|
|
@@ -1,6 +1,5 @@ |
|
|
|
module Main where |
|
|
|
|
|
|
|
--import System.Random |
|
|
|
import Control.Monad |
|
|
|
import System.Process |
|
|
|
import System.Random |
|
|
@@ -81,7 +80,13 @@ boundw n = bound (x-m) x |
|
|
|
-- may need to generalise the number |
|
|
|
-- of states |
|
|
|
data CellState = Alive | Dead |
|
|
|
deriving Eq |
|
|
|
deriving (Eq, Bounded, Enum) |
|
|
|
|
|
|
|
instance Random CellState where |
|
|
|
random g = case randomR (fromEnum (minBound :: CellState), fromEnum (maxBound :: CellState)) g of |
|
|
|
(r, g') -> (toEnum r, g') |
|
|
|
randomR (a,b) g = case randomR (fromEnum a, fromEnum b) g of |
|
|
|
(r, g') -> (toEnum r, g') |
|
|
|
|
|
|
|
-- how the states are displayed on screen |
|
|
|
-- this should probably be input to a function |
|
|
@@ -115,7 +120,7 @@ rule3 (Space (l:_) m (r:_)) |
|
|
|
|
|
|
|
-- take a space and a rule and |
|
|
|
-- return the next space |
|
|
|
step :: (Space t -> t) -> Space t -> Space t |
|
|
|
step :: Comonad w => (w t -> t) -> w t -> w t |
|
|
|
step f w = w =>> f |
|
|
|
|
|
|
|
--------------- |
|
|
@@ -129,6 +134,74 @@ ilobs rng = b : (ilobs r) |
|
|
|
where |
|
|
|
(b,r) = random rng |
|
|
|
|
|
|
|
-- this is kinda gross but if it works it works |
|
|
|
takeGive :: Int -> [a] -> ([a],[a]) |
|
|
|
takeGive n as = ( (take n as), (drop n as) ) |
|
|
|
|
|
|
|
-------------------------- |
|
|
|
-- 2d cellular automata -- |
|
|
|
-------------------------- |
|
|
|
|
|
|
|
data Space2 t = |
|
|
|
Space2 [(Space t)] |
|
|
|
(Space t) |
|
|
|
[(Space t)] |
|
|
|
|
|
|
|
instance Functor Space2 where |
|
|
|
fmap f (Space2 u m d) = |
|
|
|
Space2 (fmap (fmap f) u) (fmap f m) (fmap (fmap f) d) |
|
|
|
|
|
|
|
instance Comonad Space2 where |
|
|
|
duplicate w = |
|
|
|
Space2 (tail $ iterate (f up2) dm) |
|
|
|
dm |
|
|
|
(tail $ iterate (f down2) dm) |
|
|
|
where |
|
|
|
f g (Space l m r) = Space (fmap g l) (g m) (fmap g r) |
|
|
|
dm = Space (tail $ iterate left2 w) w (tail $ iterate right2 w) |
|
|
|
extract (Space2 _ m _) = extract m |
|
|
|
|
|
|
|
down2 :: Space2 t -> Space2 t |
|
|
|
down2 w@(Space2 u m []) = w |
|
|
|
down2 (Space2 u m (d:ds)) = Space2 (m:u) d ds |
|
|
|
|
|
|
|
up2 :: Space2 t -> Space2 t |
|
|
|
up2 w@(Space2 [] m d) = w |
|
|
|
up2 (Space2 (u:us) m d) = Space2 us u (m:d) |
|
|
|
|
|
|
|
left2 :: Space2 t -> Space2 t |
|
|
|
left2 (Space2 u m d) = Space2 (fmap left u) (left m) (fmap left d) |
|
|
|
|
|
|
|
right2 :: Space2 t -> Space2 t |
|
|
|
right2 (Space2 u m d) = Space2 (fmap right u) (right m) (fmap right d) |
|
|
|
|
|
|
|
bound2 :: Int -> Int -> Int -> Int -> Space2 t -> [[t]] |
|
|
|
bound2 u d l r (Space2 uw mw dw) = (reverse (take u (map (bound l r) uw))) ++ ((bound l r mw):(take d (map (bound l r) dw))) |
|
|
|
|
|
|
|
bound2w :: Int -> Int -> Space2 t -> [[t]] |
|
|
|
bound2w x y = bound2 (r-q) r (n-m) n |
|
|
|
where |
|
|
|
o = if odd x then 1 else 0 |
|
|
|
m = if even x then 1 else 0 |
|
|
|
n = (x - o) `div` 2 |
|
|
|
p = if odd y then 1 else 0 |
|
|
|
q = if even y then 1 else 0 |
|
|
|
r = (y - p) `div` 2 |
|
|
|
|
|
|
|
-------------- |
|
|
|
-- 2d rules -- |
|
|
|
-------------- |
|
|
|
|
|
|
|
conway :: Space2 CellState -> CellState |
|
|
|
conway (Space2 (u:_) m (d:_)) |
|
|
|
= case me of |
|
|
|
Alive -> if (length ns) == 2 || (length ns == 3) then Alive else Dead |
|
|
|
Dead -> if (length ns) == 3 then Alive else Dead |
|
|
|
where |
|
|
|
f b (Space (l:_) m (r:_)) = [l,r] ++ (if b then [m] else []) |
|
|
|
ns = filter (== Alive) $ concat [ (f True u), (f False m), (f True d) ] |
|
|
|
me = extract m |
|
|
|
|
|
|
|
----------------- |
|
|
|
-- gross io bs -- |
|
|
|
----------------- |
|
|
@@ -146,6 +219,7 @@ ilobs rng = b : (ilobs r) |
|
|
|
data Options = Options |
|
|
|
{ optWidth :: Int |
|
|
|
, optGenerations :: Int |
|
|
|
, optHeight :: Int |
|
|
|
} deriving Show |
|
|
|
|
|
|
|
-- the default options for the program |
|
|
@@ -155,7 +229,8 @@ data Options = Options |
|
|
|
defaultOptions :: Int -> Int -> Options |
|
|
|
defaultOptions w h = Options |
|
|
|
{ optWidth = w |
|
|
|
, optGenerations = h |
|
|
|
, optGenerations = 40 |
|
|
|
, optHeight = h |
|
|
|
} |
|
|
|
|
|
|
|
-- the avaliable options |
|
|
@@ -167,6 +242,9 @@ options = |
|
|
|
, Option ['g'] ["generations"] |
|
|
|
(ReqArg (\t opts -> opts { optGenerations = (read t) }) "GENERATIONS") |
|
|
|
"time steps to simulate" |
|
|
|
, Option ['h'] ["height"] |
|
|
|
(ReqArg (\t opts -> opts { optHeight = (read t) }) "HEIGHT") |
|
|
|
"term height" |
|
|
|
] |
|
|
|
|
|
|
|
-- parse the options into the structure |
|
|
@@ -188,12 +266,30 @@ parseArgs = do |
|
|
|
-- main loop -- |
|
|
|
--------------- |
|
|
|
|
|
|
|
createRandSpace :: StdGen -> Space CellState |
|
|
|
createRandSpace rng = |
|
|
|
Space (tail $ map snd $ iterate f (r1, Alive)) |
|
|
|
(fst (random rng)) |
|
|
|
(tail $ map snd $ iterate f (r2, Alive)) |
|
|
|
where |
|
|
|
f (r,b) = let (nb,nr) = (random r) in (nr,nb) |
|
|
|
(r1,r2) = split rng |
|
|
|
|
|
|
|
createRandSpace2 :: StdGen -> Space2 CellState |
|
|
|
createRandSpace2 rng = |
|
|
|
Space2 (tail $ map snd $ iterate f (r1, (createRandSpace r1))) |
|
|
|
(createRandSpace rng) |
|
|
|
(tail $ map snd $ iterate f (r2, (createRandSpace r2))) |
|
|
|
where |
|
|
|
f (r,s) = let (nr1,nr2) = split r in (nr2, (createRandSpace nr1)) |
|
|
|
(r1,r2) = split rng |
|
|
|
|
|
|
|
-- simply print the current space, then recurse to the next |
|
|
|
runAutomata :: Space CellState -> Int -> Int -> IO () |
|
|
|
runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s |
|
|
|
runAutomata s n w = do |
|
|
|
putStrLn $ concat $ map show $ boundw w s |
|
|
|
runAutomata (step rule s) (n - 1) w |
|
|
|
--runAutomata :: Space2 CellState -> Int -> Int -> IO () |
|
|
|
--runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s |
|
|
|
--runAutomata s n w = do |
|
|
|
-- mapM_ putStrLn $ map show $ concat $ bound2w w s |
|
|
|
-- runAutomata (step conway s) (n - 1) w |
|
|
|
|
|
|
|
main :: IO () |
|
|
|
main = do |
|
|
@@ -201,12 +297,12 @@ main = do |
|
|
|
rng <- getStdGen |
|
|
|
let cs = map (\x -> if x then Alive else Dead) $ ilobs rng |
|
|
|
let w = (optWidth options) |
|
|
|
let h = (optGenerations options) |
|
|
|
let wh = (w + 1) `div` 2 |
|
|
|
let m = head cs |
|
|
|
let l = take wh $ drop 1 cs |
|
|
|
let r = take wh $ drop wh $ drop 1 cs |
|
|
|
let s = Space (l ++ (repeat Dead)) m (r ++ (repeat Dead)) |
|
|
|
-- non-random starting position for rule3 (the serpinski triangle) |
|
|
|
--let s = Space (repeat Dead) Alive (repeat Dead) |
|
|
|
runAutomata s h w |
|
|
|
let h = (optHeight options) |
|
|
|
let g = (optGenerations options) |
|
|
|
let s = createRandSpace2 rng |
|
|
|
mapM_ (f w h) (loop conway g s) |
|
|
|
where |
|
|
|
f w h s = do |
|
|
|
mapM_ putStrLn $ map (concat . (map show)) $ bound2w w h s |
|
|
|
putStrLn (take w (repeat '-')) |
|
|
|
loop f n s = take n $ iterate (step f) s |