Cell.hs

module Cell where

data Cell item topology
    = Cell
        { get      :: IO item
        , set      ::    item  -> IO ()
        , move     :: topology -> Cell item topology
        , location :: topology
        }

cell `modify` f = do
    value <- get cell

    cell `set` f value

cell `modify_location` f = do
    cell `move` f (location cell)

HexMapField.hs

module HexMapField where

import Topology
import HexTopology
import MapSpace
import Cell

import Control.Monad (forM_)

at :: MapSpace a HexPoint -> HexPoint -> Cell a HexPoint
m `at` pt = Cell
    { get = m `get_cell` pt

    , set = \value -> do
        m `put_cell` pt $ value

        return ()

    , move = (m `at`)

    , location = pt
    }

pivot = (`at` pt 0 0)

test = do
    r <- void :: IO (MapSpace String HexPoint)

    forM_ [1.. 10] $ \i -> do

        let j = 10 - i

        (r `at` pt i j) `set` "dick"

    forM_ [1.. 10] $ \i -> do
        forM_ [1.. 10] $ \j -> do

            value <- get $ r `at` pt i j

            putStr $ show value ++ " "

        putStrLn ""

HexTopology.hs

{-# LANGUAGE TypeFamilies #-}

module HexTopology where

import Topology

data HexPoint
    = HexPoint { x, y :: Int }

    deriving (Show, Ord, Eq)

newtype HexPointDiff 
    = HexPointDiff { raw :: HexPoint }

    deriving Show

instance Topos HexPoint where
    type Diff HexPoint = HexPointDiff

    HexPoint x y `distance_to` HexPoint x' y' =
        HexPointDiff (HexPoint (x - x') (y - y'))

    HexPoint x y `offset_by` HexPointDiff (HexPoint dx dy) =
        HexPoint (x + dx) (y + dy)

    HexPoint x y `offset_by_n` (n, HexPointDiff (HexPoint dx dy)) =
        HexPoint (x + dx * n) (y + dy * n)

pt = HexPoint
shift x y = HexPointDiff (HexPoint x y)

MapSpace.hs

{-# LANGUAGE GADTs #-}

module MapSpace where

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

space :: Monoid a => Map b a -> IO (MapSpace a b)
space = (Space `fmap`) . newIORef

void :: Monoid a => IO (MapSpace a b)
void = space Map.empty

set_value = writeIORef
get_value = readIORef

modify_value = modifyIORef

data MapSpace a b where
    Space :: Monoid a => IORef (Map b a) -> MapSpace a b

Space m `get_cell` pt = do
    m' <- get_value m

    return $ case pt `Map.lookup` m' of
        Nothing     -> mempty
        Just result -> result

(Space m `put_cell` pt) cell = do

    m `modify_value` (Map.insert pt cell)

    return $ Space m

(m `modify_cell` pt) f = (m `put_cell` pt) . f =<< m `get_cell` pt

Topology.hs

{-# LANGUAGE TypeFamilies #-}

module Topology where

class Topos t where
    type Diff t

    distance_to :: t ->            t  -> Diff t
    offset_by   :: t ->       Diff t  ->      t
    offset_by_n :: t -> (Int, Diff t) ->      t

infixl 3 `offset_by`, `offset_by_n`