407 lines
11 KiB
Elm
407 lines
11 KiB
Elm
import Html exposing (Html, div, text, textarea, h1, h2, p)
|
|
import Html.Attributes exposing (class, classList)
|
|
import Html.Events exposing (onInput)
|
|
import Browser exposing (element)
|
|
import Canvas exposing (Shape)
|
|
import Dict exposing (Dict)
|
|
import Parser exposing (Parser, Problem(..), DeadEnd, (|.), (|=), variable, succeed, symbol, int, spaces, map, oneOf, lazy, sequence, Trailing(..), keyword, run, backtrackable, end)
|
|
import Color
|
|
import Canvas exposing (Point, path, lineTo, circle, shapes, stroke, lineWidth, fill, rect)
|
|
import Set
|
|
|
|
{-
|
|
======= Syntax Definitions =======
|
|
-}
|
|
type LogoPenMode = Up | Down
|
|
type LogoExpr = Variable String
|
|
| Number Int
|
|
| Sum LogoExpr LogoExpr
|
|
type LogoCmd = Pen LogoPenMode
|
|
| Move LogoExpr LogoExpr
|
|
| Define String (List String) LogoProg
|
|
| Call String (List LogoExpr)
|
|
type alias LogoProg = List LogoCmd
|
|
|
|
{-
|
|
======= Semantics Definitions ====
|
|
-}
|
|
|
|
type alias Coord = (Int, Int)
|
|
type alias Line = (Coord, Coord)
|
|
type alias Function = (List String, LogoProg)
|
|
|
|
type Scope = Child Scope (Dict String Function) (Dict String Int) | End
|
|
type alias Board = List Line
|
|
type alias State =
|
|
{ penMode : LogoPenMode
|
|
, pos : Coord
|
|
, scope : Scope
|
|
, board : Board
|
|
}
|
|
|
|
type alias Step a = State -> Result String (a, State)
|
|
|
|
{-
|
|
======= Type Definitions =======
|
|
-}
|
|
|
|
type alias Flags =
|
|
{ initialText : String
|
|
}
|
|
|
|
type alias Model =
|
|
{ programText : String
|
|
}
|
|
|
|
type Msg
|
|
= UpdateText String
|
|
|
|
{-
|
|
======= Syntax Code
|
|
-}
|
|
|
|
parseInt : Parser LogoExpr
|
|
parseInt = map Number int
|
|
|
|
parseVarName : Parser String
|
|
parseVarName = variable
|
|
{ start = Char.isAlphaNum
|
|
, inner = Char.isAlphaNum
|
|
, reserved = Set.fromList [ "move", "pen", "define", "call" ]
|
|
}
|
|
|
|
parseVar : Parser LogoExpr
|
|
parseVar = map Variable parseVarName
|
|
|
|
parseTerm : Parser LogoExpr
|
|
parseTerm = oneOf [ parseInt, parseVar ]
|
|
|
|
parseSum : Parser LogoExpr
|
|
parseSum = succeed Sum
|
|
|= parseTerm
|
|
|. spaces
|
|
|. symbol "+"
|
|
|. spaces
|
|
|= parseExpr
|
|
|
|
parseExpr : Parser LogoExpr
|
|
parseExpr = oneOf [ lazy (\_ -> backtrackable parseSum), parseTerm ]
|
|
|
|
parseProg : Parser LogoProg
|
|
parseProg = sequence
|
|
{ start = ""
|
|
, separator = ""
|
|
, end = ""
|
|
, spaces = spaces
|
|
, item = lazy (\_ -> parseCmd)
|
|
, trailing = Mandatory
|
|
}
|
|
|
|
parseCmd : Parser LogoCmd
|
|
parseCmd = oneOf [ parseDefine, parseCall, parseMove, parsePen ]
|
|
|
|
parseDefine : Parser LogoCmd
|
|
parseDefine = succeed Define
|
|
|. keyword "define"
|
|
|. spaces
|
|
|= parseVarName
|
|
|. spaces
|
|
|= sequence
|
|
{ start = "("
|
|
, separator = ","
|
|
, end = ")"
|
|
, spaces = spaces
|
|
, item = parseVarName
|
|
, trailing = Forbidden
|
|
}
|
|
|. spaces
|
|
|. symbol "{"
|
|
|. spaces
|
|
|= parseProg
|
|
|. spaces
|
|
|. symbol "}"
|
|
|
|
parseCall : Parser LogoCmd
|
|
parseCall = succeed Call
|
|
|. keyword "call"
|
|
|. spaces
|
|
|= parseVarName
|
|
|. spaces
|
|
|= sequence
|
|
{ start = "("
|
|
, separator = ","
|
|
, end = ")"
|
|
, spaces = spaces
|
|
, item = parseExpr
|
|
, trailing = Forbidden
|
|
}
|
|
|. spaces
|
|
|. symbol ";"
|
|
|
|
parsePenMode : Parser LogoPenMode
|
|
parsePenMode = oneOf
|
|
[ succeed Up |. keyword "up"
|
|
, succeed Down |. keyword "down"
|
|
]
|
|
|
|
parsePen : Parser LogoCmd
|
|
parsePen = succeed Pen
|
|
|. keyword "pen"
|
|
|. spaces
|
|
|= parsePenMode
|
|
|. spaces
|
|
|. symbol ";"
|
|
|
|
parseMove : Parser LogoCmd
|
|
parseMove = succeed Move
|
|
|. keyword "move"
|
|
|. spaces
|
|
|. symbol "("
|
|
|= parseExpr
|
|
|. spaces
|
|
|. symbol ","
|
|
|. spaces
|
|
|= parseExpr
|
|
|. spaces
|
|
|. symbol ")"
|
|
|. spaces
|
|
|. symbol ";"
|
|
|
|
{-
|
|
======= Semantics Code =======
|
|
-}
|
|
|
|
initialScope : Scope
|
|
initialScope = Child End Dict.empty Dict.empty
|
|
|
|
setScopeFunction : String -> Function -> Scope -> Scope
|
|
setScopeFunction s f scope = case scope of
|
|
End -> setScopeFunction s f initialScope
|
|
Child p fs vs -> Child p (Dict.insert s f fs) vs
|
|
|
|
setScopeVariable : String -> Int -> Scope -> Scope
|
|
setScopeVariable s v scope = case scope of
|
|
End -> setScopeVariable s v initialScope
|
|
Child p fs vs -> Child p fs (Dict.insert s v vs)
|
|
|
|
scopeFunction : String -> Scope -> Maybe Function
|
|
scopeFunction s scope = case scope of
|
|
End -> Nothing
|
|
Child p fs _ -> case Dict.get s fs of
|
|
Just f -> Just f
|
|
Nothing -> scopeFunction s p
|
|
|
|
scopeVariable : String -> Scope -> Maybe Int
|
|
scopeVariable s scope = case scope of
|
|
End -> Nothing
|
|
Child p _ vs -> case Dict.get s vs of
|
|
Just i -> Just i
|
|
Nothing -> scopeVariable s p
|
|
|
|
initialState : State
|
|
initialState =
|
|
{ penMode = Up
|
|
, pos = (0, 0)
|
|
, scope = initialScope
|
|
, 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
|
|
Err e -> Err e
|
|
|
|
rbind : (a -> Step b) -> Step a -> Step b
|
|
rbind f sa = bind sa f
|
|
|
|
get : Step State
|
|
get s = Ok (s, s)
|
|
|
|
put : State -> Step ()
|
|
put s _ = Ok ((), s)
|
|
|
|
modify : (State -> State) -> Step ()
|
|
modify f = get |> rbind (put << f)
|
|
|
|
lookupFunction : String -> Step Function
|
|
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 = 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
|
|
Number i -> unit i
|
|
Variable v -> lookupVariable v
|
|
Sum l r -> evaluateExp l |> rbind (\vl -> evaluateExp r |> rbind (\vr -> unit (vl + vr)))
|
|
|
|
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 (\_ -> modify <| registerVariable s i)) (unit ())
|
|
|
|
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 -> 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 -> 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
|
|
|
|
{-
|
|
======= Drawing Stuff =====
|
|
-}
|
|
transformCoord : Coord -> Point
|
|
transformCoord (x, y) = (toFloat x * 25, 500 - toFloat y * 25)
|
|
|
|
lineShape : Line -> Shape
|
|
lineShape (c1, c2) = path (transformCoord c1) [ lineTo (transformCoord c2) ]
|
|
|
|
pointerShape : Coord -> Shape
|
|
pointerShape c = circle (transformCoord c) 5
|
|
|
|
allShapes : State -> List Shape
|
|
allShapes s = pointerShape s.pos :: List.map lineShape s.board
|
|
|
|
canvas : State -> Html Msg
|
|
canvas state = Canvas.toHtml (500, 500) [ classList [ ("centered", True), ("shadow", True) ] ]
|
|
[ shapes [ fill Color.white ] [ rect (0, 0) 500 500 ]
|
|
, shapes [ stroke Color.blue, lineWidth 5] (allShapes state)
|
|
]
|
|
|
|
{-
|
|
===== Rendering Stuff
|
|
-}
|
|
|
|
humanProblemString : Problem -> String
|
|
humanProblemString p = case p of
|
|
Expecting s -> "Expecting " ++ s
|
|
ExpectingInt -> "Expecting decimal integer"
|
|
ExpectingHex -> "Expecting hexadecimal integer"
|
|
ExpectingOctal -> "Expecting octal integer"
|
|
ExpectingBinary -> "Expecting binary integer"
|
|
ExpectingFloat -> "Expecting a floating pointer number"
|
|
ExpectingNumber -> "Expecting a number"
|
|
ExpectingVariable -> "Expected variable name"
|
|
ExpectingSymbol s -> "Expected symbol \"" ++ s ++ "\""
|
|
ExpectingKeyword s -> "Expecting keyword " ++ s
|
|
ExpectingEnd -> "Expecting end of string"
|
|
UnexpectedChar -> "Unexpected character"
|
|
Problem s -> s
|
|
BadRepeat -> "Bad repetition"
|
|
|
|
humanDeadEndString : DeadEnd -> String
|
|
humanDeadEndString { row, col, problem } =
|
|
"A parse error occured on line "
|
|
++ String.fromInt row
|
|
++ ": " ++ humanProblemString problem
|
|
|
|
humanParseError : List DeadEnd -> String
|
|
humanParseError = Maybe.withDefault "" << Maybe.map humanDeadEndString << List.head
|
|
|
|
{-
|
|
======= Elm Architecture =======
|
|
-}
|
|
|
|
init : Flags -> (Model, Cmd Msg)
|
|
init fs =
|
|
let
|
|
model =
|
|
{ programText = fs.initialText
|
|
}
|
|
cmd = Cmd.none
|
|
in
|
|
(model, cmd)
|
|
|
|
view : Model -> Html Msg
|
|
view m =
|
|
let
|
|
parseResult = Result.mapError humanParseError (run (parseProg |. end) m.programText)
|
|
evalResult = Result.map (\(_, s) -> s)
|
|
<| Result.andThen (\prg -> evaluateAll prg initialState) parseResult
|
|
toRender = Result.withDefault initialState evalResult
|
|
error = case evalResult of
|
|
Err e -> [ p [ classList [ ("centered", True), ("error", True), ("shadow", True) ] ] [ text e ] ]
|
|
Ok _ -> []
|
|
in
|
|
div []
|
|
[ h1 [] [ text "MiniLogo Functional Evaluator" ]
|
|
, div [ class "logo-container" ]
|
|
[ div [ class "logo-pane" ] <|
|
|
[ h2 [] [ text "MiniLogo" ]
|
|
, textarea [ onInput UpdateText, classList [ ("centered", True), ("shadow", True) ] ] [ text m.programText ]
|
|
] ++ error
|
|
, div [ class "logo-pane" ] [ h2 [] [ text "Output" ], canvas toRender ]
|
|
]
|
|
]
|
|
|
|
update : Msg -> Model -> (Model, Cmd Msg)
|
|
update msg m = case msg of
|
|
UpdateText s -> ({ m | programText = s }, Cmd.none)
|
|
|
|
subscriptions : Model -> Sub Msg
|
|
subscriptions m = Sub.none
|
|
|
|
main = element
|
|
{ init = init
|
|
, view = view
|
|
, update = update
|
|
, subscriptions = subscriptions
|
|
}
|