diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2012, Fumiaki Kinoshita - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Fumiaki Kinoshita nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2012, Fumiaki Kinoshita + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Fumiaki Kinoshita nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/assets/Monoidal Purity.txt b/assets/Monoidal Purity.txt --- a/assets/Monoidal Purity.txt +++ b/assets/Monoidal Purity.txt @@ -1,301 +1,301 @@ ----------------- ----------------- ----------------- - ----------------- ----------------- ----------------- - -----.----------- -.-------.------- -------------.--- - -----.----------- -.-----------.--- ---------.------- - -----.----------- -.-------.---.--- ----------------- - ----------------- -.--------------- -----.---.---.--- - ----------------- -.--------------- ----------------- - -------.--------- -------------.--- -.--------------- - -------------.-.- -.-------.------- -----.-.--------- - --.-.-.-.-------- -.-------.------- ---.-.-.--------- - -.-------------.- ---.-.---.-.-.--- -------.--.------ - ---.-----.-----.- -.---.-------.--- -------.---.----- - -----.-----.----- -.-----------.--- -----.---------.- - -------.---.----- -.---.-------.--- ---.-----------.- - ---.-.---------.- -.-----.-.-.-.--- ----------.------ - ---.-----.-----.- -.---.-------.--- -------.---.----- - -.---------.----- -----.---.------- -------.--------- - ---.-------.---.- -----.---.---.--- -------.--------- - -.-------------.- ---.-.---.-.-.--- -------.--.------ - ---.-----.-----.- -.---.-------.--- -------.---.----- - -----.-----.----- -.-----------.--- -----.---------.- - -------.---.----- -.---.-------.--- ---.-----------.- - ---.-.---------.- -.-----.-.-.-.--- ----------.------ - ---.-----.-----.- -.---.-------.--- -------.---.----- - -.---.---.---.--- ----------------- ---.---.---.---.- - -.-.-.-.-.-.-.-.- ----------------- --.-.-.-.-.-.-.-. - -------------.-.- -.--.--.--.------ ----------------- - -------------.-.- -.--.--.--.------ ----------------- - -------------.-.- ----------------- -.--.--.--.------ - -------------.-.- ----------------- -.--.--.--.------ - -------------.-.- -.--.--.--.------ ----------------- - -------------.-.- -.--.--.--.------ ----------------- - -------------.-.- ----------------- -.--.--.--.------ - -------------.-.- ----------------- -.--.--.--.------ - ----------------- ----------------- ---.-.---.--.--.- - ----------------- ---.-.---.--.--.- ----------------- - -.---.---.--.--.- ----------------- ----------------- - ----------------- -.---.---.--.--.- ----------------- - ----------------- ---------.--.--.- ---.-.----------- - ----------------- ---.-.----------- ---------.--.--.- - ---------.--.--.- ---.-.----------- ----------------- - ---.-.----------- ----------------- ---------.--.--.- - -------------.--- -.--------------- -----.----------- - -------------.--- ----------------- -----.----------- - -------------.--- ----------------- -----.----------- - -------------.--- ----------------- -----.----------- - -------------.--- -.-------.------- -----.----------- - -------------.--- -.-------.------- -----.----------- - -------------.--- -.-------.------- -----.----------- - -------------.--- -.-------.------- -----.----------- - -------------.--- -.-------.------- -----.----------- - -------------.--- -.-------.------- -----.----------- - -------------.--- -.-------.------- -----.----------- - -------------.--- -.-------.------- -----.----------- - ----------------- -.--------------- ----------------- - ----------------- -.--------------- ----------------- - ----------------- -.-------.------- ----------------- - -.---.---.-.-.-.- ----------------- ---.---.--.-.-.-. - - -.-------.-.---.- -.-.-.-------.--- -.-----.--.------ - ---.-----------.- -.---.---.---.--- -------.---.----- - -----.-----.----- -.-----------.--- -----.---------.- - -------.---.----- -.---.-------.--- ---.-----------.- - ---------.-.---.- ---.-.-------.--- -.-----.--.------ - -.---.-----.---.- ---.-----.---.--- -------.--------- - -----.----------- -.-----.---.---.- -------------.--- - ---.-------.---.- -----.---.---.--- -------.--------- - - -.-------.-.---.- -.-.-.-------.--- -.-----.--.------ - ---.-----------.- -.---.---.---.--- -------.---.----- - -----.-----.----- -.-----------.--- -----.---------.- - -------.---.----- -.---.-------.--- ---.-----------.- - ---------.-.---.- ---.-.-------.--- -.-----.--.------ - -.---.-----.---.- ---.-----.---.--- -------.--------- - -----.----------- -.-----.---.---.- -------------.--- - ---.---.--------- -.---.-----.---.- ---------.---.--- - -.--------------- -.--------------- +---------------- +---------------- +---------------- + +---------------- +---------------- +---------------- + +----.----------- +.-------.------- +------------.--- + +----.----------- +.-----------.--- +--------.------- + +----.----------- +.-------.---.--- +---------------- + +---------------- +.--------------- +----.---.---.--- + +---------------- +.--------------- +---------------- + +------.--------- +------------.--- +.--------------- + +------------.-.- +.-------.------- +----.-.--------- + +-.-.-.-.-------- +.-------.------- +--.-.-.--------- + +.-------------.- +--.-.---.-.-.--- +------.--.------ + +--.-----.-----.- +.---.-------.--- +------.---.----- + +----.-----.----- +.-----------.--- +----.---------.- + +------.---.----- +.---.-------.--- +--.-----------.- + +--.-.---------.- +.-----.-.-.-.--- +---------.------ + +--.-----.-----.- +.---.-------.--- +------.---.----- + +.---------.----- +----.---.------- +------.--------- + +--.-------.---.- +----.---.---.--- +------.--------- + +.-------------.- +--.-.---.-.-.--- +------.--.------ + +--.-----.-----.- +.---.-------.--- +------.---.----- + +----.-----.----- +.-----------.--- +----.---------.- + +------.---.----- +.---.-------.--- +--.-----------.- + +--.-.---------.- +.-----.-.-.-.--- +---------.------ + +--.-----.-----.- +.---.-------.--- +------.---.----- + +.---.---.---.--- +---------------- +--.---.---.---.- + +.-.-.-.-.-.-.-.- +---------------- +-.-.-.-.-.-.-.-. + +------------.-.- +.--.--.--.------ +---------------- + +------------.-.- +.--.--.--.------ +---------------- + +------------.-.- +---------------- +.--.--.--.------ + +------------.-.- +---------------- +.--.--.--.------ + +------------.-.- +.--.--.--.------ +---------------- + +------------.-.- +.--.--.--.------ +---------------- + +------------.-.- +---------------- +.--.--.--.------ + +------------.-.- +---------------- +.--.--.--.------ + +---------------- +---------------- +--.-.---.--.--.- + +---------------- +--.-.---.--.--.- +---------------- + +.---.---.--.--.- +---------------- +---------------- + +---------------- +.---.---.--.--.- +---------------- + +---------------- +--------.--.--.- +--.-.----------- + +---------------- +--.-.----------- +--------.--.--.- + +--------.--.--.- +--.-.----------- +---------------- + +--.-.----------- +---------------- +--------.--.--.- + +------------.--- +.--------------- +----.----------- + +------------.--- +---------------- +----.----------- + +------------.--- +---------------- +----.----------- + +------------.--- +---------------- +----.----------- + +------------.--- +.-------.------- +----.----------- + +------------.--- +.-------.------- +----.----------- + +------------.--- +.-------.------- +----.----------- + +------------.--- +.-------.------- +----.----------- + +------------.--- +.-------.------- +----.----------- + +------------.--- +.-------.------- +----.----------- + +------------.--- +.-------.------- +----.----------- + +------------.--- +.-------.------- +----.----------- + +---------------- +.--------------- +---------------- + +---------------- +.--------------- +---------------- + +---------------- +.-------.------- +---------------- + +.---.---.-.-.-.- +---------------- +--.---.--.-.-.-. + + +.-------.-.---.- +.-.-.-------.--- +.-----.--.------ + +--.-----------.- +.---.---.---.--- +------.---.----- + +----.-----.----- +.-----------.--- +----.---------.- + +------.---.----- +.---.-------.--- +--.-----------.- + +--------.-.---.- +--.-.-------.--- +.-----.--.------ + +.---.-----.---.- +--.-----.---.--- +------.--------- + +----.----------- +.-----.---.---.- +------------.--- + +--.-------.---.- +----.---.---.--- +------.--------- + + +.-------.-.---.- +.-.-.-------.--- +.-----.--.------ + +--.-----------.- +.---.---.---.--- +------.---.----- + +----.-----.----- +.-----------.--- +----.---------.- + +------.---.----- +.---.-------.--- +--.-----------.- + +--------.-.---.- +--.-.-------.--- +.-----.--.------ + +.---.-----.---.- +--.-----.---.--- +------.--------- + +----.----------- +.-----.---.---.- +------------.--- + +--.---.--------- +.---.-----.---.- +--------.---.--- + +.--------------- +.--------------- .--------------- diff --git a/rhythm-game-tutorial.cabal b/rhythm-game-tutorial.cabal --- a/rhythm-game-tutorial.cabal +++ b/rhythm-game-tutorial.cabal @@ -1,52 +1,52 @@ -name: rhythm-game-tutorial -version: 0.1 -synopsis: Haskell rhythm game tutorial -description: -homepage: https://github.com/fumieval/rhythm-game-tutorial -bug-reports: https://github.com/fumieval/rhythm-game-tutorial/issues -license: BSD3 -license-file: LICENSE -author: Fumiaki Kinoshita -maintainer: Fumiaki Kinoshita -copyright: Copyright (C) 2012-2013 Fumiaki Kinoshita -category: Graphics, Monads -build-type: Simple -stability: experimental -cabal-version: >=1.10 - -data-files: - assets/*.wav - assets/*.png - assets/*.txt - -source-repository head - type: git - location: https://github.com/fumieval/rhythm-game-tutorial.git - -executable music-only - ghc-options: -threaded -O2 - main-is: music-only.hs - build-depends: base == 4.*, call >= 0.1.2 && <= 0.2, objective >= 0.6.3.1, lens == 4.*, mtl, containers, split - default-language: Haskell2010 - hs-source-dirs: src - -executable tutorial-passive - ghc-options: -threaded -O2 - main-is: tutorial-passive.hs - build-depends: base == 4.*, call >= 0.1.2 && <= 0.2, objective >= 0.6.3.1, lens == 4.*, mtl, containers, split - default-language: Haskell2010 - hs-source-dirs: src - -executable tutorial-active - ghc-options: -threaded -O2 - main-is: tutorial-active.hs - build-depends: base == 4.*, call >= 0.1.2 && <= 0.2, objective >= 0.6.3.1, lens == 4.*, mtl, containers, split - default-language: Haskell2010 - hs-source-dirs: src - -executable tutorial-extended - ghc-options: -threaded -O2 - main-is: tutorial-extended.hs - build-depends: base == 4.*, call >= 0.1.2 && <= 0.2, objective >= 0.6.3.1, lens == 4.*, mtl, containers, split - default-language: Haskell2010 - hs-source-dirs: src +name: rhythm-game-tutorial +version: 0.1.1 +synopsis: Haskell rhythm game tutorial +description: +homepage: https://github.com/fumieval/rhythm-game-tutorial +bug-reports: https://github.com/fumieval/rhythm-game-tutorial/issues +license: BSD3 +license-file: LICENSE +author: Fumiaki Kinoshita +maintainer: Fumiaki Kinoshita +copyright: Copyright (C) 2012-2013 Fumiaki Kinoshita +category: Graphics, Monads +build-type: Simple +stability: experimental +cabal-version: >=1.10 + +data-files: + assets/*.wav + assets/*.png + assets/*.txt + +source-repository head + type: git + location: https://github.com/fumieval/rhythm-game-tutorial.git + +executable music-only + ghc-options: -threaded -O2 + main-is: music-only.hs + build-depends: base == 4.*, call >= 0.1.4 && <= 0.2, objective >= 1.0.1, lens == 4.*, mtl, containers, split + default-language: Haskell2010 + hs-source-dirs: src + +executable tutorial-passive + ghc-options: -threaded -O2 + main-is: tutorial-passive.hs + build-depends: base == 4.*, call >= 0.1.4 && <= 0.2, objective >= 1.0.1, lens == 4.*, mtl, containers, split + default-language: Haskell2010 + hs-source-dirs: src + +executable tutorial-active + ghc-options: -threaded -O2 + main-is: tutorial-active.hs + build-depends: base == 4.*, call >= 0.1.4 && <= 0.2, objective >= 1.0.1, lens == 4.*, mtl, containers, split + default-language: Haskell2010 + hs-source-dirs: src + +executable tutorial-extended + ghc-options: -threaded -O2 + main-is: tutorial-extended.hs + build-depends: base == 4.*, call >= 0.1.4 && <= 0.2, objective >= 1.0.1, lens == 4.*, mtl, containers, split + default-language: Haskell2010 + hs-source-dirs: src diff --git a/src/music-only.hs b/src/music-only.hs --- a/src/music-only.hs +++ b/src/music-only.hs @@ -1,21 +1,21 @@ -import Call -import Call.Util.Deck as Deck -import Control.Monad.State.Strict -import Control.Lens - -main = runSystemDefault $ do - music <- prepareMusic "assets/Monoidal Purity.wav" - playMusic music - stand - -type Music s = Inst (System s) (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 - -playMusic :: Music s -> System s () -playMusic m = m .- playing .= True +import Call +import Call.Util.Deck as Deck +import Control.Monad.State.Strict +import Control.Lens + +main = runSystemDefault $ do + music <- prepareMusic "assets/Monoidal Purity.wav" + playMusic music + 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 + +playMusic :: Music s -> System s () +playMusic m = m .- playing .= True diff --git a/src/tutorial-active.hs b/src/tutorial-active.hs --- a/src/tutorial-active.hs +++ b/src/tutorial-active.hs @@ -1,97 +1,97 @@ -{-# LANGUAGE Rank2Types, ImpredicativeTypes, ViewPatterns #-} -import Call -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 - -gameMain :: System s () -gameMain = do - 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 !! 0 - score <- new $ variable 0 - - linkPicture $ \_ -> do - l <- renderLane <$> (timings .- get) <*> getPosition music - s <- score .- get - return $ l <> color black (translate (V2 240 40) (text (show s))) - - linkKeyboard $ \ev -> case ev of - Down KeySpace -> do - (sc, ts') <- handle <$> getPosition music <*> (timings .- get) - timings .- put ts' - score .- modify (+sc) - _ -> return () -- Discard the other events - - playMusic music - -main = runSystemDefault (gameMain >> stand) - -type Music s = Inst (System s) (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" - -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 == '.'] - -rate :: Time -> Int -rate dt - | dt < 0.05 = 4 - | dt < 0.1 = 2 - | otherwise = 1 - -handle :: Time -> Set Time -> (Int, Set Time) -handle t ts = case viewNearest t ts of - Nothing -> (0, 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 (t, sb') - _ -> Nothing +{-# 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 + +gameMain :: System s () +gameMain = do + 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 !! 0 + score <- new $ variable 0 + + linkPicture $ \_ -> do + l <- renderLane <$> (timings .- get) <*> getPosition music + s <- score .- get + return $ l <> color black (translate (V2 240 40) (text (show s))) + + linkKeyboard $ \ev -> case ev of + Down KeySpace -> do + (sc, ts') <- handle <$> getPosition music <*> (timings .- get) + timings .- put ts' + score .- modify (+sc) + _ -> 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" + +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 == '.'] + +rate :: Time -> Int +rate dt + | dt < 0.05 = 4 + | dt < 0.1 = 2 + | otherwise = 1 + +handle :: Time -> Set Time -> (Int, Set Time) +handle t ts = case viewNearest t ts of + Nothing -> (0, 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 diff --git a/src/tutorial-extended.hs b/src/tutorial-extended.hs --- a/src/tutorial-extended.hs +++ b/src/tutorial-extended.hs @@ -1,120 +1,123 @@ -{-# LANGUAGE Rank2Types, ImpredicativeTypes, ViewPatterns #-} -import Call -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 - 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 - ps <- effects .- announceMaybe (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))) - <> mconcat ps - - 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 = Inst (System s) (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 == '.'] - -rate :: Time -> (Int, Object (Request Time Picture) Maybe) -rate dt - | dt < 0.05 = (4, pop _perfect_png) - | dt < 0.1 = (2, pop _good_png) - | otherwise = (1, pop _error_png) - -handle :: Time -> Set Time -> ((Int, Object (Request Time Picture) Maybe), 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 (t, sb') - _ -> Nothing - -pop :: Bitmap -> Object (Request Time Picture) Maybe -pop bmp = 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 +{-# 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 diff --git a/src/tutorial-passive.hs b/src/tutorial-passive.hs --- a/src/tutorial-passive.hs +++ b/src/tutorial-passive.hs @@ -1,61 +1,61 @@ -{-# LANGUAGE Rank2Types, ImpredicativeTypes #-} -import Call -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) - -gameMain :: System s () -gameMain = do - music <- prepareMusic "assets/Monoidal Purity.wav" - - allTimings <- liftIO $ (!!0) <$> parseScore (60/160*4) <$> readFile "assets/Monoidal Purity.txt" - - linkPicture $ \_ -> renderLane allTimings <$> getPosition music - - playMusic music - -main = runSystemDefault (gameMain >> stand) - -type Music s = Inst' (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" - -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 == '.'] +{-# LANGUAGE Rank2Types, ImpredicativeTypes #-} +import Call +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) + +gameMain :: System s () +gameMain = do + music <- prepareMusic "assets/Monoidal Purity.wav" + + allTimings <- liftIO $ (!!0) <$> parseScore (60/160*4) <$> readFile "assets/Monoidal Purity.txt" + + linkPicture $ \_ -> renderLane allTimings <$> getPosition music + + 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" + +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 == '.']