diff --git a/src/Main.elm b/src/Main.elm index 2551e1f..e9082fb 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -206,9 +206,42 @@ initialState = , board = [] } +updatePosition : Coord -> State -> State +updatePosition c state = + let + newBoard = case state.penMode of + Up -> state.board + Down -> (state.pos, c)::state.board + in + { state | pos = c, board = newBoard } + +registerFunction : String -> Function -> State -> State +registerFunction s f state = { state | scope = setScopeFunction s f state.scope } + +registerVariable : String -> Int -> State -> State +registerVariable s v state = { state | scope = setScopeVariable s v state.scope } + +setPenMode : LogoPenMode -> State -> State +setPenMode m state = { state | penMode = m} + +upScope : State -> State +upScope state = { state | scope = Child state.scope Dict.empty Dict.empty } + +downScope : State -> State +downScope state = + let + newScope = case state.scope of + End -> End + Child p _ _ -> p + in + { state | scope = newScope } + unit : a -> Step a unit a state = Ok (a, state) +err : String -> Step a +err s state = Err s + bind : Step a -> (a -> Step b) -> Step b bind sa f state = case sa state of Ok (a, newState) -> f a newState @@ -217,45 +250,24 @@ bind sa f state = case sa state of rbind : (a -> Step b) -> Step a -> Step b rbind f sa = bind sa f -updatePosition : Coord -> Step () -updatePosition c state = - let - newBoard = case state.penMode of - Up -> state.board - Down -> (state.pos, c)::state.board - in - Ok ((), { state | pos = c, board = newBoard }) +get : Step State +get s = Ok (s, s) -registerFunction : String -> Function -> Step () -registerFunction s f state = Ok ((), { state | scope = setScopeFunction s f state.scope }) +put : State -> Step () +put s _ = Ok ((), s) -registerVariable : String -> Int -> Step () -registerVariable s v state = Ok ((), { state | scope = setScopeVariable s v state.scope }) - -setPenMode : LogoPenMode -> Step () -setPenMode m state = Ok ((), { state | penMode = m}) - -upScope : Step () -upScope state = Ok ((), { state | scope = Child state.scope Dict.empty Dict.empty }) - -downScope : Step () -downScope state = - let - newScope = case state.scope of - End -> End - Child p _ _ -> p - in - Ok ((), { state | scope = newScope }) +modify : (State -> State) -> Step () +modify f = get |> rbind (put << f) lookupFunction : String -> Step Function -lookupFunction s state = case scopeFunction s state.scope of - Just f -> Ok (f, state) - Nothing -> Err ("No function with name " ++ s) +lookupFunction s = get |> rbind (\st -> case scopeFunction s st.scope of + Just f -> unit f + Nothing -> err ("No function with name " ++ s)) lookupVariable : String -> Step Int -lookupVariable s state = case scopeVariable s state.scope of - Just i -> Ok (i, state) - Nothing -> Err ("No variable with name " ++ s) +lookupVariable s = get |> rbind (\st -> case scopeVariable s st.scope of + Just v -> unit v + Nothing -> err ("No variable with name " ++ s)) evaluateExp : LogoExpr -> Step Int evaluateExp le = case le of @@ -267,24 +279,27 @@ evaluateAllExps : List LogoExpr -> Step (List Int) evaluateAllExps = List.foldr (\x acc -> acc |> rbind (\vs -> evaluateExp x |> rbind (\v -> unit (v::vs)))) (unit []) registerAllVariables : List (String, Int) -> Step () -registerAllVariables = List.foldl (\(s, i) m -> bind m (\_ -> registerVariable s i)) (unit ()) +registerAllVariables = List.foldl (\(s, i) m -> bind m (\_ -> modify <| registerVariable s i)) (unit ()) -zip : List a -> List b -> List (a, b) -zip la lb = case (la, lb) of - (a::lat, b::lbt) -> (a, b)::zip lat lbt - _ -> [] +zipParams : List String -> List Int -> Step (List (String, Int)) +zipParams la lb = case (la, lb) of + (a::lat, b::lbt) -> zipParams lat lbt |> rbind (\ps -> unit <| (a, b)::ps) + ([], []) -> unit [] + ([], _) -> err "Passing too many parameters to macro call" + (_, []) -> err "Not enough parameters in macro call" evaluateCmd : LogoCmd -> Step () evaluateCmd c = case c of - Move l r -> evaluateExp l |> rbind (\x -> evaluateExp r |> rbind (\y -> updatePosition (x, y))) - Define n xs prg -> registerFunction n (xs, prg) - Pen mode -> setPenMode mode + Move l r -> evaluateExp l |> rbind (\x -> evaluateExp r |> rbind (\y -> modify <| updatePosition (x, y))) + Define n xs prg -> modify <| registerFunction n (xs, prg) + Pen mode -> modify <| setPenMode mode Call n args -> lookupFunction n |> rbind (\(ns, prg) -> evaluateAllExps args - |> rbind (\vs -> upScope - |> rbind (\_ -> registerAllVariables (zip ns vs) - |> rbind (\_ -> evaluateAll prg - |> rbind (\_ -> downScope))))) + |> rbind (\vs -> modify upScope + |> rbind (\_ -> zipParams ns vs + |> rbind (\ps -> registerAllVariables ps + |> rbind (\_ -> evaluateAll prg + |> rbind (\_ -> modify downScope)))))) evaluateAll : LogoProg -> Step () evaluateAll prg = List.foldl rbind (unit ()) <| List.map (\c _ -> evaluateCmd c) prg