HasteDrawImageTest.hs

import Haste
import Haste.DOM
import Haste.Events
import Haste.Foreign hiding (get)
import Haste.Graphics.Canvas
import Haste.Graphics.AnimationFrame
import Control.Monad.State
import Data.IORef
import qualified Data.IntMap as IM
import Lens.Family2
import Lens.Family2.Unchecked
import Lens.Family2.State.Lazy

randomRIO :: (Random a, MonadIO m) => (a,a) -> m a
randomRIO ix = liftIO $ do
  sd <- newSeed
  return $ fst $ randomR ix sd

data World = World {
  _lives :: [(Double, Double)],
  _livesIM :: IM.IntMap (Double, Double),
  _livesIOA :: JSAny,
  _running :: Bool,
  _timeStamp :: HRTimeStamp
  }

lives :: Lens' World [(Double, Double)]; lives = lens _lives (\a x -> a { _lives = x })
livesIM :: Lens' World (IM.IntMap (Double, Double)); livesIM = lens _livesIM (\a x -> a { _livesIM = x })
livesIOA :: Lens' World JSAny; livesIOA = lens _livesIOA (\a x -> a { _livesIOA = x })
running :: Lens' World Bool; running = lens _running (\a x -> a { _running = x })
timeStamp :: Lens' World HRTimeStamp; timeStamp = lens _timeStamp (\a x -> a { _timeStamp = x })

replaceNth n newVal (x:xs)
    | n == 0 = newVal:xs
    | otherwise = x:replaceNth (n-1) newVal xs

writeIOA :: (ToAny a, FromAny a) => Int -> a -> JSAny -> IO JSAny
writeIOA = ffi (toJSString "(function(n,x,xs){ xs[n] = x; return xs; })")

mainloop :: IORef World -> [Bitmap] -> Canvas -> IO ()
mainloop ref bmps cv = void $ do
  let objN = 1000
  -- render cv . stroke $ circle (0,0) 0

  onceStateT ref $ do
    r <- use running

    -- FFIArray
    -- when r $ do
    --   forM_ [1..objN] $ \i -> do
    --     k <- randomRIO (0,640 :: Double)
    --     k' <- randomRIO (0,480 :: Double)
    --     ls <- use livesIOA
    --     ls' <- liftIO $ writeIOA i (k,k') ls
    --     livesIOA .= ls'
    --
    --   ls0 <- use livesIOA
    --   ls <- liftIO $ fromAny ls0
    --   render cv $ do
    --     forM_ (take objN ls) $ \p -> do
    --       draw (bmps !! 2) p

    -- IntMap
    when r $ do
      forM_ [1..objN] $ \i -> do
        k <- randomRIO (0,640)
        k' <- randomRIO (0,480)
        livesIM %= IM.insert i (k,k')

      ls <- use livesIM
      render cv $ do
        forM_ (take objN $ IM.elems ls) $ \p -> do
          draw (bmps !! 2) p

    -- List
    -- when r $ do
    --   forM_ [1..objN] $ \i -> do
    --     k <- randomRIO (0,600)
    --     lives %= replaceNth i (k,fromIntegral i)
    --
    --   ls <- use lives
    --   render cv $ do
    --     forM_ (take objN ls) $ \(k,i) -> do
    --       draw (bmps !! 2) (k,i)

  requestAnimationFrame $ \p -> do
    onceStateT ref $ do
      t <- use timeStamp
      r <- use running
      when r $ do
        withElem "fps" $ \e -> do
          setProp e "innerText" $ show $ floor $ 1000 / (p - t)

      timeStamp .= p

    mainloop ref bmps cv


completeLoadBitmaps :: [Bitmap] -> IO () -> IO ()
completeLoadBitmaps bs cont = foldr (\b m -> void $ onEvent (elemOf b) Load $ const m) cont bs

main :: IO ()
main = do
  Just cv <- getCanvasById "hakoniwa-canvas"
  bmps <- mapM loadBitmap ["img/creature0.png", "img/creature1.png", "img/creature2.png"]
  ref <- newIORef $ World
    ([(fromIntegral x,0) |x <- [1..4000]])
    (IM.fromList [(x, (fromIntegral x,0)) |x <- [1..4000]])
    (toAny [(fromIntegral x :: Double,0 :: Double) |x <- [1..4000]])
    True 0

  withElem "game-run" $ \e -> do
    onEvent e Click $ \_ -> do
      onceStateT ref $ running .= True

  withElem "game-stop" $ \e -> do
    onEvent e Click $ \_ -> do
      onceStateT ref $ running .= False

  completeLoadBitmaps bmps $ do
    mainloop ref bmps cv

onceStateT :: IORef s -> StateT s IO a -> IO a
onceStateT ref m = do
  x <- readIORef ref
  (a,x') <- runStateT m x
  writeIORef ref $! x'
  return a