Game.hs

{-# LANGUAGE TemplateHaskell #-}

import Data.Lens.Template

import qualified Data.Map as Map
import           Data.Map   (Map)

import System.Random

import StatefulLens

data Direction = U | D | L | R

    deriving Enum

data Tile = Floor | Wall

    deriving (Show, Eq)

data Game = Game
    { _characters :: Map  Name (Int, Int) 
    , _space      :: Map (Int, Int) Tile
    , _dice       :: StdGen
    }

    deriving Show

type Name = String

$( makeLenses [''Game] )

getRandomFrom (a, b) = 
    with dice $ state $ randomR (a, b)

getRandom :: Random a => State Game a
getRandom = 
    with dice $ state random

selectRandomFrom :: [a] -> State Game a
selectRandomFrom list = do
    index <- getRandomFrom (0, length list - 1)

    return (list !! index)

defaultGame rng = Game
    { _characters = Map.singleton "player" (0, 0)
    , _space      = Map.fromList [((0, 0), Floor), ((0, 1), Floor)]
    , _dice       = rng
    }

step direction (x, y) = case direction of
    L -> (x - 1, y)
    U -> (x,     y - 1)
    R -> (x + 1, y)
    D -> (x,     y + 1)

-- | 'canWalk' checks if there is a possibility to 'walk' into specified
--   'Direction' and returns @(Just arrival) if it is or @Nothing otherwise.
canWalk :: Name -> Direction -> State Game (Maybe (Int, Int))
canWalk character direction = do

    character `ifExistsIn` characters $ \position -> do

        let position' = step direction position

        position' `ifExistsIn` space $ \new_cell ->

            return $ 
                if new_cell == Floor
                then Just position'
                else Nothing

walk :: Name -> Direction -> State Game ()
walk character direction = do

    possibility <- character `canWalk` direction
            
    case possibility of
        Nothing       -> return ()
        Just position -> character `moveTo` position

moveTo character position = 
    perform (character `at` characters .= position)

-- | 'ifExistsIn' takes3 params: @key, @pile_part accessor and @action
--   if @key is 'Map.member' of the @pile_part-retrieved state,
--   then it takes a value the @key points to and passes it to the @action.
ifExistsIn 
    :: Ord k 
    => k 
    -> Lens a (Map k b) 
    -> (b -> State a (Maybe c)) 
    ->       State a (Maybe c)

ifExistsIn key pile_part action = do

    exist <- with pile_part $ retrieve' (key `Map.lookup`)

    case exist of
        Nothing   -> return Nothing
        Just item -> action item

-- | 'at' grabs a @key and transforms @pile_part-map-accessor to accessor
--   to element from that map, pointed by @key
at 
    :: Ord k 
    => k 
    -> Lens a (Map k b) 
    -> Lens a        b

at key pile_part = lens 
    ((Map.! key) . (.? pile_part)) 
    ((pile_part .~) . Map.insert key)

-- | 'wander' takes a @character [its name] and searches for a possible
--   'Direction' to walk. Then, if there is none - skips, if there is one
--    walks onto it, if there are many - selects random possible one.
wander :: Name -> State Game ()
wander character = do
    
    possibilities <- mapM (character `canWalk`) [U, L, D, R]

    let possible = [position | Just position <- possibilities]

    case possible of
        []         -> return ()
        [position] -> character `moveTo` position

        positions  -> do
            
            position <- selectRandomFrom positions

            character `moveTo` position

StatefulLens.hs

module StatefulLens 
    ( module M
    , retrieve
    , retrieve'
    , perform
    , with
    , (.?)
    , (.=)
    , (.~)
    )
where

import Control.Applicative as M
import Control.Arrow       as M
import Control.Monad.State as M

import Data.Lens.Strict    as M

import Data.Maybe          as M


retrieve' :: (a -> b) -> State a b
retrieve' part = part <$> get

retrieve :: Lens a b -> State a b
retrieve part = (.? part) <$> get

perform :: (b -> b) -> State b ()
perform = modify

with :: Lens a b -> State b c -> State a c
with part transform = do

    b <- retrieve part

    let (c, b') = runState transform b

    perform (part .= b')

    return c

(.?) = flip getL

(.=) = setL

(.~) = modL