341 lines
8.8 KiB
Elm
341 lines
8.8 KiB
Elm
import Html exposing (Html, div, text, textarea)
|
|
import Html.Attributes exposing (class)
|
|
import Html.Events exposing (onInput)
|
|
import Browser exposing (element)
|
|
import Canvas exposing (Shape)
|
|
import Dict exposing (Dict)
|
|
import Parser exposing (Parser, (|.), (|=), variable, succeed, symbol, int, spaces, map, oneOf, lazy, sequence, Trailing(..), keyword, run, backtrackable)
|
|
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
|
|
}
|
|
|
|
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
|
|
|
|
parseSum : Parser LogoExpr
|
|
parseSum = succeed Sum
|
|
|= oneOf [ backtrackable parseVar, backtrackable parseInt ]
|
|
|. spaces
|
|
|. symbol "+"
|
|
|. spaces
|
|
|= parseExpr
|
|
|
|
parseExpr : Parser LogoExpr
|
|
parseExpr = oneOf [ lazy (\_ -> backtrackable parseSum), backtrackable parseInt, backtrackable parseVar ]
|
|
|
|
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
|
|
}
|
|
|
|
parsePenMode : Parser LogoPenMode
|
|
parsePenMode = oneOf
|
|
[ succeed Up |. keyword "up"
|
|
, succeed Down |. keyword "down"
|
|
]
|
|
|
|
parsePen : Parser LogoCmd
|
|
parsePen = succeed Pen
|
|
|. keyword "pen"
|
|
|. spaces
|
|
|= parsePenMode
|
|
|
|
parseMove : Parser LogoCmd
|
|
parseMove = succeed Move
|
|
|. keyword "move"
|
|
|. spaces
|
|
|. symbol "("
|
|
|= parseExpr
|
|
|. spaces
|
|
|. symbol ","
|
|
|. spaces
|
|
|= parseExpr
|
|
|. symbol ")"
|
|
|
|
{-
|
|
======= Semantics Code =======
|
|
-}
|
|
|
|
initialScope : Scope
|
|
initialScope = Child End Dict.empty Dict.empty
|
|
|
|
initialState : State
|
|
initialState =
|
|
{ penMode = Up
|
|
, pos = (0, 0)
|
|
, scope = initialScope
|
|
}
|
|
|
|
unit : a -> Step a
|
|
unit a state = Ok (a, state)
|
|
|
|
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
|
|
|
|
updatePosition : Coord -> Board -> Step Board
|
|
updatePosition c b state =
|
|
let
|
|
newBoard = case state.penMode of
|
|
Up -> b
|
|
Down -> (state.pos, c)::b
|
|
in
|
|
Ok (newBoard, { state | pos = c })
|
|
|
|
registerFunction : String -> Function -> Step ()
|
|
registerFunction s f state = Ok ((), { state | scope = setScopeFunction s f state.scope })
|
|
|
|
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 })
|
|
|
|
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
|
|
|
|
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)
|
|
|
|
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)
|
|
|
|
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 (\_ -> 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
|
|
_ -> []
|
|
|
|
evaluateCmd : LogoCmd -> Board -> Step Board
|
|
evaluateCmd c b = case c of
|
|
Move l r -> evaluateExp l |> rbind (\x -> evaluateExp r |> rbind (\y -> updatePosition (x, y) b))
|
|
Define n xs prg -> registerFunction n (xs, prg) |> rbind (\_ -> unit b)
|
|
Pen mode -> setPenMode mode |> rbind (\_ -> unit b)
|
|
Call n args -> lookupFunction n
|
|
|> rbind (\(ns, prg) -> evaluateAllExps args
|
|
|> rbind (\vs -> upScope
|
|
|> rbind (\_ -> registerAllVariables (zip ns vs)
|
|
|> rbind (\_ -> evaluateAll prg b
|
|
|> rbind (\nb -> downScope
|
|
|> rbind (\_ -> unit nb))))))
|
|
|
|
evaluateAll : LogoProg -> Board -> Step Board
|
|
evaluateAll prg board = List.foldl rbind (unit board) <| List.map evaluateCmd 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 : (Board, State) -> List Shape
|
|
allShapes (b, s) = pointerShape s.pos :: List.map lineShape b
|
|
|
|
canvas : (Board, State) -> Html Msg
|
|
canvas dat = Canvas.toHtml (500, 500) []
|
|
[ shapes [ fill Color.white ] [ rect (0, 0) 500 500 ]
|
|
, shapes [ stroke Color.blue, lineWidth 5] (allShapes dat)
|
|
]
|
|
|
|
{-
|
|
======= 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
|
|
dat = Result.withDefault ([], initialState)
|
|
<| Result.withDefault (Err "Couldn't parse program")
|
|
<| Result.map (\prg -> evaluateAll prg [] initialState) (run parseProg m.programText)
|
|
in
|
|
div [ class "logo-container" ]
|
|
[ div [ class "logo-pane" ] [ textarea [ onInput UpdateText ] [ text m.programText ] ]
|
|
, div [ class "logo-pane" ] [ canvas dat ]
|
|
]
|
|
|
|
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
|
|
}
|