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