diff --git a/src/Building.elm b/src/Building.elm index ed7acf0..0773d00 100644 --- a/src/Building.elm +++ b/src/Building.elm @@ -1,5 +1,6 @@ module Building exposing (Model, Msg(..), PersistentModel(..), editingButtons, init, initPModel, onEnter, onExit, subscriptions, update, updateArrowPos, updateStatePos, view) +import Bootstrap.Form.InputGroup exposing (Input) import Browser.Events import Dict exposing (Dict) import Environment exposing (Environment) @@ -9,7 +10,7 @@ import Json.Decode as D import Machine exposing (..) import Mistakes exposing (..) import Set -import SharedModel exposing (MachineType(..), SharedModel, machineModeButtons) +import SharedModel exposing (SharedModel, machineModeButtons) import Task import Tuple exposing (first, second) @@ -32,7 +33,7 @@ type PersistentModel type Msg = MachineMsg Machine.Msg | SaveStateName StateID String - | SaveTransitionName TransitionID String + | SaveTransitionName TransitionID ( String, String, String ) | ToggleStart StateID | ChangeMachine MachineType | AddState ( Float, Float ) @@ -131,16 +132,25 @@ update env msg ( model, pModel, sModel ) = AddingArrowOverOtherState st _ s1 -> let - newTrans = - case List.head <| Dict.values oldMachine.transitionNames of + oldTransitionNames = + oldMachine.transitionNames + + newInputLabel = + case List.head <| Dict.values oldTransitionNames of Just setchar -> - setchar + setchar.inputLabel Nothing -> Set.singleton "x" + newTrans = + { inputLabel = newInputLabel + , stackTop = "\\epsilon" + , stackPush = [ "\\epsilon" ] + } + newTransID = - case List.maximum <| Dict.keys oldMachine.transitionNames of + case List.maximum <| Dict.keys oldTransitionNames of Just n -> n + 1 @@ -148,7 +158,7 @@ update env msg ( model, pModel, sModel ) = 0 isValidTransition = - checkTransitionValid newTrans + checkTransitionValid newInputLabel newDelta : Delta newDelta = @@ -198,16 +208,19 @@ update env msg ( model, pModel, sModel ) = SelectArrow ( s0, tId, s1 ) -> let - oldTransName = + newInpLabel = case Dict.get tId sModel.machine.transitionNames of Just n -> - renderSet2String n + ( renderSet2String n.inputLabel, n.stackTop, showStackPush n.stackPush ) Nothing -> - "" + ( "", "\\epsilon", "\\epsilon" ) + + newLab = + newInpLabel in if env.holdingShift then - ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), False, focusInput NoOp ) + ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) newLab }, pModel, sModel ), False, focusInput NoOp ) else ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), False, Cmd.none ) @@ -344,15 +357,32 @@ update env msg ( model, pModel, sModel ) = in ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) - EditLabel _ lbl -> + EditStateLabel st lbl -> let newState = case model.machineState of - EditingStateLabel st _ -> + EditingStateLabel _ _ -> EditingStateLabel st lbl - EditingTransitionLabel tr _ -> - EditingTransitionLabel tr lbl + _ -> + model.machineState + in + ( ( { model | machineState = newState }, pModel, sModel ), False, Cmd.none ) + + EditTransitionLabel tr0 lblTy lbl -> + let + newState = + case model.machineState of + EditingTransitionLabel tr ( oldInpLbl, oldStkTop, oldStkPush ) -> + case lblTy of + InputLabel -> + EditingTransitionLabel tr ( lbl, oldStkTop, oldStkPush ) + + StackTop -> + EditingTransitionLabel tr ( oldInpLbl, lbl, oldStkPush ) + + StackPush -> + EditingTransitionLabel tr ( oldInpLbl, oldStkTop, lbl ) _ -> model.machineState @@ -388,6 +418,9 @@ update env msg ( model, pModel, sModel ) = DFA -> ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) + NPDA -> + ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) + DFA -> case sModel.machineType of DFA -> @@ -418,6 +451,20 @@ update env msg ( model, pModel, sModel ) = in ( ( model, pModel, newSModel ), True, Cmd.none ) + NPDA -> + ( ( model, pModel, { sModel | machineType = DFA } ), False, Cmd.none ) + + NPDA -> + case sModel.machineType of + DFA -> + ( ( model, pModel, { sModel | machineType = NPDA } ), False, Cmd.none ) + + NFA -> + ( ( model, pModel, { sModel | machineType = NPDA } ), False, Cmd.none ) + + NPDA -> + ( ( model, pModel, sModel ), False, Cmd.none ) + AddState ( x, y ) -> case model.machineState of Regular -> @@ -467,16 +514,36 @@ update env msg ( model, pModel, sModel ) = oldTransitionName = case Dict.get tId oldMachine.transitionNames of Just n -> - renderSet2String n + ( renderSet2String n.inputLabel, n.stackTop, showStackPush n.stackPush ) _ -> - "" + ( "", "\\epsilon", "\\epsilon" ) in - if newLbl == oldTransitionName || newLbl == "" then - ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), False, Cmd.none ) + case sModel.machineType of + DFA -> + if fst newLbl == fst oldTransitionName || fst 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 ) + else + ( ( { model | machineState = SelectedArrow ( s0, tId, s1 ) }, pModel, sModel ), True, sendMsg <| SaveTransitionName tId newLbl ) + + NFA -> + if fst newLbl == fst oldTransitionName || fst 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 ) + + NPDA -> + if + (fst newLbl == fst oldTransitionName || fst newLbl == "") + && (snd newLbl == snd oldTransitionName || snd newLbl == "\\epsilon") + && (thd newLbl == thd oldTransitionName || thd newLbl == "\\epsilon") + 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 @@ -494,11 +561,11 @@ update env msg ( model, pModel, sModel ) = let oldTransName = case Dict.get tId sModel.machine.transitionNames of - Just n -> - renderSet2String n + Just label -> + ( renderSet2String label.inputLabel, label.stackTop, String.concat label.stackPush ) Nothing -> - "" + ( "", "\\epsilon", "\\epsilon" ) in ( ( { model | machineState = EditingTransitionLabel ( s0, tId, s1 ) oldTransName }, pModel, sModel ), False, focusInput NoOp ) @@ -633,6 +700,11 @@ update env msg ( model, pModel, sModel ) = { oldMachine | start = Set.singleton sId } + + NPDA -> + { oldMachine + | start = Set.singleton sId + } in ( ( model, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) @@ -643,17 +715,30 @@ update env msg ( model, pModel, sModel ) = in ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) - SaveTransitionName tId newLbl -> + SaveTransitionName tId ( inpLabel, stkTop, stkPush ) -> let newTransitions = - parseString2Set newLbl + parseString2Set inpLabel + + newLabel = + { inputLabel = newTransitions + , stackTop = + if stkTop == "" then + "\\epsilon" + + else + stkTop + , stackPush = + if stkPush == "" then + [ "\\epsilon" ] - isValidTransition = - checkTransitionValid newTransitions + else + parseStackPush stkPush + } newMachine = { oldMachine - | transitionNames = Dict.insert tId newTransitions oldMachine.transitionNames + | transitionNames = Dict.insert tId newLabel oldMachine.transitionNames } in ( ( { model | machineState = Regular }, pModel, { sModel | machine = newMachine } ), True, Cmd.none ) @@ -740,7 +825,7 @@ view env ( model, pModel, sModel ) = _ -> group [] - , GraphicSVG.map MachineMsg <| Machine.view env model.machineState sModel.machine Set.empty transMistakes + , GraphicSVG.map MachineMsg <| Machine.view env model.machineState sModel.machineType sModel.machine Set.empty transMistakes , editingButtons model |> move ( winX / 2 - 30, -winY / 2 + 25 ) , machineModeButtons sModel.machineType winX winY ChangeMachine ] @@ -838,3 +923,13 @@ snapIcon = ] |> move ( 5, -10 ) ] + + +parseStackPush : String -> List String +parseStackPush = + String.split " " + + +showStackPush : List String -> String +showStackPush = + String.join " " diff --git a/src/Error.elm b/src/Error.elm index f242cb0..33fefa5 100644 --- a/src/Error.elm +++ b/src/Error.elm @@ -8,7 +8,7 @@ import Dict exposing (Dict) import Environment exposing (Environment) import GraphicSVG exposing (..) import Helpers exposing (..) -import Machine exposing (Machine, StateID, TransitionID) +import Machine exposing (Machine, MachineType(..), StateID, TransitionID) import Mistakes exposing (..) import Set exposing (Set) import SharedModel exposing (..) @@ -50,6 +50,17 @@ contextHasError err mtype = _ -> False + NPDA -> + case err of + EpsTransError -> + True + + DuplicateStates _ -> + True + + _ -> + False + machineCheck : SharedModel -> Error machineCheck sModel = @@ -61,7 +72,7 @@ machineCheck sModel = getTransitionMistakes mac allTransitionLabels = - List.sort <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values mac.transitionNames + List.sort <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| List.map .inputLabel <| Dict.values mac.transitionNames catch : Maybe (Set String) -> List String catch ms = @@ -74,7 +85,7 @@ machineCheck sModel = getTrans : Dict TransitionID StateID -> List String getTrans d = - (List.concatMap (\e -> Dict.get e mac.transitionNames |> catch) <| Dict.keys d) |> List.sort + (List.concatMap (\e -> Dict.get e mac.transitionNames |> Maybe.map .inputLabel |> catch) <| Dict.keys d) |> List.sort foldingFunc : ( StateID, Dict TransitionID StateID ) -> Error -> Error foldingFunc sTuple err = diff --git a/src/Exporting.elm b/src/Exporting.elm index 97d05e8..5c4b39a 100644 --- a/src/Exporting.elm +++ b/src/Exporting.elm @@ -141,7 +141,7 @@ view env ( model, pModel, sModel ) = |> move ( winX / 6 - 100, -105 ) in group - [ (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machine Set.empty transMistakes) |> move ( -winX / 6, 0 ) + [ (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machineType sModel.machine Set.empty transMistakes) |> move ( -winX / 6, 0 ) , machineSelected sModel.machineType winX winY , text "Choose format:" |> size 20 @@ -164,7 +164,7 @@ view env ( model, pModel, sModel ) = group [] , case ( model, pModel.outputType ) of ( ShowingOutput, Tikz ) -> - output (winX / 2) (winY / 2) (generateTikz pModel.time sModel.machine) + output (winX / 2) (winY / 2) (generateTikz pModel.time sModel.machine sModel.machineType) _ -> group [] @@ -181,6 +181,9 @@ machineSelected mtype winX winY = NFA -> "NFA" + + NPDA -> + "NPDA" in text ("Your exported machine type: " ++ mtypeStr) |> centered @@ -296,8 +299,8 @@ output w h txt = ] -generateTikz : Int -> Machine -> String -generateTikz time machine = +generateTikz : Int -> Machine -> MachineType -> String +generateTikz time machine macType = let scale = 40 @@ -361,7 +364,12 @@ generateTikz time machine = transitionName = case Dict.get tId machine.transitionNames of Just n -> - renderSet2String n + case macType of + NPDA -> + renderSet2String n.inputLabel ++ ";" ++ n.stackTop ++ ";" ++ String.join " " n.stackPush + + _ -> + renderSet2String n.inputLabel _ -> "" diff --git a/src/Helpers.elm b/src/Helpers.elm index 95deb14..ab49913 100644 --- a/src/Helpers.elm +++ b/src/Helpers.elm @@ -1,4 +1,4 @@ -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) +module Helpers exposing (..) import Browser.Dom as Dom import GraphicSVG exposing (..) @@ -89,6 +89,17 @@ trashIcon = ] +thickRightArrowIcon = + group + [ rect 30 25 + |> filled black + |> move ( -10, 0 ) + , triangle 25 + |> filled black + |> move ( 10, 0 ) + ] + + type LatexAlign = AlignLeft | AlignRight @@ -323,6 +334,19 @@ labelPosition y1 theta = Above +isPrefixOf : List a -> List a -> Bool +isPrefixOf xs ys = + case ( xs, ys ) of + ( [], _ ) -> + True + + ( _, [] ) -> + False + + ( x :: xs1, y :: ys1 ) -> + x == y && isPrefixOf xs1 ys1 + + roundTo : Float -> Float -> Float roundTo n m = Basics.toFloat (round (m + n / 2) // round n * round n) @@ -331,3 +355,33 @@ roundTo n m = roundPrec : Int -> Float -> Float roundPrec n m = Basics.toFloat (round (m * Basics.toFloat (10 ^ n))) / Basics.toFloat (10 ^ n) + + +fst : ( a, b, c ) -> a +fst ( a, b, c ) = + a + + +snd : ( a, b, c ) -> b +snd ( a, b, c ) = + b + + +thd : ( a, b, c ) -> c +thd ( a, b, c ) = + c + + +mapFst : (a -> d) -> ( a, b, c ) -> ( d, b, c ) +mapFst f ( a, b, c ) = + ( f a, b, c ) + + +mapSnd : (b -> d) -> ( a, b, c ) -> ( a, d, c ) +mapSnd f ( a, b, c ) = + ( a, f b, c ) + + +mapThd : (c -> d) -> ( a, b, c ) -> ( a, b, d ) +mapThd f ( a, b, c ) = + ( a, b, f c ) diff --git a/src/Machine.elm b/src/Machine.elm index 2108c26..614c51d 100644 --- a/src/Machine.elm +++ b/src/Machine.elm @@ -10,7 +10,7 @@ import Html.Events exposing (onInput) import Json.Decode as D import Json.Encode as E import Set exposing (Set) -import Utils exposing (decodeDict, decodePair, decodeSet, decodeTriple, encodeDict, encodePair, encodeSet, encodeTriple, textBox) +import Utils exposing (decodeDict, decodePair, decodeSet, decodeTriple, encodeDict, encodePair, encodeSet, encodeTriple, textBox, textBox3) type alias StateID = @@ -30,7 +30,20 @@ type alias StateNames = type alias TransitionNames = - Dict TransitionID (Set String) + Dict TransitionID TransitionLabel + + +type alias TransitionLabel = + { inputLabel : Set String + , stackTop : String + , stackPush : List String + } + + +type LabelEditType + = InputLabel + | StackTop + | StackPush type alias StateTransitions = @@ -49,6 +62,58 @@ type alias TransitionMistakes = Maybe (Set TransitionID) +type alias Machine = + { q : Set StateID + , delta : Delta + , start : Set StateID + , final : Set StateID + , statePositions : StatePositions + , stateTransitions : StateTransitions + , stateNames : StateNames + , transitionNames : TransitionNames + } + + +type MachineType + = DFA + | NFA + | NPDA + + +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, String, 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 + | EditTransitionLabel TransitionID LabelEditType String + | EditStateLabel StateID String + | Drag ( Float, Float ) + | TapState StateID + | StopDragging + | Reset + + machineEncoder : Machine -> E.Value machineEncoder = machineEncoderV1 @@ -88,9 +153,17 @@ machineEncoderV1 machine = stateNamesEncoder = encodeDict E.int E.string + transitionLabelEncoder : TransitionLabel -> E.Value + transitionLabelEncoder tLabel = + E.object + [ ( "inputLabel", encodeSet E.string tLabel.inputLabel ) + , ( "stackTop", E.string tLabel.stackTop ) + , ( "stackPush", E.list E.string tLabel.stackPush ) + ] + transNamesEncoder : TransitionNames -> E.Value transNamesEncoder = - encodeDict E.int (encodeSet E.string) + encodeDict E.int transitionLabelEncoder in E.object [ ( "q", qEncoder machine.q ) @@ -155,7 +228,7 @@ machineDecoderV1 = transNamesDecoder : D.Decoder TransitionNames transNamesDecoder = - D.field "transNames" <| decodeDict D.int (decodeSet D.string) + D.field "transNames" <| decodeDict D.int (D.map3 TransitionLabel (decodeSet D.string) D.string (D.list D.string)) in D.map8 Machine qDecoder @@ -168,51 +241,6 @@ machineDecoderV1 = 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 @@ -240,7 +268,17 @@ test = 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" ) ] + Dict.fromList <| + List.map (\( k, str ) -> ( k, { inputLabel = Set.singleton str, stackTop = "\\epsilon", stackPush = [ "\\epsilon" ] } )) + [ ( 0, "1" ) + , ( 1, "0" ) + , ( 2, "1" ) + , ( 3, "0" ) + , ( 4, "1" ) + , ( 5, "0" ) + , ( 6, "1" ) + , ( 7, "0" ) + ] stateTransitions = Dict.fromList @@ -257,8 +295,62 @@ test = Machine q delta0 start final statePositions stateTransitions stateNames transitionNames -view : Environment -> Model -> Machine -> Set StateID -> TransitionMistakes -> Shape Msg -view env model machine currentStates tMistakes = + +{- + machine: { delta = Dict.fromList [(1,Dict.fromList [(0,1),(1,1),(2,1),(3,1)])], + final = Set.fromList [], + q = Set.fromList [1], + start = Set.fromList [], + stateNames = Dict.fromList [(1,"q_{1}")], + statePositions = Dict.fromList [(1,(18,-53))], + stateTransitions = Dict.fromList [((1,0,1),(-86,0)),((1,1,1),(-2,-61)),((1,2,1),(79,4)),((1,3,1),(0,50))], + transitionNames = Dict.fromList [(0,{ inputLabel = Set.fromList ["]"], stackPush = "", stackTop = "[" }),(1,{ inputLabel = Set.fromList [], stackPush = "", stackTop = "Z" }),(2,{ inputLabel = Set.fromList ["["], stackPush = "[[", stackTop = "[" }),(3,{ inputLabel = Set.fromList ["["], stackPush = "Z[", stackTop = "Z" })] } +-} + + +testNPDA : Machine +testNPDA = + let + q = + Set.fromList [ 0 ] + + delta0 = + Dict.fromList + [ ( 0, Dict.fromList [ ( 0, 0 ), ( 1, 0 ), ( 2, 0 ), ( 3, 0 ) ] ) ] + + start = + Set.fromList [ 0 ] + + final = + Set.fromList [] + + statePositions = + Dict.fromList [ ( 0, ( 0, 0 ) ) ] + + stateNames = + Dict.fromList [ ( 0, "q_0" ) ] + + transitionNames = + Dict.fromList <| + [ ( 0, { inputLabel = Set.singleton "[", stackTop = "\\bot", stackPush = [ "[", "\\bot" ] } ) + , ( 1, { inputLabel = Set.singleton "[", stackTop = "[", stackPush = [ "[", "[" ] } ) + , ( 2, { inputLabel = Set.singleton "]", stackTop = "[", stackPush = [ "\\epsilon" ] } ) + , ( 3, { inputLabel = Set.singleton "\\epsilon", stackTop = "\\bot", stackPush = [ "\\epsilon" ] } ) + ] + + stateTransitions = + Dict.fromList + [ ( ( 0, 0, 0 ), ( 0, 70 ) ) + , ( ( 0, 1, 0 ), ( 0, -70 ) ) + , ( ( 0, 2, 0 ), ( 70, 0 ) ) + , ( ( 0, 3, 0 ), ( -70, 0 ) ) + ] + in + Machine q delta0 start final statePositions stateTransitions stateNames transitionNames + + +view : Environment -> Model -> MachineType -> Machine -> Set StateID -> TransitionMistakes -> Shape Msg +view env model macType machine currentStates tMistakes = let ( winX, winY ) = env.windowSize @@ -270,7 +362,7 @@ view env model machine currentStates tMistakes = |> notifyMouseUp StopDragging in group - [ renderArrows machine model tMistakes + [ renderArrows macType machine model tMistakes , renderStates currentStates machine model env , case model of AddingArrow s ( x, y ) -> @@ -284,12 +376,30 @@ view env model machine currentStates tMistakes = ( 0, 0 ) newTrans = - case List.head <| Dict.values machine.transitionNames of - Just schar -> - Set.toList schar |> renderString + case macType of + DFA -> + case List.head <| Dict.values machine.transitionNames of + Just tLabel -> + renderSet2String tLabel.inputLabel - Nothing -> - " " + Nothing -> + " " + + NFA -> + case List.head <| Dict.values machine.transitionNames of + Just tLabel -> + renderSet2String tLabel.inputLabel + + Nothing -> + " " + + NPDA -> + case List.head <| Dict.values machine.transitionNames of + Just tLabel -> + renderSet2String tLabel.inputLabel ++ ";" ++ tLabel.stackTop ++ ";" ++ String.concat tLabel.stackPush + + Nothing -> + " " newTransID = case List.head <| Dict.keys machine.transitionNames of @@ -299,7 +409,7 @@ view env model machine currentStates tMistakes = Nothing -> 0 in - renderArrow s0Pos ( 0, 0 ) ( x, y ) 20 0 newTrans newTransID False False s -1 model + renderArrow macType s0Pos ( 0, 0 ) ( x, y ) 20 0 newTrans newTransID False False s -1 model AddingArrowOverOtherState s ( x, y ) s1 -> let @@ -320,12 +430,30 @@ view env model machine currentStates tMistakes = ( 0, 0 ) newTrans = - case List.head <| Dict.values machine.transitionNames of - Just schar -> - Set.toList schar |> renderString + case macType of + DFA -> + case List.head <| Dict.values machine.transitionNames of + Just tLabel -> + renderSet2String tLabel.inputLabel - Nothing -> - " " + Nothing -> + " " + + NFA -> + case List.head <| Dict.values machine.transitionNames of + Just tLabel -> + renderSet2String tLabel.inputLabel + + Nothing -> + " " + + NPDA -> + case List.head <| Dict.values machine.transitionNames of + Just tLabel -> + renderSet2String tLabel.inputLabel ++ ";" ++ tLabel.stackTop ++ ";" ++ String.concat tLabel.stackPush + + Nothing -> + " " newTransID = case List.head <| Dict.keys machine.transitionNames of @@ -342,7 +470,7 @@ view env model machine currentStates tMistakes = else ( 0, 0 ) in - renderArrow s0Pos pullPos s1Pos 20 20 newTrans newTransID False False s s1 model + renderArrow macType s0Pos pullPos s1Pos 20 20 newTrans newTransID False False s s1 model _ -> group [] @@ -389,7 +517,8 @@ arrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) = renderArrow : - ( Float, Float ) + MachineType + -> ( Float, Float ) -> ( Float, Float ) -> ( Float, Float ) -> Float @@ -402,7 +531,7 @@ renderArrow : -> StateID -> Model -> Shape Msg -renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) r0 r1 char charID sel mistake s1 s2 model = +renderArrow macType ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) r0 r1 char charID sel mistake s1 s2 model = let ( tx, ty ) = --tangent between to and from states @@ -508,18 +637,46 @@ renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) r0 r1 char charID sel mistake s1 s2 |> notifyMouseDown (SelectArrow ( s1, charID, s2 )) , group [ case model of - EditingTransitionLabel ( _, tId, _ ) str -> + EditingTransitionLabel ( _, tId, _ ) ( lab, stkTop, stkPush ) -> if tId == charID then - textBox str - (if String.length str == 0 then - 40 - - else - 8 * toFloat (String.length str) + 5 - ) - 20 - "LaTeX" - (EditLabel tId) + case macType of + DFA -> + textBox lab + (if String.length lab == 0 then + 40 + + else + 8 * toFloat (String.length lab) + 5 + ) + 20 + "LaTeX" + (EditTransitionLabel tId InputLabel) + + NFA -> + textBox lab + (if String.length lab == 0 then + 40 + + else + 8 * toFloat (String.length lab) + 5 + ) + 20 + "LaTeX" + (EditTransitionLabel tId InputLabel) + + NPDA -> + textBox3 ( lab, stkTop, stkPush ) + (if List.any ((==) 0) <| List.map String.length [ lab, stkTop, stkPush ] then + 80 + + else + 8 * toFloat (List.foldl max 0 <| List.map String.length [ lab, stkTop, stkPush ]) + 5 + ) + 20 + ( "inputLabel", "stackTop", "stackPush" ) + (EditTransitionLabel tId InputLabel) + (EditTransitionLabel tId StackTop) + (EditTransitionLabel tId StackPush) else latex tLblW @@ -587,8 +744,8 @@ renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) r0 r1 char charID sel mistake s1 s2 ] -renderArrows : Machine -> Model -> TransitionMistakes -> Shape Msg -renderArrows machine model tMistakes = +renderArrows : MachineType -> Machine -> Model -> TransitionMistakes -> Shape Msg +renderArrows macType machine model tMistakes = let states = machine.q @@ -652,10 +809,18 @@ renderArrows machine model tMistakes = ch = case Dict.get chId machine.transitionNames of - Just setc -> - Set.toList setc |> renderString + Just tLabel -> + case macType of + DFA -> + renderSet2String tLabel.inputLabel - _ -> + NFA -> + renderSet2String tLabel.inputLabel + + NPDA -> + renderSet2String tLabel.inputLabel ++ ";" ++ tLabel.stackTop ++ ";" ++ String.join " " tLabel.stackPush + + Nothing -> "" sel = @@ -683,7 +848,7 @@ renderArrows machine model tMistakes = getTransMistake tMistakes chId in group - [ renderArrow ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) 20 20 ch chId sel mistake s1 s2 model + [ renderArrow macType ( x0, y0 ) ( x1, y1 ) ( x2, y2 ) 20 20 ch chId sel mistake s1 s2 model ] ) [ ss ] @@ -770,7 +935,7 @@ renderStates currentStates machine model env = ) 20 "LaTeX" - (EditLabel sId) + (EditStateLabel sId) else group @@ -851,3 +1016,11 @@ renderStates currentStates machine model env = ) ) stateList + + +emptyLabel : TransitionLabel +emptyLabel = + { inputLabel = Set.empty + , stackTop = "\\epsilon" + , stackPush = [ "\\epsilon" ] + } diff --git a/src/Main.elm b/src/Main.elm index 21f9aaf..5453443 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -70,7 +70,7 @@ initAppModel = initAppRecord = { appState = Building Building.init , sharedModel = SharedModel.init - , simulatingData = Simulating.initPModel + , simulatingData = Simulating.initPModel SharedModel.init.machineType , buildingData = Building.initPModel , exportingData = Exporting.initPModel } @@ -416,7 +416,7 @@ update msg model = { initSharedModel | machine = loadPayload.machine } initSimModel = - Simulating.initPModel + Simulating.initPModel initSharedModel.machineType --{ appState = Building Building.init --, sharedModel = SharedModel.init @@ -467,7 +467,7 @@ update msg model = fresh { initAppRecord | sharedModel = newSharedModel - , simulatingData = initSimModel + , simulatingData = initSimModel newSharedModel.machineType } in ( { model diff --git a/src/Mistakes.elm b/src/Mistakes.elm index 1e64268..e4bd415 100644 --- a/src/Mistakes.elm +++ b/src/Mistakes.elm @@ -16,6 +16,7 @@ getTransitionMistakes mac = -- Check if an epsilon label is well-typed +-- TODO: Check if this should be generalized to NPDAs checkEpsilonTransLabel : TransitionNames -> TransitionMistakes @@ -23,8 +24,8 @@ checkEpsilonTransLabel tNames = let tMistakes = Dict.foldl - (\tid tnames tmistakes -> - if not (checkTransitionValid tnames) then + (\tid tLabel tmistakes -> + if not (checkTransitionValid tLabel.inputLabel) then Set.insert tid tmistakes else diff --git a/src/SaveLoad.elm b/src/SaveLoad.elm index b31e538..b9dd318 100644 --- a/src/SaveLoad.elm +++ b/src/SaveLoad.elm @@ -1045,7 +1045,7 @@ renderNew loginStatus = [ Grid.col [] [ Card.deck [ Card.config [] - |> Card.headerH3 [] [ Html.text "DFA / NFA" ] + |> Card.headerH3 [] [ Html.text "DFA / NFA / NPDA" ] |> Card.block [] [ Block.text [] [ Html.text "Create a new Finite State Machine." ] ] |> Card.footer [] diff --git a/src/SharedModel.elm b/src/SharedModel.elm index 0e76a72..53e949a 100644 --- a/src/SharedModel.elm +++ b/src/SharedModel.elm @@ -1,13 +1,8 @@ -module SharedModel exposing (MachineType(..), SharedModel, init, machineModeButtons) +module SharedModel exposing (SharedModel, init, machineModeButtons) import GraphicSVG exposing (..) import Helpers exposing (..) -import Machine exposing (Machine) - - -type MachineType - = DFA - | NFA +import Machine exposing (Machine, MachineType(..)) type alias SharedModel = @@ -74,4 +69,28 @@ machineModeButtons mtype winX winY changeMsg = ] |> move ( -winX / 2 + 52, winY / 2 - 32 ) |> notifyTap (changeMsg NFA) + , group + [ roundedRect 40 15 1 + |> filled + (if mtype == NPDA then + finsmLightBlue + + else + blank + ) + |> addOutline (solid 1) darkGray + , text "NPDA" + |> centered + |> fixedwidth + |> filled + (if mtype == NPDA then + white + + else + darkGray + ) + |> move ( 0, -4 ) + ] + |> move ( -winX / 2 + 89, winY / 2 - 32 ) + |> notifyTap (changeMsg NPDA) ] diff --git a/src/Simulating.elm b/src/Simulating.elm index f7933f9..d4b827a 100644 --- a/src/Simulating.elm +++ b/src/Simulating.elm @@ -2,7 +2,6 @@ module Simulating exposing (HoverError, InputTape, Model(..), Msg(..), Persisten import Array exposing (Array) import Browser.Events -import Debug import Dict exposing (Dict) import Environment exposing (Environment) import Error exposing (..) @@ -10,10 +9,12 @@ import GraphicSVG exposing (..) import Helpers exposing (..) import Json.Decode as D import Json.Encode as E +import List exposing (..) import Machine exposing (..) import Mistakes exposing (..) import Set exposing (Set) import SharedModel exposing (..) +import String exposing (replace) import Task import Tuple exposing (first, second) import Utils exposing (decodeDict, encodeDict) @@ -27,6 +28,7 @@ subscriptions model = type alias PersistentModel = { tapes : Dict Int ( InputTape, TapeStatus ) , currentStates : Set StateID + , npdaAcceptCond : AcceptCond } @@ -55,17 +57,43 @@ type TapeStatus | Stale (Set String) +type alias Configuration = + { stack : Stack + , state : StateID + , status : ConfigStatus + , tapePos : Int + } + + +type ConfigStatus + = Alive + | Success + | Deadend + + +type AcceptCond + = EmptyStack + | FinalState + + type alias HoverError = Maybe Int +type alias Stack = + List String + + type Model = Default Int {- tapeID -} Int {- charID -} HoverError + -- | Running Int {- tapeID -} Int {- charID -} -- TODO: Decide if want to standardize simulation to a separate bottom menu screen + | RunningNPDA (List Configuration) Int {- tapeID -} Int {- paginate start point -} | Editing Int type Msg = Step + | RunTape Int | EditTape Int | DeleteTape Int | AddNewTape @@ -73,9 +101,12 @@ type Msg | ToggleStart StateID | KeyPressed String | ChangeMachine MachineType + | ChangeNPDAAcceptCond AcceptCond | MachineMsg Machine.Msg | HoverErrorEnter Int | HoverErrorExit + | IncrementPaginateCounter + | DecrementPaginateCounter onEnter : Environment -> ( PersistentModel, SharedModel ) -> ( ( Model, PersistentModel, SharedModel ), Bool, Cmd Msg ) @@ -101,14 +132,25 @@ onExit env ( model, pModel, sModel ) = ( ( pModel, sModel ), False ) -initPModel : PersistentModel -initPModel = +designatedStart : Set StateID -> StateID +designatedStart setStart = + case Set.toList setStart of + [] -> + 0 + + startState :: _ -> + startState + + +initPModel : MachineType -> PersistentModel +initPModel macType = { 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 + , npdaAcceptCond = EmptyStack } @@ -129,7 +171,7 @@ checkTape sModel inp = sModel.machine.transitionNames allTransitionLabels = - List.foldr Set.union Set.empty <| Dict.values tNames + List.foldr (Set.union << .inputLabel) Set.empty <| Dict.values tNames arrFilter = Array.filter (\v -> not <| Set.member v allTransitionLabels) inp @@ -142,8 +184,189 @@ checkTape sModel inp = 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 = +renderConfigs : Machine -> Model -> Array String -> Int -> Int -> Float -> List Configuration -> Shape Msg +renderConfigs machine model input paginateStart tapeId winX cfgs = + paginateConfigs paginateStart winX <| List.map (renderConfig machine model input tapeId) cfgs + + +paginateConfigs : Int -> Float -> List ( Shape Msg, Float ) -> Shape Msg +paginateConfigs paginateStart winX cfgWithLengths = + let + ( cfgs, lengths ) = + List.unzip cfgWithLengths + + totalConfigs = + List.length cfgs + + ( cfgArr, lengthArr ) = + ( Array.fromList cfgs, Array.fromList lengths ) + + spacing = + 10 + + totalSpacing = + toFloat <| spacing * totalConfigs + + totalCfgLength = + List.sum lengths + totalSpacing + + initLeftPos = + winX / 2 - 50 + + shiftAmountByIdx lengthList = + first <| List.foldl (\a acc -> ( second acc :: first acc, a + second acc + spacing )) ( [], 0 ) (List.reverse lengthList) + + findEndPaginateIndex start curLength = + case Array.get start lengthArr of + Nothing -> + start + + Just cfgLen -> + if curLength + cfgLen + spacing > winX then + start + + else + findEndPaginateIndex (start + 1) (curLength + cfgLen + spacing) + + paginateEnd = + findEndPaginateIndex paginateStart 0 + + paginateLeftButton = + if paginateStart <= 0 then + group [ circle 20 |> filled darkGrey, triangle 10 |> filled black |> rotate (degrees 180) ] + + else + group [ circle 20 |> filled white, triangle 10 |> filled black |> rotate (degrees 180) ] |> notifyTap DecrementPaginateCounter + + paginateRightButton = + if paginateEnd == totalConfigs then + group [ circle 20 |> filled darkGrey, triangle 10 |> filled black ] |> move ( 50, 0 ) + + else + group [ circle 20 |> filled white, triangle 10 |> filled black ] |> move ( 50, 0 ) |> notifyTap IncrementPaginateCounter + + paginateButtons = + group [ paginateLeftButton, paginateRightButton ] |> move ( -initLeftPos, 100 ) + + paginateInfo = + text ("Showing (" ++ String.fromInt paginateStart ++ ", " ++ String.fromInt paginateEnd ++ ") from a total of " ++ String.fromInt (List.length cfgs) ++ " configurations") + |> size 12 + |> fixedwidth + |> filled black + |> move ( -initLeftPos - 20, 140 ) + in + if totalCfgLength <= winX then + group <| List.map2 (\cfg moveAmt -> cfg |> move ( -initLeftPos + moveAmt, 0 )) cfgs (shiftAmountByIdx lengths) + + else + group + [ group <| + List.map2 (\cfg moveAmt -> cfg |> move ( -initLeftPos + moveAmt, 0 )) + (Array.toList <| Array.slice paginateStart paginateEnd cfgArr) + (shiftAmountByIdx <| Array.toList <| Array.slice paginateStart paginateEnd lengthArr) + , paginateButtons + , paginateInfo + ] + + +renderConfig : Machine -> Model -> Array String -> Int -> Configuration -> ( Shape Msg, Float ) +renderConfig machine model input tapeId cfg = + let + xpad = + 50 + + tapeLength = + Array.length input + + stackLength = + List.length cfg.stack + + stateName = + case Dict.get cfg.state machine.stateNames of + Just n -> + n + + _ -> + "" + + statusColour = + case cfg.status of + Success -> + green + + Deadend -> + red + + _ -> + blank + + renderedState = + group + [ circle 20 + |> filled statusColour + |> addOutline (solid 1) black + , latex 25 18 "none" stateName AlignCentre + |> move ( 0, 9 ) + ] + + configLength = + max 100 <| toFloat (max (xpad * tapeLength) (xpad * stackLength)) / 2 + + renderedStack = + renderStack cfg.stack + + renderedTape = + renderTape model NPDA input Fresh tapeId tapeId cfg.tapePos False + + cfgLength = + 50 + configLength + + outerBox = + rectangle (50 + configLength) 150 + |> outlined (solid 5) black + |> move ( configLength / 2, -25 ) + in + ( group + [ outerBox + , renderedState + , renderedStack |> move ( 0, -50 ) + , renderedTape |> move ( 25, 0 ) + ] + , cfgLength + ) + + +renderStack : Stack -> Shape Msg +renderStack stk = + let + xpad = + 20 + in + group + (List.indexedMap + (\n st -> + group + [ square xpad + |> filled white + |> addOutline + (solid 1) + black + |> move ( 0, 3 ) + , latex (xpad * 0.9) (xpad * 0.7) "white" st AlignCentre + |> move ( 0, 10.25 ) + ] + |> move + ( toFloat n + * xpad + , 0 + ) + ) + stk + ) + + +renderTape : Model -> MachineType -> Array String -> TapeStatus -> Int -> Int -> Int -> Bool -> Shape Msg +renderTape model macType input tapeSt tapeId selectedId inputAt showButtons = let hoverOn = case model of @@ -160,6 +383,15 @@ renderTape model input tapeSt tapeId selectedId inputAt showButtons = xpad = 20 + -- TODO: Figure out why this is necessary when renderTape is used in RunningNPDA mode + displaceTapePointer = + case model of + RunningNPDA _ _ _ -> + xpad + + _ -> + xpad / 2 + errWindow = group [ roundedRect 800 30 2 @@ -171,6 +403,14 @@ renderTape model input tapeSt tapeId selectedId inputAt showButtons = |> fixedwidth |> filled red ] + + disableInDefaultNPDA = + case ( model, macType ) of + ( Default _ _ _, NPDA ) -> + False + + _ -> + True in group <| Array.toList @@ -206,7 +446,7 @@ renderTape model input tapeSt tapeId selectedId inputAt showButtons = ) input ) - ++ (if tapeId == selectedId then + ++ (if tapeId == selectedId && disableInDefaultNPDA then [ group [ triangle 2.25 |> filled black @@ -220,7 +460,7 @@ renderTape model input tapeSt tapeId selectedId inputAt showButtons = |> filled black |> move ( 0, 3 ) ] - |> move ( xpad / 2 + xpad * toFloat inputAt, 0 ) + |> move ( displaceTapePointer + xpad * toFloat inputAt, 0 ) ] else @@ -246,6 +486,18 @@ renderTape model input tapeSt tapeId selectedId inputAt showButtons = ] |> move ( toFloat <| (Array.length input + 1) * xpad, 3 ) |> notifyTap (DeleteTape tapeId) + , if macType /= NPDA then + group [] + + else + group + [ roundedRect 15 15 2 + |> filled white + |> addOutline (solid 1) darkGray + , thickRightArrowIcon |> scale 0.2 |> move ( 0, -1 ) + ] + |> move ( toFloat <| (Array.length input + 2) * xpad, 2 ) + |> notifyTap (RunTape tapeId) , if not (tapeSt == Fresh) then group ([ triangle 20 |> filled red |> rotate 22.5 @@ -260,7 +512,19 @@ renderTape model input tapeSt tapeId selectedId inputAt showButtons = ) ) |> scale 0.5 - |> move ( toFloat <| (Array.length input + 2) * xpad, 1 ) + |> move + ( toFloat <| + (Array.length input + + (if macType /= NPDA then + 2 + + else + 3 + ) + ) + * xpad + , 1 + ) |> notifyEnter (HoverErrorEnter tapeId) |> notifyLeave HoverErrorExit @@ -319,9 +583,44 @@ update env msg ( model, pModel, sModel ) = else ( ( model, pModel, sModel ), False, Cmd.none ) + RunningNPDA cfgs tId _ -> + let + tape = + Dict.get tId pModel.tapes + |> Maybe.map first + |> Maybe.withDefault Array.empty + + newCfgs = + nextConfigRel oldMachine.transitionNames oldMachine.delta tape pModel.npdaAcceptCond sModel.machine.final cfgs + + newStates = + configToStates newCfgs + in + ( ( RunningNPDA newCfgs tId 0, { pModel | currentStates = newStates }, sModel ), False, Cmd.none ) + _ -> ( ( model, pModel, sModel ), False, Cmd.none ) + RunTape tId -> + case machineType of + DFA -> + ( ( model, pModel, sModel ), False, Cmd.none ) + + NFA -> + ( ( model, pModel, sModel ), False, Cmd.none ) + + NPDA -> + case Dict.get tId pModel.tapes of + Just ( ar, tapeStatus ) -> + if tapeStatus == Fresh then + ( ( RunningNPDA [ { stack = [ "\\bot" ], state = designatedStart test.start, status = Alive, tapePos = -1 } ] tId 0, pModel, sModel ), False, Cmd.none ) + + else + ( ( model, pModel, sModel ), False, Cmd.none ) + + Nothing -> + ( ( model, pModel, sModel ), False, Cmd.none ) + EditTape tId -> ( ( Editing tId, pModel, sModel ), False, Cmd.none ) @@ -372,6 +671,14 @@ update env msg ( model, pModel, sModel ) = _ -> ( ( model, pModel, sModel ), False, Cmd.none ) + else if normalizedKey == "escape" then + case model of + RunningNPDA _ 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 -> @@ -408,6 +715,9 @@ update env msg ( model, pModel, sModel ) = Default _ _ _ -> ( ( model, pModel, sModel ), False, Task.perform identity (Task.succeed <| Step) ) + RunningNPDA _ _ _ -> + ( ( model, pModel, sModel ), False, Task.perform identity (Task.succeed <| Step) ) + _ -> ( ( model, pModel, sModel ), False, Cmd.none ) @@ -507,7 +817,12 @@ update env msg ( model, pModel, sModel ) = -1 chars = - Array.fromList <| Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values oldMachine.transitionNames + Array.fromList <| + Set.toList <| + Set.remove "\\epsilon" <| + List.foldr Set.union Set.empty <| + List.map .inputLabel <| + Dict.values oldMachine.transitionNames newChar = Array.get charCode chars @@ -550,6 +865,14 @@ update env msg ( model, pModel, sModel ) = _ -> ( ( model, pModel, { sModel | machineType = NFA } ), False, Cmd.none ) + NPDA -> + 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 -> @@ -588,6 +911,63 @@ update env msg ( model, pModel, sModel ) = _ -> ( ( model, newPModel, newSModel ), True, Cmd.none ) + NPDA -> + case model of + Editing tId -> + ( ( Default tId -1 Nothing, pModel, { sModel | machineType = DFA } ), False, Cmd.none ) + + _ -> + ( ( model, pModel, { sModel | machineType = DFA } ), False, Cmd.none ) + + NPDA -> + case sModel.machineType of + DFA -> + case model of + Editing tId -> + ( ( Default tId -1 Nothing, pModel, { sModel | machineType = NPDA } ), False, Cmd.none ) + + _ -> + ( ( model, pModel, { sModel | machineType = NPDA } ), 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 = NPDA } + in + case model of + Editing tId -> + ( ( Default tId -1 Nothing, newPModel, newSModel ), True, Cmd.none ) + + _ -> + ( ( model, newPModel, newSModel ), True, Cmd.none ) + + NPDA -> + ( ( model, pModel, { sModel | machineType = NPDA } ), False, Cmd.none ) + + ChangeNPDAAcceptCond newCond -> + ( ( model, { pModel | npdaAcceptCond = newCond }, sModel ), True, Cmd.none ) + MachineMsg mmsg -> case mmsg of StartDragging sId _ -> @@ -609,18 +989,20 @@ update env msg ( model, pModel, sModel ) = NFA -> { oldMachine | start = - case Set.member sId oldMachine.start of - True -> - Set.remove sId oldMachine.start + if Set.member sId oldMachine.start then + Set.remove sId oldMachine.start - False -> - Set.insert sId oldMachine.start + else + Set.insert sId oldMachine.start } DFA -> { oldMachine | start = Set.singleton sId } + + NPDA -> + { oldMachine | start = Set.singleton sId } in case model of Default tId _ _ -> @@ -645,6 +1027,22 @@ update env msg ( model, pModel, sModel ) = _ -> ( ( model, pModel, sModel ), False, Cmd.none ) + IncrementPaginateCounter -> + case model of + RunningNPDA cfgs tId pagCount -> + ( ( RunningNPDA cfgs tId (pagCount + 1), pModel, sModel ), False, Cmd.none ) + + _ -> + ( ( model, pModel, sModel ), False, Cmd.none ) + + DecrementPaginateCounter -> + case model of + RunningNPDA cfgs tId pagCount -> + ( ( RunningNPDA cfgs tId (pagCount - 1), pModel, sModel ), False, Cmd.none ) + + _ -> + ( ( model, pModel, sModel ), False, Cmd.none ) + isAccept : Set StateID -> Set StateID -> InputTape -> Int -> Bool isAccept states finals input inputAt = @@ -672,7 +1070,12 @@ view env ( model, pModel, sModel ) = chars = -- This is broken? - Set.toList <| Set.remove "\\epsilon" <| List.foldr Set.union Set.empty <| Dict.values oldMachine.transitionNames + -- 2021-07-31 TODO: Investigate why this is broken + Set.toList <| + Set.remove "\\epsilon" <| + List.foldr Set.union Set.empty <| + List.map .inputLabel <| + Dict.values oldMachine.transitionNames menu = group <| @@ -700,7 +1103,7 @@ view env ( model, pModel, sModel ) = |> 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) + group (List.indexedMap (\x ( chId, ( ch, tapeSt ) ) -> renderTape model sModel.machineType ch tapeSt chId tapeId charId True |> move ( 0, -(toFloat x) * 25 )) <| Dict.toList tapes) |> move ( -winX / 2 + 20, winY / 6 - 40 ) _ -> @@ -712,6 +1115,14 @@ view env ( model, pModel, sModel ) = validCheck = machineCheck sModel + + selectTape tapeId = + case Dict.get tapeId tapes of + Just ( t, st ) -> + ( t, st ) + + Nothing -> + ( Array.empty, Fresh ) in group [ case model of @@ -731,12 +1142,7 @@ view env ( model, pModel, sModel ) = Editing tapeId -> let ( tape, tapeSt ) = - case Dict.get tapeId pModel.tapes of - Just ( t, st ) -> - ( t, st ) - - Nothing -> - ( Array.empty, Fresh ) + selectTape tapeId in group [ rect winX (winY / 3) @@ -753,15 +1159,59 @@ view env ( model, pModel, sModel ) = |> move ( -winX / 2 + 95, winY / 6 - 15 ) , latexKeyboard winX winY chars |> move ( 0, 0 ) - , renderTape model tape tapeSt tapeId -1 -1 False + , renderTape model sModel.machineType 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 + + RunningNPDA cfgs tId pagStart -> + group + [ rect winX (winY / 3) + |> filled lightGray + , text "Simulate NPDA" + |> size 16 + |> fixedwidth + |> filled black + |> move ( -winX / 2 + 2, winY / 6 - 15 ) + , text "(Press Right Arrow to step, Esc to exit simulation)" + |> size 6 + |> fixedwidth + |> filled black + |> move ( -winX / 2 + 120, winY / 6 - 15 ) + , renderConfigs oldMachine model (first (selectTape tId)) pagStart tId winX cfgs + ] + |> move ( 0, -winY / 3 ) + , (GraphicSVG.map MachineMsg <| Machine.view env Regular sModel.machineType sModel.machine pModel.currentStates transMistakes) |> move ( 0, winY / 6 ) + , buttonRender ( model, pModel, sModel ) winX winY ] +buttonRender : ( Model, PersistentModel, SharedModel ) -> Float -> Float -> Shape Msg +buttonRender ( model, pModel, sModel ) winX winY = + let + condMachineModeButtons = + case model of + RunningNPDA _ _ _ -> + group [] + + _ -> + machineModeButtons sModel.machineType winX winY ChangeMachine + + condNPDAAcceptButtons = + case model of + RunningNPDA _ _ _ -> + group [] + + _ -> + if sModel.machineType == NPDA then + npdaAcceptCondButtons pModel winX winY + + else + group [] + in + group [ condMachineModeButtons, condNPDAAcceptButtons ] + + machineDefn : SharedModel -> MachineType -> Float -> Float -> Shape Msg machineDefn sModel mtype winX winY = let @@ -787,13 +1237,13 @@ machineDefn sModel mtype winX winY = NFA -> group [ machineHeader - , latex 500 18 "blank" "let\\ N = (Q,\\Sigma,\\Delta,S,F)" AlignLeft + , latex 500 18 "blank" "\\textrm{let}\\ N = (Q,\\Sigma,\\Delta,S,F)" AlignLeft |> move ( -winX / 2 + 500, winY / 6 - 25 ) - , latex 500 14 "blank" "where" AlignLeft + , latex 500 14 "blank" "\\textrm{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 + , latex 500 18 "blank" ("\\Sigma = \\{ " ++ String.join "," (Set.toList <| Set.remove "\\epsilon" <| List.foldl (Set.union << .inputLabel) 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 ) @@ -806,13 +1256,13 @@ machineDefn sModel mtype winX winY = DFA -> group [ machineHeader - , latex 500 18 "blank" "let\\ M = (Q,\\Sigma,\\delta,s,F)" AlignLeft + , latex 500 18 "blank" "\\textrm{let}\\ M = (Q,\\Sigma,\\delta,s,F)" AlignLeft |> move ( -winX / 2 + 500, winY / 6 - 25 ) - , latex 500 14 "blank" "where" AlignLeft + , latex 500 14 "blank" "\\textrm{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 + , latex 500 18 "blank" ("\\Sigma = \\{ " ++ String.join "," (Set.toList <| Set.remove "\\epsilon" <| List.foldl (Set.union << .inputLabel) 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 ) @@ -837,6 +1287,59 @@ machineDefn sModel mtype winX winY = |> move ( -winX / 2 + 510, winY / 6 - 160 ) ] + NPDA -> + group + [ machineHeader + , latex 500 18 "blank" "\\textrm{let}\\ M = (Q,\\Sigma,\\Gamma,\\delta,s,\\bot,F)" AlignLeft + |> move ( -winX / 2 + 500, winY / 6 - 25 ) + , latex 500 14 "blank" "\\textrm{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 << .inputLabel) Set.empty <| Dict.values machine.transitionNames) ++ " \\}") AlignLeft + |> move ( -winX / 2 + 510, winY / 6 - 90 ) + , latex 500 + 18 + "blank" + ("\\Gamma = \\{ " + ++ String.join "," + (Dict.values machine.transitionNames + |> List.concatMap (\lab -> lab.stackTop :: lab.stackPush) + |> Set.fromList + |> Set.remove "\\bot" + |> Set.remove "\\epsilon" + |> Set.remove " " + |> Set.toList + ) + ++ " \\}" + ) + AlignLeft + |> move ( -winX / 2 + 510, winY / 6 - 115 ) + , latex 500 18 "blank" "\\delta = (above)" AlignLeft + |> move ( -winX / 2 + 510, winY / 6 - 135 ) + , latex 500 + 14 + "blank" + ("s = " + ++ (case Set.toList machine.start of + [] -> + "Please\\ select\\ a\\ start\\ state" + + x :: [] -> + getStateName x + + _ :: _ -> + "Congratulations,\\ you\\ found\\ a\\ bug!" + ) + ) + AlignLeft + |> move ( -winX / 2 + 510, winY / 6 - 160 ) + , latex 500 14 "blank" "\\bot = \\bot" AlignLeft + |> move ( -winX / 2 + 510, winY / 6 - 180 ) + , latex 500 18 "blank" ("F = \\{ " ++ String.join "," (List.map getStateName <| Set.toList <| machine.final) ++ " \\}") AlignLeft + |> move ( -winX / 2 + 510, winY / 6 - 200 ) + ] + epsTrans : TransitionNames -> Delta -> Set StateID -> Set StateID epsTrans tNames d states = @@ -848,7 +1351,7 @@ epsTrans tNames d states = getName trans = case Dict.get trans tNames of Just n -> - renderSet2String n + renderSet2String n.inputLabel _ -> "" @@ -893,7 +1396,7 @@ delta tNames d ch state = getName trans = case Dict.get trans tNames of Just n -> - n + n.inputLabel _ -> Set.empty @@ -931,6 +1434,140 @@ deltaHat tNames d ch states = epsTrans tNames d newStates + +-- NPDA functions + + +configToStates : List Configuration -> Set StateID +configToStates = + List.filter (\cfg -> cfg.status == Alive || cfg.status == Success) >> List.map .state >> Set.fromList + + +nextConfigRel : TransitionNames -> Delta -> InputTape -> AcceptCond -> Set StateID -> List Configuration -> List Configuration +nextConfigRel tNames d tape acceptCond finals cfgs = + List.concatMap (nextConfig tNames d tape acceptCond finals) cfgs + + +nextConfig : TransitionNames -> Delta -> InputTape -> AcceptCond -> Set StateID -> Configuration -> List Configuration +nextConfig tNames d tape acceptCond finals ({ stack, state, status, tapePos } as config) = + let + getName trans = + case Dict.get trans tNames of + Just n -> + n + + _ -> + emptyLabel + + matchStackTop pat = + Just pat == List.head stack || pat == "\\epsilon" + + replaceStackTop old new inpStk = + if isPrefixOf old inpStk then + new ++ drop (length old) inpStk + + else + inpStk + + nextTape cond = + if cond then + 0 + + else + 1 + + ch = + Maybe.withDefault "" (Array.get (tapePos + 1) tape) + in + case status of + Alive -> + let + newConfigs = + case Dict.get state d of + Just transMap -> + Dict.toList transMap + |> List.filterMap + (\( tId, sId ) -> + let + tLabel = + getName tId + + newStack = + updateStack tLabel stack + + newTapePos = + tapePos + nextTape (renderSet2String tLabel.inputLabel == "\\epsilon") + + newStatus = + case acceptCond of + EmptyStack -> + -- This is handled below, only when the config has an empty stack and no transitions to take + Alive + + FinalState -> + if Set.member sId finals && newTapePos == (Array.length tape - 1) then + Success + + else + Alive + in + if + (renderSet2String tLabel.inputLabel == ch || renderSet2String tLabel.inputLabel == "\\epsilon") + && matchStackTop tLabel.stackTop + then + Just + { stack = updateStack tLabel stack + , state = sId + , status = newStatus + , tapePos = tapePos + nextTape (renderSet2String tLabel.inputLabel == "\\epsilon") + } + + else + Nothing + ) + + Nothing -> + [] + in + if newConfigs == [] then + if acceptCond == EmptyStack && stack == [] && tapePos == (Array.length tape - 1) then + [ { config | status = Success } ] + + else + [ { config | status = Deadend } ] + + else + newConfigs + + Success -> + [] + + Deadend -> + [] + + +updateStack : TransitionLabel -> Stack -> Stack +updateStack { stackTop, stackPush } stk = + case stk of + [] -> + [] + + _ -> + let + pushed = + if stackPush == [ "\\epsilon" ] then + [] + + else + stackPush + in + if Just stackTop == head stk then + pushed ++ List.drop 1 stk + + else + stk + + latexKeyboard : Float -> Float -> List Character -> Shape Msg latexKeyboard w h chars = let @@ -985,3 +1622,57 @@ latexKeyboard w h chars = , oneRow homeRow (fillOutExtras 9 0 chars) |> move ( -keyW / 3, -keyH - 2 ) , oneRow botRow (fillOutExtras 7 19 chars) |> move ( -keyW, -(keyH + 2) * 2 ) ] + + +npdaAcceptCondButtons : PersistentModel -> Float -> Float -> Shape Msg +npdaAcceptCondButtons pModel winX winY = + group + [ group + [ roundedRect 100 15 1 + |> filled + (if pModel.npdaAcceptCond == EmptyStack then + finsmLightBlue + + else + blank + ) + |> addOutline (solid 1) darkGray + , text "Empty Stack" + |> centered + |> fixedwidth + |> filled + (if pModel.npdaAcceptCond == EmptyStack then + white + + else + darkGray + ) + |> move ( 0, -4 ) + ] + |> move ( -winX / 2 + 55, winY / 2 - 52 ) + |> notifyTap (ChangeNPDAAcceptCond EmptyStack) + , group + [ roundedRect 100 15 1 + |> filled + (if pModel.npdaAcceptCond == FinalState then + finsmLightBlue + + else + blank + ) + |> addOutline (solid 1) darkGray + , text "Final State" + |> centered + |> fixedwidth + |> filled + (if pModel.npdaAcceptCond == FinalState then + white + + else + darkGray + ) + |> move ( 0, -4 ) + ] + |> move ( -winX / 2 + 157, winY / 2 - 52 ) + |> notifyTap (ChangeNPDAAcceptCond FinalState) + ] diff --git a/src/Utils.elm b/src/Utils.elm index 228c243..00e67f6 100644 --- a/src/Utils.elm +++ b/src/Utils.elm @@ -64,7 +64,7 @@ textBox txt w h place msg = move ( -w / 2, h / 2 ) <| html (w * 1.5) (h * 1.5) <| input - [ id "input" + [ id <| "input" ++ place , placeholder place , onInput msg , value txt @@ -76,6 +76,21 @@ textBox txt w h place msg = [] +textBox3 : ( String, String, String ) -> Float -> Float -> ( String, String, String ) -> (String -> msg) -> (String -> msg) -> (String -> msg) -> Shape msg +textBox3 ( t1, t2, t3 ) w h ( p1, p2, p3 ) msg1 msg2 msg3 = + let + box1 = + textBox t1 w h p1 msg1 |> move ( 0, h ) + + box2 = + textBox t2 w h p2 msg2 + + box3 = + textBox t3 w h p3 msg3 |> move ( 0, -h ) + in + group [ box1, box2, box3 ] + + newMsg : msg -> Cmd msg newMsg msg = Task.perform identity <| Task.succeed msg