Viennese Maze

Viennese.elm

-- Viennese Maze Simulator, based on
-- http://zulko.github.io/blog/2014/04/27/viennese-mazes-what-they-are/

import Keyboard
import Window
import Graphics.Input as Input

-------------
-- Helpers --
-------------

sqrt2 = sqrt 2

type Coord = (Float, Float)

applyCoord : (Float -> Float -> Float) -> Coord -> Coord -> Coord
applyCoord f (a,b) (x,y) = (f a x, f b y)

both : (a -> b) -> (a,a) -> (b,b)
both f (a1,a2) = (f a1, f a2)

bind : Maybe a -> (a -> Maybe b) -> Maybe b
bind ma f = case ma of
    Nothing -> Nothing
    Just a -> f a

orTry : Maybe a -> (() -> Maybe a) -> Maybe a
orTry ma f = case ma of
    Just x -> Just x
    Nothing -> f ()

partialToMaybe : [a] -> Maybe a
partialToMaybe xs = case xs of
    [] -> Nothing
    [x] -> Just x

------------------------
-- Graph Abstractions --
------------------------

data LightColor = Green | Yellow | Red
cycle : Int -> LightColor -> LightColor
cycle n = case (n `mod` 3) of
    0 -> id
    1 -> \lc -> case lc of
                Green -> Yellow
                Yellow -> Red
                Red -> Green
    2 -> \lc -> case lc of
                Green -> Red
                Yellow -> Green
                Red -> Yellow

data Angle = Horiz | Vert | Rising | Falling
is45 angle = case angle of
    Rising -> True
    Falling -> True
    _ -> False

type Edge = { angle : Angle
            , lc : LightColor
            , coord : Coord
            }
edge angle lc x y = Edge angle lc (x,y)

type Vertex = { label : String
              , coord : Coord
              }
vertex lbl x y = Vertex lbl (x,y)


-----------
-- State --
-----------

data Command = Mov {x:Int, y:Int} | Reset
commands = merge (always Reset <~ keepIf id True Keyboard.space)
                 (Mov <~ Keyboard.arrows)

state0 = (head vertices, 0, last vertices)

type State = (Vertex, Int, Vertex)
state : Signal State
state = foldp step state0 commands

step : Command -> State -> State
step com s = case com of
    Reset -> state0
    Mov mv -> case toMove mv `bind` pickEdge s of
                Just edg -> moveOnEdge edg s
                Nothing -> s

data Move = Up | Down | Left | Right
toMove : {x:Int, y:Int} -> Maybe Move
toMove {x,y} = case (x,y) of
    (0,1) -> Just Up
    (0,-1) -> Just Down
    (-1,0) -> Just Left
    (1,0) -> Just Right
    _ -> Nothing

pickEdge : State -> Move -> Maybe Edge
pickEdge (v1, cyc, v0) mv = let
    findEdge : Coord -> Maybe Edge
    findEdge c = filter (\ed -> ed.coord == applyCoord (+) v1.coord c) edges |> partialToMaybe
    edgesFor : Coord -> Coord -> Coord -> Maybe Edge
    edgesFor c0 c1 c2 = findEdge c0 `orTry` always (findEdge c1) `orTry` always (findEdge c2)
            in case mv of
    Up    -> edgesFor (0,0.5) (0.5,0.5) (-0.5,0.5)
    Down  -> edgesFor (0,-0.5) (0.5,-0.5) (-0.5,-0.5)
    Left  -> edgesFor (-0.5,0) (-0.5,-0.5)(-0.5,0.5)
    Right -> edgesFor (0.5,0) (0.5,-0.5)(0.5,0.5)

moveOnEdge : Edge -> State -> State
moveOnEdge  edg (v1, cyc, v0) = let
    delta = applyCoord (-) edg.coord v1.coord |> both ((*) 2)
    pos = applyCoord (+) v1.coord delta
    m_vNew : Maybe Vertex
    m_vNew = filter (\c -> c.coord == pos) vertices |> partialToMaybe
        in case m_vNew of
            Nothing -> (v1, cyc, v0)
            Just vNew -> if vNew == v0 || cycle cyc edg.lc == Red then (v1, cyc, v0)
                         else (vNew, cyc+1, v1)

----------------
-- Draw Graph --
----------------

colorOf : LightColor -> Color
colorOf lc = case lc of
    Red -> red
    Yellow -> darkYellow
    Green -> darkGreen

shapeOf : LightColor -> (Float -> Path, Float)
shapeOf lc = case lc of
    Red -> (ngon 8, turns 1/16)
    Yellow -> (\s -> square (sqrt2*s), degrees 45)
    Green -> (\s -> circle(s/2), 0)

--       grid size, cycles, color blind mode
drawEdge : Float -> Int -> Bool -> Edge -> Form
drawEdge s c cb {angle, lc, coord} = let
    len = if is45 angle then sqrt2 * s else s
    theta = case angle of
        Horiz -> degrees 0
        Vert -> degrees 90
        Rising -> degrees 45
        Falling -> degrees -45
    cur_lc = cycle c lc
    (shape, rot) = shapeOf cur_lc
    fill = colorOf cur_lc
            in
    [ rect len (s/12)
        |> filled (greyscale 0.25)
        |> rotate theta
    , segment (-len/2, 0) (len/2, 0)
        |> traced (dashed white)
        |> rotate theta
    , rect len (s/12)
        |> filled fill
        |> alpha 0.4
        |> rotate theta
    ] ++ (if not cb then [] else
    [ shape (s/10)
        |> filled fill
        |> rotate rot
    ])
      |> group
      |> move (both ((*) s) coord)

drawVertex : Float -> Vertex -> Form
drawVertex s {label, coord} = group
    [ circle (s/10)
        |> filled white
    , circle (s/10)
        |> outlined (solid black)
    , toForm <| plainText label
    ]
      |> move (both ((*) s) coord)

halo : LineStyle
halo = let sb = solid blue in { sb | width <- 6}


--------------------
-- Scene and Main --
--------------------

colorBlind = Input.input False
colorBlindBox = Input.checkbox colorBlind.handle id <~ colorBlind.signal

scene : (Int, Int) -> State -> (Element, Bool) -> Element
scene (w,h) (v,c,_) (cbb, cb) = let
    s = min w h |> \x -> toFloat x / 5
    game = collage w h <| map (drawEdge s c cb) edges ++
                          map (drawVertex s) vertices ++
                          [circle (s/10)
                            |> outlined halo
                            |> move (both ((*) s) v.coord)
                          ]
        in
    flow outward <| [ spacer w h |> color grey
                    , game
                    , cbb `beside` (toText "Color blind mode" |> Text.height 12 |> leftAligned)
                    ]

main = scene <~ Window.dimensions ~ state ~ lift2 (,) colorBlindBox colorBlind.signal

------------------------
-- Defining the Graph --
------------------------

edges = [ edge Rising Yellow -1.5 0.5
        , edge Horiz Green -1.5 0
        , edge Falling Red -1.5 -0.5
        , edge Vert Green -1 0.5
        , edge Vert Yellow -1 -0.5
        , edge Rising Green -0.5 1.5
        , edge Horiz Green -0.5 1
        , edge Horiz Green -0.5 0
        , edge Horiz Green -0.5 -1
        , edge Falling Red -0.5 -1.5
        , edge Vert Green 0 1.5
        , edge Vert Green 0 0.5
        , edge Vert Green 0 -0.5
        , edge Vert Green 0 -1.5
        , edge Falling Yellow 0.5 1.5
        , edge Horiz Yellow 0.5 1
        , edge Horiz Green 0.5 0
        , edge Horiz Yellow 0.5 -1
        , edge Rising Red 0.5 -1.5
        , edge Vert Yellow 1 0.5
        , edge Vert Yellow 1 -0.5
        , edge Falling Red 1.5 0.5
        , edge Horiz Yellow 1.5 0
        , edge Rising Red 1.5 -0.5
        ]

vertices = [ vertex "a" -2 0
           , vertex "b" -1 1
           , vertex "c" -1 0
           , vertex "d" -1 -1
           , vertex "e" 0 -2
           , vertex "f" 0 -1
           , vertex "g" 0 0
           , vertex "h" 0 1
           , vertex "i" 0 2
           , vertex "j" 1 1
           , vertex "k" 1 0
           , vertex "l" 1 -1
           , vertex "m" 2 0
           ]