2次元格子ランダムウォーク
Haskellで2次元格子ランダムウォークを書いてみた。
全然、Haskellで書いた気がせず不満。
IOと評価を分けたいが次の課題。
import Data.IORef import Control.Applicative import Data.Foldable import System.Random.Mersenne import System.Exit (exitWith, ExitCode(ExitSuccess)) import Graphics.UI.GLUT as GLUT import Graphics.Rendering.FTGL as FTGL --Applicativeを使って見やすい表現に instance Num a => Num (Vertex3 a) where v1 + v2 = (+) <$> v1 <*> v2 v1 - v2 = (-) <$> v1 <*> v2 v1 * v2 = (*) <$> v1 <*> v2 -- 内積やスカラー積を求めるときに使う abs = undefined signum = undefined fromInteger = undefined data State = State { mtGen :: MTGen, -- 乱数生成の文脈 points :: IORef [Vertex3 GLfloat], -- 軌跡 counter :: IORef Int, -- 試行回数 limit :: Int, -- 最大試行回数 font :: FTGL.Font, -- Bitmap Fontの情報 xAccumulate :: IORef Double, -- x変位の積算値 yAccumulate :: IORef Double, -- y変位の積算値 xSquareAccumulate :: IORef Double, -- (x変位)^2の積算値 ySquareAccumulate :: IORef Double -- (y変位)^2の積算値 } --内積 dot :: (Foldable t, Num (t a), Num a) => t a -> t a -> a dot v1 v2 = Data.Foldable.foldl1 (+) v' where v' = v1 * v2 --スカラ積 scala :: (Functor t, Num a, Num (t a)) => a -> t a -> t a scala s v = (* s) <$> v --タイマインターバル(msec) timerInterval = 100 makeState :: Int -> FTGL.Font -> IO State makeState limit' font' = do newGen <- newMTGen Nothing initPoints <- newIORef [ Vertex3 100 100 0] newCounter <- newIORef 0 newX <- newIORef 0 newY <- newIORef 0 newsX <- newIORef 0 newsY <- newIORef 0 return $ State { mtGen = newGen, points = initPoints, counter = newCounter, limit = limit', font = font', xAccumulate = newX, yAccumulate = newY, xSquareAccumulate = newsX, ySquareAccumulate = newsY } display :: State -> DisplayCallback display state = do points <- readIORef $ points state clear [ ColorBuffer ] -- 単位行列を読み込む loadIdentity -- 頂点配列設定 -- presevingMarixが行列のPush/Popを行なってくれる GLUT.preservingMatrix $ do color (Color3 1 1 1 :: Color3 GLfloat) -- 色は白 -- renderPrimitiveが glBegin() - glEnd GLUT.renderPrimitive LineStrip $ Prelude.mapM_ vertex [ Vertex3 200 0 0, Vertex3 0 0 0, Vertex3 0 200 0 :: Vertex3 GLfloat] color (Color3 1 0 0 :: Color3 GLfloat) -- 色は赤 GLUT.renderPrimitive LineStrip $ Prelude.mapM_ vertex points GLUT.preservingMatrix $ do color (Color3 1 1 1 :: Color3 GLfloat) -- 色は白 rasterPos (Vertex3 0 200 0::Vertex3 GLfloat) nowCount <- get $ counter state FTGL.renderFont (font state) ("N=" ++ (show nowCount)) All xAcc <- get $ xAccumulate state yAcc <- get $ yAccumulate state xsAcc <- get $ xSquareAccumulate state ysAcc <- get $ ySquareAccumulate state let xAvg = xAcc/(fromIntegral $ nowCount) yAvg = yAcc/(fromIntegral $ nowCount) xsAvg = xsAcc/(fromIntegral $ nowCount) ysAvg = ysAcc/(fromIntegral $ nowCount) xSigma = xsAvg - xAvg ** 2 ySigma = ysAvg - yAvg ** 2 rasterPos (Vertex3 0 196 0::Vertex3 GLfloat) FTGL.renderFont (font state) ("<x>=" ++ (show xAvg)) All rasterPos (Vertex3 65 196 0::Vertex3 GLfloat) FTGL.renderFont (font state) ("<y>=" ++ (show xAvg)) All rasterPos (Vertex3 0 192 0::Vertex3 GLfloat) FTGL.renderFont (font state) ("<x^2>=" ++ (show xsAvg)) All rasterPos (Vertex3 65 192 0::Vertex3 GLfloat) FTGL.renderFont (font state) ("<y^2>=" ++ (show xsAvg)) All rasterPos (Vertex3 0 188 0::Vertex3 GLfloat) FTGL.renderFont (font state) ("Sigma_x=" ++ (show xSigma)) All rasterPos (Vertex3 65 188 0::Vertex3 GLfloat) FTGL.renderFont (font state) (" Sigma_y=" ++ (show ySigma)) All swapBuffers -- ウインドウサイズが変更されたときに呼ばれる reshape:: ReshapeCallback reshape size = do viewport $= (Position 0 0, size) -- ウインドウ全体を使う --射影行列の設定 matrixMode $= Projection loadIdentity --正射影を使います --二次元平面を使いたいのでこれでOK ortho (-5) 205 (-5) 205 (-1) 1 --Modelviewモードに戻す matrixMode $= Modelview 0 loadIdentity --Keyboard入力 ESCだけ引き取り keyboardMouse :: State -> KeyboardMouseCallback keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess keyboardMouse _ _ _ _ _ = return () update::State -> IO() update state = do updatePos <- random (mtGen state) :: IO Int counter' <- get $ counter state lastPoints <- get $ points state let dirc = updatePos `mod` 4 newPos = decideNewPos dirc $ last lastPoints newPoints = lastPoints ++ [newPos] limit' = limit state statistic state dirc -- 終了判定 if isEnd counter' limit' newPos then do putStr "reach limit:" print limit' else do writeIORef (points state) newPoints modifyIORef (counter state) (+1) GLUT.addTimerCallback timerInterval $ update state GLUT.postRedisplay Nothing where decideDelta :: Int -> Vertex3 GLfloat decideDelta 0 = Vertex3 1 0 0 :: Vertex3 GLfloat decideDelta 1 = Vertex3 (-1) 0 0 :: Vertex3 GLfloat decideDelta 2 = Vertex3 0 1 0 :: Vertex3 GLfloat decideDelta 3 = Vertex3 0 (-1) 0 :: Vertex3 GLfloat decideDelta _ = Vertex3 0 0 0 :: Vertex3 GLfloat decideNewPos :: Int -> Vertex3 GLfloat -> Vertex3 GLfloat decideNewPos n lastPos = lastPos + decideDelta n --統計情報を取るための関数 statistic :: State -> Int -> IO () statistic state n = do let x' = (fromRational.toRational.dot ex $ decideDelta n) :: Double let y' = (fromRational.toRational.dot ey $ decideDelta n) :: Double modifyIORef (xAccumulate state) (+ x') modifyIORef (yAccumulate state) (+ y') modifyIORef (xSquareAccumulate state) (+ x'**2) modifyIORef (ySquareAccumulate state) (+ y'**2) return () ex = Vertex3 1 0 0 -- xの基底 ey = Vertex3 0 1 0 -- yの基底 --終了判定指定した回数または、壁にぶつかれば終了 isEnd :: Int -> Int -> Vertex3 GLfloat -> Bool isEnd c l p = (c >= l) || dot ex p == 200 || dot ey p == 200 || dot ex p == 0 || dot ey p == 0 main::IO () main = do -- ウインドウタイトルと引数を取る (progName, _args) <- GLUT.getArgsAndInitialize let limit = if null _args then 10000 else read $ head _args :: Int -- $=はData.StateVerの演算子 GLUT.initialDisplayMode $= [DoubleBuffered, RGBMode] GLUT.initialWindowSize $= Size 800 800 GLUT.initialWindowPosition $= Position 100 100 GLUT.createWindow "2D Simple Random Walk" font <- FTGL.createBitmapFont "/usr/share/fonts/meguri/meguri.ttf" FTGL.setFontFaceSize font 18 18 state <- makeState limit font --背景色は黒 GLUT.clearColor $= Color4 0 0 0 0 -- displayコールバックを登録.描画が指示されたときに発生 GLUT.displayCallback $= display state -- windowSizeなどが変更されたときに発生するEventCallback GLUT.reshapeCallback $= Just reshape GLUT.keyboardMouseCallback $= Just (keyboardMouse state) -- TimerCallback登録 GLUT.addTimerCallback timerInterval $ update state mainLoop
参考にしたpage
プログラミング/Haskell/GLUT - Flightless wing
zmx.jp
GLUTによる「手抜き」OpenGL入門
