Robot.elm

import Keyboard
import Window
import Graphics.Input (Input, input, button, dropDown)
import Graphics.Input.Field (Content, noContent, field, defaultStyle, Forward, Backward)

-- MODEL
data Direction = North | East | South | West
type Robot = {x:Int, y:Int, dir:Direction}
type Board = [(Int,Int)]
type Game = {robot:Robot, board:Board}
data Language = Swedish | English
data BoardInput = Circle (Int) | Rectangle (Int,Int)
data Command = GoForward | TurnLeft | TurnRight | StandStill | Move(Int, Int, Direction)
type Inp = {boardInput: BoardInput, robotInput: Command}
defaultGame = {robot={x=0, y=0, dir = North}, board=[]}

-- UPDATE
stepRobot cmd {robot, board} = 
          {robot | x   <- case cmd of 
                            Move(x,y,_) -> if onBoard (x,y) board then x else 0 
                            _           -> let xx = next robot.x robot.dir cmd East West
                                           in if onBoard (xx,robot.y) board then xx else robot.x,
                   y   <- case cmd of 
                            Move(x,y,_) -> if onBoard (x,y) board then y else 0
                            _           -> let yy = next robot.y robot.dir cmd North South
                                           in if onBoard (robot.x,yy) board then yy else robot.y,
                   dir <- case cmd of 
                            Move(_,_,dir) -> dir
                            _             -> nextDir robot.dir cmd }

stepBoard boardInput = case boardInput of
                              Circle(radius)       -> filter (\(x,y) -> x^2+y^2 < radius^2) <|
                                                        coords [-radius..radius] [-radius..radius]
                              Rectangle(rows,cols) -> coords [0..cols-1] [0..rows-1]
                              _                    -> []

stepGame : Inp -> Game -> Game
stepGame {boardInput, robotInput} game =
          {board=stepBoard boardInput, robot=(stepRobot robotInput game)}
game = foldp stepGame defaultGame inp 

-- INPUT
colInp = input noContent
rowInp = input noContent
radInp = input noContent
startxInp = input noContent
startyInp = input noContent
click = input ()

inp = Inp <~ boardInput ~ robotInput
boardInput = toShape <~ (sampleOn click.signal <| lift4 (,,,) (contentToInt <~ radInp.signal) (contentToInt <~ rowInp.signal) (contentToInt <~ colInp.signal) shape.signal)
robotInput = merge initMoves moves

initMoves = Move <~ (sampleOn click.signal <| lift3 (,,) (contentToInt <~ startxInp.signal) (contentToInt <~ startyInp.signal) (constant North))  
moves = toMoveCmd <~ Keyboard.lastPressed ~ (sampleOn click.signal lang.signal)
main = display <~ Window.dimensions ~ colField ~ rowField ~ radField ~ startXField ~ startYField ~ game

-- DISPLAY
colField = makeField colInp "No of columns"
rowField = makeField rowInp "No of rows"
radField = makeField radInp "Radius"
startXField = makeField startxInp "x start"
startYField = makeField startyInp "y start"
startBtn = button click.handle () "Start!"

lang = input English
langDropDown =
     dropDown lang.handle
        [ ("English - Keys: f, r, l", English)
        , ("Swedish - Keys: g, h, v", Swedish)
        ]

shape = input <| Rectangle (0,0)
shapeDropDown =
     dropDown shape.handle
        [ ("Rectangle", Rectangle (0,0))
        , ("Circle" , Circle 0)
        ]

display (w,h) colField rowField radField startXField startYField {robot,board} = 
          flow down [[markdown|**Controls**|] `above` (container 250 30 midLeft langDropDown),
                     [markdown|**Board shape**|] `above` (container 250 50 midLeft shapeDropDown),
                     [markdown|**Board config**|] `above` (flow right [container 250 50 midRight colField, container 250 50 midLeft rowField]), 
                     (container 250 50 midRight radField),
                     (flow right [container 250 50 midRight startXField, container 250 50 midLeft startYField]), 
                     (container 250 50 midLeft startBtn),
                     asText robot,
                     collage w h
                      (
                        [move (toFloat(robot.x*20),toFloat(robot.y*20)+100) (filled red (rect 20 20))] ++ 
                        map (\(x,y) -> move (toFloat x*20,toFloat y*20+100) (outlined (solid blue) (rect 20 20))) board
                      )  
                    ]

-- Utils
contentToInt cont = case (String.toInt cont.string) of {Just x -> x; _ -> 0}
makeField inp txt = field defaultStyle inp.handle id txt <~ inp.signal

coords l1 l2 =
  if length l1 == 0 then [] else (map (\x -> (head l1, x)) l2) ++ (coords (tail l1) l2)
onBoard (x,y) board = any (\e -> e == (x,y)) board
next x dir cmd incrDir decDir = 
     if | dir == incrDir && cmd == GoForward -> x + 1
        | dir == decDir  && cmd == GoForward -> x - 1
        | otherwise                      -> x
nextDir dir cmd = case (dir,cmd) of
                    (North,TurnLeft)  -> West
                    (North,TurnRight) -> East
                    (South,TurnLeft)  -> East
                    (South,TurnRight) -> West
                    (East,TurnLeft)   -> North
                    (East,TurnRight)  -> South
                    (West,TurnLeft)   -> South
                    (West,TurnRight)  -> North
                    _                 -> dir

toShape (r,w,h,shape) = case shape of
                          Circle _ -> Circle(r)
                          _      -> Rectangle(w,h)
                          
toMoveCmd key lang = case (key,lang) of
                        (71,Swedish) -> GoForward
                        (86,Swedish) -> TurnLeft
                        (72,Swedish) -> TurnRight
                        (70,English) -> GoForward
                        (76,English) -> TurnLeft
                        (82,English) -> TurnRight
                        _            -> StandStill