From 7cc7abf41176546db8a4d9aa48d7ad149b32afcf Mon Sep 17 00:00:00 2001 From: Necried Date: Wed, 24 Feb 2021 10:40:35 -0500 Subject: [PATCH 1/2] Refactor Bool to new undo type --- src/BetterUndoList.elm | 4 +- src/Building.elm | 123 +++++++++++++++++++++-------------------- src/Exporting.elm | 25 +++++---- src/Main.elm | 43 +++++++------- src/Simulating.elm | 75 ++++++++++++------------- 5 files changed, 140 insertions(+), 130 deletions(-) diff --git a/src/BetterUndoList.elm b/src/BetterUndoList.elm index edc4c40..3ab303b 100644 --- a/src/BetterUndoList.elm +++ b/src/BetterUndoList.elm @@ -1,4 +1,4 @@ -module BetterUndoList exposing (BetterUndoList, fresh, new, redo, replace, undo) +module BetterUndoList exposing (BetterUndoList, fresh, new, redo, replace, undo, UndoAction(..)) import UndoList as U @@ -9,6 +9,8 @@ type alias BetterUndoList state = } +type UndoAction = NoUndo | UndoRequired + fresh : state -> BetterUndoList state fresh state = { present = state diff --git a/src/Building.elm b/src/Building.elm index ed7acf0..db84bee 100644 --- a/src/Building.elm +++ b/src/Building.elm @@ -1,6 +1,7 @@ module Building exposing (Model, Msg(..), PersistentModel(..), editingButtons, init, initPModel, onEnter, onExit, subscriptions, update, updateArrowPos, updateStatePos, view) import Browser.Events +import BetterUndoList exposing (UndoAction(..)) import Dict exposing (Dict) import Environment exposing (Environment) import GraphicSVG exposing (..) @@ -61,17 +62,17 @@ initPModel = Empty -onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) +onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), UndoAction, Cmd Msg ) onEnter env ( pModel, sModel ) = - ( ( init, pModel, sModel ), False, Cmd.none ) + ( ( init, pModel, sModel ), NoUndo, Cmd.none ) -onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) +onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), UndoAction ) onExit env ( model, pModel, sModel ) = - ( ( pModel, sModel ), False ) + ( ( pModel, sModel ), NoUndo ) -update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) +update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), UndoAction, Cmd Msg ) update env msg ( model, pModel, sModel ) = let oldMachine = @@ -92,42 +93,42 @@ update env msg ( model, pModel, sModel ) = in case model.machineState of MousingOverRim sId _ -> - ( ( { model | machineState = AddingArrow sId ( x, y ) }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = AddingArrow sId ( x, y ) }, pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( { model | machineState = DraggingState st ( x - sx, y - sy ) ( x, y ) }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = DraggingState st ( x - sx, y - sy ) ( x, y ) }, pModel, sModel ), NoUndo, Cmd.none ) StartDraggingArrow ( st1, char, st2 ) pos -> - ( ( { model | machineState = DraggingArrow ( st1, char, st2 ) pos }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = DraggingArrow ( st1, char, st2 ) pos }, pModel, sModel ), NoUndo, Cmd.none ) StartMouseOverRim stId ( x, y ) -> case model.machineState of Regular -> - ( ( { model | machineState = MousingOverRim stId ( x, y ) }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = MousingOverRim stId ( x, y ) }, pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) MoveMouseOverRim ( x, y ) -> case model.machineState of MousingOverRim stId _ -> - ( ( { model | machineState = MousingOverRim stId ( x, y ) }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = MousingOverRim stId ( x, y ) }, pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) StopMouseOverRim -> case model.machineState of MousingOverRim _ _ -> - ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) StopDragging -> case model.machineState of DraggingState st _ _ -> - ( ( { model | machineState = SelectedState st }, pModel, sModel ), True, Cmd.none ) + ( ( { model | machineState = SelectedState st }, pModel, sModel ), UndoRequired, Cmd.none ) AddingArrowOverOtherState st _ s1 -> let @@ -186,15 +187,15 @@ update env msg ( model, pModel, sModel ) = } } ) - , True + , UndoRequired , Cmd.none ) DraggingArrow tId _ -> - ( ( { model | machineState = Regular }, pModel, sModel ), True, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, sModel ), UndoRequired, Cmd.none ) _ -> - ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, sModel ), NoUndo, Cmd.none ) SelectArrow ( s0, tId, s1 ) -> let @@ -207,10 +208,10 @@ update env msg ( model, pModel, sModel ) = "" in if env.holdingShift then - ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), False, focusInput NoOp ) + ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), NoUndo, focusInput NoOp ) else - ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), NoUndo, Cmd.none ) Drag ( x, y ) -> case model.machineState of @@ -233,7 +234,7 @@ update env msg ( model, pModel, sModel ) = ( x - ox, y - oy ) in ( ( { model | machineState = DraggingState st ( ox, oy ) ( x, y ) }, pModel, { sModel | machine = { oldMachine | statePositions = updateStatePos st newPos oldMachine.statePositions } } ) - , False + , NoUndo , Cmd.none ) @@ -275,7 +276,7 @@ update env msg ( model, pModel, sModel ) = nprot = ( nx * cos theta - ny * sin theta, nx * sin theta + ny * cos theta ) in - ( ( { model | machineState = DraggingArrow ( s1, char, s2 ) ( x, y ) }, pModel, { sModel | machine = { oldMachine | stateTransitions = Dict.insert ( s1, char, s2 ) nprot oldMachine.stateTransitions } } ), False, Cmd.none ) + ( ( { model | machineState = DraggingArrow ( s1, char, s2 ) ( x, y ) }, pModel, { sModel | machine = { oldMachine | stateTransitions = Dict.insert ( s1, char, s2 ) nprot oldMachine.stateTransitions } } ), NoUndo, Cmd.none ) AddingArrow st _ -> let @@ -292,7 +293,7 @@ update env msg ( model, pModel, sModel ) = _ -> AddingArrow st ( x, y ) in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = newState }, pModel, sModel ), NoUndo, Cmd.none ) AddingArrowOverOtherState st _ s1 -> let @@ -309,13 +310,13 @@ update env msg ( model, pModel, sModel ) = _ -> AddingArrow st ( x, y ) in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = newState }, pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( { model | machineState = model.machineState }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = model.machineState }, pModel, sModel ), NoUndo, Cmd.none ) MouseOverStateLabel st -> - ( ( { model | machineState = MousingOverStateLabel st }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = MousingOverStateLabel st }, pModel, sModel ), NoUndo, Cmd.none ) MouseOverTransitionLabel tr -> let @@ -327,7 +328,7 @@ update env msg ( model, pModel, sModel ) = _ -> model.machineState in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = newState }, pModel, sModel ), NoUndo, Cmd.none ) MouseLeaveLabel -> let @@ -342,7 +343,7 @@ update env msg ( model, pModel, sModel ) = _ -> model.machineState in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = newState }, pModel, sModel ), NoUndo, Cmd.none ) EditLabel _ lbl -> let @@ -357,7 +358,7 @@ update env msg ( model, pModel, sModel ) = _ -> model.machineState in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = newState }, pModel, sModel ), NoUndo, Cmd.none ) TapState sId -> let @@ -370,28 +371,28 @@ update env msg ( model, pModel, sModel ) = "" in if env.holdingShift then - ( ( { model | machineState = EditingStateLabel sId oldStateName }, pModel, sModel ), False, focusInput NoOp ) + ( ( { model | machineState = EditingStateLabel sId oldStateName }, pModel, sModel ), NoUndo, focusInput NoOp ) else - ( ( { model | machineState = SelectedState sId }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = SelectedState sId }, pModel, sModel ), NoUndo, Cmd.none ) Reset -> - ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, sModel ), NoUndo, Cmd.none ) ChangeMachine mtype -> case mtype of NFA -> case sModel.machineType of NFA -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) DFA -> - ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) + ( ( model, pModel, { sModel | machineType = NFA } ), NoUndo, Cmd.none ) DFA -> case sModel.machineType of DFA -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) NFA -> let @@ -416,7 +417,7 @@ update env msg ( model, pModel, sModel ) = newSModel = { sModel | machine = { oldMachine | start = startState }, machineType = DFA } in - ( ( model, pModel, newSModel ), True, Cmd.none ) + ( ( model, pModel, newSModel ), UndoRequired, Cmd.none ) AddState ( x, y ) -> case model.machineState of @@ -433,10 +434,10 @@ update env msg ( model, pModel, sModel ) = , stateNames = Dict.insert newId ("q_{" ++ String.fromInt newId ++ "}") oldMachine.stateNames } in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) _ -> - ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, sModel ), NoUndo, Cmd.none ) KeyPressed k -> let @@ -457,10 +458,10 @@ update env msg ( model, pModel, sModel ) = "" in if newLbl == oldStateName || newLbl == "" then - ( ( { model | machineState = SelectedState sId }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = SelectedState sId }, pModel, sModel ), NoUndo, Cmd.none ) else - ( ( { model | machineState = SelectedState sId }, pModel, sModel ), True, sendMsg <| SaveStateName sId newLbl ) + ( ( { model | machineState = SelectedState sId }, pModel, sModel ), UndoRequired, sendMsg <| SaveStateName sId newLbl ) EditingTransitionLabel ( s0, tId, s1 ) newLbl -> let @@ -473,10 +474,10 @@ update env msg ( model, pModel, sModel ) = "" in if newLbl == oldTransitionName || newLbl == "" then - ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), False, Cmd.none ) + ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), NoUndo, Cmd.none ) else - ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), True, sendMsg <| SaveTransitionName tId newLbl ) + ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), UndoRequired, sendMsg <| SaveTransitionName tId newLbl ) SelectedState sId -> let @@ -488,7 +489,7 @@ update env msg ( model, pModel, sModel ) = _ -> "" in - ( ( { model | machineState = EditingStateLabel sId oldStateName }, pModel, sModel ), False, focusInput NoOp ) + ( ( { model | machineState = EditingStateLabel sId oldStateName }, pModel, sModel ), NoUndo, focusInput NoOp ) SelectedArrow ( s0, tId, s1 ) -> let @@ -500,18 +501,18 @@ update env msg ( model, pModel, sModel ) = Nothing -> "" in - ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), False, focusInput NoOp ) + ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), NoUndo, focusInput NoOp ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) else if normalizedKey == "s" then case model.machineState of SelectedState stId -> - ( ( model, pModel, sModel ), False, sendMsg (ToggleStart stId) ) + ( ( model, pModel, sModel ), NoUndo, sendMsg (ToggleStart stId) ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) else if normalizedKey == "d" then case model.machineState of @@ -545,7 +546,7 @@ update env msg ( model, pModel, sModel ) = removedTransitions = Dict.fromList removedTransitionsLst in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) SelectedArrow ( _, tId, _ ) -> let @@ -562,13 +563,13 @@ update env msg ( model, pModel, sModel ) = newStateTransitions = Dict.filter (\( _, tId0, _ ) _ -> tId /= tId0) oldMachine.stateTransitions in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) else if normalizedKey == "g" then - ( ( model, pModel, sModel ), False, sendMsg ToggleSnap ) + ( ( model, pModel, sModel ), NoUndo, sendMsg ToggleSnap ) else case model.machineState of @@ -586,7 +587,7 @@ update env msg ( model, pModel, sModel ) = Set.insert sId oldMachine.final } in - ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) + ( ( model, pModel, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) --else if normalizedKey == "s" then -- let -- newMachine = @@ -600,13 +601,13 @@ update env msg ( model, pModel, sModel ) = -- Set.insert sId oldMachine.start -- } -- in - -- ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) + -- ( ( model, pModel, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) else - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) ToggleStart sId -> let @@ -634,14 +635,14 @@ update env msg ( model, pModel, sModel ) = | start = Set.singleton sId } in - ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) + ( ( model, pModel, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) SaveStateName sId newLbl -> let newMachine = { oldMachine | stateNames = Dict.insert sId newLbl oldMachine.stateNames } in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) SaveTransitionName tId newLbl -> let @@ -656,7 +657,7 @@ update env msg ( model, pModel, sModel ) = | transitionNames = Dict.insert tId newTransitions oldMachine.transitionNames } in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) + ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) ToggleSnap -> ( ( { model @@ -670,7 +671,7 @@ update env msg ( model, pModel, sModel ) = , pModel , sModel ) - , False + , NoUndo , Cmd.none ) @@ -687,12 +688,12 @@ update env msg ( model, pModel, sModel ) = , pModel , sModel ) - , False + , NoUndo , Cmd.none ) NoOp -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) view : Environment -> ( Model, PersistentModel, SharedModel ) -> Shape Msg diff --git a/src/Exporting.elm b/src/Exporting.elm index 97d05e8..8566785 100644 --- a/src/Exporting.elm +++ b/src/Exporting.elm @@ -2,6 +2,7 @@ module Exporting exposing (InputTape, Model(..), Msg(..), Output(..), Persistent import Array exposing (Array) import Browser.Events +import BetterUndoList exposing (UndoAction(..)) import Dict exposing (Dict) import Environment exposing (Environment) import Error exposing (..) @@ -55,14 +56,14 @@ type Msg | HoverErrorExit -onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) +onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), UndoAction, Cmd Msg ) onEnter env ( pModel, sModel ) = - ( ( Default, pModel, sModel ), False, Cmd.none ) + ( ( Default, pModel, sModel ), NoUndo, Cmd.none ) -onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) +onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), UndoAction ) onExit env ( model, pModel, sModel ) = - ( ( pModel, sModel ), False ) + ( ( pModel, sModel ), NoUndo ) initPModel : PersistentModel @@ -72,7 +73,7 @@ initPModel = } -update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) +update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), UndoAction, Cmd Msg ) update env msg ( model, pModel, sModel ) = let machine = @@ -80,25 +81,25 @@ update env msg ( model, pModel, sModel ) = in case msg of SelectOutput outputType -> - ( ( model, { pModel | outputType = outputType }, sModel ), False, Cmd.none ) + ( ( model, { pModel | outputType = outputType }, sModel ), NoUndo, Cmd.none ) GenerateOutput -> - ( ( ShowingOutput, pModel, sModel ), False, Task.perform (GetTime << Time.posixToMillis) Time.now ) + ( ( ShowingOutput, pModel, sModel ), NoUndo, Task.perform (GetTime << Time.posixToMillis) Time.now ) CloseOutput -> - ( ( Default, pModel, sModel ), False, Cmd.none ) + ( ( Default, pModel, sModel ), NoUndo, Cmd.none ) MachineMsg mmsg -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) GetTime t -> - ( ( model, { pModel | time = t }, sModel ), False, Cmd.none ) + ( ( model, { pModel | time = t }, sModel ), NoUndo, Cmd.none ) HoverErrorEnter -> - ( ( HoverError, pModel, sModel ), False, Cmd.none ) + ( ( HoverError, pModel, sModel ), NoUndo, Cmd.none ) HoverErrorExit -> - ( ( Default, pModel, sModel ), False, Cmd.none ) + ( ( Default, pModel, sModel ), NoUndo, Cmd.none ) view : Environment -> ( Model, PersistentModel, SharedModel ) -> Shape Msg diff --git a/src/Main.elm b/src/Main.elm index 21f9aaf..66768f6 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -138,7 +138,7 @@ moduleUpdate : -> (mMsg -> Msg) -> (mModel -> ApplicationState) -> (pModel -> ApplicationModel -> ApplicationModel) - -> (Environment -> mMsg -> ( mModel, pModel, SharedModel ) -> ( ( mModel, pModel, SharedModel ), Bool, Cmd mMsg )) + -> (Environment -> mMsg -> ( mModel, pModel, SharedModel ) -> ( ( mModel, pModel, SharedModel ), UndoAction, Cmd mMsg )) -> ( Model, Cmd Msg ) moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel mUpdate = let @@ -160,19 +160,22 @@ moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel m in ( { model | appModel = - if checkpoint then - new newAppState model.appModel + case checkpoint of + UndoRequired -> + new newAppState model.appModel + + NoUndo -> + replace newAppState model.appModel - else - replace newAppState model.appModel , saveModel = { sm | unsavedChanges = - if checkpoint then - True + case checkpoint of + NoUndo -> + sm.unsavedChanges - else - sm.unsavedChanges + UndoRequired -> + True } } , Cmd.map msgWrapper cmd @@ -504,7 +507,7 @@ processExit : -> pModel -> Model -> (pModel -> ApplicationModel -> ApplicationModel) - -> (Environment -> ( mModel, pModel, SharedModel ) -> ( ( pModel, SharedModel ), Bool )) + -> (Environment -> ( mModel, pModel, SharedModel ) -> ( ( pModel, SharedModel ), UndoAction )) -> BetterUndoList ApplicationModel processExit env m pModel model setpModel onExit = let @@ -518,11 +521,12 @@ processExit env m pModel model setpModel onExit = { currentAppState | sharedModel = newSModel } |> setpModel newPModel in - if checkpoint then - new newAppState model.appModel + case checkpoint of + UndoRequired -> + new newAppState model.appModel - else - replace newAppState model.appModel + NoUndo -> + replace newAppState model.appModel processEnter : @@ -532,7 +536,7 @@ processEnter : -> (mMsg -> Msg) -> (mModel -> ApplicationState) -> (pModel -> ApplicationModel -> ApplicationModel) - -> (Environment -> ( pModel, SharedModel ) -> ( ( mModel, pModel, SharedModel ), Bool, Cmd mMsg )) + -> (Environment -> ( pModel, SharedModel ) -> ( ( mModel, pModel, SharedModel ), UndoAction, Cmd mMsg )) -> ( BetterUndoList ApplicationModel, Cmd Msg ) processEnter env pModel exitModel msgWrapper appStateWrapper setpModel onEnter = let @@ -546,11 +550,12 @@ processEnter env pModel exitModel msgWrapper appStateWrapper setpModel onEnter = { exitAppState | appState = appStateWrapper newM, sharedModel = newSModel } |> setpModel newPModel in - ( if checkpoint then - new newAppState exitModel + ( case checkpoint of + UndoRequired -> + new newAppState exitModel - else - replace newAppState exitModel + NoUndo -> + replace newAppState exitModel , Cmd.map msgWrapper mCmd ) diff --git a/src/Simulating.elm b/src/Simulating.elm index f7933f9..52c242c 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -2,6 +2,7 @@ module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), Persisten import Array exposing (Array) import Browser.Events +import BetterUndoList exposing (UndoAction(..)) import Debug import Dict exposing (Dict) import Environment exposing (Environment) @@ -78,7 +79,7 @@ type Msg | HoverErrorExit -onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) +onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), UndoAction, Cmd Msg ) onEnter env ( pModel, sModel ) = ( ( Default 0 -1 Nothing , { pModel @@ -91,14 +92,14 @@ onEnter env ( pModel, sModel ) = } , sModel ) - , False + , NoUndo , Cmd.none ) -onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) +onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), UndoAction ) onExit env ( model, pModel, sModel ) = - ( ( pModel, sModel ), False ) + ( ( pModel, sModel ), NoUndo ) initPModel : PersistentModel @@ -273,7 +274,7 @@ renderTape model input tapeSt tapeId selectedId inputAt showButtons = ) -update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) +update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), UndoAction, Cmd Msg ) update env msg ( model, pModel, sModel ) = let oldMachine = @@ -312,18 +313,18 @@ update env msg ( model, pModel, sModel ) = } , sModel ) - , False + , NoUndo , Cmd.none ) else - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) EditTape tId -> - ( ( Editing tId, pModel, sModel ), False, Cmd.none ) + ( ( Editing tId, pModel, sModel ), NoUndo, Cmd.none ) DeleteTape tId -> let @@ -340,7 +341,7 @@ update env msg ( model, pModel, sModel ) = _ -> model in - ( ( newModel, { pModel | tapes = Dict.remove tId pModel.tapes }, sModel ), True, Cmd.none ) + ( ( newModel, { pModel | tapes = Dict.remove tId pModel.tapes }, sModel ), UndoRequired, Cmd.none ) AddNewTape -> let @@ -354,10 +355,10 @@ update env msg ( model, pModel, sModel ) = ) + 1 in - ( ( model, { pModel | tapes = Dict.insert newId ( Array.empty, Fresh ) pModel.tapes }, sModel ), True, Cmd.none ) + ( ( model, { pModel | tapes = Dict.insert newId ( Array.empty, Fresh ) pModel.tapes }, sModel ), UndoRequired, Cmd.none ) ChangeTape tId -> - ( ( Default tId -1 Nothing {- ??? -}, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta oldMachine.start }, sModel ), False, Cmd.none ) + ( ( Default tId -1 Nothing {- ??? -}, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta oldMachine.start }, sModel ), NoUndo, Cmd.none ) KeyPressed k -> let @@ -367,10 +368,10 @@ update env msg ( model, pModel, sModel ) = if normalizedKey == "enter" then case model of Editing tId -> - ( ( Default tId -1 Nothing, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta oldMachine.start }, sModel ), True, Cmd.none ) + ( ( Default tId -1 Nothing, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta oldMachine.start }, sModel ), UndoRequired, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) else if normalizedKey == "backspace" || normalizedKey == "arrowleft" then case model of @@ -398,26 +399,26 @@ update env msg ( model, pModel, sModel ) = pModel.tapes } in - ( ( model, newPModel, sModel ), False, Cmd.none ) + ( ( model, newPModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) else if normalizedKey == "arrowright" then case model of Default _ _ _ -> - ( ( model, pModel, sModel ), False, Task.perform identity (Task.succeed <| Step) ) + ( ( model, pModel, sModel ), NoUndo, Task.perform identity (Task.succeed <| Step) ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) else if normalizedKey == "arrowleft" then case model of Default tId _ hErr -> - ( ( Default tId -1 hErr, { pModel | currentStates = sModel.machine.start }, sModel ), False, Cmd.none ) + ( ( Default tId -1 hErr, { pModel | currentStates = sModel.machine.start }, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) else case model of @@ -530,30 +531,30 @@ update env msg ( model, pModel, sModel ) = pModel.tapes } in - ( ( model, newPModel, sModel ), False, Cmd.none ) + ( ( model, newPModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) ChangeMachine mtype -> case mtype of NFA -> case sModel.machineType of NFA -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) DFA -> case model of Editing tId -> - ( ( Default tId -1 Nothing, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) + ( ( Default tId -1 Nothing, pModel, { sModel | machineType = NFA } ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) + ( ( model, pModel, { sModel | machineType = NFA } ), NoUndo, Cmd.none ) DFA -> case sModel.machineType of DFA -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) NFA -> let @@ -583,21 +584,21 @@ update env msg ( model, pModel, sModel ) = in case model of Editing tId -> - ( ( Default tId -1 Nothing, newPModel, newSModel ), True, Cmd.none ) + ( ( Default tId -1 Nothing, newPModel, newSModel ), UndoRequired, Cmd.none ) _ -> - ( ( model, newPModel, newSModel ), True, Cmd.none ) + ( ( model, newPModel, newSModel ), UndoRequired, Cmd.none ) MachineMsg mmsg -> case mmsg of StartDragging sId _ -> - ( ( model, pModel, sModel ), False, sendMsg (ToggleStart sId) ) + ( ( model, pModel, sModel ), NoUndo, sendMsg (ToggleStart sId) ) TapState sId -> - ( ( model, pModel, sModel ), False, sendMsg (ToggleStart sId) ) + ( ( model, pModel, sModel ), NoUndo, sendMsg (ToggleStart sId) ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) ToggleStart sId -> let @@ -624,26 +625,26 @@ update env msg ( model, pModel, sModel ) = in case model of Default tId _ _ -> - ( ( Default tId -1 Nothing, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta newMachine.start }, { sModel | machine = newMachine } ), True, Cmd.none ) + ( ( Default tId -1 Nothing, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta newMachine.start }, { sModel | machine = newMachine } ), UndoRequired, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) HoverErrorEnter tapeId -> case model of Default tId pos _ -> - ( ( Default tId pos (Just tapeId), pModel, sModel ), False, Cmd.none ) + ( ( Default tId pos (Just tapeId), pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) HoverErrorExit -> case model of Default tId pos _ -> - ( ( Default tId pos Nothing, pModel, sModel ), False, Cmd.none ) + ( ( Default tId pos Nothing, pModel, sModel ), NoUndo, Cmd.none ) _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) + ( ( model, pModel, sModel ), NoUndo, Cmd.none ) isAccept : Set StateID -> Set StateID -> InputTape -> Int -> Bool From 6a1e61d90ab054bd04ffe83c4c0bf23c08823b68 Mon Sep 17 00:00:00 2001 From: Necried Date: Wed, 24 Feb 2021 10:43:24 -0500 Subject: [PATCH 2/2] elm-format --- src/BetterUndoList.elm | 7 +++++-- src/Building.elm | 2 +- src/Exporting.elm | 2 +- src/Main.elm | 9 ++++----- src/Simulating.elm | 2 +- 5 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/BetterUndoList.elm b/src/BetterUndoList.elm index 3ab303b..ef8a547 100644 --- a/src/BetterUndoList.elm +++ b/src/BetterUndoList.elm @@ -1,4 +1,4 @@ -module BetterUndoList exposing (BetterUndoList, fresh, new, redo, replace, undo, UndoAction(..)) +module BetterUndoList exposing (BetterUndoList, UndoAction(..), fresh, new, redo, replace, undo) import UndoList as U @@ -9,7 +9,10 @@ type alias BetterUndoList state = } -type UndoAction = NoUndo | UndoRequired +type UndoAction + = NoUndo + | UndoRequired + fresh : state -> BetterUndoList state fresh state = diff --git a/src/Building.elm b/src/Building.elm index db84bee..6a13ad5 100644 --- a/src/Building.elm +++ b/src/Building.elm @@ -1,7 +1,7 @@ module Building exposing (Model, Msg(..), PersistentModel(..), editingButtons, init, initPModel, onEnter, onExit, subscriptions, update, updateArrowPos, updateStatePos, view) -import Browser.Events import BetterUndoList exposing (UndoAction(..)) +import Browser.Events import Dict exposing (Dict) import Environment exposing (Environment) import GraphicSVG exposing (..) diff --git a/src/Exporting.elm b/src/Exporting.elm index 8566785..0e781fc 100644 --- a/src/Exporting.elm +++ b/src/Exporting.elm @@ -1,8 +1,8 @@ module Exporting exposing (InputTape, Model(..), Msg(..), Output(..), PersistentModel, exportButton, exportTikz, generateTikz, indtBy, initPModel, onEnter, onExit, output, subscriptions, unlines, update, view) import Array exposing (Array) -import Browser.Events import BetterUndoList exposing (UndoAction(..)) +import Browser.Events import Dict exposing (Dict) import Environment exposing (Environment) import Error exposing (..) diff --git a/src/Main.elm b/src/Main.elm index 66768f6..45a7659 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -166,7 +166,6 @@ moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel m NoUndo -> replace newAppState model.appModel - , saveModel = { sm | unsavedChanges = @@ -551,11 +550,11 @@ processEnter env pModel exitModel msgWrapper appStateWrapper setpModel onEnter = |> setpModel newPModel in ( case checkpoint of - UndoRequired -> - new newAppState exitModel + UndoRequired -> + new newAppState exitModel - NoUndo -> - replace newAppState exitModel + NoUndo -> + replace newAppState exitModel , Cmd.map msgWrapper mCmd ) diff --git a/src/Simulating.elm b/src/Simulating.elm index 52c242c..bd5874e 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -1,8 +1,8 @@ module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, checkTapesNoStatus, delta, deltaHat, epsTrans, initPModel, inputTapeDecoder, inputTapeDictDecoder, inputTapeEncoder, isAccept, latexKeyboard, machineDefn, onEnter, onExit, renderTape, subscriptions, update, view) import Array exposing (Array) -import Browser.Events import BetterUndoList exposing (UndoAction(..)) +import Browser.Events import Debug import Dict exposing (Dict) import Environment exposing (Environment)