From 95adf37e9c98b09bd6e5649ce40d0ddd9c5e2c48 Mon Sep 17 00:00:00 2001 From: MatthewZ0823 <59446103+MatthewZ0823@users.noreply.github.com> Date: Fri, 17 Jan 2025 09:11:01 -0500 Subject: [PATCH] Remove all boiler plate --- .gitattributes | 2 - .gitignore | 4 - .travis.yml | 37 -- README.md | 2 - build_scripts/deploy_rsa.enc | Bin 3248 -> 0 bytes build_scripts/optimize.sh | 14 - elm.json | 37 -- src/ApplicationModel.elm | 21 - src/BetterUndoList.elm | 53 -- src/Building.elm | 840 -------------------------- src/Environment.elm | 24 - src/Error.elm | 247 -------- src/Exporting.elm | 555 ----------------- src/Helpers.elm | 333 ----------- src/Machine.elm | 853 -------------------------- src/Main.elm | 748 ----------------------- src/Mistakes.elm | 54 -- src/Ports.elm | 13 - src/SaveLoad.elm | 1098 ---------------------------------- src/SharedModel.elm | 77 --- src/Simulating.elm | 987 ------------------------------ src/Utils.elm | 81 --- tests/Example.elm | 20 - 23 files changed, 6100 deletions(-) delete mode 100644 .gitattributes delete mode 100644 .gitignore delete mode 100644 .travis.yml delete mode 100644 README.md delete mode 100644 build_scripts/deploy_rsa.enc delete mode 100755 build_scripts/optimize.sh delete mode 100644 elm.json delete mode 100644 src/ApplicationModel.elm delete mode 100644 src/BetterUndoList.elm delete mode 100644 src/Building.elm delete mode 100644 src/Environment.elm delete mode 100644 src/Error.elm delete mode 100644 src/Exporting.elm delete mode 100644 src/Helpers.elm delete mode 100644 src/Machine.elm delete mode 100644 src/Main.elm delete mode 100644 src/Mistakes.elm delete mode 100644 src/Ports.elm delete mode 100644 src/SaveLoad.elm delete mode 100644 src/SharedModel.elm delete mode 100644 src/Simulating.elm delete mode 100644 src/Utils.elm delete mode 100644 tests/Example.elm diff --git a/.gitattributes b/.gitattributes deleted file mode 100644 index dfe0770..0000000 --- a/.gitattributes +++ /dev/null @@ -1,2 +0,0 @@ -# Auto detect text files and perform LF normalization -* text=auto diff --git a/.gitignore b/.gitignore deleted file mode 100644 index eb07aeb..0000000 --- a/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -elm-stuff/ -*.js -*.html -*.svg diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 3a6ed85..0000000 --- a/.travis.yml +++ /dev/null @@ -1,37 +0,0 @@ -language: elm - -install: - - npm install -g elm@0.19.1-3 - - npm install -g elm-test@0.19.1 - - npm install -g elm-format@0.8.2 -env: - global: - - secure: C9poA+wbk5f2SMct/hZe2GDGRvGofIwoGJyvWQOkSVfV016YrtDMmOrrYXjx5qBmY3mO7dejG/D7yZHUKHqQO6QmAOMyrP1Efj1xqAZwOUH8z0I82mb7xjfd0pSrT/HHxd030orVRxqfOTXawvkRHcQ9/H3oREiHgV+IccFRVpTVf8avYREV7cds7p62VNj/3uK1De/etdnDxWFWEQldkdlE1dNE/KMX6SsJGs0JMMC8ubyG5sVIaBs9XPo6DPs9jphioyCmZbVzqms8F0Wirzn4OYbLIXMkV73OywCQmRBo41i/SOHIfACfKBzTnleQ8RwuCxMr9PxGD0s8+W8r1tsWYsr5nqxj8YtW2U9BI8a2P3yYyfw95jh2xrKYiJGHvVZaE0crB8xK9V7UurvrBZs1W402mKCmw0RCqc5HGyCwT4croJb6cj6IdVLurBbomcR3iUL8JuFPPihJdCVjJddO9hEnqcwr2MzcLNXR2MXIlSGX5WPAB+D7WYsfMfJwTdO2LvvToXPUc4dujnodWKjpk/PDAiOJNSEOdyTXOP/bQn7+9B9kwngfqTXdSM/EngabpdZhjRDSLqtkxzR6/3AMWvg/X0jKPds7Z1xn8cDcshOhFuHrKD6BacbkGuN7WHtemm+JCowSn70Yl/6xIWA1bpa6suFLzbCpvKXlHgk= - - secure: iSktBKBarfcmVAGJtVbifKvQ8faPbWvkmcHbgjZkaCZFhcg8iTnszJIH2ht1qicsW9xnuIzitsl/hwB9ZaRY1dXhG9sVPtJYQeSvDgb34voPGXJ+0mewxFbGi1Li+bgq5jy9j2NoPtz95swHVXfVODToU1zP2Vmp6EMnLQhidQqXvR77T1QlYOxjFnJMSBSHz1cIIt5y94n5/DSYp5F4OYqq6ia1D9Vc1iecENHscQHzKRNVXTvnBJ/rYGObWA6PfV2cTnbRrB+XANxPAI8i8aV1S/YfmkiEw4SRmK3hRN909QDVKTjATOx7zL1/BuB09Br7HnePgOB04XugWDd3hIjFoNZr5fZ3JceFgNRwW93G24spCn8tOp4E0vZCfLSirmeJPAwAH8yFPVls9OLdcflu+N9HVzpgv2kZjk11Q5tblql5ZclmyvhJtQVfmi2kb7hfABE1soqLrkTcVKjUsbPbkPLCNgdjlVaMP569PBGfuxps8EUzhDvvvPvFEU49r1nnlNU10uhUvoNmWBhsnTEQEdAm2oNC7b9XxzE/0XctSXhd+5OwccIWfhSaJH5TpTmRwmX5cOSnnwp+N+pbYITWCvI82l3yftgA1Cykhd8EVeh9uwHZcv+6wEVbYje4d7qeaMh/dlW+GVztoYr9UTA7bKKYB4q1ok0oBbBc13A= - - secure: sn5UJ+DXrtGvF7wU0roFz3Whd++kIFWSYg148phElgiqls4pUo93isGBM4XF6feeQqDrEybRPQqPcDnpsGR5kPnJrafrm6C9ZiKQMb2qDEGmSTIQ3dWapLvQJve1/pbEaaWXEQPEgTEcIZPkNaGUme6nMHwnDLIWBrkrgR9ugc0/IGgercGUJB3RVUYbF7WcsqwhILfqyZzDqZrlhaoIjLRFRfn8xvORiNki48lv9b5l5sHcGfX4Y41fUxCegXz6z63ClZr/G2jym1U416WKoTHi8BNXk9Tk5JApc5prxI9R9x9cQeauDMqFl38z9Noh0heeXxgmq3m72GhSq45avNgdDRA2SA6l3pgZeYMBs3TFFzZSgiRnr6BXF9lVSJcAKUP7+z7o5WYxSCEvEBRY8I11cK6QFM14Ssp63W0MxSlGBUu6pTXcRh5PyyqSHsavsbpWM8SnXc+SwLvkeP21VCBX4D5XZqp33ZDiGuSiUbNzzqnksESUwJ/Za6Ex5Jjk36qQbwP1vXoH0SFBMEWi44nQHVIw+nmoC0aQBX/6yk0li4W9szxpI+R+s03Vo1ZCg+l1aLXOU+Vhld/80rVJs0DnhcYJYyroH1wIAnYaMvtBBvC1U6bxWS+i7qI7lJrQ+C4mLSxo1TpjhdzhD1bQ8k8JO2bzaW0+GFoDH0RnPJI= -jobs: - include: - - stage: test - script: - - elm-format --validate . - - elm make src/Main.elm --optimize - name: elm-format and optimization validation - - script: elm-test - name: elm-test test run - - stage: deploy - script: - - openssl aes-256-cbc -K $encrypted_0d4cca618d57_key -iv $encrypted_0d4cca618d57_iv - -in build_scripts/deploy_rsa.enc -out /tmp/deploy_rsa -d - - eval "$(ssh-agent -s)" - - chmod 600 /tmp/deploy\_rsa - - chmod u+x build_scripts/optimize.sh - - ssh-add /tmp/deploy\_rsa - - echo -e "Host $DEPLOY_HOST\n\tStrictHostKeyChecking no\n" >> ~/.ssh/config - - npm install -g uglify-js - - "./build_scripts/optimize.sh src/Main.elm" - - scp finsm.min.js $DEPLOY_USER@$DEPLOY_HOST:$DEPLOY_DIRECTORY - name: Live Deployment -stages: -- test -- name: deploy - if: "(branch = master) AND (tag IS present)" diff --git a/README.md b/README.md deleted file mode 100644 index 11027db..0000000 --- a/README.md +++ /dev/null @@ -1,2 +0,0 @@ -# finsm [![Build Status](https://travis-ci.org/CSchank/finsm.svg?branch=master)](https://travis-ci.org/CSchank/finsm) -An Elm app for building and simulating deterministic and non-deterministic finite automata (DFAs and NFAs). diff --git a/build_scripts/deploy_rsa.enc b/build_scripts/deploy_rsa.enc deleted file mode 100644 index 89b7668165bb78610445b3aa816eb0cad0f27854..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3248 zcmV;h3{UeuYt7^V4?9F`gpj$2`m!vHB~c^s#5b@)EkL)up=<}4r^B{Og8}g@NqmLu zN+2Kg5skrFqjaM^Ap;Pp235yX@2MZB;AP7JL7)FAhtg7FTlt1tOubJ(2H^YchgAMv zv-`QE?E=@}A+-!ta>jkUXuD)2aLOeYB|NrHdc1EvQ-bq}oWRfO*0kmktCGe#^=0X> zNGEX4HOkznc7F76ix_@kCj!{8(^7$^38NVgDTht)$ZvtvH#7+3{am9mRoqv zN^5|dcT3;zz&Uc8riQLRlsyKRrY11s!A~A~+bY$OP*0rp&Tjmb5|?VVF$A%W07LZ= z7altcaWyYo}84<{PgE_%(22_3Z|38P%U>9rZD1O2DVY3WQ^nkl4r2B;l(F=?#&ssVjq&x|Z&k|< zuT}V}V$L(vJ`0K$EwT~1jrdp(_+Qw&pbAdz4l98n6d0DCrQo?0{7me6bLr| z<~3-Z31e#?Dk@CQ$uC`f!eJTw&bNngYr%tD6$47tQbaQf-#k3f+C1j&By~)$Qik|P z9R2`0Qd=fwhG~_s$7ikO7!z8_ul|oHl<~iBa6KF4EVLe-!%~1i0&|p7_)=_^)1H+iiM)mzp7m0-KWc*tpF*) z^sdBc0kGZTq|w0k8PL$kq`?E;sV!Q!slO_U5YZK+PuEgri20AFXoJjabx^H()7=$b z2M@^1sUo>TXJl>CV>Uq?xA~)JFIJooyW#gC#)I@?Oqu^0#8Sw{k>#%$A1+cdz#FPe zkAA=0P3l@csBr+y^P~zV8k7nkx|6^TH_{s7uD}H|ne9RO?M1_n&b-7rM2riV6-;|K z1w2>%=cCqEysE0)TY_+S(&i4pBx_fD7|4IfGMI_#onf3K9!r+BgGcjiTO@P-?yI5i z<>xyHLDDVAIB5VB9r2Y6SLif|4khaiWhIWBc_lL!)!%VDTo8 zl39$Pzi!QY#^WzuY4MfXJ3Q@Y-WCPBG*`-qlW)IaWfw@;ZXmH7v$rywfyGA1DcuCgWV|Z!~$(!qOrH%aC=}OysS503bI4 zmH&@Ih0()de}xZ z1*d$>i8!cW1{m%69QZ_XYFoeGY;I8?y=BLhr$8N}MOVlLSzNP9%z`Xz^K(gkq`L{> zEMlEZ)uPhg=g;5iO%1TVnG~~Q@1~uGWp{6;4&Gz^SS`KcJWc*9>jeo-N4zsT!Yx@A zF7XyWuh_b&?q-atl6mQq7rXmEuv?K#)E#yM0LAs?p)|7PMz@S#trf1sj?RQzZ&rJf zdcXtS;nT}5Ikc>kL$iM@c@J7(CMgzHb9)2H!u_=rW2UQfD3){Dey1CWHg{bL!N)hH zQ#X%VR$=G&!(K6Qze>Og!aqPm&>A%x$+n{&?u3hi!GzoY0K_G zl7l~9BL;a0`1ulCxwpAIZ~0xkx;bp!*LBG5BnjOVZXqF3Wt+VY^(lL^&n-1bFw{g! zH!WuWyB4{=#IWr+QFQ>0IefyqF7cLIhW_CBFPiSB36EbGqmF672mR^LuYeanjtdb6 zFO~w=$c92|%=nxAjwi0OxN3&s%xCUEf`Wz!6nh0i?Nfn?kUmK&@wSF7kW=|56VVKv z0^t8=Vv0GRb5fjN z%3mhpANXIn{3$bDiUGD>Cw&!#Jnyt#CyE7%4@UGg{dxTt@C!_d~rhRh?0-< z8ge^<*TV@2h+4=klURo(v2<}oX z)`;I(NcPm$04O);(_waaPFH@biZl_X*T;6IkZux^6d|jegY1`0`h+ArIQ+YQ;J@ z?<*=Yp)L-MeuOXxc1^~a-gSTQg}Iz8zGik4H2Q2h?&@s-L;IjmTdg>UKK1Cr`V7!_ z8B_o#Kv@|s=8(`(V70A$<)l3DaEAPF#0k)T?X?KQaBg}^<_n-E=LuvE@hM~#ChG4; zjiAYQnBJR~%NIF5O2R{G^OIA)!RT$(T?(bPOKmHA#MK(cd@%$|o2dE68!p>^K6Mxf zjYp#8z~3vPuw}~mHwYlXp-K+STb$9$RUR%V{S_Yi z{6&EU0wE&T2kDx^k1_6dJY!|9^qyKQAs&|f_Qnq>n?vv#3pCnCx+nHGoDX&v+2_4| z55TNX-h4g%mq(c=+XR)w03pqpRn{oLEcY@tW7|eUwCeMxsNA5#jTOBy)1}e+iSEz< zYBk_UPS^a>!DkGRhIz?3xUvB^uwi?WEa$^hhh5jfRf6X)V*NCTMkxOzK??+ES%O`R zQ@*NmtgspcM1y9pbSZs1wel*9T&V19pcmgD)LW0A9uPKSLJ#{0Gk3+*>R1{ zk?HhnRVCqCnou7AN{btx2plzmN^_{#g;p_}g6X!6I5|5DVsFkwSL^IFeA434A;O?O zPW4V=ig#1`lXX4Vp12S6TGT@yUUHknEP`gYKt8^V}#Co`% z*0m=_OGy#tzvMwm4{&;6G#^>;=#>kt)U!(eIUfq{;oD4{hat)ho$JtO@d&|&-shfa z!3R$P8d>o`sp+sci4U|jV~_TH`tUOOw=_0b1edd0kOeaRRXc4hxe^UD&c|AHkY$f6 zzkswmA`Fvk=5B^eN@hj>8ULgX6SjWNn(MP$Gp$b4x(y4sQ3ZR>H}^tdoq(xNjaQ6{ zNhYdzP5)-Q;~Wk`COHvaWVfMqz_CC#M`IYQHJwNBR!;Q1dLU1dU15^ePh-xQ$X5RBG_wV=?Z=az`^}T1{N$xqb@Qls zXQe%&(7iM&>>=){gz(81srm83dU5JlpKCQUCOv8G`2EvDYbkCtM{%W&vKoO3YplA;gdPf0shA&5*JAtM i?lb_$D5-wWcn+w)Y8MD^u=w{cJ)d&)Ql9}7RL?p~ BetterUndoList state -fresh state = - { present = state - , ul = U.fresh state - } - - -new : state -> BetterUndoList state -> BetterUndoList state -new state nUL = - { nUL - | present = state - , ul = U.new state nUL.ul - } - - -replace : state -> BetterUndoList state -> BetterUndoList state -replace state nUL = - { nUL - | present = state - } - - -undo : BetterUndoList state -> BetterUndoList state -undo nUL = - let - newUL = - U.undo nUL.ul - in - { present = newUL.present - , ul = U.undo nUL.ul - } - - -redo : BetterUndoList state -> BetterUndoList state -redo nUL = - let - newUL = - U.redo nUL.ul - in - { present = newUL.present - , ul = newUL - } diff --git a/src/Building.elm b/src/Building.elm deleted file mode 100644 index ed7acf0..0000000 --- a/src/Building.elm +++ /dev/null @@ -1,840 +0,0 @@ -module Building exposing (Model, Msg(..), PersistentModel(..), editingButtons, init, initPModel, onEnter, onExit, subscriptions, update, updateArrowPos, updateStatePos, view) - -import Browser.Events -import Dict exposing (Dict) -import Environment exposing (Environment) -import GraphicSVG exposing (..) -import Helpers exposing (..) -import Json.Decode as D -import Machine exposing (..) -import Mistakes exposing (..) -import Set -import SharedModel exposing (MachineType(..), SharedModel, machineModeButtons) -import Task -import Tuple exposing (first, second) - - -type alias Model = - { machineState : Machine.Model - , snapToGrid : Snap - } - - -type Snap - = SnapToGrid Int - | NoSnap - - -type PersistentModel - = Empty - - -type Msg - = MachineMsg Machine.Msg - | SaveStateName StateID String - | SaveTransitionName TransitionID String - | ToggleStart StateID - | ChangeMachine MachineType - | AddState ( Float, Float ) - | KeyPressed String - | ToggleSnap - | ChangeSnap Int - | NoOp - - -subscriptions : Model -> Sub Msg -subscriptions model = - Sub.batch - [ Browser.Events.onKeyDown (D.map KeyPressed (D.field "key" D.string)) - ] - - -init : Model -init = - { machineState = Regular - , snapToGrid = NoSnap - } - - -initPModel : PersistentModel -initPModel = - Empty - - -onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) -onEnter env ( pModel, sModel ) = - ( ( init, pModel, sModel ), False, Cmd.none ) - - -onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) -onExit env ( model, pModel, sModel ) = - ( ( pModel, sModel ), False ) - - -update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) -update env msg ( model, pModel, sModel ) = - let - oldMachine = - sModel.machine - in - case msg of - MachineMsg mmsg -> - case mmsg of - StartDragging st ( x, y ) -> - let - ( sx, sy ) = - case Dict.get st oldMachine.statePositions of - Just ( xx, yy ) -> - ( xx, yy ) - - Nothing -> - ( 0, 0 ) - in - case model.machineState of - MousingOverRim sId _ -> - ( ( { model | machineState = AddingArrow sId ( x, y ) }, pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( { model | machineState = DraggingState st ( x - sx, y - sy ) ( x, y ) }, pModel, sModel ), False, Cmd.none ) - - StartDraggingArrow ( st1, char, st2 ) pos -> - ( ( { model | machineState = DraggingArrow ( st1, char, st2 ) pos }, pModel, sModel ), False, Cmd.none ) - - StartMouseOverRim stId ( x, y ) -> - case model.machineState of - Regular -> - ( ( { model | machineState = MousingOverRim stId ( x, y ) }, pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - MoveMouseOverRim ( x, y ) -> - case model.machineState of - MousingOverRim stId _ -> - ( ( { model | machineState = MousingOverRim stId ( x, y ) }, pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - StopMouseOverRim -> - case model.machineState of - MousingOverRim _ _ -> - ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - StopDragging -> - case model.machineState of - DraggingState st _ _ -> - ( ( { model | machineState = SelectedState st }, pModel, sModel ), True, Cmd.none ) - - AddingArrowOverOtherState st _ s1 -> - let - newTrans = - case List.head <| Dict.values oldMachine.transitionNames of - Just setchar -> - setchar - - Nothing -> - Set.singleton "x" - - newTransID = - case List.maximum <| Dict.keys oldMachine.transitionNames of - Just n -> - n + 1 - - Nothing -> - 0 - - isValidTransition = - checkTransitionValid newTrans - - newDelta : Delta - newDelta = - Dict.update st - (\mcDict -> - case mcDict of - Just ss -> - Just <| - Dict.update newTransID - (\mState -> - Just s1 - ) - ss - - Nothing -> - Just <| Dict.singleton newTransID s1 - ) - oldMachine.delta - - newTransPos = - if st == s1 then - ( 0, 50 ) - - else - ( 0, 0 ) - in - ( ( { model | machineState = Regular } - , pModel - , { sModel - | machine = - { oldMachine - | delta = newDelta - , transitionNames = Dict.insert newTransID newTrans oldMachine.transitionNames - , stateTransitions = Dict.insert ( st, newTransID, s1 ) newTransPos oldMachine.stateTransitions - } - } - ) - , True - , Cmd.none - ) - - DraggingArrow tId _ -> - ( ( { model | machineState = Regular }, pModel, sModel ), True, Cmd.none ) - - _ -> - ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) - - SelectArrow ( s0, tId, s1 ) -> - let - oldTransName = - case Dict.get tId sModel.machine.transitionNames of - Just n -> - renderSet2String n - - Nothing -> - "" - in - if env.holdingShift then - ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), False, focusInput NoOp ) - - else - ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), False, Cmd.none ) - - Drag ( x, y ) -> - case model.machineState of - DraggingState st ( ox, oy ) _ -> - let - ( sx, sy ) = - case Dict.get st oldMachine.statePositions of - Just ( xx, yy ) -> - ( xx, yy ) - - Nothing -> - ( 0, 0 ) - - newPos = - case model.snapToGrid of - SnapToGrid n -> - ( roundTo (toFloat n) (x - ox), roundTo (toFloat n) (y - oy) ) - - _ -> - ( x - ox, y - oy ) - in - ( ( { model | machineState = DraggingState st ( ox, oy ) ( x, y ) }, pModel, { sModel | machine = { oldMachine | statePositions = updateStatePos st newPos oldMachine.statePositions } } ) - , False - , Cmd.none - ) - - DraggingArrow ( s1, char, s2 ) _ -> - let - ( x0, y0 ) = - case Dict.get s1 oldMachine.statePositions of - Just ( xx, yy ) -> - ( xx, yy ) - - Nothing -> - ( 0, 0 ) - - ( x1, y1 ) = - case Dict.get s2 oldMachine.statePositions of - Just ( xx, yy ) -> - ( xx, yy ) - - Nothing -> - ( 0, 0 ) - - newPos = - case model.snapToGrid of - SnapToGrid n -> - ( roundTo (toFloat n) x, roundTo (toFloat n) y ) - - _ -> - ( x, y ) - - theta = - -1 * atan2 (y1 - y0) (x1 - x0) - - ( mx, my ) = - ( (x0 + x1) / 2, (y0 + y1) / 2 ) - - ( nx, ny ) = - sub newPos ( mx, my ) - - nprot = - ( nx * cos theta - ny * sin theta, nx * sin theta + ny * cos theta ) - in - ( ( { model | machineState = DraggingArrow ( s1, char, s2 ) ( x, y ) }, pModel, { sModel | machine = { oldMachine | stateTransitions = Dict.insert ( s1, char, s2 ) nprot oldMachine.stateTransitions } } ), False, Cmd.none ) - - AddingArrow st _ -> - let - aboveStates = - List.map (\( sId, _ ) -> sId) <| - Dict.toList <| - Dict.filter (\_ ( x1, y1 ) -> (x1 - x) ^ 2 + (y1 - y) ^ 2 <= 400) oldMachine.statePositions - - newState = - case aboveStates of - h :: _ -> - AddingArrowOverOtherState st ( x, y ) h - - _ -> - AddingArrow st ( x, y ) - in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) - - AddingArrowOverOtherState st _ s1 -> - let - aboveStates = - List.map (\( sId, _ ) -> sId) <| - Dict.toList <| - Dict.filter (\_ ( x1, y1 ) -> (x1 - x) ^ 2 + (y1 - y) ^ 2 <= 400) oldMachine.statePositions - - newState = - case aboveStates of - h :: _ -> - AddingArrowOverOtherState st ( x, y ) h - - _ -> - AddingArrow st ( x, y ) - in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( { model | machineState = model.machineState }, pModel, sModel ), False, Cmd.none ) - - MouseOverStateLabel st -> - ( ( { model | machineState = MousingOverStateLabel st }, pModel, sModel ), False, Cmd.none ) - - MouseOverTransitionLabel tr -> - let - newState = - case model.machineState of - Regular -> - MousingOverTransitionLabel tr - - _ -> - model.machineState - in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) - - MouseLeaveLabel -> - let - newState = - case model.machineState of - MousingOverStateLabel _ -> - Regular - - MousingOverTransitionLabel _ -> - Regular - - _ -> - model.machineState - in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) - - EditLabel _ lbl -> - let - newState = - case model.machineState of - EditingStateLabel st _ -> - EditingStateLabel st lbl - - EditingTransitionLabel tr _ -> - EditingTransitionLabel tr lbl - - _ -> - model.machineState - in - ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) - - TapState sId -> - let - oldStateName = - case Dict.get sId sModel.machine.stateNames of - Just n -> - n - - _ -> - "" - in - if env.holdingShift then - ( ( { model | machineState = EditingStateLabel sId oldStateName }, pModel, sModel ), False, focusInput NoOp ) - - else - ( ( { model | machineState = SelectedState sId }, pModel, sModel ), False, Cmd.none ) - - Reset -> - ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) - - ChangeMachine mtype -> - case mtype of - NFA -> - case sModel.machineType of - NFA -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - DFA -> - ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) - - DFA -> - case sModel.machineType of - DFA -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - NFA -> - let - startState = - if Set.size oldMachine.start > 1 then - Set.singleton <| - (\x -> - case x of - Just val -> - val - - Nothing -> - -1 - ) - <| - List.head <| - Set.toList oldMachine.start - - else - oldMachine.start - - newSModel = - { sModel | machine = { oldMachine | start = startState }, machineType = DFA } - in - ( ( model, pModel, newSModel ), True, Cmd.none ) - - AddState ( x, y ) -> - case model.machineState of - Regular -> - let - newId = - setMax oldMachine.q + 1 - - newMachine = - { oldMachine - | q = Set.insert newId oldMachine.q - , delta = Dict.insert newId Dict.empty oldMachine.delta - , statePositions = Dict.insert newId ( x, y ) oldMachine.statePositions - , stateNames = Dict.insert newId ("q_{" ++ String.fromInt newId ++ "}") oldMachine.stateNames - } - in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - - _ -> - ( ( { model | machineState = Regular }, pModel, sModel ), False, Cmd.none ) - - KeyPressed k -> - let - normalizedKey = - String.toLower k - in - if normalizedKey == "enter" then - --pressed enter - case model.machineState of - EditingStateLabel sId newLbl -> - let - oldStateName = - case Dict.get sId oldMachine.stateNames of - Just n -> - n - - _ -> - "" - in - if newLbl == oldStateName || newLbl == "" then - ( ( { model | machineState = SelectedState sId }, pModel, sModel ), False, Cmd.none ) - - else - ( ( { model | machineState = SelectedState sId }, pModel, sModel ), True, sendMsg <| SaveStateName sId newLbl ) - - EditingTransitionLabel ( s0, tId, s1 ) newLbl -> - let - oldTransitionName = - case Dict.get tId oldMachine.transitionNames of - Just n -> - renderSet2String n - - _ -> - "" - in - if newLbl == oldTransitionName || newLbl == "" then - ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), False, Cmd.none ) - - else - ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), True, sendMsg <| SaveTransitionName tId newLbl ) - - SelectedState sId -> - let - oldStateName = - case Dict.get sId sModel.machine.stateNames of - Just n -> - n - - _ -> - "" - in - ( ( { model | machineState = EditingStateLabel sId oldStateName }, pModel, sModel ), False, focusInput NoOp ) - - SelectedArrow ( s0, tId, s1 ) -> - let - oldTransName = - case Dict.get tId sModel.machine.transitionNames of - Just n -> - renderSet2String n - - Nothing -> - "" - in - ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), False, focusInput NoOp ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - else if normalizedKey == "s" then - case model.machineState of - SelectedState stId -> - ( ( model, pModel, sModel ), False, sendMsg (ToggleStart stId) ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - else if normalizedKey == "d" then - case model.machineState of - SelectedState stId -> - let - new_q = - Set.remove stId oldMachine.q - - newDelta = - Dict.map (\_ d -> Dict.filter (\tId _ -> not <| Dict.member tId removedTransitions) d) oldMachine.delta - |> Dict.filter (\key _ -> Set.member key new_q) - - newMachine = - { oldMachine - | q = new_q - , delta = newDelta - , start = Set.remove stId oldMachine.start - , final = Set.remove stId oldMachine.final - , statePositions = Dict.remove stId oldMachine.statePositions - , stateTransitions = newStateTransitions - , stateNames = Dict.remove stId oldMachine.stateNames - , transitionNames = Dict.diff oldMachine.transitionNames removedTransitions - } - - newStateTransitions = - Dict.filter (\( _, t, _ ) _ -> not <| Dict.member t removedTransitions) oldMachine.stateTransitions - - removedTransitionsLst = - List.map (\( _, t, _ ) -> ( t, () )) <| Dict.keys <| Dict.filter (\( s0, _, s1 ) _ -> s0 == stId || s1 == stId) oldMachine.stateTransitions - - removedTransitions = - Dict.fromList removedTransitionsLst - in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - - SelectedArrow ( _, tId, _ ) -> - let - newDelta = - Dict.map (\_ d -> Dict.filter (\tId0 _ -> tId /= tId0) d) oldMachine.delta - - newMachine = - { oldMachine - | delta = newDelta - , stateTransitions = newStateTransitions - , transitionNames = Dict.remove tId oldMachine.transitionNames - } - - newStateTransitions = - Dict.filter (\( _, tId0, _ ) _ -> tId /= tId0) oldMachine.stateTransitions - in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - else if normalizedKey == "g" then - ( ( model, pModel, sModel ), False, sendMsg ToggleSnap ) - - else - case model.machineState of - SelectedState sId -> - if normalizedKey == "f" then - let - newMachine = - { oldMachine - | final = - case Set.member sId oldMachine.final of - True -> - Set.remove sId oldMachine.final - - False -> - Set.insert sId oldMachine.final - } - in - ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - --else if normalizedKey == "s" then - -- let - -- newMachine = - -- { oldMachine - -- | start = - -- case Set.member sId oldMachine.start of - -- True -> - -- Set.remove sId oldMachine.start - -- - -- False -> - -- Set.insert sId oldMachine.start - -- } - -- in - -- ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - - else - ( ( model, pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - ToggleStart sId -> - let - machineType = - sModel.machineType - - tests = - oldMachine.start - - newMachine = - case machineType of - NFA -> - { oldMachine - | start = - case Set.member sId oldMachine.start of - True -> - Set.remove sId oldMachine.start - - False -> - Set.insert sId oldMachine.start - } - - DFA -> - { oldMachine - | start = Set.singleton sId - } - in - ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - - SaveStateName sId newLbl -> - let - newMachine = - { oldMachine | stateNames = Dict.insert sId newLbl oldMachine.stateNames } - in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - - SaveTransitionName tId newLbl -> - let - newTransitions = - parseString2Set newLbl - - isValidTransition = - checkTransitionValid newTransitions - - newMachine = - { oldMachine - | transitionNames = Dict.insert tId newTransitions oldMachine.transitionNames - } - in - ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - - ToggleSnap -> - ( ( { model - | snapToGrid = - if model.snapToGrid == NoSnap then - SnapToGrid 10 - - else - NoSnap - } - , pModel - , sModel - ) - , False - , Cmd.none - ) - - ChangeSnap nn -> - ( ( { model - | snapToGrid = - case model.snapToGrid of - SnapToGrid n -> - SnapToGrid (n + nn) - - NoSnap -> - NoSnap - } - , pModel - , sModel - ) - , False - , Cmd.none - ) - - NoOp -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - -view : Environment -> ( Model, PersistentModel, SharedModel ) -> Shape Msg -view env ( model, pModel, sModel ) = - let - winX = - toFloat <| first env.windowSize - - winY = - toFloat <| second env.windowSize - - transMistakes = - getTransitionMistakes sModel.machine - in - group - [ rect winX winY - |> filled blank - |> (if env.holdingShift then - notifyTapAt AddState - - else - case model.machineState of - SelectedState _ -> - notifyTap (MachineMsg Reset) - - SelectedArrow _ -> - notifyTap (MachineMsg Reset) - - _ -> - identity - ) - , case ( model.machineState, model.snapToGrid ) of - ( DraggingState _ ( ox, oy ) ( x, y ), SnapToGrid n ) -> - group - [ graphPaperCustom (toFloat n) 1 gray - |> clip (circle 30 |> ghost |> move ( x - ox, y - oy )) - , circle 3 |> filled (rgb 112 190 255) |> move ( roundTo 10 (x - ox), roundTo 10 (y - oy) ) - ] - - ( DraggingArrow id pos, SnapToGrid n ) -> - group - [ graphPaperCustom (toFloat n) 1 gray - |> clip (circle 30 |> ghost |> move pos) - ] - - _ -> - group [] - , GraphicSVG.map MachineMsg <| Machine.view env model.machineState sModel.machine Set.empty transMistakes - , editingButtons model |> move ( winX / 2 - 30, -winY / 2 + 25 ) - , machineModeButtons sModel.machineType winX winY ChangeMachine - ] - - -updateStatePos : StateID -> ( Float, Float ) -> StatePositions -> StatePositions -updateStatePos st ( x, y ) pos = - Dict.update st - (\m -> - case m of - Just _ -> - Just ( x, y ) - - Nothing -> - Nothing - ) - pos - - -updateArrowPos : StateID -> Float -> StateTransitions -> StateTransitions -updateArrowPos st angle pos = - Dict.map - (\( st0, char, st1 ) ( x, y ) -> - if st0 == st then - ( x * cos angle, y * sin angle ) - - else if st1 == st then - ( x * cos -angle, y * sin -angle ) - - else - ( x, y ) - ) - pos - - -editingButtons model = - let - snapping = - case model.snapToGrid of - SnapToGrid _ -> - True - - _ -> - False - in - group - [ icon snapping - (snapIcon - |> scale 0.75 - |> repaint - (if snapping then - white - - else - gray - ) - ) - |> notifyTap ToggleSnap - |> move ( -36, 0 ) - ] - - -snapIcon = - group - [ group - [ roundedRect 33 4 2.5 |> filled black |> move ( 0, 10 ) - , roundedRect 33 4 2.5 |> filled black - , roundedRect 33 4 2.5 |> filled black |> move ( 0, -10 ) - , roundedRect 4 33 2.5 |> filled black |> move ( 10, 0 ) - , roundedRect 4 33 2.5 |> filled black - , roundedRect 4 33 2.5 |> filled black |> move ( -10, 0 ) - ] - |> subtract - (group - [ wedge 10 0.5 |> ghost |> rotate (degrees 90) - , rect 8 12 |> ghost |> move ( 6, -6 ) - , rect 8 12 |> ghost |> move ( -6, -6 ) - , rect 12 8 |> ghost |> move ( 0, -3 ) - ] - |> move ( 5, -10 ) - ) - , group - [ wedge 8 0.5 - |> filled black - |> rotate (degrees 90) - |> subtract (wedge 2 0.5 |> ghost |> rotate (degrees 90)) - , rect 6 6 - |> filled black - |> move ( 5, -3 ) - |> subtract (rect 2.5 3 |> ghost |> move ( 5, -3 )) - , rect 6 6 - |> filled black - |> move ( -5, -3 ) - |> subtract (rect 2.5 3 |> ghost |> move ( -5, -3 )) - ] - |> move ( 5, -10 ) - ] diff --git a/src/Environment.elm b/src/Environment.elm deleted file mode 100644 index 09c41e2..0000000 --- a/src/Environment.elm +++ /dev/null @@ -1,24 +0,0 @@ -module Environment exposing (Environment, init) - -import Time - - -init : Environment -init = - { windowSize = ( 0, 0 ) - , holdingShift = False - , holdingControl = False - , holdingMeta = False - , currentTime = Time.millisToPosix 1576798602274 - , timeZone = Time.utc - } - - -type alias Environment = - { windowSize : ( Int, Int ) - , holdingShift : Bool - , holdingControl : Bool - , holdingMeta : Bool - , currentTime : Time.Posix - , timeZone : Time.Zone - } diff --git a/src/Error.elm b/src/Error.elm deleted file mode 100644 index f242cb0..0000000 --- a/src/Error.elm +++ /dev/null @@ -1,247 +0,0 @@ -module Error exposing (DFAErrorType(..), Error(..), contextHasError, errorIcon, errorMenu, machineCheck) - --- This module serves to export checks and exception handling of finite state machines. --- When we add support for other machine types, we can extend this module as well. - -import Array exposing (Array) -import Dict exposing (Dict) -import Environment exposing (Environment) -import GraphicSVG exposing (..) -import Helpers exposing (..) -import Machine exposing (Machine, StateID, TransitionID) -import Mistakes exposing (..) -import Set exposing (Set) -import SharedModel exposing (..) -import Tuple exposing (first, second) - - -type Error - = NoError - | DFAError DFAErrorType StateID - | EpsTransError - | DuplicateStates (Set StateID) - - -type DFAErrorType - = HasEpsilon - | Incomplete - | Nondeterministic - | Unsure -- Good for debugging? - - -contextHasError : Error -> MachineType -> Bool -contextHasError err mtype = - case mtype of - DFA -> - if err == NoError then - False - - else - True - - NFA -> - case err of - EpsTransError -> - True - - DuplicateStates _ -> - True - - _ -> - False - - -machineCheck : SharedModel -> Error -machineCheck sModel = - let - mac = - sModel.machine - - tMistakes = - getTransitionMistakes mac - - allTransitionLabels = - List.sort <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values mac.transitionNames - - catch : Maybe (Set String) -> List String - catch ms = - case ms of - Nothing -> - [] - - Just s -> - Set.toList s - - getTrans : Dict TransitionID StateID -> List String - getTrans d = - (List.concatMap (\e -> Dict.get e mac.transitionNames |> catch) <| Dict.keys d) |> List.sort - - foldingFunc : ( StateID, Dict TransitionID StateID ) -> Error -> Error - foldingFunc sTuple err = - case err of - DFAError errType x -> - DFAError errType x - - NoError -> - let - transitions = - getTrans <| second sTuple - - stId = - first sTuple - in - if transitions == allTransitionLabels then - NoError - - else if List.member "\\epsilon" transitions then - DFAError HasEpsilon stId - - else - case compare (List.length transitions) (List.length allTransitionLabels) of - LT -> - DFAError Incomplete stId - - EQ -> - DFAError Incomplete stId - - -- e.g. compare [1,1,2] [1,2,3], can be Nondeterministic too - GT -> - DFAError Nondeterministic stId - - otherErr -> - otherErr - in - if tMistakes /= Nothing then - EpsTransError - - else - List.foldr (\x acc -> foldingFunc x acc) NoError <| Dict.toList mac.delta - - -errorIcon : Color -> Color -> Shape msg -errorIcon backclr shapeclrs = - group - [ triangle 20 |> filled backclr |> rotate 22.5 - , roundedRect 7.5 10 5 |> filled shapeclrs |> move ( 0, 7.5 ) - , circle 3 |> filled shapeclrs |> move ( 0, -2.5 ) - ] - - -errorMenu : Error -> Machine -> Float -> Float -> Shape msg -errorMenu err mac winX winY = - let - errStId = - case err of - DFAError _ stId -> - case Dict.get stId mac.stateNames of - Just name -> - name - - Nothing -> - "" - - _ -> - "" - - errorHeader txt = - group - [ errorIcon red white - , text txt - |> size 20 - |> fixedwidth - |> filled darkRed - |> move ( 20, 0 ) - ] - |> scale 0.75 - |> move ( 0, -20 ) - - errorReason = - group - [ circle 3 |> filled red - , (text <| - case err of - DFAError HasEpsilon _ -> - "Possible cause: There are epsilon transitions" - - DFAError Incomplete _ -> - "Possible cause: There are missing transitions" - - DFAError Nondeterministic _ -> - "Possible cause: There are extraneous transitions" - - EpsTransError -> - "Cause: Epsilon transitions are mixed with normal transitions" - - _ -> - "You might have missed something somewhere?" - ) - |> size 12 - |> fixedwidth - |> filled darkRed - |> move ( 15, -5 ) - ] - |> move ( 0, -40 ) - - errorHint = - group - [ circle 3 |> filled red - , (text <| - case err of - DFAError HasEpsilon _ -> - "Hint: Try removing all your epsilon transitions" - - DFAError Incomplete _ -> - "Hint: Check states for missing transitions" - - DFAError Nondeterministic _ -> - "Hint: Find and remove extra transitions" - - EpsTransError -> - "Hint: Switch to Build mode and fix transitions in red" - - _ -> - "" - ) - |> size 12 - |> fixedwidth - |> filled darkRed - |> move ( 15, -5 ) - ] - |> move ( 0, -60 ) - - errorState = - group - [ circle 3 |> filled red - , text "Hint: Check state " - |> size 12 - |> fixedwidth - |> filled darkRed - |> move ( 15, -5 ) - , latex 50 12 "blank" errStId AlignLeft |> move ( 150, 3 ) - ] - |> move ( 0, -80 ) - - actionHint = - group - [ circle 3 |> filled red - , text "Go to Build mode to fix your machine, or use a NFA" - |> size 12 - |> fixedwidth - |> filled darkRed - |> move ( 15, -5 ) - ] - |> move ( 0, -100 ) - in - case err of - DFAError _ _ -> - group [ errorHeader "DFA error: Your machine has a problem!", errorReason, errorHint, errorState, actionHint ] - - EpsTransError -> - group [ errorHeader "Error: You have invalid state transitions!", errorReason, errorHint ] - - NoError -> - group [] - - -- TODO: Add error handling for duplicate state names - DuplicateStates _ -> - group [] diff --git a/src/Exporting.elm b/src/Exporting.elm deleted file mode 100644 index 97d05e8..0000000 --- a/src/Exporting.elm +++ /dev/null @@ -1,555 +0,0 @@ -module Exporting exposing (InputTape, Model(..), Msg(..), Output(..), PersistentModel, exportButton, exportTikz, generateTikz, indtBy, initPModel, onEnter, onExit, output, subscriptions, unlines, update, view) - -import Array exposing (Array) -import Browser.Events -import Dict exposing (Dict) -import Environment exposing (Environment) -import Error exposing (..) -import GraphicSVG exposing (..) -import Helpers exposing (..) -import Html as H -import Html.Attributes as A -import Json.Decode as D -import Machine exposing (..) -import Mistakes exposing (..) -import Set exposing (Set) -import Sha256 exposing (sha256) -import SharedModel exposing (..) -import Task -import Time exposing (Month(..), customZone, millisToPosix, toDay, toHour, toMinute, toMonth, toSecond, toYear) -import Tuple exposing (first, second) - - -subscriptions : Model -> Sub Msg -subscriptions model = - Sub.none - - -type alias PersistentModel = - { outputType : Output - , time : Int - } - - -type alias InputTape = - Array Character - - -type Model - = Default - | HoverError - | ShowingOutput - - -type Output - = Tikz - - -type Msg - = SelectOutput Output - | GenerateOutput - | CloseOutput - | MachineMsg Machine.Msg - | GetTime Int - | HoverErrorEnter - | HoverErrorExit - - -onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) -onEnter env ( pModel, sModel ) = - ( ( Default, pModel, sModel ), False, Cmd.none ) - - -onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) -onExit env ( model, pModel, sModel ) = - ( ( pModel, sModel ), False ) - - -initPModel : PersistentModel -initPModel = - { outputType = Tikz - , time = 0 - } - - -update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) -update env msg ( model, pModel, sModel ) = - let - machine = - sModel.machine - in - case msg of - SelectOutput outputType -> - ( ( model, { pModel | outputType = outputType }, sModel ), False, Cmd.none ) - - GenerateOutput -> - ( ( ShowingOutput, pModel, sModel ), False, Task.perform (GetTime << Time.posixToMillis) Time.now ) - - CloseOutput -> - ( ( Default, pModel, sModel ), False, Cmd.none ) - - MachineMsg mmsg -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - GetTime t -> - ( ( model, { pModel | time = t }, sModel ), False, Cmd.none ) - - HoverErrorEnter -> - ( ( HoverError, pModel, sModel ), False, Cmd.none ) - - HoverErrorExit -> - ( ( Default, pModel, sModel ), False, Cmd.none ) - - -view : Environment -> ( Model, PersistentModel, SharedModel ) -> Shape Msg -view env ( model, pModel, sModel ) = - let - oldMachine = - sModel.machine - - winX = - toFloat <| first env.windowSize - - winY = - toFloat <| second env.windowSize - - menu = - group <| - [] - - errCheck = - machineCheck sModel - - hasErr = - contextHasError errCheck sModel.machineType - - transMistakes = - getTransitionMistakes oldMachine - - -- TODO: Adjust popup box size to fix custom error messages - errHover = - group - [ errorIcon red white - , if model == HoverError then - group [ roundedRect 465 110 5 |> filled darkGrey |> move ( 215, -55 ), errorMenu errCheck sModel.machine winX winY ] - - else - group [] - ] - |> notifyEnter HoverErrorEnter - |> notifyLeave HoverErrorExit - |> move ( winX / 6 - 100, -105 ) - in - group - [ (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine Set.empty transMistakes) |> move ( -winX / 6, 0 ) - , machineSelected sModel.machineType winX winY - , text "Choose format:" - |> size 20 - |> fixedwidth - |> filled black - |> move ( winX / 6 - 125, 80 ) - , exportTikz (pModel.outputType == Tikz) |> move ( winX / 6, 0 ) - , exportButton (not hasErr) - |> move ( winX / 6, -100 ) - |> (if hasErr then - identity - - else - notifyTap GenerateOutput - ) - , if hasErr then - errHover - - else - group [] - , case ( model, pModel.outputType ) of - ( ShowingOutput, Tikz ) -> - output (winX / 2) (winY / 2) (generateTikz pModel.time sModel.machine) - - _ -> - group [] - ] - - -machineSelected : MachineType -> Float -> Float -> Shape Msg -machineSelected mtype winX winY = - let - mtypeStr = - case mtype of - DFA -> - "DFA" - - NFA -> - "NFA" - in - text ("Your exported machine type: " ++ mtypeStr) - |> centered - |> fixedwidth - |> filled darkGray - |> move ( -winX / 2 + 117, winY / 2 - 32 ) - - -exportTikz : Bool -> Shape Msg -exportTikz selected = - group - [ roundedRect 250 75 5 - |> outlined (solid 2) darkGray - , text "TikZ" - |> size 20 - |> fixedwidth - |> filled black - |> move ( -50, 7.5 ) - , roundedRect 30 15 2 - |> filled finsmBlue - |> move ( 20, 12.5 ) - , text "Beta" - |> fixedwidth - |> size 10 - |> centered - |> filled white - |> move ( 20, 9.5 ) - , text "Export code to include" - |> size 12 - |> fixedwidth - |> filled black - |> move ( -50, -10 ) - , text "in a LaTeX document" - |> size 12 - |> fixedwidth - |> filled black - |> move ( -50, -22.5 ) - , circle 10 - |> outlined (solid 1) gray - |> move ( -90, 0 ) - , circle 8 - |> filled finsmBlue - |> move ( -90, 0 ) - ] - - -exportButton clickable = - group - [ roundedRect 130 40 5 - |> filled - (if clickable then - finsmBlue - - else - gray - ) - , text "Export" - |> fixedwidth - |> size 24 - |> centered - |> filled - (if clickable then - white - - else - darkGray - ) - |> move ( 0, -7 ) - ] - - -output w h txt = - group - [ roundedRect (w + 20) (h + 20) 5 - |> filled white - |> addOutline (solid 1) gray - , text "Select all and copy this code into your favourite LaTeX editor" - |> fixedwidth - |> size 8 - |> filled black - |> move ( -w / 2, h / 2 - 5 ) - , (html w (h - 10) <| - H.div - [ A.style "width" "100%" - , A.style "height" "100%" - , A.style "padding" "2px" - , A.style "padding-right" "4px" - ] - [ H.textarea - [ A.value txt - , A.style "width" "99%" - , A.style "height" "98%" - , A.style "border" "none" - , A.style "resize" "none" - , A.style "border-radius" "2px" - , A.style "position" "fixed" - , A.readonly True - ] - [] - ] - ) - |> move ( -w / 2, h / 2 - 12.5 ) - , group - [ circle 10 - |> filled white - |> addOutline (solid 2) gray - , roundedRect 10 3 1.5 |> filled gray - , roundedRect 3 10 1.5 |> filled gray - ] - |> rotate (degrees 45) - |> notifyTap CloseOutput - |> move ( w / 2 - 5, h / 2 - 5 ) - ] - - -generateTikz : Int -> Machine -> String -generateTikz time machine = - let - scale = - 40 - - states = - indtBy 4 <| - List.map oneState <| - Dict.toList machine.statePositions - - stateName sId = - case Dict.get sId machine.stateNames of - Just n -> - n - - _ -> - "" - - statePos sId = - case Dict.get sId machine.statePositions of - Just p -> - p - - _ -> - ( 0, 0 ) - - dateStr = - timeToString time - - hashCode = - String.dropRight 56 << sha256 << String.append dateStr - - oneState ( sId, ( x, y ) ) = - let - ( tx, ty ) = - ( String.fromFloat <| x / scale, String.fromFloat <| y / scale ) - - start = - if Set.member sId machine.start then - "initial,thick," - - else - "thick," - - --"initial,thick," else "thick," -- - final = - if Set.member sId machine.final then - "accepting," - - else - "" - in - String.concat [ "\\node[", start, final, "state] at (", tx, ",", ty, ") (", hashCode <| stateName sId, ") {$", stateName sId, "$};" ] - - transitions = - indtBy 4 <| - List.map oneTransition <| - Dict.toList machine.stateTransitions - - oneTransition ( ( s0, tId, s1 ), ( x1, y1 ) ) = - let - transitionName = - case Dict.get tId machine.transitionNames of - Just n -> - renderSet2String n - - _ -> - "" - - ( x0, y0 ) = - statePos s0 - - ( x2, y2 ) = - statePos s1 - - ( mx, my ) = - ( (x2 + x0) / 2 + rx, (y2 + y0) / 2 + ry ) - - ( tx, ty ) = - --tangent between to and from states - ( x2 - x0, y2 - y0 ) - - r = - 20 - - -- radius of states - theta = - atan2 ty tx - - ( rx, ry ) = - ( x1 * cos theta - y1 * sin theta, y1 * cos theta + x1 * sin theta ) - - ( inTheta, outTheta ) = - if s0 == s1 then - let - mr = - sqrt ((mx - x0) ^ 2 + (my - y0) ^ 2) - - mpl = - mr - r - - beta = - atan2 ry rx - - gamma = - atan2 mpl mr - in - ( round <| (beta + gamma) * 180 / pi, round <| (beta - gamma) * 180 / pi ) - - else - ( round <| atan2 (my - y2) (mx - x2) * 180 / pi - , round <| atan2 (my - y0) (mx - x0) * 180 / pi - ) - - position = - case labelPosition y1 theta of - Above -> - "above" - - Below -> - "below" - - Left -> - "left" - - Right -> - "right" - - loop = - if s0 == s1 then - let - loopDistance = - String.fromFloat <| roundPrec 2 <| sqrt (x1 ^ 2 + y1 ^ 2) / 40 - in - String.concat [ "loop,min distance = ", loopDistance, "cm," ] - - else - "" - in - String.concat [ "(", hashCode <| stateName s0, ") edge [", loop, position, ",in = ", String.fromInt inTheta, ", out = ", String.fromInt outTheta, "] node {$", transitionName, "$} (", hashCode <| stateName s1, ")" ] - in - unlines - [ "%% Machine generated by https://finsm.io" - , String.concat [ "%% ", dateStr ] - , "%% include in preamble:" - , "%% \\usepackage{tikz}" - , "%% \\usetikzlibrary{automata,positioning,arrows}" - , "\\begin{center}" - , "\\begin{tikzpicture}[]" - , states - , " \\path[->, thick, >=stealth]" - , transitions - , " ;" - , "\\end{tikzpicture}" - , "\\end{center}" - ] - - -est = - customZone (-5 * 60) [] - - -monthToInt : Month -> Int -monthToInt month = - case month of - Jan -> - 1 - - Feb -> - 2 - - Mar -> - 3 - - Apr -> - 4 - - May -> - 5 - - Jun -> - 6 - - Jul -> - 7 - - Aug -> - 8 - - Sep -> - 9 - - Oct -> - 10 - - Nov -> - 11 - - Dec -> - 12 - - -timeToString : Int -> String -timeToString timestamp = - let - year = - toYear est (millisToPosix timestamp) - - month = - toMonth est (millisToPosix timestamp) - - day = - toDay est (millisToPosix timestamp) - - hour = - toHour est (millisToPosix timestamp) - - minute = - toMinute est (millisToPosix timestamp) - - second = - toSecond est (millisToPosix timestamp) - in - String.fromInt year - ++ "-" - ++ String.fromInt (monthToInt month) - ++ "-" - ++ String.fromInt day - ++ "-" - ++ String.fromInt hour - ++ ":" - ++ (if minute < 10 then - "0" - - else - "" - ) - ++ String.fromInt minute - ++ ":" - ++ (if minute < 10 then - "0" - - else - "" - ) - ++ String.fromInt second - - -unlines : List String -> String -unlines = - String.concat << List.intersperse "\n" - - -indtBy : Int -> List String -> String -indtBy n = - unlines << List.map ((++) (String.repeat n " ")) diff --git a/src/Helpers.elm b/src/Helpers.elm deleted file mode 100644 index 95deb14..0000000 --- a/src/Helpers.elm +++ /dev/null @@ -1,333 +0,0 @@ -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) - -import Browser.Dom as Dom -import GraphicSVG exposing (..) -import Html as H exposing (Html, input, node) -import Html.Attributes exposing (attribute, placeholder, style, value) -import Html.Events exposing (onInput) -import Set exposing (Set) -import String exposing (..) -import Task -import Url exposing (Url, percentEncode) - - - --- import Parser exposing (..) -- Not working with Elm 0.19, switch when compatible - - -finsmBlue = - rgb 21 137 255 - - -finsmLightBlue = - rgb 112 190 255 - - -vertex ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) = - let - p0 = - ( x0, y0 ) - - p1 = - ( x1, y1 ) - - p2 = - ( x2, y2 ) - - p3 = - add p0 p2 - - t = - dot (sub p0 p1) (sub p3 (mult p1 2)) / (dot p3 p3 - 4 * dot p1 (sub p3 p1)) - in - p p0 p1 p2 t - - -p p0 p1 p2 t = - add (mult p0 ((1 - t) ^ 2)) (add (mult (mult (mult p1 t) (1 - t)) 2) (mult p2 (t ^ 2))) - - -add ( x0, y0 ) ( x1, y1 ) = - ( x0 + x1, y0 + y1 ) - - -mult ( x, y ) s = - ( x * s, y * s ) - - -sub ( x0, y0 ) ( x1, y1 ) = - ( x0 - x1, y0 - y1 ) - - -dot ( x0, y0 ) ( x1, y1 ) = - x0 * x1 + y0 * y1 - - -editIcon = - group - [ --square 5 |> outlined (solid 1) black - rect 5 2 - |> filled (rgb 21 137 255) - |> rotate (degrees 45) - |> move ( 3, 3 ) - , triangle 1 - |> filled blue - |> rotate (degrees -15) - ] - - -trashIcon = - group - [ roundedRect 30 40 3 - |> outlined (solid 4) black - , rect 42 5 |> filled black |> move ( 0, 19.5 ) - , roundedRect 36 5 1 |> filled black |> move ( 0, 21.5 ) - , roundedRect 10 10 1 |> outlined (solid 3) black |> move ( 0, 23.5 ) - , rect 4 30 |> filled black - , rect 4 30 |> filled black |> move ( -8, 0 ) - , rect 4 30 |> filled black |> move ( 8, 0 ) - ] - - -type LatexAlign - = AlignLeft - | AlignRight - | AlignCentre - - -latex w h backclr txt align = - --image (latexurl txt) - -- |> move - -- ( case align of - -- AlignLeft -> - -- 0 - -- - -- AlignRight -> - -- -w - -- - -- AlignCentre -> - -- -w / 2 - -- , 0 - -- ) - (html w h <| - H.div - [ style "width" "100%" - , style "height" "100%" - , style "-moz-user-select" "none" - , style "-webkit-user-select" "none" - , style "-user-select" "none" - - -- , style "background-color" "red" - ] - [ H.img - ([ style "background-color" backclr - , Html.Attributes.attribute "onerror" ("this.src='" ++ latexurl "\\LaTeX?" ++ "'") - , Html.Attributes.src (latexurl txt) - - --, style "width" "100%" - , style "height" "100%" - ] - ++ (case align of - AlignCentre -> - [ style "margin-left" "auto" - , style "margin-right" "auto" - ] - - AlignLeft -> - [ style "margin-right" "auto" - ] - - AlignRight -> - [ style "margin-left" "auto" - ] - ) - ++ [ style "display" "block" - , style "max-width" "100%" - ] - ) - [] - ] - ) - |> move - ( case align of - AlignLeft -> - 0 - - AlignRight -> - -w - - AlignCentre -> - -w / 2 - , 0 - ) - - -latexurl : String -> String -latexurl lx = - "https://finsm.io/latex/render/" ++ percentEncode lx - - -setMax : Set Int -> Int -setMax s = - Set.foldl max 0 s - - -sendMsg : msg -> Cmd msg -sendMsg msg = - Task.perform identity (Task.succeed msg) - - -focusInput : msg -> Cmd msg -focusInput msg = - Task.attempt (\_ -> msg) (Dom.focus "input") - - -icon : Bool -> Shape msg -> Shape msg -icon on sh = - group - [ circle 18 - |> filled - (if on then - finsmBlue - - else - white - ) - |> addOutline (solid 1) (rgb 220 220 220) - , sh - ] - - - --- Custom parsing for multiple state labels --- We treat ',' as a special delimiter for labels, and whitespace is ignored. --- To get ',' or ' ', they have to be placed inside delimiting parenthesis, --- which then becomes "{,}" and "{ }" - - -specialSymbols = - [ [ '{', ',', '}' ], [ '{', ' ', '}' ] ] - - -parseTLabel : String -> List String -parseTLabel s = - let - lst = - String.toList s - - collect : List Char -> List Char -> List (List Char) -> List (List Char) - collect input xs xxs = - case input of - [] -> - List.reverse xs :: xxs - - y :: ys -> - let - hasSpecial = - y :: List.take 2 ys - - check = - List.member hasSpecial specialSymbols - in - if check then - collect (List.drop 2 ys) [] <| hasSpecial :: xxs - - else if y == ',' then - collect ys [] (List.reverse xs :: xxs) - - else if y == ' ' then - collect ys xs xxs - - else - collect ys (y :: xs) xxs - - parsedString = - collect lst [] [] |> List.map String.fromList - in - parsedString |> List.map trim |> List.filter (\s1 -> s1 /= "") - - -parseString2Set : String -> Set String -parseString2Set = - parseTLabel >> Set.fromList - - -renderString : List String -> String -renderString = - String.join "," - - -renderSet2String : Set String -> String -renderSet2String = - Set.toList >> renderString - - -uncurry : (a -> b -> c) -> ( a, b ) -> c -uncurry f ( a, b ) = - f a b - - -type LabelPosition - = Above - | Below - | Left - | Right - - -labelPosition : Float -> Float -> LabelPosition -labelPosition y1 theta = - let - thetaF = - if theta < 0 then - 2 * pi - abs theta - - else - theta - in - if 0 <= thetaF && thetaF <= pi / 32 then - if y1 > 0 then - Above - - else - Below - - else if pi / 32 < thetaF && thetaF <= 31 * pi / 32 then - if y1 > 0 then - Left - - else - Right - - else if 31 * pi / 32 < thetaF && thetaF <= 33 * pi / 32 then - if y1 > 0 then - Below - - else - Above - - else if 33 * pi / 32 < thetaF && thetaF <= 63 * pi / 32 then - if y1 > 0 then - Right - - else - Left - - else if 63 * pi / 32 < thetaF then - if y1 > 0 then - Above - - else - Below - - else - Above - - -roundTo : Float -> Float -> Float -roundTo n m = - Basics.toFloat (round (m + n / 2) // round n * round n) - - -roundPrec : Int -> Float -> Float -roundPrec n m = - Basics.toFloat (round (m * Basics.toFloat (10 ^ n))) / Basics.toFloat (10 ^ n) diff --git a/src/Machine.elm b/src/Machine.elm deleted file mode 100644 index 2108c26..0000000 --- a/src/Machine.elm +++ /dev/null @@ -1,853 +0,0 @@ -module Machine exposing (..) - -import Dict exposing (Dict) -import Environment exposing (Environment) -import GraphicSVG exposing (..) -import Helpers exposing (..) -import Html as H exposing (Html, input, node) -import Html.Attributes exposing (attribute, id, placeholder, style, value) -import Html.Events exposing (onInput) -import Json.Decode as D -import Json.Encode as E -import Set exposing (Set) -import Utils exposing (decodeDict, decodePair, decodeSet, decodeTriple, encodeDict, encodePair, encodeSet, encodeTriple, textBox) - - -type alias StateID = - Int - - -type alias StatePositions = - Dict StateID ( Float, Float ) - - -type alias TransitionID = - Int - - -type alias StateNames = - Dict StateID String - - -type alias TransitionNames = - Dict TransitionID (Set String) - - -type alias StateTransitions = - Dict ( StateID, TransitionID, StateID ) ( Float, Float ) - - -type alias Delta = - Dict StateID (Dict TransitionID StateID) - - -type alias Character = - String - - -type alias TransitionMistakes = - Maybe (Set TransitionID) - - -machineEncoder : Machine -> E.Value -machineEncoder = - machineEncoderV1 - - -machineEncoderV1 : Machine -> E.Value -machineEncoderV1 machine = - let - transTriple = - decodeTriple D.int D.int D.int - - qEncoder : Set StateID -> E.Value - qEncoder = - encodeSet E.int - - deltaEncoder : Delta -> E.Value - deltaEncoder = - encodeDict E.int (encodeDict E.int E.int) - - startEncoder : Set StateID -> E.Value - startEncoder = - encodeSet E.int - - finalEncoder : Set StateID -> E.Value - finalEncoder = - encodeSet E.int - - statePosEncoder : StatePositions -> E.Value - statePosEncoder = - encodeDict E.int (encodePair E.float E.float) - - transPosEncoder : StateTransitions -> E.Value - transPosEncoder = - encodeDict (encodeTriple E.int E.int E.int) (encodePair E.float E.float) - - stateNamesEncoder : StateNames -> E.Value - stateNamesEncoder = - encodeDict E.int E.string - - transNamesEncoder : TransitionNames -> E.Value - transNamesEncoder = - encodeDict E.int (encodeSet E.string) - in - E.object - [ ( "q", qEncoder machine.q ) - , ( "delta", deltaEncoder machine.delta ) - , ( "start", startEncoder machine.start ) - , ( "final", finalEncoder machine.final ) - , ( "statePositions", statePosEncoder machine.statePositions ) - , ( "transPositions", transPosEncoder machine.stateTransitions ) - , ( "stateNames", stateNamesEncoder machine.stateNames ) - , ( "transNames", transNamesEncoder machine.transitionNames ) - , ( "v", E.int 1 ) - ] - - -machineDecoder : D.Decoder Machine -machineDecoder = - D.field "v" D.int - |> D.andThen - (\v -> - case v of - 1 -> - machineDecoderV1 - - _ -> - D.fail <| "Invalid save metadata version " ++ String.fromInt v - ) - - -machineDecoderV1 : D.Decoder Machine -machineDecoderV1 = - let - transTriple = - decodeTriple D.int D.int D.int - - qDecoder : D.Decoder (Set StateID) - qDecoder = - D.field "q" <| decodeSet D.int - - deltaDecoder : D.Decoder Delta - deltaDecoder = - D.field "delta" <| decodeDict D.int (decodeDict D.int D.int) - - startDecoder : D.Decoder (Set StateID) - startDecoder = - D.field "start" <| decodeSet D.int - - finalDecoder : D.Decoder (Set StateID) - finalDecoder = - D.field "final" <| decodeSet D.int - - statePosDecoder : D.Decoder StatePositions - statePosDecoder = - D.field "statePositions" <| decodeDict D.int (decodePair D.float D.float) - - transPosDecoder : D.Decoder StateTransitions - transPosDecoder = - D.field "transPositions" <| decodeDict transTriple (decodePair D.float D.float) - - stateNamesDecoder : D.Decoder StateNames - stateNamesDecoder = - D.field "stateNames" <| decodeDict D.int D.string - - transNamesDecoder : D.Decoder TransitionNames - transNamesDecoder = - D.field "transNames" <| decodeDict D.int (decodeSet D.string) - in - D.map8 Machine - qDecoder - deltaDecoder - startDecoder - finalDecoder - statePosDecoder - transPosDecoder - stateNamesDecoder - transNamesDecoder - - -type alias Machine = - { q : Set StateID - , delta : Delta - , start : Set StateID - , final : Set StateID - , statePositions : StatePositions - , stateTransitions : StateTransitions - , stateNames : StateNames - , transitionNames : TransitionNames - } - - -type Model - = Regular - | DraggingState StateID ( Float, Float ) ( Float, Float ) - | SelectedState StateID - | MousingOverRim StateID ( Float, Float ) - | AddingArrow StateID ( Float, Float ) - | AddingArrowOverOtherState StateID ( Float, Float ) StateID - | MousingOverStateLabel StateID - | MousingOverTransitionLabel TransitionID - | EditingStateLabel StateID String - | EditingTransitionLabel ( StateID, TransitionID, StateID ) String - | SelectedArrow ( StateID, TransitionID, StateID ) - | DraggingArrow ( StateID, TransitionID, StateID ) ( Float, Float ) - | CreatingNewArrow StateID - - -type Msg - = StartDragging StateID ( Float, Float ) - | StartDraggingArrow ( StateID, TransitionID, StateID ) ( Float, Float ) - | StartMouseOverRim StateID ( Float, Float ) - | MoveMouseOverRim ( Float, Float ) - | StopMouseOverRim - | SelectArrow ( StateID, TransitionID, StateID ) - | MouseOverStateLabel StateID - | MouseOverTransitionLabel TransitionID - | MouseLeaveLabel - | EditLabel StateID String - | Drag ( Float, Float ) - | TapState StateID - | StopDragging - | Reset - - -test : Machine -test = - let - q = - Set.fromList [ 0, 1, 2, 3 ] - - delta0 = - Dict.fromList - [ ( 0, Dict.fromList [ ( 0, 1 ), ( 1, 2 ) ] ) - , ( 1, Dict.fromList [ ( 2, 0 ), ( 3, 3 ) ] ) - , ( 2, Dict.fromList [ ( 4, 3 ), ( 5, 0 ) ] ) - , ( 3, Dict.fromList [ ( 6, 2 ), ( 7, 1 ) ] ) - ] - - start = - Set.fromList [ 0 ] - - final = - Set.fromList [ 0 ] - - statePositions = - Dict.fromList [ ( 0, ( -50, 50 ) ), ( 1, ( 50, 50 ) ), ( 2, ( -50, -50 ) ), ( 3, ( 50, -50 ) ) ] - - stateNames = - Dict.fromList [ ( 0, "q_0" ), ( 1, "q_1" ), ( 2, "q_2" ), ( 3, "q_3" ) ] - - transitionNames = - 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" ) ] - - stateTransitions = - Dict.fromList - [ ( ( 0, 0, 1 ), ( 0, 10 ) ) - , ( ( 1, 2, 0 ), ( 0, 10 ) ) - , ( ( 0, 1, 2 ), ( 0, 10 ) ) - , ( ( 2, 5, 0 ), ( 0, 10 ) ) - , ( ( 2, 4, 3 ), ( 0, 10 ) ) - , ( ( 3, 6, 2 ), ( 0, 10 ) ) - , ( ( 1, 3, 3 ), ( 0, 10 ) ) - , ( ( 3, 7, 1 ), ( 0, 10 ) ) - ] - in - Machine q delta0 start final statePositions stateTransitions stateNames transitionNames - - -view : Environment -> Model -> Machine -> Set StateID -> TransitionMistakes -> Shape Msg -view env model machine currentStates tMistakes = - let - ( winX, winY ) = - env.windowSize - - dragRegion = - rect (toFloat winX) (toFloat winY) - |> filled blank - |> notifyMouseMoveAt Drag - |> notifyMouseUp StopDragging - in - group - [ renderArrows machine model tMistakes - , renderStates currentStates machine model env - , case model of - AddingArrow s ( x, y ) -> - let - s0Pos = - case Dict.get s machine.statePositions of - Just pos -> - pos - - _ -> - ( 0, 0 ) - - newTrans = - case List.head <| Dict.values machine.transitionNames of - Just schar -> - Set.toList schar |> renderString - - Nothing -> - " " - - newTransID = - case List.head <| Dict.keys machine.transitionNames of - Just char -> - char - - Nothing -> - 0 - in - renderArrow s0Pos ( 0, 0 ) ( x, y ) 20 0 newTrans newTransID False False s -1 model - - AddingArrowOverOtherState s ( x, y ) s1 -> - let - s0Pos = - case Dict.get s machine.statePositions of - Just pos -> - pos - - _ -> - ( 0, 0 ) - - s1Pos = - case Dict.get s1 machine.statePositions of - Just pos -> - pos - - _ -> - ( 0, 0 ) - - newTrans = - case List.head <| Dict.values machine.transitionNames of - Just schar -> - Set.toList schar |> renderString - - Nothing -> - " " - - newTransID = - case List.head <| Dict.keys machine.transitionNames of - Just char -> - char - - Nothing -> - 0 - - pullPos = - if s == s1 then - ( 0, 50 ) - - else - ( 0, 0 ) - in - renderArrow s0Pos pullPos s1Pos 20 20 newTrans newTransID False False s s1 model - - _ -> - group [] - , case model of - DraggingState _ _ _ -> - dragRegion - - DraggingArrow _ _ -> - dragRegion - - AddingArrow _ _ -> - dragRegion - - AddingArrowOverOtherState _ _ _ -> - dragRegion - - _ -> - group [] - ] - - - ---These two functions will eventually become part of GraphicSVG in some form - - -arrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) = - let - ( dx, dy ) = - ( x2 - x1, y2 - y1 ) - in - group - [ curve ( x0, y0 ) - [ Pull ( x1, y1 ) - ( x2 - 2 * cos (atan2 dy dx) - , y2 - 2 * sin (atan2 dy dx) - ) - ] - |> outlined (solid 1) black - , triangle 4 - |> filled black - |> rotate (atan2 dy dx) - |> move ( x2 - 4 * cos (atan2 dy dx), y2 - 4 * sin (atan2 dy dx) ) - ] - - -renderArrow : - ( Float, Float ) - -> ( Float, Float ) - -> ( Float, Float ) - -> Float - -> Float - -> Character - -> TransitionID - -> Bool - -> Bool - -> StateID - -> StateID - -> Model - -> Shape Msg -renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) r0 r1 char charID sel mistake s1 s2 model = - let - ( tx, ty ) = - --tangent between to and from states - ( x2 - x0, y2 - y0 ) - - theta = - atan2 ty tx - - ( rx, ry ) = - ( x1 * cos theta - y1 * sin theta, y1 * cos theta + x1 * sin theta ) - - ( mx, my ) = - --pull point - ( (x2 + x0) / 2 + rx, (y2 + y0) / 2 + ry ) - - ( dx0, dy0 ) = - --tangent from middle point to from state - ( mx - x0, my - y0 ) - - ( dx1, dy1 ) = - --tangent from middle point to to state - ( mx - x2, my - y2 ) - - ( xx0, yy0 ) = - --from state position (with radius accounted for) - if s1 == s2 then - ( x0 + r0 * cos (atan2 dy0 dx0 + degrees 45), y0 + r0 * sin (atan2 dy0 dx0 + degrees 45) ) - - else - ( x0 + r0 * cos (atan2 dy0 dx0), y0 + r0 * sin (atan2 dy0 dx0) ) - - ( xx1, yy1 ) = - --to state position (with radius accounted for) - if s1 == s2 then - ( x0 + r0 * cos (atan2 dy0 dx0 - degrees 45), y0 + r0 * sin (atan2 dy0 dx0 - degrees 45) ) - - else - ( x2 + r1 * cos (atan2 dy1 dx1), y2 + r1 * sin (atan2 dy1 dx1) ) - - tLblW = - 200 - - off = - if y1 > 0 then - 8 - - else - -8 - - offset = - ( -off * sin theta - , off * cos theta - ) - - alignment = - case labelPosition y1 theta of - Above -> - AlignCentre - - Below -> - AlignCentre - - Left -> - AlignRight - - Right -> - AlignLeft - in - group - [ group - [ if s1 == s2 then - let - mr = - sqrt ((mx - x0) ^ 2 + (my - y0) ^ 2) - - mpl = - mr - r0 - - ppr = - sqrt (mr ^ 2 + mpl ^ 2) - - beta = - atan2 ry rx - - gamma = - atan2 mpl mr - - ( x0s, y0s ) = - ( x0 + r0 * cos (beta - gamma), y0 + r0 * sin (beta - gamma) ) - - ( x1s, y1s ) = - ( x0 + r0 * cos (beta + gamma), y0 + r0 * sin (beta + gamma) ) - in - group - [ curve ( x0s, y0s ) [ Pull ( x0 + ppr * cos (beta - gamma), y0 + ppr * sin (beta - gamma) ) ( mx, my ) ] - |> outlined (solid 1) black - , arrow ( mx, my ) ( x0 + ppr * cos (beta + gamma), y0 + ppr * sin (beta + gamma) ) ( x1s, y1s ) - ] - |> notifyMouseDown (SelectArrow ( s1, charID, s2 )) - - else - arrow ( xx0, yy0 ) ( mx, my ) ( xx1, yy1 ) - |> notifyMouseDown (SelectArrow ( s1, charID, s2 )) - , group - [ case model of - EditingTransitionLabel ( _, tId, _ ) str -> - if tId == charID then - textBox str - (if String.length str == 0 then - 40 - - else - 8 * toFloat (String.length str) + 5 - ) - 20 - "LaTeX" - (EditLabel tId) - - else - latex tLblW - 12 - (if mistake then - "LightSalmon" - - else - "none" - ) - char - alignment - - _ -> - latex tLblW - 12 - (if mistake then - "LightSalmon" - - else - "none" - ) - char - alignment - , case model of - EditingTransitionLabel tId str -> - group [] - - _ -> - rect 50 20 - |> filled blank - |> notifyTap (SelectArrow ( s1, charID, s2 )) - ] - |> (if s1 /= s2 then - move ( 0, 7 ) - >> move (p ( xx0, yy0 ) ( mx, my ) ( xx1, yy1 ) 0.5) - >> move offset - - else - move ( mx, my + 12 ) - ) - |> notifyLeave MouseLeaveLabel - ] - , if sel then - group - [ if s1 /= s2 then - line ( xx0, yy0 ) ( mx, my ) |> outlined (dotted 1) black - - else - group [] - , if s1 /= s2 then - line ( xx1, yy1 ) ( mx, my ) |> outlined (dotted 1) black - - else - group [] - , circle 3 - |> filled finsmBlue - |> move ( mx, my ) - |> notifyMouseDownAt (StartDraggingArrow ( s1, charID, s2 )) - |> notifyMouseMoveAt Drag - ] - - else - group [] - ] - - -renderArrows : Machine -> Model -> TransitionMistakes -> Shape Msg -renderArrows machine model tMistakes = - let - states = - machine.q - - pos = - machine.statePositions - - delta = - machine.delta - - transPos = - machine.stateTransitions - - stateList = - Set.toList states - - edgeToList state = - Dict.toList - (case Dict.get state delta of - Just d -> - d - - Nothing -> - Dict.empty - ) - - getPos state = - case Dict.get state pos of - Just ( x, y ) -> - ( x, y ) - - Nothing -> - ( 0, 0 ) - - getTransPos ( s1, char, s2 ) = - case Dict.get ( s1, char, s2 ) transPos of - Just ( x, y ) -> - ( x, y ) - - Nothing -> - ( 0, 0 ) - in - group <| - List.map - (\s1 -> - group - (List.concat - (List.map - (\( chId, ss ) -> - List.map - (\s2 -> - let - ( x0, y0 ) = - getPos s1 - - ( x1, y1 ) = - getTransPos ( s1, chId, s2 ) - - ( x2, y2 ) = - getPos s2 - - ch = - case Dict.get chId machine.transitionNames of - Just setc -> - Set.toList setc |> renderString - - _ -> - "" - - sel = - case model of - SelectedArrow ( ss1, char, ss2 ) -> - char == chId - - DraggingArrow ( ss1, char, ss2 ) _ -> - char == chId - - _ -> - False - - -- Transition mistake function - getTransMistake : TransitionMistakes -> TransitionID -> Bool - getTransMistake transMistakes tId = - case transMistakes of - Nothing -> - False - - Just setOfMistakes -> - Set.member tId setOfMistakes - - mistake = - getTransMistake tMistakes chId - in - group - [ renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) 20 20 ch chId sel mistake s1 s2 model - ] - ) - [ ss ] - ) - (edgeToList s1) - ) - ) - ) - stateList - - -renderStates : Set StateID -> Machine -> Model -> Environment -> Shape Msg -renderStates currentStates machine model env = - let - states = - machine.q - - pos = - machine.statePositions - - finals = - machine.final - - stateList = - Set.toList states - - getPos state = - case Dict.get state pos of - Just ( x, y ) -> - ( x, y ) - - Nothing -> - ( 0, 0 ) - - thickness state = - if Set.member state currentStates then - 2 - - else - 1 - - stateName sId = - case Dict.get sId machine.stateNames of - Just n -> - n - - _ -> - "" - - startArrow = - group - [ arrow ( -15, 0 ) ( -5, 0 ) ( 0, 0 ) - , latex 25 18 "none" "\\text{start}" AlignRight |> move ( -16, 9 ) - ] - |> move ( -20, 0 ) - in - group <| - List.map - (\sId -> - group - [ circle 21 - |> filled blank - |> notifyEnterAt (StartMouseOverRim sId) - |> notifyMouseMoveAt (StartMouseOverRim sId) - , circle 20 - |> filled blank - |> addOutline (solid (thickness sId)) black - |> notifyMouseDownAt (StartDragging sId) - , if Set.member sId finals then - circle 17 - |> outlined (solid (thickness sId)) black - - else - group [] - , case model of - EditingStateLabel st str -> - if st == sId then - textBox str - (if String.length str == 0 then - 40 - - else - 8 * toFloat (String.length str) + 5 - ) - 20 - "LaTeX" - (EditLabel sId) - - else - group - [ latex 25 18 "none" (stateName sId) AlignCentre - |> move ( 0, 9 ) - ] - - _ -> - group - [ latex 25 18 "none" (stateName sId) AlignCentre - |> move ( 0, 9 ) - ] - , case model of - SelectedState st -> - if st == sId then - circle 20.75 - |> outlined (solid 1.5) lightBlue - - else - group [] - - MousingOverRim st ( x, y ) -> - let - ( x0, y0 ) = - getPos st - - ( dx, dy ) = - ( x - x0, y - y0 ) - in - if st == sId then - group - [ circle 500 - |> filled blank - |> notifyEnter StopMouseOverRim - , group - [ circle 7 - |> filled white - |> addOutline (solid 0.5) black - , rect 8 1.5 |> filled black - , rect 1.5 8 |> filled black - ] - |> notifyMouseMoveAt MoveMouseOverRim - |> notifyLeave StopMouseOverRim - |> move ( 20 * cos (atan2 dy dx), 20 * sin (atan2 dy dx) ) - ] - - else - group [] - - AddingArrowOverOtherState _ _ st -> - if st == sId then - circle 21.5 - |> outlined (solid 3) finsmLightBlue - |> notifyLeave StopMouseOverRim - - else - group [] - - _ -> - group [] - , if Set.member sId machine.start then - startArrow - - else - group [] - ] - |> move (getPos sId) - |> (case model of - EditingStateLabel _ _ -> - identity - - _ -> - if not env.holdingShift then - notifyMouseDownAt (StartDragging sId) - - else - notifyTap (TapState sId) - ) - ) - stateList diff --git a/src/Main.elm b/src/Main.elm deleted file mode 100644 index 21f9aaf..0000000 --- a/src/Main.elm +++ /dev/null @@ -1,748 +0,0 @@ -module Main exposing (Model, Module(..), Msg(..), initAppModel, main, modeButtons, textHtml, update, view) - -import ApplicationModel exposing (ApplicationModel, ApplicationState(..)) -import Array exposing (Array) -import BetterUndoList exposing (..) -import Bootstrap.Modal as Modal -import Browser exposing (UrlRequest(..)) -import Browser.Dom -import Browser.Events exposing (Visibility) -import Building -import Dict exposing (Dict) -import Environment exposing (Environment) -import Exporting -import GraphicSVG exposing (..) -import Helpers exposing (finsmBlue, icon, sendMsg) -import Html as H exposing (Html, input, node) -import Html.Attributes -import Http -import Json.Decode as D -import Json.Encode -import List -import Machine exposing (..) -import Ports -import Random -import SaveLoad exposing (saveMachine) -import Set exposing (Set) -import SharedModel exposing (SharedModel) -import Simulating -import Task -import Time -import Tuple exposing (first, second) -import Url exposing (Url) - - -type Msg - = BMsg Building.Msg - | SMsg Simulating.Msg - | EMsg Exporting.Msg - | SaveMsg SaveLoad.Msg - | KeyPressed String - | KeyReleased String - | WindowSize ( Int, Int ) - | UrlChange Url - | UrlRequest UrlRequest - | GoTo Module - | VisibilityChanged Visibility - | GetTime Time.Posix - | GetTZ Time.Zone - | NoOp - - -type Module - = BuildingModule - | SimulatingModule - | ExportingModule - - -type alias Model = - { appModel : BetterUndoList ApplicationModel - , environment : Environment - , saveModel : SaveLoad.Model - } - - -initAppModel : BetterUndoList ApplicationModel -initAppModel = - fresh initAppRecord - - -initAppRecord = - { appState = Building Building.init - , sharedModel = SharedModel.init - , simulatingData = Simulating.initPModel - , buildingData = Building.initPModel - , exportingData = Exporting.initPModel - } - - -main : App () Model Msg -main = - app - { init = - \flags url key -> - let - ( initSave, saveCmd ) = - SaveLoad.initSaveModel - in - ( { appModel = initAppModel - , environment = Environment.init - , saveModel = initSave - } - , Cmd.batch - [ Task.perform (\vp -> WindowSize ( round vp.viewport.width, round vp.viewport.height )) Browser.Dom.getViewport - , Task.perform GetTime Time.now - , Cmd.map SaveMsg saveCmd - , Task.perform GetTZ Time.here - ] - ) - , update = update - , view = \m -> { body = view m, title = "finsm - create and simulate finite state machines" } - , subscriptions = - \model -> - Sub.batch <| - [ Browser.Events.onResize (\w h -> WindowSize ( w, h )) - , Browser.Events.onKeyDown (D.map KeyPressed (D.field "key" D.string)) - , Browser.Events.onKeyUp (D.map KeyReleased (D.field "key" D.string)) - , Browser.Events.onVisibilityChange VisibilityChanged - , case model.appModel.present.appState of - Building m -> - Sub.map BMsg (Building.subscriptions m) - - Simulating m -> - Sub.map SMsg (Simulating.subscriptions m) - - Exporting m -> - Sub.map EMsg (Exporting.subscriptions m) - , Time.every 5000 GetTime -- get the new time every 10 seconds - , Sub.map SaveMsg (SaveLoad.subscriptions model.saveModel) - ] - , onUrlChange = UrlChange - , onUrlRequest = UrlRequest - } - - - -{- replace : state -> UndoList state -> UndoList state - replace st stul = - { stul | present = st } --} - - -moduleUpdate : - Environment - -> mMsg - -> mModel - -> pModel - -> Model - -> (mMsg -> Msg) - -> (mModel -> ApplicationState) - -> (pModel -> ApplicationModel -> ApplicationModel) - -> (Environment -> mMsg -> ( mModel, pModel, SharedModel ) -> ( ( mModel, pModel, SharedModel ), Bool, Cmd mMsg )) - -> ( Model, Cmd Msg ) -moduleUpdate env mMsg mModel pModel model msgWrapper appStateWrapper setpModel mUpdate = - let - currentAppState = - model.appModel.present - - ( ( newM, newPModel, newSModel ), checkpoint, cmd ) = - mUpdate env mMsg ( mModel, pModel, currentAppState.sharedModel ) - - newAppState = - { currentAppState - | appState = appStateWrapper newM - , sharedModel = newSModel - } - |> setpModel newPModel - - sm = - model.saveModel - in - ( { model - | appModel = - if checkpoint then - new newAppState model.appModel - - else - replace newAppState model.appModel - , saveModel = - { sm - | unsavedChanges = - if checkpoint then - True - - else - sm.unsavedChanges - } - } - , Cmd.map msgWrapper cmd - ) - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - let - oldEnvironment = - model.environment - - currentAppState = - model.appModel.present - - sm = - model.saveModel - in - case msg of - BMsg bmsg -> - case currentAppState.appState of - Building m -> - moduleUpdate - oldEnvironment - bmsg - m - currentAppState.buildingData - model - BMsg - Building - (\pm am -> { am | buildingData = pm }) - Building.update - - _ -> - ( model, Cmd.none ) - - SMsg smsg -> - case currentAppState.appState of - Simulating m -> - moduleUpdate - oldEnvironment - smsg - m - currentAppState.simulatingData - model - SMsg - Simulating - (\pm am -> { am | simulatingData = pm }) - Simulating.update - - _ -> - ( model, Cmd.none ) - - EMsg emsg -> - case currentAppState.appState of - Exporting m -> - moduleUpdate - oldEnvironment - emsg - m - currentAppState.exportingData - model - EMsg - Exporting - (\pm am -> { am | exportingData = pm }) - Exporting.update - - _ -> - ( model, Cmd.none ) - - WindowSize ( w, h ) -> - ( { model | environment = { oldEnvironment | windowSize = ( w, h ) } }, Cmd.none ) - - UrlChange _ -> - ( model, Cmd.none ) - - UrlRequest url -> - ( model, Cmd.none ) - - KeyReleased k -> - if k == "Shift" then - ( { model | environment = { oldEnvironment | holdingShift = False } }, Cmd.none ) - - else if k == "Meta" then - ( { model | environment = { oldEnvironment | holdingMeta = False } }, Cmd.none ) - - else if k == "Control" then - ( { model | environment = { oldEnvironment | holdingControl = False } }, Cmd.none ) - - else if k == "Enter" then - ( { model | saveModel = { sm | editingName = False, unsavedChanges = True } }, Cmd.none ) - - else - ( model, Cmd.none ) - - KeyPressed k -> - let - normalizedKey = - String.toLower k - in - if normalizedKey == "shift" then - ( { model | environment = { oldEnvironment | holdingShift = True } }, Cmd.none ) - - else if normalizedKey == "y" || normalizedKey == "z" then - let - doUndo = - (oldEnvironment.holdingControl || oldEnvironment.holdingMeta) && normalizedKey == "z" - - doRedo = - (oldEnvironment.holdingControl && normalizedKey == "y") - || (oldEnvironment.holdingMeta && oldEnvironment.holdingShift && normalizedKey == "z") - in - ( { model - | appModel = - if doRedo then - redo model.appModel - - else if doUndo then - undo model.appModel - - else - model.appModel - , saveModel = { sm | unsavedChanges = doRedo || doUndo } - } - , Cmd.none - ) - - else if normalizedKey == "meta" then - --pressed meta key - ( { model | environment = { oldEnvironment | holdingMeta = True } }, Cmd.none ) - - else if normalizedKey == "control" then - --pressed control - ( { model | environment = { oldEnvironment | holdingControl = True } }, Cmd.none ) - {- else if k == 66 then - ( model, sendMsg <| GoTo BuildingModule ) - - else if k == 83 then - ( model, sendMsg <| GoTo SimulatingModule ) - -} - - else - ( model, Cmd.none ) - - GoTo mod -> - let - exit = - case currentAppState.appState of - Building m -> - processExit - oldEnvironment - m - currentAppState.buildingData - model - (\pm am -> { am | buildingData = pm }) - Building.onExit - - Simulating m -> - processExit - oldEnvironment - m - currentAppState.simulatingData - model - (\pm am -> { am | simulatingData = pm }) - Simulating.onExit - - Exporting m -> - processExit - oldEnvironment - m - currentAppState.exportingData - model - (\pm am -> { am | exportingData = pm }) - Exporting.onExit - - ( enter, cmd ) = - case mod of - BuildingModule -> - processEnter - oldEnvironment - currentAppState.buildingData - exit - BMsg - Building - (\pm am -> { am | buildingData = pm }) - Building.onEnter - - SimulatingModule -> - processEnter - oldEnvironment - currentAppState.simulatingData - exit - SMsg - Simulating - (\pm am -> { am | simulatingData = pm }) - Simulating.onEnter - - ExportingModule -> - processEnter - oldEnvironment - currentAppState.exportingData - exit - EMsg - Exporting - (\pm am -> { am | exportingData = pm }) - Exporting.onEnter - in - ( { model | appModel = enter }, cmd ) - - VisibilityChanged vis -> - ( { model - | environment = - { oldEnvironment - | holdingShift = False - , holdingControl = False - , holdingMeta = False - } - } - , Cmd.none - ) - - GetTime time -> - let - oldEnv = - model.environment - in - ( { model | environment = { oldEnv | currentTime = time } } - , Cmd.none - ) - - SaveMsg saveMsg -> - case saveMsg of - SaveLoad.LoadMachineResponse response -> - case response of - Ok loadPayload -> - let - initSharedModel = - SharedModel.init - - newSharedModel = - { initSharedModel | machine = loadPayload.machine } - - initSimModel = - Simulating.initPModel - - --{ appState = Building Building.init - --, sharedModel = SharedModel.init - --, simulatingData = Simulating.initPModel - --, buildingData = Building.initPModel - --, exportingData = Exporting.initPModel - --} - newModel = - fresh - { initAppRecord - | sharedModel = newSharedModel - , simulatingData = { initSimModel | tapes = Simulating.checkTapesNoStatus newSharedModel loadPayload.tapes } - } - in - ( { model - | appModel = newModel - , saveModel = - let - meta = - sm.machineMetadata - in - { sm | lastSaved = oldEnvironment.currentTime, machineData = SaveLoad.MachineCreated, machineMetadata = { meta | name = loadPayload.name, id = loadPayload.uuid } } - } - , Cmd.none - ) - - Err _ -> - ( model, Cmd.none ) - - SaveLoad.CreateNewMachine -> - let - initSharedModel = - SharedModel.init - - newSharedModel = - initSharedModel - - initSimModel = - Simulating.initPModel - - --{ appState = Building Building.init - --, sharedModel = SharedModel.init - --, simulatingData = Simulating.initPModel - --, buildingData = Building.initPModel - --, exportingData = Exporting.initPModel - --} - newModel = - fresh - { initAppRecord - | sharedModel = newSharedModel - , simulatingData = initSimModel - } - in - ( { model - | appModel = newModel - , saveModel = - { sm - | lastSaved = oldEnvironment.currentTime - , machineData = SaveLoad.MachineCreated - , loadDialog = SaveLoad.NothingOpen - , loadDialogModal = Modal.hidden - , machineMetadata = SaveLoad.initMachineMetadata - } - } - , Cmd.none - ) - - other -> - let - ( newSM, sCmd ) = - SaveLoad.update other model.saveModel model.environment model.appModel.present - in - ( { model | saveModel = newSM }, Cmd.map SaveMsg sCmd ) - - GetTZ zone -> - ( { model | environment = { oldEnvironment | timeZone = zone } }, Cmd.none ) - - NoOp -> - ( model, Cmd.none ) - - -processExit : - Environment - -> mModel - -> pModel - -> Model - -> (pModel -> ApplicationModel -> ApplicationModel) - -> (Environment -> ( mModel, pModel, SharedModel ) -> ( ( pModel, SharedModel ), Bool )) - -> BetterUndoList ApplicationModel -processExit env m pModel model setpModel onExit = - let - currentAppState = - model.appModel.present - - ( ( newPModel, newSModel ), checkpoint ) = - onExit env ( m, pModel, currentAppState.sharedModel ) - - newAppState = - { currentAppState | sharedModel = newSModel } - |> setpModel newPModel - in - if checkpoint then - new newAppState model.appModel - - else - replace newAppState model.appModel - - -processEnter : - Environment - -> pModel - -> BetterUndoList ApplicationModel - -> (mMsg -> Msg) - -> (mModel -> ApplicationState) - -> (pModel -> ApplicationModel -> ApplicationModel) - -> (Environment -> ( pModel, SharedModel ) -> ( ( mModel, pModel, SharedModel ), Bool, Cmd mMsg )) - -> ( BetterUndoList ApplicationModel, Cmd Msg ) -processEnter env pModel exitModel msgWrapper appStateWrapper setpModel onEnter = - let - exitAppState = - exitModel.present - - ( ( newM, newPModel, newSModel ), checkpoint, mCmd ) = - onEnter env ( pModel, exitAppState.sharedModel ) - - newAppState = - { exitAppState | appState = appStateWrapper newM, sharedModel = newSModel } - |> setpModel newPModel - in - ( if checkpoint then - new newAppState exitModel - - else - replace newAppState exitModel - , Cmd.map msgWrapper mCmd - ) - - -textHtml : String -> Html msg -textHtml t = - H.span - [ Json.Encode.string t - |> Html.Attributes.property "innerHTML" - ] - [] - - -view model = - let - {- accepted = - isAccept model.states oldMachine.final model.input model.inputAt - -} - winX = - toFloat <| first model.environment.windowSize - - winY = - toFloat <| second model.environment.windowSize - - appState = - model.appModel.present - in - collage - winX - --winX - winY - --winY - [ case appState.appState of - Building m -> - GraphicSVG.map BMsg <| Building.view model.environment ( m, appState.buildingData, appState.sharedModel ) - - Simulating m -> - GraphicSVG.map SMsg <| Simulating.view model.environment ( m, appState.simulatingData, appState.sharedModel ) - - Exporting m -> - GraphicSVG.map EMsg <| Exporting.view model.environment ( m, appState.exportingData, appState.sharedModel ) - , modeButtons model - , icon False (text "?" |> size 30 |> fixedwidth |> centered |> filled (rgb 220 220 220) |> move ( 0, -9 )) - |> addHyperlink "https://github.com/CSchank/finsm/wiki" - |> move ( winX / 2 - 25, -winY / 2 + 25 ) - ] - - -modeButtons model = - let - winX = - toFloat <| first model.environment.windowSize - - winY = - toFloat <| second model.environment.windowSize - - building = - case model.appModel.present.appState of - Building _ -> - True - - _ -> - False - - simulating = - case model.appModel.present.appState of - Simulating _ -> - True - - _ -> - False - - exporting = - case model.appModel.present.appState of - Exporting _ -> - True - - _ -> - False - in - group - [ group - [ roundedRect 40 15 1 - |> filled - (if building then - finsmBlue - - else - blank - ) - |> addOutline (solid 1) darkGray - , text "Build" - |> centered - |> fixedwidth - |> filled - (if building then - white - - else - darkGray - ) - |> move ( 0, -4 ) - ] - |> move ( -winX / 2 + 25, winY / 2 - 15 ) - |> notifyTap (GoTo BuildingModule) - , group - [ roundedRect 60 15 1 - |> filled - (if simulating then - finsmBlue - - else - blank - ) - |> addOutline (solid 1) darkGray - , text "Simulate" - |> centered - |> fixedwidth - |> filled - (if simulating then - white - - else - darkGray - ) - |> move ( 0, -4 ) - ] - |> move ( -winX / 2 + 77, winY / 2 - 15 ) - |> notifyTap (GoTo SimulatingModule) - , group - [ roundedRect 50 15 1 - |> filled - (if exporting then - finsmBlue - - else - blank - ) - |> addOutline (solid 1) darkGray - , text "Export" - |> centered - |> fixedwidth - |> filled - (if exporting then - white - - else - darkGray - ) - |> move ( 0, -4 ) - ] - |> move ( -winX / 2 + 134, winY / 2 - 15 ) - |> notifyTap (GoTo ExportingModule) - , GraphicSVG.map SaveMsg <| SaveLoad.view model.saveModel model.environment - ] - - -errorEpsTrans model = - let - winX = - toFloat <| first model.environment.windowSize - - winY = - toFloat <| second model.environment.windowSize - in - group - [ rectangle winX winY - |> filled darkGray - |> makeTransparent 0.75 - , group - [ roundedRect 300 150 1 |> filled lightGray - , text "finsm: Build Error" - |> bold - |> centered - |> filled lightRed - |> scale 2 - |> move ( 0, 40 ) - , text "You have invalid states:" - |> filled darkRed - |> scale 1.2 - |> move ( -140, 5 ) - , text "> Maybe ε-transitions are used with other transitions?" - |> filled darkRed - |> move ( -140, -10 ) - , text "> Hint: Fix transitions highlighted in red" - |> filled darkGreen - |> move ( -140, -25 ) - , text "Hit any key to dismiss this message" - |> bold - |> centered - |> filled black - |> scale 1.25 - |> move ( 0, -60 ) - ] - ] diff --git a/src/Mistakes.elm b/src/Mistakes.elm deleted file mode 100644 index 1e64268..0000000 --- a/src/Mistakes.elm +++ /dev/null @@ -1,54 +0,0 @@ -module Mistakes exposing (checkEpsilonTransLabel, checkTransitionValid, getTransitionMistakes) - -import Dict exposing (..) -import Machine exposing (..) -import Set exposing (..) - - -getTransitionMistakes : Machine -> TransitionMistakes -getTransitionMistakes mac = - let - tNames = - mac.transitionNames - in - checkEpsilonTransLabel tNames - - - --- Check if an epsilon label is well-typed - - -checkEpsilonTransLabel : TransitionNames -> TransitionMistakes -checkEpsilonTransLabel tNames = - let - tMistakes = - Dict.foldl - (\tid tnames tmistakes -> - if not (checkTransitionValid tnames) then - Set.insert tid tmistakes - - else - tmistakes - ) - Set.empty - tNames - in - if Set.isEmpty tMistakes then - Nothing - - else - Just tMistakes - - -checkTransitionValid : Set.Set String -> Bool -checkTransitionValid set = - case Set.member "\\epsilon" set of - False -> - True - - True -> - if Set.size set == 1 then - True - - else - False diff --git a/src/Ports.elm b/src/Ports.elm deleted file mode 100644 index 71f795e..0000000 --- a/src/Ports.elm +++ /dev/null @@ -1,13 +0,0 @@ -port module Ports exposing (..) - - -port launchLogin : () -> Cmd msg - - -port launchLogout : () -> Cmd msg - - -port loginComplete : (() -> msg) -> Sub msg - - -port logoutComplete : (() -> msg) -> Sub msg diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm deleted file mode 100644 index b31e538..0000000 --- a/src/SaveLoad.elm +++ /dev/null @@ -1,1098 +0,0 @@ -module SaveLoad exposing (..) - -import ApplicationModel exposing (ApplicationModel) -import Bootstrap.Button as Button -import Bootstrap.ButtonGroup as ButtonGroup -import Bootstrap.Card as Card -import Bootstrap.Card.Block as Block -import Bootstrap.Grid as Grid -import Bootstrap.Grid.Row as Row -import Bootstrap.ListGroup as ListGroup -import Bootstrap.Modal as Modal -import Bootstrap.Spinner as Spinner -import Bootstrap.Tab as Tab -import Bootstrap.Text as Text -import Bootstrap.Utilities.Flex as Flex -import Bootstrap.Utilities.Size as Size -import Bootstrap.Utilities.Spacing as Spacing -import Browser.Events -import Dict exposing (Dict) -import Duration -import Environment exposing (Environment) -import GraphicSVG exposing (..) -import Helpers exposing (editIcon) -import Html exposing (Html) -import Html.Attributes exposing (attribute, placeholder, style, value) -import Html.Events exposing (onInput) -import Http -import Json.Decode as D -import Json.Encode as E -import Machine exposing (Machine) -import Ports -import Simulating exposing (InputTape) -import Time exposing (Posix) -import Utils exposing (newMsg, textBox) - - -type MachineType - = DFA - | NFA - | NPDA - | Turing - - -type FilterType - = FilterActive - | MachineFilter MachineType - | FilterArchived - - -filterToString : FilterType -> String -filterToString f = - case f of - FilterActive -> - "all" - - MachineFilter m -> - machineTypeStr m - - FilterArchived -> - "arc" - - -decodeMachineType : D.Decoder MachineType -decodeMachineType = - D.string - |> D.andThen - (\m -> - case m of - "D" -> - D.succeed DFA - - "N" -> - D.succeed NFA - - "P" -> - D.succeed NPDA - - "T" -> - D.succeed Turing - - s -> - D.fail <| "Invalid string " ++ s ++ " for machine type" - ) - - -encodeMachineType : MachineType -> E.Value -encodeMachineType = - E.string << machineTypeStr - - -machineTypeStr : MachineType -> String -machineTypeStr m = - case m of - DFA -> - "D" - - NFA -> - "N" - - NPDA -> - "P" - - Turing -> - "T" - - -machineTypeFullStr : MachineType -> String -machineTypeFullStr m = - case m of - DFA -> - "DFA" - - NFA -> - "NFA" - - NPDA -> - "NPDA" - - Turing -> - "Turing" - - -type alias LoadMetadata = - { id : String - , name : String - , date : Posix - , description : String - , machine_type : MachineType - } - - -decodeMetadataV1 : D.Decoder LoadMetadata -decodeMetadataV1 = - D.map5 LoadMetadata - (D.field "id" D.string) - (D.field "name" D.string) - (D.field "date" <| D.map Time.millisToPosix D.int) - (D.field "desc" D.string) - (D.field "type" decodeMachineType) - - -decodeMetadata : D.Decoder LoadMetadata -decodeMetadata = - D.field "v" D.int - |> D.andThen - (\v -> - case v of - 1 -> - decodeMetadataV1 - - _ -> - D.fail <| "Invalid save metadata version " ++ String.fromInt v - ) - - -decodeMachineList : D.Decoder (List LoadMetadata) -decodeMachineList = - D.list decodeMetadata - - -encodeMachinePayload = - encodeMachinePayloadV1 - - - --- encode the payload when saving a machine to the server --- note: id is empty if the machine is a new one instead of one already saved to the server --- sending an existing id will overwrite the machine saved with that id - - -encodeMachinePayloadV1 : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> MachineType -> E.Value -encodeMachinePayloadV1 name desc machine uuid inputTape machine_type = - E.object - [ ( "name", E.string name ) - , ( "desc", E.string desc ) - , ( "machine", Machine.machineEncoder machine ) - , ( "v", E.int 1 ) - , ( "uuid", E.string uuid ) - , ( "tape", Simulating.inputTapeEncoder inputTape ) - , ( "type", encodeMachineType machine_type ) - ] - - -type alias SaveResponse = - { success : Bool - , uuid : String - } - - -decodeSaveResponse : D.Decoder SaveResponse -decodeSaveResponse = - D.map2 SaveResponse - (D.field "success" D.bool) - (D.field "uuid" D.string) - - -saveMachine : String -> String -> Machine -> String -> Dict Int ( InputTape, a ) -> MachineType -> (Result Http.Error SaveResponse -> msg) -> Cmd msg -saveMachine name desc machine uuid inputTape machine_type toMsg = - Http.send toMsg <| - Http.post - "/api/machine/save" - (Http.jsonBody <| encodeMachinePayload name desc machine uuid inputTape machine_type) - decodeSaveResponse - - -type alias ArchivePayload = - { uuid : String - , restore : Bool - } - - -encodeArchivePayload : ArchivePayload -> E.Value -encodeArchivePayload ap = - E.object - [ ( "uuid", E.string ap.uuid ) - , ( "restore", E.bool ap.restore ) - ] - - -archiveMachine : ArchivePayload -> (Result Http.Error ArchiveResponse -> msg) -> Cmd msg -archiveMachine payload toMsg = - Http.send toMsg <| - Http.post - "/api/machine/archive" - (Http.jsonBody <| encodeArchivePayload payload) - decodeArchiveResponse - - -type alias LoadPayload = - { machine : Machine - , tapes : Dict Int InputTape - , name : String - , uuid : String - } - - -type alias ArchiveResponse = - { success : Bool - } - - -decodeArchiveResponse : D.Decoder ArchiveResponse -decodeArchiveResponse = - D.map ArchiveResponse (D.field "success" <| D.bool) - - -decodeLoadPayload : D.Decoder LoadPayload -decodeLoadPayload = - D.map4 LoadPayload - (D.field "machine" Machine.machineDecoder) - (D.field "tape" Simulating.inputTapeDictDecoder) - (D.field "name" D.string) - (D.field "uuid" D.string) - - -loadMachine : String -> (Result Http.Error LoadPayload -> msg) -> Cmd msg -loadMachine uuid toMsg = - Http.send toMsg <| - Http.post - "/api/machine/load" - (Http.jsonBody <| E.string uuid) - decodeLoadPayload - - -loadList : FilterType -> (Result Http.Error (List LoadMetadata) -> msg) -> Cmd msg -loadList machineType toMsg = - Http.send toMsg <| - Http.post - "/api/machine/list" - (Http.stringBody "text/plain" <| filterToString machineType) - decodeMachineList - - -type Msg - = OpenLoginDialog - | OpenLogoutDialog - | MachineCreatedMsg MachineCreatedMsg - | GetLoginStatus - | ArchiveMachine String - | RestoreMachine String - | LoginStatusChange (Result Http.Error LoginStatus) - | InitLoginStatus (Result Http.Error LoginStatus) - | LoadMachine LoadMetadata - | LoadMachineResponse (Result Http.Error LoadPayload) - | ArchiveMachineResponse (Result Http.Error ArchiveResponse) - | SelectFilter FilterType - | OpenLoadDialog - | OpenNewDialog - | CloseLoadDialog - | ListLoadResponse (Result Http.Error (List LoadMetadata)) - | ModalAnimation Modal.Visibility - | CreateNewMachine - - - --- messages that can only be sent when there is a machine loaded - - -type MachineCreatedMsg - = EditMachineName - | TypeName String - | SaveMachine - | MachineSaveResponse (Result Http.Error SaveResponse) - | AutoSave Posix - | TabMsg Tab.State - - -loginStatusDecoder : D.Decoder LoginStatus -loginStatusDecoder = - D.field "loggedin" D.bool - |> D.andThen - (\loggedIn -> - if loggedIn then - D.map2 LoggedIn - (D.field "email" D.string) - (D.map - (\s -> - if s == "" then - Nothing - - else - Just s - ) - <| - D.field "newestMachine" D.string - ) - - else - D.succeed NotLoggedIn - ) - - -getInitLoginStatus : Cmd Msg -getInitLoginStatus = - Http.send InitLoginStatus <| - Http.post - "/accounts/loginstate/" - Http.emptyBody - loginStatusDecoder - - -getLoginStatus : Cmd Msg -getLoginStatus = - Http.send LoginStatusChange <| - Http.post - "/accounts/loginstate/" - Http.emptyBody - loginStatusDecoder - - -type LoginStatus - = LoggedIn String {- username -} (Maybe String) {- latest machine -} - | NotLoggedIn - | LoggingIn - - -initSaveModel = - ( { loginState = NotLoggedIn - , machineData = MachineCreated - , loadDialog = NothingOpen - , loadDialogModal = Modal.shown - , machineMetadata = initMachineMetadata - , tabState = Tab.initialState - , loadingList = Nothing - , editingName = False - , lastSaved = Time.millisToPosix 0 - , unsavedChanges = False - , loadFilter = FilterActive - } - , Cmd.batch [ getInitLoginStatus ] - ) - - -initMachineMetadata = - { id = "", name = "Untitled", description = "", date = Time.millisToPosix 0, machine_type = DFA } - - -subscriptions : Model -> Sub Msg -subscriptions model = - Sub.batch <| - [ Browser.Events.onVisibilityChange (\_ -> GetLoginStatus) - , Ports.loginComplete (\_ -> GetLoginStatus) - , Ports.logoutComplete (\_ -> GetLoginStatus) - , Modal.subscriptions model.loadDialogModal ModalAnimation - ] - ++ (case ( model.machineData, model.loginState ) of - ( MachineCreated, LoggedIn _ _ ) -> - if model.unsavedChanges then - [ Time.every 5000 (MachineCreatedMsg << AutoSave) ] - - else - [] - - ( _, _ ) -> - [] - ) - - -type alias Model = - { loginState : LoginStatus - , tabState : Tab.State - , machineData : MachineCreated - , loadDialog : DialogStatus - , machineMetadata : LoadMetadata - , loadDialogModal : Modal.Visibility - , loadingList : Maybe FilterType - , editingName : Bool - , lastSaved : Time.Posix - , unsavedChanges : Bool - , loadFilter : FilterType - } - - -type MachineCreated - = MachineCreated - | MachineNotCreated - - -type DialogStatus - = NothingOpen - | LoadLoading - | LoadOpen (List LoadMetadata) - | NewOpen - - -type SaveStatus - = NotSaved - | LastSaved Time.Posix - | Saved Time.Posix - - -update : Msg -> Model -> Environment -> ApplicationModel -> ( Model, Cmd Msg ) -update msg model env appModel = - case msg of - OpenLoadDialog -> - ( { model | loadDialog = LoadLoading } - , Cmd.batch - [ loadList FilterActive ListLoadResponse - , if model.unsavedChanges then - newMsg (MachineCreatedMsg SaveMachine) - - else - Cmd.none - ] - ) - - ListLoadResponse response -> - case response of - Ok machineList -> - ( { model | loadDialog = LoadOpen machineList, loadDialogModal = Modal.shown, loadingList = Nothing, machineData = MachineCreated }, Cmd.none ) - - Err _ -> - ( { model | loadDialog = NothingOpen }, Cmd.none ) - - LoadMachine meta -> - ( { model | machineMetadata = meta, loadDialog = NothingOpen } - , loadMachine meta.id LoadMachineResponse - ) - - -- handled by Main.elm - LoadMachineResponse _ -> - ( model, Cmd.none ) - - SelectFilter filter_type -> - ( { model - | tabState = Tab.customInitialState (filterToString filter_type) - , loadingList = Just filter_type - , loadFilter = filter_type - , loadDialog = LoadOpen [] - } - , loadList filter_type ListLoadResponse - ) - - OpenLoginDialog -> - ( { model | loginState = LoggingIn }, Ports.launchLogin () ) - - OpenLogoutDialog -> - ( model, Ports.launchLogout () ) - - GetLoginStatus -> - ( model, getLoginStatus ) - - LoginStatusChange loginStatus -> - case loginStatus of - Ok loginState -> - ( { model | loginState = loginState }, Cmd.none ) - - Err _ -> - ( model, Cmd.none ) - - InitLoginStatus loginStatus -> - case loginStatus of - Ok loginState -> - ( { model - | loginState = loginState - , loadDialog = - case loginState of - LoggedIn email latestMachine -> - NothingOpen - - NotLoggedIn -> - NewOpen - - LoggingIn -> - NothingOpen - , loadDialogModal = Modal.shown - } - , case loginState of - LoggedIn _ (Just uuid) -> - loadMachine uuid LoadMachineResponse - - _ -> - Cmd.none - ) - - Err _ -> - ( model, Cmd.none ) - - ArchiveMachine uuid -> - ( model - , archiveMachine { uuid = uuid, restore = False } ArchiveMachineResponse - ) - - RestoreMachine uuid -> - ( model - , archiveMachine { uuid = uuid, restore = True } ArchiveMachineResponse - ) - - ArchiveMachineResponse archiveResponse -> - ( model, loadList model.loadFilter ListLoadResponse ) - - MachineCreatedMsg mcMsg -> - case model.machineData of - MachineCreated -> - let - ( newModel, mcCmd ) = - machineCreatedUpdate env appModel mcMsg model - in - ( newModel, Cmd.map MachineCreatedMsg mcCmd ) - - _ -> - ( model, Cmd.none ) - - CloseLoadDialog -> - ( { model | loadDialogModal = Modal.hidden, loadDialog = NothingOpen }, Cmd.none ) - - ModalAnimation v -> - ( { model | loadDialogModal = v }, Cmd.none ) - - OpenNewDialog -> - ( { model | loadDialog = NewOpen, loadDialogModal = Modal.shown }, Cmd.none ) - - -- handled in Main.elm - CreateNewMachine -> - ( model, Cmd.none ) - - -machineCreatedUpdate : Environment -> ApplicationModel -> MachineCreatedMsg -> Model -> ( Model, Cmd MachineCreatedMsg ) -machineCreatedUpdate env appModel msg model = - case msg of - EditMachineName -> - ( { model | editingName = True }, Cmd.none ) - - TypeName n -> - let - meta = - model.machineMetadata - in - ( { model | machineMetadata = { meta | name = n } }, Cmd.none ) - - SaveMachine -> - ( model - , saveMachine - model.machineMetadata.name - model.machineMetadata.description - appModel.sharedModel.machine - model.machineMetadata.id - appModel.simulatingData.tapes - model.machineMetadata.machine_type - MachineSaveResponse - ) - - MachineSaveResponse saveresp -> - let - meta = - model.machineMetadata - in - case saveresp of - Ok oksaveresp -> - ( { model - | machineMetadata = { meta | id = oksaveresp.uuid } - , lastSaved = env.currentTime - , unsavedChanges = False - } - , Cmd.none - ) - - Err _ -> - ( model, Cmd.none ) - - AutoSave time -> - ( model - , if model.unsavedChanges then - saveMachine - model.machineMetadata.name - model.machineMetadata.description - appModel.sharedModel.machine - model.machineMetadata.id - appModel.simulatingData.tapes - model.machineMetadata.machine_type - MachineSaveResponse - - else - Cmd.none - ) - - TabMsg state -> - ( { model | tabState = state }, Cmd.none ) - - -view : Model -> Environment -> Shape Msg -view model env = - let - winX = - toFloat <| Tuple.first env.windowSize - - winY = - toFloat <| Tuple.second env.windowSize - in - group - [ case model.loginState of - NotLoggedIn -> - group - [ roundedRect 50 15 1 - |> filled blank - |> addOutline (solid 1) darkGray - , text "Log in" - |> centered - |> fixedwidth - |> filled black - |> move ( 0, -4 ) - ] - |> move ( winX / 2 - 50, winY / 2 - 15 ) - |> notifyTap OpenLoginDialog - - LoggedIn email lastMachine -> - group - [ text ("Welcome " ++ email) - |> alignRight - |> fixedwidth - |> filled black - |> move ( 0, -4 ) - , group - [ roundedRect 55 15 1 - |> filled blank - |> addOutline (solid 1) darkGray - , text "Log out" - |> centered - |> fixedwidth - |> filled black - |> move ( 0, -4 ) - ] - |> move ( 40, 0 ) - |> notifyTap OpenLogoutDialog - , group - [ roundedRect 85 15 1 - |> filled blank - |> addOutline (solid 1) darkGray - , text "My Machines" - |> centered - |> fixedwidth - |> filled black - |> move ( 0, -4 ) - ] - |> move ( 40, -20 ) - |> notifyTap OpenLoadDialog - ] - |> move ( winX / 2 - 100, winY / 2 - 15 ) - - _ -> - group [] - , case model.loadDialog of - LoadOpen metas -> - let - tab : FilterType -> Tab.Item Msg - tab ft = - Tab.item - { id = - case ft of - FilterActive -> - "all" - - MachineFilter DFA -> - "D" - - MachineFilter NFA -> - "N" - - MachineFilter NPDA -> - "P" - - MachineFilter Turing -> - "T" - - FilterArchived -> - "arc" - , link = - Tab.link [ Html.Events.onClick <| SelectFilter ft ] <| - [] - {- <| - (if model.loadingList == Just ft then - [ Spinner.spinner - [ Spinner.small, Spinner.attrs [ Spacing.mr1 ] ] - [] - ] - - else - [] - ) - -} - ++ [ Html.text - (case ft of - FilterActive -> - "All" - - MachineFilter DFA -> - "DFA" - - MachineFilter NFA -> - "NFA" - - MachineFilter NPDA -> - "NPDA" - - MachineFilter Turing -> - "TM" - - FilterArchived -> - "Archived" - ) - ] - , pane = - Tab.pane [] - [] - } - in - GraphicSVG.html winX - winY - (Modal.config CloseLoadDialog - -- Configure the modal to use animations providing the new AnimateModal msg - |> Modal.withAnimation ModalAnimation - |> Modal.header [] - [ Html.div [] [ Html.h3 [] [ Html.text "My Machines" ] ] - , Html.div [] [ Button.button [ Button.primary, Button.attrs [ style "margin-left" "10px" ], Button.onClick OpenNewDialog ] [ Html.text "New" ] ] - ] - -- |> Modal.header [] [ Html.h3 [] [Html.text "Your Machines"] , Html.div [style "display" "block", style "float" "right"] [Button.button [Button.primary, Button.small ] [ Html.text "New" ] ] ] - |> Modal.body [ style "height" (String.fromFloat (winY / 2) ++ "px"), style "overflow" "scroll" ] [ renderLoadList (model.loadingList /= Nothing) (model.loadFilter == FilterArchived) metas env.currentTime env.timeZone ] - {- |> Modal.footer [] - [ Button.button - [ Button.outlinePrimary - -- If you want the custom close button to use animations; - -- you should use the AnimateModal msg and provide it with the Modal.hiddenAnimated visibility - , Button.attrs [ Html.Events.onClick <| ModalAnimation Modal.hiddenAnimated ] - ] - [ Html.text "Close" ] - ] - -} - |> Modal.footer [] - [ Html.div [ style "width" "100%" ] - [ Tab.config (MachineCreatedMsg << TabMsg) - |> Tab.pills - -- |> Tab.attrs [style "float" "left"] - |> Tab.center - |> Tab.items - (List.map tab - [ FilterActive - , MachineFilter DFA - , MachineFilter NFA - - {- , MachineFilter NPDA, MachineFilter Turing, -} - , FilterArchived - ] - ) - |> Tab.view model.tabState - ] - ] - |> Modal.view model.loadDialogModal - ) - |> move ( -winX / 2, winY / 2 ) - - NewOpen -> - GraphicSVG.html winX - winY - (Modal.config CloseLoadDialog - -- Configure the modal to use animations providing the new AnimateModal msg - |> Modal.withAnimation ModalAnimation - |> Modal.header [] - [ Html.div [] [ Html.h3 [] [ Html.text "Welcome to finsm.io!" ] ] - ] - -- |> Modal.header [] [ Html.h3 [] [Html.text "Your Machines"] , Html.div [style "display" "block", style "float" "right"] [Button.button [Button.primary, Button.small ] [ Html.text "New" ] ] ] - |> Modal.body [ style "height" (String.fromFloat (winY / 2) ++ "px"), style "overflow" "scroll" ] - [ Html.h4 [] [ Html.text "finsm.io lets you create, test and export finite state machines. Get started by selecting an option below:" ] - , renderNew model.loginState - ] - {- |> Modal.footer [] - [ Button.button - [ Button.outlinePrimary - -- If you want the custom close button to use animations; - -- you should use the AnimateModal msg and provide it with the Modal.hiddenAnimated visibility - , Button.attrs [ Html.Events.onClick <| ModalAnimation Modal.hiddenAnimated ] - ] - [ Html.text "Close" ] - ] - -} - |> Modal.footer [] [] - |> Modal.view model.loadDialogModal - ) - |> move ( -winX / 2, winY / 2 ) - - _ -> - group [] - , case model.machineData of - MachineCreated -> - group - [ if not model.editingName then - group - [ group - [ roundedRect 15 15 2 |> filled white |> addOutline (solid 1) darkGray |> move ( 3, 3 ) - , editIcon - |> scale 1.5 - ] - |> move ( -winX / 2 + 470, winY / 2 - 20 ) - , text model.machineMetadata.name - |> fixedwidth - |> size 16 - |> filled black - |> move ( -winX / 2 + 175, winY / 2 - 20 ) - ] - |> notifyTap (MachineCreatedMsg EditMachineName) - - else - textBox model.machineMetadata.name 300 20 "Machine Name" (MachineCreatedMsg << TypeName) - |> move ( -winX / 2 + 325, winY / 2 - 10 ) - , text (lastSaved model env) - |> fixedwidth - |> size 14 - |> filled darkGray - |> move ( -winX / 2 + 490, winY / 2 - 20 ) - ] - - MachineNotCreated -> - group [] - ] - - -lastSaved : Model -> Environment -> String -lastSaved model env = - let - duration = - Duration.from model.lastSaved env.currentTime - in - if not model.unsavedChanges then - if Duration.inSeconds duration <= 30 then - "last edit saved just now" - - else if Duration.inSeconds duration <= 90 then - "last edit saved about a minute ago" - - else if Duration.inMinutes duration <= 60 then - "last edit saved " ++ String.fromInt (round <| Duration.inMinutes duration) ++ " minutes ago" - - else if Duration.inMinutes duration <= 90 then - "last edit saved about an hour ago" - - else - "last edit saved " ++ String.fromInt (round <| Duration.inHours duration) ++ " hours ago" - - else - case model.loginState of - LoggedIn _ _ -> - "saving..." - - NotLoggedIn -> - "log in to save changes" - - _ -> - "" - - -aboutAXAgo : Duration.Duration -> String -aboutAXAgo duration = - if Duration.inSeconds duration <= 30 then - "just now" - - else if Duration.inSeconds duration <= 90 then - "about a minute ago" - - else if Duration.inMinutes duration <= 60 then - String.fromInt (round <| Duration.inMinutes duration) ++ " minutes ago" - - else if Duration.inMinutes duration <= 90 then - "about an hour ago" - - else if Duration.inDays duration <= 1 then - String.fromInt (round <| Duration.inHours duration) ++ " hours ago" - - else - String.fromInt (round <| Duration.inDays duration) ++ " days ago" - - -dateFormat : Time.Zone -> Posix -> Posix -> String -dateFormat zn now thn = - let - duration = - Duration.from thn now - - dayStr day = - case day of - Time.Mon -> - "Monday" - - Time.Tue -> - "Tuesday" - - Time.Wed -> - "Wednesday" - - Time.Thu -> - "Thursday" - - Time.Fri -> - "Friday" - - Time.Sat -> - "Saturday" - - Time.Sun -> - "Sunday" - - monStr mon = - case mon of - Time.Jan -> - "January" - - Time.Feb -> - "February" - - Time.Mar -> - "March" - - Time.Apr -> - "April" - - Time.May -> - "May" - - Time.Jun -> - "June" - - Time.Jul -> - "July" - - Time.Aug -> - "August" - - Time.Sep -> - "September" - - Time.Oct -> - "October" - - Time.Nov -> - "November" - - Time.Dec -> - "December" - - dateFmt : Posix -> String - dateFmt t = - (monStr <| Time.toMonth zn t) ++ " " ++ (String.fromInt <| Time.toDay zn t) ++ ", " ++ (String.fromInt <| Time.toYear zn t) - in - if Duration.inDays duration <= 1 then - aboutAXAgo duration - - else if Duration.inDays duration <= 3 then - dayStr (Time.toWeekday zn thn) - - else - dateFmt thn - - -renderLoadList : Bool -> Bool -> List LoadMetadata -> Posix -> Time.Zone -> Html Msg -renderLoadList loadingList archiveList metas now zn = - let - oneRow machine = - ListGroup.anchor - [ ListGroup.attrs [ Flex.col, Flex.alignItemsStart, Size.w100 ] - ] - [ Html.div [ Flex.block, Flex.justifyBetween, Size.w100 ] - [ Html.h5 [ Spacing.mb1 ] [ Html.text machine.name ] - , Html.small [] [ Html.text <| dateFormat zn now machine.date ] - ] - , ButtonGroup.buttonGroup [ ButtonGroup.attrs [ style "float" "right" ] ] - [ ButtonGroup.button [ Button.primary, Button.small, Button.onClick (LoadMachine machine) ] [ Html.text "Open" ] - , ButtonGroup.button - [ Button.danger - , Button.small - , Button.onClick - (if archiveList then - RestoreMachine machine.id - - else - ArchiveMachine machine.id - ) - ] - [ Html.text - (if archiveList then - "Restore" - - else - "Archive" - ) - ] - ] - , Html.div [] [ Html.b [] [ Html.text (machineTypeFullStr machine.machine_type) ] ] - ] - in - Html.div [] - --[style "overflow" "scroll"]-- style "width" (String.fromInt w ++ "px"), style "height" (String.fromInt h ++ "px"), style "position" "fixed"] - [ if loadingList then - Html.div [ style "height" "500px" ] [ Spinner.spinner [ Spinner.color Text.primary, Spinner.large, Spinner.grow, Spinner.attrs [ style "display" "block", style "margin" "auto" ] ] [] ] - - else if metas == [] then - Html.div [ style "text-align" "center" ] [ Html.text "No machines matching current filter." ] - - else - ListGroup.custom (List.map oneRow metas) - ] - - -renderNew : LoginStatus -> Html Msg -renderNew loginStatus = - Grid.container [] - [ Grid.row [] - [ Grid.col [] - [ Card.deck - [ Card.config [] - |> Card.headerH3 [] [ Html.text "DFA / NFA" ] - |> Card.block [] - [ Block.text [] [ Html.text "Create a new Finite State Machine." ] ] - |> Card.footer [] - [ Button.button [ Button.primary, Button.onClick CreateNewMachine ] [ Html.text "Create!" ] ] - , case loginStatus of - LoggedIn _ _ -> - Card.config [] - |> Card.headerH3 [] [ Html.text "Load Existing" ] - |> Card.block [] - [ Block.text [] [ Html.text "Load an existing machine." ] ] - |> Card.footer [] - [ Button.button [ Button.primary, Button.onClick OpenLoadDialog ] [ Html.text "Load" ] ] - - NotLoggedIn -> - Card.config [] - |> Card.headerH3 [] [ Html.text "Load Existing" ] - |> Card.block [] - [ Block.text [] [ Html.text "Log in to load an existing machine." ] ] - |> Card.footer [] - [ Button.button [ Button.primary, Button.onClick OpenLoginDialog ] [ Html.text "Login" ] ] - - LoggingIn -> - Card.config [] - |> Card.headerH3 [] [ Html.text "Load Existing" ] - |> Card.block [] - [ Block.text [] [ Html.text "Please finish logging in to load your machines." ] ] - |> Card.footer [] - [ Button.button [ Button.primary, Button.onClick OpenLoginDialog ] [ Html.text "Login" ] ] - ] - , Grid.row [ Row.attrs [ style "margin-top" "10px" ] ] - [ Grid.col [] - [ Card.deck - [ Card.config [] - |> Card.headerH3 [] [ Html.text "Quickstart Guide" ] - |> Card.block [] - [ Block.text [] [ Html.text "Before you start using the site, you may want to read our \"Quickstart\" guide to learn tips & tricks!" ] ] - |> Card.footer [] - [ Button.linkButton [ Button.primary, Button.attrs [ Html.Attributes.href "https://github.com/CSchank/finsm/wiki/QUICKSTART", Html.Attributes.target "_blank" ] ] [ Html.text "Go!" ] ] - , Card.config [] - |> Card.headerH3 [] [ Html.text "Get Involved!" ] - |> Card.block [] - [ Block.text [] [ Html.text "Have questions? Comments? Suggestions? Pull requests? We welcome it all! Come visit us on GitHub!" ] ] - |> Card.footer [] - [ Button.linkButton [ Button.primary, Button.attrs [ Html.Attributes.href "https://github.com/cschank/finsm", Html.Attributes.target "_blank" ] ] [ Html.text "Go!" ] ] - ] - ] - ] - ] - ] - ] diff --git a/src/SharedModel.elm b/src/SharedModel.elm deleted file mode 100644 index 0e76a72..0000000 --- a/src/SharedModel.elm +++ /dev/null @@ -1,77 +0,0 @@ -module SharedModel exposing (MachineType(..), SharedModel, init, machineModeButtons) - -import GraphicSVG exposing (..) -import Helpers exposing (..) -import Machine exposing (Machine) - - -type MachineType - = DFA - | NFA - - -type alias SharedModel = - { machine : Machine - , machineType : MachineType - } - - -init : SharedModel -init = - { machine = Machine.test - , machineType = DFA - } - - -machineModeButtons : MachineType -> Float -> Float -> (MachineType -> msg) -> Shape msg -machineModeButtons mtype winX winY changeMsg = - group - [ group - [ roundedRect 30 15 1 - |> filled - (if mtype == DFA then - finsmLightBlue - - else - blank - ) - |> addOutline (solid 1) darkGray - , text "DFA" - |> centered - |> fixedwidth - |> filled - (if mtype == DFA then - white - - else - darkGray - ) - |> move ( 0, -4 ) - ] - |> move ( -winX / 2 + 20, winY / 2 - 32 ) - |> notifyTap (changeMsg DFA) - , group - [ roundedRect 30 15 1 - |> filled - (if mtype == NFA then - finsmLightBlue - - else - blank - ) - |> addOutline (solid 1) darkGray - , text "NFA" - |> centered - |> fixedwidth - |> filled - (if mtype == NFA then - white - - else - darkGray - ) - |> move ( 0, -4 ) - ] - |> move ( -winX / 2 + 52, winY / 2 - 32 ) - |> notifyTap (changeMsg NFA) - ] diff --git a/src/Simulating.elm b/src/Simulating.elm deleted file mode 100644 index f7933f9..0000000 --- a/src/Simulating.elm +++ /dev/null @@ -1,987 +0,0 @@ -module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), PersistentModel, TapeStatus(..), checkTape, checkTapes, checkTapesNoStatus, delta, deltaHat, epsTrans, initPModel, inputTapeDecoder, inputTapeDictDecoder, inputTapeEncoder, isAccept, latexKeyboard, machineDefn, onEnter, onExit, renderTape, subscriptions, update, view) - -import Array exposing (Array) -import Browser.Events -import Debug -import Dict exposing (Dict) -import Environment exposing (Environment) -import Error exposing (..) -import GraphicSVG exposing (..) -import Helpers exposing (..) -import Json.Decode as D -import Json.Encode as E -import Machine exposing (..) -import Mistakes exposing (..) -import Set exposing (Set) -import SharedModel exposing (..) -import Task -import Tuple exposing (first, second) -import Utils exposing (decodeDict, encodeDict) - - -subscriptions : Model -> Sub Msg -subscriptions model = - Browser.Events.onKeyDown (D.map KeyPressed (D.field "key" D.string)) - - -type alias PersistentModel = - { tapes : Dict Int ( InputTape, TapeStatus ) - , currentStates : Set StateID - } - - -inputTapeEncoder : Dict Int ( InputTape, a ) -> E.Value -inputTapeEncoder = - encodeDict E.int (E.list E.string << Array.toList << Tuple.first) - - -inputTapeDecoder : D.Decoder InputTape -inputTapeDecoder = - D.map Array.fromList - (D.list D.string) - - -inputTapeDictDecoder : D.Decoder (Dict Int InputTape) -inputTapeDictDecoder = - decodeDict D.int inputTapeDecoder - - -type alias InputTape = - Array Character - - -type TapeStatus - = Fresh - | Stale (Set String) - - -type alias HoverError = - Maybe Int - - -type Model - = Default Int {- tapeID -} Int {- charID -} HoverError - | Editing Int - - -type Msg - = Step - | EditTape Int - | DeleteTape Int - | AddNewTape - | ChangeTape Int - | ToggleStart StateID - | KeyPressed String - | ChangeMachine MachineType - | MachineMsg Machine.Msg - | HoverErrorEnter Int - | HoverErrorExit - - -onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) -onEnter env ( pModel, sModel ) = - ( ( Default 0 -1 Nothing - , { pModel - | currentStates = - epsTrans - sModel.machine.transitionNames - sModel.machine.delta - sModel.machine.start - , tapes = checkTapes sModel pModel.tapes - } - , sModel - ) - , False - , Cmd.none - ) - - -onExit : Environment -> ( Model, PersistentModel, SharedModel ) -> ( ( PersistentModel, SharedModel ), Bool ) -onExit env ( model, pModel, sModel ) = - ( ( pModel, sModel ), False ) - - -initPModel : PersistentModel -initPModel = - { tapes = - Dict.fromList - [ ( 0, ( Array.fromList [ "0", "0", "0", "1", "1", "0", "1", "0", "1", "0" ], Fresh ) ) - , ( 1, ( Array.fromList [ "0", "0", "0", "1", "1", "0", "1", "0", "1", "0", "1", "1", "1", "1", "0" ], Fresh ) ) - ] - , currentStates = test.start - } - - -checkTapes : SharedModel -> Dict Int ( InputTape, TapeStatus ) -> Dict Int ( InputTape, TapeStatus ) -checkTapes sModel tapes = - Dict.map (\k ( tape, _ ) -> ( tape, checkTape sModel tape )) tapes - - -checkTapesNoStatus : SharedModel -> Dict Int InputTape -> Dict Int ( InputTape, TapeStatus ) -checkTapesNoStatus sModel tapes = - Dict.map (\k tape -> ( tape, checkTape sModel tape )) tapes - - -checkTape : SharedModel -> InputTape -> TapeStatus -checkTape sModel inp = - let - tNames = - sModel.machine.transitionNames - - allTransitionLabels = - List.foldr Set.union Set.empty <| Dict.values tNames - - arrFilter = - Array.filter (\v -> not <| Set.member v allTransitionLabels) inp - in - case Array.isEmpty arrFilter of - True -> - Fresh - - False -> - Stale <| Set.fromList <| Array.toList arrFilter - - -renderTape : Model -> Array String -> TapeStatus -> Int -> Int -> Int -> Bool -> Shape Msg -renderTape model input tapeSt tapeId selectedId inputAt showButtons = - let - hoverOn = - case model of - Default _ _ (Just errId) -> - if errId == tapeId then - True - - else - False - - _ -> - False - - xpad = - 20 - - errWindow = - group - [ roundedRect 800 30 2 - |> filled white - |> addOutline (solid 1) darkGray - |> move ( 400, 5 ) - , text "This tape has stale transitions. Modify or delete it!" - |> size 25 - |> fixedwidth - |> filled red - ] - in - group <| - Array.toList - (Array.indexedMap - (\n st -> - group - [ square xpad - |> filled white - |> addOutline - (solid 1) - (if tapeSt == Fresh then - black - - else - red - ) - |> move ( 0, 3 ) - , latex (xpad * 0.9) (xpad * 0.7) "white" st AlignCentre - |> move ( 0, 10.25 ) - ] - |> move - ( toFloat n - * xpad - + (if not showButtons then - xpad / 2 - - else - 0 - ) - , 0 - ) - |> notifyTap (ChangeTape tapeId) - ) - input - ) - ++ (if tapeId == selectedId then - [ group - [ triangle 2.25 - |> filled black - |> rotate (degrees 30) - |> move ( 0, xpad / 2 + 5.75 ) - , triangle 2.25 - |> filled black - |> rotate (degrees -30) - |> move ( 0, -xpad / 2 + 0.25 ) - , rect 2 (xpad + 1) - |> filled black - |> move ( 0, 3 ) - ] - |> move ( xpad / 2 + xpad * toFloat inputAt, 0 ) - ] - - else - [] - ) - ++ (if showButtons then - [ group - [ roundedRect 15 15 2 - |> filled white - |> addOutline (solid 1) darkGray - , editIcon - |> scale 1.5 - |> move ( -3, -3 ) - |> repaint black - ] - |> move ( toFloat <| Array.length input * xpad, 3 ) - |> notifyTap (EditTape tapeId) - , group - [ roundedRect 15 15 2 - |> filled white - |> addOutline (solid 1) darkGray - , trashIcon |> scale 0.2 |> move ( 0, -1 ) - ] - |> move ( toFloat <| (Array.length input + 1) * xpad, 3 ) - |> notifyTap (DeleteTape tapeId) - , if not (tapeSt == Fresh) then - group - ([ triangle 20 |> filled red |> rotate 22.5 - , roundedRect 7.5 10 5 |> filled white |> move ( 0, 7.5 ) - , circle 3 |> filled white |> move ( 0, -2.5 ) - ] - ++ (if hoverOn then - [ errWindow ] - - else - [] - ) - ) - |> scale 0.5 - |> move ( toFloat <| (Array.length input + 2) * xpad, 1 ) - |> notifyEnter (HoverErrorEnter tapeId) - |> notifyLeave HoverErrorExit - - else - group [] - ] - - else - [] - ) - - -update : Environment -> Msg -> ( Model, PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) -update env msg ( model, pModel, sModel ) = - let - oldMachine = - sModel.machine - - machineType = - sModel.machineType - in - case msg of - Step -> - case model of - Default tapeId charId hover -> - let - nextCh = - case Dict.get tapeId pModel.tapes of - Just ( ar, tapeStatus ) -> - case Array.get (charId + 1) ar of - Just ch -> - if tapeStatus == Fresh then - ch - - else - "" - - _ -> - "" - - _ -> - "" - in - if nextCh /= "" then - ( ( Default tapeId (charId + 1) hover - , { pModel - | currentStates = - deltaHat oldMachine.transitionNames oldMachine.delta nextCh pModel.currentStates - } - , sModel - ) - , False - , Cmd.none - ) - - else - ( ( model, pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - EditTape tId -> - ( ( Editing tId, pModel, sModel ), False, Cmd.none ) - - DeleteTape tId -> - let - newModel = - case model of - Default tId0 chId hover -> - -- FIXME: choose a good tape to go to - if tId0 == tId then - Default 0 -1 hover - - else - Default tId0 chId hover - - _ -> - model - in - ( ( newModel, { pModel | tapes = Dict.remove tId pModel.tapes }, sModel ), True, Cmd.none ) - - AddNewTape -> - let - newId = - (case List.maximum <| Dict.keys pModel.tapes of - Just n -> - n - - Nothing -> - 0 - ) - + 1 - in - ( ( model, { pModel | tapes = Dict.insert newId ( Array.empty, Fresh ) pModel.tapes }, sModel ), True, Cmd.none ) - - ChangeTape tId -> - ( ( Default tId -1 Nothing {- ??? -}, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta oldMachine.start }, sModel ), False, Cmd.none ) - - KeyPressed k -> - let - normalizedKey = - String.toLower k - in - if normalizedKey == "enter" then - case model of - Editing tId -> - ( ( Default tId -1 Nothing, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta oldMachine.start }, sModel ), True, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - else if normalizedKey == "backspace" || normalizedKey == "arrowleft" then - case model of - Editing tapeId -> - let - newPModel = - { pModel - | tapes = - Dict.update tapeId - (\m -> - case m of - Just ( ar, tapeSt ) -> - let - newTape = - Array.slice 0 -1 ar - - freshSt = - checkTape sModel newTape - in - Just ( Array.slice 0 -1 ar, freshSt ) - - _ -> - m - ) - pModel.tapes - } - in - ( ( model, newPModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - else if normalizedKey == "arrowright" then - case model of - Default _ _ _ -> - ( ( model, pModel, sModel ), False, Task.perform identity (Task.succeed <| Step) ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - else if normalizedKey == "arrowleft" then - case model of - Default tId _ hErr -> - ( ( Default tId -1 hErr, { pModel | currentStates = sModel.machine.start }, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - else - case model of - Editing tapeId -> - let - charCode = - case normalizedKey of - "a" -> - 0 - - "s" -> - 1 - - "d" -> - 2 - - "f" -> - 3 - - "g" -> - 4 - - "h" -> - 5 - - "j" -> - 6 - - "k" -> - 7 - - "l" -> - 8 - - "q" -> - 9 - - "w" -> - 10 - - "e" -> - 11 - - "r" -> - 12 - - "t" -> - 13 - - "y" -> - 14 - - "u" -> - 15 - - "i" -> - 16 - - "o" -> - 17 - - "p" -> - 18 - - "z" -> - 19 - - "x" -> - 20 - - "c" -> - 21 - - "v" -> - 22 - - "b" -> - 23 - - "n" -> - 24 - - "m" -> - 25 - - _ -> - -1 - - chars = - Array.fromList <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values oldMachine.transitionNames - - newChar = - Array.get charCode chars - - newPModel = - { pModel - | tapes = - Dict.update tapeId - (\m -> - case ( m, newChar ) of - ( Just ( ar, tapeSt ), Just ch ) -> - Just ( Array.push ch ar, tapeSt ) - - ( Nothing, Just ch ) -> - Just ( Array.fromList [ ch ], Fresh ) - - _ -> - m - ) - pModel.tapes - } - in - ( ( model, newPModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - ChangeMachine mtype -> - case mtype of - NFA -> - case sModel.machineType of - NFA -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - DFA -> - case model of - Editing tId -> - ( ( Default tId -1 Nothing, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) - - _ -> - ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) - - DFA -> - case sModel.machineType of - DFA -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - NFA -> - let - startState = - if Set.size oldMachine.start > 1 then - Set.singleton <| - (\x -> - case x of - Just val -> - val - - Nothing -> - -1 - ) - <| - List.head <| - Set.toList oldMachine.start - - else - oldMachine.start - - newPModel = - { pModel | currentStates = startState } - - newSModel = - { sModel | machine = { oldMachine | start = startState }, machineType = DFA } - in - case model of - Editing tId -> - ( ( Default tId -1 Nothing, newPModel, newSModel ), True, Cmd.none ) - - _ -> - ( ( model, newPModel, newSModel ), True, Cmd.none ) - - MachineMsg mmsg -> - case mmsg of - StartDragging sId _ -> - ( ( model, pModel, sModel ), False, sendMsg (ToggleStart sId) ) - - TapState sId -> - ( ( model, pModel, sModel ), False, sendMsg (ToggleStart sId) ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - ToggleStart sId -> - let - tests = - oldMachine.start - - newMachine = - case machineType of - NFA -> - { oldMachine - | start = - case Set.member sId oldMachine.start of - True -> - Set.remove sId oldMachine.start - - False -> - Set.insert sId oldMachine.start - } - - DFA -> - { oldMachine - | start = Set.singleton sId - } - in - case model of - Default tId _ _ -> - ( ( Default tId -1 Nothing, { pModel | currentStates = epsTrans oldMachine.transitionNames oldMachine.delta newMachine.start }, { sModel | machine = newMachine } ), True, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - HoverErrorEnter tapeId -> - case model of - Default tId pos _ -> - ( ( Default tId pos (Just tapeId), pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - HoverErrorExit -> - case model of - Default tId pos _ -> - ( ( Default tId pos Nothing, pModel, sModel ), False, Cmd.none ) - - _ -> - ( ( model, pModel, sModel ), False, Cmd.none ) - - -isAccept : Set StateID -> Set StateID -> InputTape -> Int -> Bool -isAccept states finals input inputAt = - if inputAt == Array.length input then - Set.size (Set.intersect states finals) > 0 - - else - False - - -view : Environment -> ( Model, PersistentModel, SharedModel ) -> Shape Msg -view env ( model, pModel, sModel ) = - let - oldMachine = - sModel.machine - - winX = - toFloat <| first env.windowSize - - winY = - toFloat <| second env.windowSize - - transMistakes = - getTransitionMistakes sModel.machine - - chars = - -- This is broken? - Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values oldMachine.transitionNames - - menu = - group <| - [ text "Simulate" - |> size 16 - |> fixedwidth - |> filled black - |> move ( -winX / 2 + 2, winY / 6 - 15 ) - , text "(Click to toggle start state(s), right arrow to scrub through tape)" - |> size 6 - |> fixedwidth - |> filled black - |> move ( -winX / 2 + 85, winY / 6 - 15 ) - , group - [ roundedRect 15 15 2 - |> filled white - |> addOutline (solid 1) darkGray - , text "+" - |> size 16 - |> fixedwidth - |> filled black - |> move ( -4.5, -5 ) - |> notifyTap AddNewTape - ] - |> move ( -winX / 2 + 20, winY / 6 - 35 - 25 * (toFloat <| Dict.size pModel.tapes) ) - , case model of - Default tapeId charId _ -> - group (List.indexedMap (\x ( chId, ( ch, tapeSt ) ) -> renderTape model ch tapeSt chId tapeId charId True |> move ( 0, -(toFloat x) * 25 )) <| Dict.toList tapes) - |> move ( -winX / 2 + 20, winY / 6 - 40 ) - - _ -> - group [] - ] - - tapes = - pModel.tapes - - validCheck = - machineCheck sModel - in - group - [ case model of - Default _ _ _ -> - group - [ rect winX (winY / 3) - |> filled lightGray - , machineDefn sModel sModel.machineType winX winY - , if contextHasError validCheck sModel.machineType then - errorMenu validCheck oldMachine winX winY |> move ( -winX / 2 + 20, winY / 6 ) - - else - menu - ] - |> move ( 0, -winY / 3 ) - - Editing tapeId -> - let - ( tape, tapeSt ) = - case Dict.get tapeId pModel.tapes of - Just ( t, st ) -> - ( t, st ) - - Nothing -> - ( Array.empty, Fresh ) - in - group - [ rect winX (winY / 3) - |> filled lightGray - , text "Edit Tape" - |> size 16 - |> fixedwidth - |> filled black - |> move ( -winX / 2 + 2, winY / 6 - 15 ) - , text "(Type symbols with your keyboard; backspace to delete; enter to accept)" - |> size 6 - |> fixedwidth - |> filled black - |> move ( -winX / 2 + 95, winY / 6 - 15 ) - , latexKeyboard winX winY chars - |> move ( 0, 0 ) - , renderTape model tape tapeSt tapeId -1 -1 False - |> move ( -10 * toFloat (Array.length tape), winY / 6 - 65 ) - ] - |> move ( 0, -winY / 3 ) - , (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine pModel.currentStates transMistakes) |> move ( 0, winY / 6 ) - , machineModeButtons sModel.machineType winX winY ChangeMachine - ] - - -machineDefn : SharedModel -> MachineType -> Float -> Float -> Shape Msg -machineDefn sModel mtype winX winY = - let - machine = - sModel.machine - - getStateName sId = - case Dict.get sId machine.stateNames of - Just n -> - n - - Nothing -> - "\\ " - - machineHeader = - text "Machine" - |> size 16 - |> fixedwidth - |> filled black - |> move ( -winX / 2 + 492, winY / 6 - 15 ) - in - case mtype of - NFA -> - group - [ machineHeader - , latex 500 18 "blank" "let\\ N = (Q,\\Sigma,\\Delta,S,F)" AlignLeft - |> move ( -winX / 2 + 500, winY / 6 - 25 ) - , latex 500 14 "blank" "where" AlignLeft - |> move ( -winX / 2 + 500, winY / 6 - 45 ) - , latex 500 18 "blank" ("Q = \\{ " ++ String.join "," (Dict.values machine.stateNames) ++ " \\}") AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 65 ) - , latex 500 18 "blank" ("\\Sigma = \\{ " ++ String.join "," (Set.toList <| Set.remove "\\epsilon" <| List.foldl Set.union Set.empty <| Dict.values machine.transitionNames) ++ " \\}") AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 90 ) - , latex 500 18 "blank" "\\Delta = (above)" AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 115 ) - , latex 500 18 "blank" ("S = \\{ " ++ String.join "," (List.map getStateName <| Set.toList <| machine.start) ++ " \\}") AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 140 ) - , latex 500 18 "blank" ("F = \\{ " ++ String.join "," (List.map getStateName <| Set.toList <| machine.final) ++ " \\}") AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 165 ) - ] - - DFA -> - group - [ machineHeader - , latex 500 18 "blank" "let\\ M = (Q,\\Sigma,\\delta,s,F)" AlignLeft - |> move ( -winX / 2 + 500, winY / 6 - 25 ) - , latex 500 14 "blank" "where" AlignLeft - |> move ( -winX / 2 + 500, winY / 6 - 45 ) - , latex 500 18 "blank" ("Q = \\{ " ++ String.join "," (Dict.values machine.stateNames) ++ " \\}") AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 65 ) - , latex 500 18 "blank" ("\\Sigma = \\{ " ++ String.join "," (Set.toList <| Set.remove "\\epsilon" <| List.foldl Set.union Set.empty <| Dict.values machine.transitionNames) ++ " \\}") AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 90 ) - , latex 500 18 "blank" "\\delta = (above)" AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 115 ) - , latex 500 - 14 - "blank" - ("s = " - ++ (case Set.toList machine.start of - [] -> - "Please\\ select\\ a\\ start\\ state" - - x :: [] -> - getStateName x - - x :: xs -> - "Congratulations,\\ you\\ found\\ a\\ bug!" - ) - ) - AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 140 ) - , latex 500 18 "blank" ("F = \\{ " ++ String.join "," (List.map getStateName <| Set.toList <| machine.final) ++ " \\}") AlignLeft - |> move ( -winX / 2 + 510, winY / 6 - 160 ) - ] - - -epsTrans : TransitionNames -> Delta -> Set StateID -> Set StateID -epsTrans tNames d states = - let - dList = - (Dict.toList << Dict.filter (\k _ -> Set.member k states)) d - - -- LMD: This was copy-pasted from delta - getName trans = - case Dict.get trans tNames of - Just n -> - renderSet2String n - - _ -> - "" - - findEpsTransitions : List ( StateID, Dict TransitionID StateID ) -> List StateID - findEpsTransitions lst = - case lst of - [] -> - [] - - ( sID, dictTrans ) :: xs -> - let - listTrans = - Dict.toList dictTrans - - epsStates = - List.filterMap - (\( tId, sId ) -> - if getName tId == "\\epsilon" then - Just sId - - else - Nothing - ) - listTrans - in - epsStates ++ findEpsTransitions xs - - newCurrentStates = - Set.union (Set.fromList <| findEpsTransitions dList) states - in - if newCurrentStates == states then - states - - else - epsTrans tNames d newCurrentStates - - -delta : TransitionNames -> Delta -> Character -> StateID -> Set StateID -delta tNames d ch state = - let - getName trans = - case Dict.get trans tNames of - Just n -> - n - - _ -> - Set.empty - in - case Dict.get state d of - Just transMap -> - let - states = - List.filterMap - (\( tId, sId ) -> - if - (Set.member ch <| getName tId) - || ((renderSet2String <| getName tId) == "\\epsilon" && sId == state) - then - Just sId - - else - Nothing - ) - <| - Dict.toList transMap - in - Set.fromList states - - Nothing -> - Set.empty - - -deltaHat : TransitionNames -> Delta -> Character -> Set StateID -> Set StateID -deltaHat tNames d ch states = - let - newStates = - Set.foldl (\curr ss -> Set.union ss (delta tNames d ch curr)) Set.empty states - in - epsTrans tNames d newStates - - -latexKeyboard : Float -> Float -> List Character -> Shape Msg -latexKeyboard w h chars = - let - topRow = - [ 'q', 'w', 'e', 'r', 't', 'y', 'u', 'i', 'o', 'p' ] - - homeRow = - [ 'a', 's', 'd', 'f', 'g', 'h', 'j', 'k', 'l' ] - - botRow = - [ 'z', 'x', 'c', 'v', 'b', 'n', 'm' ] - - keyW = - clamp 0 50 (min (w / 11) (keyH * 1.2)) - - keyH = - h / 18 - - renderKey letter char = - group - [ roundedRect keyW keyH 2 - |> filled white - |> addOutline (solid 0.5) black - , text (String.fromChar letter) - |> fixedwidth - |> size 10 - |> filled (rgb 150 150 150) - |> move ( -keyW / 2 + 2, keyH / 2 - 8 ) - , latex (keyW / 1.5) (keyH / 1.5) "white" char AlignCentre - |> move ( 0, 10 ) - ] - - fillOutExtras n offset chs = - let - newL = - List.take n (List.drop offset chs) - in - newL ++ List.repeat (n - List.length newL) "\\ " - - oneRow letters chs = - group - (List.indexedMap - (\x ( c, l ) -> - renderKey l c - |> move ( (keyW + 2) * (toFloat x - (toFloat <| List.length chs) / 2) + keyW / 2 + w / 33, 0 ) - ) - (List.map2 (\a b -> ( a, b )) chs letters) - ) - in - group - [ oneRow topRow (fillOutExtras 10 9 chars) |> move ( -keyW / 3, 0 ) - , oneRow homeRow (fillOutExtras 9 0 chars) |> move ( -keyW / 3, -keyH - 2 ) - , oneRow botRow (fillOutExtras 7 19 chars) |> move ( -keyW, -(keyH + 2) * 2 ) - ] diff --git a/src/Utils.elm b/src/Utils.elm deleted file mode 100644 index 228c243..0000000 --- a/src/Utils.elm +++ /dev/null @@ -1,81 +0,0 @@ -module Utils exposing (..) - -import Dict exposing (Dict) -import GraphicSVG exposing (..) -import Html exposing (input) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Json.Decode as D -import Json.Encode as E -import Set exposing (Set) -import Task - - -encodePair : (a -> E.Value) -> (b -> E.Value) -> ( a, b ) -> E.Value -encodePair encA encB ( a, b ) = - E.object [ ( "f", encA a ), ( "s", encB b ) ] - - -encodeTriple : (a -> E.Value) -> (b -> E.Value) -> (c -> E.Value) -> ( a, b, c ) -> E.Value -encodeTriple encA encB encC ( a, b, c ) = - E.object [ ( "f", encA a ), ( "s", encB b ), ( "t", encC c ) ] - - -decodeDict : D.Decoder comparable -> D.Decoder value -> D.Decoder (Dict comparable value) -decodeDict decComp decValu = - D.map Dict.fromList <| D.list <| D.map2 Tuple.pair (D.field "k" decComp) (D.field "v" decValu) - - -decodeSet : D.Decoder comparable -> D.Decoder (Set comparable) -decodeSet decComp = - D.map Set.fromList <| D.list decComp - - -decodePair : D.Decoder x -> D.Decoder y -> D.Decoder ( x, y ) -decodePair decX decY = - D.map2 Tuple.pair (D.field "f" decX) (D.field "s" decY) - - -decodeTriple : D.Decoder x -> D.Decoder y -> D.Decoder z -> D.Decoder ( x, y, z ) -decodeTriple decX decY decZ = - D.map3 (\x y z -> ( x, y, z )) (D.field "f" decX) (D.field "s" decY) (D.field "t" decZ) - - -encodeSet : (comparable -> E.Value) -> Set comparable -> E.Value -encodeSet valFn = - E.list valFn << Set.toList - - -encodeDict : (comparable -> E.Value) -> (value -> E.Value) -> Dict comparable value -> E.Value -encodeDict compFn valFn dict = - E.list - (\( k, v ) -> - E.object - [ ( "k", compFn k ) - , ( "v", valFn v ) - ] - ) - <| - Dict.toList dict - - -textBox : String -> Float -> Float -> String -> (String -> msg) -> Shape msg -textBox txt w h place msg = - move ( -w / 2, h / 2 ) <| - html (w * 1.5) (h * 1.5) <| - input - [ id "input" - , placeholder place - , onInput msg - , value txt - , style "width" (String.fromFloat w ++ "px") - , style "height" (String.fromFloat h ++ "px") - , style "margin-top" "1px" - , style "font-family" "monospace" - ] - [] - - -newMsg : msg -> Cmd msg -newMsg msg = - Task.perform identity <| Task.succeed msg diff --git a/tests/Example.elm b/tests/Example.elm deleted file mode 100644 index 38cb2e7..0000000 --- a/tests/Example.elm +++ /dev/null @@ -1,20 +0,0 @@ -module Example exposing (suite) - -import Expect exposing (Expectation) -import Fuzz exposing (Fuzzer, int, list, string) -import Json.Decode as D -import Json.Encode as E -import Machine exposing (test) -import Test exposing (..) - - -suite : Test -suite = - describe "Machine encoder-decoder" - [ Test.test "Self-cancellation of encoding and decoding for V1" <| - \_ -> - Expect.equal (Ok Machine.test) - (D.decodeString Machine.machineDecoder <| - E.encode 0 (Machine.machineEncoder Machine.test) - ) - ]