【Haskell】unsafeInterleaveIOでゲームループ

module Main where

import Multimedia.SDL
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Concurrent (threadDelay)

wndTitle = "delayed-stream test"
wndWidth = 256
wndHeight = 240
wndBpp = 32

frameRate = 60

-- 描画コマンド
type Scr = Surface -> IO ()

-- エントリ
main :: IO ()
main = do
    sdlInit [VIDEO]
    setCaption wndTitle wndTitle
    sur <- setVideoMode wndWidth wndHeight wndBpp [HWSURFACE, DOUBLEBUF, ANYFORMAT]
    do
        strm <- delayedStream (1000000 `div` frameRate) fetch
        let scrs = process $ map snd $ takeWhile notQuit strm
        mapM_ (\scr -> scr sur) scrs
    sdlQuit

    where
        -- 環境のフェッチ
        fetch = do
            quit <- checkSDLEvent
            ks <- getKeyState
            return (quit, ks)
        notQuit = not . fst

-- 遅延ストリーム
-- microsec 秒ごとに func を実行したアクションの結果をリストとして返す
delayedStream :: Int -> IO a -> IO [a]
delayedStream microsec func = unsafeInterleaveIO $ do
    threadDelay microsec
    x <- func
    xs <- delayedStream microsec func
    return $ x:xs

-- SDL のイベントを処理
-- 終了イベントがきたら True を返す
checkSDLEvent = do
    ev <- pollEvent
    case ev of
        Just QuitEvent    -> return True
        Just (KeyboardEvent { kbPress = True, kbKeysym = Keysym { ksSym = ks, ksMod = km } })
            | ks == SDLK_ESCAPE -> return True
            | ks == SDLK_F4 && (KMOD_LALT `elem` km || KMOD_RALT `elem` km) -> return True
        Nothing    -> return False
        _        -> checkSDLEvent

----

-- 状態
data GameState = GameState { x :: Int, y :: Int, cnt :: Int }

-- 初期状態
initialState = GameState { x = 100, y = 100, cnt = 0 }

-- キー入力を処理して描画コマンドを返す
process :: [[SDLKey]] -> [Scr]
process = loop initialState
    where
        loop gs [] = []
        loop gs (ks:kss) = scr' : loop gs' kss
            where (scr', gs') = update ks gs

-- 更新
update :: [SDLKey] -> GameState -> (Scr, GameState)
update ks gs = (render gs', gs')
    where
        gs' = GameState { x = x', y = y', cnt = cnt' }
        x' = x gs - (pressed SDLK_LEFT) + (pressed SDLK_RIGHT)
        y' = y gs - (pressed SDLK_UP) + (pressed SDLK_DOWN)
        cnt' = cnt gs + 1
        pressed k = if k `elem` ks then 1 else 0

-- 描画
render :: GameState -> Scr
render gs sur = do
    clearBG
    renderPlayer
    flipSurface sur
    return ()
    where
        clearBG = fillRect sur Nothing (fromInteger $ toInteger (cnt gs))
        renderPlayer = fillRect sur (Just $ Rect (x gs) (y gs) 16 16) 0xff0000