GameModel.elm

import Color            exposing (..)
import Dict             exposing (..)
import Graphics.Element exposing (..)
import Graphics.Collage exposing (..)
import Keyboard         exposing (..)
import Maybe            exposing (..)
import Signal           exposing (..)

type alias Game  = 
  { player : Point
  , level  : Level 
  }
  
type alias Level = Dict Point Land
type alias Point = (Int, Int)

type Land 
  = Floor
  | Wall
  
cELL_SIZE         = 12.0
cONTENT_SIZE      = 11.0
cONTENT_RADIUS    = cONTENT_SIZE / 2
vISION_DIAPASONE  = [-vISION_RADIUS.. vISION_RADIUS]
vISION_RADIUS     = 5
vISION_RADIUS_SQR = round <| sqr (toFloat vISION_RADIUS * 1.1)
cOORD_OFFSET = 
  ( 0
  , (minOf vISION_DIAPASONE - 1.5) * cELL_SIZE
  )
  
gAME_SIZE 
  =  let (min, max) = bounds vISION_DIAPASONE
  in round
  <| (max - min) * cELL_SIZE + 100

minOf = List.minimum >> withDefault 0
maxOf = List.maximum >> withDefault 0

bounds list = (minOf list, maxOf list)

drawGame : Game -> Element
-- | Draws 11x11 zone around the player
drawGame {player, level} = 
  collage gAME_SIZE gAME_SIZE
  <| postpend (show player |> toForm |> move cOORD_OFFSET)
  <| postpend (circle cONTENT_RADIUS |> filled green)
  <| vISION_DIAPASONE `for` \x
  -> vISION_DIAPASONE `for` \y
  -> if | x * x + y * y > vISION_RADIUS_SQR -> fail
        | otherwise
        -> let shift    = (x, y)
        in let position = scalar (+) player shift
        in single
        <| drawLandAt shift
        <| withDefault Wall
        <| get position level

sqr : number -> number
sqr x = x * x

postpend : a -> List a -> List a
postpend x list = list ++ [x]

scalar : (a -> a -> a) -> (a, a) -> (a, a) -> (a, a)
scalar op (lx, ly) (rx, ry) = 
  ( lx `op` rx
  , ly `op` ry
  )

for : List a -> (a -> List b) -> List b
-- | `Bind` for list monad
for = flip List.concatMap

single : a -> List a
-- | `Return` for list monad
single x = [x]

fail : List a
fail = []

drawLandAt :  Point -> Land -> Form
drawLandAt point land
  =  square cONTENT_SIZE
  |> filled (colorOf land)
  |> movedTo point
  
colorOf : Land -> Color
colorOf land = case land of
  Wall  -> black
  Floor -> gray
  
movedTo : (Int, Int) -> Form -> Form
movedTo (x, y) = 
  move 
    ( toFloat x * cELL_SIZE
    , toFloat y * cELL_SIZE
    )

(=>) : a -> b -> (a, b)
-- | synonym for pretty look
(=>) = (,)

type Action = Move (Int, Int)

moves : Signal Action
-- | Capture WASD and arrow keypresses
moves = asMove <~ merge wasd arrows

asMove : {x : Int, y : Int} -> Action
-- | Capture shift as move action
asMove point = Move (point.x, point.y)

act : Action -> Game -> Game
-- | Perform an action (if possible)
act (Move shift) game
  =  let newPos = scalar (+) shift game.player
  in case withDefault Wall 
       <| get newPos game.level
     of
       Floor -> { game | player <- newPos }
       _     ->   game

main = 
  let game =
    { player = (10, 10)
    , level  = Dict.fromList
        [ (11, 11) => Floor
        , (10, 11) => Floor
        , (10, 10) => Floor
        , (9 , 10) => Floor
        , (9 , 9 ) => Floor
        , (9 , 8 ) => Floor
        , (9 , 7 ) => Floor
        , (8 , 7 ) => Floor
        , (8 , 6 ) => Floor
        , (8 , 5 ) => Floor
        , (8 , 10) => Floor
        , (7 , 10) => Floor
        , (7 , 9 ) => Floor
        , (7 , 8 ) => Floor
        , (7 , 7 ) => Floor
        ]
    }
  in drawGame <~ foldp act game moves