forked from tA/cellularAutomata
111 lines
3.1 KiB
Haskell
111 lines
3.1 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
module Spaces.Space2 where
|
|
|
|
import Comonad
|
|
import Data.Maybe
|
|
import Control.DeepSeq
|
|
import GHC.Generics
|
|
import Spaces.Space1
|
|
|
|
-- a nested space
|
|
data Space2 t = Space2 [(Space t)] (Space t) [(Space t)]
|
|
deriving (Generic, Generic1, Show)
|
|
|
|
-- generating strict data instances
|
|
instance NFData a => NFData (Space2 a)
|
|
instance NFData1 Space2
|
|
|
|
-- we can fmap into this structure by recursively fmapping
|
|
-- the inner spaces
|
|
instance Functor Space2 where
|
|
fmap f (Space2 u m d) =
|
|
Space2 (fmap (fmap f) u) (fmap f m) (fmap (fmap f) d)
|
|
|
|
-- map a partial function, converting to non maybe values
|
|
fintermap :: (a -> Maybe a) -> [a] -> [a]
|
|
fintermap _ [] = []
|
|
fintermap f (a:as) = case f a of
|
|
Nothing -> []
|
|
Just y -> y : fintermap f as
|
|
|
|
f :: ((Space2 a) -> Maybe (Space2 a)) -> Space (Space2 a) -> Maybe (Space (Space2 a))
|
|
f g (Space l m r) = case (g m) of
|
|
Nothing -> Nothing
|
|
Just y -> Just $ Space (fintermap g l) y (fintermap g r)
|
|
|
|
-- comonad instance for our 2d space
|
|
instance Comonad Space2 where
|
|
duplicate w =
|
|
Space2 (finterate (f up2) dm) dm (finterate (f down2) dm)
|
|
where
|
|
dm = Space (finterate left2 w) w (finterate right2 w)
|
|
-- to duplicate we must recursively duplicate in all directions
|
|
-- the focussed space becomes the whole space, with left and right
|
|
-- mapped to each side.
|
|
-- to do the up and down lists, each needs to be the middle space
|
|
-- mapped up and down as far as we can.
|
|
-- up2 and down2 will return Nothing when they cant go further
|
|
-- to extract we simply recursively extract
|
|
extract (Space2 _ m _) = extract m
|
|
|
|
-- directional moving of focus
|
|
up2 :: Space2 t -> Maybe (Space2 t)
|
|
up2 (Space2 [] _ _) = Nothing
|
|
up2 (Space2 (u:us) m d) = Just $ Space2 us u (m:d)
|
|
|
|
down2 :: Space2 t -> Maybe (Space2 t)
|
|
down2 (Space2 _ _ []) = Nothing
|
|
down2 (Space2 u m (d:ds)) = Just $ Space2 (m:u) d ds
|
|
|
|
noLeft :: Space t -> Bool
|
|
noLeft (Space [] _ _) = True
|
|
noLeft _ = False
|
|
|
|
noRight :: Space t -> Bool
|
|
noRight (Space _ _ []) = True
|
|
noRight _ = False
|
|
|
|
-- left and right require mapping further
|
|
-- we are assuming things are rectangular (maybe a bad idea?)
|
|
left2 :: Space2 t -> Maybe (Space2 t)
|
|
left2 (Space2 u m d) =
|
|
if check
|
|
then Nothing
|
|
else Just $ Space2 (fmap (f . left) u) (f $ left m) (fmap (f . left) d)
|
|
where
|
|
check = noLeft m
|
|
f l = fromJust l
|
|
|
|
right2 :: Space2 t -> Maybe (Space2 t)
|
|
right2 (Space2 u m d) =
|
|
if check
|
|
then Nothing
|
|
else Just $ Space2 (fmap (f . right) u) (f $ right m) (fmap (f . right) d)
|
|
where
|
|
check = noRight m
|
|
f l = fromJust l
|
|
|
|
-- clamp as we do in 1d Spaces
|
|
clampRel2 :: Int -> Int -> Int -> Int -> Space2 t -> Space2 t
|
|
clampRel2 w x y z (Space2 u m d) = Space2 (take w $ fmap f u) (f m) (take x $ fmap f d)
|
|
where
|
|
f = clampRel y z
|
|
|
|
clamp2 :: Int -> Int -> Space2 t -> Space2 t
|
|
clamp2 w h = clampRel2 nu nd nl nr
|
|
where
|
|
nu = h `div` 2
|
|
nd = nu - (if even h then 1 else 0)
|
|
nr = w `div` 2
|
|
nl = nr - (if even w then 1 else 0)
|
|
|
|
mat2 :: Space2 t -> [[t]]
|
|
mat2 (Space2 u m d) = (reverse (fmap mat u)) ++ ((mat m):(fmap mat d))
|
|
|
|
matn2 :: Int -> Int -> Space2 t -> [[t]]
|
|
matn2 w h = mat2 . (clamp2 w h)
|
|
|
|
step :: Comonad w => (w t -> t) -> w t -> w t
|
|
step f w = w =>> f
|