DouKaku?beta

challenge ライフゲーム 

セルオートマトンに関するお題です. 
2次元タイプの'ライフゲーム'を実装して下さい. 
初期値としては10行10列程度の格子上の平面に0.3程度の人口(?)密度を考え, 
末端はループするようにして下さい. (例: 座標[-1, -1] = [10, 10])

それだけだと簡単すぎると思われる方は, 
過密状態で間引きが発生するような機能を組み込んで下さい. 
間引きは, 少なくともその後の1時間ステップにおける死亡率が, 
それをしなかった場合よりも小さくなれば結構です. 
(死亡率の最小化は複雑性が高すぎる感がありますし. )
サンプル:
t = 0
[ ][*][ ][ ][ ][ ][*][*][*][ ]
[ ][ ][ ][ ][*][ ][ ][*][*][ ]
[ ][ ][ ][*][ ][ ][*][ ][*][ ]
[*][ ][*][*][ ][ ][*][ ][ ][ ]
[ ][*][ ][ ][ ][ ][ ][ ][*][ ]
[*][ ][ ][ ][*][ ][*][*][ ][*]
[ ][*][ ][ ][ ][ ][*][ ][ ][ ]
[ ][ ][ ][ ][ ][ ][ ][ ][ ][*]
[*][ ][ ][ ][ ][ ][*][ ][ ][*]
[ ][ ][ ][ ][*][*][ ][ ][*][ ]
t = 1
[ ][ ][ ][ ][*][ ][ ][ ][ ][*]
[ ][ ][ ][ ][ ][*][ ][ ][ ][*]
[ ][ ][*][ ][*][*][*][ ][*][*]
[ ][*][ ][*][ ][ ][ ][ ][ ][*]
[ ][ ][*][*][ ][*][*][ ][*][ ]
[ ][*][ ][ ][ ][*][*][ ][*][*]
[ ][ ][ ][ ][ ][*][*][*][*][*]
[ ][ ][ ][ ][ ][ ][ ][ ][ ][*]
[*][ ][ ][ ][ ][*][ ][ ][*][ ]
[*][ ][ ][ ][ ][ ][ ][ ][ ][ ]

see: Wikipedia:ライフゲーム

post comment

Posted feedbacks - Haskell

とりあえずWikiPediaでルールを読んで23/3を組んでみました。末端のループもやっています。 ライフゲームは昔から動いてるところは見たことあっても、実際に書いてみたことはなかったので楽しめました...間引きはこれから勉強します。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
module Main
    where

import Data.Array

type Point = (Int, Int)
type Size = (Int, Int)
type TwoDArray = (Size, Array Int Char)

glider = ".........." ++
     "..X......." ++ 
     ".X........" ++ 
     ".XXX......" ++ 
     ".........." ++
     ".........." ++
     ".........." ++
     ".........." ++
     ".........." ++
     ".........."

makeArray :: Size -> [Char] -> TwoDArray
makeArray  sz@(cx, cy) str = (sz, listArray (0, cx * cy - 1) str)

ptToIdx :: Size -> Point -> Int
ptToIdx (cx, cy) (x, y) = (y * cx) + x

fetch :: TwoDArray -> Point -> Char
fetch (sz, rg) pt = rg!(ptToIdx sz pt)

surrounding = [(x, y) | x <- [-1..1], y <-[-1..1], x /= 0 || y /= 0]

addPt :: Point -> Size -> Point -> Point
addPt (x1, y1) (cx, cy) (x2, y2) = ((x1 + x2) `mod` cx, (y1 + y2) `mod` cy)

getSurroundingPts :: Point -> Size -> [Point]
getSurroundingPts pt sz = map (addPt pt sz) surrounding

countSurroundingLife :: TwoDArray -> Point -> Int
countSurroundingLife td@(sz, rg) pt  = 
    length $ filter (/='.') $ map (fetch td) $ getSurroundingPts pt sz

allPoints :: Size -> [Point]
allPoints (cx, cy) = [(x, y) | y <- [0..(cx - 1)], x <- [0..(cy - 1)]]

birthDeath :: Char -> Int -> Char
birthDeath ch c
    | c == 3 && ch == '.' = 'X'
    | ch == 'X' && (c == 2 || c == 3) = 'X'
    | otherwise = '.'

doGen :: TwoDArray -> Point -> Char
doGen rg pt = birthDeath (fetch rg pt) (countSurroundingLife rg pt)

nextGen :: TwoDArray -> TwoDArray
nextGen td@(sz, rg) = makeArray sz $ map (doGen td) (allPoints sz)

lifes :: TwoDArray -> [TwoDArray]
lifes td = [td] ++ (lifes (nextGen td))

dumpRow :: TwoDArray -> Int -> IO()
dumpRow ((cx, cy), rg) iy = putStrLn $ map (rg!) $ [(iy * cx)..((iy * cx) + cx - 1)]

dumpMap :: TwoDArray -> Int -> IO()
dumpMap td@(size@(cx, cy), rg) iGen = do
    putStrLn $ "Generation " ++ (show iGen)
    mapM (dumpRow td) [0..(cy-1)]
    putStrLn ""

doLife :: [(Int, TwoDArray)] -> IO()
doLife [] = return ()
doLife (x@(iGen, rg):xs) = do
    dumpMap rg iGen
    doLife xs

main :: IO()
main = do
    doLife $ zip [1..20] (lifes start)
    where
        start = makeArray sz glider
        sz = (10, 10)

Haskell の勉強中です． 間引きはありません． 初期状態を表す， "0001000:0010010:001000..."のような文字列を，引数として与えます（':' は行の区切り）．

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
import List
import System
import System.Posix.Unistd

main = do args <- getArgs
          let initState    = [[read [c] :: Int| c <- line]| line <- initStateStr]
              initStateStr = split ':' $ head args
                  where
                    split :: (Eq a) => a -> [a] -> [[a]]
                    split d xs
                        | null xs   = []
                        | otherwise = case break (== d) xs of
                                        (fxs,[])  -> [fxs]
                                        (fxs,sxs) -> fxs : split d (tail sxs)
          (putEachStrWithSleep 400000) . (map stateToStr) $ lifeGame initState

putEachStrWithSleep :: Int -> [String] -> IO ()
putEachStrWithSleep _ []        = putStr ""
putEachStrWithSleep usec (s:ss) = (putStrLn . replace0 . replace1) s >> 
                                  usleep usec >> 
                                  putEachStrWithSleep usec ss
    where
      replace0 = replaceStr '0' '.'
      replace1 = replaceStr '1' '@'

      replaceStr :: Char -> Char -> String -> String
      replaceStr _ _ ""      = []
      replaceStr c c' (s:ss) = (if (c == s) then c' else s) : replaceStr c c' ss

infixl 9 !!>

(!!>) :: [a] -> Int -> a
(!!>) xs n
    | null xs   = error "Main.(!!>): empty list\n."
    | otherwise = xs !! (n `mod` length xs)

type State = [[Int]]

stateToStr :: State -> String
stateToStr []     = ""
stateToStr (s:ss) = concatMap show s ++ "\n" ++ stateToStr ss

lifeGame :: State -> [State]
lifeGame state = state : (lifeGame . nextState) state

nextState :: State -> State
nextState state = [[nextCell state (x,y)| x <- [0..maxX]]| y <- [0..maxY]]
    where
      maxX = ((length . head) state) - 1
      maxY = (length state) - 1

nextCell :: State -> (Int,Int) -> Int
nextCell state (x,y)
    | numNeighborLives == 2 = targetCell
    | numNeighborLives == 3 = if (targetCell == 0) then 1 else targetCell
    | otherwise             = 0
    where
      targetCell :: Int
      targetCell = cell (x,y)

      numNeighborLives :: Int
      numNeighborLives = (length . filter (== 1)) neighborCells

      neighborCells :: [Int]
      neighborCells
          = [cell (x-1,y-1), cell (x,y-1), cell (x+1,y-1),
             cell (x-1,y)  ,               cell (x+1,y)  ,
             cell (x-1,y+1), cell (x,y+1), cell (x+1,y+1)]

      cell :: (Int,Int) -> Int
      cell (x,y) = state !!> y !!> x

ランダムな初期環境を作り、50世代分を表示します。 （ただし、乱数処理が手抜きです） 間引きとかはやっていません。 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
module Main (main) where

import Data.Array
import Data.List (iterate)
import System.Random (randomRs, newStdGen)

newtype World = World (Array (Int, Int) Bool)
instance Show World where
    show (World cells) = concat $ map f $ assocs cells
        where showCell c = if c then "[*]" else "[ ]"
              (_, (lastx, _)) = bounds cells
              f ((_, x), c) | x == lastx = showCell c ++ "\n"
                            | otherwise  = showCell c

(!@) :: World -> (Int, Int) -> Bool
(World cells) !@ (x, y) = cells ! (wrap x, wrap y)
    where (_, (size, _)) = bounds cells
          wrap n | n < 0     = size
                 | n > size  = 0
                 | otherwise = n

next :: World -> World
next w@(World cells) = rebuild $ map step $ assocs cells
    where rebuild = World . array (bounds cells)
          around (px, py) = length $ filter id [w !@ (x, y) | x <- [px - 1 .. px + 1],
                                                              y <- [py - 1 .. py + 1],
                                                              x /= px || y /= py]
          step (p, True)  = let a = around p in (p, a == 2 || a == 3)
          step (p, False) = (p, around p == 3)

mkWorld :: Int -> IO World
mkWorld size = do g1 <- newStdGen
                  g2 <- newStdGen
                  return $ w g1 g2
    where ix       = ((0, 0), (size - 1, size - 1))
          init     = [((x, y), False) | x <- [0 .. size - 1], y <- [0 .. size - 1]]
          w g1 g2  = World $ array ix init // ps g1 g2
          ps g1 g2 = take (size * size `div` 3) $
                     flip zip (repeat True) $
                     zipWith (,) (randomRs (0, size - 1) g1) (randomRs (0, size - 1) g2)

generations :: World -> [World]
generations = iterate next

main :: IO ()
main = mkWorld 10 >>= mapM_ print . take 50 . generations

間引きはやってません。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
import List
import System.Environment
g0 = [[0,1,0,0,0,0,1,1,1,0],
      [0,0,0,0,1,0,0,1,1,0],
      [0,0,0,1,0,0,1,0,1,0],
      [1,0,1,1,0,0,1,0,0,0],
      [0,1,0,0,0,0,0,0,1,0],
      [1,0,0,0,1,0,1,1,0,1],
      [0,1,0,0,0,0,1,0,0,0],
      [0,0,0,0,0,0,0,0,0,1],
      [1,0,0,0,0,0,1,0,0,1],
      [0,0,0,0,1,1,0,0,1,0]]

revFun f = reverse.f.reverse
tspFun f = transpose.f.transpose
l t = map rotateL t
r t = map rotateR t
u t = (tspFun l) t
d t = (tspFun r) t


rotateL (x:xs) = xs++[x]
rotateR = revFun rotateL

showGame table = unlines $ map concat $ (map.map) (\x->if x==0 then "_" else "X")  table

zipped xs 
  |any (==[]) xs = []
  |otherwise     = map head xs:zipped (map tail xs)

next t = every 10 $ map nextCell $ zipped $ map concat [t,u t,d t,l t,r t,u$l$t,u$r$t,d$l$t,d$r$t]
  where nextCell (0:xs) = let live = length (filter (==1) xs)
                          in  if live == 3 then 1 else 0
        nextCell (1:xs) = let live = length (filter (==1) xs)
--                          in  if live == 3 || live == 2 then 1 else 0
                          in  if live == 2 then 1 else 0

every n xs = unfoldr f xs 
    where f [] = Nothing
          f cs = Just (splitAt n cs)


main  = getArgs >>= (\args-> mapM_ putStr $ take (getLim args) $
                     zipWith (\t game->"t="++show t++"\n"++showGame game) [1..]  (iterate next g0))
        where getLim []     = 10      --default
              getLim (x:xs) = read x

{-
*Main> :main 3
t=1
_X____XXX_
____X__XX_
___X__X_X_
X_XX__X___
_X______X_
X___X_XX_X
_X____X___
_________X
X_____X__X
____XX__X_
t=2
____X____X
_____X___X
__X_XXX_XX
_X_X_____X
__XX_XX_X_
_X___XX_XX
_____XXXXX
_________X
X____X__X_
X_________
t=3
X________X
X__X__X___
__XX__X___
XX________
_X_X______
X_X_______
__________
X____X____
X_________
X_________
-}


今更ですが、短さ重視で。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
import Data.List

-- 生きているセル:1 、死んでいるセル: 0
initialState = [[1,0,1,0,1,0,1,0,1,0],
                [1,1,1,0,1,0,1,0,1,0],
                [1,1,1,0,1,0,1,0,1,0],
                [1,0,1,0,1,0,1,0,1,0],
                [1,1,1,0,1,1,1,0,1,0],
                [1,1,1,0,1,0,1,0,0,0],
                [1,0,1,0,1,0,1,0,1,0],
                [1,1,1,0,0,0,1,0,1,0],
                [1,1,1,0,1,0,1,0,1,0],
                [1,0,1,0,1,1,1,0,1,0]]

lifeGame = -- 状態遷移の無限リスト
  unfoldr (\g -> Just (unfoldr f g, nextGeneration g)) $ foldl1 (++) initialState
    where w = length $ head initialState
          f g = if length g == 0 then Nothing else Just (take w g, drop w g)
          nextGeneration g = snd $ mapAccumL (\ i _ -> (i + 1, newState i)) 0 g
            where getState i = (cycle g) !! (if i >= 0 then i else length g + i)
                  livingCells i = sum [getState (x + y) | x <- [i - 1 .. i + 1], y <- [-w, 0, w]] - (getState i) 
                  newState i = case getState i of
                    1 -> if livingCells i == 2 || livingCells i == 3 then 1 else 0
                    0 -> if livingCells i == 3 then 1 else 0

main =  let n = 25 in -- 最初の25世代を表示
        let t = take (n + 1) lifeGame in
          flip mapM_ [0 .. n] $ \n -> do
            putStrLn $ "generation: " ++ (show n)
            mapM_ (\l -> putStrLn $ show l) $ t !! n

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]