Add implementation of evaluator, without dynamic code loading.
This commit is contained in:
commit
bda42ad2e0
27
elm.json
Normal file
27
elm.json
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
{
|
||||
"type": "application",
|
||||
"source-directories": [
|
||||
"src"
|
||||
],
|
||||
"elm-version": "0.19.0",
|
||||
"dependencies": {
|
||||
"direct": {
|
||||
"avh4/elm-color": "1.0.0",
|
||||
"elm/browser": "1.0.1",
|
||||
"elm/core": "1.0.2",
|
||||
"elm/html": "1.0.0",
|
||||
"elm/parser": "1.1.0",
|
||||
"joakin/elm-canvas": "3.0.3"
|
||||
},
|
||||
"indirect": {
|
||||
"elm/json": "1.1.2",
|
||||
"elm/time": "1.0.0",
|
||||
"elm/url": "1.0.0",
|
||||
"elm/virtual-dom": "1.0.2"
|
||||
}
|
||||
},
|
||||
"test-dependencies": {
|
||||
"direct": {},
|
||||
"indirect": {}
|
||||
}
|
||||
}
|
||||
32
index.html
Normal file
32
index.html
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
<html>
|
||||
<head>
|
||||
<title>MiniLogo Simulator</title>
|
||||
<script src="minilogo.js"></script>
|
||||
<script src="http://unpkg.com/elm-canvas/elm-canvas.js"></script>
|
||||
</head>
|
||||
<body>
|
||||
<div id="elm-container">
|
||||
</div>
|
||||
<script>
|
||||
var program = `
|
||||
move(0, 0);
|
||||
define line(x1, y1, x2, y2) {
|
||||
pen up;
|
||||
move(x1, y1);
|
||||
pen down;
|
||||
move(x2, y2);
|
||||
};
|
||||
define nix(x, y, width, height) {
|
||||
call line (x, y, x + width, y + height);
|
||||
call line (x + width, y, x, y + height);
|
||||
};
|
||||
call nix(0, 0, 5, 10);
|
||||
`
|
||||
var container = document.getElementById("elm-container");
|
||||
var app = Elm.Main.init({
|
||||
"flags": { initialText: program },
|
||||
"node": container
|
||||
});
|
||||
</script>
|
||||
</body>
|
||||
</html>
|
||||
334
src/Main.elm
Normal file
334
src/Main.elm
Normal file
|
|
@ -0,0 +1,334 @@
|
|||
import Html exposing (Html, div, text)
|
||||
import Html.Attributes exposing (class)
|
||||
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)
|
||||
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
|
||||
= Run
|
||||
|
||||
{-
|
||||
======= 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 [ 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
|
||||
canvas dat
|
||||
|
||||
update : Msg -> Model -> (Model, Cmd Msg)
|
||||
update msg m = (m, Cmd.none)
|
||||
|
||||
subscriptions : Model -> Sub Msg
|
||||
subscriptions m = Sub.none
|
||||
|
||||
main = element
|
||||
{ init = init
|
||||
, view = view
|
||||
, update = update
|
||||
, subscriptions = subscriptions
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user