ゆるふわブログ

東京大学理科 I 類 2 年の学生です.プログラミング,大学の勉強,日常生活で感じたことをゆるふわに書いていけたらなと思います.技術的に拙いところがあっても温かい目で見守っていただければ幸いです.

ブロック崩し (by Haskell)

Haskell から JavaScript に変換してくれる Haste というライブラリを使ってとりあえずブロック崩しを作って見ました.
忙しいので詳細は後日書きます.
以下ソースコード

{-# LANGUAGE LambdaCase #-}
import Haste
import Haste.DOM
import Haste.Events
import Haste.Graphics.Canvas
import Lens.Micro
import Control.Applicative
import Control.Arrow ((***))
import Control.Monad
import Data.Array
import Data.IORef
import System.Random

data BlkState = NoDamage | Hit | Destroy
  deriving (Eq, Enum)

data ScrState = Prepare | Game | Clear
  deriving Eq

data State = State {
  scrRef :: IORef ScrState,
  keyFRef :: IORef (Bool, Bool),
  bxRef :: IORef Double,
  bpRef :: IORef Point,
  bvRef :: IORef Point,
  missRef :: IORef Int,
  blocks :: IORef (Array (Int, Int) BlkState)
}

bnw, bnh :: Int
(bnw,bnh) = (12, 12)

main :: IO ()
main = do
  elemById "canvas" >>= \case
    Just cid -> do
      w <- read <$> getProp cid "width"
      h <- read <$> getProp cid "height"
      let (bw, bh) = (floor (w/fi bnw), floor (h/fi (2*bnh)))

      scrRef <- newIORef Prepare
      keyFRef <- newIORef (False, False)
      bxRef <- newIORef (-50)
      bpRef <- newIORef (0, h/2-70)
      theta <- randomRIO (-pi/3, pi/3) :: IO Double
      bvRef <- newIORef (5*cos (theta-pi/2), 5*sin (theta-pi/2))
      missRef <- newIORef 0
      arr <- newIORef $ listArray ((0,0),(bh,bw)) $ repeat NoDamage

      documentBody `onEvent` KeyDown $ \(KeyData code _ _ _ _) -> do
        when (code==37) $ modifyIORef keyFRef (&_1.~True)        -- Left
        when (code==39) $ modifyIORef keyFRef (&_2.~True)        -- Right
        scr <- readIORef scrRef
        when (code==13 && scr /= Clear) $ writeIORef scrRef Game -- Enter
      documentBody `onEvent` KeyUp $ \(KeyData code _ _ _ _) -> do
        when (code==37) $ modifyIORef keyFRef (&_1.~False) -- Left
        when (code==39) $ modifyIORef keyFRef (&_2.~False) -- Right
      
      getCanvas cid >>= \case
        Just cvs -> loop cvs (w,h) (bw,bh) (State scrRef keyFRef bxRef bpRef bvRef missRef arr)
        Nothing  -> error "Canvas could not be found!"
    Nothing  -> error "Canvas ID could not be found!"

loop :: Canvas -> Vector -> (Int, Int) -> State -> IO ()
loop cvs (w,h) (bw,bh) (State scrRef keyFRef bxRef bpRef bvRef missRef arr) = do
  let org = (w/2,h/2)

  scr <- readIORef scrRef
  bx <- readIORef bxRef

  when (scr /= Prepare) $ do
    (leftF, rightF) <- readIORef keyFRef
    when (leftF && bx > -w/2) $ modifyIORef bxRef (subtract 5)
    when (rightF && bx+fi bw-10 < w/2) $ modifyIORef bxRef (+5)

    bv <- readIORef bvRef
    modifyIORef bpRef ((+fst bv)***(+snd bv))

  (bpx, bpy) <- readIORef bpRef
  miss <- readIORef missRef
  blocks <- readIORef arr 

  render cvs $ translate org $ do
    color (RGB 40 40 40) $ fill $ rect (bx,h/2-50) (bx+fi bw-10,h/2-50+fi bh-5)
    color (RGB 40 40 40) $ fill $ circle (bpx,bpy) 10
    color (RGB 40 40 40) $ font "30px ヒラギノ角ゴ" $ text (-w/2+10,-h/2+38) $ "Miss: " ++ show miss
    forM_ [0..bnh-1] $ \i -> do
      forM_ [0..bnw-1] $ \j -> do
        let alpha = case blocks!(i,j) of
                      NoDamage -> 1.0
                      Hit -> 0.2
                      Destroy -> 0

        opacity alpha $ do
          color (hsv ((fi bnh-1-fi i+fi j)*360/fi bnh) 180 240) $ fill $ rect ((w-fi bnw*fi bw)/2+fi bw*fi j+5-w/2, 60+fi i*fi bh-h/2) ((w-fi bnw*fi bw)/2+fi bw*fi j+5-w/2+fi bw-10, 60+fi i*fi bh+fi bh-5-h/2)
          let (rx,ry) = ((w-fi bnw*fi bw)/2+fi bw*fi j+5-w/2+2, 60+fi i*fi bh-h/2+2)
          color (hsv ((fi bnh-1-fi i+fi j)*360/fi bnh) 120 240) $ lineWidth 5 $ stroke $ path [(rx,ry), (rx+fi bw-10-4,ry), (rx+fi bw-10-4,ry+fi bh-5-4), (rx,ry+fi bh-5-4), (rx,ry-2.5)]

    when (scr /= Game) $ do
      opacity 0.8 $ color (RGB 40 40 40) $ fill $ rect (-w/2,-h/2) (w/2,h/2)
      color (RGB 255 255 255) $ font "60px ヒラギノ角ゴ" $ do
        when (scr == Prepare) $ text (-450/2,0) "Enter To Start!"
        when (scr == Clear) $ text (-240/2,0) "Cleared!"

  when (bpx < -w/2+10 || bpx > w/2-10) $ modifyIORef bvRef (&_1%~negate)
  when (bpy < -h/2+10 || bpy > h/2-10) $ modifyIORef bvRef (&_2%~negate) 
  when (bpy > h/2-10) $ modifyIORef missRef (+1)
  reflect (bw,bh) (bx,h/2-50) (bpx,bpy) bpRef bvRef

  forM_ [0..bnh-1] $ \i -> do
    forM_ [0..bnw-1] $ \j -> when (blocks!(i,j) /= Destroy) $ do
      refF <- reflect (bw,bh) ((w-fi bnw*fi bw)/2+fi bw*fi j+5-w/2, 60+fi i*fi bh-h/2) (bpx,bpy) bpRef bvRef

      when refF $ writeIORef arr $ blocks // [((i,j), succ $ blocks!(i,j))]

  when (all (==Destroy) $ elems blocks) $ writeIORef scrRef Clear

  setTimer (Once 10) (loop cvs (w,h) (bw,bh) (State scrRef keyFRef bxRef bpRef bvRef missRef arr))
  return ()

reflect :: (Int, Int) -> Point -> Point -> IORef Point -> IORef Point -> IO Bool
reflect (bw,bh) (bx,by) (x,y) bpRef bvRef = do
  if (y+10 >= by && y-10 <= by+fi bh-5 && x+10 >= bx && x-10 <= bx+fi bw-10)
    then do
      modifyIORef bvRef (&_2%~negate)
      when (y+10 < by+fi bh-5) $ modifyIORef bpRef (&_2%~(subtract 1))
      when (y-10 > by) $ modifyIORef bpRef (&_2%~(+1))
      when (y+10 < by || y-10 > by+fi bh-5) $ modifyIORef bvRef (&_1%~negate)
      return True
    else return False

fi :: (Integral a, Num b) => a -> b
fi = fromIntegral

hsv :: Double -> Double -> Double -> Color
hsv h s v = case hi of
  0 -> fRGB v k m
  1 -> fRGB n v m
  2 -> fRGB m v k
  3 -> fRGB m n v
  4 -> fRGB k m v
  5 -> fRGB v m n
  where
    h' = h-(fromIntegral $ floor $ h/360)*360
    hi = fromIntegral $ floor $ h' / 60
    f = h' / 60 - hi
    m = v * (1-s/255)
    n = v * (1-s/255*f)
    k = v * (1-s/255*(1-f))
    fRGB :: Double -> Double -> Double -> Color
    fRGB r g b = RGB (floor r) (floor g) (floor b)

練習あるのみと思って下手くそなりに書いてみたわけだけど,絶対もっとうまく書けるよね… IORef 使う以外にないのかなぁ…
Haste サンプルが少なくて使い方よくわかってないけど,とりあえず描画とキーの取得さえできればゲームはできる (?)

f:id:Ysmr_Ry:20170119094626g:plain