ラングトンのアリの描画 in Haskell DouKaku?

ラングトンのアリの描画

ラングトンのアリを描画してください。ラングトンのアリは、以下のような動きをする、セル・オートマトンです。(Wikipediaより引用)
- 黒いマスにアリがいた場合、90°右に方向転換し、そのマスの色を反転させ、1マス前進する。
- 白いマスにアリがいた場合、90°左に方向転換し、そのマスの色を反転させ、1マス前進する。
詳しくはWikipedia等で調べるか、参考ページに拙作のデモがありますのでご覧下さい。

see: JavaScriptでラングトンの蟻

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<html lang="ja">
<head>
       <meta http-equiv="content-type" content="text/html;charset=utf-8">
       <meta http-equiv="content-script-type" content="text/javascript">
       <meta http-equiv="content-style-type" content="text/css">
       <title>ラングトンの蟻</title>
<style type="text/css">
#canvas{
       border: 1px solid #999;
       width: 300px;
       height: 300px;
}
#canvas div{
       width: 3px;
       height: 3px;
       float: left;
}
</style>
<script>
var earth = [];
var WORLD_SIZE = 100;
var lang_ant;

function Ant(){}
Ant.prototype = {
    age : 0,
    ageDisplay : undefined,
    id : undefined,
    speed: 200,
    direction: [0,-1],//向き。x軸 y軸。最初は上に動く
    position: [60,40],//初期位置
    world: [],
    start: function(){
        var self = this;
        this.id = setInterval(function(){self.move()}, 1000/this.speed);
    },
    move: function(){
        this.ageDisplay.innerHTML = ++this.age;
        this.moveNextCell();
        var cell = this.getCellInfo();
        var color = cell.getAndToggleColor();
        this.setNextDirection(color);
    },
    moveNextCell: function(){
        this.position[0] += this.direction[0];
        this.position[1] += this.direction[1];
        if(this.position[0] < 0 || this.position[1] < 0 ||
           this.position[0] >= WORLD_SIZE || this.position[1] >= WORLD_SIZE){
            clearInterval(this.id);
            this.die();
        }
    },
    getCellInfo: function(){
        var idx = this.position[0] + this.position[1] * WORLD_SIZE;
        return this.world[idx];
    },
    setNextDirection: function(bool){//colorがfalse(白)なら右へ、true(黒)なら左へ転回
        if(bool){//黒
            var tmp = this.direction[0];
            this.direction[0] = this.direction[1];
            this.direction[1] = -tmp;
        }
        else{//白
            var tmp = this.direction[0];
            this.direction[0] = -this.direction[1];
            this.direction[1] = tmp;
        }
    },
    die: function(){
        alert('Langton\'s ant is dead.');
        throw true;
    }
};

function Cell(elm){
    this.elm = elm;
}
Cell.prototype = {
    elm: undefined,
    color: false, //colorは2値なのでbooleanで表す
    colorList: ['#FFF','#000'],
    getAndToggleColor: function(){
        this.color = !this.color;
        var i = this.color ? 1 : 0;
        this.elm.style.backgroundColor = this.colorList[i];
        return !this.color;
    }
}
window.onload = function(){
    var canvas = document.getElementById('canvas');
    var div = '<div></div>';
    var inner_canvas = "";
    for(var i=0; i< WORLD_SIZE*WORLD_SIZE; i++){
        inner_canvas += div;
    }
    canvas.innerHTML = inner_canvas;
    
    var cells = canvas.childNodes;
    for(var i=0; i<cells.length; i++){//世界の誕生
        earth[i] = new Cell(cells[i]);
    }
    lang_ant = new Ant();//蟻の誕生
    lang_ant.world = earth;//地球に降り立つ
    lang_ant.ageDisplay = document.getElementById('step');
    
    document.getElementById('run').disabled = false;
}
</script>
</head>
<body>
<p><input type="button" value="run" onclick="lang_ant.start();this.disabled=true;" id="run" disabled="disabled">　<span id="step"></span>
　<input type="button" value="stop &amp; refresh" onclick="location.reload();"></p>
<div id="canvas"></div>

post comment

Posted feedbacks - Haskell

Haskellで実装。要：UTF8-String

$ runhaskell langton.hs 100 100 20

とかすると、100x100マスの世界の模様を20ステップごとに表示してくれます。最後の数字を省略すると律儀に一世代ごとに印字します。

無限リストばんざい！

import qualified System.IO.UTF8 as U
import System.Environment (getArgs, getProgName)
import Control.Monad.State
import qualified Data.Map as M
import Data.List (sortBy, groupBy)

type Point = (Int, Int)
type Direction = (Int, Int)
data Ant = Ant {pos::Point, direction::Direction} deriving Show
data Color = White | Black

data AntsState = AS { world::(M.Map Point Color), ants::[Ant], wrap :: Bool, height::Int, width::Int, generation::Int }

instance Show Color where
  show Black = "■"
  show White = "□"

cmp f ((_,a),_) ((_,b),_) = f a b

instance Show AntsState where
  show AS{world=wd, generation=g} = "gen: " ++ show g ++ "\n" ++ (unlines $ map (concatMap(show.snd)) $ groupBy (cmp (==)) $ (sortBy (cmp compare) $ M.toList wd))

main = do args <- getArgs
          pname <- getProgName
          case args of
            (x:y:s:_) -> mapM_ (U.putStrLn . show . head) $ iterate (drop (read s)) $ evolutions (read x) (read y)
            (x:y:_)   -> mapM_ (U.putStrLn . show) $ evolutions (read x) (read y)
            _         -> putStrLn ("usage: " ++ pname ++ " height width [step]")

makeAnt x y = Ant {pos=(x, y), direction=(0,-1)}

makeWorld height width ants wrap = AS {
  world = M.fromList [((x,y), White) | x <- [0..width-1], y <- [0..height-1]],
  ants = ants,
  height = height,
  width = width,
  generation = 0,
  wrap = wrap
}

proceed :: State AntsState AntsState
proceed = do  st@AS{ants=as,generation=g} <- get
              a' <- mapM procAnts as
              st <- get
              let s = st{ants = a',generation=g+1}
              put s
              return s

procAnts ant@Ant{pos=p@(x,y), direction=(dx,dy)} = do
  w@AS{world=wd, wrap=wr, width=wdt, height=h} <- get
  let pt = ((x+dx) `mod` wdt, (y+dy) ` mod` h)
      st = maybe Black id $ M.lookup pt wd
      (dr, s') = case st of
                  Black -> ((dy, -dx), White)
                  _     -> ((-dy, dx), Black)
  put w{world= M.insert pt s' wd}
  return ant{pos = pt, direction = dr}

evolutions width height = iterate (execState proceed) (makeWorld width height [makeAnt (width*3`div`5) (height*2`div`5)] True)

Haskellに翻訳。
C++からの「翻訳」なのでHaskellらしくないかもしれません。

import Graphics.UI.GLUT
import Control.Exception
import System.Exit
import Data.IORef

interval     = 0
windowWidth  = 320::GLsizei
windowHeight = 240::GLsizei

data Direction = North | East | South | West deriving Enum
data Ant = Ant Position Direction

turnRight :: Direction -> Direction
turnRight d = toEnum (((fromEnum d) + 1) `mod` 4)

turnLeft :: Direction -> Direction
turnLeft d = toEnum (((fromEnum d) + 3) `mod` 4)

initialEnv :: (Ant, [Position])
initialEnv = (Ant (Position (windowWidth `div` 2) (windowHeight `div` 2)) East, [])

convd :: (Integral a) => a -> GLdouble
convd = fromInteger.toInteger

forward (Position x y) North = Position x (y - 1)
forward (Position x y) East  = Position (x + 1) y
forward (Position x y) South = Position x (y + 1)
forward (Position x y) West  = Position (x - 1) y

draw env = do
  (_, ps) <- readIORef env
  clearColor $= Color4 1.0 1.0 1.0 1.0
  clear [ColorBuffer]
  color $ Color3 (0.0::Double) 0.0 0.0
  renderPrimitive Points $ mapM_ (¥ (Position x y) -> vertex $ Vertex2 x y) ps
  swapBuffers

update (Ant pos dir, ps) =
  if elem pos ps
    then (Ant (forward pos (turnRight dir)) (turnRight dir), [p | p <- ps, p /= pos])
    else (Ant (forward pos (turnLeft dir)) (turnLeft dir), pos:ps)

-- event handlers

display env = do
  draw env

reshape (Size w h) = do
  viewport $= (Position 0 0, Size w h)
  loadIdentity
  ortho (-0.5) ((convd w) - 0.5) ((convd h) - 0.5) (-0.5) (-1.0) (1.0)

keyboardMouse key keystate modifiers position = do
  case key of
    Char 'q' -> throwIO $ ExitException ExitSuccess
    _        -> return ()

timer env = do
  modifyIORef env $ update
  draw env
  addTimerCallback interval $ timer env

main = do
  env <- newIORef initialEnv
  getArgsAndInitialize
  initialDisplayMode    $= [RGBAMode, DoubleBuffered]
  initialWindowPosition $= Position 100 100
  initialWindowSize     $= Size windowWidth windowHeight
  createWindow "doukaku#276"
  displayCallback       $= display env
  reshapeCallback       $= Just reshape
  keyboardMouseCallback $= Just keyboardMouse
  addTimerCallback interval $ timer env
  mainLoop

DouKaku?

ラングトンのアリの描画

Posted feedbacks - Haskell

Index

Feed

Other

Link

Pathtraq