├── .gitattributes ├── .gitignore ├── .travis.yml ├── README.md ├── build_scripts ├── deploy_rsa.enc └── optimize.sh ├── elm.json ├── src ├── ApplicationModel.elm ├── BetterUndoList.elm ├── Building.elm ├── Environment.elm ├── Error.elm ├── Exporting.elm ├── Helpers.elm ├── Machine.elm ├── Main.elm ├── Mistakes.elm ├── Ports.elm ├── SaveLoad.elm ├── SharedModel.elm ├── Simulating.elm └── Utils.elm └── tests └── Example.elm /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | elm-stuff/ 2 | *.js 3 | *.html 4 | *.svg 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: elm 2 | 3 | install: 4 | - npm install -g elm@0.19.1-3 5 | - npm install -g elm-test@0.19.1 6 | - npm install -g elm-format@0.8.2 7 | env: 8 | global: 9 | - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= 10 | - secure: iSktBKBarfcmVAGJtVbifKvQ8faPbWvkmcHbgjZkaCZFhcg8iTnszJIH2ht1qicsW9xnuIzitsl/hwB9ZaRY1dXhG9sVPtJYQeSvDgb34voPGXJ+0mewxFbGi1Li+bgq5jy9j2NoPtz95swHVXfVODToU1zP2Vmp6EMnLQhidQqXvR77T1QlYOxjFnJMSBSHz1cIIt5y94n5/DSYp5F4OYqq6ia1D9Vc1iecENHscQHzKRNVXTvnBJ/rYGObWA6PfV2cTnbRrB+XANxPAI8i8aV1S/YfmkiEw4SRmK3hRN909QDVKTjATOx7zL1/BuB09Br7HnePgOB04XugWDd3hIjFoNZr5fZ3JceFgNRwW93G24spCn8tOp4E0vZCfLSirmeJPAwAH8yFPVls9OLdcflu+N9HVzpgv2kZjk11Q5tblql5ZclmyvhJtQVfmi2kb7hfABE1soqLrkTcVKjUsbPbkPLCNgdjlVaMP569PBGfuxps8EUzhDvvvPvFEU49r1nnlNU10uhUvoNmWBhsnTEQEdAm2oNC7b9XxzE/0XctSXhd+5OwccIWfhSaJH5TpTmRwmX5cOSnnwp+N+pbYITWCvI82l3yftgA1Cykhd8EVeh9uwHZcv+6wEVbYje4d7qeaMh/dlW+GVztoYr9UTA7bKKYB4q1ok0oBbBc13A= 11 | - secure: sn5UJ+DXrtGvF7wU0roFz3Whd++kIFWSYg148phElgiqls4pUo93isGBM4XF6feeQqDrEybRPQqPcDnpsGR5kPnJrafrm6C9ZiKQMb2qDEGmSTIQ3dWapLvQJve1/pbEaaWXEQPEgTEcIZPkNaGUme6nMHwnDLIWBrkrgR9ugc0/IGgercGUJB3RVUYbF7WcsqwhILfqyZzDqZrlhaoIjLRFRfn8xvORiNki48lv9b5l5sHcGfX4Y41fUxCegXz6z63ClZr/G2jym1U416WKoTHi8BNXk9Tk5JApc5prxI9R9x9cQeauDMqFl38z9Noh0heeXxgmq3m72GhSq45avNgdDRA2SA6l3pgZeYMBs3TFFzZSgiRnr6BXF9lVSJcAKUP7+z7o5WYxSCEvEBRY8I11cK6QFM14Ssp63W0MxSlGBUu6pTXcRh5PyyqSHsavsbpWM8SnXc+SwLvkeP21VCBX4D5XZqp33ZDiGuSiUbNzzqnksESUwJ/Za6Ex5Jjk36qQbwP1vXoH0SFBMEWi44nQHVIw+nmoC0aQBX/6yk0li4W9szxpI+R+s03Vo1ZCg+l1aLXOU+Vhld/80rVJs0DnhcYJYyroH1wIAnYaMvtBBvC1U6bxWS+i7qI7lJrQ+C4mLSxo1TpjhdzhD1bQ8k8JO2bzaW0+GFoDH0RnPJI= 12 | jobs: 13 | include: 14 | - stage: test 15 | script: 16 | - elm-format --validate . 17 | - elm make src/Main.elm --optimize 18 | name: elm-format and optimization validation 19 | - script: elm-test 20 | name: elm-test test run 21 | - stage: deploy 22 | script: 23 | - openssl aes-256-cbc -K $encrypted_0d4cca618d57_key -iv $encrypted_0d4cca618d57_iv 24 | -in build_scripts/deploy_rsa.enc -out /tmp/deploy_rsa -d 25 | - eval "$(ssh-agent -s)" 26 | - chmod 600 /tmp/deploy\_rsa 27 | - chmod u+x build_scripts/optimize.sh 28 | - ssh-add /tmp/deploy\_rsa 29 | - echo -e "Host $DEPLOY_HOST\n\tStrictHostKeyChecking no\n" >> ~/.ssh/config 30 | - npm install -g uglify-js 31 | - "./build_scripts/optimize.sh src/Main.elm" 32 | - scp finsm.min.js $DEPLOY_USER@$DEPLOY_HOST:$DEPLOY_DIRECTORY 33 | name: Live Deployment 34 | stages: 35 | - test 36 | - name: deploy 37 | if: "(branch = master) AND (tag IS present)" 38 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # finsm [![Build Status](https://travis-ci.org/CSchank/finsm.svg?branch=master)](https://travis-ci.org/CSchank/finsm) 2 | An Elm app for building and simulating deterministic and non-deterministic finite automata (DFAs and NFAs). 3 | -------------------------------------------------------------------------------- /build_scripts/deploy_rsa.enc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CSchank/finsm/dbcb361e858ce320ee98aab6dbb2a68c93e4d951/build_scripts/deploy_rsa.enc -------------------------------------------------------------------------------- /build_scripts/optimize.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | js="finsm.js" 6 | min="finsm.min.js" 7 | 8 | elm make --optimize --output=$js $@ 9 | 10 | uglifyjs $js --compress 'pure_funcs="F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9",pure_getters,keep_fargs=false,unsafe_comps,unsafe' | uglifyjs --mangle --output=$min 11 | 12 | echo "Compiled size:$(cat $js | wc -c) bytes ($js)" 13 | echo "Minified size:$(cat $min | wc -c) bytes ($min)" 14 | echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes" 15 | -------------------------------------------------------------------------------- /elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.1", 7 | "dependencies": { 8 | "direct": { 9 | "MacCASOutreach/graphicsvg": "5.1.0", 10 | "avh4/elm-color": "1.0.0", 11 | "billstclair/elm-sha256": "1.0.9", 12 | "elm/browser": "1.0.1", 13 | "elm/core": "1.0.2", 14 | "elm/html": "1.0.0", 15 | "elm/http": "1.0.0", 16 | "elm/json": "1.1.2", 17 | "elm/random": "1.0.0", 18 | "elm/svg": "1.0.1", 19 | "elm/time": "1.0.0", 20 | "elm/url": "1.0.0", 21 | "elm-community/undo-redo": "3.0.0", 22 | "ianmackenzie/elm-units": "2.2.0", 23 | "rundis/elm-bootstrap": "5.2.0" 24 | }, 25 | "indirect": { 26 | "elm/regex": "1.0.0", 27 | "elm/virtual-dom": "1.0.2", 28 | "elm-community/list-extra": "8.1.0" 29 | } 30 | }, 31 | "test-dependencies": { 32 | "direct": { 33 | "elm-explorations/test": "1.2.0" 34 | }, 35 | "indirect": {} 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /src/ApplicationModel.elm: -------------------------------------------------------------------------------- 1 | module ApplicationModel exposing (..) 2 | 3 | import Building 4 | import Exporting 5 | import SharedModel exposing (SharedModel) 6 | import Simulating 7 | 8 | 9 | type ApplicationState 10 | = Building Building.Model 11 | | Simulating Simulating.Model 12 | | Exporting Exporting.Model 13 | 14 | 15 | type alias ApplicationModel = 16 | { appState : ApplicationState 17 | , simulatingData : Simulating.PersistentModel 18 | , buildingData : Building.PersistentModel 19 | , exportingData : Exporting.PersistentModel 20 | , sharedModel : SharedModel 21 | } 22 | -------------------------------------------------------------------------------- /src/BetterUndoList.elm: -------------------------------------------------------------------------------- 1 | module BetterUndoList exposing (BetterUndoList, fresh, new, redo, replace, undo) 2 | 3 | import UndoList as U 4 | 5 | 6 | type alias BetterUndoList state = 7 | { ul : U.UndoList state 8 | , present : state 9 | } 10 | 11 | 12 | fresh : state -> BetterUndoList state 13 | fresh state = 14 | { present = state 15 | , ul = U.fresh state 16 | } 17 | 18 | 19 | new : state -> BetterUndoList state -> BetterUndoList state 20 | new state nUL = 21 | { nUL 22 | | present = state 23 | , ul = U.new state nUL.ul 24 | } 25 | 26 | 27 | replace : state -> BetterUndoList state -> BetterUndoList state 28 | replace state nUL = 29 | { nUL 30 | | present = state 31 | } 32 | 33 | 34 | undo : BetterUndoList state -> BetterUndoList state 35 | undo nUL = 36 | let 37 | newUL = 38 | U.undo nUL.ul 39 | in 40 | { present = newUL.present 41 | , ul = U.undo nUL.ul 42 | } 43 | 44 | 45 | redo : BetterUndoList state -> BetterUndoList state 46 | redo nUL = 47 | let 48 | newUL = 49 | U.redo nUL.ul 50 | in 51 | { present = newUL.present 52 | , ul = newUL 53 | } 54 | -------------------------------------------------------------------------------- /src/Building.elm: -------------------------------------------------------------------------------- 1 | module Building exposing (Model, Msg(..), PersistentModel(..), editingButtons, init, initPModel, onEnter, onExit, subscriptions, update, updateArrowPos, updateStatePos, view) 2 | 3 | import Browser.Events 4 | import Dict exposing (Dict) 5 | import Environment exposing (Environment) 6 | import GraphicSVG exposing (..) 7 | import Helpers exposing (..) 8 | import Json.Decode as D 9 | import Machine exposing (..) 10 | import Mistakes exposing (..) 11 | import Set 12 | import SharedModel exposing (MachineType(..), SharedModel, machineModeButtons) 13 | import Task 14 | import Tuple exposing (first, second) 15 | 16 | 17 | type alias Model = 18 | { machineState : Machine.Model 19 | , snapToGrid : Snap 20 | } 21 | 22 | 23 | type Snap 24 | = SnapToGrid Int 25 | | NoSnap 26 | 27 | 28 | type PersistentModel 29 | = Empty 30 | 31 | 32 | type Msg 33 | = MachineMsg Machine.Msg 34 | | SaveStateName StateID String 35 | | SaveTransitionName TransitionID String 36 | | ToggleStart StateID 37 | | ChangeMachine MachineType 38 | | AddState ( Float, Float ) 39 | | KeyPressed String 40 | | KeyReleased String 41 | | ToggleSnap 42 | | ChangeSnap Int 43 | | NoOp 44 | 45 | 46 | subscriptions : Model -> Sub Msg 47 | subscriptions model = 48 | Sub.batch 49 | [ Browser.Events.onKeyDown (D.map KeyPressed (D.field "key" D.string)) 50 | , Browser.Events.onKeyUp (D.map KeyReleased (D.field "key" D.string)) 51 | ] 52 | 53 | 54 | init : Model 55 | init = 56 | { machineState = Regular 57 | , snapToGrid = NoSnap 58 | } 59 | 60 | 61 | initPModel : PersistentModel 62 | initPModel = 63 | Empty 64 | 65 | 66 | onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) 67 | onEnter env ( pModel, sModel ) = 68 | ( ( init, pModel, sModel ), False, Cmd.none ) 69 | 70 | 71 | onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) 72 | onExit env ( model, pModel, sModel ) = 73 | ( ( pModel, sModel ), False ) 74 | 75 | 76 | update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) 77 | update env msg ( model, pModel, sModel ) = 78 | let 79 | oldMachine = 80 | sModel.machine 81 | in 82 | case msg of 83 | MachineMsg mmsg -> 84 | case mmsg of 85 | StartDragging st ( x, y ) -> 86 | let 87 | ( sx, sy ) = 88 | case Dict.get st oldMachine.statePositions of 89 | Just ( xx, yy ) -> 90 | ( xx, yy ) 91 | 92 | Nothing -> 93 | ( 0, 0 ) 94 | in 95 | case model.machineState of 96 | MousingOverRim sId _ -> 97 | ( ( { model | machineState = AddingArrow sId ( x, y ) }, pModel, sModel ), False, Cmd.none ) 98 | 99 | _ -> 100 | ( ( { model | machineState = DraggingState st ( x - sx, y - sy ) ( x, y ) }, pModel, sModel ), False, Cmd.none ) 101 | 102 | StartDraggingArrow ( st1, char, st2 ) pos -> 103 | ( ( { model | machineState = DraggingArrow ( st1, char, st2 ) pos }, pModel, sModel ), False, Cmd.none ) 104 | 105 | StartMouseOverRim stId ( x, y ) -> 106 | case model.machineState of 107 | Regular -> 108 | ( ( { model | machineState = MousingOverRim stId ( x, y ) }, pModel, sModel ), False, Cmd.none ) 109 | 110 | _ -> 111 | ( ( model, pModel, sModel ), False, Cmd.none ) 112 | 113 | MoveMouseOverRim ( x, y ) -> 114 | case model.machineState of 115 | MousingOverRim stId _ -> 116 | ( ( { model | machineState = MousingOverRim stId ( x, y ) }, pModel, sModel ), False, Cmd.none ) 117 | 118 | _ -> 119 | ( ( model, pModel, sModel ), False, Cmd.none ) 120 | 121 | StopMouseOverRim -> 122 | case model.machineState of 123 | MousingOverRim _ _ -> 124 | ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) 125 | 126 | _ -> 127 | ( ( model, pModel, sModel ), False, Cmd.none ) 128 | 129 | StopDragging -> 130 | case model.machineState of 131 | DraggingState st _ _ -> 132 | ( ( { model | machineState = SelectedState st }, pModel, sModel ), True, Cmd.none ) 133 | 134 | AddingArrowOverOtherState st _ s1 -> 135 | let 136 | newTrans = 137 | case List.head <| Dict.values oldMachine.transitionNames of 138 | Just setchar -> 139 | setchar 140 | 141 | Nothing -> 142 | Set.singleton "x" 143 | 144 | newTransID = 145 | case List.maximum <| Dict.keys oldMachine.transitionNames of 146 | Just n -> 147 | n + 1 148 | 149 | Nothing -> 150 | 0 151 | 152 | isValidTransition = 153 | checkTransitionValid newTrans 154 | 155 | newDelta : Delta 156 | newDelta = 157 | Dict.update st 158 | (\mcDict -> 159 | case mcDict of 160 | Just ss -> 161 | Just <| 162 | Dict.update newTransID 163 | (\mState -> 164 | Just s1 165 | ) 166 | ss 167 | 168 | Nothing -> 169 | Just <| Dict.singleton newTransID s1 170 | ) 171 | oldMachine.delta 172 | 173 | newTransPos = 174 | if st == s1 then 175 | ( 0, 50 ) 176 | 177 | else 178 | ( 0, 0 ) 179 | in 180 | ( ( { model | machineState = Regular } 181 | , pModel 182 | , { sModel 183 | | machine = 184 | { oldMachine 185 | | delta = newDelta 186 | , transitionNames = Dict.insert newTransID newTrans oldMachine.transitionNames 187 | , stateTransitions = Dict.insert ( st, newTransID, s1 ) newTransPos oldMachine.stateTransitions 188 | } 189 | } 190 | ) 191 | , True 192 | , Cmd.none 193 | ) 194 | 195 | DraggingArrow tId _ -> 196 | ( ( { model | machineState = Regular }, pModel, sModel ), True, Cmd.none ) 197 | 198 | _ -> 199 | ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) 200 | 201 | SelectArrow ( s0, tId, s1 ) -> 202 | let 203 | oldTransName = 204 | case Dict.get tId sModel.machine.transitionNames of 205 | Just n -> 206 | renderSet2String n 207 | 208 | Nothing -> 209 | "" 210 | in 211 | if env.holdingShift then 212 | ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), False, focusInput NoOp ) 213 | 214 | else 215 | ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), False, Cmd.none ) 216 | 217 | Drag ( x, y ) -> 218 | case model.machineState of 219 | DraggingState st ( ox, oy ) _ -> 220 | let 221 | ( sx, sy ) = 222 | case Dict.get st oldMachine.statePositions of 223 | Just ( xx, yy ) -> 224 | ( xx, yy ) 225 | 226 | Nothing -> 227 | ( 0, 0 ) 228 | 229 | newPos = 230 | case model.snapToGrid of 231 | SnapToGrid n -> 232 | ( roundTo (toFloat n) (x - ox), roundTo (toFloat n) (y - oy) ) 233 | 234 | _ -> 235 | ( x - ox, y - oy ) 236 | in 237 | ( ( { model | machineState = DraggingState st ( ox, oy ) ( x, y ) }, pModel, { sModel | machine = { oldMachine | statePositions = updateStatePos st newPos oldMachine.statePositions } } ) 238 | , False 239 | , Cmd.none 240 | ) 241 | 242 | DraggingArrow ( s1, char, s2 ) _ -> 243 | let 244 | ( x0, y0 ) = 245 | case Dict.get s1 oldMachine.statePositions of 246 | Just ( xx, yy ) -> 247 | ( xx, yy ) 248 | 249 | Nothing -> 250 | ( 0, 0 ) 251 | 252 | ( x1, y1 ) = 253 | case Dict.get s2 oldMachine.statePositions of 254 | Just ( xx, yy ) -> 255 | ( xx, yy ) 256 | 257 | Nothing -> 258 | ( 0, 0 ) 259 | 260 | newPos = 261 | case model.snapToGrid of 262 | SnapToGrid n -> 263 | ( roundTo (toFloat n) x, roundTo (toFloat n) y ) 264 | 265 | _ -> 266 | ( x, y ) 267 | 268 | theta = 269 | -1 * atan2 (y1 - y0) (x1 - x0) 270 | 271 | ( mx, my ) = 272 | ( (x0 + x1) / 2, (y0 + y1) / 2 ) 273 | 274 | ( nx, ny ) = 275 | sub newPos ( mx, my ) 276 | 277 | nprot = 278 | ( nx * cos theta - ny * sin theta, nx * sin theta + ny * cos theta ) 279 | in 280 | ( ( { model | machineState = DraggingArrow ( s1, char, s2 ) ( x, y ) }, pModel, { sModel | machine = { oldMachine | stateTransitions = Dict.insert ( s1, char, s2 ) nprot oldMachine.stateTransitions } } ), False, Cmd.none ) 281 | 282 | AddingArrow st _ -> 283 | let 284 | aboveStates = 285 | List.map (\( sId, _ ) -> sId) <| 286 | Dict.toList <| 287 | Dict.filter (\_ ( x1, y1 ) -> (x1 - x) ^ 2 + (y1 - y) ^ 2 <= 400) oldMachine.statePositions 288 | 289 | newState = 290 | case aboveStates of 291 | h :: _ -> 292 | AddingArrowOverOtherState st ( x, y ) h 293 | 294 | _ -> 295 | AddingArrow st ( x, y ) 296 | in 297 | ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) 298 | 299 | AddingArrowOverOtherState st _ s1 -> 300 | let 301 | aboveStates = 302 | List.map (\( sId, _ ) -> sId) <| 303 | Dict.toList <| 304 | Dict.filter (\_ ( x1, y1 ) -> (x1 - x) ^ 2 + (y1 - y) ^ 2 <= 400) oldMachine.statePositions 305 | 306 | newState = 307 | case aboveStates of 308 | h :: _ -> 309 | AddingArrowOverOtherState st ( x, y ) h 310 | 311 | _ -> 312 | AddingArrow st ( x, y ) 313 | in 314 | ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) 315 | 316 | _ -> 317 | ( ( { model | machineState = model.machineState }, pModel, sModel ), False, Cmd.none ) 318 | 319 | MouseOverStateLabel st -> 320 | ( ( { model | machineState = MousingOverStateLabel st }, pModel, sModel ), False, Cmd.none ) 321 | 322 | MouseOverTransitionLabel tr -> 323 | let 324 | newState = 325 | case model.machineState of 326 | Regular -> 327 | MousingOverTransitionLabel tr 328 | 329 | _ -> 330 | model.machineState 331 | in 332 | ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) 333 | 334 | MouseLeaveLabel -> 335 | let 336 | newState = 337 | case model.machineState of 338 | MousingOverStateLabel _ -> 339 | Regular 340 | 341 | MousingOverTransitionLabel _ -> 342 | Regular 343 | 344 | _ -> 345 | model.machineState 346 | in 347 | ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) 348 | 349 | EditLabel _ lbl -> 350 | let 351 | newState = 352 | case model.machineState of 353 | EditingStateLabel st _ -> 354 | EditingStateLabel st lbl 355 | 356 | EditingTransitionLabel tr _ -> 357 | EditingTransitionLabel tr lbl 358 | 359 | _ -> 360 | model.machineState 361 | in 362 | ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) 363 | 364 | TapState sId -> 365 | let 366 | oldStateName = 367 | case Dict.get sId sModel.machine.stateNames of 368 | Just n -> 369 | n 370 | 371 | _ -> 372 | "" 373 | in 374 | if env.holdingShift then 375 | ( ( { model | machineState = EditingStateLabel sId oldStateName }, pModel, sModel ), False, focusInput NoOp ) 376 | 377 | else 378 | ( ( { model | machineState = SelectedState sId }, pModel, sModel ), False, Cmd.none ) 379 | 380 | Reset -> 381 | ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) 382 | 383 | ChangeMachine mtype -> 384 | case mtype of 385 | NFA -> 386 | case sModel.machineType of 387 | NFA -> 388 | ( ( model, pModel, sModel ), False, Cmd.none ) 389 | 390 | DFA -> 391 | ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) 392 | 393 | DFA -> 394 | case sModel.machineType of 395 | DFA -> 396 | ( ( model, pModel, sModel ), False, Cmd.none ) 397 | 398 | NFA -> 399 | let 400 | startState = 401 | if Set.size oldMachine.start > 1 then 402 | Set.singleton <| 403 | (\x -> 404 | case x of 405 | Just val -> 406 | val 407 | 408 | Nothing -> 409 | -1 410 | ) 411 | <| 412 | List.head <| 413 | Set.toList oldMachine.start 414 | 415 | else 416 | oldMachine.start 417 | 418 | newSModel = 419 | { sModel | machine = { oldMachine | start = startState }, machineType = DFA } 420 | in 421 | ( ( model, pModel, newSModel ), True, Cmd.none ) 422 | 423 | AddState ( x, y ) -> 424 | case model.machineState of 425 | Regular -> 426 | let 427 | newId = 428 | setMax oldMachine.q + 1 429 | 430 | newMachine = 431 | { oldMachine 432 | | q = Set.insert newId oldMachine.q 433 | , delta = Dict.insert newId Dict.empty oldMachine.delta 434 | , statePositions = Dict.insert newId ( x, y ) oldMachine.statePositions 435 | , stateNames = Dict.insert newId ("q_{" ++ String.fromInt newId ++ "}") oldMachine.stateNames 436 | } 437 | in 438 | ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) 439 | 440 | _ -> 441 | ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) 442 | 443 | KeyPressed k -> 444 | let 445 | normalizedKey = 446 | String.toLower k 447 | in 448 | if normalizedKey == "enter" then 449 | --pressed enter 450 | case model.machineState of 451 | EditingStateLabel sId newLbl -> 452 | let 453 | oldStateName = 454 | case Dict.get sId oldMachine.stateNames of 455 | Just n -> 456 | n 457 | 458 | _ -> 459 | "" 460 | in 461 | if newLbl == oldStateName || newLbl == "" then 462 | ( ( { model | machineState = SelectedState sId }, pModel, sModel ), False, Cmd.none ) 463 | 464 | else 465 | ( ( { model | machineState = SelectedState sId }, pModel, sModel ), True, sendMsg <| SaveStateName sId newLbl ) 466 | 467 | EditingTransitionLabel ( s0, tId, s1 ) newLbl -> 468 | let 469 | oldTransitionName = 470 | case Dict.get tId oldMachine.transitionNames of 471 | Just n -> 472 | renderSet2String n 473 | 474 | _ -> 475 | "" 476 | in 477 | if newLbl == oldTransitionName || newLbl == "" then 478 | ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), False, Cmd.none ) 479 | 480 | else 481 | ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), True, sendMsg <| SaveTransitionName tId newLbl ) 482 | 483 | SelectedState sId -> 484 | let 485 | oldStateName = 486 | case Dict.get sId sModel.machine.stateNames of 487 | Just n -> 488 | n 489 | 490 | _ -> 491 | "" 492 | in 493 | ( ( { model | machineState = EditingStateLabel sId oldStateName }, pModel, sModel ), False, focusInput NoOp ) 494 | 495 | SelectedArrow ( s0, tId, s1 ) -> 496 | let 497 | oldTransName = 498 | case Dict.get tId sModel.machine.transitionNames of 499 | Just n -> 500 | renderSet2String n 501 | 502 | Nothing -> 503 | "" 504 | in 505 | ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), False, focusInput NoOp ) 506 | 507 | _ -> 508 | ( ( model, pModel, sModel ), False, Cmd.none ) 509 | 510 | else if normalizedKey == "s" then 511 | case model.machineState of 512 | SelectedState stId -> 513 | ( ( model, pModel, sModel ), False, sendMsg (ToggleStart stId) ) 514 | 515 | _ -> 516 | ( ( model, pModel, sModel ), False, Cmd.none ) 517 | 518 | else if normalizedKey == "d" then 519 | case model.machineState of 520 | SelectedState stId -> 521 | let 522 | new_q = 523 | Set.remove stId oldMachine.q 524 | 525 | newDelta = 526 | Dict.map (\_ d -> Dict.filter (\tId _ -> not <| Dict.member tId removedTransitions) d) oldMachine.delta 527 | |> Dict.filter (\key _ -> Set.member key new_q) 528 | 529 | newMachine = 530 | { oldMachine 531 | | q = new_q 532 | , delta = newDelta 533 | , start = Set.remove stId oldMachine.start 534 | , final = Set.remove stId oldMachine.final 535 | , statePositions = Dict.remove stId oldMachine.statePositions 536 | , stateTransitions = newStateTransitions 537 | , stateNames = Dict.remove stId oldMachine.stateNames 538 | , transitionNames = Dict.diff oldMachine.transitionNames removedTransitions 539 | } 540 | 541 | newStateTransitions = 542 | Dict.filter (\( _, t, _ ) _ -> not <| Dict.member t removedTransitions) oldMachine.stateTransitions 543 | 544 | removedTransitionsLst = 545 | List.map (\( _, t, _ ) -> ( t, () )) <| Dict.keys <| Dict.filter (\( s0, _, s1 ) _ -> s0 == stId || s1 == stId) oldMachine.stateTransitions 546 | 547 | removedTransitions = 548 | Dict.fromList removedTransitionsLst 549 | in 550 | ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) 551 | 552 | SelectedArrow ( _, tId, _ ) -> 553 | let 554 | newDelta = 555 | Dict.map (\_ d -> Dict.filter (\tId0 _ -> tId /= tId0) d) oldMachine.delta 556 | 557 | newMachine = 558 | { oldMachine 559 | | delta = newDelta 560 | , stateTransitions = newStateTransitions 561 | , transitionNames = Dict.remove tId oldMachine.transitionNames 562 | } 563 | 564 | newStateTransitions = 565 | Dict.filter (\( _, tId0, _ ) _ -> tId /= tId0) oldMachine.stateTransitions 566 | in 567 | ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) 568 | 569 | _ -> 570 | ( ( model, pModel, sModel ), False, Cmd.none ) 571 | 572 | else if normalizedKey == "g" then 573 | ( ( model, pModel, sModel ), False, sendMsg ToggleSnap ) 574 | 575 | else 576 | case model.machineState of 577 | SelectedState sId -> 578 | if normalizedKey == "f" then 579 | let 580 | newMachine = 581 | { oldMachine 582 | | final = 583 | case Set.member sId oldMachine.final of 584 | True -> 585 | Set.remove sId oldMachine.final 586 | 587 | False -> 588 | Set.insert sId oldMachine.final 589 | } 590 | in 591 | ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) 592 | --else if normalizedKey == "s" then 593 | -- let 594 | -- newMachine = 595 | -- { oldMachine 596 | -- | start = 597 | -- case Set.member sId oldMachine.start of 598 | -- True -> 599 | -- Set.remove sId oldMachine.start 600 | -- 601 | -- False -> 602 | -- Set.insert sId oldMachine.start 603 | -- } 604 | -- in 605 | -- ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) 606 | 607 | else if normalizedKey == "c" then 608 | ( ( { model | machineState = AddingArrow sId env.mousePos }, pModel, sModel ), False, Cmd.none ) 609 | 610 | else 611 | ( ( model, pModel, sModel ), False, Cmd.none ) 612 | 613 | _ -> 614 | ( ( model, pModel, sModel ), False, Cmd.none ) 615 | 616 | KeyReleased k -> 617 | let 618 | normalizedKey = 619 | String.toLower k 620 | in 621 | case model.machineState of 622 | AddingArrow sId _ -> 623 | if normalizedKey == "c" then 624 | ( ( { model | machineState = SelectedState sId }, pModel, sModel ), False, Cmd.none ) 625 | 626 | else 627 | ( ( model, pModel, sModel ), False, Cmd.none ) 628 | 629 | _ -> 630 | ( ( model, pModel, sModel ), False, Cmd.none ) 631 | 632 | ToggleStart sId -> 633 | let 634 | machineType = 635 | sModel.machineType 636 | 637 | tests = 638 | oldMachine.start 639 | 640 | newMachine = 641 | case machineType of 642 | NFA -> 643 | { oldMachine 644 | | start = 645 | case Set.member sId oldMachine.start of 646 | True -> 647 | Set.remove sId oldMachine.start 648 | 649 | False -> 650 | Set.insert sId oldMachine.start 651 | } 652 | 653 | DFA -> 654 | { oldMachine 655 | | start = Set.singleton sId 656 | } 657 | in 658 | ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) 659 | 660 | SaveStateName sId newLbl -> 661 | let 662 | newMachine = 663 | { oldMachine | stateNames = Dict.insert sId newLbl oldMachine.stateNames } 664 | in 665 | ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) 666 | 667 | SaveTransitionName tId newLbl -> 668 | let 669 | newTransitions = 670 | parseString2Set newLbl 671 | 672 | isValidTransition = 673 | checkTransitionValid newTransitions 674 | 675 | newMachine = 676 | { oldMachine 677 | | transitionNames = Dict.insert tId newTransitions oldMachine.transitionNames 678 | } 679 | in 680 | ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) 681 | 682 | ToggleSnap -> 683 | ( ( { model 684 | | snapToGrid = 685 | if model.snapToGrid == NoSnap then 686 | SnapToGrid 10 687 | 688 | else 689 | NoSnap 690 | } 691 | , pModel 692 | , sModel 693 | ) 694 | , False 695 | , Cmd.none 696 | ) 697 | 698 | ChangeSnap nn -> 699 | ( ( { model 700 | | snapToGrid = 701 | case model.snapToGrid of 702 | SnapToGrid n -> 703 | SnapToGrid (n + nn) 704 | 705 | NoSnap -> 706 | NoSnap 707 | } 708 | , pModel 709 | , sModel 710 | ) 711 | , False 712 | , Cmd.none 713 | ) 714 | 715 | NoOp -> 716 | ( ( model, pModel, sModel ), False, Cmd.none ) 717 | 718 | 719 | view : Environment -> ( Model, PersistentModel, SharedModel ) -> Shape Msg 720 | view env ( model, pModel, sModel ) = 721 | let 722 | winX = 723 | toFloat <| first env.windowSize 724 | 725 | winY = 726 | toFloat <| second env.windowSize 727 | 728 | transMistakes = 729 | getTransitionMistakes sModel.machine 730 | in 731 | group 732 | [ rect winX winY 733 | |> filled blank 734 | |> (if env.holdingShift then 735 | notifyTapAt AddState 736 | 737 | else 738 | case model.machineState of 739 | SelectedState _ -> 740 | notifyTap (MachineMsg Reset) 741 | 742 | SelectedArrow _ -> 743 | notifyTap (MachineMsg Reset) 744 | 745 | _ -> 746 | identity 747 | ) 748 | , case ( model.machineState, model.snapToGrid ) of 749 | ( DraggingState _ ( ox, oy ) ( x, y ), SnapToGrid n ) -> 750 | group 751 | [ graphPaperCustom (toFloat n) 1 gray 752 | |> clip (circle 30 |> ghost |> move ( x - ox, y - oy )) 753 | , circle 3 |> filled (rgb 112 190 255) |> move ( roundTo 10 (x - ox), roundTo 10 (y - oy) ) 754 | ] 755 | 756 | ( DraggingArrow id pos, SnapToGrid n ) -> 757 | group 758 | [ graphPaperCustom (toFloat n) 1 gray 759 | |> clip (circle 30 |> ghost |> move pos) 760 | ] 761 | 762 | _ -> 763 | group [] 764 | , GraphicSVG.map MachineMsg <| Machine.view env model.machineState sModel.machine Set.empty transMistakes 765 | , editingButtons model |> move ( winX / 2 - 30, -winY / 2 + 25 ) 766 | , machineModeButtons sModel.machineType winX winY ChangeMachine 767 | ] 768 | 769 | 770 | updateStatePos : StateID -> ( Float, Float ) -> StatePositions -> StatePositions 771 | updateStatePos st ( x, y ) pos = 772 | Dict.update st 773 | (\m -> 774 | case m of 775 | Just _ -> 776 | Just ( x, y ) 777 | 778 | Nothing -> 779 | Nothing 780 | ) 781 | pos 782 | 783 | 784 | updateArrowPos : StateID -> Float -> StateTransitions -> StateTransitions 785 | updateArrowPos st angle pos = 786 | Dict.map 787 | (\( st0, char, st1 ) ( x, y ) -> 788 | if st0 == st then 789 | ( x * cos angle, y * sin angle ) 790 | 791 | else if st1 == st then 792 | ( x * cos -angle, y * sin -angle ) 793 | 794 | else 795 | ( x, y ) 796 | ) 797 | pos 798 | 799 | 800 | editingButtons model = 801 | let 802 | snapping = 803 | case model.snapToGrid of 804 | SnapToGrid _ -> 805 | True 806 | 807 | _ -> 808 | False 809 | in 810 | group 811 | [ icon snapping 812 | (snapIcon 813 | |> scale 0.75 814 | |> repaint 815 | (if snapping then 816 | white 817 | 818 | else 819 | gray 820 | ) 821 | ) 822 | |> notifyTap ToggleSnap 823 | |> move ( -36, 0 ) 824 | ] 825 | 826 | 827 | snapIcon = 828 | group 829 | [ group 830 | [ roundedRect 33 4 2.5 |> filled black |> move ( 0, 10 ) 831 | , roundedRect 33 4 2.5 |> filled black 832 | , roundedRect 33 4 2.5 |> filled black |> move ( 0, -10 ) 833 | , roundedRect 4 33 2.5 |> filled black |> move ( 10, 0 ) 834 | , roundedRect 4 33 2.5 |> filled black 835 | , roundedRect 4 33 2.5 |> filled black |> move ( -10, 0 ) 836 | ] 837 | |> subtract 838 | (group 839 | [ wedge 10 0.5 |> ghost |> rotate (degrees 90) 840 | , rect 8 12 |> ghost |> move ( 6, -6 ) 841 | , rect 8 12 |> ghost |> move ( -6, -6 ) 842 | , rect 12 8 |> ghost |> move ( 0, -3 ) 843 | ] 844 | |> move ( 5, -10 ) 845 | ) 846 | , group 847 | [ wedge 8 0.5 848 | |> filled black 849 | |> rotate (degrees 90) 850 | |> subtract (wedge 2 0.5 |> ghost |> rotate (degrees 90)) 851 | , rect 6 6 852 | |> filled black 853 | |> move ( 5, -3 ) 854 | |> subtract (rect 2.5 3 |> ghost |> move ( 5, -3 )) 855 | , rect 6 6 856 | |> filled black 857 | |> move ( -5, -3 ) 858 | |> subtract (rect 2.5 3 |> ghost |> move ( -5, -3 )) 859 | ] 860 | |> move ( 5, -10 ) 861 | ] 862 | -------------------------------------------------------------------------------- /src/Environment.elm: -------------------------------------------------------------------------------- 1 | module Environment exposing (Environment, init) 2 | 3 | import Time 4 | 5 | 6 | init : Environment 7 | init = 8 | { windowSize = ( 0, 0 ) 9 | , holdingShift = False 10 | , holdingControl = False 11 | , holdingMeta = False 12 | , currentTime = Time.millisToPosix 1576798602274 13 | , timeZone = Time.utc 14 | , mousePos = ( 0, 0 ) 15 | } 16 | 17 | 18 | type alias Environment = 19 | { windowSize : ( Int, Int ) 20 | , holdingShift : Bool 21 | , holdingControl : Bool 22 | , holdingMeta : Bool 23 | , currentTime : Time.Posix 24 | , timeZone : Time.Zone 25 | , mousePos : ( Float, Float ) 26 | } 27 | -------------------------------------------------------------------------------- /src/Error.elm: -------------------------------------------------------------------------------- 1 | module Error exposing (DFAErrorType(..), Error(..), contextHasError, errorIcon, errorMenu, machineCheck) 2 | 3 | -- This module serves to export checks and exception handling of finite state machines. 4 | -- When we add support for other machine types, we can extend this module as well. 5 | 6 | import Array exposing (Array) 7 | import Dict exposing (Dict) 8 | import Environment exposing (Environment) 9 | import GraphicSVG exposing (..) 10 | import Helpers exposing (..) 11 | import Machine exposing (Machine, StateID, TransitionID) 12 | import Mistakes exposing (..) 13 | import Set exposing (Set) 14 | import SharedModel exposing (..) 15 | import Tuple exposing (first, second) 16 | 17 | 18 | type Error 19 | = NoError 20 | | DFAError DFAErrorType StateID 21 | | EpsTransError 22 | | DuplicateStates (Set StateID) 23 | 24 | 25 | type DFAErrorType 26 | = HasEpsilon 27 | | Incomplete 28 | | Nondeterministic 29 | | Unsure -- Good for debugging? 30 | 31 | 32 | contextHasError : Error -> MachineType -> Bool 33 | contextHasError err mtype = 34 | case mtype of 35 | DFA -> 36 | if err == NoError then 37 | False 38 | 39 | else 40 | True 41 | 42 | NFA -> 43 | case err of 44 | EpsTransError -> 45 | True 46 | 47 | DuplicateStates _ -> 48 | True 49 | 50 | _ -> 51 | False 52 | 53 | 54 | machineCheck : SharedModel -> Error 55 | machineCheck sModel = 56 | let 57 | mac = 58 | sModel.machine 59 | 60 | tMistakes = 61 | getTransitionMistakes mac 62 | 63 | allTransitionLabels = 64 | List.sort <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values mac.transitionNames 65 | 66 | catch : Maybe (Set String) -> List String 67 | catch ms = 68 | case ms of 69 | Nothing -> 70 | [] 71 | 72 | Just s -> 73 | Set.toList s 74 | 75 | getTrans : Dict TransitionID StateID -> List String 76 | getTrans d = 77 | (List.concatMap (\e -> Dict.get e mac.transitionNames |> catch) <| Dict.keys d) |> List.sort 78 | 79 | foldingFunc : ( StateID, Dict TransitionID StateID ) -> Error -> Error 80 | foldingFunc sTuple err = 81 | case err of 82 | DFAError errType x -> 83 | DFAError errType x 84 | 85 | NoError -> 86 | let 87 | transitions = 88 | getTrans <| second sTuple 89 | 90 | stId = 91 | first sTuple 92 | in 93 | if transitions == allTransitionLabels then 94 | NoError 95 | 96 | else if List.member "\\epsilon" transitions then 97 | DFAError HasEpsilon stId 98 | 99 | else 100 | case compare (List.length transitions) (List.length allTransitionLabels) of 101 | LT -> 102 | DFAError Incomplete stId 103 | 104 | EQ -> 105 | DFAError Incomplete stId 106 | 107 | -- e.g. compare [1,1,2] [1,2,3], can be Nondeterministic too 108 | GT -> 109 | DFAError Nondeterministic stId 110 | 111 | otherErr -> 112 | otherErr 113 | in 114 | if tMistakes /= Nothing then 115 | EpsTransError 116 | 117 | else 118 | List.foldr (\x acc -> foldingFunc x acc) NoError <| Dict.toList mac.delta 119 | 120 | 121 | errorIcon : Color -> Color -> Shape msg 122 | errorIcon backclr shapeclrs = 123 | group 124 | [ triangle 20 |> filled backclr |> rotate 22.5 125 | , roundedRect 7.5 10 5 |> filled shapeclrs |> move ( 0, 7.5 ) 126 | , circle 3 |> filled shapeclrs |> move ( 0, -2.5 ) 127 | ] 128 | 129 | 130 | errorMenu : Error -> Machine -> Float -> Float -> Shape msg 131 | errorMenu err mac winX winY = 132 | let 133 | errStId = 134 | case err of 135 | DFAError _ stId -> 136 | case Dict.get stId mac.stateNames of 137 | Just name -> 138 | name 139 | 140 | Nothing -> 141 | "" 142 | 143 | _ -> 144 | "" 145 | 146 | errorHeader txt = 147 | group 148 | [ errorIcon red white 149 | , text txt 150 | |> size 20 151 | |> fixedwidth 152 | |> filled darkRed 153 | |> move ( 20, 0 ) 154 | ] 155 | |> scale 0.75 156 | |> move ( 0, -20 ) 157 | 158 | errorReason = 159 | group 160 | [ circle 3 |> filled red 161 | , (text <| 162 | case err of 163 | DFAError HasEpsilon _ -> 164 | "Possible cause: There are epsilon transitions" 165 | 166 | DFAError Incomplete _ -> 167 | "Possible cause: There are missing transitions" 168 | 169 | DFAError Nondeterministic _ -> 170 | "Possible cause: There are extraneous transitions" 171 | 172 | EpsTransError -> 173 | "Cause: Epsilon transitions are mixed with normal transitions" 174 | 175 | _ -> 176 | "You might have missed something somewhere?" 177 | ) 178 | |> size 12 179 | |> fixedwidth 180 | |> filled darkRed 181 | |> move ( 15, -5 ) 182 | ] 183 | |> move ( 0, -40 ) 184 | 185 | errorHint = 186 | group 187 | [ circle 3 |> filled red 188 | , (text <| 189 | case err of 190 | DFAError HasEpsilon _ -> 191 | "Hint: Try removing all your epsilon transitions" 192 | 193 | DFAError Incomplete _ -> 194 | "Hint: Check states for missing transitions" 195 | 196 | DFAError Nondeterministic _ -> 197 | "Hint: Find and remove extra transitions" 198 | 199 | EpsTransError -> 200 | "Hint: Switch to Build mode and fix transitions in red" 201 | 202 | _ -> 203 | "" 204 | ) 205 | |> size 12 206 | |> fixedwidth 207 | |> filled darkRed 208 | |> move ( 15, -5 ) 209 | ] 210 | |> move ( 0, -60 ) 211 | 212 | errorState = 213 | group 214 | [ circle 3 |> filled red 215 | , text "Hint: Check state " 216 | |> size 12 217 | |> fixedwidth 218 | |> filled darkRed 219 | |> move ( 15, -5 ) 220 | , latex 50 12 "blank" errStId AlignLeft |> move ( 150, 3 ) 221 | ] 222 | |> move ( 0, -80 ) 223 | 224 | actionHint = 225 | group 226 | [ circle 3 |> filled red 227 | , text "Go to Build mode to fix your machine, or use a NFA" 228 | |> size 12 229 | |> fixedwidth 230 | |> filled darkRed 231 | |> move ( 15, -5 ) 232 | ] 233 | |> move ( 0, -100 ) 234 | in 235 | case err of 236 | DFAError _ _ -> 237 | group [ errorHeader "DFA error: Your machine has a problem!", errorReason, errorHint, errorState, actionHint ] 238 | 239 | EpsTransError -> 240 | group [ errorHeader "Error: You have invalid state transitions!", errorReason, errorHint ] 241 | 242 | NoError -> 243 | group [] 244 | 245 | -- TODO: Add error handling for duplicate state names 246 | DuplicateStates _ -> 247 | group [] 248 | -------------------------------------------------------------------------------- /src/Exporting.elm: -------------------------------------------------------------------------------- 1 | module Exporting exposing (InputTape, Model(..), Msg(..), Output(..), PersistentModel, exportButton, exportTikz, generateTikz, indtBy, initPModel, onEnter, onExit, output, subscriptions, unlines, update, view) 2 | 3 | import Array exposing (Array) 4 | import Browser.Events 5 | import Dict exposing (Dict) 6 | import Environment exposing (Environment) 7 | import Error exposing (..) 8 | import GraphicSVG exposing (..) 9 | import Helpers exposing (..) 10 | import Html as H 11 | import Html.Attributes as A 12 | import Json.Decode as D 13 | import Machine exposing (..) 14 | import Mistakes exposing (..) 15 | import Set exposing (Set) 16 | import Sha256 exposing (sha256) 17 | import SharedModel exposing (..) 18 | import Task 19 | import Time exposing (Month(..), customZone, millisToPosix, toDay, toHour, toMinute, toMonth, toSecond, toYear) 20 | import Tuple exposing (first, second) 21 | 22 | 23 | subscriptions : Model -> Sub Msg 24 | subscriptions model = 25 | Sub.none 26 | 27 | 28 | type alias PersistentModel = 29 | { outputType : Output 30 | , time : Int 31 | } 32 | 33 | 34 | type alias InputTape = 35 | Array Character 36 | 37 | 38 | type Model 39 | = Default 40 | | HoverError 41 | | ShowingOutput 42 | 43 | 44 | type Output 45 | = Tikz 46 | 47 | 48 | type Msg 49 | = SelectOutput Output 50 | | GenerateOutput 51 | | CloseOutput 52 | | MachineMsg Machine.Msg 53 | | GetTime Int 54 | | HoverErrorEnter 55 | | HoverErrorExit 56 | 57 | 58 | onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) 59 | onEnter env ( pModel, sModel ) = 60 | ( ( Default, pModel, sModel ), False, Cmd.none ) 61 | 62 | 63 | onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) 64 | onExit env ( model, pModel, sModel ) = 65 | ( ( pModel, sModel ), False ) 66 | 67 | 68 | initPModel : PersistentModel 69 | initPModel = 70 | { outputType = Tikz 71 | , time = 0 72 | } 73 | 74 | 75 | update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) 76 | update env msg ( model, pModel, sModel ) = 77 | let 78 | machine = 79 | sModel.machine 80 | in 81 | case msg of 82 | SelectOutput outputType -> 83 | ( ( model, { pModel | outputType = outputType }, sModel ), False, Cmd.none ) 84 | 85 | GenerateOutput -> 86 | ( ( ShowingOutput, pModel, sModel ), False, Task.perform (GetTime << Time.posixToMillis) Time.now ) 87 | 88 | CloseOutput -> 89 | ( ( Default, pModel, sModel ), False, Cmd.none ) 90 | 91 | MachineMsg mmsg -> 92 | ( ( model, pModel, sModel ), False, Cmd.none ) 93 | 94 | GetTime t -> 95 | ( ( model, { pModel | time = t }, sModel ), False, Cmd.none ) 96 | 97 | HoverErrorEnter -> 98 | ( ( HoverError, pModel, sModel ), False, Cmd.none ) 99 | 100 | HoverErrorExit -> 101 | ( ( Default, pModel, sModel ), False, Cmd.none ) 102 | 103 | 104 | view : Environment -> ( Model, PersistentModel, SharedModel ) -> Shape Msg 105 | view env ( model, pModel, sModel ) = 106 | let 107 | oldMachine = 108 | sModel.machine 109 | 110 | winX = 111 | toFloat <| first env.windowSize 112 | 113 | winY = 114 | toFloat <| second env.windowSize 115 | 116 | menu = 117 | group <| 118 | [] 119 | 120 | errCheck = 121 | machineCheck sModel 122 | 123 | hasErr = 124 | contextHasError errCheck sModel.machineType 125 | 126 | transMistakes = 127 | getTransitionMistakes oldMachine 128 | 129 | -- TODO: Adjust popup box size to fix custom error messages 130 | errHover = 131 | group 132 | [ errorIcon red white 133 | , if model == HoverError then 134 | group [ roundedRect 465 110 5 |> filled darkGrey |> move ( 215, -55 ), errorMenu errCheck sModel.machine winX winY ] 135 | 136 | else 137 | group [] 138 | ] 139 | |> notifyEnter HoverErrorEnter 140 | |> notifyLeave HoverErrorExit 141 | |> move ( winX / 6 - 100, -105 ) 142 | in 143 | group 144 | [ (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine Set.empty transMistakes) |> move ( -winX / 6, 0 ) 145 | , machineSelected sModel.machineType winX winY 146 | , text "Choose format:" 147 | |> size 20 148 | |> fixedwidth 149 | |> filled black 150 | |> move ( winX / 6 - 125, 80 ) 151 | , exportTikz (pModel.outputType == Tikz) |> move ( winX / 6, 0 ) 152 | , exportButton (not hasErr) 153 | |> move ( winX / 6, -100 ) 154 | |> (if hasErr then 155 | identity 156 | 157 | else 158 | notifyTap GenerateOutput 159 | ) 160 | , if hasErr then 161 | errHover 162 | 163 | else 164 | group [] 165 | , case ( model, pModel.outputType ) of 166 | ( ShowingOutput, Tikz ) -> 167 | output (winX / 2) (winY / 2) (generateTikz pModel.time sModel.machine) 168 | 169 | _ -> 170 | group [] 171 | ] 172 | 173 | 174 | machineSelected : MachineType -> Float -> Float -> Shape Msg 175 | machineSelected mtype winX winY = 176 | let 177 | mtypeStr = 178 | case mtype of 179 | DFA -> 180 | "DFA" 181 | 182 | NFA -> 183 | "NFA" 184 | in 185 | text ("Your exported machine type: " ++ mtypeStr) 186 | |> centered 187 | |> fixedwidth 188 | |> filled darkGray 189 | |> move ( -winX / 2 + 117, winY / 2 - 32 ) 190 | 191 | 192 | exportTikz : Bool -> Shape Msg 193 | exportTikz selected = 194 | group 195 | [ roundedRect 250 75 5 196 | |> outlined (solid 2) darkGray 197 | , text "TikZ" 198 | |> size 20 199 | |> fixedwidth 200 | |> filled black 201 | |> move ( -50, 7.5 ) 202 | , roundedRect 30 15 2 203 | |> filled finsmBlue 204 | |> move ( 20, 12.5 ) 205 | , text "Beta" 206 | |> fixedwidth 207 | |> size 10 208 | |> centered 209 | |> filled white 210 | |> move ( 20, 9.5 ) 211 | , text "Export code to include" 212 | |> size 12 213 | |> fixedwidth 214 | |> filled black 215 | |> move ( -50, -10 ) 216 | , text "in a LaTeX document" 217 | |> size 12 218 | |> fixedwidth 219 | |> filled black 220 | |> move ( -50, -22.5 ) 221 | , circle 10 222 | |> outlined (solid 1) gray 223 | |> move ( -90, 0 ) 224 | , circle 8 225 | |> filled finsmBlue 226 | |> move ( -90, 0 ) 227 | ] 228 | 229 | 230 | exportButton clickable = 231 | group 232 | [ roundedRect 130 40 5 233 | |> filled 234 | (if clickable then 235 | finsmBlue 236 | 237 | else 238 | gray 239 | ) 240 | , text "Export" 241 | |> fixedwidth 242 | |> size 24 243 | |> centered 244 | |> filled 245 | (if clickable then 246 | white 247 | 248 | else 249 | darkGray 250 | ) 251 | |> move ( 0, -7 ) 252 | ] 253 | 254 | 255 | output w h txt = 256 | group 257 | [ roundedRect (w + 20) (h + 20) 5 258 | |> filled white 259 | |> addOutline (solid 1) gray 260 | , text "Select all and copy this code into your favourite LaTeX editor" 261 | |> fixedwidth 262 | |> size 8 263 | |> filled black 264 | |> move ( -w / 2, h / 2 - 5 ) 265 | , (html w (h - 10) <| 266 | H.div 267 | [ A.style "width" "100%" 268 | , A.style "height" "100%" 269 | , A.style "padding" "2px" 270 | , A.style "padding-right" "4px" 271 | ] 272 | [ H.textarea 273 | [ A.value txt 274 | , A.style "width" "99%" 275 | , A.style "height" "98%" 276 | , A.style "border" "none" 277 | , A.style "resize" "none" 278 | , A.style "border-radius" "2px" 279 | , A.style "position" "fixed" 280 | , A.readonly True 281 | ] 282 | [] 283 | ] 284 | ) 285 | |> move ( -w / 2, h / 2 - 12.5 ) 286 | , group 287 | [ circle 10 288 | |> filled white 289 | |> addOutline (solid 2) gray 290 | , roundedRect 10 3 1.5 |> filled gray 291 | , roundedRect 3 10 1.5 |> filled gray 292 | ] 293 | |> rotate (degrees 45) 294 | |> notifyTap CloseOutput 295 | |> move ( w / 2 - 5, h / 2 - 5 ) 296 | ] 297 | 298 | 299 | generateTikz : Int -> Machine -> String 300 | generateTikz time machine = 301 | let 302 | scale = 303 | 40 304 | 305 | states = 306 | indtBy 4 <| 307 | List.map oneState <| 308 | Dict.toList machine.statePositions 309 | 310 | stateName sId = 311 | case Dict.get sId machine.stateNames of 312 | Just n -> 313 | n 314 | 315 | _ -> 316 | "" 317 | 318 | statePos sId = 319 | case Dict.get sId machine.statePositions of 320 | Just p -> 321 | p 322 | 323 | _ -> 324 | ( 0, 0 ) 325 | 326 | dateStr = 327 | timeToString time 328 | 329 | hashCode = 330 | String.dropRight 56 << sha256 << String.append dateStr 331 | 332 | oneState ( sId, ( x, y ) ) = 333 | let 334 | ( tx, ty ) = 335 | ( String.fromFloat <| x / scale, String.fromFloat <| y / scale ) 336 | 337 | start = 338 | if Set.member sId machine.start then 339 | "initial,thick," 340 | 341 | else 342 | "thick," 343 | 344 | --"initial,thick," else "thick," -- 345 | final = 346 | if Set.member sId machine.final then 347 | "accepting," 348 | 349 | else 350 | "" 351 | in 352 | String.concat [ "\\node[", start, final, "state] at (", tx, ",", ty, ") (", hashCode <| stateName sId, ") {$", stateName sId, "$};" ] 353 | 354 | transitions = 355 | indtBy 4 <| 356 | List.map oneTransition <| 357 | Dict.toList machine.stateTransitions 358 | 359 | oneTransition ( ( s0, tId, s1 ), ( x1, y1 ) ) = 360 | let 361 | transitionName = 362 | case Dict.get tId machine.transitionNames of 363 | Just n -> 364 | renderSet2String n 365 | 366 | _ -> 367 | "" 368 | 369 | ( x0, y0 ) = 370 | statePos s0 371 | 372 | ( x2, y2 ) = 373 | statePos s1 374 | 375 | ( mx, my ) = 376 | ( (x2 + x0) / 2 + rx, (y2 + y0) / 2 + ry ) 377 | 378 | ( tx, ty ) = 379 | --tangent between to and from states 380 | ( x2 - x0, y2 - y0 ) 381 | 382 | r = 383 | 20 384 | 385 | -- radius of states 386 | theta = 387 | atan2 ty tx 388 | 389 | ( rx, ry ) = 390 | ( x1 * cos theta - y1 * sin theta, y1 * cos theta + x1 * sin theta ) 391 | 392 | ( inTheta, outTheta ) = 393 | if s0 == s1 then 394 | let 395 | mr = 396 | sqrt ((mx - x0) ^ 2 + (my - y0) ^ 2) 397 | 398 | mpl = 399 | mr - r 400 | 401 | beta = 402 | atan2 ry rx 403 | 404 | gamma = 405 | atan2 mpl mr 406 | in 407 | ( round <| (beta + gamma) * 180 / pi, round <| (beta - gamma) * 180 / pi ) 408 | 409 | else 410 | ( round <| atan2 (my - y2) (mx - x2) * 180 / pi 411 | , round <| atan2 (my - y0) (mx - x0) * 180 / pi 412 | ) 413 | 414 | position = 415 | case labelPosition y1 theta of 416 | Above -> 417 | "above" 418 | 419 | Below -> 420 | "below" 421 | 422 | Left -> 423 | "left" 424 | 425 | Right -> 426 | "right" 427 | 428 | loop = 429 | if s0 == s1 then 430 | let 431 | loopDistance = 432 | String.fromFloat <| roundPrec 2 <| sqrt (x1 ^ 2 + y1 ^ 2) / 40 433 | in 434 | String.concat [ "loop,min distance = ", loopDistance, "cm," ] 435 | 436 | else 437 | "" 438 | in 439 | String.concat [ "(", hashCode <| stateName s0, ") edge [", loop, position, ",in = ", String.fromInt inTheta, ", out = ", String.fromInt outTheta, "] node {$", transitionName, "$} (", hashCode <| stateName s1, ")" ] 440 | in 441 | unlines 442 | [ "%% Machine generated by https://finsm.io" 443 | , String.concat [ "%% ", dateStr ] 444 | , "%% include in preamble:" 445 | , "%% \\usepackage{tikz}" 446 | , "%% \\usetikzlibrary{automata,positioning,arrows}" 447 | , "\\begin{center}" 448 | , "\\begin{tikzpicture}[]" 449 | , states 450 | , " \\path[->, thick, >=stealth]" 451 | , transitions 452 | , " ;" 453 | , "\\end{tikzpicture}" 454 | , "\\end{center}" 455 | ] 456 | 457 | 458 | est = 459 | customZone (-5 * 60) [] 460 | 461 | 462 | monthToInt : Month -> Int 463 | monthToInt month = 464 | case month of 465 | Jan -> 466 | 1 467 | 468 | Feb -> 469 | 2 470 | 471 | Mar -> 472 | 3 473 | 474 | Apr -> 475 | 4 476 | 477 | May -> 478 | 5 479 | 480 | Jun -> 481 | 6 482 | 483 | Jul -> 484 | 7 485 | 486 | Aug -> 487 | 8 488 | 489 | Sep -> 490 | 9 491 | 492 | Oct -> 493 | 10 494 | 495 | Nov -> 496 | 11 497 | 498 | Dec -> 499 | 12 500 | 501 | 502 | timeToString : Int -> String 503 | timeToString timestamp = 504 | let 505 | year = 506 | toYear est (millisToPosix timestamp) 507 | 508 | month = 509 | toMonth est (millisToPosix timestamp) 510 | 511 | day = 512 | toDay est (millisToPosix timestamp) 513 | 514 | hour = 515 | toHour est (millisToPosix timestamp) 516 | 517 | minute = 518 | toMinute est (millisToPosix timestamp) 519 | 520 | second = 521 | toSecond est (millisToPosix timestamp) 522 | in 523 | String.fromInt year 524 | ++ "-" 525 | ++ String.fromInt (monthToInt month) 526 | ++ "-" 527 | ++ String.fromInt day 528 | ++ "-" 529 | ++ String.fromInt hour 530 | ++ ":" 531 | ++ (if minute < 10 then 532 | "0" 533 | 534 | else 535 | "" 536 | ) 537 | ++ String.fromInt minute 538 | ++ ":" 539 | ++ (if minute < 10 then 540 | "0" 541 | 542 | else 543 | "" 544 | ) 545 | ++ String.fromInt second 546 | 547 | 548 | unlines : List String -> String 549 | unlines = 550 | String.concat << List.intersperse "\n" 551 | 552 | 553 | indtBy : Int -> List String -> String 554 | indtBy n = 555 | unlines << List.map ((++) (String.repeat n " ")) 556 | -------------------------------------------------------------------------------- /src/Helpers.elm: -------------------------------------------------------------------------------- 1 | module Helpers exposing (LabelPosition(..), LatexAlign(..), add, dot, editIcon, finsmBlue, finsmLightBlue, focusInput, icon, labelPosition, latex, latexurl, mult, p, parseString2Set, parseTLabel, renderSet2String, renderString, roundPrec, roundTo, sendMsg, setMax, specialSymbols, sub, trashIcon, uncurry, vertex) 2 | 3 | import Browser.Dom as Dom 4 | import GraphicSVG exposing (..) 5 | import Html as H exposing (Html, input, node) 6 | import Html.Attributes exposing (attribute, placeholder, style, value) 7 | import Html.Events exposing (onInput) 8 | import Set exposing (Set) 9 | import String exposing (..) 10 | import Task 11 | import Url exposing (Url, percentEncode) 12 | 13 | 14 | 15 | -- import Parser exposing (..) -- Not working with Elm 0.19, switch when compatible 16 | 17 | 18 | finsmBlue = 19 | rgb 21 137 255 20 | 21 | 22 | finsmLightBlue = 23 | rgb 112 190 255 24 | 25 | 26 | vertex ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) = 27 | let 28 | p0 = 29 | ( x0, y0 ) 30 | 31 | p1 = 32 | ( x1, y1 ) 33 | 34 | p2 = 35 | ( x2, y2 ) 36 | 37 | p3 = 38 | add p0 p2 39 | 40 | t = 41 | dot (sub p0 p1) (sub p3 (mult p1 2)) / (dot p3 p3 - 4 * dot p1 (sub p3 p1)) 42 | in 43 | p p0 p1 p2 t 44 | 45 | 46 | p p0 p1 p2 t = 47 | add (mult p0 ((1 - t) ^ 2)) (add (mult (mult (mult p1 t) (1 - t)) 2) (mult p2 (t ^ 2))) 48 | 49 | 50 | add ( x0, y0 ) ( x1, y1 ) = 51 | ( x0 + x1, y0 + y1 ) 52 | 53 | 54 | mult ( x, y ) s = 55 | ( x * s, y * s ) 56 | 57 | 58 | sub ( x0, y0 ) ( x1, y1 ) = 59 | ( x0 - x1, y0 - y1 ) 60 | 61 | 62 | dot ( x0, y0 ) ( x1, y1 ) = 63 | x0 * x1 + y0 * y1 64 | 65 | 66 | editIcon = 67 | group 68 | [ --square 5 |> outlined (solid 1) black 69 | rect 5 2 70 | |> filled (rgb 21 137 255) 71 | |> rotate (degrees 45) 72 | |> move ( 3, 3 ) 73 | , triangle 1 74 | |> filled blue 75 | |> rotate (degrees -15) 76 | ] 77 | 78 | 79 | trashIcon = 80 | group 81 | [ roundedRect 30 40 3 82 | |> outlined (solid 4) black 83 | , rect 42 5 |> filled black |> move ( 0, 19.5 ) 84 | , roundedRect 36 5 1 |> filled black |> move ( 0, 21.5 ) 85 | , roundedRect 10 10 1 |> outlined (solid 3) black |> move ( 0, 23.5 ) 86 | , rect 4 30 |> filled black 87 | , rect 4 30 |> filled black |> move ( -8, 0 ) 88 | , rect 4 30 |> filled black |> move ( 8, 0 ) 89 | ] 90 | 91 | 92 | type LatexAlign 93 | = AlignLeft 94 | | AlignRight 95 | | AlignCentre 96 | 97 | 98 | latex w h backclr txt align = 99 | --image (latexurl txt) 100 | -- |> move 101 | -- ( case align of 102 | -- AlignLeft -> 103 | -- 0 104 | -- 105 | -- AlignRight -> 106 | -- -w 107 | -- 108 | -- AlignCentre -> 109 | -- -w / 2 110 | -- , 0 111 | -- ) 112 | (html w h <| 113 | H.div 114 | [ style "width" "100%" 115 | , style "height" "100%" 116 | , style "-moz-user-select" "none" 117 | , style "-webkit-user-select" "none" 118 | , style "-user-select" "none" 119 | 120 | -- , style "background-color" "red" 121 | ] 122 | [ H.img 123 | ([ style "background-color" backclr 124 | , Html.Attributes.attribute "onerror" ("this.src='" ++ latexurl "\\LaTeX?" ++ "'") 125 | , Html.Attributes.src (latexurl txt) 126 | 127 | --, style "width" "100%" 128 | , style "height" "100%" 129 | ] 130 | ++ (case align of 131 | AlignCentre -> 132 | [ style "margin-left" "auto" 133 | , style "margin-right" "auto" 134 | ] 135 | 136 | AlignLeft -> 137 | [ style "margin-right" "auto" 138 | ] 139 | 140 | AlignRight -> 141 | [ style "margin-left" "auto" 142 | ] 143 | ) 144 | ++ [ style "display" "block" 145 | , style "max-width" "100%" 146 | ] 147 | ) 148 | [] 149 | ] 150 | ) 151 | |> move 152 | ( case align of 153 | AlignLeft -> 154 | 0 155 | 156 | AlignRight -> 157 | -w 158 | 159 | AlignCentre -> 160 | -w / 2 161 | , 0 162 | ) 163 | 164 | 165 | latexurl : String -> String 166 | latexurl lx = 167 | "https://finsm.io/latex/render/" ++ percentEncode lx 168 | 169 | 170 | setMax : Set Int -> Int 171 | setMax s = 172 | Set.foldl max 0 s 173 | 174 | 175 | sendMsg : msg -> Cmd msg 176 | sendMsg msg = 177 | Task.perform identity (Task.succeed msg) 178 | 179 | 180 | focusInput : msg -> Cmd msg 181 | focusInput msg = 182 | Task.attempt (\_ -> msg) (Dom.focus "input") 183 | 184 | 185 | icon : Bool -> Shape msg -> Shape msg 186 | icon on sh = 187 | group 188 | [ circle 18 189 | |> filled 190 | (if on then 191 | finsmBlue 192 | 193 | else 194 | white 195 | ) 196 | |> addOutline (solid 1) (rgb 220 220 220) 197 | , sh 198 | ] 199 | 200 | 201 | 202 | -- Custom parsing for multiple state labels 203 | -- We treat ',' as a special delimiter for labels, and whitespace is ignored. 204 | -- To get ',' or ' ', they have to be placed inside delimiting parenthesis, 205 | -- which then becomes "{,}" and "{ }" 206 | 207 | 208 | specialSymbols = 209 | [ [ '{', ',', '}' ], [ '{', ' ', '}' ] ] 210 | 211 | 212 | parseTLabel : String -> List String 213 | parseTLabel s = 214 | let 215 | lst = 216 | String.toList s 217 | 218 | collect : List Char -> List Char -> List (List Char) -> List (List Char) 219 | collect input xs xxs = 220 | case input of 221 | [] -> 222 | List.reverse xs :: xxs 223 | 224 | y :: ys -> 225 | let 226 | hasSpecial = 227 | y :: List.take 2 ys 228 | 229 | check = 230 | List.member hasSpecial specialSymbols 231 | in 232 | if check then 233 | collect (List.drop 2 ys) [] <| hasSpecial :: xxs 234 | 235 | else if y == ',' then 236 | collect ys [] (List.reverse xs :: xxs) 237 | 238 | else if y == ' ' then 239 | collect ys xs xxs 240 | 241 | else 242 | collect ys (y :: xs) xxs 243 | 244 | parsedString = 245 | collect lst [] [] |> List.map String.fromList 246 | in 247 | parsedString |> List.map trim |> List.filter (\s1 -> s1 /= "") 248 | 249 | 250 | parseString2Set : String -> Set String 251 | parseString2Set = 252 | parseTLabel >> Set.fromList 253 | 254 | 255 | renderString : List String -> String 256 | renderString = 257 | String.join "," 258 | 259 | 260 | renderSet2String : Set String -> String 261 | renderSet2String = 262 | Set.toList >> renderString 263 | 264 | 265 | uncurry : (a -> b -> c) -> ( a, b ) -> c 266 | uncurry f ( a, b ) = 267 | f a b 268 | 269 | 270 | type LabelPosition 271 | = Above 272 | | Below 273 | | Left 274 | | Right 275 | 276 | 277 | labelPosition : Float -> Float -> LabelPosition 278 | labelPosition y1 theta = 279 | let 280 | thetaF = 281 | if theta < 0 then 282 | 2 * pi - abs theta 283 | 284 | else 285 | theta 286 | in 287 | if 0 <= thetaF && thetaF <= pi / 32 then 288 | if y1 > 0 then 289 | Above 290 | 291 | else 292 | Below 293 | 294 | else if pi / 32 < thetaF && thetaF <= 31 * pi / 32 then 295 | if y1 > 0 then 296 | Left 297 | 298 | else 299 | Right 300 | 301 | else if 31 * pi / 32 < thetaF && thetaF <= 33 * pi / 32 then 302 | if y1 > 0 then 303 | Below 304 | 305 | else 306 | Above 307 | 308 | else if 33 * pi / 32 < thetaF && thetaF <= 63 * pi / 32 then 309 | if y1 > 0 then 310 | Right 311 | 312 | else 313 | Left 314 | 315 | else if 63 * pi / 32 < thetaF then 316 | if y1 > 0 then 317 | Above 318 | 319 | else 320 | Below 321 | 322 | else 323 | Above 324 | 325 | 326 | roundTo : Float -> Float -> Float 327 | roundTo n m = 328 | Basics.toFloat (round (m + n / 2) // round n * round n) 329 | 330 | 331 | roundPrec : Int -> Float -> Float 332 | roundPrec n m = 333 | Basics.toFloat (round (m * Basics.toFloat (10 ^ n))) / Basics.toFloat (10 ^ n) 334 | -------------------------------------------------------------------------------- /src/Machine.elm: -------------------------------------------------------------------------------- 1 | module Machine exposing (..) 2 | 3 | import Dict exposing (Dict) 4 | import Environment exposing (Environment) 5 | import GraphicSVG exposing (..) 6 | import Helpers exposing (..) 7 | import Html as H exposing (Html, input, node) 8 | import Html.Attributes exposing (attribute, id, placeholder, style, value) 9 | import Html.Events exposing (onInput) 10 | import Json.Decode as D 11 | import Json.Encode as E 12 | import Set exposing (Set) 13 | import Utils exposing (decodeDict, decodePair, decodeSet, decodeTriple, encodeDict, encodePair, encodeSet, encodeTriple, textBox) 14 | 15 | 16 | type alias StateID = 17 | Int 18 | 19 | 20 | type alias StatePositions = 21 | Dict StateID ( Float, Float ) 22 | 23 | 24 | type alias TransitionID = 25 | Int 26 | 27 | 28 | type alias StateNames = 29 | Dict StateID String 30 | 31 | 32 | type alias TransitionNames = 33 | Dict TransitionID (Set String) 34 | 35 | 36 | type alias StateTransitions = 37 | Dict ( StateID, TransitionID, StateID ) ( Float, Float ) 38 | 39 | 40 | type alias Delta = 41 | Dict StateID (Dict TransitionID StateID) 42 | 43 | 44 | type alias Character = 45 | String 46 | 47 | 48 | type alias TransitionMistakes = 49 | Maybe (Set TransitionID) 50 | 51 | 52 | machineEncoder : Machine -> E.Value 53 | machineEncoder = 54 | machineEncoderV1 55 | 56 | 57 | machineEncoderV1 : Machine -> E.Value 58 | machineEncoderV1 machine = 59 | let 60 | transTriple = 61 | decodeTriple D.int D.int D.int 62 | 63 | qEncoder : Set StateID -> E.Value 64 | qEncoder = 65 | encodeSet E.int 66 | 67 | deltaEncoder : Delta -> E.Value 68 | deltaEncoder = 69 | encodeDict E.int (encodeDict E.int E.int) 70 | 71 | startEncoder : Set StateID -> E.Value 72 | startEncoder = 73 | encodeSet E.int 74 | 75 | finalEncoder : Set StateID -> E.Value 76 | finalEncoder = 77 | encodeSet E.int 78 | 79 | statePosEncoder : StatePositions -> E.Value 80 | statePosEncoder = 81 | encodeDict E.int (encodePair E.float E.float) 82 | 83 | transPosEncoder : StateTransitions -> E.Value 84 | transPosEncoder = 85 | encodeDict (encodeTriple E.int E.int E.int) (encodePair E.float E.float) 86 | 87 | stateNamesEncoder : StateNames -> E.Value 88 | stateNamesEncoder = 89 | encodeDict E.int E.string 90 | 91 | transNamesEncoder : TransitionNames -> E.Value 92 | transNamesEncoder = 93 | encodeDict E.int (encodeSet E.string) 94 | in 95 | E.object 96 | [ ( "q", qEncoder machine.q ) 97 | , ( "delta", deltaEncoder machine.delta ) 98 | , ( "start", startEncoder machine.start ) 99 | , ( "final", finalEncoder machine.final ) 100 | , ( "statePositions", statePosEncoder machine.statePositions ) 101 | , ( "transPositions", transPosEncoder machine.stateTransitions ) 102 | , ( "stateNames", stateNamesEncoder machine.stateNames ) 103 | , ( "transNames", transNamesEncoder machine.transitionNames ) 104 | , ( "v", E.int 1 ) 105 | ] 106 | 107 | 108 | machineDecoder : D.Decoder Machine 109 | machineDecoder = 110 | D.field "v" D.int 111 | |> D.andThen 112 | (\v -> 113 | case v of 114 | 1 -> 115 | machineDecoderV1 116 | 117 | _ -> 118 | D.fail <| "Invalid save metadata version " ++ String.fromInt v 119 | ) 120 | 121 | 122 | machineDecoderV1 : D.Decoder Machine 123 | machineDecoderV1 = 124 | let 125 | transTriple = 126 | decodeTriple D.int D.int D.int 127 | 128 | qDecoder : D.Decoder (Set StateID) 129 | qDecoder = 130 | D.field "q" <| decodeSet D.int 131 | 132 | deltaDecoder : D.Decoder Delta 133 | deltaDecoder = 134 | D.field "delta" <| decodeDict D.int (decodeDict D.int D.int) 135 | 136 | startDecoder : D.Decoder (Set StateID) 137 | startDecoder = 138 | D.field "start" <| decodeSet D.int 139 | 140 | finalDecoder : D.Decoder (Set StateID) 141 | finalDecoder = 142 | D.field "final" <| decodeSet D.int 143 | 144 | statePosDecoder : D.Decoder StatePositions 145 | statePosDecoder = 146 | D.field "statePositions" <| decodeDict D.int (decodePair D.float D.float) 147 | 148 | transPosDecoder : D.Decoder StateTransitions 149 | transPosDecoder = 150 | D.field "transPositions" <| decodeDict transTriple (decodePair D.float D.float) 151 | 152 | stateNamesDecoder : D.Decoder StateNames 153 | stateNamesDecoder = 154 | D.field "stateNames" <| decodeDict D.int D.string 155 | 156 | transNamesDecoder : D.Decoder TransitionNames 157 | transNamesDecoder = 158 | D.field "transNames" <| decodeDict D.int (decodeSet D.string) 159 | in 160 | D.map8 Machine 161 | qDecoder 162 | deltaDecoder 163 | startDecoder 164 | finalDecoder 165 | statePosDecoder 166 | transPosDecoder 167 | stateNamesDecoder 168 | transNamesDecoder 169 | 170 | 171 | type alias Machine = 172 | { q : Set StateID 173 | , delta : Delta 174 | , start : Set StateID 175 | , final : Set StateID 176 | , statePositions : StatePositions 177 | , stateTransitions : StateTransitions 178 | , stateNames : StateNames 179 | , transitionNames : TransitionNames 180 | } 181 | 182 | 183 | type Model 184 | = Regular 185 | | DraggingState StateID ( Float, Float ) ( Float, Float ) 186 | | SelectedState StateID 187 | | MousingOverRim StateID ( Float, Float ) 188 | | AddingArrow StateID ( Float, Float ) 189 | | AddingArrowOverOtherState StateID ( Float, Float ) StateID 190 | | MousingOverStateLabel StateID 191 | | MousingOverTransitionLabel TransitionID 192 | | EditingStateLabel StateID String 193 | | EditingTransitionLabel ( StateID, TransitionID, StateID ) String 194 | | SelectedArrow ( StateID, TransitionID, StateID ) 195 | | DraggingArrow ( StateID, TransitionID, StateID ) ( Float, Float ) 196 | | CreatingNewArrow StateID 197 | 198 | 199 | type Msg 200 | = StartDragging StateID ( Float, Float ) 201 | | StartDraggingArrow ( StateID, TransitionID, StateID ) ( Float, Float ) 202 | | StartMouseOverRim StateID ( Float, Float ) 203 | | MoveMouseOverRim ( Float, Float ) 204 | | StopMouseOverRim 205 | | SelectArrow ( StateID, TransitionID, StateID ) 206 | | MouseOverStateLabel StateID 207 | | MouseOverTransitionLabel TransitionID 208 | | MouseLeaveLabel 209 | | EditLabel StateID String 210 | | Drag ( Float, Float ) 211 | | TapState StateID 212 | | StopDragging 213 | | Reset 214 | 215 | 216 | test : Machine 217 | test = 218 | let 219 | q = 220 | Set.fromList [ 0, 1, 2, 3 ] 221 | 222 | delta0 = 223 | Dict.fromList 224 | [ ( 0, Dict.fromList [ ( 0, 1 ), ( 1, 2 ) ] ) 225 | , ( 1, Dict.fromList [ ( 2, 0 ), ( 3, 3 ) ] ) 226 | , ( 2, Dict.fromList [ ( 4, 3 ), ( 5, 0 ) ] ) 227 | , ( 3, Dict.fromList [ ( 6, 2 ), ( 7, 1 ) ] ) 228 | ] 229 | 230 | start = 231 | Set.fromList [ 0 ] 232 | 233 | final = 234 | Set.fromList [ 0 ] 235 | 236 | statePositions = 237 | Dict.fromList [ ( 0, ( -50, 50 ) ), ( 1, ( 50, 50 ) ), ( 2, ( -50, -50 ) ), ( 3, ( 50, -50 ) ) ] 238 | 239 | stateNames = 240 | Dict.fromList [ ( 0, "q_0" ), ( 1, "q_1" ), ( 2, "q_2" ), ( 3, "q_3" ) ] 241 | 242 | transitionNames = 243 | Dict.fromList <| List.map (\( k, str ) -> ( k, Set.singleton str )) [ ( 0, "1" ), ( 1, "0" ), ( 2, "1" ), ( 3, "0" ), ( 4, "1" ), ( 5, "0" ), ( 6, "1" ), ( 7, "0" ) ] 244 | 245 | stateTransitions = 246 | Dict.fromList 247 | [ ( ( 0, 0, 1 ), ( 0, 10 ) ) 248 | , ( ( 1, 2, 0 ), ( 0, 10 ) ) 249 | , ( ( 0, 1, 2 ), ( 0, 10 ) ) 250 | , ( ( 2, 5, 0 ), ( 0, 10 ) ) 251 | , ( ( 2, 4, 3 ), ( 0, 10 ) ) 252 | , ( ( 3, 6, 2 ), ( 0, 10 ) ) 253 | , ( ( 1, 3, 3 ), ( 0, 10 ) ) 254 | , ( ( 3, 7, 1 ), ( 0, 10 ) ) 255 | ] 256 | in 257 | Machine q delta0 start final statePositions stateTransitions stateNames transitionNames 258 | 259 | 260 | view : Environment -> Model -> Machine -> Set StateID -> TransitionMistakes -> Shape Msg 261 | view env model machine currentStates tMistakes = 262 | let 263 | ( winX, winY ) = 264 | env.windowSize 265 | 266 | dragRegion = 267 | rect (toFloat winX) (toFloat winY) 268 | |> filled blank 269 | |> notifyMouseMoveAt Drag 270 | |> notifyMouseUp StopDragging 271 | in 272 | group 273 | [ renderArrows machine model tMistakes 274 | , renderStates currentStates machine model env 275 | , case model of 276 | AddingArrow s ( x, y ) -> 277 | let 278 | s0Pos = 279 | case Dict.get s machine.statePositions of 280 | Just pos -> 281 | pos 282 | 283 | _ -> 284 | ( 0, 0 ) 285 | 286 | newTrans = 287 | case List.head <| Dict.values machine.transitionNames of 288 | Just schar -> 289 | Set.toList schar |> renderString 290 | 291 | Nothing -> 292 | " " 293 | 294 | newTransID = 295 | case List.head <| Dict.keys machine.transitionNames of 296 | Just char -> 297 | char 298 | 299 | Nothing -> 300 | 0 301 | in 302 | renderArrow s0Pos ( 0, 0 ) ( x, y ) 20 0 newTrans newTransID False False s -1 model 303 | 304 | AddingArrowOverOtherState s ( x, y ) s1 -> 305 | let 306 | s0Pos = 307 | case Dict.get s machine.statePositions of 308 | Just pos -> 309 | pos 310 | 311 | _ -> 312 | ( 0, 0 ) 313 | 314 | s1Pos = 315 | case Dict.get s1 machine.statePositions of 316 | Just pos -> 317 | pos 318 | 319 | _ -> 320 | ( 0, 0 ) 321 | 322 | newTrans = 323 | case List.head <| Dict.values machine.transitionNames of 324 | Just schar -> 325 | Set.toList schar |> renderString 326 | 327 | Nothing -> 328 | " " 329 | 330 | newTransID = 331 | case List.head <| Dict.keys machine.transitionNames of 332 | Just char -> 333 | char 334 | 335 | Nothing -> 336 | 0 337 | 338 | pullPos = 339 | if s == s1 then 340 | ( 0, 50 ) 341 | 342 | else 343 | ( 0, 0 ) 344 | in 345 | renderArrow s0Pos pullPos s1Pos 20 20 newTrans newTransID False False s s1 model 346 | 347 | _ -> 348 | group [] 349 | , case model of 350 | DraggingState _ _ _ -> 351 | dragRegion 352 | 353 | DraggingArrow _ _ -> 354 | dragRegion 355 | 356 | AddingArrow _ _ -> 357 | dragRegion 358 | 359 | AddingArrowOverOtherState _ _ _ -> 360 | dragRegion 361 | 362 | _ -> 363 | group [] 364 | ] 365 | 366 | 367 | 368 | --These two functions will eventually become part of GraphicSVG in some form 369 | 370 | 371 | arrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) = 372 | let 373 | ( dx, dy ) = 374 | ( x2 - x1, y2 - y1 ) 375 | in 376 | group 377 | [ curve ( x0, y0 ) 378 | [ Pull ( x1, y1 ) 379 | ( x2 - 2 * cos (atan2 dy dx) 380 | , y2 - 2 * sin (atan2 dy dx) 381 | ) 382 | ] 383 | |> outlined (solid 1) black 384 | , triangle 4 385 | |> filled black 386 | |> rotate (atan2 dy dx) 387 | |> move ( x2 - 4 * cos (atan2 dy dx), y2 - 4 * sin (atan2 dy dx) ) 388 | ] 389 | 390 | 391 | renderArrow : 392 | ( Float, Float ) 393 | -> ( Float, Float ) 394 | -> ( Float, Float ) 395 | -> Float 396 | -> Float 397 | -> Character 398 | -> TransitionID 399 | -> Bool 400 | -> Bool 401 | -> StateID 402 | -> StateID 403 | -> Model 404 | -> Shape Msg 405 | renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) r0 r1 char charID sel mistake s1 s2 model = 406 | let 407 | ( tx, ty ) = 408 | --tangent between to and from states 409 | ( x2 - x0, y2 - y0 ) 410 | 411 | theta = 412 | atan2 ty tx 413 | 414 | ( rx, ry ) = 415 | ( x1 * cos theta - y1 * sin theta, y1 * cos theta + x1 * sin theta ) 416 | 417 | ( mx, my ) = 418 | --pull point 419 | ( (x2 + x0) / 2 + rx, (y2 + y0) / 2 + ry ) 420 | 421 | ( dx0, dy0 ) = 422 | --tangent from middle point to from state 423 | ( mx - x0, my - y0 ) 424 | 425 | ( dx1, dy1 ) = 426 | --tangent from middle point to to state 427 | ( mx - x2, my - y2 ) 428 | 429 | ( xx0, yy0 ) = 430 | --from state position (with radius accounted for) 431 | if s1 == s2 then 432 | ( x0 + r0 * cos (atan2 dy0 dx0 + degrees 45), y0 + r0 * sin (atan2 dy0 dx0 + degrees 45) ) 433 | 434 | else 435 | ( x0 + r0 * cos (atan2 dy0 dx0), y0 + r0 * sin (atan2 dy0 dx0) ) 436 | 437 | ( xx1, yy1 ) = 438 | --to state position (with radius accounted for) 439 | if s1 == s2 then 440 | ( x0 + r0 * cos (atan2 dy0 dx0 - degrees 45), y0 + r0 * sin (atan2 dy0 dx0 - degrees 45) ) 441 | 442 | else 443 | ( x2 + r1 * cos (atan2 dy1 dx1), y2 + r1 * sin (atan2 dy1 dx1) ) 444 | 445 | tLblW = 446 | 200 447 | 448 | off = 449 | if y1 > 0 then 450 | 8 451 | 452 | else 453 | -8 454 | 455 | offset = 456 | ( -off * sin theta 457 | , off * cos theta 458 | ) 459 | 460 | alignment = 461 | case labelPosition y1 theta of 462 | Above -> 463 | AlignCentre 464 | 465 | Below -> 466 | AlignCentre 467 | 468 | Left -> 469 | AlignRight 470 | 471 | Right -> 472 | AlignLeft 473 | in 474 | group 475 | [ group 476 | [ if s1 == s2 then 477 | let 478 | mr = 479 | sqrt ((mx - x0) ^ 2 + (my - y0) ^ 2) 480 | 481 | mpl = 482 | mr - r0 483 | 484 | ppr = 485 | sqrt (mr ^ 2 + mpl ^ 2) 486 | 487 | beta = 488 | atan2 ry rx 489 | 490 | gamma = 491 | atan2 mpl mr 492 | 493 | ( x0s, y0s ) = 494 | ( x0 + r0 * cos (beta - gamma), y0 + r0 * sin (beta - gamma) ) 495 | 496 | ( x1s, y1s ) = 497 | ( x0 + r0 * cos (beta + gamma), y0 + r0 * sin (beta + gamma) ) 498 | in 499 | group 500 | [ curve ( x0s, y0s ) [ Pull ( x0 + ppr * cos (beta - gamma), y0 + ppr * sin (beta - gamma) ) ( mx, my ) ] 501 | |> outlined (solid 1) black 502 | , arrow ( mx, my ) ( x0 + ppr * cos (beta + gamma), y0 + ppr * sin (beta + gamma) ) ( x1s, y1s ) 503 | ] 504 | |> notifyMouseDown (SelectArrow ( s1, charID, s2 )) 505 | 506 | else 507 | arrow ( xx0, yy0 ) ( mx, my ) ( xx1, yy1 ) 508 | |> notifyMouseDown (SelectArrow ( s1, charID, s2 )) 509 | , group 510 | [ case model of 511 | EditingTransitionLabel ( _, tId, _ ) str -> 512 | if tId == charID then 513 | textBox str 514 | (if String.length str == 0 then 515 | 40 516 | 517 | else 518 | 8 * toFloat (String.length str) + 5 519 | ) 520 | 20 521 | "LaTeX" 522 | (EditLabel tId) 523 | 524 | else 525 | latex tLblW 526 | 12 527 | (if mistake then 528 | "LightSalmon" 529 | 530 | else 531 | "none" 532 | ) 533 | char 534 | alignment 535 | 536 | _ -> 537 | latex tLblW 538 | 12 539 | (if mistake then 540 | "LightSalmon" 541 | 542 | else 543 | "none" 544 | ) 545 | char 546 | alignment 547 | , case model of 548 | EditingTransitionLabel tId str -> 549 | group [] 550 | 551 | _ -> 552 | rect 50 20 553 | |> filled blank 554 | |> notifyTap (SelectArrow ( s1, charID, s2 )) 555 | ] 556 | |> (if s1 /= s2 then 557 | move ( 0, 7 ) 558 | >> move (p ( xx0, yy0 ) ( mx, my ) ( xx1, yy1 ) 0.5) 559 | >> move offset 560 | 561 | else 562 | move ( mx, my + 12 ) 563 | ) 564 | |> notifyLeave MouseLeaveLabel 565 | ] 566 | , if sel then 567 | group 568 | [ if s1 /= s2 then 569 | line ( xx0, yy0 ) ( mx, my ) |> outlined (dotted 1) black 570 | 571 | else 572 | group [] 573 | , if s1 /= s2 then 574 | line ( xx1, yy1 ) ( mx, my ) |> outlined (dotted 1) black 575 | 576 | else 577 | group [] 578 | , circle 3 579 | |> filled finsmBlue 580 | |> move ( mx, my ) 581 | |> notifyMouseDownAt (StartDraggingArrow ( s1, charID, s2 )) 582 | |> notifyMouseMoveAt Drag 583 | ] 584 | 585 | else 586 | group [] 587 | ] 588 | 589 | 590 | renderArrows : Machine -> Model -> TransitionMistakes -> Shape Msg 591 | renderArrows machine model tMistakes = 592 | let 593 | states = 594 | machine.q 595 | 596 | pos = 597 | machine.statePositions 598 | 599 | delta = 600 | machine.delta 601 | 602 | transPos = 603 | machine.stateTransitions 604 | 605 | stateList = 606 | Set.toList states 607 | 608 | edgeToList state = 609 | Dict.toList 610 | (case Dict.get state delta of 611 | Just d -> 612 | d 613 | 614 | Nothing -> 615 | Dict.empty 616 | ) 617 | 618 | getPos state = 619 | case Dict.get state pos of 620 | Just ( x, y ) -> 621 | ( x, y ) 622 | 623 | Nothing -> 624 | ( 0, 0 ) 625 | 626 | getTransPos ( s1, char, s2 ) = 627 | case Dict.get ( s1, char, s2 ) transPos of 628 | Just ( x, y ) -> 629 | ( x, y ) 630 | 631 | Nothing -> 632 | ( 0, 0 ) 633 | in 634 | group <| 635 | List.map 636 | (\s1 -> 637 | group 638 | (List.concat 639 | (List.map 640 | (\( chId, ss ) -> 641 | List.map 642 | (\s2 -> 643 | let 644 | ( x0, y0 ) = 645 | getPos s1 646 | 647 | ( x1, y1 ) = 648 | getTransPos ( s1, chId, s2 ) 649 | 650 | ( x2, y2 ) = 651 | getPos s2 652 | 653 | ch = 654 | case Dict.get chId machine.transitionNames of 655 | Just setc -> 656 | Set.toList setc |> renderString 657 | 658 | _ -> 659 | "" 660 | 661 | sel = 662 | case model of 663 | SelectedArrow ( ss1, char, ss2 ) -> 664 | char == chId 665 | 666 | DraggingArrow ( ss1, char, ss2 ) _ -> 667 | char == chId 668 | 669 | _ -> 670 | False 671 | 672 | -- Transition mistake function 673 | getTransMistake : TransitionMistakes -> TransitionID -> Bool 674 | getTransMistake transMistakes tId = 675 | case transMistakes of 676 | Nothing -> 677 | False 678 | 679 | Just setOfMistakes -> 680 | Set.member tId setOfMistakes 681 | 682 | mistake = 683 | getTransMistake tMistakes chId 684 | in 685 | group 686 | [ renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) 20 20 ch chId sel mistake s1 s2 model 687 | ] 688 | ) 689 | [ ss ] 690 | ) 691 | (edgeToList s1) 692 | ) 693 | ) 694 | ) 695 | stateList 696 | 697 | 698 | renderStates : Set StateID -> Machine -> Model -> Environment -> Shape Msg 699 | renderStates currentStates machine model env = 700 | let 701 | states = 702 | machine.q 703 | 704 | pos = 705 | machine.statePositions 706 | 707 | finals = 708 | machine.final 709 | 710 | stateList = 711 | Set.toList states 712 | 713 | getPos state = 714 | case Dict.get state pos of 715 | Just ( x, y ) -> 716 | ( x, y ) 717 | 718 | Nothing -> 719 | ( 0, 0 ) 720 | 721 | thickness state = 722 | if Set.member state currentStates then 723 | 2 724 | 725 | else 726 | 1 727 | 728 | stateName sId = 729 | case Dict.get sId machine.stateNames of 730 | Just n -> 731 | n 732 | 733 | _ -> 734 | "" 735 | 736 | startArrow = 737 | group 738 | [ arrow ( -15, 0 ) ( -5, 0 ) ( 0, 0 ) 739 | , latex 25 18 "none" "\\text{start}" AlignRight |> move ( -16, 9 ) 740 | ] 741 | |> move ( -20, 0 ) 742 | in 743 | group <| 744 | List.map 745 | (\sId -> 746 | group 747 | [ circle 30 748 | |> filled blank 749 | |> notifyEnterAt (StartMouseOverRim sId) 750 | |> notifyMouseMoveAt (StartMouseOverRim sId) 751 | , circle 20 752 | |> filled blank 753 | |> addOutline (solid (thickness sId)) black 754 | |> notifyMouseDownAt (StartDragging sId) 755 | , if Set.member sId finals then 756 | circle 17 757 | |> outlined (solid (thickness sId)) black 758 | 759 | else 760 | group [] 761 | , case model of 762 | EditingStateLabel st str -> 763 | if st == sId then 764 | textBox str 765 | (if String.length str == 0 then 766 | 40 767 | 768 | else 769 | 8 * toFloat (String.length str) + 5 770 | ) 771 | 20 772 | "LaTeX" 773 | (EditLabel sId) 774 | 775 | else 776 | group 777 | [ latex 25 18 "none" (stateName sId) AlignCentre 778 | |> move ( 0, 9 ) 779 | ] 780 | 781 | _ -> 782 | group 783 | [ latex 25 18 "none" (stateName sId) AlignCentre 784 | |> move ( 0, 9 ) 785 | ] 786 | , case model of 787 | SelectedState st -> 788 | if st == sId then 789 | circle 20.75 790 | |> outlined (solid 1.5) lightBlue 791 | 792 | else 793 | group [] 794 | 795 | MousingOverRim st ( x, y ) -> 796 | let 797 | ( x0, y0 ) = 798 | getPos st 799 | 800 | ( dx, dy ) = 801 | ( x - x0, y - y0 ) 802 | in 803 | if st == sId then 804 | group 805 | [ circle 500 806 | |> filled blank 807 | |> notifyEnter StopMouseOverRim 808 | , group 809 | [ circle 10 810 | |> filled white 811 | |> addOutline (solid 0.5) black 812 | , rect 10 1.5 |> filled black 813 | , rect 1.5 10 |> filled black 814 | ] 815 | |> notifyMouseMoveAt MoveMouseOverRim 816 | |> notifyLeave StopMouseOverRim 817 | |> move ( 20 * cos (atan2 dy dx), 20 * sin (atan2 dy dx) ) 818 | ] 819 | 820 | else 821 | group [] 822 | 823 | AddingArrowOverOtherState _ _ st -> 824 | if st == sId then 825 | circle 21.5 826 | |> outlined (solid 3) finsmLightBlue 827 | |> notifyLeave StopMouseOverRim 828 | 829 | else 830 | group [] 831 | 832 | _ -> 833 | group [] 834 | , if Set.member sId machine.start then 835 | startArrow 836 | 837 | else 838 | group [] 839 | ] 840 | |> move (getPos sId) 841 | |> (case model of 842 | EditingStateLabel _ _ -> 843 | identity 844 | 845 | _ -> 846 | if not env.holdingShift then 847 | notifyMouseDownAt (StartDragging sId) 848 | 849 | else 850 | notifyTap (TapState sId) 851 | ) 852 | ) 853 | stateList 854 | -------------------------------------------------------------------------------- /src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (Model, Module(..), Msg(..), initAppModel, main, modeButtons, textHtml, update, view) 2 | 3 | import ApplicationModel exposing (ApplicationModel, ApplicationState(..)) 4 | import Array exposing (Array) 5 | import BetterUndoList exposing (..) 6 | import Bootstrap.Modal as Modal 7 | import Browser exposing (UrlRequest(..)) 8 | import Browser.Dom 9 | import Browser.Events exposing (Visibility) 10 | import Building 11 | import Dict exposing (Dict) 12 | import Environment exposing (Environment) 13 | import Exporting 14 | import GraphicSVG exposing (..) 15 | import Helpers exposing (finsmBlue, icon, sendMsg) 16 | import Html as H exposing (Html, input, node) 17 | import Html.Attributes 18 | import Http 19 | import Json.Decode as D 20 | import Json.Encode 21 | import List 22 | import Machine exposing (..) 23 | import Ports 24 | import Random 25 | import SaveLoad exposing (saveMachine) 26 | import Set exposing (Set) 27 | import SharedModel exposing (SharedModel) 28 | import Simulating 29 | import Task 30 | import Time 31 | import Tuple exposing (first, second) 32 | import Url exposing (Url) 33 | 34 | 35 | type Msg 36 | = BMsg Building.Msg 37 | | SMsg Simulating.Msg 38 | | EMsg Exporting.Msg 39 | | SaveMsg SaveLoad.Msg 40 | | KeyPressed String 41 | | KeyReleased String 42 | | WindowSize ( Int, Int ) 43 | | UrlChange Url 44 | | UrlRequest UrlRequest 45 | | GoTo Module 46 | | VisibilityChanged Visibility 47 | | GetTime Time.Posix 48 | | GetTZ Time.Zone 49 | | MouseMoved ( Float, Float ) 50 | | NoOp 51 | 52 | 53 | type Module 54 | = BuildingModule 55 | | SimulatingModule 56 | | ExportingModule 57 | 58 | 59 | type alias Model = 60 | { appModel : BetterUndoList ApplicationModel 61 | , environment : Environment 62 | , saveModel : SaveLoad.Model 63 | } 64 | 65 | 66 | initAppModel : BetterUndoList ApplicationModel 67 | initAppModel = 68 | fresh initAppRecord 69 | 70 | 71 | initAppRecord = 72 | { appState = Building Building.init 73 | , sharedModel = SharedModel.init 74 | , simulatingData = Simulating.initPModel 75 | , buildingData = Building.initPModel 76 | , exportingData = Exporting.initPModel 77 | } 78 | 79 | 80 | main : App () Model Msg 81 | main = 82 | app 83 | { init = 84 | \flags url key -> 85 | let 86 | ( initSave, saveCmd ) = 87 | SaveLoad.initSaveModel 88 | in 89 | ( { appModel = initAppModel 90 | , environment = Environment.init 91 | , saveModel = initSave 92 | } 93 | , Cmd.batch 94 | [ Task.perform (\vp -> WindowSize ( round vp.viewport.width, round vp.viewport.height )) Browser.Dom.getViewport 95 | , Task.perform GetTime Time.now 96 | , Cmd.map SaveMsg saveCmd 97 | , Task.perform GetTZ Time.here 98 | ] 99 | ) 100 | , update = update 101 | , view = \m -> { body = view m, title = "finsm - create and simulate finite state machines" } 102 | , subscriptions = 103 | \model -> 104 | Sub.batch <| 105 | [ Browser.Events.onResize (\w h -> WindowSize ( w, h )) 106 | , Browser.Events.onKeyDown (D.map KeyPressed (D.field "key" D.string)) 107 | , Browser.Events.onKeyUp (D.map KeyReleased (D.field "key" D.string)) 108 | , Browser.Events.onVisibilityChange VisibilityChanged 109 | , case model.appModel.present.appState of 110 | Building m -> 111 | Sub.map BMsg (Building.subscriptions m) 112 | 113 | Simulating m -> 114 | Sub.map SMsg (Simulating.subscriptions m) 115 | 116 | Exporting m -> 117 | Sub.map EMsg (Exporting.subscriptions m) 118 | , Time.every 5000 GetTime -- get the new time every 10 seconds 119 | , Sub.map SaveMsg (SaveLoad.subscriptions model.saveModel) 120 | , Browser.Events.onMouseMove (decodeMousePosition model.environment.windowSize) 121 | ] 122 | , onUrlChange = UrlChange 123 | , onUrlRequest = UrlRequest 124 | } 125 | 126 | decodeMousePosition : ( Int , Int ) -> D.Decoder Msg 127 | decodeMousePosition ( w, h ) = 128 | D.map2 (\x y -> MouseMoved ( -(toFloat w)/2 + x, (toFloat h)/2 - y )) 129 | (D.field "pageX" D.float) 130 | (D.field "pageY" D.float) 131 | 132 | {- replace : state -> UndoList state -> UndoList state 133 | replace st stul = 134 | { stul | present = st } 135 | -} 136 | 137 | 138 | moduleUpdate : 139 | Environment 140 | -> mMsg 141 | -> mModel 142 | -> pModel 143 | -> Model 144 | -> (mMsg -> Msg) 145 | -> (mModel -> ApplicationState) 146 | -> (pModel -> ApplicationModel -> ApplicationModel) 147 | -> (Environment -> mMsg -> ( mModel, pModel, SharedModel ) -> ( ( mModel, pModel, SharedModel ), Bool, Cmd mMsg )) 148 | -> ( Model, Cmd Msg ) 149 | moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel mUpdate = 150 | let 151 | currentAppState = 152 | model.appModel.present 153 | 154 | ( ( newM, newPModel, newSModel ), checkpoint, cmd ) = 155 | mUpdate env mMsg ( mModel, pModel, currentAppState.sharedModel ) 156 | 157 | newAppState = 158 | { currentAppState 159 | | appState = appStateWrapper newM 160 | , sharedModel = newSModel 161 | } 162 | |> setpModel newPModel 163 | 164 | sm = 165 | model.saveModel 166 | in 167 | ( { model 168 | | appModel = 169 | if checkpoint then 170 | new newAppState model.appModel 171 | 172 | else 173 | replace newAppState model.appModel 174 | , saveModel = 175 | { sm 176 | | unsavedChanges = 177 | if checkpoint then 178 | True 179 | 180 | else 181 | sm.unsavedChanges 182 | } 183 | } 184 | , Cmd.map msgWrapper cmd 185 | ) 186 | 187 | 188 | update : Msg -> Model -> ( Model, Cmd Msg ) 189 | update msg model = 190 | let 191 | oldEnvironment = 192 | model.environment 193 | 194 | currentAppState = 195 | model.appModel.present 196 | 197 | sm = 198 | model.saveModel 199 | in 200 | case msg of 201 | BMsg bmsg -> 202 | case currentAppState.appState of 203 | Building m -> 204 | moduleUpdate 205 | oldEnvironment 206 | bmsg 207 | m 208 | currentAppState.buildingData 209 | model 210 | BMsg 211 | Building 212 | (\pm am -> { am | buildingData = pm }) 213 | Building.update 214 | 215 | _ -> 216 | ( model, Cmd.none ) 217 | 218 | SMsg smsg -> 219 | case currentAppState.appState of 220 | Simulating m -> 221 | moduleUpdate 222 | oldEnvironment 223 | smsg 224 | m 225 | currentAppState.simulatingData 226 | model 227 | SMsg 228 | Simulating 229 | (\pm am -> { am | simulatingData = pm }) 230 | Simulating.update 231 | 232 | _ -> 233 | ( model, Cmd.none ) 234 | 235 | EMsg emsg -> 236 | case currentAppState.appState of 237 | Exporting m -> 238 | moduleUpdate 239 | oldEnvironment 240 | emsg 241 | m 242 | currentAppState.exportingData 243 | model 244 | EMsg 245 | Exporting 246 | (\pm am -> { am | exportingData = pm }) 247 | Exporting.update 248 | 249 | _ -> 250 | ( model, Cmd.none ) 251 | 252 | WindowSize ( w, h ) -> 253 | ( { model | environment = { oldEnvironment | windowSize = ( w, h ) } }, Cmd.none ) 254 | 255 | UrlChange _ -> 256 | ( model, Cmd.none ) 257 | 258 | UrlRequest url -> 259 | ( model, Cmd.none ) 260 | 261 | KeyReleased k -> 262 | if k == "Shift" then 263 | ( { model | environment = { oldEnvironment | holdingShift = False } }, Cmd.none ) 264 | 265 | else if k == "Meta" then 266 | ( { model | environment = { oldEnvironment | holdingMeta = False } }, Cmd.none ) 267 | 268 | else if k == "Control" then 269 | ( { model | environment = { oldEnvironment | holdingControl = False } }, Cmd.none ) 270 | 271 | else if k == "Enter" then 272 | ( { model | saveModel = { sm | editingName = False, unsavedChanges = True } }, Cmd.none ) 273 | 274 | else 275 | ( model, Cmd.none ) 276 | 277 | KeyPressed k -> 278 | let 279 | normalizedKey = 280 | String.toLower k 281 | in 282 | if normalizedKey == "shift" then 283 | ( { model | environment = { oldEnvironment | holdingShift = True } }, Cmd.none ) 284 | 285 | else if normalizedKey == "y" || normalizedKey == "z" then 286 | let 287 | doUndo = 288 | (oldEnvironment.holdingControl || oldEnvironment.holdingMeta) && normalizedKey == "z" 289 | 290 | doRedo = 291 | (oldEnvironment.holdingControl && normalizedKey == "y") 292 | || (oldEnvironment.holdingMeta && oldEnvironment.holdingShift && normalizedKey == "z") 293 | in 294 | ( { model 295 | | appModel = 296 | if doRedo then 297 | redo model.appModel 298 | 299 | else if doUndo then 300 | undo model.appModel 301 | 302 | else 303 | model.appModel 304 | , saveModel = { sm | unsavedChanges = doRedo || doUndo } 305 | } 306 | , Cmd.none 307 | ) 308 | 309 | else if normalizedKey == "meta" then 310 | --pressed meta key 311 | ( { model | environment = { oldEnvironment | holdingMeta = True } }, Cmd.none ) 312 | 313 | else if normalizedKey == "control" then 314 | --pressed control 315 | ( { model | environment = { oldEnvironment | holdingControl = True } }, Cmd.none ) 316 | {- else if k == 66 then 317 | ( model, sendMsg <| GoTo BuildingModule ) 318 | 319 | else if k == 83 then 320 | ( model, sendMsg <| GoTo SimulatingModule ) 321 | -} 322 | 323 | else 324 | ( model, Cmd.none ) 325 | 326 | GoTo mod -> 327 | let 328 | exit = 329 | case currentAppState.appState of 330 | Building m -> 331 | processExit 332 | oldEnvironment 333 | m 334 | currentAppState.buildingData 335 | model 336 | (\pm am -> { am | buildingData = pm }) 337 | Building.onExit 338 | 339 | Simulating m -> 340 | processExit 341 | oldEnvironment 342 | m 343 | currentAppState.simulatingData 344 | model 345 | (\pm am -> { am | simulatingData = pm }) 346 | Simulating.onExit 347 | 348 | Exporting m -> 349 | processExit 350 | oldEnvironment 351 | m 352 | currentAppState.exportingData 353 | model 354 | (\pm am -> { am | exportingData = pm }) 355 | Exporting.onExit 356 | 357 | ( enter, cmd ) = 358 | case mod of 359 | BuildingModule -> 360 | processEnter 361 | oldEnvironment 362 | currentAppState.buildingData 363 | exit 364 | BMsg 365 | Building 366 | (\pm am -> { am | buildingData = pm }) 367 | Building.onEnter 368 | 369 | SimulatingModule -> 370 | processEnter 371 | oldEnvironment 372 | currentAppState.simulatingData 373 | exit 374 | SMsg 375 | Simulating 376 | (\pm am -> { am | simulatingData = pm }) 377 | Simulating.onEnter 378 | 379 | ExportingModule -> 380 | processEnter 381 | oldEnvironment 382 | currentAppState.exportingData 383 | exit 384 | EMsg 385 | Exporting 386 | (\pm am -> { am | exportingData = pm }) 387 | Exporting.onEnter 388 | in 389 | ( { model | appModel = enter }, cmd ) 390 | 391 | VisibilityChanged vis -> 392 | ( { model 393 | | environment = 394 | { oldEnvironment 395 | | holdingShift = False 396 | , holdingControl = False 397 | , holdingMeta = False 398 | } 399 | } 400 | , Cmd.none 401 | ) 402 | 403 | GetTime time -> 404 | let 405 | oldEnv = 406 | model.environment 407 | in 408 | ( { model | environment = { oldEnv | currentTime = time } } 409 | , Cmd.none 410 | ) 411 | 412 | SaveMsg saveMsg -> 413 | case saveMsg of 414 | SaveLoad.LoadMachineResponse response -> 415 | case response of 416 | Ok loadPayload -> 417 | let 418 | initSharedModel = 419 | SharedModel.init 420 | 421 | newSharedModel = 422 | { initSharedModel | machine = loadPayload.machine } 423 | 424 | initSimModel = 425 | Simulating.initPModel 426 | 427 | --{ appState = Building Building.init 428 | --, sharedModel = SharedModel.init 429 | --, simulatingData = Simulating.initPModel 430 | --, buildingData = Building.initPModel 431 | --, exportingData = Exporting.initPModel 432 | --} 433 | newModel = 434 | fresh 435 | { initAppRecord 436 | | sharedModel = newSharedModel 437 | , simulatingData = { initSimModel | tapes = Simulating.checkTapesNoStatus newSharedModel loadPayload.tapes } 438 | } 439 | in 440 | ( { model 441 | | appModel = newModel 442 | , saveModel = 443 | let 444 | meta = 445 | sm.machineMetadata 446 | in 447 | { sm | lastSaved = oldEnvironment.currentTime, machineData = SaveLoad.MachineCreated, machineMetadata = { meta | name = loadPayload.name, id = loadPayload.uuid } } 448 | } 449 | , Cmd.none 450 | ) 451 | 452 | Err _ -> 453 | ( model, Cmd.none ) 454 | 455 | SaveLoad.CreateNewMachine -> 456 | let 457 | initSharedModel = 458 | SharedModel.init 459 | 460 | newSharedModel = 461 | initSharedModel 462 | 463 | initSimModel = 464 | Simulating.initPModel 465 | 466 | --{ appState = Building Building.init 467 | --, sharedModel = SharedModel.init 468 | --, simulatingData = Simulating.initPModel 469 | --, buildingData = Building.initPModel 470 | --, exportingData = Exporting.initPModel 471 | --} 472 | newModel = 473 | fresh 474 | { initAppRecord 475 | | sharedModel = newSharedModel 476 | , simulatingData = initSimModel 477 | } 478 | in 479 | ( { model 480 | | appModel = newModel 481 | , saveModel = 482 | { sm 483 | | lastSaved = oldEnvironment.currentTime 484 | , machineData = SaveLoad.MachineCreated 485 | , loadDialog = SaveLoad.NothingOpen 486 | , loadDialogModal = Modal.hidden 487 | , machineMetadata = SaveLoad.initMachineMetadata 488 | } 489 | } 490 | , Cmd.none 491 | ) 492 | 493 | other -> 494 | let 495 | ( newSM, sCmd ) = 496 | SaveLoad.update other model.saveModel model.environment model.appModel.present 497 | in 498 | ( { model | saveModel = newSM }, Cmd.map SaveMsg sCmd ) 499 | 500 | GetTZ zone -> 501 | ( { model | environment = { oldEnvironment | timeZone = zone } }, Cmd.none ) 502 | 503 | MouseMoved ( x, y ) -> 504 | ( { model | environment = { oldEnvironment | mousePos = ( x, y ) } }, Cmd.none ) 505 | 506 | NoOp -> 507 | ( model, Cmd.none ) 508 | 509 | 510 | processExit : 511 | Environment 512 | -> mModel 513 | -> pModel 514 | -> Model 515 | -> (pModel -> ApplicationModel -> ApplicationModel) 516 | -> (Environment -> ( mModel, pModel, SharedModel ) -> ( ( pModel, SharedModel ), Bool )) 517 | -> BetterUndoList ApplicationModel 518 | processExit env m pModel model setpModel onExit = 519 | let 520 | currentAppState = 521 | model.appModel.present 522 | 523 | ( ( newPModel, newSModel ), checkpoint ) = 524 | onExit env ( m, pModel, currentAppState.sharedModel ) 525 | 526 | newAppState = 527 | { currentAppState | sharedModel = newSModel } 528 | |> setpModel newPModel 529 | in 530 | if checkpoint then 531 | new newAppState model.appModel 532 | 533 | else 534 | replace newAppState model.appModel 535 | 536 | 537 | processEnter : 538 | Environment 539 | -> pModel 540 | -> BetterUndoList ApplicationModel 541 | -> (mMsg -> Msg) 542 | -> (mModel -> ApplicationState) 543 | -> (pModel -> ApplicationModel -> ApplicationModel) 544 | -> (Environment -> ( pModel, SharedModel ) -> ( ( mModel, pModel, SharedModel ), Bool, Cmd mMsg )) 545 | -> ( BetterUndoList ApplicationModel, Cmd Msg ) 546 | processEnter env pModel exitModel msgWrapper appStateWrapper setpModel onEnter = 547 | let 548 | exitAppState = 549 | exitModel.present 550 | 551 | ( ( newM, newPModel, newSModel ), checkpoint, mCmd ) = 552 | onEnter env ( pModel, exitAppState.sharedModel ) 553 | 554 | newAppState = 555 | { exitAppState | appState = appStateWrapper newM, sharedModel = newSModel } 556 | |> setpModel newPModel 557 | in 558 | ( if checkpoint then 559 | new newAppState exitModel 560 | 561 | else 562 | replace newAppState exitModel 563 | , Cmd.map msgWrapper mCmd 564 | ) 565 | 566 | 567 | textHtml : String -> Html msg 568 | textHtml t = 569 | H.span 570 | [ Json.Encode.string t 571 | |> Html.Attributes.property "innerHTML" 572 | ] 573 | [] 574 | 575 | 576 | view model = 577 | let 578 | {- accepted = 579 | isAccept model.states oldMachine.final model.input model.inputAt 580 | -} 581 | winX = 582 | toFloat <| first model.environment.windowSize 583 | 584 | winY = 585 | toFloat <| second model.environment.windowSize 586 | 587 | appState = 588 | model.appModel.present 589 | in 590 | collage 591 | winX 592 | --winX 593 | winY 594 | --winY 595 | [ case appState.appState of 596 | Building m -> 597 | GraphicSVG.map BMsg <| Building.view model.environment ( m, appState.buildingData, appState.sharedModel ) 598 | 599 | Simulating m -> 600 | GraphicSVG.map SMsg <| Simulating.view model.environment ( m, appState.simulatingData, appState.sharedModel ) 601 | 602 | Exporting m -> 603 | GraphicSVG.map EMsg <| Exporting.view model.environment ( m, appState.exportingData, appState.sharedModel ) 604 | , modeButtons model 605 | , icon False (text "?" |> size 30 |> fixedwidth |> centered |> filled (rgb 220 220 220) |> move ( 0, -9 )) 606 | |> addHyperlink "https://github.com/CSchank/finsm/wiki" 607 | |> move ( winX / 2 - 25, -winY / 2 + 25 ) 608 | ] 609 | 610 | 611 | modeButtons model = 612 | let 613 | winX = 614 | toFloat <| first model.environment.windowSize 615 | 616 | winY = 617 | toFloat <| second model.environment.windowSize 618 | 619 | building = 620 | case model.appModel.present.appState of 621 | Building _ -> 622 | True 623 | 624 | _ -> 625 | False 626 | 627 | simulating = 628 | case model.appModel.present.appState of 629 | Simulating _ -> 630 | True 631 | 632 | _ -> 633 | False 634 | 635 | exporting = 636 | case model.appModel.present.appState of 637 | Exporting _ -> 638 | True 639 | 640 | _ -> 641 | False 642 | in 643 | group 644 | [ group 645 | [ roundedRect 40 15 1 646 | |> filled 647 | (if building then 648 | finsmBlue 649 | 650 | else 651 | blank 652 | ) 653 | |> addOutline (solid 1) darkGray 654 | , text "Build" 655 | |> centered 656 | |> fixedwidth 657 | |> filled 658 | (if building then 659 | white 660 | 661 | else 662 | darkGray 663 | ) 664 | |> move ( 0, -4 ) 665 | ] 666 | |> move ( -winX / 2 + 25, winY / 2 - 15 ) 667 | |> notifyTap (GoTo BuildingModule) 668 | , group 669 | [ roundedRect 60 15 1 670 | |> filled 671 | (if simulating then 672 | finsmBlue 673 | 674 | else 675 | blank 676 | ) 677 | |> addOutline (solid 1) darkGray 678 | , text "Simulate" 679 | |> centered 680 | |> fixedwidth 681 | |> filled 682 | (if simulating then 683 | white 684 | 685 | else 686 | darkGray 687 | ) 688 | |> move ( 0, -4 ) 689 | ] 690 | |> move ( -winX / 2 + 77, winY / 2 - 15 ) 691 | |> notifyTap (GoTo SimulatingModule) 692 | , group 693 | [ roundedRect 50 15 1 694 | |> filled 695 | (if exporting then 696 | finsmBlue 697 | 698 | else 699 | blank 700 | ) 701 | |> addOutline (solid 1) darkGray 702 | , text "Export" 703 | |> centered 704 | |> fixedwidth 705 | |> filled 706 | (if exporting then 707 | white 708 | 709 | else 710 | darkGray 711 | ) 712 | |> move ( 0, -4 ) 713 | ] 714 | |> move ( -winX / 2 + 134, winY / 2 - 15 ) 715 | |> notifyTap (GoTo ExportingModule) 716 | , GraphicSVG.map SaveMsg <| SaveLoad.view model.saveModel model.environment 717 | ] 718 | 719 | 720 | errorEpsTrans model = 721 | let 722 | winX = 723 | toFloat <| first model.environment.windowSize 724 | 725 | winY = 726 | toFloat <| second model.environment.windowSize 727 | in 728 | group 729 | [ rectangle winX winY 730 | |> filled darkGray 731 | |> makeTransparent 0.75 732 | , group 733 | [ roundedRect 300 150 1 |> filled lightGray 734 | , text "finsm: Build Error" 735 | |> bold 736 | |> centered 737 | |> filled lightRed 738 | |> scale 2 739 | |> move ( 0, 40 ) 740 | , text "You have invalid states:" 741 | |> filled darkRed 742 | |> scale 1.2 743 | |> move ( -140, 5 ) 744 | , text "> Maybe ε-transitions are used with other transitions?" 745 | |> filled darkRed 746 | |> move ( -140, -10 ) 747 | , text "> Hint: Fix transitions highlighted in red" 748 | |> filled darkGreen 749 | |> move ( -140, -25 ) 750 | , text "Hit any key to dismiss this message" 751 | |> bold 752 | |> centered 753 | |> filled black 754 | |> scale 1.25 755 | |> move ( 0, -60 ) 756 | ] 757 | ] 758 | -------------------------------------------------------------------------------- /src/Mistakes.elm: -------------------------------------------------------------------------------- 1 | module Mistakes exposing (checkEpsilonTransLabel, checkTransitionValid, getTransitionMistakes) 2 | 3 | import Dict exposing (..) 4 | import Machine exposing (..) 5 | import Set exposing (..) 6 | 7 | 8 | getTransitionMistakes : Machine -> TransitionMistakes 9 | getTransitionMistakes mac = 10 | let 11 | tNames = 12 | mac.transitionNames 13 | in 14 | checkEpsilonTransLabel tNames 15 | 16 | 17 | 18 | -- Check if an epsilon label is well-typed 19 | 20 | 21 | checkEpsilonTransLabel : TransitionNames -> TransitionMistakes 22 | checkEpsilonTransLabel tNames = 23 | let 24 | tMistakes = 25 | Dict.foldl 26 | (\tid tnames tmistakes -> 27 | if not (checkTransitionValid tnames) then 28 | Set.insert tid tmistakes 29 | 30 | else 31 | tmistakes 32 | ) 33 | Set.empty 34 | tNames 35 | in 36 | if Set.isEmpty tMistakes then 37 | Nothing 38 | 39 | else 40 | Just tMistakes 41 | 42 | 43 | checkTransitionValid : Set.Set String -> Bool 44 | checkTransitionValid set = 45 | case Set.member "\\epsilon" set of 46 | False -> 47 | True 48 | 49 | True -> 50 | if Set.size set == 1 then 51 | True 52 | 53 | else 54 | False 55 | -------------------------------------------------------------------------------- /src/Ports.elm: -------------------------------------------------------------------------------- 1 | port module Ports exposing (..) 2 | 3 | 4 | port launchLogin : () -> Cmd msg 5 | 6 | 7 | port launchLogout : () -> Cmd msg 8 | 9 | 10 | port loginComplete : (() -> msg) -> Sub msg 11 | 12 | 13 | port logoutComplete : (() -> msg) -> Sub msg 14 | -------------------------------------------------------------------------------- /src/SaveLoad.elm: -------------------------------------------------------------------------------- 1 | module SaveLoad exposing (..) 2 | 3 | import ApplicationModel exposing (ApplicationModel) 4 | import Bootstrap.Button as Button 5 | import Bootstrap.ButtonGroup as ButtonGroup 6 | import Bootstrap.Card as Card 7 | import Bootstrap.Card.Block as Block 8 | import Bootstrap.Grid as Grid 9 | import Bootstrap.Grid.Row as Row 10 | import Bootstrap.ListGroup as ListGroup 11 | import Bootstrap.Modal as Modal 12 | import Bootstrap.Spinner as Spinner 13 | import Bootstrap.Tab as Tab 14 | import Bootstrap.Text as Text 15 | import Bootstrap.Utilities.Flex as Flex 16 | import Bootstrap.Utilities.Size as Size 17 | import Bootstrap.Utilities.Spacing as Spacing 18 | import Browser.Events 19 | import Dict exposing (Dict) 20 | import Duration 21 | import Environment exposing (Environment) 22 | import GraphicSVG exposing (..) 23 | import Helpers exposing (editIcon) 24 | import Html exposing (Html) 25 | import Html.Attributes exposing (attribute, placeholder, style, value) 26 | import Html.Events exposing (onInput) 27 | import Http 28 | import Json.Decode as D 29 | import Json.Encode as E 30 | import Machine exposing (Machine) 31 | import Ports 32 | import Simulating exposing (InputTape) 33 | import Time exposing (Posix) 34 | import Utils exposing (newMsg, textBox) 35 | 36 | 37 | type MachineType 38 | = DFA 39 | | NFA 40 | | NPDA 41 | | Turing 42 | 43 | 44 | type FilterType 45 | = FilterActive 46 | | MachineFilter MachineType 47 | | FilterArchived 48 | 49 | 50 | filterToString : FilterType -> String 51 | filterToString f = 52 | case f of 53 | FilterActive -> 54 | "all" 55 | 56 | MachineFilter m -> 57 | machineTypeStr m 58 | 59 | FilterArchived -> 60 | "arc" 61 | 62 | 63 | decodeMachineType : D.Decoder MachineType 64 | decodeMachineType = 65 | D.string 66 | |> D.andThen 67 | (\m -> 68 | case m of 69 | "D" -> 70 | D.succeed DFA 71 | 72 | "N" -> 73 | D.succeed NFA 74 | 75 | "P" -> 76 | D.succeed NPDA 77 | 78 | "T" -> 79 | D.succeed Turing 80 | 81 | s -> 82 | D.fail <| "Invalid string " ++ s ++ " for machine type" 83 | ) 84 | 85 | 86 | encodeMachineType : MachineType -> E.Value 87 | encodeMachineType = 88 | E.string << machineTypeStr 89 | 90 | 91 | machineTypeStr : MachineType -> String 92 | machineTypeStr m = 93 | case m of 94 | DFA -> 95 | "D" 96 | 97 | NFA -> 98 | "N" 99 | 100 | NPDA -> 101 | "P" 102 | 103 | Turing -> 104 | "T" 105 | 106 | 107 | machineTypeFullStr : MachineType -> String 108 | machineTypeFullStr m = 109 | case m of 110 | DFA -> 111 | "DFA" 112 | 113 | NFA -> 114 | "NFA" 115 | 116 | NPDA -> 117 | "NPDA" 118 | 119 | Turing -> 120 | "Turing" 121 | 122 | 123 | type alias LoadMetadata = 124 | { id : String 125 | , name : String 126 | , date : Posix 127 | , description : String 128 | , machine_type : MachineType 129 | } 130 | 131 | 132 | decodeMetadataV1 : D.Decoder LoadMetadata 133 | decodeMetadataV1 = 134 | D.map5 LoadMetadata 135 | (D.field "id" D.string) 136 | (D.field "name" D.string) 137 | (D.field "date" <| D.map Time.millisToPosix D.int) 138 | (D.field "desc" D.string) 139 | (D.field "type" decodeMachineType) 140 | 141 | 142 | decodeMetadata : D.Decoder LoadMetadata 143 | decodeMetadata = 144 | D.field "v" D.int 145 | |> D.andThen 146 | (\v -> 147 | case v of 148 | 1 -> 149 | decodeMetadataV1 150 | 151 | _ -> 152 | D.fail <| "Invalid save metadata version " ++ String.fromInt v 153 | ) 154 | 155 | 156 | decodeMachineList : D.Decoder (List LoadMetadata) 157 | decodeMachineList = 158 | D.list decodeMetadata 159 | 160 | 161 | encodeMachinePayload = 162 | encodeMachinePayloadV1 163 | 164 | 165 | 166 | -- encode the payload when saving a machine to the server 167 | -- note: id is empty if the machine is a new one instead of one already saved to the server 168 | -- sending an existing id will overwrite the machine saved with that id 169 | 170 | 171 | encodeMachinePayloadV1 : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> MachineType -> E.Value 172 | encodeMachinePayloadV1 name desc machine uuid inputTape machine_type = 173 | E.object 174 | [ ( "name", E.string name ) 175 | , ( "desc", E.string desc ) 176 | , ( "machine", Machine.machineEncoder machine ) 177 | , ( "v", E.int 1 ) 178 | , ( "uuid", E.string uuid ) 179 | , ( "tape", Simulating.inputTapeEncoder inputTape ) 180 | , ( "type", encodeMachineType machine_type ) 181 | ] 182 | 183 | 184 | type alias SaveResponse = 185 | { success : Bool 186 | , uuid : String 187 | } 188 | 189 | 190 | decodeSaveResponse : D.Decoder SaveResponse 191 | decodeSaveResponse = 192 | D.map2 SaveResponse 193 | (D.field "success" D.bool) 194 | (D.field "uuid" D.string) 195 | 196 | 197 | saveMachine : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> MachineType -> (Result Http.Error SaveResponse -> msg) -> Cmd msg 198 | saveMachine name desc machine uuid inputTape machine_type toMsg = 199 | Http.send toMsg <| 200 | Http.post 201 | "/api/machine/save" 202 | (Http.jsonBody <| encodeMachinePayload name desc machine uuid inputTape machine_type) 203 | decodeSaveResponse 204 | 205 | 206 | type alias ArchivePayload = 207 | { uuid : String 208 | , restore : Bool 209 | } 210 | 211 | 212 | encodeArchivePayload : ArchivePayload -> E.Value 213 | encodeArchivePayload ap = 214 | E.object 215 | [ ( "uuid", E.string ap.uuid ) 216 | , ( "restore", E.bool ap.restore ) 217 | ] 218 | 219 | 220 | archiveMachine : ArchivePayload -> (Result Http.Error ArchiveResponse -> msg) -> Cmd msg 221 | archiveMachine payload toMsg = 222 | Http.send toMsg <| 223 | Http.post 224 | "/api/machine/archive" 225 | (Http.jsonBody <| encodeArchivePayload payload) 226 | decodeArchiveResponse 227 | 228 | 229 | type alias LoadPayload = 230 | { machine : Machine 231 | , tapes : Dict Int InputTape 232 | , name : String 233 | , uuid : String 234 | } 235 | 236 | 237 | type alias ArchiveResponse = 238 | { success : Bool 239 | } 240 | 241 | 242 | decodeArchiveResponse : D.Decoder ArchiveResponse 243 | decodeArchiveResponse = 244 | D.map ArchiveResponse (D.field "success" <| D.bool) 245 | 246 | 247 | decodeLoadPayload : D.Decoder LoadPayload 248 | decodeLoadPayload = 249 | D.map4 LoadPayload 250 | (D.field "machine" Machine.machineDecoder) 251 | (D.field "tape" Simulating.inputTapeDictDecoder) 252 | (D.field "name" D.string) 253 | (D.field "uuid" D.string) 254 | 255 | 256 | loadMachine : String -> (Result Http.Error LoadPayload -> msg) -> Cmd msg 257 | loadMachine uuid toMsg = 258 | Http.send toMsg <| 259 | Http.post 260 | "/api/machine/load" 261 | (Http.jsonBody <| E.string uuid) 262 | decodeLoadPayload 263 | 264 | 265 | loadList : FilterType -> (Result Http.Error (List LoadMetadata) -> msg) -> Cmd msg 266 | loadList machineType toMsg = 267 | Http.send toMsg <| 268 | Http.post 269 | "/api/machine/list" 270 | (Http.stringBody "text/plain" <| filterToString machineType) 271 | decodeMachineList 272 | 273 | 274 | type Msg 275 | = OpenLoginDialog 276 | | OpenLogoutDialog 277 | | MachineCreatedMsg MachineCreatedMsg 278 | | GetLoginStatus 279 | | ArchiveMachine String 280 | | RestoreMachine String 281 | | LoginStatusChange (Result Http.Error LoginStatus) 282 | | InitLoginStatus (Result Http.Error LoginStatus) 283 | | LoadMachine LoadMetadata 284 | | LoadMachineResponse (Result Http.Error LoadPayload) 285 | | ArchiveMachineResponse (Result Http.Error ArchiveResponse) 286 | | SelectFilter FilterType 287 | | OpenLoadDialog 288 | | OpenNewDialog 289 | | CloseLoadDialog 290 | | ListLoadResponse (Result Http.Error (List LoadMetadata)) 291 | | ModalAnimation Modal.Visibility 292 | | CreateNewMachine 293 | 294 | 295 | 296 | -- messages that can only be sent when there is a machine loaded 297 | 298 | 299 | type MachineCreatedMsg 300 | = EditMachineName 301 | | TypeName String 302 | | SaveMachine 303 | | MachineSaveResponse (Result Http.Error SaveResponse) 304 | | AutoSave Posix 305 | | TabMsg Tab.State 306 | 307 | 308 | loginStatusDecoder : D.Decoder LoginStatus 309 | loginStatusDecoder = 310 | D.field "loggedin" D.bool 311 | |> D.andThen 312 | (\loggedIn -> 313 | if loggedIn then 314 | D.map2 LoggedIn 315 | (D.field "email" D.string) 316 | (D.map 317 | (\s -> 318 | if s == "" then 319 | Nothing 320 | 321 | else 322 | Just s 323 | ) 324 | <| 325 | D.field "newestMachine" D.string 326 | ) 327 | 328 | else 329 | D.succeed NotLoggedIn 330 | ) 331 | 332 | 333 | getInitLoginStatus : Cmd Msg 334 | getInitLoginStatus = 335 | Http.send InitLoginStatus <| 336 | Http.post 337 | "/accounts/loginstate/" 338 | Http.emptyBody 339 | loginStatusDecoder 340 | 341 | 342 | getLoginStatus : Cmd Msg 343 | getLoginStatus = 344 | Http.send LoginStatusChange <| 345 | Http.post 346 | "/accounts/loginstate/" 347 | Http.emptyBody 348 | loginStatusDecoder 349 | 350 | 351 | type LoginStatus 352 | = LoggedIn String {- username -} (Maybe String) {- latest machine -} 353 | | NotLoggedIn 354 | | LoggingIn 355 | 356 | 357 | initSaveModel = 358 | ( { loginState = NotLoggedIn 359 | , machineData = MachineCreated 360 | , loadDialog = NothingOpen 361 | , loadDialogModal = Modal.shown 362 | , machineMetadata = initMachineMetadata 363 | , tabState = Tab.initialState 364 | , loadingList = Nothing 365 | , editingName = False 366 | , lastSaved = Time.millisToPosix 0 367 | , unsavedChanges = False 368 | , loadFilter = FilterActive 369 | } 370 | , Cmd.batch [ getInitLoginStatus ] 371 | ) 372 | 373 | 374 | initMachineMetadata = 375 | { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0, machine_type = DFA } 376 | 377 | 378 | subscriptions : Model -> Sub Msg 379 | subscriptions model = 380 | Sub.batch <| 381 | [ Browser.Events.onVisibilityChange (\_ -> GetLoginStatus) 382 | , Ports.loginComplete (\_ -> GetLoginStatus) 383 | , Ports.logoutComplete (\_ -> GetLoginStatus) 384 | , Modal.subscriptions model.loadDialogModal ModalAnimation 385 | ] 386 | ++ (case ( model.machineData, model.loginState ) of 387 | ( MachineCreated, LoggedIn _ _ ) -> 388 | if model.unsavedChanges then 389 | [ Time.every 5000 (MachineCreatedMsg << AutoSave) ] 390 | 391 | else 392 | [] 393 | 394 | ( _, _ ) -> 395 | [] 396 | ) 397 | 398 | 399 | type alias Model = 400 | { loginState : LoginStatus 401 | , tabState : Tab.State 402 | , machineData : MachineCreated 403 | , loadDialog : DialogStatus 404 | , machineMetadata : LoadMetadata 405 | , loadDialogModal : Modal.Visibility 406 | , loadingList : Maybe FilterType 407 | , editingName : Bool 408 | , lastSaved : Time.Posix 409 | , unsavedChanges : Bool 410 | , loadFilter : FilterType 411 | } 412 | 413 | 414 | type MachineCreated 415 | = MachineCreated 416 | | MachineNotCreated 417 | 418 | 419 | type DialogStatus 420 | = NothingOpen 421 | | LoadLoading 422 | | LoadOpen (List LoadMetadata) 423 | | NewOpen 424 | 425 | 426 | type SaveStatus 427 | = NotSaved 428 | | LastSaved Time.Posix 429 | | Saved Time.Posix 430 | 431 | 432 | update : Msg -> Model -> Environment -> ApplicationModel -> ( Model, Cmd Msg ) 433 | update msg model env appModel = 434 | case msg of 435 | OpenLoadDialog -> 436 | ( { model | loadDialog = LoadLoading } 437 | , Cmd.batch 438 | [ loadList FilterActive ListLoadResponse 439 | , if model.unsavedChanges then 440 | newMsg (MachineCreatedMsg SaveMachine) 441 | 442 | else 443 | Cmd.none 444 | ] 445 | ) 446 | 447 | ListLoadResponse response -> 448 | case response of 449 | Ok machineList -> 450 | ( { model | loadDialog = LoadOpen machineList, loadDialogModal = Modal.shown, loadingList = Nothing, machineData = MachineCreated }, Cmd.none ) 451 | 452 | Err _ -> 453 | ( { model | loadDialog = NothingOpen }, Cmd.none ) 454 | 455 | LoadMachine meta -> 456 | ( { model | machineMetadata = meta, loadDialog = NothingOpen } 457 | , loadMachine meta.id LoadMachineResponse 458 | ) 459 | 460 | -- handled by Main.elm 461 | LoadMachineResponse _ -> 462 | ( model, Cmd.none ) 463 | 464 | SelectFilter filter_type -> 465 | ( { model 466 | | tabState = Tab.customInitialState (filterToString filter_type) 467 | , loadingList = Just filter_type 468 | , loadFilter = filter_type 469 | , loadDialog = LoadOpen [] 470 | } 471 | , loadList filter_type ListLoadResponse 472 | ) 473 | 474 | OpenLoginDialog -> 475 | ( { model | loginState = LoggingIn }, Ports.launchLogin () ) 476 | 477 | OpenLogoutDialog -> 478 | ( model, Ports.launchLogout () ) 479 | 480 | GetLoginStatus -> 481 | ( model, getLoginStatus ) 482 | 483 | LoginStatusChange loginStatus -> 484 | case loginStatus of 485 | Ok loginState -> 486 | ( { model | loginState = loginState }, Cmd.none ) 487 | 488 | Err _ -> 489 | ( model, Cmd.none ) 490 | 491 | InitLoginStatus loginStatus -> 492 | case loginStatus of 493 | Ok loginState -> 494 | ( { model 495 | | loginState = loginState 496 | , loadDialog = 497 | case loginState of 498 | LoggedIn email latestMachine -> 499 | NothingOpen 500 | 501 | NotLoggedIn -> 502 | NewOpen 503 | 504 | LoggingIn -> 505 | NothingOpen 506 | , loadDialogModal = Modal.shown 507 | } 508 | , case loginState of 509 | LoggedIn _ (Just uuid) -> 510 | loadMachine uuid LoadMachineResponse 511 | 512 | _ -> 513 | Cmd.none 514 | ) 515 | 516 | Err _ -> 517 | ( model, Cmd.none ) 518 | 519 | ArchiveMachine uuid -> 520 | ( model 521 | , archiveMachine { uuid = uuid, restore = False } ArchiveMachineResponse 522 | ) 523 | 524 | RestoreMachine uuid -> 525 | ( model 526 | , archiveMachine { uuid = uuid, restore = True } ArchiveMachineResponse 527 | ) 528 | 529 | ArchiveMachineResponse archiveResponse -> 530 | ( model, loadList model.loadFilter ListLoadResponse ) 531 | 532 | MachineCreatedMsg mcMsg -> 533 | case model.machineData of 534 | MachineCreated -> 535 | let 536 | ( newModel, mcCmd ) = 537 | machineCreatedUpdate env appModel mcMsg model 538 | in 539 | ( newModel, Cmd.map MachineCreatedMsg mcCmd ) 540 | 541 | _ -> 542 | ( model, Cmd.none ) 543 | 544 | CloseLoadDialog -> 545 | ( { model | loadDialogModal = Modal.hidden, loadDialog = NothingOpen }, Cmd.none ) 546 | 547 | ModalAnimation v -> 548 | ( { model | loadDialogModal = v }, Cmd.none ) 549 | 550 | OpenNewDialog -> 551 | ( { model | loadDialog = NewOpen, loadDialogModal = Modal.shown }, Cmd.none ) 552 | 553 | -- handled in Main.elm 554 | CreateNewMachine -> 555 | ( model, Cmd.none ) 556 | 557 | 558 | machineCreatedUpdate : Environment -> ApplicationModel -> MachineCreatedMsg -> Model -> ( Model, Cmd MachineCreatedMsg ) 559 | machineCreatedUpdate env appModel msg model = 560 | case msg of 561 | EditMachineName -> 562 | ( { model | editingName = True }, Cmd.none ) 563 | 564 | TypeName n -> 565 | let 566 | meta = 567 | model.machineMetadata 568 | in 569 | ( { model | machineMetadata = { meta | name = n } }, Cmd.none ) 570 | 571 | SaveMachine -> 572 | ( model 573 | , saveMachine 574 | model.machineMetadata.name 575 | model.machineMetadata.description 576 | appModel.sharedModel.machine 577 | model.machineMetadata.id 578 | appModel.simulatingData.tapes 579 | model.machineMetadata.machine_type 580 | MachineSaveResponse 581 | ) 582 | 583 | MachineSaveResponse saveresp -> 584 | let 585 | meta = 586 | model.machineMetadata 587 | in 588 | case saveresp of 589 | Ok oksaveresp -> 590 | ( { model 591 | | machineMetadata = { meta | id = oksaveresp.uuid } 592 | , lastSaved = env.currentTime 593 | , unsavedChanges = False 594 | } 595 | , Cmd.none 596 | ) 597 | 598 | Err _ -> 599 | ( model, Cmd.none ) 600 | 601 | AutoSave time -> 602 | ( model 603 | , if model.unsavedChanges then 604 | saveMachine 605 | model.machineMetadata.name 606 | model.machineMetadata.description 607 | appModel.sharedModel.machine 608 | model.machineMetadata.id 609 | appModel.simulatingData.tapes 610 | model.machineMetadata.machine_type 611 | MachineSaveResponse 612 | 613 | else 614 | Cmd.none 615 | ) 616 | 617 | TabMsg state -> 618 | ( { model | tabState = state }, Cmd.none ) 619 | 620 | 621 | view : Model -> Environment -> Shape Msg 622 | view model env = 623 | let 624 | winX = 625 | toFloat <| Tuple.first env.windowSize 626 | 627 | winY = 628 | toFloat <| Tuple.second env.windowSize 629 | in 630 | group 631 | [ case model.loginState of 632 | NotLoggedIn -> 633 | group 634 | [ roundedRect 50 15 1 635 | |> filled blank 636 | |> addOutline (solid 1) darkGray 637 | , text "Log in" 638 | |> centered 639 | |> fixedwidth 640 | |> filled black 641 | |> move ( 0, -4 ) 642 | ] 643 | |> move ( winX / 2 - 50, winY / 2 - 15 ) 644 | |> notifyTap OpenLoginDialog 645 | 646 | LoggedIn email lastMachine -> 647 | group 648 | [ text ("Welcome " ++ email) 649 | |> alignRight 650 | |> fixedwidth 651 | |> filled black 652 | |> move ( 0, -4 ) 653 | , group 654 | [ roundedRect 55 15 1 655 | |> filled blank 656 | |> addOutline (solid 1) darkGray 657 | , text "Log out" 658 | |> centered 659 | |> fixedwidth 660 | |> filled black 661 | |> move ( 0, -4 ) 662 | ] 663 | |> move ( 40, 0 ) 664 | |> notifyTap OpenLogoutDialog 665 | , group 666 | [ roundedRect 85 15 1 667 | |> filled blank 668 | |> addOutline (solid 1) darkGray 669 | , text "My Machines" 670 | |> centered 671 | |> fixedwidth 672 | |> filled black 673 | |> move ( 0, -4 ) 674 | ] 675 | |> move ( 40, -20 ) 676 | |> notifyTap OpenLoadDialog 677 | ] 678 | |> move ( winX / 2 - 100, winY / 2 - 15 ) 679 | 680 | _ -> 681 | group [] 682 | , case model.loadDialog of 683 | LoadOpen metas -> 684 | let 685 | tab : FilterType -> Tab.Item Msg 686 | tab ft = 687 | Tab.item 688 | { id = 689 | case ft of 690 | FilterActive -> 691 | "all" 692 | 693 | MachineFilter DFA -> 694 | "D" 695 | 696 | MachineFilter NFA -> 697 | "N" 698 | 699 | MachineFilter NPDA -> 700 | "P" 701 | 702 | MachineFilter Turing -> 703 | "T" 704 | 705 | FilterArchived -> 706 | "arc" 707 | , link = 708 | Tab.link [ Html.Events.onClick <| SelectFilter ft ] <| 709 | [] 710 | {- <| 711 | (if model.loadingList == Just ft then 712 | [ Spinner.spinner 713 | [ Spinner.small, Spinner.attrs [ Spacing.mr1 ] ] 714 | [] 715 | ] 716 | 717 | else 718 | [] 719 | ) 720 | -} 721 | ++ [ Html.text 722 | (case ft of 723 | FilterActive -> 724 | "All" 725 | 726 | MachineFilter DFA -> 727 | "DFA" 728 | 729 | MachineFilter NFA -> 730 | "NFA" 731 | 732 | MachineFilter NPDA -> 733 | "NPDA" 734 | 735 | MachineFilter Turing -> 736 | "TM" 737 | 738 | FilterArchived -> 739 | "Archived" 740 | ) 741 | ] 742 | , pane = 743 | Tab.pane [] 744 | [] 745 | } 746 | in 747 | GraphicSVG.html winX 748 | winY 749 | (Modal.config CloseLoadDialog 750 | -- Configure the modal to use animations providing the new AnimateModal msg 751 | |> Modal.withAnimation ModalAnimation 752 | |> Modal.header [] 753 | [ Html.div [] [ Html.h3 [] [ Html.text "My Machines" ] ] 754 | , Html.div [] [ Button.button [ Button.primary, Button.attrs [ style "margin-left" "10px" ], Button.onClick OpenNewDialog ] [ Html.text "New" ] ] 755 | ] 756 | -- |> 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" ] ] ] 757 | |> Modal.body [ style "height" (String.fromFloat (winY / 2) ++ "px"), style "overflow" "scroll" ] [ renderLoadList (model.loadingList /= Nothing) (model.loadFilter == FilterArchived) metas env.currentTime env.timeZone ] 758 | {- |> Modal.footer [] 759 | [ Button.button 760 | [ Button.outlinePrimary 761 | -- If you want the custom close button to use animations; 762 | -- you should use the AnimateModal msg and provide it with the Modal.hiddenAnimated visibility 763 | , Button.attrs [ Html.Events.onClick <| ModalAnimation Modal.hiddenAnimated ] 764 | ] 765 | [ Html.text "Close" ] 766 | ] 767 | -} 768 | |> Modal.footer [] 769 | [ Html.div [ style "width" "100%" ] 770 | [ Tab.config (MachineCreatedMsg << TabMsg) 771 | |> Tab.pills 772 | -- |> Tab.attrs [style "float" "left"] 773 | |> Tab.center 774 | |> Tab.items 775 | (List.map tab 776 | [ FilterActive 777 | , MachineFilter DFA 778 | , MachineFilter NFA 779 | 780 | {- , MachineFilter NPDA, MachineFilter Turing, -} 781 | , FilterArchived 782 | ] 783 | ) 784 | |> Tab.view model.tabState 785 | ] 786 | ] 787 | |> Modal.view model.loadDialogModal 788 | ) 789 | |> move ( -winX / 2, winY / 2 ) 790 | 791 | NewOpen -> 792 | GraphicSVG.html winX 793 | winY 794 | (Modal.config CloseLoadDialog 795 | -- Configure the modal to use animations providing the new AnimateModal msg 796 | |> Modal.withAnimation ModalAnimation 797 | |> Modal.header [] 798 | [ Html.div [] [ Html.h3 [] [ Html.text "Welcome to finsm.io!" ] ] 799 | ] 800 | -- |> 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" ] ] ] 801 | |> Modal.body [ style "height" (String.fromFloat (winY / 2) ++ "px"), style "overflow" "scroll" ] 802 | [ Html.h4 [] [ Html.text "finsm.io lets you create, test and export finite state machines. Get started by selecting an option below:" ] 803 | , renderNew model.loginState 804 | ] 805 | {- |> Modal.footer [] 806 | [ Button.button 807 | [ Button.outlinePrimary 808 | -- If you want the custom close button to use animations; 809 | -- you should use the AnimateModal msg and provide it with the Modal.hiddenAnimated visibility 810 | , Button.attrs [ Html.Events.onClick <| ModalAnimation Modal.hiddenAnimated ] 811 | ] 812 | [ Html.text "Close" ] 813 | ] 814 | -} 815 | |> Modal.footer [] [] 816 | |> Modal.view model.loadDialogModal 817 | ) 818 | |> move ( -winX / 2, winY / 2 ) 819 | 820 | _ -> 821 | group [] 822 | , case model.machineData of 823 | MachineCreated -> 824 | group 825 | [ if not model.editingName then 826 | group 827 | [ group 828 | [ roundedRect 15 15 2 |> filled white |> addOutline (solid 1) darkGray |> move ( 3, 3 ) 829 | , editIcon 830 | |> scale 1.5 831 | ] 832 | |> move ( -winX / 2 + 470, winY / 2 - 20 ) 833 | , text model.machineMetadata.name 834 | |> fixedwidth 835 | |> size 16 836 | |> filled black 837 | |> move ( -winX / 2 + 175, winY / 2 - 20 ) 838 | ] 839 | |> notifyTap (MachineCreatedMsg EditMachineName) 840 | 841 | else 842 | textBox model.machineMetadata.name 300 20 "Machine Name" (MachineCreatedMsg << TypeName) 843 | |> move ( -winX / 2 + 325, winY / 2 - 10 ) 844 | , text (lastSaved model env) 845 | |> fixedwidth 846 | |> size 14 847 | |> filled darkGray 848 | |> move ( -winX / 2 + 490, winY / 2 - 20 ) 849 | ] 850 | 851 | MachineNotCreated -> 852 | group [] 853 | ] 854 | 855 | 856 | lastSaved : Model -> Environment -> String 857 | lastSaved model env = 858 | let 859 | duration = 860 | Duration.from model.lastSaved env.currentTime 861 | in 862 | if not model.unsavedChanges then 863 | if Duration.inSeconds duration <= 30 then 864 | "last edit saved just now" 865 | 866 | else if Duration.inSeconds duration <= 90 then 867 | "last edit saved about a minute ago" 868 | 869 | else if Duration.inMinutes duration <= 60 then 870 | "last edit saved " ++ String.fromInt (round <| Duration.inMinutes duration) ++ " minutes ago" 871 | 872 | else if Duration.inMinutes duration <= 90 then 873 | "last edit saved about an hour ago" 874 | 875 | else 876 | "last edit saved " ++ String.fromInt (round <| Duration.inHours duration) ++ " hours ago" 877 | 878 | else 879 | case model.loginState of 880 | LoggedIn _ _ -> 881 | "saving..." 882 | 883 | NotLoggedIn -> 884 | "log in to save changes" 885 | 886 | _ -> 887 | "" 888 | 889 | 890 | aboutAXAgo : Duration.Duration -> String 891 | aboutAXAgo duration = 892 | if Duration.inSeconds duration <= 30 then 893 | "just now" 894 | 895 | else if Duration.inSeconds duration <= 90 then 896 | "about a minute ago" 897 | 898 | else if Duration.inMinutes duration <= 60 then 899 | String.fromInt (round <| Duration.inMinutes duration) ++ " minutes ago" 900 | 901 | else if Duration.inMinutes duration <= 90 then 902 | "about an hour ago" 903 | 904 | else if Duration.inDays duration <= 1 then 905 | String.fromInt (round <| Duration.inHours duration) ++ " hours ago" 906 | 907 | else 908 | String.fromInt (round <| Duration.inDays duration) ++ " days ago" 909 | 910 | 911 | dateFormat : Time.Zone -> Posix -> Posix -> String 912 | dateFormat zn now thn = 913 | let 914 | duration = 915 | Duration.from thn now 916 | 917 | dayStr day = 918 | case day of 919 | Time.Mon -> 920 | "Monday" 921 | 922 | Time.Tue -> 923 | "Tuesday" 924 | 925 | Time.Wed -> 926 | "Wednesday" 927 | 928 | Time.Thu -> 929 | "Thursday" 930 | 931 | Time.Fri -> 932 | "Friday" 933 | 934 | Time.Sat -> 935 | "Saturday" 936 | 937 | Time.Sun -> 938 | "Sunday" 939 | 940 | monStr mon = 941 | case mon of 942 | Time.Jan -> 943 | "January" 944 | 945 | Time.Feb -> 946 | "February" 947 | 948 | Time.Mar -> 949 | "March" 950 | 951 | Time.Apr -> 952 | "April" 953 | 954 | Time.May -> 955 | "May" 956 | 957 | Time.Jun -> 958 | "June" 959 | 960 | Time.Jul -> 961 | "July" 962 | 963 | Time.Aug -> 964 | "August" 965 | 966 | Time.Sep -> 967 | "September" 968 | 969 | Time.Oct -> 970 | "October" 971 | 972 | Time.Nov -> 973 | "November" 974 | 975 | Time.Dec -> 976 | "December" 977 | 978 | dateFmt : Posix -> String 979 | dateFmt t = 980 | (monStr <| Time.toMonth zn t) ++ " " ++ (String.fromInt <| Time.toDay zn t) ++ ", " ++ (String.fromInt <| Time.toYear zn t) 981 | in 982 | if Duration.inDays duration <= 1 then 983 | aboutAXAgo duration 984 | 985 | else if Duration.inDays duration <= 3 then 986 | dayStr (Time.toWeekday zn thn) 987 | 988 | else 989 | dateFmt thn 990 | 991 | 992 | renderLoadList : Bool -> Bool -> List LoadMetadata -> Posix -> Time.Zone -> Html Msg 993 | renderLoadList loadingList archiveList metas now zn = 994 | let 995 | oneRow machine = 996 | ListGroup.anchor 997 | [ ListGroup.attrs [ Flex.col, Flex.alignItemsStart, Size.w100 ] 998 | ] 999 | [ Html.div [ Flex.block, Flex.justifyBetween, Size.w100 ] 1000 | [ Html.h5 [ Spacing.mb1 ] [ Html.text machine.name ] 1001 | , Html.small [] [ Html.text <| dateFormat zn now machine.date ] 1002 | ] 1003 | , ButtonGroup.buttonGroup [ ButtonGroup.attrs [ style "float" "right" ] ] 1004 | [ ButtonGroup.button [ Button.primary, Button.small, Button.onClick (LoadMachine machine) ] [ Html.text "Open" ] 1005 | , ButtonGroup.button 1006 | [ Button.danger 1007 | , Button.small 1008 | , Button.onClick 1009 | (if archiveList then 1010 | RestoreMachine machine.id 1011 | 1012 | else 1013 | ArchiveMachine machine.id 1014 | ) 1015 | ] 1016 | [ Html.text 1017 | (if archiveList then 1018 | "Restore" 1019 | 1020 | else 1021 | "Archive" 1022 | ) 1023 | ] 1024 | ] 1025 | , Html.div [] [ Html.b [] [ Html.text (machineTypeFullStr machine.machine_type) ] ] 1026 | ] 1027 | in 1028 | Html.div [] 1029 | --[style "overflow" "scroll"]-- style "width" (String.fromInt w ++ "px"), style "height" (String.fromInt h ++ "px"), style "position" "fixed"] 1030 | [ if loadingList then 1031 | Html.div [ style "height" "500px" ] [ Spinner.spinner [ Spinner.color Text.primary, Spinner.large, Spinner.grow, Spinner.attrs [ style "display" "block", style "margin" "auto" ] ] [] ] 1032 | 1033 | else if metas == [] then 1034 | Html.div [ style "text-align" "center" ] [ Html.text "No machines matching current filter." ] 1035 | 1036 | else 1037 | ListGroup.custom (List.map oneRow metas) 1038 | ] 1039 | 1040 | 1041 | renderNew : LoginStatus -> Html Msg 1042 | renderNew loginStatus = 1043 | Grid.container [] 1044 | [ Grid.row [] 1045 | [ Grid.col [] 1046 | [ Card.deck 1047 | [ Card.config [] 1048 | |> Card.headerH3 [] [ Html.text "DFA / NFA" ] 1049 | |> Card.block [] 1050 | [ Block.text [] [ Html.text "Create a new Finite State Machine." ] ] 1051 | |> Card.footer [] 1052 | [ Button.button [ Button.primary, Button.onClick CreateNewMachine ] [ Html.text "Create!" ] ] 1053 | , case loginStatus of 1054 | LoggedIn _ _ -> 1055 | Card.config [] 1056 | |> Card.headerH3 [] [ Html.text "Load Existing" ] 1057 | |> Card.block [] 1058 | [ Block.text [] [ Html.text "Load an existing machine." ] ] 1059 | |> Card.footer [] 1060 | [ Button.button [ Button.primary, Button.onClick OpenLoadDialog ] [ Html.text "Load" ] ] 1061 | 1062 | NotLoggedIn -> 1063 | Card.config [] 1064 | |> Card.headerH3 [] [ Html.text "Load Existing" ] 1065 | |> Card.block [] 1066 | [ Block.text [] [ Html.text "Log in to load an existing machine." ] ] 1067 | |> Card.footer [] 1068 | [ Button.button [ Button.primary, Button.onClick OpenLoginDialog ] [ Html.text "Login" ] ] 1069 | 1070 | LoggingIn -> 1071 | Card.config [] 1072 | |> Card.headerH3 [] [ Html.text "Load Existing" ] 1073 | |> Card.block [] 1074 | [ Block.text [] [ Html.text "Please finish logging in to load your machines." ] ] 1075 | |> Card.footer [] 1076 | [ Button.button [ Button.primary, Button.onClick OpenLoginDialog ] [ Html.text "Login" ] ] 1077 | ] 1078 | , Grid.row [ Row.attrs [ style "margin-top" "10px" ] ] 1079 | [ Grid.col [] 1080 | [ Card.deck 1081 | [ Card.config [] 1082 | |> Card.headerH3 [] [ Html.text "Quickstart Guide" ] 1083 | |> Card.block [] 1084 | [ Block.text [] [ Html.text "Before you start using the site, you may want to read our \"Quickstart\" guide to learn tips & tricks!" ] ] 1085 | |> Card.footer [] 1086 | [ Button.linkButton [ Button.primary, Button.attrs [ Html.Attributes.href "https://github.com/CSchank/finsm/wiki/QUICKSTART", Html.Attributes.target "_blank" ] ] [ Html.text "Go!" ] ] 1087 | , Card.config [] 1088 | |> Card.headerH3 [] [ Html.text "Get Involved!" ] 1089 | |> Card.block [] 1090 | [ Block.text [] [ Html.text "Have questions? Comments? Suggestions? Pull requests? We welcome it all! Come visit us on GitHub!" ] ] 1091 | |> Card.footer [] 1092 | [ Button.linkButton [ Button.primary, Button.attrs [ Html.Attributes.href "https://github.com/cschank/finsm", Html.Attributes.target "_blank" ] ] [ Html.text "Go!" ] ] 1093 | ] 1094 | ] 1095 | ] 1096 | ] 1097 | ] 1098 | ] 1099 | -------------------------------------------------------------------------------- /src/SharedModel.elm: -------------------------------------------------------------------------------- 1 | module SharedModel exposing (MachineType(..), SharedModel, init, machineModeButtons) 2 | 3 | import GraphicSVG exposing (..) 4 | import Helpers exposing (..) 5 | import Machine exposing (Machine) 6 | 7 | 8 | type MachineType 9 | = DFA 10 | | NFA 11 | 12 | 13 | type alias SharedModel = 14 | { machine : Machine 15 | , machineType : MachineType 16 | } 17 | 18 | 19 | init : SharedModel 20 | init = 21 | { machine = Machine.test 22 | , machineType = DFA 23 | } 24 | 25 | 26 | machineModeButtons : MachineType -> Float -> Float -> (MachineType -> msg) -> Shape msg 27 | machineModeButtons mtype winX winY changeMsg = 28 | group 29 | [ group 30 | [ roundedRect 30 15 1 31 | |> filled 32 | (if mtype == DFA then 33 | finsmLightBlue 34 | 35 | else 36 | blank 37 | ) 38 | |> addOutline (solid 1) darkGray 39 | , text "DFA" 40 | |> centered 41 | |> fixedwidth 42 | |> filled 43 | (if mtype == DFA then 44 | white 45 | 46 | else 47 | darkGray 48 | ) 49 | |> move ( 0, -4 ) 50 | ] 51 | |> move ( -winX / 2 + 20, winY / 2 - 32 ) 52 | |> notifyTap (changeMsg DFA) 53 | , group 54 | [ roundedRect 30 15 1 55 | |> filled 56 | (if mtype == NFA then 57 | finsmLightBlue 58 | 59 | else 60 | blank 61 | ) 62 | |> addOutline (solid 1) darkGray 63 | , text "NFA" 64 | |> centered 65 | |> fixedwidth 66 | |> filled 67 | (if mtype == NFA then 68 | white 69 | 70 | else 71 | darkGray 72 | ) 73 | |> move ( 0, -4 ) 74 | ] 75 | |> move ( -winX / 2 + 52, winY / 2 - 32 ) 76 | |> notifyTap (changeMsg NFA) 77 | ] 78 | -------------------------------------------------------------------------------- /src/Simulating.elm: -------------------------------------------------------------------------------- 1 | module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, checkTapesNoStatus, delta, deltaHat, epsTrans, initPModel, inputTapeDecoder, inputTapeDictDecoder, inputTapeEncoder, isAccept, latexKeyboard, machineDefn, onEnter, onExit, renderTape, subscriptions, update, view) 2 | 3 | import Array exposing (Array) 4 | import Browser.Events 5 | import Debug 6 | import Dict exposing (Dict) 7 | import Environment exposing (Environment) 8 | import Error exposing (..) 9 | import GraphicSVG exposing (..) 10 | import Helpers exposing (..) 11 | import Json.Decode as D 12 | import Json.Encode as E 13 | import Machine exposing (..) 14 | import Mistakes exposing (..) 15 | import Set exposing (Set) 16 | import SharedModel exposing (..) 17 | import Task 18 | import Tuple exposing (first, second) 19 | import Utils exposing (decodeDict, encodeDict) 20 | 21 | 22 | subscriptions : Model -> Sub Msg 23 | subscriptions model = 24 | Browser.Events.onKeyDown (D.map KeyPressed (D.field "key" D.string)) 25 | 26 | 27 | type alias PersistentModel = 28 | { tapes : Dict Int ( InputTape, TapeStatus ) 29 | , currentStates : Set StateID 30 | } 31 | 32 | 33 | inputTapeEncoder : Dict Int ( InputTape, a ) -> E.Value 34 | inputTapeEncoder = 35 | encodeDict E.int (E.list E.string << Array.toList << Tuple.first) 36 | 37 | 38 | inputTapeDecoder : D.Decoder InputTape 39 | inputTapeDecoder = 40 | D.map Array.fromList 41 | (D.list D.string) 42 | 43 | 44 | inputTapeDictDecoder : D.Decoder (Dict Int InputTape) 45 | inputTapeDictDecoder = 46 | decodeDict D.int inputTapeDecoder 47 | 48 | 49 | type alias InputTape = 50 | Array Character 51 | 52 | 53 | type TapeStatus 54 | = Fresh 55 | | Stale (Set String) 56 | 57 | 58 | type alias HoverError = 59 | Maybe Int 60 | 61 | 62 | type Model 63 | = Default Int {- tapeID -} Int {- charID -} HoverError 64 | | Editing Int 65 | 66 | 67 | type Msg 68 | = Step 69 | | EditTape Int 70 | | DeleteTape Int 71 | | AddNewTape 72 | | ChangeTape Int 73 | | ToggleStart StateID 74 | | KeyPressed String 75 | | ChangeMachine MachineType 76 | | MachineMsg Machine.Msg 77 | | HoverErrorEnter Int 78 | | HoverErrorExit 79 | 80 | 81 | onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) 82 | onEnter env ( pModel, sModel ) = 83 | ( ( Default 0 -1 Nothing 84 | , { pModel 85 | | currentStates = 86 | epsTrans 87 | sModel.machine.transitionNames 88 | sModel.machine.delta 89 | sModel.machine.start 90 | , tapes = checkTapes sModel pModel.tapes 91 | } 92 | , sModel 93 | ) 94 | , False 95 | , Cmd.none 96 | ) 97 | 98 | 99 | onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) 100 | onExit env ( model, pModel, sModel ) = 101 | ( ( pModel, sModel ), False ) 102 | 103 | 104 | initPModel : PersistentModel 105 | initPModel = 106 | { tapes = 107 | Dict.fromList 108 | [ ( 0, ( Array.fromList [ "0", "0", "0", "1", "1", "0", "1", "0", "1", "0" ], Fresh ) ) 109 | , ( 1, ( Array.fromList [ "0", "0", "0", "1", "1", "0", "1", "0", "1", "0", "1", "1", "1", "1", "0" ], Fresh ) ) 110 | ] 111 | , currentStates = test.start 112 | } 113 | 114 | 115 | checkTapes : SharedModel -> Dict Int ( InputTape, TapeStatus ) -> Dict Int ( InputTape, TapeStatus ) 116 | checkTapes sModel tapes = 117 | Dict.map (\k ( tape, _ ) -> ( tape, checkTape sModel tape )) tapes 118 | 119 | 120 | checkTapesNoStatus : SharedModel -> Dict Int InputTape -> Dict Int ( InputTape, TapeStatus ) 121 | checkTapesNoStatus sModel tapes = 122 | Dict.map (\k tape -> ( tape, checkTape sModel tape )) tapes 123 | 124 | 125 | checkTape : SharedModel -> InputTape -> TapeStatus 126 | checkTape sModel inp = 127 | let 128 | tNames = 129 | sModel.machine.transitionNames 130 | 131 | allTransitionLabels = 132 | List.foldr Set.union Set.empty <| Dict.values tNames 133 | 134 | arrFilter = 135 | Array.filter (\v -> not <| Set.member v allTransitionLabels) inp 136 | in 137 | case Array.isEmpty arrFilter of 138 | True -> 139 | Fresh 140 | 141 | False -> 142 | Stale <| Set.fromList <| Array.toList arrFilter 143 | 144 | 145 | renderTape : Model -> Array String -> TapeStatus -> Int -> Int -> Int -> Bool -> Shape Msg 146 | renderTape model input tapeSt tapeId selectedId inputAt showButtons = 147 | let 148 | hoverOn = 149 | case model of 150 | Default _ _ (Just errId) -> 151 | if errId == tapeId then 152 | True 153 | 154 | else 155 | False 156 | 157 | _ -> 158 | False 159 | 160 | xpad = 161 | 20 162 | 163 | errWindow = 164 | group 165 | [ roundedRect 800 30 2 166 | |> filled white 167 | |> addOutline (solid 1) darkGray 168 | |> move ( 400, 5 ) 169 | , text "This tape has stale transitions. Modify or delete it!" 170 | |> size 25 171 | |> fixedwidth 172 | |> filled red 173 | ] 174 | in 175 | group <| 176 | Array.toList 177 | (Array.indexedMap 178 | (\n st -> 179 | group 180 | [ square xpad 181 | |> filled white 182 | |> addOutline 183 | (solid 1) 184 | (if tapeSt == Fresh then 185 | black 186 | 187 | else 188 | red 189 | ) 190 | |> move ( 0, 3 ) 191 | , latex (xpad * 0.9) (xpad * 0.7) "white" st AlignCentre 192 | |> move ( 0, 10.25 ) 193 | ] 194 | |> move 195 | ( toFloat n 196 | * xpad 197 | + (if not showButtons then 198 | xpad / 2 199 | 200 | else 201 | 0 202 | ) 203 | , 0 204 | ) 205 | |> notifyTap (ChangeTape tapeId) 206 | ) 207 | input 208 | ) 209 | ++ (if tapeId == selectedId then 210 | [ group 211 | [ triangle 2.25 212 | |> filled black 213 | |> rotate (degrees 30) 214 | |> move ( 0, xpad / 2 + 5.75 ) 215 | , triangle 2.25 216 | |> filled black 217 | |> rotate (degrees -30) 218 | |> move ( 0, -xpad / 2 + 0.25 ) 219 | , rect 2 (xpad + 1) 220 | |> filled black 221 | |> move ( 0, 3 ) 222 | ] 223 | |> move ( xpad / 2 + xpad * toFloat inputAt, 0 ) 224 | ] 225 | 226 | else 227 | [] 228 | ) 229 | ++ (if showButtons then 230 | [ group 231 | [ roundedRect 15 15 2 232 | |> filled white 233 | |> addOutline (solid 1) darkGray 234 | , editIcon 235 | |> scale 1.5 236 | |> move ( -3, -3 ) 237 | |> repaint black 238 | ] 239 | |> move ( toFloat <| Array.length input * xpad, 3 ) 240 | |> notifyTap (EditTape tapeId) 241 | , group 242 | [ roundedRect 15 15 2 243 | |> filled white 244 | |> addOutline (solid 1) darkGray 245 | , trashIcon |> scale 0.2 |> move ( 0, -1 ) 246 | ] 247 | |> move ( toFloat <| (Array.length input + 1) * xpad, 3 ) 248 | |> notifyTap (DeleteTape tapeId) 249 | , if not (tapeSt == Fresh) then 250 | group 251 | ([ triangle 20 |> filled red |> rotate 22.5 252 | , roundedRect 7.5 10 5 |> filled white |> move ( 0, 7.5 ) 253 | , circle 3 |> filled white |> move ( 0, -2.5 ) 254 | ] 255 | ++ (if hoverOn then 256 | [ errWindow ] 257 | 258 | else 259 | [] 260 | ) 261 | ) 262 | |> scale 0.5 263 | |> move ( toFloat <| (Array.length input + 2) * xpad, 1 ) 264 | |> notifyEnter (HoverErrorEnter tapeId) 265 | |> notifyLeave HoverErrorExit 266 | 267 | else 268 | group [] 269 | ] 270 | 271 | else 272 | [] 273 | ) 274 | 275 | 276 | update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) 277 | update env msg ( model, pModel, sModel ) = 278 | let 279 | oldMachine = 280 | sModel.machine 281 | 282 | machineType = 283 | sModel.machineType 284 | in 285 | case msg of 286 | Step -> 287 | case model of 288 | Default tapeId charId hover -> 289 | let 290 | nextCh = 291 | case Dict.get tapeId pModel.tapes of 292 | Just ( ar, tapeStatus ) -> 293 | case Array.get (charId + 1) ar of 294 | Just ch -> 295 | if tapeStatus == Fresh then 296 | ch 297 | 298 | else 299 | "" 300 | 301 | _ -> 302 | "" 303 | 304 | _ -> 305 | "" 306 | in 307 | if nextCh /= "" then 308 | ( ( Default tapeId (charId + 1) hover 309 | , { pModel 310 | | currentStates = 311 | deltaHat oldMachine.transitionNames oldMachine.delta nextCh pModel.currentStates 312 | } 313 | , sModel 314 | ) 315 | , False 316 | , Cmd.none 317 | ) 318 | 319 | else 320 | ( ( model, pModel, sModel ), False, Cmd.none ) 321 | 322 | _ -> 323 | ( ( model, pModel, sModel ), False, Cmd.none ) 324 | 325 | EditTape tId -> 326 | ( ( Editing tId, pModel, sModel ), False, Cmd.none ) 327 | 328 | DeleteTape tId -> 329 | let 330 | newModel = 331 | case model of 332 | Default tId0 chId hover -> 333 | -- FIXME: choose a good tape to go to 334 | if tId0 == tId then 335 | Default 0 -1 hover 336 | 337 | else 338 | Default tId0 chId hover 339 | 340 | _ -> 341 | model 342 | in 343 | ( ( newModel, { pModel | tapes = Dict.remove tId pModel.tapes }, sModel ), True, Cmd.none ) 344 | 345 | AddNewTape -> 346 | let 347 | newId = 348 | (case List.maximum <| Dict.keys pModel.tapes of 349 | Just n -> 350 | n 351 | 352 | Nothing -> 353 | 0 354 | ) 355 | + 1 356 | in 357 | ( ( model, { pModel | tapes = Dict.insert newId ( Array.empty, Fresh ) pModel.tapes }, sModel ), True, Cmd.none ) 358 | 359 | ChangeTape tId -> 360 | ( ( Default tId -1 Nothing {- ??? -}, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta oldMachine.start }, sModel ), False, Cmd.none ) 361 | 362 | KeyPressed k -> 363 | let 364 | normalizedKey = 365 | String.toLower k 366 | in 367 | if normalizedKey == "enter" then 368 | case model of 369 | Editing tId -> 370 | ( ( Default tId -1 Nothing, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta oldMachine.start }, sModel ), True, Cmd.none ) 371 | 372 | _ -> 373 | ( ( model, pModel, sModel ), False, Cmd.none ) 374 | 375 | else if normalizedKey == "backspace" || normalizedKey == "arrowleft" then 376 | case model of 377 | Editing tapeId -> 378 | let 379 | newPModel = 380 | { pModel 381 | | tapes = 382 | Dict.update tapeId 383 | (\m -> 384 | case m of 385 | Just ( ar, tapeSt ) -> 386 | let 387 | newTape = 388 | Array.slice 0 -1 ar 389 | 390 | freshSt = 391 | checkTape sModel newTape 392 | in 393 | Just ( Array.slice 0 -1 ar, freshSt ) 394 | 395 | _ -> 396 | m 397 | ) 398 | pModel.tapes 399 | } 400 | in 401 | ( ( model, newPModel, sModel ), False, Cmd.none ) 402 | 403 | _ -> 404 | ( ( model, pModel, sModel ), False, Cmd.none ) 405 | 406 | else if normalizedKey == "arrowright" then 407 | case model of 408 | Default _ _ _ -> 409 | ( ( model, pModel, sModel ), False, Task.perform identity (Task.succeed <| Step) ) 410 | 411 | _ -> 412 | ( ( model, pModel, sModel ), False, Cmd.none ) 413 | 414 | else if normalizedKey == "arrowleft" then 415 | case model of 416 | Default tId _ hErr -> 417 | ( ( Default tId -1 hErr, { pModel | currentStates = sModel.machine.start }, sModel ), False, Cmd.none ) 418 | 419 | _ -> 420 | ( ( model, pModel, sModel ), False, Cmd.none ) 421 | 422 | else 423 | case model of 424 | Editing tapeId -> 425 | let 426 | charCode = 427 | case normalizedKey of 428 | "a" -> 429 | 0 430 | 431 | "s" -> 432 | 1 433 | 434 | "d" -> 435 | 2 436 | 437 | "f" -> 438 | 3 439 | 440 | "g" -> 441 | 4 442 | 443 | "h" -> 444 | 5 445 | 446 | "j" -> 447 | 6 448 | 449 | "k" -> 450 | 7 451 | 452 | "l" -> 453 | 8 454 | 455 | "q" -> 456 | 9 457 | 458 | "w" -> 459 | 10 460 | 461 | "e" -> 462 | 11 463 | 464 | "r" -> 465 | 12 466 | 467 | "t" -> 468 | 13 469 | 470 | "y" -> 471 | 14 472 | 473 | "u" -> 474 | 15 475 | 476 | "i" -> 477 | 16 478 | 479 | "o" -> 480 | 17 481 | 482 | "p" -> 483 | 18 484 | 485 | "z" -> 486 | 19 487 | 488 | "x" -> 489 | 20 490 | 491 | "c" -> 492 | 21 493 | 494 | "v" -> 495 | 22 496 | 497 | "b" -> 498 | 23 499 | 500 | "n" -> 501 | 24 502 | 503 | "m" -> 504 | 25 505 | 506 | _ -> 507 | -1 508 | 509 | chars = 510 | Array.fromList <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values oldMachine.transitionNames 511 | 512 | newChar = 513 | Array.get charCode chars 514 | 515 | newPModel = 516 | { pModel 517 | | tapes = 518 | Dict.update tapeId 519 | (\m -> 520 | case ( m, newChar ) of 521 | ( Just ( ar, tapeSt ), Just ch ) -> 522 | Just ( Array.push ch ar, tapeSt ) 523 | 524 | ( Nothing, Just ch ) -> 525 | Just ( Array.fromList [ ch ], Fresh ) 526 | 527 | _ -> 528 | m 529 | ) 530 | pModel.tapes 531 | } 532 | in 533 | ( ( model, newPModel, sModel ), False, Cmd.none ) 534 | 535 | _ -> 536 | ( ( model, pModel, sModel ), False, Cmd.none ) 537 | 538 | ChangeMachine mtype -> 539 | case mtype of 540 | NFA -> 541 | case sModel.machineType of 542 | NFA -> 543 | ( ( model, pModel, sModel ), False, Cmd.none ) 544 | 545 | DFA -> 546 | case model of 547 | Editing tId -> 548 | ( ( Default tId -1 Nothing, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) 549 | 550 | _ -> 551 | ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) 552 | 553 | DFA -> 554 | case sModel.machineType of 555 | DFA -> 556 | ( ( model, pModel, sModel ), False, Cmd.none ) 557 | 558 | NFA -> 559 | let 560 | startState = 561 | if Set.size oldMachine.start > 1 then 562 | Set.singleton <| 563 | (\x -> 564 | case x of 565 | Just val -> 566 | val 567 | 568 | Nothing -> 569 | -1 570 | ) 571 | <| 572 | List.head <| 573 | Set.toList oldMachine.start 574 | 575 | else 576 | oldMachine.start 577 | 578 | newPModel = 579 | { pModel | currentStates = startState } 580 | 581 | newSModel = 582 | { sModel | machine = { oldMachine | start = startState }, machineType = DFA } 583 | in 584 | case model of 585 | Editing tId -> 586 | ( ( Default tId -1 Nothing, newPModel, newSModel ), True, Cmd.none ) 587 | 588 | _ -> 589 | ( ( model, newPModel, newSModel ), True, Cmd.none ) 590 | 591 | MachineMsg mmsg -> 592 | case mmsg of 593 | StartDragging sId _ -> 594 | ( ( model, pModel, sModel ), False, sendMsg (ToggleStart sId) ) 595 | 596 | TapState sId -> 597 | ( ( model, pModel, sModel ), False, sendMsg (ToggleStart sId) ) 598 | 599 | _ -> 600 | ( ( model, pModel, sModel ), False, Cmd.none ) 601 | 602 | ToggleStart sId -> 603 | let 604 | tests = 605 | oldMachine.start 606 | 607 | newMachine = 608 | case machineType of 609 | NFA -> 610 | { oldMachine 611 | | start = 612 | case Set.member sId oldMachine.start of 613 | True -> 614 | Set.remove sId oldMachine.start 615 | 616 | False -> 617 | Set.insert sId oldMachine.start 618 | } 619 | 620 | DFA -> 621 | { oldMachine 622 | | start = Set.singleton sId 623 | } 624 | in 625 | case model of 626 | Default tId _ _ -> 627 | ( ( Default tId -1 Nothing, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta newMachine.start }, { sModel | machine = newMachine } ), True, Cmd.none ) 628 | 629 | _ -> 630 | ( ( model, pModel, sModel ), False, Cmd.none ) 631 | 632 | HoverErrorEnter tapeId -> 633 | case model of 634 | Default tId pos _ -> 635 | ( ( Default tId pos (Just tapeId), pModel, sModel ), False, Cmd.none ) 636 | 637 | _ -> 638 | ( ( model, pModel, sModel ), False, Cmd.none ) 639 | 640 | HoverErrorExit -> 641 | case model of 642 | Default tId pos _ -> 643 | ( ( Default tId pos Nothing, pModel, sModel ), False, Cmd.none ) 644 | 645 | _ -> 646 | ( ( model, pModel, sModel ), False, Cmd.none ) 647 | 648 | 649 | isAccept : Set StateID -> Set StateID -> InputTape -> Int -> Bool 650 | isAccept states finals input inputAt = 651 | if inputAt == Array.length input then 652 | Set.size (Set.intersect states finals) > 0 653 | 654 | else 655 | False 656 | 657 | 658 | view : Environment -> ( Model, PersistentModel, SharedModel ) -> Shape Msg 659 | view env ( model, pModel, sModel ) = 660 | let 661 | oldMachine = 662 | sModel.machine 663 | 664 | winX = 665 | toFloat <| first env.windowSize 666 | 667 | winY = 668 | toFloat <| second env.windowSize 669 | 670 | transMistakes = 671 | getTransitionMistakes sModel.machine 672 | 673 | chars = 674 | -- This is broken? 675 | Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values oldMachine.transitionNames 676 | 677 | menu = 678 | group <| 679 | [ text "Simulate" 680 | |> size 16 681 | |> fixedwidth 682 | |> filled black 683 | |> move ( -winX / 2 + 2, winY / 6 - 15 ) 684 | , text "(Click to toggle start state(s), right arrow to scrub through tape)" 685 | |> size 6 686 | |> fixedwidth 687 | |> filled black 688 | |> move ( -winX / 2 + 85, winY / 6 - 15 ) 689 | , group 690 | [ roundedRect 15 15 2 691 | |> filled white 692 | |> addOutline (solid 1) darkGray 693 | , text "+" 694 | |> size 16 695 | |> fixedwidth 696 | |> filled black 697 | |> move ( -4.5, -5 ) 698 | |> notifyTap AddNewTape 699 | ] 700 | |> move ( -winX / 2 + 20, winY / 6 - 35 - 25 * (toFloat <| Dict.size pModel.tapes) ) 701 | , case model of 702 | Default tapeId charId _ -> 703 | group (List.indexedMap (\x ( chId, ( ch, tapeSt ) ) -> renderTape model ch tapeSt chId tapeId charId True |> move ( 0, -(toFloat x) * 25 )) <| Dict.toList tapes) 704 | |> move ( -winX / 2 + 20, winY / 6 - 40 ) 705 | 706 | _ -> 707 | group [] 708 | ] 709 | 710 | tapes = 711 | pModel.tapes 712 | 713 | validCheck = 714 | machineCheck sModel 715 | in 716 | group 717 | [ case model of 718 | Default _ _ _ -> 719 | group 720 | [ rect winX (winY / 3) 721 | |> filled lightGray 722 | , machineDefn sModel sModel.machineType winX winY 723 | , if contextHasError validCheck sModel.machineType then 724 | errorMenu validCheck oldMachine winX winY |> move ( -winX / 2 + 20, winY / 6 ) 725 | 726 | else 727 | menu 728 | ] 729 | |> move ( 0, -winY / 3 ) 730 | 731 | Editing tapeId -> 732 | let 733 | ( tape, tapeSt ) = 734 | case Dict.get tapeId pModel.tapes of 735 | Just ( t, st ) -> 736 | ( t, st ) 737 | 738 | Nothing -> 739 | ( Array.empty, Fresh ) 740 | in 741 | group 742 | [ rect winX (winY / 3) 743 | |> filled lightGray 744 | , text "Edit Tape" 745 | |> size 16 746 | |> fixedwidth 747 | |> filled black 748 | |> move ( -winX / 2 + 2, winY / 6 - 15 ) 749 | , text "(Type symbols with your keyboard; backspace to delete; enter to accept)" 750 | |> size 6 751 | |> fixedwidth 752 | |> filled black 753 | |> move ( -winX / 2 + 95, winY / 6 - 15 ) 754 | , latexKeyboard winX winY chars 755 | |> move ( 0, 0 ) 756 | , renderTape model tape tapeSt tapeId -1 -1 False 757 | |> move ( -10 * toFloat (Array.length tape), winY / 6 - 65 ) 758 | ] 759 | |> move ( 0, -winY / 3 ) 760 | , (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine pModel.currentStates transMistakes) |> move ( 0, winY / 6 ) 761 | , machineModeButtons sModel.machineType winX winY ChangeMachine 762 | ] 763 | 764 | 765 | machineDefn : SharedModel -> MachineType -> Float -> Float -> Shape Msg 766 | machineDefn sModel mtype winX winY = 767 | let 768 | machine = 769 | sModel.machine 770 | 771 | getStateName sId = 772 | case Dict.get sId machine.stateNames of 773 | Just n -> 774 | n 775 | 776 | Nothing -> 777 | "\\ " 778 | 779 | machineHeader = 780 | text "Machine" 781 | |> size 16 782 | |> fixedwidth 783 | |> filled black 784 | |> move ( -winX / 2 + 492, winY / 6 - 15 ) 785 | in 786 | case mtype of 787 | NFA -> 788 | group 789 | [ machineHeader 790 | , latex 500 18 "blank" "let\\ N = (Q,\\Sigma,\\Delta,S,F)" AlignLeft 791 | |> move ( -winX / 2 + 500, winY / 6 - 25 ) 792 | , latex 500 14 "blank" "where" AlignLeft 793 | |> move ( -winX / 2 + 500, winY / 6 - 45 ) 794 | , latex 500 18 "blank" ("Q = \\{ " ++ String.join "," (Dict.values machine.stateNames) ++ " \\}") AlignLeft 795 | |> move ( -winX / 2 + 510, winY / 6 - 65 ) 796 | , latex 500 18 "blank" ("\\Sigma = \\{ " ++ String.join "," (Set.toList <| Set.remove "\\epsilon" <| List.foldl Set.union Set.empty <| Dict.values machine.transitionNames) ++ " \\}") AlignLeft 797 | |> move ( -winX / 2 + 510, winY / 6 - 90 ) 798 | , latex 500 18 "blank" "\\Delta = (above)" AlignLeft 799 | |> move ( -winX / 2 + 510, winY / 6 - 115 ) 800 | , latex 500 18 "blank" ("S = \\{ " ++ String.join "," (List.map getStateName <| Set.toList <| machine.start) ++ " \\}") AlignLeft 801 | |> move ( -winX / 2 + 510, winY / 6 - 140 ) 802 | , latex 500 18 "blank" ("F = \\{ " ++ String.join "," (List.map getStateName <| Set.toList <| machine.final) ++ " \\}") AlignLeft 803 | |> move ( -winX / 2 + 510, winY / 6 - 165 ) 804 | ] 805 | 806 | DFA -> 807 | group 808 | [ machineHeader 809 | , latex 500 18 "blank" "let\\ M = (Q,\\Sigma,\\delta,s,F)" AlignLeft 810 | |> move ( -winX / 2 + 500, winY / 6 - 25 ) 811 | , latex 500 14 "blank" "where" AlignLeft 812 | |> move ( -winX / 2 + 500, winY / 6 - 45 ) 813 | , latex 500 18 "blank" ("Q = \\{ " ++ String.join "," (Dict.values machine.stateNames) ++ " \\}") AlignLeft 814 | |> move ( -winX / 2 + 510, winY / 6 - 65 ) 815 | , latex 500 18 "blank" ("\\Sigma = \\{ " ++ String.join "," (Set.toList <| Set.remove "\\epsilon" <| List.foldl Set.union Set.empty <| Dict.values machine.transitionNames) ++ " \\}") AlignLeft 816 | |> move ( -winX / 2 + 510, winY / 6 - 90 ) 817 | , latex 500 18 "blank" "\\delta = (above)" AlignLeft 818 | |> move ( -winX / 2 + 510, winY / 6 - 115 ) 819 | , latex 500 820 | 14 821 | "blank" 822 | ("s = " 823 | ++ (case Set.toList machine.start of 824 | [] -> 825 | "Please\\ select\\ a\\ start\\ state" 826 | 827 | x :: [] -> 828 | getStateName x 829 | 830 | x :: xs -> 831 | "Congratulations,\\ you\\ found\\ a\\ bug!" 832 | ) 833 | ) 834 | AlignLeft 835 | |> move ( -winX / 2 + 510, winY / 6 - 140 ) 836 | , latex 500 18 "blank" ("F = \\{ " ++ String.join "," (List.map getStateName <| Set.toList <| machine.final) ++ " \\}") AlignLeft 837 | |> move ( -winX / 2 + 510, winY / 6 - 160 ) 838 | ] 839 | 840 | 841 | epsTrans : TransitionNames -> Delta -> Set StateID -> Set StateID 842 | epsTrans tNames d states = 843 | let 844 | dList = 845 | (Dict.toList << Dict.filter (\k _ -> Set.member k states)) d 846 | 847 | -- LMD: This was copy-pasted from delta 848 | getName trans = 849 | case Dict.get trans tNames of 850 | Just n -> 851 | renderSet2String n 852 | 853 | _ -> 854 | "" 855 | 856 | findEpsTransitions : List ( StateID, Dict TransitionID StateID ) -> List StateID 857 | findEpsTransitions lst = 858 | case lst of 859 | [] -> 860 | [] 861 | 862 | ( sID, dictTrans ) :: xs -> 863 | let 864 | listTrans = 865 | Dict.toList dictTrans 866 | 867 | epsStates = 868 | List.filterMap 869 | (\( tId, sId ) -> 870 | if getName tId == "\\epsilon" then 871 | Just sId 872 | 873 | else 874 | Nothing 875 | ) 876 | listTrans 877 | in 878 | epsStates ++ findEpsTransitions xs 879 | 880 | newCurrentStates = 881 | Set.union (Set.fromList <| findEpsTransitions dList) states 882 | in 883 | if newCurrentStates == states then 884 | states 885 | 886 | else 887 | epsTrans tNames d newCurrentStates 888 | 889 | 890 | delta : TransitionNames -> Delta -> Character -> StateID -> Set StateID 891 | delta tNames d ch state = 892 | let 893 | getName trans = 894 | case Dict.get trans tNames of 895 | Just n -> 896 | n 897 | 898 | _ -> 899 | Set.empty 900 | in 901 | case Dict.get state d of 902 | Just transMap -> 903 | let 904 | states = 905 | List.filterMap 906 | (\( tId, sId ) -> 907 | if 908 | (Set.member ch <| getName tId) 909 | || ((renderSet2String <| getName tId) == "\\epsilon" && sId == state) 910 | then 911 | Just sId 912 | 913 | else 914 | Nothing 915 | ) 916 | <| 917 | Dict.toList transMap 918 | in 919 | Set.fromList states 920 | 921 | Nothing -> 922 | Set.empty 923 | 924 | 925 | deltaHat : TransitionNames -> Delta -> Character -> Set StateID -> Set StateID 926 | deltaHat tNames d ch states = 927 | let 928 | newStates = 929 | Set.foldl (\curr ss -> Set.union ss (delta tNames d ch curr)) Set.empty states 930 | in 931 | epsTrans tNames d newStates 932 | 933 | 934 | latexKeyboard : Float -> Float -> List Character -> Shape Msg 935 | latexKeyboard w h chars = 936 | let 937 | topRow = 938 | [ 'q', 'w', 'e', 'r', 't', 'y', 'u', 'i', 'o', 'p' ] 939 | 940 | homeRow = 941 | [ 'a', 's', 'd', 'f', 'g', 'h', 'j', 'k', 'l' ] 942 | 943 | botRow = 944 | [ 'z', 'x', 'c', 'v', 'b', 'n', 'm' ] 945 | 946 | keyW = 947 | clamp 0 50 (min (w / 11) (keyH * 1.2)) 948 | 949 | keyH = 950 | h / 18 951 | 952 | renderKey letter char = 953 | group 954 | [ roundedRect keyW keyH 2 955 | |> filled white 956 | |> addOutline (solid 0.5) black 957 | , text (String.fromChar letter) 958 | |> fixedwidth 959 | |> size 10 960 | |> filled (rgb 150 150 150) 961 | |> move ( -keyW / 2 + 2, keyH / 2 - 8 ) 962 | , latex (keyW / 1.5) (keyH / 1.5) "white" char AlignCentre 963 | |> move ( 0, 10 ) 964 | ] 965 | 966 | fillOutExtras n offset chs = 967 | let 968 | newL = 969 | List.take n (List.drop offset chs) 970 | in 971 | newL ++ List.repeat (n - List.length newL) "\\ " 972 | 973 | oneRow letters chs = 974 | group 975 | (List.indexedMap 976 | (\x ( c, l ) -> 977 | renderKey l c 978 | |> move ( (keyW + 2) * (toFloat x - (toFloat <| List.length chs) / 2) + keyW / 2 + w / 33, 0 ) 979 | ) 980 | (List.map2 (\a b -> ( a, b )) chs letters) 981 | ) 982 | in 983 | group 984 | [ oneRow topRow (fillOutExtras 10 9 chars) |> move ( -keyW / 3, 0 ) 985 | , oneRow homeRow (fillOutExtras 9 0 chars) |> move ( -keyW / 3, -keyH - 2 ) 986 | , oneRow botRow (fillOutExtras 7 19 chars) |> move ( -keyW, -(keyH + 2) * 2 ) 987 | ] 988 | -------------------------------------------------------------------------------- /src/Utils.elm: -------------------------------------------------------------------------------- 1 | module Utils exposing (..) 2 | 3 | import Dict exposing (Dict) 4 | import GraphicSVG exposing (..) 5 | import Html exposing (input) 6 | import Html.Attributes exposing (..) 7 | import Html.Events exposing (..) 8 | import Json.Decode as D 9 | import Json.Encode as E 10 | import Set exposing (Set) 11 | import Task 12 | 13 | 14 | encodePair : (a -> E.Value) -> (b -> E.Value) -> ( a, b ) -> E.Value 15 | encodePair encA encB ( a, b ) = 16 | E.object [ ( "f", encA a ), ( "s", encB b ) ] 17 | 18 | 19 | encodeTriple : (a -> E.Value) -> (b -> E.Value) -> (c -> E.Value) -> ( a, b, c ) -> E.Value 20 | encodeTriple encA encB encC ( a, b, c ) = 21 | E.object [ ( "f", encA a ), ( "s", encB b ), ( "t", encC c ) ] 22 | 23 | 24 | decodeDict : D.Decoder comparable -> D.Decoder value -> D.Decoder (Dict comparable value) 25 | decodeDict decComp decValu = 26 | D.map Dict.fromList <| D.list <| D.map2 Tuple.pair (D.field "k" decComp) (D.field "v" decValu) 27 | 28 | 29 | decodeSet : D.Decoder comparable -> D.Decoder (Set comparable) 30 | decodeSet decComp = 31 | D.map Set.fromList <| D.list decComp 32 | 33 | 34 | decodePair : D.Decoder x -> D.Decoder y -> D.Decoder ( x, y ) 35 | decodePair decX decY = 36 | D.map2 Tuple.pair (D.field "f" decX) (D.field "s" decY) 37 | 38 | 39 | decodeTriple : D.Decoder x -> D.Decoder y -> D.Decoder z -> D.Decoder ( x, y, z ) 40 | decodeTriple decX decY decZ = 41 | D.map3 (\x y z -> ( x, y, z )) (D.field "f" decX) (D.field "s" decY) (D.field "t" decZ) 42 | 43 | 44 | encodeSet : (comparable -> E.Value) -> Set comparable -> E.Value 45 | encodeSet valFn = 46 | E.list valFn << Set.toList 47 | 48 | 49 | encodeDict : (comparable -> E.Value) -> (value -> E.Value) -> Dict comparable value -> E.Value 50 | encodeDict compFn valFn dict = 51 | E.list 52 | (\( k, v ) -> 53 | E.object 54 | [ ( "k", compFn k ) 55 | , ( "v", valFn v ) 56 | ] 57 | ) 58 | <| 59 | Dict.toList dict 60 | 61 | 62 | textBox : String -> Float -> Float -> String -> (String -> msg) -> Shape msg 63 | textBox txt w h place msg = 64 | move ( -w / 2, h / 2 ) <| 65 | html (w * 1.5) (h * 1.5) <| 66 | input 67 | [ id "input" 68 | , placeholder place 69 | , onInput msg 70 | , value txt 71 | , style "width" (String.fromFloat w ++ "px") 72 | , style "height" (String.fromFloat h ++ "px") 73 | , style "margin-top" "1px" 74 | , style "font-family" "monospace" 75 | ] 76 | [] 77 | 78 | 79 | newMsg : msg -> Cmd msg 80 | newMsg msg = 81 | Task.perform identity <| Task.succeed msg 82 | -------------------------------------------------------------------------------- /tests/Example.elm: -------------------------------------------------------------------------------- 1 | module Example exposing (suite) 2 | 3 | import Expect exposing (Expectation) 4 | import Fuzz exposing (Fuzzer, int, list, string) 5 | import Json.Decode as D 6 | import Json.Encode as E 7 | import Machine exposing (test) 8 | import Test exposing (..) 9 | 10 | 11 | suite : Test 12 | suite = 13 | describe "Machine encoder-decoder" 14 | [ Test.test "Self-cancellation of encoding and decoding for V1" <| 15 | \_ -> 16 | Expect.equal (Ok Machine.test) 17 | (D.decodeString Machine.machineDecoder <| 18 | E.encode 0 (Machine.machineEncoder Machine.test) 19 | ) 20 | ] 21 | --------------------------------------------------------------------------------