diff --git a/.travis.yml b/.travis.yml index 545c962..3a6ed85 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,9 @@ language: elm + +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= diff --git a/elm.json b/elm.json index da56120..40bde1f 100644 --- a/elm.json +++ b/elm.json @@ -3,24 +3,27 @@ "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", "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" + "elm-community/undo-redo": "3.0.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" } @@ -31,4 +34,4 @@ }, "indirect": {} } -} \ No newline at end of file +} 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/Building.elm b/src/Building.elm index 16e3968..865a898 100644 --- a/src/Building.elm +++ b/src/Building.elm @@ -1,13 +1,13 @@ module Building exposing (Model, Msg(..), PersistentModel(..), editingButtons, init, initPModel, onEnter, onExit, subscriptions, update, updateArrowPos, updateStatePos, view) import Browser.Events -import Debug 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 @@ -148,34 +148,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 +181,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 } } ) @@ -489,15 +460,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 @@ -516,14 +483,10 @@ 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 ) @@ -572,20 +535,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 ) @@ -635,6 +587,9 @@ view env ( model, pModel, sModel ) = winY = toFloat <| second env.windowSize + + transMistakes = + getTransitionMistakes sModel.machine in group [ rect winX winY @@ -669,7 +624,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 ) ] @@ -766,17 +721,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/Environment.elm b/src/Environment.elm index ef99db5..09c41e2 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,8 @@ init = , holdingShift = False , holdingControl = False , holdingMeta = False + , currentTime = Time.millisToPosix 1576798602274 + , timeZone = Time.utc } @@ -15,4 +19,6 @@ type alias Environment = , holdingShift : Bool , holdingControl : Bool , holdingMeta : Bool + , currentTime : Time.Posix + , timeZone : Time.Zone } diff --git a/src/Error.elm b/src/Error.elm index dbd2a4d..f242cb0 100644 --- a/src/Error.elm +++ b/src/Error.elm @@ -9,6 +9,7 @@ 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) @@ -57,7 +58,7 @@ machineCheck sModel = sModel.machine tMistakes = - sModel.machine.transitionMistakes + 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..5db0843 100644 --- a/src/Exporting.elm +++ b/src/Exporting.elm @@ -11,6 +11,7 @@ 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 (..) @@ -122,6 +123,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 +141,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/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/Machine.elm b/src/Machine.elm index b02901f..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, renderArrow, renderArrows, renderStates, tMistakeAdd, tMistakeRemove, test, textBox, view) +module Machine exposing (..) import Dict exposing (Dict) import Environment exposing (Environment) @@ -7,7 +7,10 @@ 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) +import Utils exposing (decodeDict, decodePair, decodeSet, decodeTriple, encodeDict, encodePair, encodeSet, encodeTriple, textBox) type alias StateID = @@ -46,6 +49,125 @@ type alias TransitionMistakes = Maybe (Set TransitionID) +machineEncoder : Machine -> E.Value +machineEncoder = + machineEncoderV1 + + +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 ) + , ( "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 + 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 @@ -55,7 +177,6 @@ type alias Machine = , stateTransitions : StateTransitions , stateNames : StateNames , transitionNames : TransitionNames - , transitionMistakes : TransitionMistakes } @@ -132,15 +253,12 @@ test = , ( ( 1, 3, 3 ), ( 0, 10 ) ) , ( ( 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 +270,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 ) -> @@ -246,55 +364,10 @@ view env model machine currentStates = ] -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 -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 ) = @@ -514,8 +587,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 +602,6 @@ renderArrows machine model = transPos = machine.stateTransitions - transMistakes = - machine.transitionMistakes - stateList = Set.toList states @@ -560,14 +630,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 +669,18 @@ renderArrows machine model = _ -> False + -- Transition mistake function + getTransMistake : TransitionMistakes -> TransitionID -> Bool + getTransMistake transMistakes tId = + case transMistakes of + Nothing -> + False + + Just setOfMistakes -> + Set.member tId setOfMistakes + mistake = - getTransMistake chId + 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/Main.elm b/src/Main.elm index 002945c..8b45adf 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -1,7 +1,9 @@ -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) @@ -12,17 +14,20 @@ 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 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) @@ -31,6 +36,7 @@ type Msg = BMsg Building.Msg | SMsg Simulating.Msg | EMsg Exporting.Msg + | SaveMsg SaveLoad.Msg | KeyPressed String | KeyReleased String | WindowSize ( Int, Int ) @@ -38,6 +44,9 @@ type Msg | UrlRequest UrlRequest | GoTo Module | VisibilityChanged Visibility + | GetTime Time.Posix + | GetTZ Time.Zone + | NoOp type Module @@ -46,36 +55,25 @@ type Module | ExportingModule -type ApplicationState - = Building Building.Model - | Simulating Simulating.Model - | Exporting Exporting.Model - - type alias Model = { appModel : BetterUndoList ApplicationModel , environment : Environment - } - - -type alias ApplicationModel = - { appState : ApplicationState - , simulatingData : Simulating.PersistentModel - , buildingData : Building.PersistentModel - , exportingData : Exporting.PersistentModel - , sharedModel : SharedModel + , saveModel : SaveLoad.Model } initAppModel : BetterUndoList ApplicationModel initAppModel = - fresh - { appState = Building Building.init - , sharedModel = SharedModel.init - , simulatingData = Simulating.initPModel - , buildingData = Building.initPModel - , exportingData = Exporting.initPModel - } + fresh initAppRecord + + +initAppRecord = + { appState = Building Building.init + , sharedModel = SharedModel.init + , simulatingData = Simulating.initPModel + , buildingData = Building.initPModel + , exportingData = Exporting.initPModel + } main : App () Model Msg @@ -83,16 +81,26 @@ main = app { init = \flags url key -> + let + ( initSave, saveCmd ) = + SaveLoad.initSaveModel + in ( { appModel = initAppModel , environment = Environment.init + , saveModel = initSave } - , 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 + , Task.perform GetTime Time.now + , Cmd.map SaveMsg saveCmd + , Task.perform GetTZ Time.here + ] ) , update = update , 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)) @@ -106,6 +114,8 @@ main = Exporting m -> Sub.map EMsg (Exporting.subscriptions m) + , Time.every 5000 GetTime -- get the new time every 10 seconds + , Sub.map SaveMsg (SaveLoad.subscriptions model.saveModel) ] , onUrlChange = UrlChange , onUrlRequest = UrlRequest @@ -144,6 +154,9 @@ moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel m , sharedModel = newSModel } |> setpModel newPModel + + sm = + model.saveModel in ( { model | appModel = @@ -152,6 +165,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 ) @@ -165,6 +187,9 @@ update msg model = currentAppState = model.appModel.present + + sm = + model.saveModel in case msg of BMsg bmsg -> @@ -237,6 +262,9 @@ update msg model = else if k == "Control" then ( { model | environment = { oldEnvironment | holdingControl = False } }, Cmd.none ) + else if k == "Enter" then + ( { model | saveModel = { sm | editingName = False, unsavedChanges = True } }, Cmd.none ) + else ( model, Cmd.none ) @@ -267,6 +295,7 @@ update msg model = else model.appModel + , saveModel = { sm | unsavedChanges = doRedo || doUndo } } , Cmd.none ) @@ -365,6 +394,109 @@ update msg model = , Cmd.none ) + GetTime time -> + let + oldEnv = + model.environment + in + ( { model | environment = { oldEnv | currentTime = time } } + , Cmd.none + ) + + SaveMsg saveMsg -> + case saveMsg of + SaveLoad.LoadMachineResponse response -> + case 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 + , 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 + } + in + ( { model + | appModel = newModel + , saveModel = + { sm + | lastSaved = oldEnvironment.currentTime + , machineData = SaveLoad.MachineCreated + , loadDialog = SaveLoad.NothingOpen + , loadDialogModal = Modal.hidden + , machineMetadata = SaveLoad.initMachineMetadata + } + } + , 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 ) + processExit : Environment @@ -572,6 +704,7 @@ modeButtons model = ] |> move ( -winX / 2 + 134, winY / 2 - 15 ) |> notifyTap (GoTo ExportingModule) + , GraphicSVG.map SaveMsg <| SaveLoad.view model.saveModel model.environment ] diff --git a/src/Mistakes.elm b/src/Mistakes.elm new file mode 100644 index 0000000..1e64268 --- /dev/null +++ b/src/Mistakes.elm @@ -0,0 +1,54 @@ +module Mistakes exposing (checkEpsilonTransLabel, checkTransitionValid, getTransitionMistakes) + +import Dict exposing (..) +import Machine exposing (..) +import Set exposing (..) + + +getTransitionMistakes : Machine -> TransitionMistakes +getTransitionMistakes mac = + let + tNames = + mac.transitionNames + in + checkEpsilonTransLabel tNames + + + +-- 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/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 new file mode 100644 index 0000000..bd3f444 --- /dev/null +++ b/src/SaveLoad.elm @@ -0,0 +1,1062 @@ +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 = + { id : String + , name : String + , date : Posix + , description : String + , machine_type : MachineType + } + + +decodeMetadataV1 : D.Decoder LoadMetadata +decodeMetadataV1 = + 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 +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 LoadMetadata) +decodeMachineList = + D.list decodeMetadata + + +encodeMachinePayload = + encodeMachinePayloadV1 + + + +-- 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 -> 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 ) + , ( "machine", Machine.machineEncoder machine ) + , ( "v", E.int 1 ) + , ( "uuid", E.string uuid ) + , ( "tape", Simulating.inputTapeEncoder inputTape ) + , ( "type", encodeMachineType machine_type ) + ] + + +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 -> 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 machine_type) + decodeSaveResponse + + +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 <| 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.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 +loadMachine uuid toMsg = + Http.send toMsg <| + Http.post + "/api/machine/load" + (Http.jsonBody <| E.string uuid) + decodeLoadPayload + + +loadList : FilterType -> (Result Http.Error (List LoadMetadata) -> msg) -> Cmd msg +loadList machineType toMsg = + Http.send toMsg <| + Http.post + "/api/machine/list" + (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 = + case msg of + OpenLoadDialog -> + ( { model | loadDialog = LoadLoading } + , Cmd.batch + [ loadList FilterActive ListLoadResponse + , if model.unsavedChanges then + newMsg (MachineCreatedMsg SaveMachine) + + else + Cmd.none + ] + ) + + ListLoadResponse response -> + case 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 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 cb3f7c4..7cebb1f 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, 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 @@ -9,11 +9,14 @@ 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) import SharedModel exposing (..) import Task import Tuple exposing (first, second) +import Utils exposing (decodeDict, encodeDict) subscriptions : Model -> Sub Msg @@ -27,6 +30,22 @@ type alias PersistentModel = } +inputTapeEncoder : Dict Int ( InputTape, a ) -> E.Value +inputTapeEncoder = + encodeDict E.int (E.list E.string << Array.toList << Tuple.first) + + +inputTapeDecoder : D.Decoder InputTape +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 @@ -98,6 +117,11 @@ 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 = let @@ -643,6 +667,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 @@ -730,7 +757,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 ] diff --git a/src/Utils.elm b/src/Utils.elm new file mode 100644 index 0000000..228c243 --- /dev/null +++ b/src/Utils.elm @@ -0,0 +1,81 @@ +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) +import Task + + +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 + + +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" + ] + [] + + +newMsg : msg -> Cmd msg +newMsg msg = + Task.perform identity <| Task.succeed msg diff --git a/tests/Example.elm b/tests/Example.elm index 10f6714..38cb2e7 100644 --- a/tests/Example.elm +++ b/tests/Example.elm @@ -2,12 +2,19 @@ module Example exposing (suite) import Expect exposing (Expectation) import Fuzz exposing (Fuzzer, int, list, string) +import Json.Decode as D +import Json.Encode as E +import Machine exposing (test) import Test exposing (..) 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.machineDecoder <| + E.encode 0 (Machine.machineEncoder Machine.test) + ) ]