From 18d6bc2359c49ccae781dde0bf20130b3f397487 Mon Sep 17 00:00:00 2001 From: Necried Date: Sat, 9 Nov 2019 11:24:21 -0500 Subject: [PATCH 01/27] Update dependencies and version to elm-0.19.1 --- elm.json | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/elm.json b/elm.json index da56120..f7820e3 100644 --- a/elm.json +++ b/elm.json @@ -3,11 +3,11 @@ "source-directories": [ "src" ], - "elm-version": "0.19.0", + "elm-version": "0.19.1", "dependencies": { "direct": { "MacCASOutreach/graphicsvg": "5.1.0", - "billstclair/elm-sha256": "1.0.8", + "billstclair/elm-sha256": "1.0.9", "elm/browser": "1.0.1", "elm/core": "1.0.2", "elm/html": "1.0.0", @@ -31,4 +31,4 @@ }, "indirect": {} } -} \ No newline at end of file +} From 5837c71e6a180deb607f568edc0baa2b9ab8e890 Mon Sep 17 00:00:00 2001 From: Necried Date: Sat, 9 Nov 2019 14:08:17 -0500 Subject: [PATCH 02/27] Made TransitionMistakes stateless, nothing broken so far. --- src/Building.elm | 68 +++----------------------------- src/Error.elm | 8 ++-- src/Exporting.elm | 7 +++- src/Machine.elm | 73 ++++++++++------------------------ src/Mistakes.elm | 98 ++++++++++++++++++++++++++++++++++++++++++++++ src/Simulating.elm | 7 +++- 6 files changed, 138 insertions(+), 123 deletions(-) create mode 100644 src/Mistakes.elm diff --git a/src/Building.elm b/src/Building.elm index 9cc9995..8e095cc 100644 --- a/src/Building.elm +++ b/src/Building.elm @@ -12,7 +12,8 @@ import Set import SharedModel exposing (SharedModel) import Task import Tuple exposing (first, second) - +import Mistakes exposing (..) +import Debug exposing (todo) type alias Model = { machineState : Machine.Model @@ -148,34 +149,6 @@ update env msg ( model, pModel, sModel ) = isValidTransition = checkTransitionValid newTrans - oldTransitionMistakes = - oldMachine.transitionMistakes - - newTransitionMistakes = - if isValidTransition then - case oldTransitionMistakes of - Just setOfMistakes -> - let - newSetOfMistakes = - Set.remove newTransID setOfMistakes - in - if Set.isEmpty newSetOfMistakes then - Nothing - - else - Just newSetOfMistakes - - Nothing -> - Nothing - - else - case oldTransitionMistakes of - Just setOfMistakes -> - Just <| Set.insert newTransID setOfMistakes - - Nothing -> - Just <| Set.singleton newTransID - newDelta : Delta newDelta = Dict.update st @@ -209,7 +182,6 @@ update env msg ( model, pModel, sModel ) = | delta = newDelta , transitionNames = Dict.insert newTransID newTrans oldMachine.transitionNames , stateTransitions = Dict.insert ( st, newTransID, s1 ) newTransPos oldMachine.stateTransitions - , transitionMistakes = newTransitionMistakes } } ) @@ -485,14 +457,11 @@ update env msg ( model, pModel, sModel ) = , stateTransitions = newStateTransitions , stateNames = Dict.remove stId oldMachine.stateNames , transitionNames = Dict.diff oldMachine.transitionNames removedTransitions - , transitionMistakes = newTMistakes } newStateTransitions = Dict.filter (\( _, t, _ ) _ -> not <| Dict.member t removedTransitions) oldMachine.stateTransitions - newTMistakes = - List.foldr (\tId mistakes -> tMistakeRemove (first tId) mistakes) oldMachine.transitionMistakes removedTransitionsLst removedTransitionsLst = List.map (\( _, t, _ ) -> ( t, () )) <| Dict.keys <| Dict.filter (\( s0, _, s1 ) _ -> s0 == stId || s1 == stId) oldMachine.stateTransitions @@ -512,14 +481,11 @@ update env msg ( model, pModel, sModel ) = | delta = newDelta , stateTransitions = newStateTransitions , transitionNames = Dict.remove tId oldMachine.transitionNames - , transitionMistakes = newTMistakes } newStateTransitions = Dict.filter (\( _, tId0, _ ) _ -> tId /= tId0) oldMachine.stateTransitions - newTMistakes = - tMistakeRemove tId oldMachine.transitionMistakes in ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) @@ -568,20 +534,9 @@ update env msg ( model, pModel, sModel ) = isValidTransition = checkTransitionValid newTransitions - oldTransitionMistakes = - oldMachine.transitionMistakes - - newTransitionMistakes = - if isValidTransition then - tMistakeRemove tId oldTransitionMistakes - - else - tMistakeAdd tId oldTransitionMistakes - newMachine = { oldMachine | transitionNames = Dict.insert tId newTransitions oldMachine.transitionNames - , transitionMistakes = newTransitionMistakes } in ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) @@ -631,6 +586,9 @@ view env ( model, pModel, sModel ) = winY = toFloat <| second env.windowSize + + transMistakes = + getTransitionMistakes sModel.machine in group [ rect winX winY @@ -665,7 +623,7 @@ view env ( model, pModel, sModel ) = _ -> group [] - , GraphicSVG.map MachineMsg <| Machine.view env model.machineState sModel.machine Set.empty + , GraphicSVG.map MachineMsg <| Machine.view env model.machineState sModel.machine Set.empty transMistakes , editingButtons model |> move ( winX / 2 - 30, -winY / 2 + 25 ) ] @@ -762,17 +720,3 @@ snapIcon = ] |> move ( 5, -10 ) ] - - -checkTransitionValid : Set.Set String -> Bool -checkTransitionValid set = - case Set.member "\\epsilon" set of - False -> - True - - True -> - if Set.size set == 1 then - True - - else - False diff --git a/src/Error.elm b/src/Error.elm index dbd2a4d..ed70239 100644 --- a/src/Error.elm +++ b/src/Error.elm @@ -12,7 +12,7 @@ import Machine exposing (Machine, StateID, TransitionID) import Set exposing (Set) import SharedModel exposing (..) import Tuple exposing (first, second) - +import Mistakes exposing (..) type Error = NoError @@ -56,9 +56,9 @@ machineCheck sModel = mac = sModel.machine - tMistakes = - sModel.machine.transitionMistakes - + + tMistakes = getTransitionMistakes mac + allTransitionLabels = List.sort <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values mac.transitionNames diff --git a/src/Exporting.elm b/src/Exporting.elm index ba7112a..831713d 100644 --- a/src/Exporting.elm +++ b/src/Exporting.elm @@ -17,7 +17,7 @@ import SharedModel exposing (..) import Task import Time exposing (Month(..), customZone, millisToPosix, toDay, toHour, toMinute, toMonth, toSecond, toYear) import Tuple exposing (first, second) - +import Mistakes exposing (..) subscriptions : Model -> Sub Msg subscriptions model = @@ -122,6 +122,9 @@ view env ( model, pModel, sModel ) = hasErr = contextHasError errCheck sModel.machineType + transMistakes = + getTransitionMistakes oldMachine + -- TODO: Adjust popup box size to fix custom error messages errHover = group @@ -137,7 +140,7 @@ view env ( model, pModel, sModel ) = |> move ( winX / 6 - 100, -105 ) in group - [ (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine sModel.machine.start) |> move ( -winX / 6, 0 ) + [ (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine sModel.machine.start transMistakes) |> move ( -winX / 6, 0 ) , machineSelected sModel.machineType winX winY , text "Choose format:" |> size 20 diff --git a/src/Machine.elm b/src/Machine.elm index b02901f..f8d66a7 100644 --- a/src/Machine.elm +++ b/src/Machine.elm @@ -1,4 +1,4 @@ -module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID, TransitionMistakes, TransitionNames, arrow, renderArrow, renderArrows, renderStates, tMistakeAdd, tMistakeRemove, test, textBox, view) +module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID,TransitionNames, TransitionMistakes, arrow, renderArrow, renderArrows, renderStates, test, textBox, view) import Dict exposing (Dict) import Environment exposing (Environment) @@ -9,7 +9,6 @@ import Html.Attributes exposing (attribute, id, placeholder, style, value) import Html.Events exposing (onInput) import Set exposing (Set) - type alias StateID = Int @@ -55,7 +54,6 @@ type alias Machine = , stateTransitions : StateTransitions , stateNames : StateNames , transitionNames : TransitionNames - , transitionMistakes : TransitionMistakes } @@ -133,14 +131,12 @@ test = , ( ( 3, 7, 1 ), ( 0, 10 ) ) ] - transitionMistakes = - Nothing in - Machine q delta0 start final statePositions stateTransitions stateNames transitionNames transitionMistakes + Machine q delta0 start final statePositions stateTransitions stateNames transitionNames -view : Environment -> Model -> Machine -> Set StateID -> Shape Msg -view env model machine currentStates = +view : Environment -> Model -> Machine -> Set StateID -> TransitionMistakes -> Shape Msg +view env model machine currentStates tMistakes = let ( winX, winY ) = env.windowSize @@ -152,7 +148,7 @@ view env model machine currentStates = |> notifyMouseUp StopDragging in group - [ renderArrows machine model + [ renderArrows machine model tMistakes , renderStates currentStates machine model env , case model of AddingArrow s ( x, y ) -> @@ -245,36 +241,6 @@ view env model machine currentStates = group [] ] - -tMistakeRemove : TransitionID -> TransitionMistakes -> TransitionMistakes -tMistakeRemove tId tMistake = - case tMistake of - Just setOfMistakes -> - let - newSetOfMistakes = - Set.remove tId setOfMistakes - in - if Set.isEmpty newSetOfMistakes then - Nothing - - else - Just newSetOfMistakes - - Nothing -> - Nothing - - -tMistakeAdd : TransitionID -> TransitionMistakes -> TransitionMistakes -tMistakeAdd tId tMistake = - case tMistake of - Nothing -> - Just <| Set.singleton tId - - Just setOfMistakes -> - Just <| Set.insert tId setOfMistakes - - - --These two functions will eventually become part of GraphicSVG in some form @@ -514,8 +480,8 @@ renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) r0 r1 char charID sel mistake s1 s2 ] -renderArrows : Machine -> Model -> Shape Msg -renderArrows machine model = +renderArrows : Machine -> Model -> TransitionMistakes -> Shape Msg +renderArrows machine model tMistakes = let states = machine.q @@ -529,9 +495,6 @@ renderArrows machine model = transPos = machine.stateTransitions - transMistakes = - machine.transitionMistakes - stateList = Set.toList states @@ -561,13 +524,6 @@ renderArrows machine model = Nothing -> ( 0, 0 ) - getTransMistake tId = - case transMistakes of - Nothing -> - False - - Just setOfMistakes -> - Set.member tId setOfMistakes in group <| List.map @@ -607,8 +563,19 @@ renderArrows machine model = _ -> False - mistake = - getTransMistake chId + -- Transition mistake function + getTransMistake : TransitionMistakes -> TransitionID -> Bool + getTransMistake transMistakes tId = + case transMistakes of + Nothing -> + False + + Just setOfMistakes -> + Set.member tId setOfMistakes + + + mistake = getTransMistake tMistakes chId + in group [ renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) 20 20 ch chId sel mistake s1 s2 model diff --git a/src/Mistakes.elm b/src/Mistakes.elm new file mode 100644 index 0000000..5652457 --- /dev/null +++ b/src/Mistakes.elm @@ -0,0 +1,98 @@ +module Mistakes exposing (..) + +import Machine exposing (..) +import Set exposing (..) +import Dict exposing (..) + +getTransitionMistakes : Machine -> TransitionMistakes +getTransitionMistakes mac = + let + tNames = mac.transitionNames + in + checkEpsilonTransLabel tNames + + +tMistakeRemove : TransitionID -> TransitionMistakes -> TransitionMistakes +tMistakeRemove tId tMistake = + case tMistake of + Just setOfMistakes -> + let + newSetOfMistakes = + Set.remove tId setOfMistakes + in + if Set.isEmpty newSetOfMistakes then + Nothing + + else + Just newSetOfMistakes + + Nothing -> + Nothing + + +tMistakeAdd : TransitionID -> TransitionMistakes -> TransitionMistakes +tMistakeAdd tId tMistake = + case tMistake of + Nothing -> + Just <| Set.singleton tId + + Just setOfMistakes -> + Just <| Set.insert tId setOfMistakes + +{- +newTransitionMistakes = + if isValidTransition then + case oldTransitionMistakes of + Just setOfMistakes -> + let + newSetOfMistakes = + Set.remove newTransID setOfMistakes + in + if Set.isEmpty newSetOfMistakes then + Nothing + + else + Just newSetOfMistakes + + Nothing -> + Nothing + + else + case oldTransitionMistakes of + Just setOfMistakes -> + Just <| Set.insert newTransID setOfMistakes + + Nothing -> + Just <| Set.singleton newTransID +-} + +-- Check if an epsilon label is well-typed +checkEpsilonTransLabel : TransitionNames -> TransitionMistakes +checkEpsilonTransLabel tNames = + let + tMistakes = + Dict.foldl + (\tid tnames tmistakes -> if not (checkTransitionValid tnames) + then Set.insert tid tmistakes + else tmistakes) + Set.empty tNames + in + if Set.isEmpty tMistakes + then Nothing + else + Just tMistakes + +checkTransitionValid : Set.Set String -> Bool +checkTransitionValid set = + case Set.member "\\epsilon" set of + False -> + True + + True -> + if Set.size set == 1 then + True + + else + False + + diff --git a/src/Simulating.elm b/src/Simulating.elm index e087b36..38f5eb3 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -14,7 +14,7 @@ import Set exposing (Set) import SharedModel exposing (..) import Task import Tuple exposing (first, second) - +import Mistakes exposing (..) subscriptions : Model -> Sub Msg subscriptions model = @@ -639,6 +639,9 @@ view env ( model, pModel, sModel ) = winY = toFloat <| second env.windowSize + transMistakes = + getTransitionMistakes sModel.machine + chars = -- This is broken? Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values oldMachine.transitionNames @@ -726,7 +729,7 @@ view env ( model, pModel, sModel ) = |> move ( -10 * toFloat (Array.length tape), winY / 6 - 65 ) ] |> move ( 0, -winY / 3 ) - , (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine pModel.currentStates) |> move ( 0, winY / 6 ) + , (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine pModel.currentStates transMistakes) |> move ( 0, winY / 6 ) , machineModeButtons sModel.machineType winX winY ] From a3403ba071a05dbb17f62803caf4752e1b6ab2c9 Mon Sep 17 00:00:00 2001 From: Necried Date: Sat, 9 Nov 2019 14:11:59 -0500 Subject: [PATCH 03/27] Elm format and cleanup Mistakes.elm --- src/Building.elm | 8 ++-- src/Error.elm | 9 +++-- src/Exporting.elm | 5 ++- src/Machine.elm | 16 ++++---- src/Mistakes.elm | 92 ++++++++++++---------------------------------- src/Simulating.elm | 5 ++- 6 files changed, 46 insertions(+), 89 deletions(-) diff --git a/src/Building.elm b/src/Building.elm index 8e095cc..1f60545 100644 --- a/src/Building.elm +++ b/src/Building.elm @@ -1,19 +1,19 @@ module Building exposing (Model, Msg(..), PersistentModel(..), editingButtons, init, initPModel, onEnter, onExit, subscriptions, update, updateArrowPos, updateStatePos, view) import Browser.Events -import Debug +import Debug exposing (todo) import Dict exposing (Dict) import Environment exposing (Environment) import GraphicSVG exposing (..) import Helpers exposing (..) import Json.Decode as D import Machine exposing (..) +import Mistakes exposing (..) import Set import SharedModel exposing (SharedModel) import Task import Tuple exposing (first, second) -import Mistakes exposing (..) -import Debug exposing (todo) + type alias Model = { machineState : Machine.Model @@ -462,7 +462,6 @@ update env msg ( model, pModel, sModel ) = newStateTransitions = Dict.filter (\( _, t, _ ) _ -> not <| Dict.member t removedTransitions) oldMachine.stateTransitions - removedTransitionsLst = List.map (\( _, t, _ ) -> ( t, () )) <| Dict.keys <| Dict.filter (\( s0, _, s1 ) _ -> s0 == stId || s1 == stId) oldMachine.stateTransitions @@ -485,7 +484,6 @@ 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 ) diff --git a/src/Error.elm b/src/Error.elm index ed70239..f242cb0 100644 --- a/src/Error.elm +++ b/src/Error.elm @@ -9,10 +9,11 @@ import Environment exposing (Environment) import GraphicSVG exposing (..) import Helpers exposing (..) import Machine exposing (Machine, StateID, TransitionID) +import Mistakes exposing (..) import Set exposing (Set) import SharedModel exposing (..) import Tuple exposing (first, second) -import Mistakes exposing (..) + type Error = NoError @@ -56,9 +57,9 @@ machineCheck sModel = mac = sModel.machine - - tMistakes = getTransitionMistakes mac - + tMistakes = + getTransitionMistakes mac + allTransitionLabels = List.sort <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values mac.transitionNames diff --git a/src/Exporting.elm b/src/Exporting.elm index 831713d..5db0843 100644 --- a/src/Exporting.elm +++ b/src/Exporting.elm @@ -11,13 +11,14 @@ import Html as H import Html.Attributes as A import Json.Decode as D import Machine exposing (..) +import Mistakes exposing (..) import Set exposing (Set) import Sha256 exposing (sha256) import SharedModel exposing (..) import Task import Time exposing (Month(..), customZone, millisToPosix, toDay, toHour, toMinute, toMonth, toSecond, toYear) import Tuple exposing (first, second) -import Mistakes exposing (..) + subscriptions : Model -> Sub Msg subscriptions model = @@ -124,7 +125,7 @@ view env ( model, pModel, sModel ) = transMistakes = getTransitionMistakes oldMachine - + -- TODO: Adjust popup box size to fix custom error messages errHover = group diff --git a/src/Machine.elm b/src/Machine.elm index f8d66a7..f44bbfa 100644 --- a/src/Machine.elm +++ b/src/Machine.elm @@ -1,4 +1,4 @@ -module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID,TransitionNames, TransitionMistakes, arrow, renderArrow, renderArrows, renderStates, test, textBox, view) +module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID, TransitionMistakes, TransitionNames, arrow, renderArrow, renderArrows, renderStates, test, textBox, view) import Dict exposing (Dict) import Environment exposing (Environment) @@ -9,6 +9,7 @@ import Html.Attributes exposing (attribute, id, placeholder, style, value) import Html.Events exposing (onInput) import Set exposing (Set) + type alias StateID = Int @@ -130,7 +131,6 @@ test = , ( ( 1, 3, 3 ), ( 0, 10 ) ) , ( ( 3, 7, 1 ), ( 0, 10 ) ) ] - in Machine q delta0 start final statePositions stateTransitions stateNames transitionNames @@ -241,6 +241,8 @@ view env model machine currentStates tMistakes = group [] ] + + --These two functions will eventually become part of GraphicSVG in some form @@ -523,7 +525,6 @@ renderArrows machine model tMistakes = Nothing -> ( 0, 0 ) - in group <| List.map @@ -563,19 +564,18 @@ renderArrows machine model tMistakes = _ -> False - -- Transition mistake function + -- Transition mistake function getTransMistake : TransitionMistakes -> TransitionID -> Bool getTransMistake transMistakes tId = case transMistakes of Nothing -> False - + Just setOfMistakes -> Set.member tId setOfMistakes - - - mistake = getTransMistake tMistakes chId + mistake = + getTransMistake tMistakes chId in group [ renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) 20 20 ch chId sel mistake s1 s2 model diff --git a/src/Mistakes.elm b/src/Mistakes.elm index 5652457..1e64268 100644 --- a/src/Mistakes.elm +++ b/src/Mistakes.elm @@ -1,87 +1,45 @@ -module Mistakes exposing (..) +module Mistakes exposing (checkEpsilonTransLabel, checkTransitionValid, getTransitionMistakes) -import Machine exposing (..) -import Set exposing (..) import Dict exposing (..) +import Machine exposing (..) +import Set exposing (..) + getTransitionMistakes : Machine -> TransitionMistakes getTransitionMistakes mac = let - tNames = mac.transitionNames + tNames = + mac.transitionNames in - checkEpsilonTransLabel tNames - - -tMistakeRemove : TransitionID -> TransitionMistakes -> TransitionMistakes -tMistakeRemove tId tMistake = - case tMistake of - Just setOfMistakes -> - let - newSetOfMistakes = - Set.remove tId setOfMistakes - in - if Set.isEmpty newSetOfMistakes then - Nothing + checkEpsilonTransLabel tNames - else - Just newSetOfMistakes - - Nothing -> - Nothing -tMistakeAdd : TransitionID -> TransitionMistakes -> TransitionMistakes -tMistakeAdd tId tMistake = - case tMistake of - Nothing -> - Just <| Set.singleton tId +-- Check if an epsilon label is well-typed - Just setOfMistakes -> - Just <| Set.insert tId setOfMistakes -{- -newTransitionMistakes = - if isValidTransition then - case oldTransitionMistakes of - Just setOfMistakes -> - let - newSetOfMistakes = - Set.remove newTransID setOfMistakes - in - if Set.isEmpty newSetOfMistakes then - Nothing - - else - Just newSetOfMistakes - - Nothing -> - Nothing - - else - case oldTransitionMistakes of - Just setOfMistakes -> - Just <| Set.insert newTransID setOfMistakes - - Nothing -> - Just <| Set.singleton newTransID --} - --- Check if an epsilon label is well-typed checkEpsilonTransLabel : TransitionNames -> TransitionMistakes checkEpsilonTransLabel tNames = let tMistakes = Dict.foldl - (\tid tnames tmistakes -> if not (checkTransitionValid tnames) - then Set.insert tid tmistakes - else tmistakes) - Set.empty tNames + (\tid tnames tmistakes -> + if not (checkTransitionValid tnames) then + Set.insert tid tmistakes + + else + tmistakes + ) + Set.empty + tNames in - if Set.isEmpty tMistakes - then Nothing - else - Just tMistakes - + if Set.isEmpty tMistakes then + Nothing + + else + Just tMistakes + + checkTransitionValid : Set.Set String -> Bool checkTransitionValid set = case Set.member "\\epsilon" set of @@ -94,5 +52,3 @@ checkTransitionValid set = else False - - diff --git a/src/Simulating.elm b/src/Simulating.elm index 38f5eb3..a29bbd1 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -10,11 +10,12 @@ import GraphicSVG exposing (..) import Helpers exposing (..) import Json.Decode as D import Machine exposing (..) +import Mistakes exposing (..) import Set exposing (Set) import SharedModel exposing (..) import Task import Tuple exposing (first, second) -import Mistakes exposing (..) + subscriptions : Model -> Sub Msg subscriptions model = @@ -641,7 +642,7 @@ view env ( model, pModel, sModel ) = transMistakes = getTransitionMistakes sModel.machine - + chars = -- This is broken? Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values oldMachine.transitionNames From 522eb71814fb2676aa906cb94d54121cea33fac9 Mon Sep 17 00:00:00 2001 From: Necried Date: Sat, 9 Nov 2019 14:13:23 -0500 Subject: [PATCH 04/27] Remove todo import --- src/Building.elm | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Building.elm b/src/Building.elm index 1f60545..4475c47 100644 --- a/src/Building.elm +++ b/src/Building.elm @@ -1,7 +1,6 @@ module Building exposing (Model, Msg(..), PersistentModel(..), editingButtons, init, initPModel, onEnter, onExit, subscriptions, update, updateArrowPos, updateStatePos, view) import Browser.Events -import Debug exposing (todo) import Dict exposing (Dict) import Environment exposing (Environment) import GraphicSVG exposing (..) From 8f4c01364e669a35a9653d3c4cf9a619e949001e Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 18:31:05 -0500 Subject: [PATCH 05/27] encoding and decoding, v1 --- src/Machine.elm | 151 +++++++++++++++++++++++++++++++++++++++++++++- tests/Example.elm | 10 ++- 2 files changed, 157 insertions(+), 4 deletions(-) diff --git a/src/Machine.elm b/src/Machine.elm index f44bbfa..deeab39 100644 --- a/src/Machine.elm +++ b/src/Machine.elm @@ -1,4 +1,4 @@ -module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID, TransitionMistakes, TransitionNames, arrow, renderArrow, renderArrows, renderStates, test, textBox, view) +module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID, TransitionMistakes, TransitionNames, arrow, machineDecoderV1, machineEncoderV1, renderArrow, renderArrows, renderStates, test, textBox, view) import Dict exposing (Dict) import Environment exposing (Environment) @@ -7,6 +7,8 @@ import Helpers exposing (..) import Html as H exposing (Html, input, node) import Html.Attributes exposing (attribute, id, placeholder, style, value) import Html.Events exposing (onInput) +import Json.Decode as D +import Json.Encode as E import Set exposing (Set) @@ -46,6 +48,153 @@ type alias TransitionMistakes = Maybe (Set TransitionID) +decodeDict : D.Decoder comparable -> D.Decoder value -> D.Decoder (Dict comparable value) +decodeDict decComp decValu = + D.map Dict.fromList <| D.list <| D.map2 Tuple.pair (D.field "k" decComp) (D.field "v" decValu) + + +decodeSet : D.Decoder comparable -> D.Decoder (Set comparable) +decodeSet decComp = + D.map Set.fromList <| D.list decComp + + +decodePair : D.Decoder x -> D.Decoder y -> D.Decoder ( x, y ) +decodePair decX decY = + D.map2 Tuple.pair (D.field "f" decX) (D.field "s" decY) + + +decodeTriple : D.Decoder x -> D.Decoder y -> D.Decoder z -> D.Decoder ( x, y, z ) +decodeTriple decX decY decZ = + D.map3 (\x y z -> ( x, y, z )) (D.field "f" decX) (D.field "s" decY) (D.field "t" decZ) + + +encodeSet : (comparable -> E.Value) -> Set comparable -> E.Value +encodeSet valFn = + E.list valFn << Set.toList + + +encodeDict : (comparable -> E.Value) -> (value -> E.Value) -> Dict comparable value -> E.Value +encodeDict compFn valFn dict = + E.list + (\( k, v ) -> + E.object + [ ( "k", compFn k ) + , ( "v", valFn v ) + ] + ) + <| + Dict.toList dict + + +encodePair : (a -> E.Value) -> (b -> E.Value) -> ( a, b ) -> E.Value +encodePair encA encB ( a, b ) = + E.object [ ( "f", encA a ), ( "s", encB b ) ] + + +encodeTriple : (a -> E.Value) -> (b -> E.Value) -> (c -> E.Value) -> ( a, b, c ) -> E.Value +encodeTriple encA encB encC ( a, b, c ) = + E.object [ ( "f", encA a ), ( "s", encB b ), ( "t", encC c ) ] + + +machineEncoderV1 : Machine -> E.Value +machineEncoderV1 machine = + let + transTriple = + decodeTriple D.int D.int D.int + + qEncoder : Set StateID -> E.Value + qEncoder = + encodeSet E.int + + deltaEncoder : Delta -> E.Value + deltaEncoder = + encodeDict E.int (encodeDict E.int E.int) + + startEncoder : Set StateID -> E.Value + startEncoder = + encodeSet E.int + + finalEncoder : Set StateID -> E.Value + finalEncoder = + encodeSet E.int + + statePosEncoder : StatePositions -> E.Value + statePosEncoder = + encodeDict E.int (encodePair E.float E.float) + + transPosEncoder : StateTransitions -> E.Value + transPosEncoder = + encodeDict (encodeTriple E.int E.int E.int) (encodePair E.float E.float) + + stateNamesEncoder : StateNames -> E.Value + stateNamesEncoder = + encodeDict E.int E.string + + transNamesEncoder : TransitionNames -> E.Value + transNamesEncoder = + encodeDict E.int (encodeSet E.string) + in + E.object + [ ( "q", qEncoder machine.q ) + , ( "delta", deltaEncoder machine.delta ) + , ( "start", startEncoder machine.start ) + , ( "final", finalEncoder machine.final ) + , ( "statePositions", statePosEncoder machine.statePositions ) + , ( "transPositions", transPosEncoder machine.stateTransitions ) + , ( "stateNames", stateNamesEncoder machine.stateNames ) + , ( "transNames", transNamesEncoder machine.transitionNames ) + ] + + +machineDecoderV1 : D.Decoder Machine +machineDecoderV1 = + let + transTriple = + decodeTriple D.int D.int D.int + + qDecoder : D.Decoder (Set StateID) + qDecoder = + D.field "q" <| decodeSet D.int + + deltaDecoder : D.Decoder Delta + deltaDecoder = + D.field "delta" <| decodeDict D.int (decodeDict D.int D.int) + + startDecoder : D.Decoder (Set StateID) + startDecoder = + D.field "start" <| decodeSet D.int + + finalDecoder : D.Decoder (Set StateID) + finalDecoder = + D.field "final" <| decodeSet D.int + + statePosDecoder : D.Decoder StatePositions + statePosDecoder = + D.field "statePositions" <| decodeDict D.int (decodePair D.float D.float) + + transPosDecoder : D.Decoder StateTransitions + transPosDecoder = + D.field "transPositions" <| decodeDict transTriple (decodePair D.float D.float) + + stateNamesDecoder : D.Decoder StateNames + stateNamesDecoder = + D.field "stateNames" <| decodeDict D.int D.string + + transNamesDecoder : D.Decoder TransitionNames + transNamesDecoder = + D.field "transNames" <| decodeDict D.int (decodeSet D.string) + in + D.map8 Machine + qDecoder + deltaDecoder + startDecoder + finalDecoder + statePosDecoder + transPosDecoder + stateNamesDecoder + transNamesDecoder + + type alias Machine = { q : Set StateID , delta : Delta diff --git a/tests/Example.elm b/tests/Example.elm index 10f6714..4cebff1 100644 --- a/tests/Example.elm +++ b/tests/Example.elm @@ -3,11 +3,15 @@ module Example exposing (suite) import Expect exposing (Expectation) import Fuzz exposing (Fuzzer, int, list, string) import Test exposing (..) +import Machine exposing (test) + +import Json.Encode as E +import Json.Decode as D suite : Test suite = - describe "An easy test" - [ test "Example test" <| - \_ -> Expect.equal 3 3 + describe "Machine encoder-decoder" + [ Test.test "Self-cancellation of encoding and decoding for V1" <| + \_ -> Expect.equal (Ok Machine.test) (D.decodeString Machine.machineDecoderV1 <| E.encode 0 (Machine.machineEncoderV1 Machine.test)) ] From 8bc94a8f536739c6acf17cc3ca2d15e445799019 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 19:15:28 -0500 Subject: [PATCH 06/27] versioning for machine encoding / decoding; save-load module --- src/Machine.elm | 22 +++++++++++- src/SaveLoad.elm | 94 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 115 insertions(+), 1 deletion(-) create mode 100644 src/SaveLoad.elm diff --git a/src/Machine.elm b/src/Machine.elm index deeab39..2b22367 100644 --- a/src/Machine.elm +++ b/src/Machine.elm @@ -1,4 +1,4 @@ -module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID, TransitionMistakes, TransitionNames, arrow, machineDecoderV1, machineEncoderV1, renderArrow, renderArrows, renderStates, test, textBox, view) +module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID, TransitionMistakes, TransitionNames, arrow, machineDecoder, machineEncoder, renderArrow, renderArrows, renderStates, test, textBox, view) import Dict exposing (Dict) import Environment exposing (Environment) @@ -96,6 +96,11 @@ encodeTriple encA encB encC ( a, b, c ) = E.object [ ( "f", encA a ), ( "s", encB b ), ( "t", encC c ) ] +machineEncoder : Machine -> E.Value +machineEncoder = + machineEncoderV1 + + machineEncoderV1 : Machine -> E.Value machineEncoderV1 machine = let @@ -143,9 +148,24 @@ machineEncoderV1 machine = , ( "transPositions", transPosEncoder machine.stateTransitions ) , ( "stateNames", stateNamesEncoder machine.stateNames ) , ( "transNames", transNamesEncoder machine.transitionNames ) + , ( "v", E.int 1 ) ] +machineDecoder : D.Decoder Machine +machineDecoder = + D.field "v" D.int + |> D.andThen + (\v -> + case v of + 1 -> + machineDecoderV1 + + _ -> + D.fail <| "Invalid save metadata version " ++ String.fromInt v + ) + + machineDecoderV1 : D.Decoder Machine machineDecoderV1 = let diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm new file mode 100644 index 0000000..d65c377 --- /dev/null +++ b/src/SaveLoad.elm @@ -0,0 +1,94 @@ +module SaveLoad exposing (..) + +import Http +import Json.Decode as D +import Json.Encode as E +import Machine exposing (Machine) +import Time exposing (Posix) + + +type alias SaveMetadata = + { id : Int + , name : String + , date : Posix + , description : String + } + + +decodeMetadataV1 : D.Decoder SaveMetadata +decodeMetadataV1 = + D.map4 SaveMetadata + (D.field "id" D.int) + (D.field "name" D.string) + (D.field "date" <| D.map Time.millisToPosix D.int) + (D.field "desc" D.string) + + +decodeMetadata : D.Decoder SaveMetadata +decodeMetadata = + D.field "v" D.int + |> D.andThen + (\v -> + case v of + 1 -> + decodeMetadataV1 + + _ -> + D.fail <| "Invalid save metadata version " ++ String.fromInt v + ) + + +decodeMachineList : D.Decoder (List SaveMetadata) +decodeMachineList = + D.list decodeMetadata + + +encodeMachinePayload = + encodeMachinePayloadV1 + + +encodeMachinePayloadV1 : String -> String -> Posix -> Machine -> E.Value +encodeMachinePayloadV1 name desc time machine = + E.object + [ ( "name", E.string name ) + , ( "desc", E.string desc ) + , ( "time", E.int <| Time.posixToMillis time ) + , ( "machine", Machine.machineEncoder machine ) + , ( "v", E.int 1 ) + ] + + +saveMachine : String -> String -> Posix -> Machine -> (Result Http.Error Bool -> msg) -> Cmd msg +saveMachine name desc time machine toMsg = + Http.send toMsg <| + Http.post + "https://finsm.io/api/machine/save" + (Http.jsonBody <| encodeMachinePayload name desc time machine) + D.bool + + +archiveMachine : Int -> (Result Http.Error Bool -> msg) -> Cmd msg +archiveMachine id toMsg = + Http.send toMsg <| + Http.post + "https://finsm.io/api/machine/archive" + (Http.jsonBody <| E.int id) + D.bool + + +loadMachine : String -> String -> Posix -> Int -> (Result Http.Error Machine -> msg) -> Cmd msg +loadMachine name desc time id toMsg = + Http.send toMsg <| + Http.post + "https://finsm.io/api/machine/load" + (Http.jsonBody <| E.int id) + Machine.machineDecoder + + +loadList : (Result Http.Error (List SaveMetadata) -> msg) -> Cmd msg +loadList toMsg = + Http.send toMsg <| + Http.post + "https://finsm.io/api/machine/list" + Http.emptyBody + decodeMachineList From f0f102aa24e70455584f565794ef4e37495dce0e Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 19:16:50 -0500 Subject: [PATCH 07/27] bump Elm release for travis --- .travis.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.travis.yml b/.travis.yml index 545c962..2b6686a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,6 @@ language: elm +elm: + -0.19.1 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From 2104f0e24efb76c3594e1a143e12ac5a8ebc58f9 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 19:19:26 -0500 Subject: [PATCH 08/27] fix travis Elm version --- .travis.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 2b6686a..28d51a5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,5 @@ language: elm -elm: - -0.19.1 +elm: 0.19.1 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From 44414f15e1acf09155bac2e2465d4d4785b3d136 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:15:58 -0500 Subject: [PATCH 09/27] correct Elm version in travis --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 28d51a5..f4a6e1f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,5 @@ language: elm -elm: 0.19.1 +elm: 0.19.1-3 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From 627a436dc9ad044f870298254eba8e9c22de4e31 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:20:45 -0500 Subject: [PATCH 10/27] debugging travis build --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index f4a6e1f..33874c7 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,5 @@ language: elm -elm: 0.19.1-3 +elm: "0.19.1-3" env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From fd31ace8c2005e835e8ef22ed42eb379de77f32c Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:23:43 -0500 Subject: [PATCH 11/27] debugging travis... --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 33874c7..7add6ad 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,5 @@ language: elm -elm: "0.19.1-3" +elm: elm0.19.1-3 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From 98213cb61dc6c73208ff0d9aa280993b36da3c92 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:25:29 -0500 Subject: [PATCH 12/27] debugging travis --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 7add6ad..46f5b92 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,6 @@ language: elm -elm: elm0.19.1-3 +elm: + - 0.19.1-3 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From 88e3d3bdae26e2a7c6e320b28f6f1edd5fa35224 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:28:20 -0500 Subject: [PATCH 13/27] explicit versions for elm-test and elm-format in travis --- .travis.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.travis.yml b/.travis.yml index 46f5b92..099816d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,10 @@ language: elm elm: - 0.19.1-3 +elm-test: + - 0.19.1 +elm-format: + - 0.8.2 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From 32c482c6a27eadeaa118f834495c001be6500266 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:31:19 -0500 Subject: [PATCH 14/27] fix elm-test and elm-format versions --- .travis.yml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 099816d..3e64b33 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,10 +1,8 @@ language: elm elm: - 0.19.1-3 -elm-test: - - 0.19.1 -elm-format: - - 0.8.2 +elm-test: 0.19.1 +elm-format: 0.8.2 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From df5df28648af968f004968783e0b18286cd77221 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:35:38 -0500 Subject: [PATCH 15/27] debugging elm-test in travis --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3e64b33..c55ab11 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,8 +1,8 @@ language: elm -elm: - - 0.19.1-3 elm-test: 0.19.1 elm-format: 0.8.2 +elm: + - 0.19.1-3 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From 4238db5ce42c549303bc8cf6facaa03d7b58ef0a Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:43:55 -0500 Subject: [PATCH 16/27] still attempting to debug Elm build in travis --- .travis.yml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index c55ab11..3a6ed85 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,8 +1,9 @@ language: elm -elm-test: 0.19.1 -elm-format: 0.8.2 -elm: - - 0.19.1-3 + +install: + - npm install -g elm@0.19.1-3 + - npm install -g elm-test@0.19.1 + - npm install -g elm-format@0.8.2 env: global: - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= From 385b29bf3dbb03b30d8699530fb39998db710be4 Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:46:18 -0500 Subject: [PATCH 17/27] run elm-format Elm on travis seems to work now?! --- tests/Example.elm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/tests/Example.elm b/tests/Example.elm index 4cebff1..9da7abd 100644 --- a/tests/Example.elm +++ b/tests/Example.elm @@ -2,16 +2,15 @@ module Example exposing (suite) import Expect exposing (Expectation) import Fuzz exposing (Fuzzer, int, list, string) -import Test exposing (..) -import Machine exposing (test) - -import Json.Encode as E import Json.Decode as D +import Json.Encode as E +import Machine exposing (test) +import Test exposing (..) suite : Test suite = describe "Machine encoder-decoder" [ Test.test "Self-cancellation of encoding and decoding for V1" <| - \_ -> Expect.equal (Ok Machine.test) (D.decodeString Machine.machineDecoderV1 <| E.encode 0 (Machine.machineEncoderV1 Machine.test)) + \_ -> Expect.equal (Ok Machine.test) (D.decodeString Machine.machineDecoderV1 <| E.encode 0 (Machine.machineEncoderV1 Machine.test)) ] From a0eff4456658063858c1b7b833bf7686d5499dee Mon Sep 17 00:00:00 2001 From: CSchank Date: Fri, 22 Nov 2019 23:52:13 -0500 Subject: [PATCH 18/27] fix tests --- tests/Example.elm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/tests/Example.elm b/tests/Example.elm index 9da7abd..38cb2e7 100644 --- a/tests/Example.elm +++ b/tests/Example.elm @@ -12,5 +12,9 @@ suite : Test suite = describe "Machine encoder-decoder" [ Test.test "Self-cancellation of encoding and decoding for V1" <| - \_ -> Expect.equal (Ok Machine.test) (D.decodeString Machine.machineDecoderV1 <| E.encode 0 (Machine.machineEncoderV1 Machine.test)) + \_ -> + Expect.equal (Ok Machine.test) + (D.decodeString Machine.machineDecoder <| + E.encode 0 (Machine.machineEncoder Machine.test) + ) ] From 2f5d8b14adf7a0a0259d4ef785bad22752f942af Mon Sep 17 00:00:00 2001 From: CSchank Date: Sat, 23 Nov 2019 22:04:15 -0500 Subject: [PATCH 19/27] break out codec helpers into Utils.elm --- src/Machine.elm | 49 +------------------------------------------- src/Utils.elm | 54 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 55 insertions(+), 48 deletions(-) create mode 100644 src/Utils.elm diff --git a/src/Machine.elm b/src/Machine.elm index 2b22367..80368c1 100644 --- a/src/Machine.elm +++ b/src/Machine.elm @@ -10,6 +10,7 @@ import Html.Events exposing (onInput) import Json.Decode as D import Json.Encode as E import Set exposing (Set) +import Utils exposing (decodeDict, decodePair, decodeSet, decodeTriple, encodeDict, encodePair, encodeSet, encodeTriple) type alias StateID = @@ -48,54 +49,6 @@ type alias TransitionMistakes = Maybe (Set TransitionID) -decodeDict : D.Decoder comparable -> D.Decoder value -> D.Decoder (Dict comparable value) -decodeDict decComp decValu = - D.map Dict.fromList <| D.list <| D.map2 Tuple.pair (D.field "k" decComp) (D.field "v" decValu) - - -decodeSet : D.Decoder comparable -> D.Decoder (Set comparable) -decodeSet decComp = - D.map Set.fromList <| D.list decComp - - -decodePair : D.Decoder x -> D.Decoder y -> D.Decoder ( x, y ) -decodePair decX decY = - D.map2 Tuple.pair (D.field "f" decX) (D.field "s" decY) - - -decodeTriple : D.Decoder x -> D.Decoder y -> D.Decoder z -> D.Decoder ( x, y, z ) -decodeTriple decX decY decZ = - D.map3 (\x y z -> ( x, y, z )) (D.field "f" decX) (D.field "s" decY) (D.field "t" decZ) - - -encodeSet : (comparable -> E.Value) -> Set comparable -> E.Value -encodeSet valFn = - E.list valFn << Set.toList - - -encodeDict : (comparable -> E.Value) -> (value -> E.Value) -> Dict comparable value -> E.Value -encodeDict compFn valFn dict = - E.list - (\( k, v ) -> - E.object - [ ( "k", compFn k ) - , ( "v", valFn v ) - ] - ) - <| - Dict.toList dict - - -encodePair : (a -> E.Value) -> (b -> E.Value) -> ( a, b ) -> E.Value -encodePair encA encB ( a, b ) = - E.object [ ( "f", encA a ), ( "s", encB b ) ] - - -encodeTriple : (a -> E.Value) -> (b -> E.Value) -> (c -> E.Value) -> ( a, b, c ) -> E.Value -encodeTriple encA encB encC ( a, b, c ) = - E.object [ ( "f", encA a ), ( "s", encB b ), ( "t", encC c ) ] - - machineEncoder : Machine -> E.Value machineEncoder = machineEncoderV1 diff --git a/src/Utils.elm b/src/Utils.elm new file mode 100644 index 0000000..8b275ab --- /dev/null +++ b/src/Utils.elm @@ -0,0 +1,54 @@ +module Utils exposing (..) + +import Dict exposing (Dict) +import Json.Decode as D +import Json.Encode as E +import Set exposing (Set) + + +encodePair : (a -> E.Value) -> (b -> E.Value) -> ( a, b ) -> E.Value +encodePair encA encB ( a, b ) = + E.object [ ( "f", encA a ), ( "s", encB b ) ] + + +encodeTriple : (a -> E.Value) -> (b -> E.Value) -> (c -> E.Value) -> ( a, b, c ) -> E.Value +encodeTriple encA encB encC ( a, b, c ) = + E.object [ ( "f", encA a ), ( "s", encB b ), ( "t", encC c ) ] + + +decodeDict : D.Decoder comparable -> D.Decoder value -> D.Decoder (Dict comparable value) +decodeDict decComp decValu = + D.map Dict.fromList <| D.list <| D.map2 Tuple.pair (D.field "k" decComp) (D.field "v" decValu) + + +decodeSet : D.Decoder comparable -> D.Decoder (Set comparable) +decodeSet decComp = + D.map Set.fromList <| D.list decComp + + +decodePair : D.Decoder x -> D.Decoder y -> D.Decoder ( x, y ) +decodePair decX decY = + D.map2 Tuple.pair (D.field "f" decX) (D.field "s" decY) + + +decodeTriple : D.Decoder x -> D.Decoder y -> D.Decoder z -> D.Decoder ( x, y, z ) +decodeTriple decX decY decZ = + D.map3 (\x y z -> ( x, y, z )) (D.field "f" decX) (D.field "s" decY) (D.field "t" decZ) + + +encodeSet : (comparable -> E.Value) -> Set comparable -> E.Value +encodeSet valFn = + E.list valFn << Set.toList + + +encodeDict : (comparable -> E.Value) -> (value -> E.Value) -> Dict comparable value -> E.Value +encodeDict compFn valFn dict = + E.list + (\( k, v ) -> + E.object + [ ( "k", compFn k ) + , ( "v", valFn v ) + ] + ) + <| + Dict.toList dict From 61c415e5b0baa88adf9ac986e31fb7e1dffa15b4 Mon Sep 17 00:00:00 2001 From: CSchank Date: Thu, 19 Dec 2019 14:41:45 -0500 Subject: [PATCH 20/27] continuing on saving/loading, decoding / encoding of tapes --- src/SaveLoad.elm | 76 +++++++++++++++++++++++++++++++++------------- src/Simulating.elm | 14 ++++++++- 2 files changed, 68 insertions(+), 22 deletions(-) diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm index d65c377..ef0a370 100644 --- a/src/SaveLoad.elm +++ b/src/SaveLoad.elm @@ -4,27 +4,28 @@ import Http import Json.Decode as D import Json.Encode as E import Machine exposing (Machine) +import Simulating exposing (InputTape) import Time exposing (Posix) -type alias SaveMetadata = - { id : Int +type alias LoadMetadata = + { id : String , name : String , date : Posix , description : String } -decodeMetadataV1 : D.Decoder SaveMetadata +decodeMetadataV1 : D.Decoder LoadMetadata decodeMetadataV1 = - D.map4 SaveMetadata - (D.field "id" D.int) + D.map4 LoadMetadata + (D.field "id" D.string) (D.field "name" D.string) (D.field "date" <| D.map Time.millisToPosix D.int) (D.field "desc" D.string) -decodeMetadata : D.Decoder SaveMetadata +decodeMetadata : D.Decoder LoadMetadata decodeMetadata = D.field "v" D.int |> D.andThen @@ -38,7 +39,7 @@ decodeMetadata = ) -decodeMachineList : D.Decoder (List SaveMetadata) +decodeMachineList : D.Decoder (List LoadMetadata) decodeMachineList = D.list decodeMetadata @@ -47,23 +48,43 @@ encodeMachinePayload = encodeMachinePayloadV1 -encodeMachinePayloadV1 : String -> String -> Posix -> Machine -> E.Value -encodeMachinePayloadV1 name desc time machine = + +-- encode the payload when saving a machine to the server +-- note: id is empty if the machine is a new one instead of one already saved to the server +-- sending an existing id will overwrite the machine saved with that id + + +encodeMachinePayloadV1 : String -> String -> Posix -> Machine -> String -> InputTape -> E.Value +encodeMachinePayloadV1 name desc time machine uuid inputTape = E.object [ ( "name", E.string name ) , ( "desc", E.string desc ) - , ( "time", E.int <| Time.posixToMillis time ) , ( "machine", Machine.machineEncoder machine ) , ( "v", E.int 1 ) + , ( "uuid", E.string uuid ) + , ( "tape", Simulating.inputTapeEncoder inputTape ) ] -saveMachine : String -> String -> Posix -> Machine -> (Result Http.Error Bool -> msg) -> Cmd msg -saveMachine name desc time machine toMsg = +type alias SaveResponse = + { success : Bool + , uuid : String + } + + +decodeSaveResponse : D.Decoder SaveResponse +decodeSaveResponse = + D.map2 SaveResponse + (D.field "success" D.bool) + (D.field "uuid" D.string) + + +saveMachine : String -> String -> Posix -> Machine -> String -> InputTape -> (Result Http.Error Bool -> msg) -> Cmd msg +saveMachine name desc time machine uuid inputTape toMsg = Http.send toMsg <| Http.post - "https://finsm.io/api/machine/save" - (Http.jsonBody <| encodeMachinePayload name desc time machine) + "api/machine/save" + (Http.jsonBody <| encodeMachinePayload name desc time machine uuid inputTape) D.bool @@ -71,24 +92,37 @@ archiveMachine : Int -> (Result Http.Error Bool -> msg) -> Cmd msg archiveMachine id toMsg = Http.send toMsg <| Http.post - "https://finsm.io/api/machine/archive" + "api/machine/archive" (Http.jsonBody <| E.int id) D.bool -loadMachine : String -> String -> Posix -> Int -> (Result Http.Error Machine -> msg) -> Cmd msg -loadMachine name desc time id toMsg = +type alias LoadPayload = + { machine : Machine + , tape : InputTape + } + + +decodeLoadPayload : D.Decoder LoadPayload +decodeLoadPayload = + D.map2 LoadPayload + (D.field "machine" Machine.machineDecoder) + (D.field "tape" Simulating.inputTapeDecoder) + + +loadMachine : String -> String -> Posix -> String -> (Result Http.Error Machine -> msg) -> Cmd msg +loadMachine name desc time uuid toMsg = Http.send toMsg <| Http.post - "https://finsm.io/api/machine/load" - (Http.jsonBody <| E.int id) + "api/machine/load" + (Http.jsonBody <| E.string uuid) Machine.machineDecoder -loadList : (Result Http.Error (List SaveMetadata) -> msg) -> Cmd msg +loadList : (Result Http.Error (List LoadMetadata) -> msg) -> Cmd msg loadList toMsg = Http.send toMsg <| Http.post - "https://finsm.io/api/machine/list" + "api/machine/list" Http.emptyBody decodeMachineList diff --git a/src/Simulating.elm b/src/Simulating.elm index a29bbd1..0526a38 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -1,4 +1,4 @@ -module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, delta, deltaHat, epsTrans, initPModel, isAccept, latexKeyboard, machineDefn, machineModeButtons, onEnter, onExit, renderTape, subscriptions, update, view) +module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, delta, deltaHat, epsTrans, initPModel, inputTapeDecoder, inputTapeEncoder, isAccept, latexKeyboard, machineDefn, machineModeButtons, onEnter, onExit, renderTape, subscriptions, update, view) import Array exposing (Array) import Browser.Events @@ -9,6 +9,7 @@ import Error exposing (..) import GraphicSVG exposing (..) import Helpers exposing (..) import Json.Decode as D +import Json.Encode as E import Machine exposing (..) import Mistakes exposing (..) import Set exposing (Set) @@ -28,6 +29,17 @@ type alias PersistentModel = } +inputTapeEncoder : InputTape -> E.Value +inputTapeEncoder = + E.list E.string << Array.toList + + +inputTapeDecoder : D.Decoder InputTape +inputTapeDecoder = + D.map Array.fromList + (D.list D.string) + + type alias InputTape = Array Character From c6edb24c7ae65bd5e18675ef807ab4e3efb24218 Mon Sep 17 00:00:00 2001 From: CSchank Date: Thu, 19 Dec 2019 17:31:48 -0500 Subject: [PATCH 21/27] starting saving on client side --- src/Machine.elm | 21 +---- src/Main.elm | 203 ++++++++++++++++++++++++++++++++++++++++++++- src/Ports.elm | 13 +++ src/SaveLoad.elm | 21 ++--- src/Simulating.elm | 5 +- src/Utils.elm | 21 +++++ 6 files changed, 252 insertions(+), 32 deletions(-) create mode 100644 src/Ports.elm diff --git a/src/Machine.elm b/src/Machine.elm index 80368c1..47c9271 100644 --- a/src/Machine.elm +++ b/src/Machine.elm @@ -1,4 +1,4 @@ -module Machine exposing (Character, Delta, Machine, Model(..), Msg(..), StateID, StateNames, StatePositions, StateTransitions, TransitionID, TransitionMistakes, TransitionNames, arrow, machineDecoder, machineEncoder, renderArrow, renderArrows, renderStates, test, textBox, view) +module Machine exposing (..) import Dict exposing (Dict) import Environment exposing (Environment) @@ -10,7 +10,7 @@ import Html.Events exposing (onInput) import Json.Decode as D import Json.Encode as E import Set exposing (Set) -import Utils exposing (decodeDict, decodePair, decodeSet, decodeTriple, encodeDict, encodePair, encodeSet, encodeTriple) +import Utils exposing (decodeDict, decodePair, decodeSet, decodeTriple, encodeDict, encodePair, encodeSet, encodeTriple, textBox) type alias StateID = @@ -368,23 +368,6 @@ view env model machine currentStates tMistakes = --These two functions will eventually become part of GraphicSVG in some form -textBox : String -> Float -> Float -> String -> (String -> Msg) -> Shape Msg -textBox txt w h place msg = - move ( -w / 2, h / 2 ) <| - html (w * 1.5) (h * 1.5) <| - input - [ id "input" - , placeholder place - , onInput msg - , value txt - , style "width" (String.fromFloat w ++ "px") - , style "height" (String.fromFloat h ++ "px") - , style "margin-top" "1px" - , style "font-family" "monospace" - ] - [] - - arrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) = let ( dx, dy ) = diff --git a/src/Main.elm b/src/Main.elm index 15d3e74..b4efa4f 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -14,17 +14,22 @@ import Helpers exposing (finsmBlue, icon, sendMsg) import Html as H exposing (Html, input, node) import Html.Attributes exposing (attribute, placeholder, style, value) import Html.Events exposing (onInput) +import Http import Json.Decode as D import Json.Encode import List import Machine exposing (..) +import Ports import Random +import SaveLoad exposing (saveMachine) import Set exposing (Set) import SharedModel exposing (SharedModel) import Simulating import Task +import Time import Tuple exposing (first, second) import Url exposing (Url) +import Utils exposing (textBox) type Msg @@ -38,6 +43,37 @@ type Msg | UrlRequest UrlRequest | GoTo Module | VisibilityChanged Visibility + | OpenLoginDialog + | OpenLogoutDialog + | GetLoginStatus + | LoginStatusChange (Result Http.Error LoginStatus) + | EditMachineName + | TypeName String + | SaveMachine + | MachineSaveResponse (Result Http.Error SaveLoad.SaveResponse) + | NoOp + + +loginStatusDecoder : D.Decoder LoginStatus +loginStatusDecoder = + D.field "loggedin" D.bool + |> D.andThen + (\loggedIn -> + if loggedIn then + D.map LoggedIn (D.field "email" D.string) + + else + D.succeed NotLoggedIn + ) + + +getLoginStatus : Cmd Msg +getLoginStatus = + Http.send LoginStatusChange <| + Http.post + "/accounts/loginstate/" + Http.emptyBody + loginStatusDecoder type Module @@ -52,9 +88,19 @@ type ApplicationState | Exporting Exporting.Model +type LoginStatus + = LoggedIn String + | NotLoggedIn + | LoggingIn + + type alias Model = { appModel : BetterUndoList ApplicationModel , environment : Environment + , loginState : LoginStatus + , loginDialog : Bool + , machineMetadata : SaveLoad.LoadMetadata + , editingName : Bool } @@ -85,8 +131,15 @@ main = \flags url key -> ( { appModel = initAppModel , environment = Environment.init + , loginState = NotLoggedIn + , loginDialog = False + , machineMetadata = { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0 } + , editingName = False } - , Task.perform (\vp -> WindowSize ( round vp.viewport.width, round vp.viewport.height )) Browser.Dom.getViewport + , Cmd.batch + [ Task.perform (\vp -> WindowSize ( round vp.viewport.width, round vp.viewport.height )) Browser.Dom.getViewport + , getLoginStatus + ] ) , update = update , view = \m -> { body = view m, title = "finsm - create and simulate finite state machines" } @@ -106,6 +159,9 @@ main = Exporting m -> Sub.map EMsg (Exporting.subscriptions m) + , Browser.Events.onVisibilityChange (\_ -> GetLoginStatus) + , Ports.loginComplete (\_ -> GetLoginStatus) + , Ports.logoutComplete (\_ -> GetLoginStatus) ] , onUrlChange = UrlChange , onUrlRequest = UrlRequest @@ -237,6 +293,9 @@ update msg model = else if k == "Control" then ( { model | environment = { oldEnvironment | holdingControl = False } }, Cmd.none ) + else if k == "Enter" then + ( { model | editingName = False }, Cmd.none ) + else ( model, Cmd.none ) @@ -361,6 +420,59 @@ update msg model = , Cmd.none ) + OpenLoginDialog -> + ( { model | loginDialog = not model.loginDialog }, Ports.launchLogin () ) + + OpenLogoutDialog -> + ( { model | loginDialog = not model.loginDialog }, Ports.launchLogout () ) + + GetLoginStatus -> + ( model, getLoginStatus ) + + LoginStatusChange loginStatus -> + case loginStatus of + Ok loginState -> + ( { model | loginState = loginState }, Cmd.none ) + + Err _ -> + ( model, Cmd.none ) + + EditMachineName -> + ( { model | editingName = True }, Cmd.none ) + + TypeName n -> + let + meta = + model.machineMetadata + in + ( { model | machineMetadata = { meta | name = n } }, Cmd.none ) + + SaveMachine -> + ( model + , saveMachine + model.machineMetadata.name + model.machineMetadata.description + model.appModel.present.sharedModel.machine + model.machineMetadata.id + model.appModel.present.simulatingData.tapes + MachineSaveResponse + ) + + MachineSaveResponse saveresp -> + let + meta = + model.machineMetadata + in + case saveresp of + Ok oksaveresp -> + ( { model | machineMetadata = { meta | id = oksaveresp.uuid } }, Cmd.none ) + + Err _ -> + ( model, Cmd.none ) + + NoOp -> + ( model, Cmd.none ) + processExit : Environment @@ -568,6 +680,95 @@ modeButtons model = ] |> move ( -winX / 2 + 134, winY / 2 - 15 ) |> notifyTap (GoTo ExportingModule) + , case model.loginState of + NotLoggedIn -> + group + [ roundedRect 50 15 1 + |> filled + (if exporting then + finsmBlue + + else + blank + ) + |> addOutline (solid 1) darkGray + , text "Log in" + |> centered + |> fixedwidth + |> filled black + |> move ( 0, -4 ) + ] + |> move ( winX / 2 - 50, winY / 2 - 15 ) + |> notifyTap OpenLoginDialog + + LoggedIn email -> + group + [ text ("Welcome " ++ email) + |> alignRight + |> fixedwidth + |> filled + black + |> move ( 0, -4 ) + , group + [ roundedRect 55 15 1 + |> filled + (if exporting then + finsmBlue + + else + blank + ) + |> addOutline (solid 1) darkGray + , text "Log out" + |> centered + |> fixedwidth + |> filled black + |> move ( 0, -4 ) + ] + |> move ( 40, 0 ) + |> notifyTap OpenLogoutDialog + ] + |> move ( winX / 2 - 100, winY / 2 - 15 ) + + _ -> + group [] + , if not model.editingName then + text model.machineMetadata.name + |> fixedwidth + |> size 16 + |> filled black + |> move ( -winX / 2 + 250, winY / 2 - 20 ) + |> notifyTap EditMachineName + + else + textBox model.machineMetadata.name 1000 20 "Machine Name" TypeName + |> move ( -winX / 2 + 700, winY / 2 - 20 ) + , group + [ roundedRect 50 15 1 + |> filled + (if exporting then + finsmBlue + + else + blank + ) + |> addOutline (solid 1) darkGray + , text "Save" + |> centered + |> fixedwidth + |> filled + (if exporting then + white + + else + darkGray + ) + |> move ( 0, -4 ) + ] + |> move ( -winX / 2 + 183, winY / 2 - 15 ) + |> notifyTap SaveMachine + + --, if model.loginDialog then ] diff --git a/src/Ports.elm b/src/Ports.elm new file mode 100644 index 0000000..71f795e --- /dev/null +++ b/src/Ports.elm @@ -0,0 +1,13 @@ +port module Ports exposing (..) + + +port launchLogin : () -> Cmd msg + + +port launchLogout : () -> Cmd msg + + +port loginComplete : (() -> msg) -> Sub msg + + +port logoutComplete : (() -> msg) -> Sub msg diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm index ef0a370..77b1191 100644 --- a/src/SaveLoad.elm +++ b/src/SaveLoad.elm @@ -1,5 +1,6 @@ module SaveLoad exposing (..) +import Dict exposing (Dict) import Http import Json.Decode as D import Json.Encode as E @@ -54,8 +55,8 @@ encodeMachinePayload = -- sending an existing id will overwrite the machine saved with that id -encodeMachinePayloadV1 : String -> String -> Posix -> Machine -> String -> InputTape -> E.Value -encodeMachinePayloadV1 name desc time machine uuid inputTape = +encodeMachinePayloadV1 : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> E.Value +encodeMachinePayloadV1 name desc machine uuid inputTape = E.object [ ( "name", E.string name ) , ( "desc", E.string desc ) @@ -79,20 +80,20 @@ decodeSaveResponse = (D.field "uuid" D.string) -saveMachine : String -> String -> Posix -> Machine -> String -> InputTape -> (Result Http.Error Bool -> msg) -> Cmd msg -saveMachine name desc time machine uuid inputTape toMsg = +saveMachine : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> (Result Http.Error SaveResponse -> msg) -> Cmd msg +saveMachine name desc machine uuid inputTape toMsg = Http.send toMsg <| Http.post - "api/machine/save" - (Http.jsonBody <| encodeMachinePayload name desc time machine uuid inputTape) - D.bool + "/api/machine/save" + (Http.jsonBody <| encodeMachinePayload name desc machine uuid inputTape) + decodeSaveResponse archiveMachine : Int -> (Result Http.Error Bool -> msg) -> Cmd msg archiveMachine id toMsg = Http.send toMsg <| Http.post - "api/machine/archive" + "/api/machine/archive" (Http.jsonBody <| E.int id) D.bool @@ -114,7 +115,7 @@ loadMachine : String -> String -> Posix -> String -> (Result Http.Error Machine loadMachine name desc time uuid toMsg = Http.send toMsg <| Http.post - "api/machine/load" + "/api/machine/load" (Http.jsonBody <| E.string uuid) Machine.machineDecoder @@ -123,6 +124,6 @@ loadList : (Result Http.Error (List LoadMetadata) -> msg) -> Cmd msg loadList toMsg = Http.send toMsg <| Http.post - "api/machine/list" + "/api/machine/list" Http.emptyBody decodeMachineList diff --git a/src/Simulating.elm b/src/Simulating.elm index 0526a38..3103df0 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -16,6 +16,7 @@ import Set exposing (Set) import SharedModel exposing (..) import Task import Tuple exposing (first, second) +import Utils exposing (encodeDict) subscriptions : Model -> Sub Msg @@ -29,9 +30,9 @@ type alias PersistentModel = } -inputTapeEncoder : InputTape -> E.Value +inputTapeEncoder : Dict Int ( InputTape, a ) -> E.Value inputTapeEncoder = - E.list E.string << Array.toList + encodeDict E.int (E.list E.string << Array.toList << Tuple.first) inputTapeDecoder : D.Decoder InputTape diff --git a/src/Utils.elm b/src/Utils.elm index 8b275ab..1376bad 100644 --- a/src/Utils.elm +++ b/src/Utils.elm @@ -1,6 +1,10 @@ module Utils exposing (..) import Dict exposing (Dict) +import GraphicSVG exposing (..) +import Html exposing (input) +import Html.Attributes exposing (..) +import Html.Events exposing (..) import Json.Decode as D import Json.Encode as E import Set exposing (Set) @@ -52,3 +56,20 @@ encodeDict compFn valFn dict = ) <| Dict.toList dict + + +textBox : String -> Float -> Float -> String -> (String -> msg) -> Shape msg +textBox txt w h place msg = + move ( -w / 2, h / 2 ) <| + html (w * 1.5) (h * 1.5) <| + input + [ id "input" + , placeholder place + , onInput msg + , value txt + , style "width" (String.fromFloat w ++ "px") + , style "height" (String.fromFloat h ++ "px") + , style "margin-top" "1px" + , style "font-family" "monospace" + ] + [] From 493b737d9363f7bbf2bc13f286c400bcdbb7f0dc Mon Sep 17 00:00:00 2001 From: CSchank Date: Sat, 21 Dec 2019 00:53:46 -0500 Subject: [PATCH 22/27] starting implementing autosave --- src/Environment.elm | 4 ++++ src/Main.elm | 16 ++++++++++++++++ 2 files changed, 20 insertions(+) diff --git a/src/Environment.elm b/src/Environment.elm index ef99db5..ec4788e 100644 --- a/src/Environment.elm +++ b/src/Environment.elm @@ -1,5 +1,7 @@ module Environment exposing (Environment, init) +import Time + init : Environment init = @@ -7,6 +9,7 @@ init = , holdingShift = False , holdingControl = False , holdingMeta = False + , currentTime = Time.millisToPosix 1576798602274 } @@ -15,4 +18,5 @@ type alias Environment = , holdingShift : Bool , holdingControl : Bool , holdingMeta : Bool + , currentTime : Time.Posix } diff --git a/src/Main.elm b/src/Main.elm index b4efa4f..58ba208 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -51,6 +51,7 @@ type Msg | TypeName String | SaveMachine | MachineSaveResponse (Result Http.Error SaveLoad.SaveResponse) + | GetTime Time.Posix | NoOp @@ -94,6 +95,12 @@ type LoginStatus | LoggingIn +type SaveStatus + = NotSaved + | LastSaved Time.Posix + | Saved Time.Posix + + type alias Model = { appModel : BetterUndoList ApplicationModel , environment : Environment @@ -139,6 +146,7 @@ main = , Cmd.batch [ Task.perform (\vp -> WindowSize ( round vp.viewport.width, round vp.viewport.height )) Browser.Dom.getViewport , getLoginStatus + , Task.perform GetTime Time.now ] ) , update = update @@ -162,6 +170,7 @@ main = , Browser.Events.onVisibilityChange (\_ -> GetLoginStatus) , Ports.loginComplete (\_ -> GetLoginStatus) , Ports.logoutComplete (\_ -> GetLoginStatus) + , Time.every 10000 GetTime -- get the new time every 10 seconds ] , onUrlChange = UrlChange , onUrlRequest = UrlRequest @@ -470,6 +479,13 @@ update msg model = Err _ -> ( model, Cmd.none ) + GetTime time -> + let + oldEnv = + model.environment + in + ( { model | environment = { oldEnv | currentTime = time } }, Cmd.none ) + NoOp -> ( model, Cmd.none ) From a8d00931f931c9f9a0870f97f75196865b4a8567 Mon Sep 17 00:00:00 2001 From: CSchank Date: Sun, 22 Dec 2019 22:41:22 -0500 Subject: [PATCH 23/27] enable autosave --- elm.json | 3 +- src/Main.elm | 144 +++++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 119 insertions(+), 28 deletions(-) diff --git a/elm.json b/elm.json index f7820e3..47e1d7b 100644 --- a/elm.json +++ b/elm.json @@ -16,7 +16,8 @@ "elm/random": "1.0.0", "elm/time": "1.0.0", "elm/url": "1.0.0", - "elm-community/undo-redo": "3.0.0" + "elm-community/undo-redo": "3.0.0", + "ianmackenzie/elm-units": "2.2.0" }, "indirect": { "elm/regex": "1.0.0", diff --git a/src/Main.elm b/src/Main.elm index 58ba208..ceebd64 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -7,6 +7,7 @@ import Browser.Dom import Browser.Events exposing (Visibility) import Building import Dict exposing (Dict) +import Duration import Environment exposing (Environment) import Exporting import GraphicSVG exposing (..) @@ -104,10 +105,17 @@ type SaveStatus type alias Model = { appModel : BetterUndoList ApplicationModel , environment : Environment - , loginState : LoginStatus + , saveModel : SaveModel + } + + +type alias SaveModel = + { loginState : LoginStatus , loginDialog : Bool , machineMetadata : SaveLoad.LoadMetadata , editingName : Bool + , lastSaved : Time.Posix + , unsavedChanges : Bool } @@ -138,10 +146,14 @@ main = \flags url key -> ( { appModel = initAppModel , environment = Environment.init - , loginState = NotLoggedIn - , loginDialog = False - , machineMetadata = { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0 } - , editingName = False + , saveModel = + { loginState = NotLoggedIn + , loginDialog = False + , machineMetadata = { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0 } + , editingName = False + , lastSaved = Time.millisToPosix 0 + , unsavedChanges = False + } } , Cmd.batch [ Task.perform (\vp -> WindowSize ( round vp.viewport.width, round vp.viewport.height )) Browser.Dom.getViewport @@ -153,7 +165,7 @@ main = , view = \m -> { body = view m, title = "finsm - create and simulate finite state machines" } , subscriptions = \model -> - Sub.batch + Sub.batch <| [ Browser.Events.onResize (\w h -> WindowSize ( w, h )) , Browser.Events.onKeyDown (D.map KeyPressed (D.field "key" D.string)) , Browser.Events.onKeyUp (D.map KeyReleased (D.field "key" D.string)) @@ -170,7 +182,7 @@ main = , Browser.Events.onVisibilityChange (\_ -> GetLoginStatus) , Ports.loginComplete (\_ -> GetLoginStatus) , Ports.logoutComplete (\_ -> GetLoginStatus) - , Time.every 10000 GetTime -- get the new time every 10 seconds + , Time.every 5000 GetTime -- get the new time every 10 seconds ] , onUrlChange = UrlChange , onUrlRequest = UrlRequest @@ -209,6 +221,12 @@ moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel m , sharedModel = newSModel } |> setpModel newPModel + + sm = + model.saveModel + + cp = + Debug.log "unsavedChanges" sm.unsavedChanges in ( { model | appModel = @@ -217,6 +235,15 @@ moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel m else replace newAppState model.appModel + , saveModel = + { sm + | unsavedChanges = + if checkpoint then + True + + else + sm.unsavedChanges + } } , Cmd.map msgWrapper cmd ) @@ -230,6 +257,9 @@ update msg model = currentAppState = model.appModel.present + + sm = + model.saveModel in case msg of BMsg bmsg -> @@ -303,7 +333,7 @@ update msg model = ( { model | environment = { oldEnvironment | holdingControl = False } }, Cmd.none ) else if k == "Enter" then - ( { model | editingName = False }, Cmd.none ) + ( { model | saveModel = { sm | editingName = False, unsavedChanges = True } }, Cmd.none ) else ( model, Cmd.none ) @@ -331,6 +361,7 @@ update msg model = else model.appModel + , saveModel = { sm | unsavedChanges = doRedo || doUndo } } , Cmd.none ) @@ -430,10 +461,10 @@ update msg model = ) OpenLoginDialog -> - ( { model | loginDialog = not model.loginDialog }, Ports.launchLogin () ) + ( { model | saveModel = { sm | loginDialog = not sm.loginDialog } }, Ports.launchLogin () ) OpenLogoutDialog -> - ( { model | loginDialog = not model.loginDialog }, Ports.launchLogout () ) + ( { model | saveModel = { sm | loginDialog = not sm.loginDialog } }, Ports.launchLogout () ) GetLoginStatus -> ( model, getLoginStatus ) @@ -441,28 +472,28 @@ update msg model = LoginStatusChange loginStatus -> case loginStatus of Ok loginState -> - ( { model | loginState = loginState }, Cmd.none ) + ( { model | saveModel = { sm | loginState = loginState } }, Cmd.none ) Err _ -> ( model, Cmd.none ) EditMachineName -> - ( { model | editingName = True }, Cmd.none ) + ( { model | saveModel = { sm | editingName = True } }, Cmd.none ) TypeName n -> let meta = - model.machineMetadata + model.saveModel.machineMetadata in - ( { model | machineMetadata = { meta | name = n } }, Cmd.none ) + ( { model | saveModel = { sm | machineMetadata = { meta | name = n } } }, Cmd.none ) SaveMachine -> ( model , saveMachine - model.machineMetadata.name - model.machineMetadata.description + model.saveModel.machineMetadata.name + model.saveModel.machineMetadata.description model.appModel.present.sharedModel.machine - model.machineMetadata.id + model.saveModel.machineMetadata.id model.appModel.present.simulatingData.tapes MachineSaveResponse ) @@ -470,11 +501,20 @@ update msg model = MachineSaveResponse saveresp -> let meta = - model.machineMetadata + model.saveModel.machineMetadata in case saveresp of Ok oksaveresp -> - ( { model | machineMetadata = { meta | id = oksaveresp.uuid } }, Cmd.none ) + ( { model + | saveModel = + { sm + | machineMetadata = { meta | id = oksaveresp.uuid } + , lastSaved = model.environment.currentTime + , unsavedChanges = False + } + } + , Cmd.none + ) Err _ -> ( model, Cmd.none ) @@ -484,7 +524,19 @@ update msg model = oldEnv = model.environment in - ( { model | environment = { oldEnv | currentTime = time } }, Cmd.none ) + ( { model | environment = { oldEnv | currentTime = time } } + , if sm.unsavedChanges then + saveMachine + model.saveModel.machineMetadata.name + model.saveModel.machineMetadata.description + model.appModel.present.sharedModel.machine + model.saveModel.machineMetadata.id + model.appModel.present.simulatingData.tapes + MachineSaveResponse + + else + Cmd.none + ) NoOp -> ( model, Cmd.none ) @@ -696,7 +748,7 @@ modeButtons model = ] |> move ( -winX / 2 + 134, winY / 2 - 15 ) |> notifyTap (GoTo ExportingModule) - , case model.loginState of + , case model.saveModel.loginState of NotLoggedIn -> group [ roundedRect 50 15 1 @@ -722,8 +774,7 @@ modeButtons model = [ text ("Welcome " ++ email) |> alignRight |> fixedwidth - |> filled - black + |> filled black |> move ( 0, -4 ) , group [ roundedRect 55 15 1 @@ -748,8 +799,8 @@ modeButtons model = _ -> group [] - , if not model.editingName then - text model.machineMetadata.name + , if not model.saveModel.editingName then + text model.saveModel.machineMetadata.name |> fixedwidth |> size 16 |> filled black @@ -757,8 +808,13 @@ modeButtons model = |> notifyTap EditMachineName else - textBox model.machineMetadata.name 1000 20 "Machine Name" TypeName - |> move ( -winX / 2 + 700, winY / 2 - 20 ) + textBox model.saveModel.machineMetadata.name 300 20 "Machine Name" TypeName + |> move ( -winX / 2 + 400, winY / 2 - 10 ) + , text (lastSaved model) + |> fixedwidth + |> size 14 + |> filled darkGray + |> move ( -winX / 2 + 550, winY / 2 - 20 ) , group [ roundedRect 50 15 1 |> filled @@ -788,6 +844,40 @@ modeButtons model = ] +lastSaved : Model -> String +lastSaved model = + let + duration = + Duration.from model.saveModel.lastSaved model.environment.currentTime + in + if not model.saveModel.unsavedChanges then + if Duration.inSeconds duration <= 30 then + "last edit saved just now" + + else if Duration.inSeconds duration <= 90 then + "last edit saved about a minute ago" + + else if Duration.inMinutes duration <= 60 then + "last edit saved " ++ String.fromInt (round <| Duration.inMinutes duration) ++ " minutes ago" + + else if Duration.inMinutes duration <= 90 then + "last edit saved about an hour ago" + + else + "last edit saved " ++ String.fromInt (round <| Duration.inHours duration) ++ " hours ago" + + else + case model.saveModel.loginState of + LoggedIn _ -> + "saving..." + + NotLoggedIn -> + "log in to save changes" + + _ -> + "" + + errorEpsTrans model = let winX = From 2d877ea2a2b7052f2371a41c24214bcc15c13355 Mon Sep 17 00:00:00 2001 From: CSchank Date: Tue, 24 Dec 2019 00:09:40 -0500 Subject: [PATCH 24/27] first draft of saving/loading --- elm.json | 6 +- src/Helpers.elm | 13 ++++ src/Main.elm | 171 ++++++++++++++++++++++++++++++++------------- src/SaveLoad.elm | 10 +-- src/Simulating.elm | 12 +++- 5 files changed, 154 insertions(+), 58 deletions(-) diff --git a/elm.json b/elm.json index 47e1d7b..40bde1f 100644 --- a/elm.json +++ b/elm.json @@ -14,14 +14,16 @@ "elm/http": "1.0.0", "elm/json": "1.1.2", "elm/random": "1.0.0", + "elm/svg": "1.0.1", "elm/time": "1.0.0", "elm/url": "1.0.0", "elm-community/undo-redo": "3.0.0", - "ianmackenzie/elm-units": "2.2.0" + "ianmackenzie/elm-units": "2.2.0", + "rundis/elm-bootstrap": "5.2.0" }, "indirect": { + "avh4/elm-color": "1.0.0", "elm/regex": "1.0.0", - "elm/svg": "1.0.1", "elm/virtual-dom": "1.0.2", "elm-community/list-extra": "8.1.0" } diff --git a/src/Helpers.elm b/src/Helpers.elm index 3203b66..95deb14 100644 --- a/src/Helpers.elm +++ b/src/Helpers.elm @@ -96,6 +96,19 @@ type LatexAlign latex w h backclr txt align = + --image (latexurl txt) + -- |> move + -- ( case align of + -- AlignLeft -> + -- 0 + -- + -- AlignRight -> + -- -w + -- + -- AlignCentre -> + -- -w / 2 + -- , 0 + -- ) (html w h <| H.div [ style "width" "100%" diff --git a/src/Main.elm b/src/Main.elm index ceebd64..b3de7d1 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -31,6 +31,13 @@ import Time import Tuple exposing (first, second) import Url exposing (Url) import Utils exposing (textBox) +import Bootstrap.ListGroup as ListGroup +import Html +import Bootstrap.Utilities.Spacing as Spacing +import Bootstrap.Utilities.Flex as Flex +import Bootstrap.Utilities.Size as Size +import Bootstrap.ButtonGroup as ButtonGroup +import Bootstrap.Button as Button type Msg @@ -46,12 +53,16 @@ type Msg | VisibilityChanged Visibility | OpenLoginDialog | OpenLogoutDialog + | OpenLoadDialog | GetLoginStatus | LoginStatusChange (Result Http.Error LoginStatus) | EditMachineName | TypeName String | SaveMachine | MachineSaveResponse (Result Http.Error SaveLoad.SaveResponse) + | ListLoadResponse (Result Http.Error (List SaveLoad.LoadMetadata)) + | LoadMachine SaveLoad.LoadMetadata + | LoadMachineResponse (Result Http.Error SaveLoad.LoadPayload) | GetTime Time.Posix | NoOp @@ -109,9 +120,14 @@ type alias Model = } +type LoadDialog = + LoadNotOpen + | LoadLoading + | LoadOpen (List SaveLoad.LoadMetadata) + type alias SaveModel = { loginState : LoginStatus - , loginDialog : Bool + , loadDialog : LoadDialog , machineMetadata : SaveLoad.LoadMetadata , editingName : Bool , lastSaved : Time.Posix @@ -130,14 +146,24 @@ type alias ApplicationModel = initAppModel : BetterUndoList ApplicationModel initAppModel = - fresh - { appState = Building Building.init + fresh initAppRecord + + +initAppRecord = { appState = Building Building.init , sharedModel = SharedModel.init , simulatingData = Simulating.initPModel , buildingData = Building.initPModel , exportingData = Exporting.initPModel } +initSaveModel = { loginState = NotLoggedIn + , loadDialog = LoadNotOpen + , machineMetadata = { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0 } + , editingName = False + , lastSaved = Time.millisToPosix 0 + , unsavedChanges = True + } + main : App () Model Msg main = @@ -146,14 +172,7 @@ main = \flags url key -> ( { appModel = initAppModel , environment = Environment.init - , saveModel = - { loginState = NotLoggedIn - , loginDialog = False - , machineMetadata = { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0 } - , editingName = False - , lastSaved = Time.millisToPosix 0 - , unsavedChanges = False - } + , saveModel = initSaveModel } , Cmd.batch [ Task.perform (\vp -> WindowSize ( round vp.viewport.width, round vp.viewport.height )) Browser.Dom.getViewport @@ -213,7 +232,7 @@ moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel m model.appModel.present ( ( newM, newPModel, newSModel ), checkpoint, cmd ) = - mUpdate env mMsg ( mModel, pModel, currentAppState.sharedModel ) + mUpdate env (Debug.log "mMsg" mMsg) ( mModel, pModel, currentAppState.sharedModel ) newAppState = { currentAppState @@ -461,10 +480,13 @@ update msg model = ) OpenLoginDialog -> - ( { model | saveModel = { sm | loginDialog = not sm.loginDialog } }, Ports.launchLogin () ) + ( model , Ports.launchLogin () ) OpenLogoutDialog -> - ( { model | saveModel = { sm | loginDialog = not sm.loginDialog } }, Ports.launchLogout () ) + (model , Ports.launchLogout () ) + + OpenLoadDialog -> + ( { model | saveModel = { sm | loadDialog = LoadLoading } }, SaveLoad.loadList ListLoadResponse ) GetLoginStatus -> ( model, getLoginStatus ) @@ -538,6 +560,45 @@ update msg model = Cmd.none ) + ListLoadResponse response -> + case Debug.log "machineListResponse" response of + Ok machineList -> + ( { model | saveModel = { sm | loadDialog = LoadOpen machineList } }, Cmd.none ) + Err _ -> + ( { model | saveModel = { sm | loadDialog = LoadNotOpen } }, Cmd.none ) + + LoadMachine meta -> + ( { model | saveModel = { sm | machineMetadata = meta, loadDialog = LoadNotOpen }} + , SaveLoad.loadMachine meta.id LoadMachineResponse) + + LoadMachineResponse response -> + case Debug.log "loadMachineResponse" response of + Ok loadPayload -> + let + initSharedModel = SharedModel.init + newSharedModel = { initSharedModel | machine = loadPayload.machine } + initSimModel = Simulating.initPModel + + --{ appState = Building Building.init + --, sharedModel = SharedModel.init + --, simulatingData = Simulating.initPModel + --, buildingData = Building.initPModel + --, exportingData = Exporting.initPModel + --} + newModel = + fresh { + initAppRecord | + sharedModel = newSharedModel + , simulatingData = { initSimModel | tapes = Simulating.checkTapesNoStatus newSharedModel loadPayload.tapes } + } + in + ( { model | appModel = newModel + } + , Cmd.none) + Err _ -> + (model, Cmd.none) + + NoOp -> ( model, Cmd.none ) @@ -778,13 +839,7 @@ modeButtons model = |> move ( 0, -4 ) , group [ roundedRect 55 15 1 - |> filled - (if exporting then - finsmBlue - - else - blank - ) + |> filled blank |> addOutline (solid 1) darkGray , text "Log out" |> centered @@ -794,6 +849,18 @@ modeButtons model = ] |> move ( 40, 0 ) |> notifyTap OpenLogoutDialog + , group + [ roundedRect 85 15 1 + |> filled blank + |> addOutline (solid 1) darkGray + , text "My Machines" + |> centered + |> fixedwidth + |> filled black + |> move ( 0, -4 ) + ] + |> move ( 40, -20 ) + |> notifyTap OpenLoadDialog ] |> move ( winX / 2 - 100, winY / 2 - 15 ) @@ -804,43 +871,28 @@ modeButtons model = |> fixedwidth |> size 16 |> filled black - |> move ( -winX / 2 + 250, winY / 2 - 20 ) + |> move ( -winX / 2 + 175, winY / 2 - 20 ) |> notifyTap EditMachineName else textBox model.saveModel.machineMetadata.name 300 20 "Machine Name" TypeName - |> move ( -winX / 2 + 400, winY / 2 - 10 ) + |> move ( -winX / 2 + 325, winY / 2 - 10 ) , text (lastSaved model) |> fixedwidth |> size 14 |> filled darkGray - |> move ( -winX / 2 + 550, winY / 2 - 20 ) - , group - [ roundedRect 50 15 1 - |> filled - (if exporting then - finsmBlue - - else - blank - ) - |> addOutline (solid 1) darkGray - , text "Save" - |> centered - |> fixedwidth - |> filled - (if exporting then - white - - else - darkGray - ) - |> move ( 0, -4 ) - ] - |> move ( -winX / 2 + 183, winY / 2 - 15 ) - |> notifyTap SaveMachine + |> move ( -winX / 2 + 490, winY / 2 - 20 ) + , case model.saveModel.loadDialog of + LoadNotOpen -> group [] + LoadLoading -> group [text "Loading" |> fixedwidth |> centered |> size 24 |> filled black] + LoadOpen metas -> + let + (w,h) = model.environment.windowSize + in + GraphicSVG.html (toFloat w/2) (toFloat h/2) (renderLoadList (w//2) (h//2) metas) + |> move(-(toFloat w)/4,(toFloat h)/4) - --, if model.loginDialog then + --group (List.indexedMap (\n meta -> text (meta.name) |> filled black |> move(0,10*toFloat n)) metas) ] @@ -877,6 +929,27 @@ lastSaved model = _ -> "" +renderLoadList : Int -> Int -> List SaveLoad.LoadMetadata -> Html Msg +renderLoadList w h metas = + let + oneRow machine = + ListGroup.anchor + [ ListGroup.attrs [ Html.Events.onClick (LoadMachine machine), Flex.col, Flex.alignItemsStart ] + ] + [ Html.div [ Flex.block, Flex.justifyBetween, Size.w100 ] + [ Html.h5 [ Spacing.mb1 ] [ Html.text machine.name ] + , Html.small [] [ Html.text "3 days ago" ] + ] + , ButtonGroup.buttonGroup [ButtonGroup.attrs [style "float" "right"]] + [ ButtonGroup.button [ Button.primary, Button.small ] [ Html.text "Load" ] + , ButtonGroup.button [ Button.danger, Button.small ] [ Html.text "Archive" ] + ] + ] + in + Html.div [style "overflow" "scroll", style "width" (String.fromInt w ++ "px"), style "height" (String.fromInt h ++ "px"), style "position" "fixed"] + [ Html.h3 [] [Html.text "Load a saved machine"] + ,ListGroup.custom (List.map oneRow metas)] + errorEpsTrans model = let diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm index 77b1191..e04b6f8 100644 --- a/src/SaveLoad.elm +++ b/src/SaveLoad.elm @@ -100,7 +100,7 @@ archiveMachine id toMsg = type alias LoadPayload = { machine : Machine - , tape : InputTape + , tapes : Dict Int InputTape } @@ -108,16 +108,16 @@ decodeLoadPayload : D.Decoder LoadPayload decodeLoadPayload = D.map2 LoadPayload (D.field "machine" Machine.machineDecoder) - (D.field "tape" Simulating.inputTapeDecoder) + (D.field "tape" Simulating.inputTapeDictDecoder) -loadMachine : String -> String -> Posix -> String -> (Result Http.Error Machine -> msg) -> Cmd msg -loadMachine name desc time uuid toMsg = +loadMachine : String -> (Result Http.Error LoadPayload -> msg) -> Cmd msg +loadMachine uuid toMsg = Http.send toMsg <| Http.post "/api/machine/load" (Http.jsonBody <| E.string uuid) - Machine.machineDecoder + decodeLoadPayload loadList : (Result Http.Error (List LoadMetadata) -> msg) -> Cmd msg diff --git a/src/Simulating.elm b/src/Simulating.elm index 3103df0..c9dd918 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -1,4 +1,4 @@ -module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, delta, deltaHat, epsTrans, initPModel, inputTapeDecoder, inputTapeEncoder, isAccept, latexKeyboard, machineDefn, machineModeButtons, onEnter, onExit, renderTape, subscriptions, update, view) +module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, delta, deltaHat, epsTrans, initPModel, inputTapeDecoder, inputTapeEncoder, isAccept, latexKeyboard, machineDefn, machineModeButtons, onEnter, onExit, renderTape, subscriptions, update, view, inputTapeDictDecoder, checkTapesNoStatus) import Array exposing (Array) import Browser.Events @@ -16,7 +16,7 @@ import Set exposing (Set) import SharedModel exposing (..) import Task import Tuple exposing (first, second) -import Utils exposing (encodeDict) +import Utils exposing (encodeDict, decodeDict) subscriptions : Model -> Sub Msg @@ -40,6 +40,10 @@ inputTapeDecoder = D.map Array.fromList (D.list D.string) +inputTapeDictDecoder : D.Decoder (Dict Int InputTape) +inputTapeDictDecoder = + decodeDict D.int inputTapeDecoder + type alias InputTape = Array Character @@ -111,6 +115,10 @@ checkTapes : SharedModel -> Dict Int ( InputTape, TapeStatus ) -> Dict Int ( Inp checkTapes sModel tapes = Dict.map (\k ( tape, _ ) -> ( tape, checkTape sModel tape )) tapes +checkTapesNoStatus : SharedModel -> Dict Int InputTape -> Dict Int ( InputTape, TapeStatus ) +checkTapesNoStatus sModel tapes = + Dict.map (\k tape -> ( tape, checkTape sModel tape )) tapes + checkTape : SharedModel -> InputTape -> TapeStatus checkTape sModel inp = From 23b7486aa78989c164c939c0786588f10c45b1e1 Mon Sep 17 00:00:00 2001 From: CSchank Date: Tue, 11 Feb 2020 21:39:59 -0500 Subject: [PATCH 25/27] final draft of saving --- src/ApplicationModel.elm | 21 + src/Environment.elm | 2 + src/Main.elm | 447 ++++-------------- src/SaveLoad.elm | 965 ++++++++++++++++++++++++++++++++++++++- src/Simulating.elm | 6 +- src/Utils.elm | 6 + 6 files changed, 1084 insertions(+), 363 deletions(-) create mode 100644 src/ApplicationModel.elm diff --git a/src/ApplicationModel.elm b/src/ApplicationModel.elm new file mode 100644 index 0000000..848c9d3 --- /dev/null +++ b/src/ApplicationModel.elm @@ -0,0 +1,21 @@ +module ApplicationModel exposing (..) + +import Building +import Exporting +import SharedModel exposing (SharedModel) +import Simulating + + +type ApplicationState + = Building Building.Model + | Simulating Simulating.Model + | Exporting Exporting.Model + + +type alias ApplicationModel = + { appState : ApplicationState + , simulatingData : Simulating.PersistentModel + , buildingData : Building.PersistentModel + , exportingData : Exporting.PersistentModel + , sharedModel : SharedModel + } diff --git a/src/Environment.elm b/src/Environment.elm index ec4788e..09c41e2 100644 --- a/src/Environment.elm +++ b/src/Environment.elm @@ -10,6 +10,7 @@ init = , holdingControl = False , holdingMeta = False , currentTime = Time.millisToPosix 1576798602274 + , timeZone = Time.utc } @@ -19,4 +20,5 @@ type alias Environment = , holdingControl : Bool , holdingMeta : Bool , currentTime : Time.Posix + , timeZone : Time.Zone } diff --git a/src/Main.elm b/src/Main.elm index b3de7d1..c1aa6b5 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -1,20 +1,20 @@ -module Main exposing (ApplicationModel, ApplicationState(..), Model, Module(..), Msg(..), initAppModel, main, modeButtons, textHtml, update, view) +module Main exposing (Model, Module(..), Msg(..), initAppModel, main, modeButtons, textHtml, update, view) +import ApplicationModel exposing (ApplicationModel, ApplicationState(..)) import Array exposing (Array) import BetterUndoList exposing (..) +import Bootstrap.Modal as Modal import Browser exposing (UrlRequest) import Browser.Dom import Browser.Events exposing (Visibility) import Building import Dict exposing (Dict) -import Duration import Environment exposing (Environment) import Exporting import GraphicSVG exposing (..) import Helpers exposing (finsmBlue, icon, sendMsg) import Html as H exposing (Html, input, node) -import Html.Attributes exposing (attribute, placeholder, style, value) -import Html.Events exposing (onInput) +import Html.Attributes import Http import Json.Decode as D import Json.Encode @@ -30,20 +30,13 @@ import Task import Time import Tuple exposing (first, second) import Url exposing (Url) -import Utils exposing (textBox) -import Bootstrap.ListGroup as ListGroup -import Html -import Bootstrap.Utilities.Spacing as Spacing -import Bootstrap.Utilities.Flex as Flex -import Bootstrap.Utilities.Size as Size -import Bootstrap.ButtonGroup as ButtonGroup -import Bootstrap.Button as Button type Msg = BMsg Building.Msg | SMsg Simulating.Msg | EMsg Exporting.Msg + | SaveMsg SaveLoad.Msg | KeyPressed String | KeyReleased String | WindowSize ( Int, Int ) @@ -51,96 +44,21 @@ type Msg | UrlRequest UrlRequest | GoTo Module | VisibilityChanged Visibility - | OpenLoginDialog - | OpenLogoutDialog - | OpenLoadDialog - | GetLoginStatus - | LoginStatusChange (Result Http.Error LoginStatus) - | EditMachineName - | TypeName String - | SaveMachine - | MachineSaveResponse (Result Http.Error SaveLoad.SaveResponse) - | ListLoadResponse (Result Http.Error (List SaveLoad.LoadMetadata)) - | LoadMachine SaveLoad.LoadMetadata - | LoadMachineResponse (Result Http.Error SaveLoad.LoadPayload) | GetTime Time.Posix + | GetTZ Time.Zone | NoOp -loginStatusDecoder : D.Decoder LoginStatus -loginStatusDecoder = - D.field "loggedin" D.bool - |> D.andThen - (\loggedIn -> - if loggedIn then - D.map LoggedIn (D.field "email" D.string) - - else - D.succeed NotLoggedIn - ) - - -getLoginStatus : Cmd Msg -getLoginStatus = - Http.send LoginStatusChange <| - Http.post - "/accounts/loginstate/" - Http.emptyBody - loginStatusDecoder - - type Module = BuildingModule | SimulatingModule | ExportingModule -type ApplicationState - = Building Building.Model - | Simulating Simulating.Model - | Exporting Exporting.Model - - -type LoginStatus - = LoggedIn String - | NotLoggedIn - | LoggingIn - - -type SaveStatus - = NotSaved - | LastSaved Time.Posix - | Saved Time.Posix - - type alias Model = { appModel : BetterUndoList ApplicationModel , environment : Environment - , saveModel : SaveModel - } - - -type LoadDialog = - LoadNotOpen - | LoadLoading - | LoadOpen (List SaveLoad.LoadMetadata) - -type alias SaveModel = - { loginState : LoginStatus - , loadDialog : LoadDialog - , machineMetadata : SaveLoad.LoadMetadata - , editingName : Bool - , lastSaved : Time.Posix - , unsavedChanges : Bool - } - - -type alias ApplicationModel = - { appState : ApplicationState - , simulatingData : Simulating.PersistentModel - , buildingData : Building.PersistentModel - , exportingData : Exporting.PersistentModel - , sharedModel : SharedModel + , saveModel : SaveLoad.Model } @@ -149,20 +67,13 @@ initAppModel = fresh initAppRecord -initAppRecord = { appState = Building Building.init - , sharedModel = SharedModel.init - , simulatingData = Simulating.initPModel - , buildingData = Building.initPModel - , exportingData = Exporting.initPModel - } - -initSaveModel = { loginState = NotLoggedIn - , loadDialog = LoadNotOpen - , machineMetadata = { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0 } - , editingName = False - , lastSaved = Time.millisToPosix 0 - , unsavedChanges = True - } +initAppRecord = + { appState = Building Building.init + , sharedModel = SharedModel.init + , simulatingData = Simulating.initPModel + , buildingData = Building.initPModel + , exportingData = Exporting.initPModel + } main : App () Model Msg @@ -170,14 +81,19 @@ main = app { init = \flags url key -> + let + ( initSave, saveCmd ) = + SaveLoad.initSaveModel + in ( { appModel = initAppModel , environment = Environment.init - , saveModel = initSaveModel + , saveModel = initSave } , Cmd.batch [ Task.perform (\vp -> WindowSize ( round vp.viewport.width, round vp.viewport.height )) Browser.Dom.getViewport - , getLoginStatus , Task.perform GetTime Time.now + , Cmd.map SaveMsg saveCmd + , Task.perform GetTZ Time.here ] ) , update = update @@ -198,10 +114,8 @@ main = Exporting m -> Sub.map EMsg (Exporting.subscriptions m) - , Browser.Events.onVisibilityChange (\_ -> GetLoginStatus) - , Ports.loginComplete (\_ -> GetLoginStatus) - , Ports.logoutComplete (\_ -> GetLoginStatus) , Time.every 5000 GetTime -- get the new time every 10 seconds + , Sub.map SaveMsg (SaveLoad.subscriptions model.saveModel) ] , onUrlChange = UrlChange , onUrlRequest = UrlRequest @@ -243,9 +157,6 @@ moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel m sm = model.saveModel - - cp = - Debug.log "unsavedChanges" sm.unsavedChanges in ( { model | appModel = @@ -479,105 +390,29 @@ update msg model = , Cmd.none ) - OpenLoginDialog -> - ( model , Ports.launchLogin () ) - - OpenLogoutDialog -> - (model , Ports.launchLogout () ) - - OpenLoadDialog -> - ( { model | saveModel = { sm | loadDialog = LoadLoading } }, SaveLoad.loadList ListLoadResponse ) - - GetLoginStatus -> - ( model, getLoginStatus ) - - LoginStatusChange loginStatus -> - case loginStatus of - Ok loginState -> - ( { model | saveModel = { sm | loginState = loginState } }, Cmd.none ) - - Err _ -> - ( model, Cmd.none ) - - EditMachineName -> - ( { model | saveModel = { sm | editingName = True } }, Cmd.none ) - - TypeName n -> - let - meta = - model.saveModel.machineMetadata - in - ( { model | saveModel = { sm | machineMetadata = { meta | name = n } } }, Cmd.none ) - - SaveMachine -> - ( model - , saveMachine - model.saveModel.machineMetadata.name - model.saveModel.machineMetadata.description - model.appModel.present.sharedModel.machine - model.saveModel.machineMetadata.id - model.appModel.present.simulatingData.tapes - MachineSaveResponse - ) - - MachineSaveResponse saveresp -> - let - meta = - model.saveModel.machineMetadata - in - case saveresp of - Ok oksaveresp -> - ( { model - | saveModel = - { sm - | machineMetadata = { meta | id = oksaveresp.uuid } - , lastSaved = model.environment.currentTime - , unsavedChanges = False - } - } - , Cmd.none - ) - - Err _ -> - ( model, Cmd.none ) - GetTime time -> let oldEnv = model.environment in ( { model | environment = { oldEnv | currentTime = time } } - , if sm.unsavedChanges then - saveMachine - model.saveModel.machineMetadata.name - model.saveModel.machineMetadata.description - model.appModel.present.sharedModel.machine - model.saveModel.machineMetadata.id - model.appModel.present.simulatingData.tapes - MachineSaveResponse - - else - Cmd.none + , Cmd.none ) - ListLoadResponse response -> - case Debug.log "machineListResponse" response of - Ok machineList -> - ( { model | saveModel = { sm | loadDialog = LoadOpen machineList } }, Cmd.none ) - Err _ -> - ( { model | saveModel = { sm | loadDialog = LoadNotOpen } }, Cmd.none ) + SaveMsg saveMsg -> + case saveMsg of + SaveLoad.LoadMachineResponse response -> + case Debug.log "loadMachineResponse" response of + Ok loadPayload -> + let + initSharedModel = + SharedModel.init - LoadMachine meta -> - ( { model | saveModel = { sm | machineMetadata = meta, loadDialog = LoadNotOpen }} - , SaveLoad.loadMachine meta.id LoadMachineResponse) + newSharedModel = + { initSharedModel | machine = loadPayload.machine } - LoadMachineResponse response -> - case Debug.log "loadMachineResponse" response of - Ok loadPayload -> - let - initSharedModel = SharedModel.init - newSharedModel = { initSharedModel | machine = loadPayload.machine } - initSimModel = Simulating.initPModel + initSimModel = + Simulating.initPModel --{ appState = Building Building.init --, sharedModel = SharedModel.init @@ -585,19 +420,75 @@ update msg model = --, buildingData = Building.initPModel --, exportingData = Exporting.initPModel --} + newModel = + fresh + { initAppRecord + | sharedModel = newSharedModel + , simulatingData = { initSimModel | tapes = Simulating.checkTapesNoStatus newSharedModel loadPayload.tapes } + } + in + ( { model + | appModel = newModel + , saveModel = + let + meta = + sm.machineMetadata + in + { sm | lastSaved = oldEnvironment.currentTime, machineData = SaveLoad.MachineCreated, machineMetadata = { meta | name = loadPayload.name, id = loadPayload.uuid } } + } + , Cmd.none + ) + + Err _ -> + ( model, Cmd.none ) + + SaveLoad.CreateNewMachine -> + let + initSharedModel = + SharedModel.init + + newSharedModel = + initSharedModel + + initSimModel = + Simulating.initPModel + + --{ appState = Building Building.init + --, sharedModel = SharedModel.init + --, simulatingData = Simulating.initPModel + --, buildingData = Building.initPModel + --, exportingData = Exporting.initPModel + --} newModel = - fresh { - initAppRecord | - sharedModel = newSharedModel - , simulatingData = { initSimModel | tapes = Simulating.checkTapesNoStatus newSharedModel loadPayload.tapes } + fresh + { initAppRecord + | sharedModel = newSharedModel + , simulatingData = initSimModel } in - ( { model | appModel = newModel + ( { model + | appModel = newModel + , saveModel = + { sm + | lastSaved = oldEnvironment.currentTime + , machineData = SaveLoad.MachineCreated + , loadDialog = SaveLoad.NothingOpen + , loadDialogModal = Modal.hidden + , machineMetadata = SaveLoad.initMachineMetadata + } } - , Cmd.none) - Err _ -> - (model, Cmd.none) + , Cmd.none + ) + other -> + let + ( newSM, sCmd ) = + SaveLoad.update other model.saveModel model.environment model.appModel.present + in + ( { model | saveModel = newSM }, Cmd.map SaveMsg sCmd ) + + GetTZ zone -> + ( { model | environment = { oldEnvironment | timeZone = zone } }, Cmd.none ) NoOp -> ( model, Cmd.none ) @@ -809,148 +700,10 @@ modeButtons model = ] |> move ( -winX / 2 + 134, winY / 2 - 15 ) |> notifyTap (GoTo ExportingModule) - , case model.saveModel.loginState of - NotLoggedIn -> - group - [ roundedRect 50 15 1 - |> filled - (if exporting then - finsmBlue - - else - blank - ) - |> addOutline (solid 1) darkGray - , text "Log in" - |> centered - |> fixedwidth - |> filled black - |> move ( 0, -4 ) - ] - |> move ( winX / 2 - 50, winY / 2 - 15 ) - |> notifyTap OpenLoginDialog - - LoggedIn email -> - group - [ text ("Welcome " ++ email) - |> alignRight - |> fixedwidth - |> filled black - |> move ( 0, -4 ) - , group - [ roundedRect 55 15 1 - |> filled blank - |> addOutline (solid 1) darkGray - , text "Log out" - |> centered - |> fixedwidth - |> filled black - |> move ( 0, -4 ) - ] - |> move ( 40, 0 ) - |> notifyTap OpenLogoutDialog - , group - [ roundedRect 85 15 1 - |> filled blank - |> addOutline (solid 1) darkGray - , text "My Machines" - |> centered - |> fixedwidth - |> filled black - |> move ( 0, -4 ) - ] - |> move ( 40, -20 ) - |> notifyTap OpenLoadDialog - ] - |> move ( winX / 2 - 100, winY / 2 - 15 ) - - _ -> - group [] - , if not model.saveModel.editingName then - text model.saveModel.machineMetadata.name - |> fixedwidth - |> size 16 - |> filled black - |> move ( -winX / 2 + 175, winY / 2 - 20 ) - |> notifyTap EditMachineName - - else - textBox model.saveModel.machineMetadata.name 300 20 "Machine Name" TypeName - |> move ( -winX / 2 + 325, winY / 2 - 10 ) - , text (lastSaved model) - |> fixedwidth - |> size 14 - |> filled darkGray - |> move ( -winX / 2 + 490, winY / 2 - 20 ) - , case model.saveModel.loadDialog of - LoadNotOpen -> group [] - LoadLoading -> group [text "Loading" |> fixedwidth |> centered |> size 24 |> filled black] - LoadOpen metas -> - let - (w,h) = model.environment.windowSize - in - GraphicSVG.html (toFloat w/2) (toFloat h/2) (renderLoadList (w//2) (h//2) metas) - |> move(-(toFloat w)/4,(toFloat h)/4) - - --group (List.indexedMap (\n meta -> text (meta.name) |> filled black |> move(0,10*toFloat n)) metas) + , GraphicSVG.map SaveMsg <| SaveLoad.view model.saveModel model.environment ] -lastSaved : Model -> String -lastSaved model = - let - duration = - Duration.from model.saveModel.lastSaved model.environment.currentTime - in - if not model.saveModel.unsavedChanges then - if Duration.inSeconds duration <= 30 then - "last edit saved just now" - - else if Duration.inSeconds duration <= 90 then - "last edit saved about a minute ago" - - else if Duration.inMinutes duration <= 60 then - "last edit saved " ++ String.fromInt (round <| Duration.inMinutes duration) ++ " minutes ago" - - else if Duration.inMinutes duration <= 90 then - "last edit saved about an hour ago" - - else - "last edit saved " ++ String.fromInt (round <| Duration.inHours duration) ++ " hours ago" - - else - case model.saveModel.loginState of - LoggedIn _ -> - "saving..." - - NotLoggedIn -> - "log in to save changes" - - _ -> - "" - -renderLoadList : Int -> Int -> List SaveLoad.LoadMetadata -> Html Msg -renderLoadList w h metas = - let - oneRow machine = - ListGroup.anchor - [ ListGroup.attrs [ Html.Events.onClick (LoadMachine machine), Flex.col, Flex.alignItemsStart ] - ] - [ Html.div [ Flex.block, Flex.justifyBetween, Size.w100 ] - [ Html.h5 [ Spacing.mb1 ] [ Html.text machine.name ] - , Html.small [] [ Html.text "3 days ago" ] - ] - , ButtonGroup.buttonGroup [ButtonGroup.attrs [style "float" "right"]] - [ ButtonGroup.button [ Button.primary, Button.small ] [ Html.text "Load" ] - , ButtonGroup.button [ Button.danger, Button.small ] [ Html.text "Archive" ] - ] - ] - in - Html.div [style "overflow" "scroll", style "width" (String.fromInt w ++ "px"), style "height" (String.fromInt h ++ "px"), style "position" "fixed"] - [ Html.h3 [] [Html.text "Load a saved machine"] - ,ListGroup.custom (List.map oneRow metas)] - - errorEpsTrans model = let winX = diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm index e04b6f8..6c5fc2c 100644 --- a/src/SaveLoad.elm +++ b/src/SaveLoad.elm @@ -1,12 +1,120 @@ module SaveLoad exposing (..) +import ApplicationModel exposing (ApplicationModel) +import Bootstrap.Button as Button +import Bootstrap.ButtonGroup as ButtonGroup +import Bootstrap.Card as Card +import Bootstrap.Card.Block as Block +import Bootstrap.ListGroup as ListGroup +import Bootstrap.Modal as Modal +import Bootstrap.Spinner as Spinner +import Bootstrap.Tab as Tab +import Bootstrap.Text as Text +import Bootstrap.Utilities.Flex as Flex +import Bootstrap.Utilities.Size as Size +import Bootstrap.Utilities.Spacing as Spacing +import Browser.Events import Dict exposing (Dict) +import Duration +import Environment exposing (Environment) +import GraphicSVG exposing (..) +import Html exposing (Html) +import Html.Attributes exposing (attribute, placeholder, style, value) +import Html.Events exposing (onInput) import Http import Json.Decode as D import Json.Encode as E import Machine exposing (Machine) +import Ports import Simulating exposing (InputTape) import Time exposing (Posix) +import Utils exposing (newMsg, textBox) + + +type MachineType + = DFA + | NFA + | NPDA + | Turing + + +type FilterType + = FilterActive + | MachineFilter MachineType + | FilterArchived + + +filterToString : FilterType -> String +filterToString f = + case f of + FilterActive -> + "all" + + MachineFilter m -> + machineTypeStr m + + FilterArchived -> + "arc" + + +decodeMachineType : D.Decoder MachineType +decodeMachineType = + D.string + |> D.andThen + (\m -> + case m of + "D" -> + D.succeed DFA + + "N" -> + D.succeed NFA + + "P" -> + D.succeed NPDA + + "T" -> + D.succeed Turing + + s -> + D.fail <| "Invalid string " ++ s ++ " for machine type" + ) + + +encodeMachineType : MachineType -> E.Value +encodeMachineType = + E.string << machineTypeStr + + +machineTypeStr : MachineType -> String +machineTypeStr m = + case m of + DFA -> + "D" + + NFA -> + "N" + + NPDA -> + "P" + + Turing -> + "T" + + +machineTypeFullStr : MachineType -> String +machineTypeFullStr m = + case m of + DFA -> + "DFA" + + NFA -> + "NFA" + + NPDA -> + "NPDA" + + Turing -> + "Turing" type alias LoadMetadata = @@ -14,16 +122,18 @@ type alias LoadMetadata = , name : String , date : Posix , description : String + , machine_type : MachineType } decodeMetadataV1 : D.Decoder LoadMetadata decodeMetadataV1 = - D.map4 LoadMetadata + D.map5 LoadMetadata (D.field "id" D.string) (D.field "name" D.string) (D.field "date" <| D.map Time.millisToPosix D.int) (D.field "desc" D.string) + (D.field "type" decodeMachineType) decodeMetadata : D.Decoder LoadMetadata @@ -55,8 +165,8 @@ encodeMachinePayload = -- sending an existing id will overwrite the machine saved with that id -encodeMachinePayloadV1 : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> E.Value -encodeMachinePayloadV1 name desc machine uuid inputTape = +encodeMachinePayloadV1 : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> MachineType -> E.Value +encodeMachinePayloadV1 name desc machine uuid inputTape machine_type = E.object [ ( "name", E.string name ) , ( "desc", E.string desc ) @@ -64,6 +174,7 @@ encodeMachinePayloadV1 name desc machine uuid inputTape = , ( "v", E.int 1 ) , ( "uuid", E.string uuid ) , ( "tape", Simulating.inputTapeEncoder inputTape ) + , ( "type", encodeMachineType machine_type ) ] @@ -80,35 +191,63 @@ decodeSaveResponse = (D.field "uuid" D.string) -saveMachine : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> (Result Http.Error SaveResponse -> msg) -> Cmd msg -saveMachine name desc machine uuid inputTape toMsg = +saveMachine : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> MachineType -> (Result Http.Error SaveResponse -> msg) -> Cmd msg +saveMachine name desc machine uuid inputTape machine_type toMsg = Http.send toMsg <| Http.post "/api/machine/save" - (Http.jsonBody <| encodeMachinePayload name desc machine uuid inputTape) + (Http.jsonBody <| encodeMachinePayload name desc machine uuid inputTape machine_type) decodeSaveResponse -archiveMachine : Int -> (Result Http.Error Bool -> msg) -> Cmd msg -archiveMachine id toMsg = +type alias ArchivePayload = + { uuid : String + , restore : Bool + } + + +encodeArchivePayload : ArchivePayload -> E.Value +encodeArchivePayload ap = + E.object + [ ( "uuid", E.string ap.uuid ) + , ( "restore", E.bool ap.restore ) + ] + + +archiveMachine : ArchivePayload -> (Result Http.Error ArchiveResponse -> msg) -> Cmd msg +archiveMachine payload toMsg = Http.send toMsg <| Http.post "/api/machine/archive" - (Http.jsonBody <| E.int id) - D.bool + (Http.jsonBody <| encodeArchivePayload payload) + decodeArchiveResponse type alias LoadPayload = { machine : Machine , tapes : Dict Int InputTape + , name : String + , uuid : String } +type alias ArchiveResponse = + { success : Bool + } + + +decodeArchiveResponse : D.Decoder ArchiveResponse +decodeArchiveResponse = + D.map ArchiveResponse (D.field "success" <| D.bool) + + decodeLoadPayload : D.Decoder LoadPayload decodeLoadPayload = - D.map2 LoadPayload + D.map4 LoadPayload (D.field "machine" Machine.machineDecoder) (D.field "tape" Simulating.inputTapeDictDecoder) + (D.field "name" D.string) + (D.field "uuid" D.string) loadMachine : String -> (Result Http.Error LoadPayload -> msg) -> Cmd msg @@ -120,10 +259,808 @@ loadMachine uuid toMsg = decodeLoadPayload -loadList : (Result Http.Error (List LoadMetadata) -> msg) -> Cmd msg -loadList toMsg = +loadList : FilterType -> (Result Http.Error (List LoadMetadata) -> msg) -> Cmd msg +loadList machineType toMsg = Http.send toMsg <| Http.post "/api/machine/list" - Http.emptyBody + (Http.stringBody "text/plain" <| filterToString machineType) decodeMachineList + + +type Msg + = OpenLoginDialog + | OpenLogoutDialog + | MachineCreatedMsg MachineCreatedMsg + | GetLoginStatus + | ArchiveMachine String + | RestoreMachine String + | LoginStatusChange (Result Http.Error LoginStatus) + | InitLoginStatus (Result Http.Error LoginStatus) + | LoadMachine LoadMetadata + | LoadMachineResponse (Result Http.Error LoadPayload) + | ArchiveMachineResponse (Result Http.Error ArchiveResponse) + | SelectFilter FilterType + | OpenLoadDialog + | OpenNewDialog + | CloseLoadDialog + | ListLoadResponse (Result Http.Error (List LoadMetadata)) + | ModalAnimation Modal.Visibility + | CreateNewMachine + + + +-- messages that can only be sent when there is a machine loaded + + +type MachineCreatedMsg + = EditMachineName + | TypeName String + | SaveMachine + | MachineSaveResponse (Result Http.Error SaveResponse) + | AutoSave Posix + | TabMsg Tab.State + + +loginStatusDecoder : D.Decoder LoginStatus +loginStatusDecoder = + D.field "loggedin" D.bool + |> D.andThen + (\loggedIn -> + if loggedIn then + D.map2 LoggedIn + (D.field "email" D.string) + (D.map + (\s -> + if s == "" then + Nothing + + else + Just s + ) + <| + D.field "newestMachine" D.string + ) + + else + D.succeed NotLoggedIn + ) + + +getInitLoginStatus : Cmd Msg +getInitLoginStatus = + Http.send InitLoginStatus <| + Http.post + "/accounts/loginstate/" + Http.emptyBody + loginStatusDecoder + + +getLoginStatus : Cmd Msg +getLoginStatus = + Http.send LoginStatusChange <| + Http.post + "/accounts/loginstate/" + Http.emptyBody + loginStatusDecoder + + +type LoginStatus + = LoggedIn String {- username -} (Maybe String) {- latest machine -} + | NotLoggedIn + | LoggingIn + + +initSaveModel = + ( { loginState = NotLoggedIn + , machineData = MachineNotCreated + , loadDialog = NothingOpen + , loadDialogModal = Modal.shown + , machineMetadata = initMachineMetadata + , tabState = Tab.initialState + , loadingList = Nothing + , editingName = False + , lastSaved = Time.millisToPosix 0 + , unsavedChanges = False + , loadFilter = FilterActive + } + , Cmd.batch [ getInitLoginStatus ] + ) + + +initMachineMetadata = + { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0, machine_type = DFA } + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.batch <| + [ Browser.Events.onVisibilityChange (\_ -> GetLoginStatus) + , Ports.loginComplete (\_ -> GetLoginStatus) + , Ports.logoutComplete (\_ -> GetLoginStatus) + , Modal.subscriptions model.loadDialogModal ModalAnimation + ] + ++ (case model.machineData of + MachineCreated -> + if model.unsavedChanges then + [ Time.every 5000 (MachineCreatedMsg << AutoSave) ] + + else + [] + + MachineNotCreated -> + [] + ) + + +type alias Model = + { loginState : LoginStatus + , tabState : Tab.State + , machineData : MachineCreated + , loadDialog : DialogStatus + , machineMetadata : LoadMetadata + , loadDialogModal : Modal.Visibility + , loadingList : Maybe FilterType + , editingName : Bool + , lastSaved : Time.Posix + , unsavedChanges : Bool + , loadFilter : FilterType + } + + +type MachineCreated + = MachineCreated + | MachineNotCreated + + +type DialogStatus + = NothingOpen + | LoadLoading + | LoadOpen (List LoadMetadata) + | NewOpen + + +type SaveStatus + = NotSaved + | LastSaved Time.Posix + | Saved Time.Posix + + +update : Msg -> Model -> Environment -> ApplicationModel -> ( Model, Cmd Msg ) +update msg model env appModel = + let + m = + Debug.log "model" model + in + case msg of + OpenLoadDialog -> + ( { m | loadDialog = LoadLoading } + , Cmd.batch + [ loadList FilterActive ListLoadResponse + , if model.unsavedChanges then + newMsg (MachineCreatedMsg SaveMachine) + + else + Cmd.none + ] + ) + + ListLoadResponse response -> + case Debug.log "machineListResponse" response of + Ok machineList -> + ( { model | loadDialog = LoadOpen machineList, loadDialogModal = Modal.shown, loadingList = Nothing, machineData = MachineCreated }, Cmd.none ) + + Err _ -> + ( { model | loadDialog = NothingOpen }, Cmd.none ) + + LoadMachine meta -> + ( { model | machineMetadata = meta, loadDialog = NothingOpen } + , loadMachine meta.id LoadMachineResponse + ) + + -- handled by Main.elm + LoadMachineResponse _ -> + ( model, Cmd.none ) + + SelectFilter filter_type -> + ( { model + | tabState = Tab.customInitialState (filterToString filter_type) + , loadingList = Just filter_type + , loadFilter = filter_type + , loadDialog = LoadOpen [] + } + , loadList filter_type ListLoadResponse + ) + + OpenLoginDialog -> + ( { model | loginState = LoggingIn }, Ports.launchLogin () ) + + OpenLogoutDialog -> + ( model, Ports.launchLogout () ) + + GetLoginStatus -> + ( model, getLoginStatus ) + + LoginStatusChange loginStatus -> + case loginStatus of + Ok loginState -> + ( { model | loginState = loginState }, Cmd.none ) + + Err _ -> + ( model, Cmd.none ) + + InitLoginStatus loginStatus -> + case Debug.log "loginStatus" loginStatus of + Ok loginState -> + ( { model + | loginState = loginState + , loadDialog = + case loginState of + LoggedIn email latestMachine -> + NothingOpen + + NotLoggedIn -> + NewOpen + + LoggingIn -> + NothingOpen + , loadDialogModal = Modal.shown + } + , case loginState of + LoggedIn _ (Just uuid) -> + loadMachine uuid LoadMachineResponse + + _ -> + Cmd.none + ) + + Err _ -> + ( model, Cmd.none ) + + ArchiveMachine uuid -> + ( model + , archiveMachine { uuid = uuid, restore = False } ArchiveMachineResponse + ) + + RestoreMachine uuid -> + ( model + , archiveMachine { uuid = uuid, restore = True } ArchiveMachineResponse + ) + + ArchiveMachineResponse archiveResponse -> + ( model, loadList model.loadFilter ListLoadResponse ) + + MachineCreatedMsg mcMsg -> + case model.machineData of + MachineCreated -> + let + ( newModel, mcCmd ) = + machineCreatedUpdate env appModel mcMsg model + in + ( newModel, Cmd.map MachineCreatedMsg mcCmd ) + + _ -> + ( model, Cmd.none ) + + CloseLoadDialog -> + ( { model | loadDialogModal = Modal.hidden, loadDialog = NothingOpen }, Cmd.none ) + + ModalAnimation v -> + ( { model | loadDialogModal = v }, Cmd.none ) + + OpenNewDialog -> + ( { model | loadDialog = NewOpen, loadDialogModal = Modal.shown }, Cmd.none ) + + -- handled in Main.elm + CreateNewMachine -> + ( model, Cmd.none ) + + +machineCreatedUpdate : Environment -> ApplicationModel -> MachineCreatedMsg -> Model -> ( Model, Cmd MachineCreatedMsg ) +machineCreatedUpdate env appModel msg model = + case msg of + EditMachineName -> + ( { model | editingName = True }, Cmd.none ) + + TypeName n -> + let + meta = + model.machineMetadata + in + ( { model | machineMetadata = { meta | name = n } }, Cmd.none ) + + SaveMachine -> + ( model + , saveMachine + model.machineMetadata.name + model.machineMetadata.description + appModel.sharedModel.machine + model.machineMetadata.id + appModel.simulatingData.tapes + model.machineMetadata.machine_type + MachineSaveResponse + ) + + MachineSaveResponse saveresp -> + let + meta = + model.machineMetadata + in + case saveresp of + Ok oksaveresp -> + ( { model + | machineMetadata = { meta | id = oksaveresp.uuid } + , lastSaved = env.currentTime + , unsavedChanges = False + } + , Cmd.none + ) + + Err _ -> + ( model, Cmd.none ) + + AutoSave time -> + ( model + , if model.unsavedChanges then + saveMachine + model.machineMetadata.name + model.machineMetadata.description + appModel.sharedModel.machine + model.machineMetadata.id + appModel.simulatingData.tapes + model.machineMetadata.machine_type + MachineSaveResponse + + else + Cmd.none + ) + + TabMsg state -> + ( { model | tabState = state }, Cmd.none ) + + +view : Model -> Environment -> Shape Msg +view model env = + let + winX = + toFloat <| Tuple.first env.windowSize + + winY = + toFloat <| Tuple.second env.windowSize + in + group + [ case model.loginState of + NotLoggedIn -> + group + [ roundedRect 50 15 1 + |> filled blank + |> addOutline (solid 1) darkGray + , text "Log in" + |> centered + |> fixedwidth + |> filled black + |> move ( 0, -4 ) + ] + |> move ( winX / 2 - 50, winY / 2 - 15 ) + |> notifyTap OpenLoginDialog + + LoggedIn email lastMachine -> + group + [ text ("Welcome " ++ email) + |> alignRight + |> fixedwidth + |> filled black + |> move ( 0, -4 ) + , group + [ roundedRect 55 15 1 + |> filled blank + |> addOutline (solid 1) darkGray + , text "Log out" + |> centered + |> fixedwidth + |> filled black + |> move ( 0, -4 ) + ] + |> move ( 40, 0 ) + |> notifyTap OpenLogoutDialog + , group + [ roundedRect 85 15 1 + |> filled blank + |> addOutline (solid 1) darkGray + , text "My Machines" + |> centered + |> fixedwidth + |> filled black + |> move ( 0, -4 ) + ] + |> move ( 40, -20 ) + |> notifyTap OpenLoadDialog + ] + |> move ( winX / 2 - 100, winY / 2 - 15 ) + + _ -> + group [] + , case model.loadDialog of + LoadOpen metas -> + let + tab : FilterType -> Tab.Item Msg + tab ft = + Tab.item + { id = + case ft of + FilterActive -> + "all" + + MachineFilter DFA -> + "D" + + MachineFilter NFA -> + "N" + + MachineFilter NPDA -> + "P" + + MachineFilter Turing -> + "T" + + FilterArchived -> + "arc" + , link = + Tab.link [ Html.Events.onClick <| SelectFilter ft ] <| + [] + {- <| + (if model.loadingList == Just ft then + [ Spinner.spinner + [ Spinner.small, Spinner.attrs [ Spacing.mr1 ] ] + [] + ] + + else + [] + ) + -} + ++ [ Html.text + (case ft of + FilterActive -> + "All" + + MachineFilter DFA -> + "DFA/NFA" + + MachineFilter NFA -> + "DFA/NFA" + + MachineFilter NPDA -> + "NPDA" + + MachineFilter Turing -> + "TM" + + FilterArchived -> + "Archived" + ) + ] + , pane = + Tab.pane [] + [] + } + in + GraphicSVG.html winX + winY + (Modal.config CloseLoadDialog + -- Configure the modal to use animations providing the new AnimateModal msg + |> Modal.withAnimation ModalAnimation + |> Modal.header [] + [ Html.div [] [ Html.h3 [] [ Html.text "My Machines" ] ] + , Html.div [] [ Button.button [ Button.primary, Button.attrs [ style "margin-left" "10px" ], Button.onClick OpenNewDialog ] [ Html.text "New" ] ] + ] + -- |> Modal.header [] [ Html.h3 [] [Html.text "Your Machines"] , Html.div [style "display" "block", style "float" "right"] [Button.button [Button.primary, Button.small ] [ Html.text "New" ] ] ] + |> Modal.body [ style "height" (String.fromFloat (winY / 2) ++ "px"), style "overflow" "scroll" ] [ renderLoadList (model.loadingList /= Nothing) (model.loadFilter == FilterArchived) metas env.currentTime env.timeZone ] + {- |> Modal.footer [] + [ Button.button + [ Button.outlinePrimary + -- If you want the custom close button to use animations; + -- you should use the AnimateModal msg and provide it with the Modal.hiddenAnimated visibility + , Button.attrs [ Html.Events.onClick <| ModalAnimation Modal.hiddenAnimated ] + ] + [ Html.text "Close" ] + ] + -} + |> Modal.footer [] + [ Html.div [ style "width" "100%" ] + [ Tab.config (MachineCreatedMsg << TabMsg) + |> Tab.pills + -- |> Tab.attrs [style "float" "left"] + |> Tab.center + |> Tab.items + (List.map tab + [ FilterActive + , MachineFilter DFA + + {- , MachineFilter NPDA, MachineFilter Turing, -} + , FilterArchived + ] + ) + |> Tab.view model.tabState + ] + ] + |> Modal.view model.loadDialogModal + ) + |> move ( -winX / 2, winY / 2 ) + + NewOpen -> + GraphicSVG.html winX + winY + (Modal.config CloseLoadDialog + -- Configure the modal to use animations providing the new AnimateModal msg + |> Modal.withAnimation ModalAnimation + |> Modal.header [] + [ Html.div [] [ Html.h3 [] [ Html.text "Welcome to finsm.io!" ] ] + ] + -- |> Modal.header [] [ Html.h3 [] [Html.text "Your Machines"] , Html.div [style "display" "block", style "float" "right"] [Button.button [Button.primary, Button.small ] [ Html.text "New" ] ] ] + |> Modal.body [ style "height" (String.fromFloat (winY / 2) ++ "px"), style "overflow" "scroll" ] + [ Html.h4 [] [ Html.text "finsm.io lets you create, test and export finite state machines. Get started by selecting an option below:" ] + , renderNew model.loginState + ] + {- |> Modal.footer [] + [ Button.button + [ Button.outlinePrimary + -- If you want the custom close button to use animations; + -- you should use the AnimateModal msg and provide it with the Modal.hiddenAnimated visibility + , Button.attrs [ Html.Events.onClick <| ModalAnimation Modal.hiddenAnimated ] + ] + [ Html.text "Close" ] + ] + -} + |> Modal.footer [] [] + |> Modal.view model.loadDialogModal + ) + |> move ( -winX / 2, winY / 2 ) + + _ -> + group [] + , case model.machineData of + MachineCreated -> + group + [ if not model.editingName then + text model.machineMetadata.name + |> fixedwidth + |> size 16 + |> filled black + |> move ( -winX / 2 + 175, winY / 2 - 20 ) + |> notifyTap (MachineCreatedMsg EditMachineName) + + else + textBox model.machineMetadata.name 300 20 "Machine Name" (MachineCreatedMsg << TypeName) + |> move ( -winX / 2 + 325, winY / 2 - 10 ) + , text (lastSaved model env) + |> fixedwidth + |> size 14 + |> filled darkGray + |> move ( -winX / 2 + 490, winY / 2 - 20 ) + ] + + MachineNotCreated -> + group [] + ] + + +lastSaved : Model -> Environment -> String +lastSaved model env = + let + duration = + Duration.from model.lastSaved env.currentTime + in + if not model.unsavedChanges then + if Duration.inSeconds duration <= 30 then + "last edit saved just now" + + else if Duration.inSeconds duration <= 90 then + "last edit saved about a minute ago" + + else if Duration.inMinutes duration <= 60 then + "last edit saved " ++ String.fromInt (round <| Duration.inMinutes duration) ++ " minutes ago" + + else if Duration.inMinutes duration <= 90 then + "last edit saved about an hour ago" + + else + "last edit saved " ++ String.fromInt (round <| Duration.inHours duration) ++ " hours ago" + + else + case model.loginState of + LoggedIn _ _ -> + "saving..." + + NotLoggedIn -> + "log in to save changes" + + _ -> + "" + + +aboutAXAgo : Duration.Duration -> String +aboutAXAgo duration = + if Duration.inSeconds duration <= 30 then + "just now" + + else if Duration.inSeconds duration <= 90 then + "about a minute ago" + + else if Duration.inMinutes duration <= 60 then + String.fromInt (round <| Duration.inMinutes duration) ++ " minutes ago" + + else if Duration.inMinutes duration <= 90 then + "about an hour ago" + + else if Duration.inDays duration <= 1 then + String.fromInt (round <| Duration.inHours duration) ++ " hours ago" + + else + String.fromInt (round <| Duration.inDays duration) ++ " days ago" + + +dateFormat : Time.Zone -> Posix -> Posix -> String +dateFormat zn now thn = + let + duration = + Duration.from thn now + + dayStr day = + case day of + Time.Mon -> + "Monday" + + Time.Tue -> + "Tuesday" + + Time.Wed -> + "Wednesday" + + Time.Thu -> + "Thursday" + + Time.Fri -> + "Friday" + + Time.Sat -> + "Saturday" + + Time.Sun -> + "Sunday" + + monStr mon = + case mon of + Time.Jan -> + "January" + + Time.Feb -> + "February" + + Time.Mar -> + "March" + + Time.Apr -> + "April" + + Time.May -> + "May" + + Time.Jun -> + "June" + + Time.Jul -> + "July" + + Time.Aug -> + "August" + + Time.Sep -> + "September" + + Time.Oct -> + "October" + + Time.Nov -> + "November" + + Time.Dec -> + "December" + + dateFmt : Posix -> String + dateFmt t = + (monStr <| Time.toMonth zn t) ++ " " ++ (String.fromInt <| Time.toDay zn t) ++ ", " ++ (String.fromInt <| Time.toYear zn t) + in + if Duration.inDays duration <= 1 then + aboutAXAgo duration + + else if Duration.inDays duration <= 3 then + dayStr (Time.toWeekday zn thn) + + else + dateFmt thn + + +renderLoadList : Bool -> Bool -> List LoadMetadata -> Posix -> Time.Zone -> Html Msg +renderLoadList loadingList archiveList metas now zn = + let + oneRow machine = + ListGroup.anchor + [ ListGroup.attrs [ Flex.col, Flex.alignItemsStart, Size.w100 ] + ] + [ Html.div [ Flex.block, Flex.justifyBetween, Size.w100 ] + [ Html.h5 [ Spacing.mb1 ] [ Html.text machine.name ] + , Html.small [] [ Html.text <| dateFormat zn now machine.date ] + ] + , ButtonGroup.buttonGroup [ ButtonGroup.attrs [ style "float" "right" ] ] + [ ButtonGroup.button [ Button.primary, Button.small, Button.onClick (LoadMachine machine) ] [ Html.text "Open" ] + , ButtonGroup.button + [ Button.danger + , Button.small + , Button.onClick + (if archiveList then + RestoreMachine machine.id + + else + ArchiveMachine machine.id + ) + ] + [ Html.text + (if archiveList then + "Restore" + + else + "Archive" + ) + ] + ] + , Html.div [] [ Html.b [] [ Html.text (machineTypeFullStr machine.machine_type) ] ] + ] + in + Html.div [] + --[style "overflow" "scroll"]-- style "width" (String.fromInt w ++ "px"), style "height" (String.fromInt h ++ "px"), style "position" "fixed"] + [ if loadingList then + Html.div [ style "height" "500px" ] [ Spinner.spinner [ Spinner.color Text.primary, Spinner.large, Spinner.grow, Spinner.attrs [ style "display" "block", style "margin" "auto" ] ] [] ] + + else if metas == [] then + Html.div [ style "text-align" "center" ] [ Html.text "No machines matching current filter." ] + + else + ListGroup.custom (List.map oneRow metas) + ] + + +renderNew : LoginStatus -> Html Msg +renderNew loginStatus = + Card.deck + [ Card.config [] + |> Card.headerH3 [] [ Html.text "DFA / NFA" ] + |> Card.block [] + [ Block.text [] [ Html.text "Create a new Finite State Machine." ] ] + |> Card.footer [] + [ Button.button [ Button.primary, Button.onClick CreateNewMachine ] [ Html.text "Create!" ] ] + , case loginStatus of + LoggedIn _ _ -> + Card.config [] + |> Card.headerH3 [] [ Html.text "Load Existing" ] + |> Card.block [] + [ Block.text [] [ Html.text "Load an existing machine." ] ] + |> Card.footer [] + [ Button.button [ Button.primary, Button.onClick OpenLoadDialog ] [ Html.text "Load" ] ] + + NotLoggedIn -> + Card.config [] + |> Card.headerH3 [] [ Html.text "Load Existing" ] + |> Card.block [] + [ Block.text [] [ Html.text "Log in to load an existing machine." ] ] + |> Card.footer [] + [ Button.button [ Button.primary, Button.onClick OpenLoginDialog ] [ Html.text "Login" ] ] + + LoggingIn -> + Card.config [] + |> Card.headerH3 [] [ Html.text "Load Existing" ] + |> Card.block [] + [ Block.text [] [ Html.text "Please finish logging in to load your machines." ] ] + |> Card.footer [] + [ Button.button [ Button.primary, Button.onClick OpenLoginDialog ] [ Html.text "Login" ] ] + ] diff --git a/src/Simulating.elm b/src/Simulating.elm index c9dd918..87c197d 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -1,4 +1,4 @@ -module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, delta, deltaHat, epsTrans, initPModel, inputTapeDecoder, inputTapeEncoder, isAccept, latexKeyboard, machineDefn, machineModeButtons, onEnter, onExit, renderTape, subscriptions, update, view, inputTapeDictDecoder, checkTapesNoStatus) +module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, checkTapesNoStatus, delta, deltaHat, epsTrans, initPModel, inputTapeDecoder, inputTapeDictDecoder, inputTapeEncoder, isAccept, latexKeyboard, machineDefn, machineModeButtons, onEnter, onExit, renderTape, subscriptions, update, view) import Array exposing (Array) import Browser.Events @@ -16,7 +16,7 @@ import Set exposing (Set) import SharedModel exposing (..) import Task import Tuple exposing (first, second) -import Utils exposing (encodeDict, decodeDict) +import Utils exposing (decodeDict, encodeDict) subscriptions : Model -> Sub Msg @@ -40,6 +40,7 @@ inputTapeDecoder = D.map Array.fromList (D.list D.string) + inputTapeDictDecoder : D.Decoder (Dict Int InputTape) inputTapeDictDecoder = decodeDict D.int inputTapeDecoder @@ -115,6 +116,7 @@ checkTapes : SharedModel -> Dict Int ( InputTape, TapeStatus ) -> Dict Int ( Inp checkTapes sModel tapes = Dict.map (\k ( tape, _ ) -> ( tape, checkTape sModel tape )) tapes + checkTapesNoStatus : SharedModel -> Dict Int InputTape -> Dict Int ( InputTape, TapeStatus ) checkTapesNoStatus sModel tapes = Dict.map (\k tape -> ( tape, checkTape sModel tape )) tapes diff --git a/src/Utils.elm b/src/Utils.elm index 1376bad..228c243 100644 --- a/src/Utils.elm +++ b/src/Utils.elm @@ -8,6 +8,7 @@ import Html.Events exposing (..) import Json.Decode as D import Json.Encode as E import Set exposing (Set) +import Task encodePair : (a -> E.Value) -> (b -> E.Value) -> ( a, b ) -> E.Value @@ -73,3 +74,8 @@ textBox txt w h place msg = , style "font-family" "monospace" ] [] + + +newMsg : msg -> Cmd msg +newMsg msg = + Task.perform identity <| Task.succeed msg From 0e331c1bbdede5a2a47fbb811cd5e7cea595b179 Mon Sep 17 00:00:00 2001 From: CSchank Date: Tue, 11 Feb 2020 22:17:28 -0500 Subject: [PATCH 26/27] remove debug --- src/Main.elm | 4 ++-- src/SaveLoad.elm | 8 ++------ 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Main.elm b/src/Main.elm index c1aa6b5..070441e 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -146,7 +146,7 @@ moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel m model.appModel.present ( ( newM, newPModel, newSModel ), checkpoint, cmd ) = - mUpdate env (Debug.log "mMsg" mMsg) ( mModel, pModel, currentAppState.sharedModel ) + mUpdate env mMsg ( mModel, pModel, currentAppState.sharedModel ) newAppState = { currentAppState @@ -402,7 +402,7 @@ update msg model = SaveMsg saveMsg -> case saveMsg of SaveLoad.LoadMachineResponse response -> - case Debug.log "loadMachineResponse" response of + case response of Ok loadPayload -> let initSharedModel = diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm index 6c5fc2c..9dda97a 100644 --- a/src/SaveLoad.elm +++ b/src/SaveLoad.elm @@ -428,10 +428,6 @@ type SaveStatus update : Msg -> Model -> Environment -> ApplicationModel -> ( Model, Cmd Msg ) update msg model env appModel = - let - m = - Debug.log "model" model - in case msg of OpenLoadDialog -> ( { m | loadDialog = LoadLoading } @@ -446,7 +442,7 @@ update msg model env appModel = ) ListLoadResponse response -> - case Debug.log "machineListResponse" response of + case response of Ok machineList -> ( { model | loadDialog = LoadOpen machineList, loadDialogModal = Modal.shown, loadingList = Nothing, machineData = MachineCreated }, Cmd.none ) @@ -490,7 +486,7 @@ update msg model env appModel = ( model, Cmd.none ) InitLoginStatus loginStatus -> - case Debug.log "loginStatus" loginStatus of + case loginStatus of Ok loginState -> ( { model | loginState = loginState From 2ababf446b1cc8ce9584ddc5e71751cd3aa80bad Mon Sep 17 00:00:00 2001 From: CSchank Date: Tue, 11 Feb 2020 22:18:19 -0500 Subject: [PATCH 27/27] fix variable name --- src/SaveLoad.elm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm index 9dda97a..bd3f444 100644 --- a/src/SaveLoad.elm +++ b/src/SaveLoad.elm @@ -430,7 +430,7 @@ update : Msg -> Model -> Environment -> ApplicationModel -> ( Model, Cmd Msg ) update msg model env appModel = case msg of OpenLoadDialog -> - ( { m | loadDialog = LoadLoading } + ( { model | loadDialog = LoadLoading } , Cmd.batch [ loadList FilterActive ListLoadResponse , if model.unsavedChanges then