rhythm-game-tutorial-0.1.1: src/tutorial-extended.hs

{-# LANGUAGE Rank2Types, ImpredicativeTypes, ViewPatterns #-}
import Call hiding (new')
import Call.Util.Deck as Deck
import Control.Lens
import Control.Monad.State.Strict
import Data.Foldable (foldMap)
import qualified Data.Set as Set
import Data.Set (Set)
import System.IO.Unsafe
import Data.List
import Data.List.Split (splitWhen)
import Call.Util.Text as Text
import Data.Functor.Request
import Control.Object

gameMain :: System s ()
gameMain = do
  setFPS 60
  music <- prepareMusic "assets/Monoidal Purity.wav"

  allTimings <- liftIO $ parseScore (60/160*4) <$> readFile "assets/Monoidal Purity.txt"

  text <- Text.simple defaultFont 24

  timings <- new $ variable allTimings
  score <- new $ variable 0
  effects <- new $ variable []

  linkPicture $ \dt -> do
    [l0, l1, l2] <- forM [0..2] $ \i -> renderLane <$> (timings .- use (ix i)) <*> getPosition music
    s <- score .- get
    ef <- effects .- gatherFst id (apprises (request dt))
    return $ translate (V2 (-120) 0) l0
      <> translate (V2 0 0) l1
      <> translate (V2 120 0) l2
      <> color black (translate (V2 240 40) (text (show s)))
      <> ef

  let touchLane i = do
        ((sc, obj), ts') <- handle <$> getPosition music <*> (timings .- use (ix i))
        effects .- modify (obj:)
        timings .- ix i .= ts'
        score .- modify (+sc)

  linkKeyboard $ \ev -> case ev of
    Down KeySpace -> touchLane 1
    Down KeyF -> touchLane 0
    Down KeyJ -> touchLane 2
    _ -> return () -- Discard the other events

  playMusic music

main = runSystemDefault (gameMain >> stand)

type Music s = Instance (StateT Deck (System s)) (System s)

prepareMusic :: FilePath -> System s (Music s)
prepareMusic path = do
  wav <- readWAVE path
  i <- new $ variable $ source .~ sampleSource wav $ Deck.empty
  linkAudio $ \dt n -> i .- playback dt n
  return i

phases :: Set Time -- ^ timings
    -> Time -- ^ life span
    -> Time -- ^ the current time
    -> [Float] -- ^ phase
phases s len t = map ((/len) . subtract t) -- transform to an interval [0, 1]
  $ Set.toList
  $ fst $ Set.split (t + len) s -- before the limit

circle_png :: Bitmap
circle_png = unsafePerformIO $ readBitmap "assets/circle.png"

_perfect_png = unsafePerformIO $ readBitmap "assets/perfect.png"
_good_png = unsafePerformIO $ readBitmap "assets/good.png"
_error_png = unsafePerformIO $ readBitmap "assets/error.png"

circles :: [Float] -> Picture
circles = foldMap (\p -> V2 320 ((1 - p) * 480) `translate` bitmap circle_png)

renderLane :: Set Time -> Time -> Picture
renderLane ts t = mconcat [color blue $ circles (phases ts 1 t)
    , V2 320 480 `translate` color black (bitmap circle_png) -- criterion
    ]

getPosition :: Music s -> System s Time
getPosition m = m .- use pos

playMusic :: Music s -> System s ()
playMusic m = m .- playing .= True

parseScore :: Time -> String -> [Set Time]
parseScore d = map (Set.fromAscList . concat . zipWith (map . (+)) [0,d..]) . Data.List.transpose . map (map f) . splitWhen (=="") . lines where
  f l = [t | (t, c) <- zip [0, d/fromIntegral (length l)..] l, c == '.']

type Effect m = Mortal (Request Time Picture) m ()

rate :: Monad m => Time -> (Int, Effect m)
rate dt
  | dt < 0.05 = (4, pop _perfect_png)
  | dt < 0.1 = (2, pop _good_png)
  | otherwise = (1, pop _error_png)

handle :: Monad m => Time -> Set Time -> ((Int, Effect m), Set Time)
handle t ts = case viewNearest t ts of
  Nothing -> ((0, pop _error_png), ts) -- The song is over
  Just (t', ts') -> (rate $ abs (t - t'), ts')

viewNearest :: (Num a, Ord a) => a -> Set a -> Maybe (a, Set a)
viewNearest t ts = case Set.split t ts of
  (sa@(Set.maxView -> Just (a, sa')), sb@(Set.minView -> Just (b, sb')))
    | t - a < b - t -> Just (a, sa' `Set.union` sb)
    | otherwise -> Just (b, sa `Set.union` sb')
  (Set.maxView -> Just (a, sa'), _) -> Just (a, sa')
  (_, Set.minView -> Just (b, sb')) -> Just (b, sb')
  _ -> Nothing

pop :: Monad m => Bitmap -> Effect m
pop bmp = Mortal $ Control.Object.transit 0.5 $ \t -> return $ translate (V2 320 360)
  $ translate (V2 0 (-80) ^* t)
  $ color (V4 1 1 1 (realToFrac $ 1 - t))
  $ bitmap bmp