packages feed

nyx-game (empty) → 0.1.0.0

raw patch · 64 files changed

+5258/−0 lines, 64 filesdep +asyncdep +basedep +bytestringbinary-added

Dependencies added: async, base, bytestring, containers, deepseq, dlist, lens, mtl, nyx-game, optparse-generic, random, sdl2, sdl2-image, sdl2-mixer, sdl2-ttf, stm, text, vector

Files

+ LICENSE view
@@ -0,0 +1,202 @@+                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "{}"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright 2019 Gil Mizrahi++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.+
+ README.md view
@@ -0,0 +1,26 @@+# [nyx](https://gilmi.me/nyx)++A bullet hell game written in Haskell.++## How to Run++### From Source++You will need [Stack](https://haskellstack.org).++#### Ubuntu:++```sh+sudo apt install libsdl2-dev libsdl2-ttf-dev libsdl2-image-dev libsdl2-mixer-dev+make build+make exec+```++#### OS X++```sh+brew install sdl2 sdl2_ttf sdl2_image sdl2_mixer+make build+make exec+```+
+ app/Attack.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}++module Attack where++import qualified SDL++import Play.Engine+import Control.Lens+import qualified Data.DList as DL++import Bullet+import qualified Play.Engine.Movement as MV+++data Attack+  = Attack+  { _movement :: !MV.Movement+  , _outAngles :: ![Float]+  , _texture :: SDL.Texture+  , _attackTimerInit :: !Int+  , _attackTimer :: !Int+  , _attackUpdate :: IPoint -> IPoint -> Attack -> (DL.DList Bullet, Attack)+  }+++makeFieldsNoPrefix ''Attack++make :: MV.Movement -> [Float] -> Int -> SDL.Texture+  -> (IPoint -> IPoint -> Attack -> (DL.DList Bullet, Attack))+  -> Attack+make mv angles every txt updater =+  Attack+    { _movement = mv+    , _outAngles = angles+    , _texture = txt+    , _attackTimerInit = every+    , _attackTimer = 60+    , _attackUpdate = updater+    }++update :: IPoint -> IPoint -> Attack -> (DL.DList Bullet, Attack)+update posi sz attack =+  let+    bullets'+      | attack ^. attackTimer == 0 = addBullets posi sz attack+      | otherwise = DL.empty++    attack' =+      attack+        & over attackTimer (\t -> if t <= 0 then attack ^. attackTimerInit else t - 1)++  in+    ( bullets'+    , attack'+    )+++addBullets :: IPoint -> IPoint -> Attack -> DL.DList Bullet +addBullets posi sz attack =+  let+    Point w h = Point (sz ^. x) (sz ^. y)+    ds = map ((pi / 180) *) (attack ^. outAngles)+    dirs = map (\d -> Point (cos d) (sin d)) ds+  in DL.fromList $ map+    (\dir ->+       mkBullet+         (attack ^. texture)+         dir+         (attack ^. movement+           & over MV.maxSpeed (fmap abs . mulPoint dir)+           & over MV.minSpeed (fmap abs . mulPoint dir)+           & over MV.speed (mulPoint dir)+         )+         5+         230+        $ (posi `addPoint` Point (w `div` 2) (h `div` 2))+          `addPoint` fmap (floor . (*) (fromIntegral $ w `div` 2)) dir+    ) dirs+
+ app/Attack/SpiralAttack.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}++module Attack.SpiralAttack where++import qualified SDL++import Play.Engine.Types+import Control.Lens+import qualified Data.DList as DL++import Bullet+import Play.Engine+import qualified Attack as A+import qualified Play.Engine.Movement as MV+++make :: Int -> Int -> (Int, Float) -> MV.Movement -> SDL.Texture -> A.Attack+make numOfOutPoints initAngle' (every, change) mv txt =+  A.make+    mv+    (mkAngles initAngle' numOfOutPoints)+    every+    txt+    spiralUpdate++  where+    spiralUpdate :: IPoint -> IPoint -> A.Attack -> (DL.DList Bullet, A.Attack)+    spiralUpdate posi sz attack =+      A.update posi sz attack+        & over (_2 . A.outAngles) (map $ (+) change)+
+ app/Bullet.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE FlexibleInstances  #-}++module Bullet where++import qualified SDL++import Data.Tuple+import Data.Word+import Data.Maybe+import Play.Engine+import Control.Lens+import Control.DeepSeq+import qualified Data.Map as M+import qualified Play.Engine.Movement as MV+++data Bullet+  = Bullet+  { _pos :: {-# UNPACK #-} !IPoint+  , _size :: {-# UNPACK #-} !Size+  , _direction :: {-# UNPACK #-} !FPoint+  , _movement :: {-# UNPACK #-} !MV.Movement+  , _damage :: {-# UNPACK #-} !Int+  , _texture :: SDL.Texture+  , _transparency :: {-# UNPACK #-} !Word8+  }++makeFieldsNoPrefix ''Bullet++instance Eq Bullet where+  b1 == b2 =+    b1 ^. pos == b2 ^. pos+    && b1 ^. size == b2 ^. size+    && b1 ^. damage == b2 ^. damage++instance Ord Bullet where+  b1 <= b2 =+    b1 ^. pos <= b2 ^. pos+    && b1 ^. size <= b2 ^. size+    && b1 ^. damage <= b2 ^. damage++instance NFData Bullet where+  rnf (Bullet {_pos, _size, _direction, _movement, _damage, _transparency}) =+    rnf _pos+    `seq` rnf _size+    `seq` rnf _direction+    `seq` rnf _movement+    `seq` rnf _damage+    `seq` rnf _transparency++mkBullet :: SDL.Texture -> FPoint -> MV.Movement -> Int -> Word8 -> IPoint -> Bullet+mkBullet txt dir mv dmg transp position = Bullet+  { _pos = fmap fromIntegral position `addPoint` Point (-6) (-12)+  , _movement = mv+  , _size = Point 15 15+  , _direction = dir+  , _damage = dmg+  , _texture = txt+  , _transparency = transp+  }++update wsize touchCheck entities b =+  case mapMaybe (touchCheck b) entities of+    []+      | not $ isInWindow wsize (b ^. pos) (b ^. size)+      -> ([], M.empty)+      | otherwise ->+        let+          (mv, addition) = MV.update (b ^. direction) $ b ^. movement+        in+          ([set movement mv $ over pos (`addPoint` addition) $ b], M.empty)+    es ->+      ([], fromListConcat $ map swap es)++fromListConcat :: Ord k => [(k, a)] -> M.Map k [a]+fromListConcat = foldr (uncurry $ M.insertWith (++)) M.empty . map (fmap (:[]))++render :: SDL.Renderer -> Camera -> Bullet -> IO ()+render renderer cam bullet = do+  SDL.textureBlendMode (bullet ^. texture) SDL.$= SDL.BlendAlphaBlend+  SDL.textureAlphaMod  (bullet ^. texture) SDL.$= (bullet ^. transparency)+  SDL.copy renderer (bullet ^. texture) Nothing (Just $ toRect (cam $ bullet ^. pos) (bullet ^. size))
+ app/Credits.hs view
@@ -0,0 +1,116 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module Credits where++import SDL.Vect (V4(..))+import qualified SDL+import qualified SDL.Mixer as Mix+import qualified Play.Engine.MySDL.MySDL as MySDL++import Play.Engine+import Control.Monad.Except+import Control.Lens+import System.Random+import qualified Play.Engine.Load as Load+import qualified Control.Monad.State as SM++import qualified Script+import qualified Play.Engine.Sprite as Spr+++data State+  = State+  { _bg :: Maybe Spr.Sprite+  , _script :: Script.Script+  , _camera :: !Int+  , _exit :: !Bool+  }++makeFieldsNoPrefix ''State++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("bg", MySDL.Texture "VNBG.png")+  , ("unispace", MySDL.Font "unispace/unispace.ttf")+  ]++make :: Int -> Script.ScriptData -> Scene+make t sd = Load.mkState t (wantedAssets ++ Script.assets sd) (mkState $ Script.script sd)++mkState+  :: (MySDL.Resources -> Script.Script)+  -> MySDL.Resources -> Result Scene+mkState scrpt rs = do+  state <- initState (scrpt rs)+  pure $ mkScene+    state+    update+    render++initState :: Script.Script -> Result State+initState scrpt = do+  pure $ State+    { _bg = Nothing+    , _script = scrpt+    , _camera = 0+    , _exit = False+    }++update :: Input -> State -> Result (StackCommand, State)+update input state = do+  _wSize <- _windowSize <$> SM.get++  (acts, script') <- Script.update input Nothing mempty (state ^. script)++  let+    newState =+      state'+        & set script script'+        & over camera+          (\c ->+             if+               | c <= 0 && Script.shake acts -> 60+               | c <= 0 -> 0+               | otherwise -> c - 1+          )+      where+        state' =+          if Script.stopTheWorld acts+            then+              state+            else+              state+                & over (bg . _Just)+                ( case Script.changeSprite acts of+                    Nothing -> Spr.update Nothing False+                    Just sp -> const sp+                )++  if+    | keyReleased KeyQuit input -> do+      pure (None, set exit True state)+    | state ^. exit -> do+      pure (Done, state)+    | otherwise ->+      pure (Script.command acts, newState)++render :: SDL.Renderer -> State -> IO ()+render renderer state = do+  cam' <- Point <$> randomRIO (-1, 1) <*> randomRIO (-1, 1) :: IO FPoint+  let cam = addPoint $ fmap (floor . (*) (fromIntegral $ state ^. camera `div` 3)) cam'+  void $ MySDL.setBGColor (V4 0 0 0 255) renderer+  case state ^. bg of+    Nothing -> pure ()+    Just bgSpr ->+      Spr.render renderer cam (Point 0 0) (bgSpr ^. size) 255 bgSpr++  Script.render renderer cam (state ^. script)++  when (state ^. exit) $+    Mix.haltMusic
+ app/DecObj/Particle.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}++module DecObj.Particle where++import qualified SDL+import SDL.Vect (Point(P))++import Play.Engine+import Control.Lens+import GHC.Generics+import Control.DeepSeq+import qualified Control.Monad.State as SM++import qualified DecorationObject as DecObj+import qualified Play.Engine.Movement as MV++data Particle+  = Particle+  { _pos :: {-# UNPACK #-} !IPoint+  , _size :: {-# UNPACK #-} !Size+  , _movement :: {-# UNPACK #-} !MV.Movement+  , _direction :: {-# UNPACK #-} !FPoint+  , _texture :: SDL.Texture+  , _texturePos :: {-# UNPACK #-} !IPoint+  , _textureSize :: {-# UNPACK #-} !IPoint+  , _deathTime :: {-# UNPACK #-} !Int+  , _timers :: {-# UNPACK #-} !Timers+  }++data Timers+  = Timers+  { _deathAnimationTimer :: {-# UNPACK #-} !Int+  }+  deriving (Eq, Ord, Show, Generic, NFData)+++instance NFData Particle where+  rnf (Particle {..}) =+    rnf _pos+    `seq` rnf _size+    `seq` rnf _movement+    `seq` rnf _direction+    `seq` rnf _texturePos+    `seq` rnf _textureSize+    `seq` rnf _deathTime+    `seq` rnf _timers++makeFieldsNoPrefix ''Particle+makeFieldsNoPrefix ''Timers++data MakeParticle+  = MakeParticle+  { mkPos :: {-# UNPACK #-} !IPoint+  , mkSize :: {-# UNPACK #-} !Size+  , mkDir :: {-# UNPACK #-} !FPoint+  , mkMov :: {-# UNPACK #-} !MV.Movement+  , mkTexture :: !SDL.Texture+  , mkTexturePos :: {-# UNPACK #-} !IPoint+  , mkTextureSize :: {-# UNPACK #-} !IPoint+  , mkDeathTime :: {-# UNPACK #-} !Int+  }++make :: MakeParticle -> Particle+make MakeParticle{..} =+  Particle+    { _pos = mkPos+    , _size = mkSize+    , _direction = mkDir+    , _movement = mkMov+    , _texture = mkTexture+    , _texturePos = mkTexturePos+    , _textureSize = mkTextureSize+    , _deathTime = mkDeathTime+    , _timers = initEnemyTimers mkDeathTime+    }++toDecObj :: Particle -> DecObj.DecorationObject+toDecObj part = DecObj.make+  part+  (\i p -> (,[]) <$> update i p)+  renderFading++initEnemyTimers :: Int -> Timers+initEnemyTimers death = Timers+  { _deathAnimationTimer = death+  }++update :: Input -> Particle -> Result (Maybe Particle)+update _ part = do+  wsize <- _windowSize <$> SM.get+  let+    (mv, move) =+      MV.update (part ^. direction)+        $ (part ^. movement)++    part' =+      part+      & over pos (`addPoint` move)+      & set movement mv+      & set timers (updateTimers part)++  pure+    ( if part' ^. timers . deathAnimationTimer <= 0+        || not (isInWindow wsize (part ^. pos) (part ^. size))+        then Nothing+        else pure part'+    )++updateTimers :: Particle -> Timers+updateTimers part =+  (part ^. timers)+    & over deathAnimationTimer+      (\t ->+        if+          | t >= 0 -> t - 1+          | otherwise -> -1+      )++renderFading :: SDL.Renderer -> Camera -> Particle -> IO ()+renderFading renderer cam part = do+  SDL.textureBlendMode (part ^. texture) SDL.$= SDL.BlendAlphaBlend+  SDL.textureAlphaMod  (part ^. texture) SDL.$=+    ( floor @Float+      $ (255 *)+      $ fromIntegral (part ^. timers . deathAnimationTimer)+      / fromIntegral (max (part ^. deathTime) 1)+    )+  let+    rect = toRect (cam $ part ^. pos) (part ^. size)+    clip = SDL.Rectangle (P $ part ^. texturePos) (part ^. size)+  SDL.copy renderer (part ^. texture) (Just $ fmap fromIntegral clip) (Just rect)+  SDL.textureAlphaMod  (part ^. texture) SDL.$= 255
+ app/DecObj/SplitTexture.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}++module DecObj.SplitTexture where++import qualified SDL++import Play.Engine+import Control.Lens++import qualified DecObj.Particle as Part+import qualified DecorationObject as DecObj+import qualified Play.Engine.Movement as MV+++data MakeSplitTexture+  = MakeSplitTexture+  { mkPos :: {-# UNPACK #-} !IPoint+  , mkSize :: {-# UNPACK #-} !Size+  , mkSplit :: {-# UNPACK #-} !IPoint+  , mkTexture :: !SDL.Texture+  , mkTexturePos :: {-# UNPACK #-} !IPoint+  , mkDeathTime :: {-# UNPACK #-} !Int+  }++make :: MakeSplitTexture -> Result [DecObj.DecorationObject]+make MakeSplitTexture{..} = do+  let+    (w, h) =+      ( mkSize ^. x `div` max 1 (mkSplit ^. x)+      , mkSize ^. y `div` max 1 (mkSplit ^. y)+      )+    dirs =+      map (\((*) (pi / 180) -> d) -> Point (cos d) (sin d))+        . mkAngles 135+        $ mkSplit ^. x * mkSplit ^. y+    zipped =+      zip+        [ (a, b)+        | a <- [0..(mkSplit ^. x - 1)]+        , b <- [0..(mkSplit ^. y - 1)]+        ]+        dirs+  pure $ flip map zipped $ \((x',y'), dir) ->+    Part.toDecObj $ Part.make $ Part.MakeParticle+      { Part.mkPos = mkPos `addPoint` Point (x' * w) (y' * h)+      , Part.mkSize = Point w h+      , Part.mkDir = dir+      , Part.mkMov = MV.fastGradualStart $ Point 0.6 0.6 `mulPoint` dir+      , Part.mkTexture = mkTexture+      , Part.mkTexturePos = mkTexturePos `addPoint` Point (x' * w) (y' * h)+      , Part.mkTextureSize = Point w h+      , Part.mkDeathTime = mkDeathTime+      }
+ app/DecorationObject.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}++module DecorationObject where++import qualified SDL++import Play.Engine+import Control.Lens+import Control.DeepSeq++data DecorationObject+  = forall s. DecObj (DecorationObject' s)++make s u r = DecObj $ DecObj' s u r++data DecorationObject' a+  = DecObj'+  { _state :: !a+  , _update :: Input -> a -> Result (Maybe a, [DecorationObject])+  , _render :: SDL.Renderer -> Camera -> a -> IO ()+  }++instance NFData a => NFData (DecorationObject' a) where+  rnf dec =+    rnf (_state dec)++instance Eq a => Eq (DecorationObject' a) where+  d1 == d2 =+    _state d1 == _state d2++instance Ord a => Ord (DecorationObject' a) where+  d1 <= d2 =+    _state d1 <= _state d2++makeFieldsNoPrefix ''DecorationObject'+
+ app/Enemy.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Enemy where++import qualified SDL++import Data.Maybe+import Play.Engine+import Control.Lens hiding (parts)+import Control.DeepSeq+import qualified Control.Monad.State as SM+import qualified Data.DList as DL++import Bullet+import qualified Attack as A+import qualified DecorationObject as DO+import qualified DecObj.SplitTexture as ST+import qualified Play.Engine.Movement as MV+import qualified Play.Engine.Sprite as Spr++++data Enemy+  = Enemy+  { _pos :: {-# UNPACK #-} !IPoint+  , _size :: {-# UNPACK #-} !Size+  , _sprite :: {-# UNPACK #-} !Spr.Sprite+  , _hitbox :: {-# UNPACK #-} !Hitbox+  , _movement :: {-# UNPACK #-} !MV.Movement+  , _direction :: {-# UNPACK #-} !FPoint+  , _directionChanger :: Size -> Enemy -> FPoint+  , _attack :: {-# UNPACK #-} !A.Attack+  , _attackId :: {-# UNPACK #-} !Int+  , _attackChanger :: Enemy -> Int -> Maybe A.Attack+  , _health :: {-# UNPACK #-} !Int+  , _deathTime :: {-# UNPACK #-} !Int+  , _deathParts :: {-# UNPACK #-} !IPoint+  , _deathTexture :: {-# UNPACK #-} !SDL.Texture+  , _timers :: {-# UNPACK #-} !EnemyTimers+  }++data EnemyTimers+  = EnemyTimers+  { _hitTimer :: {-# UNPACK #-} !Int+  , _gracePeriodTimer :: {-# UNPACK #-} !Int+  }+++instance NFData Enemy where+  rnf (Enemy {_pos, _size, _movement, _health, _timers}) =+    rnf _pos+    `seq` rnf _size+    `seq` rnf _movement+    `seq` rnf _timers+    `seq` rnf _health+    `seq` rnf _attack+    `seq` rnf _deathTime+    `seq` rnf _deathParts++instance NFData EnemyTimers where+  rnf (EnemyTimers {_hitTimer}) =+    rnf _hitTimer+    `seq` rnf _gracePeriodTimer+++makeFieldsNoPrefix ''Enemy+makeFieldsNoPrefix ''EnemyTimers++instance Eq Enemy where+  e1 == e2 =+    e1 ^. pos == e2 ^. pos+    && e1 ^. size == e2 ^. size++instance Ord Enemy where+  e1 <= e2 =+    e1 ^. pos <= e2 ^. pos+    && e1 ^. size <= e2 ^. size+++data MakeEnemy+  = MakeEnemy+  { mkePos :: {-# UNPACK #-} !IPoint+  , mkeSize :: {-# UNPACK #-} !Size+  , mkeSprite :: {-# UNPACK #-} !Spr.Sprite+  , mkeHitbox :: {-# UNPACK #-} !Hitbox+  , mkeMov :: {-# UNPACK #-} !MV.Movement+  , mkeHealth :: {-# UNPACK #-} !Int+  , mkeDirChanger :: Size -> Enemy -> FPoint+  , mkeAtk :: {-# UNPACK #-} !A.Attack+  , mkeAtkChanger :: Enemy -> Int -> Maybe A.Attack+  , mkeDeathTime :: {-# UNPACK #-} !Int+  , mkeDeathParts :: {-# UNPACK #-} !IPoint+  , mkeDeathTexture :: {-# UNPACK #-} !SDL.Texture+  }++mkEnemy :: MakeEnemy -> Enemy+mkEnemy MakeEnemy{..} =+  Enemy+    { _pos = mkePos+    , _size = mkeSize+    , _sprite = mkeSprite+    , _hitbox = mkeHitbox+    , _direction = Point 0 0+    , _movement = mkeMov+    , _directionChanger = mkeDirChanger+    , _attack = mkeAtk+    , _attackId = 0+    , _attackChanger = mkeAtkChanger+    , _health = mkeHealth+    , _deathTime = mkeDeathTime+    , _deathParts = mkeDeathParts+    , _deathTexture = mkeDeathTexture+    , _timers = initEnemyTimers+    }++initEnemyTimers :: EnemyTimers+initEnemyTimers = EnemyTimers+  { _hitTimer = -1+  , _gracePeriodTimer = 60 * 5+  }++update :: Input -> Enemy -> Result ([Enemy], DL.DList Bullet -> DL.DList Bullet, [DO.DecorationObject])+update _ enemy = do+  wsize <- _windowSize <$> SM.get+  let+    dir = (enemy ^. directionChanger) wsize enemy+    (mv, move) =+      MV.update dir+        $ (enemy ^. movement)++    (newBullets, attack') =+      (enemy ^. attack . A.attackUpdate) (enemy ^. pos) (enemy ^. size) (enemy ^. attack)++    changedAttack =+      (enemy ^. attackChanger) enemy (enemy ^. attackId)++    enemy' =+      enemy+      & over pos (if isAlive enemy then (`addPoint` move) else id)+      & over sprite (Spr.update Nothing False)+      & set movement mv+      & over timers updateTimers+      & set direction dir+      & set attack (fromMaybe attack' changedAttack)+      & over attackId (maybe id (const (+1)) changedAttack)++  parts <-+    if isDead enemy'+      then+        ST.make $ ST.MakeSplitTexture+          { mkPos = enemy' ^. pos+          , mkSize = enemy' ^. sprite . size+          , mkSplit = enemy' ^. deathParts+          , mkTexture = enemy' ^. deathTexture+          , mkTexturePos = Point 0 0+          , mkDeathTime = enemy' ^. deathTime+          }+      else pure []++  pure+    ( if isDead enemy'+        || not (isInWindow wsize (enemy ^. pos) (enemy ^. size))+           && (enemy' ^. timers . gracePeriodTimer) < 0+        then []+        else pure enemy'+    , if isDead enemy'+        || not (isInWindow wsize (enemy ^. pos) (Point 0 0))+        then id+        else DL.append newBullets+    , parts+    )++updateTimers :: EnemyTimers -> EnemyTimers+updateTimers et =+  et+    & over hitTimer (\t -> if t <= 0 then -1 else t - 1)+    & over gracePeriodTimer (\t -> if t <= 0 then -1 else t - 1)+++checkHit :: DL.DList Bullet -> Enemy -> Enemy+checkHit bullets enemy+  | any (isJust . flip isTouchingCircleRect enemy) bullets && enemy ^. health > 0+  = enemy+    & over health (flip (-) (DL.head bullets ^. damage))+    & \enemy' ->+      enemy'+        & set+           (timers . hitTimer)+           ( if+               | enemy' ^. health <= 0 ->+                 hitTimeout * 4+               | enemy' ^. timers . hitTimer < 0 ->+                 hitTimeout+               | otherwise ->+                 enemy' ^. timers . hitTimer+           )+  | otherwise+  = enemy++hitTimeout = 20++isDead :: Enemy -> Bool+isDead enemy =+  enemy ^. health <= 0+  && enemy ^. timers . hitTimer < 0++isAlive :: Enemy -> Bool+isAlive enemy =+  enemy ^. health > 0++render :: SDL.Renderer -> Camera -> Enemy -> IO ()+render renderer cam enemy = do+  let+    -- h = fromIntegral $ 255 - max 0 (enemy ^. health * 2)+    isHit = enemy ^. timers . hitTimer > 0 && enemy ^. timers . hitTimer `mod` 8 < 4++  Spr.render renderer cam (enemy ^. pos) (enemy ^. size) (if isHit then 100 else 255) (enemy ^. sprite)++  -- when isHit $ do+  --   let+  --     colour = Vect.V4 255 (255 - h) (255 - h) 150+  --     radius = fromIntegral $ enemy ^. size . x `div` 2+  --     center =+  --       Vect.V2+  --         (fromIntegral (cam (enemy ^. pos) ^. x) + radius)+  --         (fromIntegral (cam (enemy ^. pos) ^. y) + radius)+  --   SDL.circle renderer center radius colour+  --   SDL.fillCircle renderer center radius colour
+ app/Enemy/CrossDown.hs view
@@ -0,0 +1,100 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings  #-}++module Enemy.CrossDown where++import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified Data.Map as M+import Control.Monad.Except+import Control.Lens+import Data.Maybe (fromJust)++import Play.Engine++import Bullet+import Enemy+import qualified Attack as A+import qualified Attack.SpiralAttack as SA+import qualified Play.Engine.Movement as MV+import qualified Play.Engine.Sprite as Spr+++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("bullet", MySDL.Texture "bullet.png")+  , ("crossdown", MySDL.Texture "crossdown.png")+  ]++make :: IPoint -> Either () () -> M.Map String SDL.Texture -> Result Enemy+make posi dir ts = do+  let textName = "bullet"+  case (,) <$> M.lookup textName ts <*> M.lookup "crossdown" ts of+    Nothing ->+      throwError ["Texture not found: crossdown or " ++ textName]+    Just (bt, et) -> do+      let+        sz = Point 48 48+      pure . mkEnemy $+        MakeEnemy+          { mkePos = posi+          , mkeSize = sz+          , mkeMov = crossMovement dir+          , mkeHealth = 70+          , mkeDirChanger = changeDirection+          , mkeAtk = downAttack bt+          , mkeAtkChanger = \_ _ -> Nothing+          , mkeSprite =+            fromJust+              $ Spr.make+              $ Spr.MakeArgs+              { mkActionmap = ["normal"]+              , mkAction = "normal"+              , mkTexture = et+              , mkSize = sz+              , mkMaxPos = 1+              , mkSpeed = 1+              }+          , mkeHitbox = Hitbox+            { _alignment = Point 4 4+            , _size = sz+              & over x (\n -> n - 8)+              & over y (\n -> n - 8)+            }+          , mkeDeathTime = 20+          , mkeDeathParts = Point 3 3+          , mkeDeathTexture = et+          }++crossMovement :: Either () () -> MV.Movement+crossMovement dir = MV.make $ MV.defArgs+  { MV.maxspeed = Point 4.5 2.5+  , MV.accel = Point (mul 0.1) 0.3+  }+  where+    mul = case dir of+      Left () -> (*) (-1)+      Right () -> (*) 1++downAttack :: SDL.Texture -> A.Attack+downAttack = SA.make 1 90 (12, 0) $ MV.straight (Point 0 8)++changeDirection :: Size -> Enemy -> FPoint+changeDirection _ enemy+  | enemy ^. direction . x == 0+  , enemy ^. direction . y == 0+  = Point 0 1++  | enemy ^. pos . y >= 0+  , enemy ^. direction . y == 1+  , enemy ^. direction . x == 0+  = Point 1 1++  | otherwise+  = enemy ^. direction+
+ app/Enemy/Fast.hs view
@@ -0,0 +1,127 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings  #-}++module Enemy.Fast where++import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified Data.Map as M+import Control.Monad.Except+import Control.Lens++import Play.Engine++import Bullet+import Enemy+import qualified Attack as A+import qualified Attack.SpiralAttack as SA+import qualified Play.Engine.Movement as MV+import qualified Play.Engine.Sprite as Spr+import Data.Maybe (fromJust)+++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("bullet", MySDL.Texture "bullet.png")+  , ("astral-sprite", MySDL.Texture "astral-sprite.png")+  , ("astral", MySDL.Texture "astral.png")+  ]++make :: IPoint -> M.Map String SDL.Texture -> Result Enemy+make posi ts = do+  let textName = "bullet"+  case (,,) <$> M.lookup textName ts <*> M.lookup "astral" ts <*> M.lookup "astral-sprite" ts of+    Nothing ->+      throwError ["Texture not found: astral or " ++ textName ++ " in " ++ show (M.keys ts)]+    Just (bt, et, spr) -> do+      let+        sz = Point 100 100+      pure . mkEnemy $+        MakeEnemy+          { mkePos = posi+          , mkeSize = sz+          , mkeMov = crossMovement (Right ())+          , mkeHealth = 300+          , mkeDirChanger = changeDirection+          , mkeAtk = attackPattern1 bt+          , mkeAtkChanger = \enemy atkId ->+              if+                | enemy ^. health < 200 && atkId < 1 -> pure $ attackPattern2 bt+                | enemy ^. health < 100 && atkId < 2 -> pure $ attackPattern3 bt+                | otherwise -> Nothing++          , mkeSprite =+            fromJust+              $ Spr.make+              $ Spr.MakeArgs+              { mkActionmap = ["normal"]+              , mkAction = "normal"+              , mkTexture = spr+              , mkSize = sz+              , mkMaxPos = 4+              , mkSpeed = 5+              }+          , mkeHitbox = Hitbox+            { _alignment = Point 30 6+            , _size = sz+              & over x (\n -> n - 60)+              & over y (\n -> n - 12)+            }+          , mkeDeathTime = 150+          , mkeDeathParts = Point 4 3+          , mkeDeathTexture = et+          }++crossMovement :: Either () () -> MV.Movement+crossMovement dir = MV.make $ MV.defArgs+  { MV.maxspeed = Point 1.8 1+  , MV.accel = Point (mul 0.4) 0.2+  }+  where+    mul = case dir of+      Left () -> (*) (-1)+      Right () -> (*) 1++attackPattern1 :: SDL.Texture -> A.Attack+attackPattern1 = SA.make 5 0 (1, 9) $ MV.fastGradualStart (Point 3.2 3.2)++attackPattern2 :: SDL.Texture -> A.Attack+attackPattern2 = SA.make 3 0 (1, 7) $ MV.fastGradualStart (Point 3.2 3.2)++attackPattern3 :: SDL.Texture -> A.Attack+attackPattern3 = SA.make 5 0 (3, 7) $ MV.gradualSlowdown (Point 12 14)+++changeDirection :: Size -> Enemy -> FPoint+changeDirection wsize enemy+  | enemy ^. direction . x == 0+  , enemy ^. direction . y == 0+  = Point 0 1++  | enemy ^. pos . y >= 0+  , enemy ^. direction . y == 1+  , enemy ^. direction . x == 0+  = Point 1 1++  | enemy ^. pos . y <= 0+  = enemy ^. direction++  | otherwise+  = enemy ^. direction+    & set x+      (if+         | enemy ^. pos . x > (wsize ^. x * 2) `div` 3 -> -1+         | enemy ^. pos . x <= wsize ^. x `div` 3 -> 1+         | otherwise -> enemy ^. direction . x+      )+    & set y+      (if+         | enemy ^. pos . y > 250 -> -1+         | enemy ^. pos . y <= 50 -> 1+         | otherwise -> enemy ^. direction . y+      )
+ app/Enemy/SideToSideSpiral.hs view
@@ -0,0 +1,107 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings  #-}++module Enemy.SideToSideSpiral where++import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified Data.Map as M+import Control.Monad.Except+import Control.Lens++import Play.Engine++import Bullet+import Enemy+import qualified Attack as A+import qualified Attack.SpiralAttack as SA+import qualified Play.Engine.Movement as MV+import qualified Play.Engine.Sprite as Spr+import Data.Maybe (fromJust)+++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("static", MySDL.Texture "static.png")+  , ("crossdown", MySDL.Texture "crossdown.png")+  ]++make :: IPoint -> M.Map String SDL.Texture -> Result Enemy+make posi ts = do+  case (,) <$> M.lookup "static" ts <*> M.lookup "crossdown" ts of+    Nothing ->+      throwError ["Texture not found: static or crossdown" ]+    Just (et, bt) -> do+      let+        sz = Point 48 48+      pure . mkEnemy $+        MakeEnemy+          { mkePos = posi+          , mkeSize = sz+          , mkeMov = leftRightMovement+          , mkeHealth = 100+          , mkeDirChanger = changeDirection+          , mkeAtk = singleSpiralAttack bt+          , mkeAtkChanger = \_ _ -> Nothing+          , mkeDeathTime = 0+          , mkeDeathParts = Point 3 3+          , mkeDeathTexture = et+          , mkeSprite =+            fromJust+              $ Spr.make+              $ Spr.MakeArgs+              { mkActionmap = ["normal"]+              , mkAction = "normal"+              , mkTexture = et+              , mkSize = sz+              , mkMaxPos = 1+              , mkSpeed = 1+              }+          , mkeHitbox = Hitbox+            { _alignment = Point 4 4+            , _size = sz+              & over x (\n -> n - 8)+              & over y (\n -> n - 8)+            }+          }++leftRightMovement :: MV.Movement+leftRightMovement = MV.make $ MV.MakeArgs+  { MV.startspeed = Point 0 0+  , MV.minspeed = Point 0 0+  , MV.maxspeed = Point 1.5 1.5+  , MV.accel = Point 0.1 0.1+  }++singleSpiralAttack :: SDL.Texture -> A.Attack+singleSpiralAttack = SA.make 6 0 (2, 1.2) $ MV.gradualSlowdown (Point 8 8)++changeDirection :: Size -> Enemy -> FPoint+changeDirection wsize enemy+  | enemy ^. direction . x == 0+  , enemy ^. direction . y == 0+  = Point 0 1++  | enemy ^. pos . y >= 100+  , enemy ^. direction . y == 1+  = Point 1 0++  | enemy ^. pos . x > 2 * (wsize ^. x `div` 3) - enemy ^. sprite . size . x+  , enemy ^. direction . y == 0+  = Point (-1) 0++  | enemy ^. pos . x <= (wsize ^. x `div` 3)+  , enemy ^. direction . y == 0+  = Point 1 0++  | enemy ^. health <= 0+  = Point 0 0++  | otherwise+  = enemy ^. direction+
+ app/Enemy/Static.hs view
@@ -0,0 +1,96 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings  #-}++module Enemy.Static where++import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified Data.Map as M+import Control.Monad.Except+import Control.Lens++import Play.Engine++import Bullet+import Enemy+import qualified Attack as A+import qualified Attack.SpiralAttack as SA+import qualified Play.Engine.Movement as MV+import qualified Play.Engine.Sprite as Spr+import Data.Maybe (fromJust)+++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("bullet", MySDL.Texture "bullet.png")+  , ("static", MySDL.Texture "static.png")+  ]++make :: IPoint -> FPoint -> Int -> M.Map String SDL.Texture -> Result Enemy+make posi dir targetY ts = do+  let textName = "bullet"+  case (,) <$> M.lookup textName ts <*> M.lookup "static" ts of+    Nothing ->+      throwError ["Texture not found: static or " ++ textName ++ " in:\n" ++ show (M.keys ts)]+    Just (bt, et) -> do+      let+        sz = Point 48 48+      pure . mkEnemy $+        MakeEnemy+          { mkePos = posi+          , mkeSize = sz+          , mkeMov = staticMovement dir+          , mkeHealth = 5+          , mkeDirChanger = changeDirection targetY+          , mkeAtk = sprayAttack bt+          , mkeAtkChanger = \_ _ -> Nothing+          , mkeDeathTime = 30+          , mkeDeathParts = Point 3 3+          , mkeDeathTexture = et+          , mkeSprite =+            fromJust+              $ Spr.make+              $ Spr.MakeArgs+              { mkActionmap = ["normal"]+              , mkAction = "normal"+              , mkTexture = et+              , mkSize = sz+              , mkMaxPos = 1+              , mkSpeed = 1+              }+          , mkeHitbox = Hitbox+            { _alignment = Point 4 4+            , _size = sz+              & over x (\n -> n - 8)+              & over y (\n -> n - 8)+            }+          }++staticMovement :: FPoint -> MV.Movement+staticMovement dir = MV.make $ MV.defArgs+  { MV.maxspeed = Point 3 3+  , MV.accel = Point (dir ^. x * 0.1) (dir ^.y * 0.1)+  }++sprayAttack :: SDL.Texture -> A.Attack+sprayAttack = SA.make 5 0 (45, 15) $ MV.straight (Point 3.5 3.5)++changeDirection :: Int -> Size -> Enemy -> FPoint+changeDirection targetY _ enemy+  | enemy ^. direction . x == 0+  , enemy ^. direction . y == 0+  , enemy ^. pos . y < targetY+  = Point 1 1++  | enemy ^. pos . y >= targetY+  , enemy ^. direction . y == 1+  = Point 0 0++  | otherwise+  = enemy ^. direction+
+ app/GameState.hs view
@@ -0,0 +1,261 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}++module GameState where++import qualified SDL+import qualified SDL.Font as SDLF+import qualified SDL.Mixer as Mix+import qualified Play.Engine.MySDL.MySDL as MySDL++import Play.Engine+import Control.Monad+import Control.Monad.Except+import Control.Lens+import Data.Maybe+import Data.Foldable+import System.Random+import qualified Play.Engine.Load as Load++import qualified Control.Monad.State as SM+import qualified Data.DList as DL+import qualified Data.Map as M++import qualified Script+import Bullet hiding (update, render)+import qualified Bullet+import qualified ShootingBox as SB+import qualified Enemy as Enemy+import qualified DecorationObject as DO+import qualified Play.Engine.ScrollingBackground as SBG+import qualified Play.Engine.Sprite as Spr+++data State+  = State+  { _bg :: SBG.SBG+  , _bga :: Spr.Sprite+  , _mc :: SB.MainChar+  , _enemies :: [Enemy.Enemy]+  , _mcBullets :: DL.DList Bullet+  , _enemyBullets :: DL.DList Bullet+  , _decObjs :: DL.DList DO.DecorationObject+  , _resources :: MySDL.Resources+  , _script :: Script.Script+  , _camera :: Int+  , _restart :: Scene+  , _isPause :: !Bool+  , _pauseChanged :: !Bool+  , _isMute :: !Bool+  , _hudFont :: SDLF.Font+  , _exit :: !Bool+  }++makeFieldsNoPrefix ''State++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("bg", MySDL.Texture "background.png")+  , ("unispace", MySDL.Font "unispace/unispace.ttf")+  --, ("bga", MySDL.Texture "bga.png")+  ]+  ++ SB.wantedAssets++mkGameState :: Script.ScriptData -> Scene+mkGameState sd = Load.mkState 30 (wantedAssets ++ Script.assets sd) (mkState sd)++mkState+  :: Script.ScriptData+  -> MySDL.Resources -> Result Scene+mkState sd rs = do+  state <- initState sd (Script.script sd rs) rs+  pure $ mkScene+    state+    update+    render++initState :: Script.ScriptData -> Script.Script -> MySDL.Resources -> Result State+initState sd scrpt rs = do+  case (,) <$> M.lookup "bg" (MySDL.textures rs) <*> M.lookup "unispace" (MySDL.fonts rs) of+    Nothing ->+      throwError ["Texture or font not found: bg / unispace"]+    Just (bgt, font) -> do+      mc' <- (SB.mkMainChar $ MySDL.textures rs)+      pure $ State+        (SBG.mkSBG bgt 1 (Point 800 1000) (Point 0 0))+        ( maybe undefined id $ Spr.make $ Spr.MakeArgs+          { mkActionmap = ["normal"]+          , mkAction = "normal"+          , mkTexture = bgt+          , mkSize = Point 800 1000+          , mkMaxPos = 4+          , mkSpeed = 2+          }+        )+        mc'+        []+        (DL.fromList [])+        (DL.fromList [])+        (DL.fromList [])+        rs+        scrpt+        0+        (Script.restart sd)+        False+        False+        False+        font+        False++initEnemyTimer :: Int+initEnemyTimer = 60++update :: Input -> State -> Result (StackCommand, State)+update input state = do+  wSize <- _windowSize <$> SM.get+  ismute <- _muteMusic <$> SM.get++  (acts, script') <- Script.update input (SB.get (state ^. mc) pos) (state ^. enemies) (state ^. script)++  (mc', addMCBullets) <-+    SB.update+      (maybe input (dirToInput . dirToPlace (state ^. mc . pos)) (Script.moveMC acts))+      (state ^. mc)++  (enemies', addEnemiesBullets, newDecObjs) <-+    (\(a, b, c) ->+       ( mconcat a+       , foldr (.) id b+       , foldr (\curr acc -> DL.fromList curr `DL.append` acc) DL.empty c+       )+    ) . unzip3+      <$> traverse (Enemy.update input) (state ^. enemies)+  let+    (mcBullets', _enemiesHit) =+      updateListWith+        M.empty+        (const $ const M.empty)+        (Bullet.update wSize isTouchingCircleRect (state ^. enemies))+        (state ^. mcBullets)++    (enemyBullets', (concat . map snd . M.toList) -> mcHits) =+      updateListWith+        M.empty+        M.union+        (Bullet.update wSize isTouchingCircleRect $ maybe [] (:[]) $ SB.get (state ^. mc) id)+        (state ^. enemyBullets)++  updatedDecObjs <- updateDecObjs input (state ^. decObjs)++  let+    newState =+      state'+        & set pauseChanged False+        & set isMute ismute+        & set script script'+        & over bg SBG.updateSBG+        & over camera+          (\c ->+             if+               | c <= 0 && Script.shake acts -> 60+               | c <= 0 -> 0+               | otherwise -> c - 1+          )+        & over bga+          ( case Script.changeSprite acts of+              Nothing -> Spr.update Nothing False+              Just sp -> const sp+          )+      where+        state' =+          if Script.stopTheWorld acts+            then+              state+                & set mcBullets mcBullets'+                & set enemyBullets enemyBullets'+            else+              state+                & set mc (SB.checkHit mcHits mc')+                & set enemies enemies'+                & over enemies ((++) (Script.spawn acts) . map (Enemy.checkHit mcBullets'))+                & set mcBullets (addMCBullets mcBullets')+                & set enemyBullets (addEnemiesBullets enemyBullets')+                & set decObjs (updatedDecObjs `DL.append` newDecObjs)+  if+    | keyReleased KeyC input -> do+      pure (Replace $ state ^. restart, state)+    | keyReleased KeyP input && state ^. isPause -> do+      pure (None, set pauseChanged True $ set isPause False state)+    | keyReleased KeyP input && not (state ^. isPause) -> do+      pure (None, set pauseChanged True $ set isPause True state)+    | state ^. isPause -> do+      pure (None, state)+    | keyReleased KeyQuit input -> do+      pure (None, set exit True state)+    | state ^. exit -> do+      pure (Done, state)+    | otherwise ->+      pure (Script.command acts, newState)+++updateDecObjs :: Input -> DL.DList DO.DecorationObject -> Result (DL.DList DO.DecorationObject)+updateDecObjs input =+  foldrM+    ( \(DO.DecObj obj@(DO.DecObj'{..})) acc -> do+      (r, objs) <- _update input _state+      pure $ DL.append+        (DL.fromList $ maybeToList (fmap (DO.DecObj . flip (set DO.state) obj) r) ++ objs)+        acc+    )+    DL.empty+++flipEnemyDir :: Either () () -> Either () ()+flipEnemyDir = \case+  Right () -> Left ()+  Left () -> Right ()++render :: SDL.Renderer -> State -> IO ()+render renderer state = do++  cam' <- Point <$> randomRIO (-1, 1) <*> randomRIO (-1, 1) :: IO FPoint+  let cam = addPoint $ fmap (floor . (*) (fromIntegral $ state ^. camera `div` 3)) cam'+  SBG.render renderer cam (state ^. bg)+  --Spr.render renderer cam (Point 0 0) (state ^. bga . size) (state ^. bga)+  SB.render renderer cam (state ^. mc)+  void $ traverse (Enemy.render renderer cam) (state ^. enemies)+  forM_ (state ^. decObjs) (\(DO.DecObj (DO.DecObj'{..})) -> _render renderer cam _state)+  forM_ (state ^. mcBullets) (Bullet.render renderer cam)+  forM_ (state ^. enemyBullets) (Bullet.render renderer cam)++  when (state ^. isMute) $+    renderText renderer (state ^. hudFont) (Point 40 30) "MUTED"++  Script.render renderer cam (state ^. script)++  when (state ^. isPause)+    $ renderText renderer (state ^. hudFont) (Point 370 380) "PAUSE"++  when (state ^. pauseChanged) $+    if (state ^. isPause)+      then+        Mix.pauseMusic+      else+        Mix.resumeMusic++  when (state ^. exit) $+    Mix.haltMusic++dirToInput :: IPoint -> Input+dirToInput dir =+  Input ks []+  where+    ks = M.fromList $ map (,Click)+      $  (if dir ^. x > 0 then [KeyRight] else if dir ^. x < 0 then [KeyLeft] else [])+      ++ (if dir ^. y > 0 then [KeyUp]    else if dir ^. y < 0 then [KeyDown] else [])+
+ app/KeyScreen.hs view
@@ -0,0 +1,118 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module KeyScreen where++import Data.Maybe (fromJust)+import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL++import Play.Engine hiding (head)+import Control.Monad.Except+import Control.Lens+import Data.Bifunctor+import Data.Bool+import qualified Data.Map as M+import qualified Play.Engine.Sprite as Spr+import qualified Play.Engine.ListZipper as Z+import qualified Play.Engine.Load as Load+import qualified Control.Monad.State as SM++import qualified Play.Engine.Button as Btn+++data State+  = State+  { _bg :: Spr.Sprite+  , _buttons :: Z.ListZipper (Btn.Button, Result StackCommand)+  }++makeFieldsNoPrefix ''State++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("keys", MySDL.Texture "keys.png")+  , ("unispace", MySDL.Font "unispace/unispace.ttf")+  ]++make :: Scene+make = Load.mkState 0 wantedAssets mkState++mkState :: MySDL.Resources -> Result Scene+mkState rs = do+  state <- initState rs+  pure $ mkScene+    state+    update+    render++initState :: MySDL.Resources -> Result State+initState rs = do+  case (,)+    <$> M.lookup "keys" (MySDL.textures rs)+    <*> M.lookup "unispace" (MySDL.fonts rs) of+    Nothing ->+      throwError ["Texture not found: keys or unispace"]+    Just (bgt, fnt) -> do+      let+        makeBtn' n =+          Btn.make (Point 320 (720 + n * 60)) (Point 180 50) fnt++        btns = zipWith (flip ($)) [0..] $+          [ \n -> (makeBtn' n "Back", pure Done)+          ]++      pure $ State+        { _bg =+          fromJust+            $ Spr.make+            $ Spr.MakeArgs+            { mkActionmap = ["normal"]+            , mkAction = "normal"+            , mkTexture = bgt+            , mkSize = Point 800 1000+            , mkMaxPos = 1+            , mkSpeed = 1+            }+        , _buttons = Z.ListZipper+          []+          (head btns)+          (tail btns)+        }++update :: Input -> State -> Result (StackCommand, State)+update input state = do+  _wSize <- _windowSize <$> SM.get+  btns <- Z.diffMapM (firstM $ Btn.update empty) (firstM $ Btn.update input)+    $ if+       | keyClicked KeyDown input ->+         Z.nextCycle (state ^. buttons)++       | keyClicked KeyUp input ->+         Z.prevCycle (state ^. buttons)++        | otherwise ->+          state ^. buttons++  let ((check, _), cmd') = Z.get btns+  cmd <- bool (pure None) cmd' (check || keyClicked KeyQuit input)+  pure+    ( cmd+    , state+      & set buttons (fmap (first snd) btns)+      & over bg (Spr.update Nothing False)+    )++render :: SDL.Renderer -> State -> IO ()+render renderer state = do+  Spr.render renderer id (Point 0 0) (state ^. bg . size) 255 (state ^. bg)+  shade renderer id 30+  void $ Z.diffMapM+    (Btn.render renderer False)+    (Btn.render renderer True)+    (fmap fst $ state ^. buttons)
+ app/Main.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}  -- One more extension.+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}  -- To derive Show+{-# LANGUAGE TypeOperators      #-}++module Main where++import Options.Generic++import Play.Engine.Runner++import Play.Engine+import qualified StartScreen as S++main :: IO ()+main = do+  config <- unwrapRecord "Nyx Game"+  let+    h | unHelpful $ small config = 850+      | otherwise = 1000++  runGame (settings h) (S.make `Stack` [])++settings :: Int -> Settings+settings h = def+  { _windowSize = Point 800 h+  }++data Config w = Config+  { small :: Bool <?> "Start game on smaller resolution"+  }+  deriving (Generic)++instance ParseRecord (Config Wrapped)+deriving instance Show (Config Unwrapped)
+ app/PickStage.hs view
@@ -0,0 +1,133 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PickStage where++import Data.Maybe (fromJust)+import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL++import Play.Engine hiding (head)+import Control.Monad.Except+import Control.Lens+import Data.Bifunctor+import Data.Bool+import qualified Data.Map as M+import qualified Play.Engine.Sprite as Spr+import qualified Play.Engine.ListZipper as Z+import qualified Play.Engine.Load as Load+import qualified Control.Monad.State as SM++import qualified Script.Introduction as Intro+import qualified Script.Level1 as Level1+import qualified Script.Level2 as Level2+import qualified Script.Boss as Boss+import qualified Script.End as End+import qualified Play.Engine.Button as Btn+++data State+  = State+  { _bg :: Spr.Sprite+  , _buttons :: Z.ListZipper (Btn.Button, Result StackCommand)+  }++makeFieldsNoPrefix ''State++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("vnbg", MySDL.Texture "VNBG.png")+  , ("unispace", MySDL.Font "unispace/unispace.ttf")+  ]++make :: Scene+make = Load.mkState 0 wantedAssets mkState++mkState :: MySDL.Resources -> Result Scene+mkState rs = do+  state <- initState rs+  pure $ mkScene+    state+    update+    render++initState :: MySDL.Resources -> Result State+initState rs = do+  case (,)+    <$> M.lookup "vnbg" (MySDL.textures rs)+    <*> M.lookup "unispace" (MySDL.fonts rs) of+    Nothing ->+      throwError ["Texture not found: vnbg or unispace"]+    Just (bgt, fnt) -> do+      let+        makeBtn' n =+          Btn.make (Point 320 (600 + n * 60)) (Point 180 50) fnt++        makeBtn name state n =+          (makeBtn' n name, pure $ Replace state)+            ++        btns = zipWith (flip ($)) [0..] $+          [ makeBtn "Intro" Intro.intro+          , makeBtn "Level1" $ Level1.level1 True+          , makeBtn "Level2" $ Level2.level2 True+          , makeBtn "Boss" $ Boss.boss True 0+          , makeBtn "Credits" $ End.end True++          , \n -> (makeBtn' n "Back", pure $ Done)+          ]++      pure $ State+        { _bg =+          fromJust+            $ Spr.make+            $ Spr.MakeArgs+            { mkActionmap = ["normal"]+            , mkAction = "normal"+            , mkTexture = bgt+            , mkSize = Point 800 1000+            , mkMaxPos = 8+            , mkSpeed = 8+            }+        , _buttons = Z.ListZipper+          []+          (head btns)+          (tail btns)+        }++update :: Input -> State -> Result (StackCommand, State)+update input state = do+  _wSize <- _windowSize <$> SM.get+  btns <- Z.diffMapM (firstM $ Btn.update empty) (firstM $ Btn.update input)+    $ if+       | keyClicked KeyDown input ->+         Z.nextCycle (state ^. buttons)++       | keyClicked KeyUp input ->+         Z.prevCycle (state ^. buttons)++        | otherwise ->+          state ^. buttons++  let ((check, _), cmd') = Z.get btns+  cmd <- bool (pure None) cmd' (check || keyClicked KeyQuit input)+  pure+    ( cmd+    , state+      & set buttons (fmap (first snd) btns)+      & over bg (Spr.update Nothing False)+    )++render :: SDL.Renderer -> State -> IO ()+render renderer state = do+  Spr.render renderer id (Point 0 0) (state ^. bg . size) 255 (state ^. bg)+  shade renderer id 120+  void $ Z.diffMapM+    (Btn.render renderer False)+    (Btn.render renderer True)+    (fmap fst $ state ^. buttons)
+ app/Script.hs view
@@ -0,0 +1,181 @@+module Script where++import Data.Word (Word8)+import Data.Maybe+import qualified SDL+import qualified SDL.Font as SDLF+import qualified SDL.Mixer as Mix+import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified Data.ByteString as BS+import qualified Data.Text as T++import Enemy+import qualified TextBox as TB+import Control.Lens+import Control.Monad.Except+import Play.Engine+import qualified Play.Engine.Input as I+import qualified Play.Engine.Sprite as Spr+++data Command+  = Wait !Actions Int+  | WaitUntil !Actions (Maybe IPoint -> [Enemy] -> Bool)+  | Spawn (Result [Enemy])+  | LoadTextBox !Actions (Result TB.TextBox)+  | WaitTextBox !Actions TB.TextBox+  | PlayMusic Mix.Times (String, Maybe BS.ByteString)+  | PlayMusic' Mix.Times BS.ByteString+  | StopMusic+  | Shake+  | FadeOut !Actions Word8+  | FadeIn !Actions Word8+  | TextUp Word8 SDLF.Font IPoint T.Text++data ScriptData+  = Script+  { assets :: [(String, MySDL.ResourceType FilePath)]+  , script :: MySDL.Resources -> Script+  , restart :: Scene+  }++type Script = [Command]++data Actions+  = Actions+  { moveMC :: Maybe IPoint+  , spawn :: [Enemy]+  , stopTheWorld :: Bool+  , shake :: Bool+  , playMusic :: MusicAction+  , command :: StackCommand+  , changeSprite :: Maybe Spr.Sprite+  }++data MusicAction+  = MAPlay (String, FilePath)+  | MAContinue+  | MAStop++noAction :: Actions+noAction = Actions+  { moveMC = Nothing+  , spawn = []+  , stopTheWorld = False+  , playMusic = MAContinue+  , shake = False+  , command = None+  , changeSprite = Nothing+  }++act :: Actions+act = noAction++update :: I.Input -> Maybe IPoint -> [Enemy] -> Script -> Result (Actions, Script)+update input mcPos enemies = \case+  [] -> pure (noAction, [])+  Wait acts i : rest+    | i <= 0 -> pure (acts, rest)+    | otherwise -> pure (acts, Wait acts (i-1) : rest)++  WaitUntil acts test : rest+    | test mcPos enemies -> pure (acts, rest)+    | otherwise -> pure (acts, WaitUntil acts test : rest)++  Spawn spawned : rest ->+    (, rest) . (\s -> noAction { spawn = s }) <$> spawned++  LoadTextBox acts rtb : rest -> do+    tb <- rtb+    pure (acts, WaitTextBox (acts { changeSprite = Nothing }) tb : rest)++  WaitTextBox acts tb : rest -> do+    TB.update input tb >>= \case+      Nothing -> pure  (acts, rest)+      Just tb' -> pure (acts, WaitTextBox acts tb' : rest)++  PlayMusic times (name, m) : rest -> do+    case m of+      Nothing ->+        throwError ["Audio asset not loaded: " ++ name]+      Just msc ->+        pure (noAction, PlayMusic' times msc : rest)++  PlayMusic' _ _ : rest ->+    pure (noAction, rest) -- `render` takes care of playing the music++  StopMusic : rest ->+    pure (noAction, rest) -- `render` takes care of playing the music++  Shake : rest ->+    pure (noAction { shake = True }, rest)++  FadeOut actions n : rest ->+    let+      jump = 2+    in case n of+      255 ->+        pure (actions, rest)+      _ | n > 255 - jump ->+        pure (noAction, FadeOut actions 255 : rest)+      _ ->+        pure (noAction, FadeOut actions (n + jump) : rest)++  FadeIn actions n : rest ->+    let+      jump = 2+    in case n of+      0 -> pure (actions, rest)+      _ | n < jump ->+        pure (noAction, FadeIn actions 0 : rest)+      _ ->+        pure (noAction, FadeIn actions (n - jump) : rest)++  TextUp spd font location txt : rest ->+    case location ^. y of+      n | n < -50 ->+        pure (noAction, rest)+      n ->+        pure (noAction, TextUp spd font (set y (n - fromIntegral spd) location) txt : rest)+++++goToLoc :: IPoint -> Command+goToLoc p =+  WaitUntil+    (act { moveMC = Just p })+    (\mcPos _ -> case mcPos of+        Nothing -> False+        Just posi -> isAround p posi (Point 20 20)+    )++render :: SDL.Renderer -> Camera -> Script -> IO ()+render renderer cam =+  maybe (pure ()) f . listToMaybe+  where+    f = \case+      WaitTextBox _ tb ->+        TB.render renderer tb++      PlayMusic' times m ->+        Mix.playMusic times =<< Mix.decode m++      StopMusic ->+        void $ Mix.fadeOutMusic (1000 * 2) -- milliseconds++      FadeOut _ n -> shade renderer cam n+      FadeIn  _ n -> shade renderer cam n++      TextUp _ font location txt ->+        renderText renderer font location txt++      _ -> pure ()++getNewText :: [MySDL.Response] -> Maybe MySDL.Response+getNewText = \case+  [] -> Nothing+  MySDL.NewText txt : _ ->+    pure $ MySDL.NewText txt+  MySDL.Exception e : _ -> pure $ MySDL.Exception e+  _ : r -> getNewText r
+ app/Script/Boss.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings #-}++module Script.Boss where++import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified SDL.Mixer as Mix++import Script+import Play.Engine+import qualified Enemy.Fast as Fast+import qualified GameState as GS+import qualified TextBox as TB+import qualified Data.Map as M+import qualified Script.End as End+++boss :: Bool -> Int -> Scene+boss playMusic tryNum =+  GS.mkGameState $ Script+    wantedAssets+    (lScript playMusic tryNum)+    (boss False $ tryNum + 1)+++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  Fast.wantedAssets+  ++ TB.wantedAssets+  ++ [ ("astral-avatar", MySDL.Texture "astral-avatar.png")+     , ("battle", MySDL.Music "battle.ogg")+     , ("nyx-avatar", MySDL.Texture "nyx-avatar.png")+     ]+++lScript :: Bool -> Int -> MySDL.Resources -> Script+lScript playMusic tryNum MySDL.Resources{ MySDL.textures = ts, MySDL.fonts = fs, MySDL.music = ms } =+  +  [ goToLoc $ Point 380 800+  ] +++  ( if+      | tryNum <= 0 ->+        [ LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Bottom 7+          "Phew..."+          (M.lookup "nyx-avatar" ts) (M.lookup "unispace" fs)+        , Wait act { stopTheWorld = True } 120+        , LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 3+          "Not bad Nyx!"+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        , LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 3+          "But did you really think it'll be that easy?"+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        , LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Bottom 5+          "Who are you...?\nHow do you know my name?"+          (M.lookup "nyx-avatar" ts) (M.lookup "unispace" fs)+        , LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 3+          "I think you have bigger things to worry about right now!"+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        , LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 4+          "Here I come!"+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        , LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Bottom 2+          "!!!"+          (M.lookup "nyx-avatar" ts) (M.lookup "unispace" fs)+        ]+      | tryNum < 4 ->+        [ LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 4+          "Did you really think you can beat me?"+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        ]+      | tryNum < 7 ->+        [ LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 4+          "Didn't you have enough yet?"+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        ]+      | tryNum < 10 ->+        [ LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 5+          "That persistence... Admirable..."+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        ]+      | tryNum < 15 ->+        [ LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 4+          "Or maybe you just don't know when to give up..."+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        ]+      | tryNum < 25 ->+        [ LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 6+          "You are never going to beat me."+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        ]+      | otherwise ->+        [ LoadTextBox act{ stopTheWorld = True } $+          TB.make TB.Top 9+          "..."+          (M.lookup "astral-avatar" ts) (M.lookup "unispace" fs)+        ]+  ) +++  [ PlayMusic Mix.Forever ("battle", M.lookup "battle" ms)+  | playMusic+  ] +++  -- Boss+  [ Spawn $ sequence [Fast.make (Point 350 (-100)) ts]+  , WaitUntil noAction (const $ null)++  , StopMusic+  , Wait act{ stopTheWorld = False } 2+  , Wait act{ stopTheWorld = True } 150++  -- End+  , LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Top 6+    "It's not over Nyx!"+    Nothing (M.lookup "unispace" fs)++  , LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Top 7+    "This is just the beginning!!"+    Nothing (M.lookup "unispace" fs)++  , LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Top 10+    "J u S t . Y o U . W a I t . . ."+    Nothing (M.lookup "unispace" fs)++  , Wait act{ stopTheWorld = True } 60++  , Shake++  , Wait act{ stopTheWorld = False } 150++  , Wait act{ stopTheWorld = True } 150++  , LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Bottom 4+    "What was that thing..?"+    (M.lookup "nyx-avatar" ts) (M.lookup "unispace" fs)++  , LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Bottom 4+    "Why did she know my name..?"+    (M.lookup "nyx-avatar" ts) (M.lookup "unispace" fs)++  , Wait act{ stopTheWorld = True } 60++  , LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Bottom 4+    "I did not know that at the time,"+    Nothing (M.lookup "unispace" fs)++  , LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Bottom 4+    "But my fight was far from over..."+    Nothing (M.lookup "unispace" fs)++  , FadeOut act{ command = Replace $ End.end True } 0++  ]+
+ app/Script/End.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module Script.End where++import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified SDL.Mixer as Mix++import Data.Maybe (fromJust)+import Script+import Play.Engine+import qualified Credits+import qualified TextBox as TB+import qualified Data.Map as M+++end :: Bool -> Scene+end playMusic =+  Credits.make 0 $ Script+    wantedAssets+    (lScript playMusic)+    (end False)+++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  TB.wantedAssets+  ++ [ ("music-end", MySDL.Music "end.ogg")+     , ("nyx-avatar", MySDL.Texture "nyx-avatar.png")+     ]+++lScript :: Bool -> MySDL.Resources -> Script+lScript playMusic MySDL.Resources{ MySDL.fonts = fs, MySDL.music = ms } =+  [ PlayMusic Mix.Once ("music-end", M.lookup "music-end" ms)+  | playMusic+  ] +++  [ TextUp 3 (fromJust $ M.lookup "unispace" fs) (Point 280 1000) "ART BY: @trixelbit"+  , TextUp 2 (fromJust $ M.lookup "unispace" fs) (Point 300 1000) "GAME BY: @_gilmi"+  , TextUp 2 (fromJust $ M.lookup "unispace" fs) (Point 270 1000) "THANKS FOR PLAYING!"+  , Wait noAction 60+  , StopMusic+  , Wait act{ command = Done } 120+  ]
+ app/Script/Introduction.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}++module Script.Introduction where++import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified SDL.Mixer as Mix++import Script+import Play.Engine+import qualified Data.Text as T+import qualified Data.Map as M+import qualified TextBox as TB+import qualified Play.Engine.Sprite as Spr+import qualified Script.Level1 as L1+import qualified VN+++intro :: Scene+intro =+  VN.make 0 $ Script+    wantedAssets+    introScript+    intro++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  TB.wantedAssets+  ++ [ ("store", MySDL.Music "store.ogg")+     , ("nyx-avatar", MySDL.Texture "nyx-avatar.png")+     , ("customer-avatar", MySDL.Texture "customer.png")+     ]+++introScript :: MySDL.Resources -> Script+introScript MySDL.Resources{ MySDL.textures = ts, MySDL.fonts = fs, MySDL.music = ms } =++  [ FadeIn noAction 200+  , PlayMusic Mix.Forever ("store", M.lookup "store" ms)++  , let+      sprargs rint =+        Spr.make $ Spr.MakeArgs+          { mkActionmap = ["normal"]+          , mkAction = "normal"+          , mkTexture = rint+          , mkSize = Point 800 1000+          , mkMaxPos = 4+          , mkSpeed = 30+          }+      spr = sprargs =<< M.lookup "bga" ts+    in+      Wait act{ changeSprite = spr } 0++  , Wait noAction 120+  , nyxInnerVoice fs "Hi."+  , nyxInnerVoice fs "I'm Nyx."++  , nyxInnerVoice fs "I work at this store. Fixing computers."+  , nyxInnerVoice fs $ T.unwords+    [ "While there still aren't many computers in personal use, their numbers keep increasing by the day."+    ]+  , nyxInnerVoice fs $ T.unwords+    [ "So I believe this is a good business to be in."+    ]+  , nyxInnerVoice fs "Sorry, gotta work now. A customer just came in."++  , customerVoice ts fs "Hey."+  , customerVoice ts fs "This is Nyx Fix, right? You fix computers?"++  , nyxVoice ts fs "Yeah.          \nHow can I help you?"++  , customerVoice ts fs "My computer is stuck. I can't run any programs. Can you do anything about it?"++  , nyxVoice ts fs "Let me have a look..."+  , Wait noAction 120++  , nyxVoice ts fs "Yep.        \nIt looks like it's infected with viruses."++  , customerVoice ts fs "A virus?! Will I get sick?"++  , nyxVoice ts fs "Computer viruses. It only affects computers."+  , nyxVoice ts fs "I can fix it but I'll need to keep it here for a few days."+  , nyxVoice ts fs "Can you leave your computer and your contact information?\nI'll call you when it's fixed."++  , customerVoice ts fs "Oh, good. Yes. Thank you. I'll wait for your call."++  , nyxVoice ts fs "Have a nice day."++  , customerVoice ts fs "You too."+++  , StopMusic+  , Wait noAction 100++  , LoadTextBox noAction $+    TB.make TB.Top 15 "*Click*" Nothing (M.lookup "unispace" fs)+  , customerVoice ts fs "..."++  , customerVoice ts fs "Yeah, it's me."+  , customerVoice ts fs "It is done."+  , customerVoice ts fs "Now all we can do is wait and see if she can actually do it..."++  , Wait noAction 100+  , nyxVoice ts fs "Alright."+  , nyxVoice ts fs "Let the fixing begin!"+++  , Wait noAction 60++  , Wait act{ command = Replace $ L1.level1 True } 60+  ]+++nyxInnerVoice fs txt =+  LoadTextBox noAction $+    TB.make TB.Bottom 3 txt+    Nothing+    (M.lookup "unispace" fs)++nyxVoice ts fs txt =+  LoadTextBox noAction $+    TB.make TB.Bottom 3 txt+    (M.lookup "nyx-avatar" ts)+    (M.lookup "unispace" fs)++customerVoice ts fs txt =+  LoadTextBox noAction $+    TB.make TB.Top 3 txt+    (M.lookup "customer-avatar" ts)+    (M.lookup "unispace" fs)
+ app/Script/Level1.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++module Script.Level1 where++import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified SDL.Mixer as Mix++import Script+import Play.Engine.Types+import Play.Engine+import qualified Enemy.Static as St+import qualified Enemy.CrossDown as CDE+import qualified Enemy.SideToSideSpiral as SSE+import qualified GameState as GS+import qualified Script.Level2 as L2+import qualified TextBox as TB+import qualified Data.Map as M+++level1 :: Bool -> Scene+level1 playMusic =+  GS.mkGameState $ Script+    wantedAssets+    (lScript playMusic)+    (level1 False)+++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  CDE.wantedAssets+  ++ St.wantedAssets+  ++ SSE.wantedAssets+  ++ TB.wantedAssets+  ++ [ ("battle", MySDL.Music "battle.ogg")+     , ("nyx-avatar", MySDL.Texture "nyx-avatar.png")+     ]+++lScript :: Bool -> MySDL.Resources -> Script+lScript playMusic MySDL.Resources{ MySDL.textures = ts, MySDL.fonts = fs, MySDL.music = ms } =+  +  -- [ Spawn $ sequence [Fast.make (Point 350 (-100)) ts]+  -- , WaitUntil noAction (const $ null)++  [ PlayMusic Mix.Forever ("battle", M.lookup "battle" ms)+  | playMusic+  ] +++  [ LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Bottom 3 "Here they come." (M.lookup "nyx-avatar" ts) (M.lookup "unispace" fs)++  , Wait noAction 60+  ] +++  -- First sequence+  concat+    ( replicate 3 $ concat+      [ spawnStaticAndWait 200 300 ts+      , spawnStaticAndWait 600 200 ts+      , spawnStaticAndWait 400 400 ts+      , spawnStaticAndWait 250 250 ts+      , spawnStaticAndWait 650 400 ts+      , spawnStaticAndWait 350 350 ts+      ]+    ) +++  -- Mixing in up+  concat+    [ spawnStaticAndWait 200 300 ts+    , spawnStaticAndWait 600 200 ts+    , [Spawn $ sequence [CDE.make (Point 100 (-180)) (Right ()) ts]]+    , spawnStaticAndWait 400 400 ts+    , spawnStaticAndWait 250 250 ts+    , spawnStaticAndWait 650 400 ts+    , spawnStaticAndWait 350 350 ts+    ] +++  -- Mixing in up+  concat+    [ spawnStaticAndWait 200 300 ts+    , spawnStaticAndWait 600 200 ts+    , spawnStaticAndWait 400 400 ts+    , spawnStaticAndWait 250 250 ts+    , [Spawn $ sequence [CDE.make (Point 700 (-180)) (Left ()) ts]]+    , spawnStaticAndWait 650 400 ts+    , spawnStaticAndWait 350 350 ts+    ] +++  -- Mixing in up more+  concat+    [ spawnStaticAndWait 200 300 ts+    , [Spawn $ sequence [CDE.make (Point 100 (-180)) (Right ()) ts]]+    , spawnStaticAndWait 600 200 ts+    , spawnStaticAndWait 400 400 ts+    , [Spawn $ sequence [CDE.make (Point 700 (-180)) (Left ()) ts]]+    , spawnStaticAndWait 250 250 ts+    , spawnStaticAndWait 650 400 ts+    , spawnStaticAndWait 350 350 ts+    , [spawnTwoCDEs (Right ()) (Left ()) ts]+    ] ++++  -- First wave done+  [ WaitUntil noAction (const $ null)+  , Wait noAction 200+  , Wait act{ stopTheWorld = True } 30+  , Wait act{ command = Replace $ L2.level2 False } 60+  ]++spawnTwoCDEs dir1 dir2 ts =+  Spawn $ sequence+    [ CDE.make (Point 300 (-180)) dir1 ts+    , CDE.make (Point 400 (-180)) dir2 ts+    ]++spawnStaticAndWait posx target ts =+  [ Spawn $ sequence+    [ St.make (Point posx (-100)) (Point 0 1) target ts+    ]+  , Wait noAction 120+  ]
+ app/Script/Level2.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++module Script.Level2 where++import qualified Play.Engine.MySDL.MySDL as MySDL+import qualified SDL.Mixer as Mix++import Script+import Play.Engine+import qualified Enemy.Static as St+import qualified Enemy.CrossDown as CDE+import qualified GameState as GS+import qualified Script.Boss as Boss+import qualified TextBox as TB+import qualified Data.Map as M+++level2 :: Bool -> Scene+level2 playMusic =+  GS.mkGameState $ Script+    wantedAssets+    (lScript playMusic)+    (level2 False)+++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  CDE.wantedAssets+  ++ St.wantedAssets+  ++ TB.wantedAssets+  ++ [ ("battle", MySDL.Music "battle.ogg")+     , ("nyx-avatar", MySDL.Texture "nyx-avatar.png")+     ]+++lScript :: Bool -> MySDL.Resources -> Script+lScript playMusic MySDL.Resources{ MySDL.textures = ts, MySDL.fonts = fs, MySDL.music = ms } =+  +  [ goToLoc $ Point 380 800+  ] +++  [ PlayMusic Mix.Forever ("battle", M.lookup "battle" ms)+  | playMusic+  ] +++  [ LoadTextBox act{ stopTheWorld = True } $+    TB.make TB.Bottom 4 "This is harder than I expected..." (M.lookup "nyx-avatar" ts) (M.lookup "unispace" fs)+  ] ++++  -- Second wave+  concat+    [ [ Spawn $ sequence [CDE.make (Point 100 (-180)) (Right ()) ts]+      , Wait noAction 100+      ]+    , spawnStaticAndWait 400 300 ts+    , [ Spawn $ sequence [CDE.make (Point 700 (-180)) (Left ()) ts]+      , Wait noAction 100+      ]+    , [ Spawn $ sequence [CDE.make (Point 650 (-150)) (Left ()) ts]+      , Wait noAction 100+      ]+    , [ Spawn $ sequence [CDE.make (Point 100 (-180)) (Right ()) ts]+      , Wait noAction 100+      ]+    , spawnStaticAndWait 600 300 ts+    , spawnStaticAndWait 250 250 ts+    , [ spawnTwoCDEs (Left ()) (Right ()) ts+      , Wait noAction 100+      , spawnTwoCDEs (Right ()) (Left ()) ts+      , Wait noAction 100+      ]+    , [ spawnTwoCDEs (Left ()) (Right ()) ts+      , Wait noAction 60+      , spawnTwoCDEs (Right ()) (Left ()) ts+      ]+    , spawnStaticAndWait 600 300 ts+    , spawnStaticAndWait 250 250 ts+    , [ spawnTwoCDEs (Left ()) (Right ()) ts+      , Wait noAction 60+      , spawnTwoCDEs (Right ()) (Left ()) ts+      ]+    ] ++++  -- Second wave done+  [ WaitUntil noAction (const $ null)+  , Wait noAction 200+  , StopMusic+  , Wait act{ stopTheWorld = True } 30+  , Wait act{ command = Replace $ Boss.boss True 0 } 60+  ]++spawnTwoCDEs dir1 dir2 ts =+  Spawn $ sequence+    [ CDE.make (Point 300 (-180)) dir1 ts+    , CDE.make (Point 400 (-180)) dir2 ts+    ]++spawnStaticAndWait posx target ts =+  [ Spawn $ sequence+    [ St.make (Point posx (-100)) (Point 0 1) target ts+    ]+  , Wait noAction 120+  ]
+ app/ShootingBox.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module ShootingBox where++import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL++import Play.Engine++import Data.Maybe+import Control.Monad.Except+import Control.Lens+import Control.DeepSeq+import qualified Control.Monad.State as SM+import qualified Data.DList as DL+import qualified Data.Map as M++import qualified Play.Engine.Movement as MV+import qualified Play.Engine.Sprite as Spr+import Bullet++-- import Debug.Trace++++data Dir+  = DirRight+  | DirLeft+  deriving (Eq, Show)++data MainChar+  = MainChar+  { _pos :: {-# UNPACK #-} !IPoint+  , _size :: {-# UNPACK #-} !Size+  , _movement :: {-# UNPACK #-} !MV.Movement+  , _sprite :: !Spr.Sprite+  , _bullet :: !SDL.Texture+  , _hitTimer :: {-# UNPACK #-} !Int+  , _bulletsTimer :: {-# UNPACK #-} !Int+  , _health :: {-# UNPACK #-} !Int+  , _lastDir :: !Dir+  , _hitbox :: !Hitbox+  }++makeFieldsNoPrefix ''MainChar++instance NFData MainChar where+  rnf (MainChar {_pos, _size, _hitTimer, _movement, _health, _bulletsTimer}) =+    rnf _pos+    `seq` rnf _size+    `seq` rnf _direction+    `seq` rnf _movement+    `seq` rnf _hitTimer+    `seq` rnf _bulletsTimer+    `seq` rnf _health+    `seq` rnf _transparency++instance Eq MainChar where+  mc1 == mc2 =+    mc1 ^. pos == mc2 ^. pos+    && mc1 ^. size == mc2 ^. size++instance Ord MainChar where+  mc1 <= mc2 =+    mc1 ^. pos <= mc2 ^. pos+    && mc1 ^. size <= mc2 ^. size++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("nyx-sprites", MySDL.Texture "nyx-sprites-animated.png")+  , ("nyx-bullet", MySDL.Texture "nyx-bullet.png")+  ]+++mkMainChar :: M.Map String SDL.Texture -> Result MainChar+mkMainChar ts = do+  case mapM ((`M.lookup` ts) . fst) wantedAssets of+    Just [nyxSprites, nyxBullet] ->+      pure $+        MainChar+          { _pos = Point 380 800+          , _size = charSize+          , _sprite =+            fromJust+              $ Spr.make+              $ Spr.MakeArgs+              { mkActionmap = ["normal", "side-right", "side-left"]+              , mkAction = "normal"+              , mkTexture = nyxSprites+              , mkSize = Point 180 380+              , mkMaxPos = 4+              , mkSpeed = 5+              }+          , _bullet = nyxBullet+          , _hitTimer = -1+          , _bulletsTimer = 5+          , _health = 1+          , _movement = MV.make $ MV.defArgs+            { MV.maxspeed = Point 5 5+            , MV.accel = Point 3.5 3.5+            }+          , _lastDir = DirRight+          , _hitbox = Hitbox+            { _alignment = Point (charSize ^. x `div` 4) (charSize ^. y `div` 4)+            , _size = charSize+              & over x (`div` 2)+              & over y (`div` 2)+            }+          }+    _ ->+      throwError ["Texture not found: nyx-sprites"]++charSize :: Size+charSize = Point 60 108++fixHitpos :: MainChar -> MainChar+fixHitpos mc = mc+  & set (hitbox . alignment . x) (charSize ^. x `div` 4)+  & set (hitbox . alignment . y) (charSize ^. y `div` 4)+  & set (hitbox . size . x) (charSize ^. x `div` 2)+  & set (hitbox . size . y) (charSize ^. y `div` 3)++halfHitbox :: MainChar -> MainChar+halfHitbox mc = mc+  & set (hitbox . alignment . x) (charSize ^. x `div` 3)+  & set (hitbox . alignment . y) (charSize ^. y `div` 3)+  & set (hitbox . size . x) (charSize ^. x `div` 3)+  & set (hitbox . size . y) (charSize ^. y `div` 3)+++update :: Input -> MainChar -> Result (MainChar, DL.DList Bullet -> DL.DList Bullet)+update input mc = do+  wsize <- _windowSize <$> SM.get+  let+    dir = keysToMovement 1 input+    (mv, move) =+      MV.update dir+        . set MV.maxSpeed (if keyPressed KeyB input then Point 1.2 1.2 else Point 4 4)+        $ (mc ^. movement)++    addBullets+      | keyPressed KeyA input+      , mc ^. bulletsTimer == 0 =+        DL.append $ DL.fromList (newBullet mc)+      | otherwise = id++    newDir+      | keyPressed KeyLeft  input = DirLeft+      | keyPressed KeyRight input = DirRight+      | otherwise = mc ^. lastDir++    newMC =+      mc+      & over pos (`addPoint` move)+      & fixPos wsize+      & fixHitpos+      & set (size . x) (if keyPressed KeyB input then charSize ^. x `div` 2 else charSize ^. x)+      & (if keyPressed KeyB input then halfHitbox else id)+      & set movement mv+      & set lastDir newDir+      & over sprite+        (flip Spr.update False $+           if+             | keyPressed KeyB input && newDir == DirRight -> Just "side-left"+             | keyPressed KeyB input -> Just "side-right"+             | otherwise -> Just "normal"+        )+      & over hitTimer (\t -> if t <= 0 then -1 else t - 1)+      & over bulletsTimer (\t -> if t > 0 then t - 1 else if keyPressed KeyA input then 5 else 0)++    result =+      if mc ^. health <= 0 && mc ^. hitTimer < 0+        then (set size (Point 0 0) mc, id)+        else (newMC, addBullets)++  pure result++newBullet :: MainChar -> [Bullet]+newBullet mc+  | mc ^. size . x == charSize ^. x =+    [ mkBullet (mc ^. bullet) (Point 0 (-1)) mv 2 70 ((mc ^. pos) `addPoint` Point (mc ^. size . x `div` 4) 0)+    , mkBullet (mc ^. bullet) (Point 0 (-1)) mv 2 70 ((mc ^. pos) `addPoint` Point ((mc ^. size . x `div` 4) * 3) 0)+    ]+  | otherwise =+    [ mkBullet (mc ^. bullet) (Point 0 (-1)) mv 5 140 ((mc ^. pos) `addPoint` Point (charSize ^. x `div` 2) 0)+    ]++  where+    mv = MV.make $ MV.defArgs+      { MV.maxspeed = Point 0 10+      , MV.accel = Point 0 10+      }++checkHit :: [Bullet] -> MainChar -> MainChar+checkHit bullets mc+  | not (null bullets) && mc ^. health > 0+  = mc+    & over health (flip (-) (maximum $ (0:) $ map (^. damage) bullets))+    & \mc' -> set hitTimer (if mc' ^. health <= 0 then hitTimeout * 4 else hitTimeout) mc'+  | otherwise+  = mc++hitTimeout = 20++render :: SDL.Renderer -> Camera -> MainChar -> IO ()+render renderer cam mc =+  unless (mc ^. health < 0 && mc ^. hitTimer < 0) $ do+    let+      isHit = mc ^. hitTimer > 0 && mc ^. hitTimer `mod` 8 < 4+    Spr.render renderer cam (mc ^. pos) charSize (if isHit then 100 else 255) (mc ^. sprite)++get mc l+  | mc ^. health <= 0 && mc ^. hitTimer < 0 = Nothing+  | otherwise = pure $ mc ^. l
+ app/StartScreen.hs view
@@ -0,0 +1,134 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module StartScreen where++import Data.Maybe (fromJust)+import SDL.Vect (V4(..))+import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL++import Play.Engine hiding (head)+import Control.Monad.Except+import Control.Lens+import Data.Bifunctor+import Data.Bool+import qualified Data.Map as M+import qualified Play.Engine.Sprite as Spr+import qualified Play.Engine.ListZipper as Z+import qualified Play.Engine.Load as Load+import qualified Control.Monad.State as SM++import qualified Script.Introduction as Intro+import qualified PickStage as Pick+import qualified KeyScreen as Keys+import qualified Play.Engine.Button as Btn+++data State+  = State+  { _bg :: Spr.Sprite+  , _buttons :: Z.ListZipper (Btn.Button, Result StackCommand)+  , _cheat :: !Int+  }++makeFieldsNoPrefix ''State++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("vnbg", MySDL.Texture "VNBG.png")+  , ("unispace", MySDL.Font "unispace/unispace.ttf")+  ]++make :: Scene+make = Load.mkState 0 wantedAssets (mkState 5)++mkState :: Int -> MySDL.Resources -> Result Scene+mkState cheat_ rs = do+  state <- initState cheat_ rs+  pure $ mkScene+    state+    update+    render++initState :: Int -> MySDL.Resources -> Result State+initState cheat_ rs = do+  case (,)+    <$> M.lookup "vnbg" (MySDL.textures rs)+    <*> M.lookup "unispace" (MySDL.fonts rs) of+    Nothing ->+      throwError ["Texture not found: vnbg or unispace"]+    Just (bgt, fnt) -> do+      let+        makeBtn' n =+          Btn.make (Point 320 (600 + n * 60)) (Point 180 50) fnt++        makeBtn name state n =+          (makeBtn' n name, pure $ Push state)++        btns = zipWith (flip ($)) [0..] $+          [ makeBtn "Start" Intro.intro ]+          ++ [ makeBtn "Pick Stage" Pick.make | cheat_ <= 0 ]+          ++ [ makeBtn "Keys" Keys.make ]+          ++ [ \n -> (makeBtn' n "Exit", throwError []) ]++      pure $ State+        { _bg =+          fromJust+            $ Spr.make+            $ Spr.MakeArgs+            { mkActionmap = ["normal"]+            , mkAction = "normal"+            , mkTexture = bgt+            , mkSize = Point 800 1000+            , mkMaxPos = 8+            , mkSpeed = 8+            }+        , _buttons = Z.ListZipper+          []+          (head btns)+          (tail btns)+        , _cheat = cheat_+        }++update :: Input -> State -> Result (StackCommand, State)+update input state = do+  _wSize <- _windowSize <$> SM.get+  btns <- Z.diffMapM (firstM $ Btn.update empty) (firstM $ Btn.update input)+    $ if+       | keyClicked KeyDown input ->+         Z.nextCycle (state ^. buttons)++       | keyClicked KeyUp input ->+         Z.prevCycle (state ^. buttons)++        | otherwise ->+          state ^. buttons++  let ((check, _), cmd') = Z.get btns+  cmd <- bool (pure None) cmd' check+  pure+    ( if state ^. cheat == 0+        then Replace $ Load.mkState 0 wantedAssets (mkState $ -1)+        else cmd+    , state+      & set buttons (fmap (first snd) btns)+      & over cheat (if keyClicked KeyC input then (\c -> c - 1) else id)+    )++render :: SDL.Renderer -> State -> IO ()+render renderer state = do+  let n = fromIntegral $ max (-1) (state ^. cheat) * 8+  void $ MySDL.setBGColor (V4 (10 + n) 0 20 255) renderer+  Spr.render renderer id (Point 0 0) (state ^. bg . size) 255 (state ^. bg)+  shade renderer id (160 + n)+  void $ Z.diffMapM+    (Btn.render renderer False)+    (Btn.render renderer True)+    (fmap fst $ state ^. buttons)+
+ app/TextBox.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}++module TextBox where++import SDL.Vect (V4(..))+import qualified SDL+import qualified SDL.Font as SDLF+import qualified Play.Engine.MySDL.MySDL as MySDL++import Data.Monoid ((<>))+import Data.Maybe+import Control.Arrow+import Control.Lens+import Control.Monad.Except+import Play.Engine hiding (renderText)+import qualified Control.Monad.State as SM+import qualified Data.Text as T+import qualified Play.Engine.ListZipper as Zip+++data Loc+  = Top+  | Bottom+  | All+  deriving (Show, Eq, Ord)++data TextBox+  = TextBox+  { _avatar :: Maybe SDL.Texture+  , _font :: SDLF.Font+  , _text :: Zip.ListZipper (Int, T.Text)+  , _posY :: !Loc+  , _pos :: {-# UNPACK #-} !IPoint+  , _size :: {-# UNPACK #-} !IPoint+  , _textSpeed :: Int+  , _textTimer :: Int+  }++makeFieldsNoPrefix ''TextBox++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("unispace", MySDL.Font "unispace/unispace.ttf")+  ]++make :: Loc -> Int -> T.Text -> Maybe SDL.Texture -> Maybe SDLF.Font -> Result TextBox+make _ _ _ _ Nothing =+  throwError ["A font was not provided to TextBox."]+make py spd txt mavatar (Just fnt) =+  pure $ TextBox+    { _avatar = mavatar+    , _font = fnt+    , _text =+      uncurry+        (Zip.ListZipper [])+      . (Prelude.head &&& tail)+      . zip (cycle [0])+      . concat+      . fmap (splitLine $ isJust mavatar)+      . T.lines+      $ txt+    , _posY = py+    , _pos = Point 0 0+    , _size = Point 0 0+    , _textSpeed = spd+    , _textTimer = spd+    }++splitLine :: Bool -> T.Text -> [T.Text]+splitLine hasAvatar txt =+  groupWhile (\t1 t2 -> plus1' (T.length t1) + T.length t2 <= (if hasAvatar then 43 else 50)) ""+  . T.words+  $ txt+++groupWhile :: (T.Text -> T.Text -> Bool) -> T.Text -> [T.Text] -> [T.Text]+groupWhile test t1 = \case+  t2 : rest+    | test t1 t2 ->+      groupWhile test (t1 <> (if t1 == "" then "" else " ") <> t2) rest+    | otherwise  -> t1 : groupWhile test t2 rest+  [] -> [t1]++plus1' :: Int -> Int+plus1' n+  | n == 0 = 0+  | otherwise = n + 1++update :: Input -> TextBox -> Result (Maybe TextBox)+update input tb+  | keyClicked KeyA input+  , let (l, t) = Zip.last (tb ^. text) in l == T.length t+  = pure Nothing+  | otherwise = do+    wSize <- _windowSize <$> SM.get+    let+      locY = case tb ^. posY of+        Top -> 20+        All -> 20+        Bottom -> (wSize ^. y - 220)++    pure $ pure $ tb+      & set pos (Point 20 locY)+      & set size+        (Point (wSize ^. x - 40) $+          if tb ^. posY == All+            then wSize ^. y - 40+            else 200+        )+      & over text+        (\(txt :: Zip.ListZipper (Int, T.Text)) ->+           if+             | keyClicked KeyA input+             || tb ^. textSpeed == 0 ->+               fmap (\(_, t) -> (T.length t, t)) txt+             | tb ^. textTimer == 0+             && fst (Zip.get txt) < T.length (snd $ Zip.get txt) ->+               Zip.overCurr (first (+1)) txt+             | tb ^. textTimer == 0 ->+               Zip.nextStop txt+             | otherwise ->+               txt+        )+      & over textTimer (\t -> if t <= 0 then tb ^. textSpeed else t - 1)+++render :: SDL.Renderer -> TextBox -> IO ()+render renderer tb+  | tb ^. size == Point 0 0 =+    pure ()+  | otherwise = do+  let+    rect = toRect (tb ^. pos) (tb ^. size)++  SDL.rendererDrawColor renderer SDL.$= V4 0 0 0 150+  SDL.fillRect renderer (Just rect)+  SDL.rendererDrawColor renderer SDL.$= V4 255 0 160 200+  SDL.drawRect renderer (Just rect)++  loc <- case tb ^. avatar of+    Nothing -> pure (fmap (+20) $ tb ^. pos)+    Just av -> do+      SDL.copy+        renderer+        av+        Nothing+        (Just $ toRect+          (fmap (+20) $ tb ^. pos)+          (Point 96 96)+        )+      pure (Point (20 + tb ^. pos . x + 96 + 20) (tb ^. pos . y + 20))+  void $ traverse (renderText renderer tb loc) $ Zip.addIndex (tb ^. text)++renderText :: SDL.Renderer -> TextBox -> IPoint -> (Int, (Int, T.Text)) -> IO ()+renderText renderer tb loc (idx, (txtPart, txt)) =+  if txtPart == 0+    then pure ()+    else do+      texture <- SDL.createTextureFromSurface renderer+        =<< SDLF.solid+          (tb ^. font)+          (V4 255 255 255 255)+          (T.take txtPart txt)+      ti <- SDL.queryTexture texture+      SDL.copy+        renderer+        texture+        Nothing+        (Just $ toRect+          (over y ((+) (idx * 35)) loc)+          (Point (fromIntegral $ SDL.textureWidth ti) (fromIntegral $ SDL.textureHeight ti))+        )+      SDL.destroyTexture texture
+ app/VN.hs view
@@ -0,0 +1,165 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module VN where++import SDL.Vect (V4(..))+import qualified SDL+import qualified SDL.Mixer as Mix+import qualified SDL.Font as SDLF+import qualified Play.Engine.MySDL.MySDL as MySDL++import Data.Maybe+import Control.Monad.Except+import Control.Lens+import System.Random+import Play.Engine+import qualified Play.Engine.Load as Load+import qualified Control.Monad.State as SM+import qualified Data.Map as M++import qualified Script+import qualified Play.Engine.Sprite as Spr+++data State+  = State+  { _bg :: Spr.Sprite+  , _resources :: MySDL.Resources+  , _script :: Script.Script+  , _camera :: Int+  , _isPause :: !Bool+  , _pauseChanged :: !Bool+  , _isMute :: !Bool+  , _hudFont :: SDLF.Font+  , _exit :: !Bool+  }++makeFieldsNoPrefix ''State++wantedAssets :: [(String, MySDL.ResourceType FilePath)]+wantedAssets =+  [ ("bg", MySDL.Texture "VNBG.png")+  , ("unispace", MySDL.Font "unispace/unispace.ttf")+  ]++make :: Int -> Script.ScriptData -> Scene+make t sd = Load.mkState t (wantedAssets ++ Script.assets sd) (mkState $ Script.script sd)++mkState+  :: (MySDL.Resources -> Script.Script)+  -> MySDL.Resources -> Result Scene+mkState scrpt rs = do+  state <- initState (scrpt rs) rs+  pure $ mkScene+    state+    update+    render++initState :: Script.Script -> MySDL.Resources -> Result State+initState scrpt rs = do+  case (,) <$> M.lookup "bg" (MySDL.textures rs) <*> M.lookup "unispace" (MySDL.fonts rs) of+    Nothing ->+      throwError ["Texture not found: bg ot unispace"]+    Just (bgt, font) -> do+      pure $ State+        { _bg =+          fromJust+            $ Spr.make+            $ Spr.MakeArgs+            { mkActionmap = ["normal"]+            , mkAction = "normal"+            , mkTexture = bgt+            , mkSize = Point 800 1000+            , mkMaxPos = 8+            , mkSpeed = 8+            }+        , _resources = rs+        , _script = scrpt+        , _camera = 0+        , _isPause = False+        , _pauseChanged = False+        , _isMute = False+        , _hudFont = font+        , _exit = False+        }++update :: Input -> State -> Result (StackCommand, State)+update input st = do+  _wSize <- _windowSize <$> SM.get+  ismute <- _muteMusic <$> SM.get+  let+    state = set isMute ismute st++  (acts, script') <- Script.update input Nothing mempty (state ^. script)++  let+    newState =+      state'+        & set script script'+        & over camera+          (\c ->+             if+               | c <= 0 && Script.shake acts -> 60+               | c <= 0 -> 0+               | otherwise -> c - 1+          )+      where+        state' =+          if Script.stopTheWorld acts+            then+              state+            else+              state+                & over bg+                ( case Script.changeSprite acts of+                    Nothing -> Spr.update Nothing False+                    Just sp -> const sp+                )++  if+    | keyReleased KeyP input && state ^. isPause -> do+      pure (None, set pauseChanged True $ set isPause False state)+    | keyReleased KeyP input && not (state ^. isPause) -> do+      pure (None, set pauseChanged True $ set isPause True state)+    | state ^. isPause -> do+      pure (None, state)+    | keyReleased KeyQuit input -> do+      pure (None, set exit True state)+    | state ^. exit -> do+      pure (Done, state)+    | otherwise ->+      pure (Script.command acts, newState)++render :: SDL.Renderer -> State -> IO ()+render renderer state = do+  cam' <- Point <$> randomRIO (-1, 1) <*> randomRIO (-1, 1) :: IO FPoint+  let cam = addPoint $ fmap (floor . (*) (fromIntegral $ state ^. camera `div` 3)) cam'+  Spr.render renderer cam (Point 0 0) (state ^. bg . size) 255 (state ^. bg)++  when (state ^. isMute) $+    renderText renderer (state ^. hudFont) (Point 40 30) "MUTED"++  Script.render renderer cam (state ^. script)+  renderText renderer (state ^. hudFont) (Point 900 30) "MUTED"++  when (state ^. isPause) $ do+    let rect = toRect (cam $ Point 342 375) (Point 85 35)+    SDL.rendererDrawColor renderer SDL.$= V4 40 0 30 180+    SDL.fillRect renderer (Just rect)+    renderText renderer (state ^. hudFont) (Point 352 380) "PAUSE"++  when (state ^. pauseChanged) $+    if (state ^. isPause)+      then+        Mix.pauseMusic+      else+        Mix.resumeMusic++  when (state ^. exit) $+    Mix.haltMusic
+ assets/audio/battle.ogg view

binary file changed (absent → 1461387 bytes)

+ assets/audio/end.ogg view

binary file changed (absent → 77591 bytes)

+ assets/audio/store.ogg view

binary file changed (absent → 1381445 bytes)

+ assets/fonts/unispace/read_me.html view
@@ -0,0 +1,143 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+	<META HTTP-EQUIV="CONTENT-TYPE" CONTENT="text/html; charset=shift_jis">
+	<TITLE>LARABIE FONTS &ldquo;README</TITLE>
+	<META NAME="GENERATOR" CONTENT="StarOffice 8  (Win32)">
+	<META NAME="AUTHOR" CONTENT="Rina Larabie">
+	<META NAME="CREATED" CONTENT="20061130;11580000">
+	<META NAME="CHANGEDBY" CONTENT="Rina Larabie">
+	<META NAME="CHANGED" CONTENT="20061207;15120000">
+	<STYLE>
+	<!--
+		@page { size: 8.5in 11in; margin-right: 1.25in; margin-top: 1in; margin-bottom: 1in }
+		P { margin-bottom: 0.08in; direction: ltr; color: #000000; widows: 2; orphans: 2 }
+		P.western { font-family: "Times New Roman", serif; font-size: 12pt; so-language: en-US }
+		P.cjk { font-family: "Times New Roman", serif; font-size: 12pt }
+		P.ctl { font-family: "Times New Roman", serif; font-size: 12pt; so-language: ar-SA }
+		H3 { margin-top: 0.19in; margin-bottom: 0.19in; direction: ltr; color: #000000; widows: 2; orphans: 2; page-break-after: auto }
+		H3.western { font-size: 13pt; so-language: en-US }
+		H3.cjk { font-family: "Times New Roman", serif; font-size: 13pt }
+		H3.ctl { font-family: "Times New Roman", serif; font-size: 13pt; so-language: ar-SA }
+		A:link { color: #0000ff }
+	-->
+	</STYLE>
+</HEAD>
+<BODY LANG="en-US" TEXT="#000000" LINK="#0000ff" DIR="LTR">
+<H3 CLASS="western" STYLE="margin-top: 0in"><FONT FACE="Tahoma, sans-serif">LARABIE
+FONTS FREEWARE FONTS EULA (End User License Agreement) and SOFTWARE
+INCLUSION AGREEMENT</FONT></H3>
+<P CLASS="western" STYLE="margin-bottom: 0in"><B><FONT FACE="Tahoma, sans-serif">LARABIE
+FONTS FREEWARE FONTS EULA</FONT></B></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">Larabie
+Fonts Freeware Fonts in TrueType format are free to use for personal
+and commercial purposes. No payment is necessary to use Larabie Fonts
+Freeware Fonts for personal or commercial use. If you wish to include
+Larabie Fonts Freeware Fonts in software see SOFTWARE INCLUSION
+AGREEMENT below. </FONT></FONT>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT FACE="Tahoma, sans-serif"><FONT SIZE=2><B>USAGE</B></FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">You
+can offer individual Larabie Fonts Freeware Fonts for download on a
+website but do not combine fonts into a single archive or alter them
+in any way. We appreciate inclusion of the font name and trademark or
+site URL in the credits or documentation but it is not mandatory. </FONT></FONT>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">Some
+Larabie Fonts Freeware Fonts may have enhanced and/or expanded
+families available for sale at </FONT></FONT><FONT COLOR="#0000ff"><U><A HREF="http://www.typodermic.com/"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">www.typodermic.com</FONT></FONT></A></U></FONT><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">.</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT FACE="Tahoma, sans-serif"><FONT SIZE=2><B>PAYMENT</B></FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">Payment
+is not required for the use of Larabie Fonts Freeware Fonts unless
+they are intended to be <I>included</I> with software. More details
+follow.</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">Donations
+to Larabie Fonts are welcome via check or electronic payment via
+Paypal. We can accept any amount in US dollars, Canadian dollars, GBP
+or euros. If you require an invoice for your donation, please refer
+to </FONT></FONT><FONT COLOR="#0000ff"><U><A HREF="http://www.larabiefonts.com/donation.html"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">www.larabiefonts.com/donation.html</FONT></FONT></A></U></FONT><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">
+for instructions. </FONT></FONT>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">Donations
+can include CDs, magazines, t-shirts, a sample of your merchandise or
+anything featuring Larabie Fonts. Mailing information is available at
+the link above.</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT FACE="Tahoma, sans-serif"><FONT SIZE=2><B>SUPPORT</B></FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">Font
+installation help is available at </FONT></FONT><FONT COLOR="#0000ff"><U><A HREF="http://www.myfonts.com/support"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">www.myfonts.com/support</FONT></FONT></A></U></FONT><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">.
+If you experience problems with any Larabie Font, please visit
+</FONT></FONT><FONT COLOR="#0000ff"><U><A HREF="http://www.larabiefonts.com/"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">www.larabiefonts.com</FONT></FONT></A></U></FONT><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">
+to verify you have the latest version. If you download Larabie Fonts
+Freeware Fonts from other websites you may get older versions that
+have spacing issues, incomplete character sets or technical problems.
+</FONT></FONT>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><B><FONT FACE="Tahoma, sans-serif">SOFTWARE
+INCLUSION AGREEMENT </FONT></B>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">The
+Larabie Fonts SOFTWARE PRODUCT is protected by copyright laws and
+International copyright treaties, as well as other intellectual
+property laws and treaties. The SOFTWARE PRODUCT is licensed, not
+sold.</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">1.
+GRANT OF LICENSE. This document grants you the following rights:</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT FACE="Tahoma, sans-serif"><FONT SIZE=2>-
+Installation and Use. You may install and use an unlimited number of
+copies of the SOFTWARE PRODUCT. You may copy and distribute unlimited
+copies of the SOFTWARE PRODUCT as you receive them, in any medium,
+provided that you publish on each copy an appropriate copyright
+notice. Keep intact all the notices that refer to this License and
+give any other recipients of the fonts a copy of this License along
+with the fonts.</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">2.
+LIMITED WARRANTY NO WARRANTIES. Larabie Fonts expressly disclaims any
+warranty for the SOFTWARE PRODUCT. The SOFTWARE PRODUCT and any
+related documentation is provided &quot;as is&quot; without warranty
+of any kind, either express or implied, including, without
+limitation, the implied warranties or merchantability, fitness for a
+particular purpose, or non-infringement. The entire risk arising out
+of use or performance of the SOFTWARE PRODUCT remains with you.</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">NO
+LIABILITY FOR CONSEQUENTIAL DAMAGES. In no event shall Ray Larabie or
+Larabie Fonts be liable for any damages whatsoever (including,
+without limitation, damages for loss of business profits, business
+interruption, loss of business information, or any other pecuniary
+loss) arising out of the use of or inability to use this product,
+even if Larabie Fonts has been advised of the possibility of such
+damages.</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT FACE="Tahoma, sans-serif"><FONT SIZE=2>3.
+MISCELLANEOUS</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">Should
+you have any questions concerning this document or you desire to
+contact Larabie Fonts for any reason, please email
+</FONT></FONT><FONT COLOR="#0000ff"><U><A HREF="http://www.larabiefonts.com/email.html"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">www.larabiefonts.com/email.html</FONT></FONT></A></U></FONT><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">.</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><BR>
+</P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT SIZE=2><FONT FACE="Tahoma, sans-serif">4.
+GOVERNING LAW</FONT></FONT></P>
+<P CLASS="western" STYLE="margin-bottom: 0in"><FONT FACE="Tahoma, sans-serif"><FONT SIZE=2>This
+agreement is governed by the laws of Canada and the province of
+British Columbia.</FONT></FONT></P>
+</BODY>
+</HTML>
+ assets/fonts/unispace/unispace bold italic.ttf view

binary file changed (absent → 45048 bytes)

+ assets/fonts/unispace/unispace bold.ttf view

binary file changed (absent → 46112 bytes)

+ assets/fonts/unispace/unispace italic.ttf view

binary file changed (absent → 46680 bytes)

+ assets/fonts/unispace/unispace.ttf view

binary file changed (absent → 46360 bytes)

+ assets/imgs/VNBG.png view

binary file changed (absent → 56951 bytes)

+ assets/imgs/astral-avatar.png view

binary file changed (absent → 1719 bytes)

+ assets/imgs/astral-sprite.png view

binary file changed (absent → 21328 bytes)

+ assets/imgs/astral.png view

binary file changed (absent → 5821 bytes)

+ assets/imgs/background.png view

binary file changed (absent → 28220 bytes)

+ assets/imgs/bullet.png view

binary file changed (absent → 321 bytes)

+ assets/imgs/crossdown.png view

binary file changed (absent → 6260 bytes)

+ assets/imgs/customer.png view

binary file changed (absent → 1859 bytes)

+ assets/imgs/keys.png view

binary file changed (absent → 109192 bytes)

+ assets/imgs/nyx-avatar.png view

binary file changed (absent → 2206 bytes)

+ assets/imgs/nyx-bullet.png view

binary file changed (absent → 288 bytes)

+ assets/imgs/nyx-sprites-animated.png view

binary file changed (absent → 15495 bytes)

+ assets/imgs/static.png view

binary file changed (absent → 6289 bytes)

+ nyx-game.cabal view
@@ -0,0 +1,138 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 78a675277ac3aefd9876b0e6d0774e00d9e50cf1743bb5390353b88ca6ddf864++name:           nyx-game+version:        0.1.0.0+synopsis:       A bullet-hell game made with SDL2.+description:    A purely functional bullet-hell game made with SDL2. Visit https://gilmi.me/nyx for more details.+category:       Game+author:         Gil Mizrahi+maintainer:     gilmi@posteo.net+copyright:      2019 Gil Mizrahi+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+data-files:+    assets/audio/battle.ogg+    assets/audio/end.ogg+    assets/audio/store.ogg+    assets/fonts/unispace/read_me.html+    "assets/fonts/unispace/unispace bold italic.ttf"+    "assets/fonts/unispace/unispace bold.ttf"+    "assets/fonts/unispace/unispace italic.ttf"+    assets/fonts/unispace/unispace.ttf+    assets/imgs/astral-avatar.png+    assets/imgs/astral-sprite.png+    assets/imgs/astral.png+    assets/imgs/background.png+    assets/imgs/bullet.png+    assets/imgs/crossdown.png+    assets/imgs/customer.png+    assets/imgs/keys.png+    assets/imgs/nyx-avatar.png+    assets/imgs/nyx-bullet.png+    assets/imgs/nyx-sprites-animated.png+    assets/imgs/static.png+    assets/imgs/VNBG.png++library+  exposed-modules:+      Play.Engine+      Play.Engine.Button+      Play.Engine.Input+      Play.Engine.ListZipper+      Play.Engine.Load+      Play.Engine.Movement+      Play.Engine.MySDL.MySDL+      Play.Engine.Runner+      Play.Engine.Scene+      Play.Engine.ScrollingBackground+      Play.Engine.Settings+      Play.Engine.Sprite+      Play.Engine.Types+      Play.Engine.Utils+  other-modules:+      Paths_nyx_game+  hs-source-dirs:+      src+  default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf PatternGuards PatternSynonyms RankNTypes RecordWildCards NamedFieldPuns ScopedTypeVariables TupleSections ViewPatterns BangPatterns+  build-depends:+      async+    , base >=4.7 && <5+    , bytestring+    , containers+    , deepseq+    , dlist+    , lens+    , mtl+    , optparse-generic+    , random+    , sdl2+    , sdl2-image+    , sdl2-mixer+    , sdl2-ttf+    , stm+    , text+    , vector+  default-language: Haskell2010++executable app+  main-is: Main.hs+  other-modules:+      Attack+      Attack.SpiralAttack+      Bullet+      Credits+      DecObj.Particle+      DecObj.SplitTexture+      DecorationObject+      Enemy+      Enemy.CrossDown+      Enemy.Fast+      Enemy.SideToSideSpiral+      Enemy.Static+      GameState+      KeyScreen+      PickStage+      Script+      Script.Boss+      Script.End+      Script.Introduction+      Script.Level1+      Script.Level2+      ShootingBox+      StartScreen+      TextBox+      VN+      Paths_nyx_game+  hs-source-dirs:+      app+  default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf PatternGuards PatternSynonyms RankNTypes RecordWildCards NamedFieldPuns ScopedTypeVariables TupleSections ViewPatterns+  ghc-options: -Wall -fno-warn-missing-signatures -O2 -rtsopts -funfolding-use-threshold=16 -optc-O3+  build-depends:+      async+    , base+    , bytestring+    , containers+    , deepseq+    , dlist+    , lens+    , mtl+    , nyx-game+    , optparse-generic+    , random+    , sdl2+    , sdl2-image+    , sdl2-mixer+    , sdl2-ttf+    , stm+    , text+    , vector+  default-language: Haskell2010
+ src/Play/Engine.hs view
@@ -0,0 +1,10 @@+module Play.Engine+  ( module Engine+  )+where++import Play.Engine.Scene as Engine+import Play.Engine.Types as Engine+import Play.Engine.Utils as Engine+import Play.Engine.Input as Engine+import Play.Engine.Settings as Engine
+ src/Play/Engine/Button.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}++module Play.Engine.Button where++import qualified SDL+import qualified SDL.Font as SDLF++import Play.Engine+import Control.Lens+import SDL.Vect (V4(..))+import qualified Data.Text as T+++data Button+  = Button+  { _font :: SDLF.Font+  , _text :: T.Text+  , _pos :: {-# UNPACK #-} !IPoint+  , _size :: {-# UNPACK #-} !IPoint+  , _isClicked :: Bool+  }++makeFieldsNoPrefix ''Button++make :: IPoint -> Size -> SDLF.Font -> T.Text -> Button+make posi sz fnt txt = do+  Button+    { _font = fnt+    , _text = txt+    , _pos = posi+    , _size = sz+    , _isClicked = False+    }++update :: Input -> Button -> Result (Bool, Button)+update input btn =+  pure+    $ (keyClicked KeyStart input || keyClicked KeyA input,)+    $ btn+    & over isClicked (|| keyClicked KeyStart input || keyClicked KeyA input)++render :: SDL.Renderer -> Bool -> Button -> IO ()+render renderer marked btn+  | btn ^. size == Point 0 0 =+    pure ()+  | otherwise = do+  let+    rect = toRect (btn ^. pos) (btn ^. size)++  SDL.rendererDrawColor renderer SDL.$= V4 0 0 0 255+  SDL.fillRect renderer (Just rect)+  SDL.rendererDrawColor renderer SDL.$= V4 100 (if marked then 255 else 130) (if btn ^. isClicked then 255 else 180) 255+  SDL.drawRect renderer (Just rect)++  if T.length (btn ^. text) < 1+    then pure ()+    else do+      txt <- SDL.createTextureFromSurface renderer+        =<< SDLF.solid (btn ^. font) (V4 255 255 255 255) (btn ^. text)+      ti <- SDL.queryTexture txt+      let+        loc =+          Point+            (btn ^. pos . x + ((btn ^. size . x - fromIntegral (SDL.textureWidth  ti)) `div` 2))+            (btn ^. pos . y + ((btn ^. size . y - fromIntegral (SDL.textureHeight ti)) `div` 2))+      SDL.copy+        renderer+        txt+        Nothing+        (Just $ toRect+          loc+          (Point (fromIntegral $ SDL.textureWidth ti) (fromIntegral $ SDL.textureHeight ti))+        )+      SDL.destroyTexture txt
+ src/Play/Engine/Input.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}++module Play.Engine.Input where++import Data.Maybe+import Data.Word (Word8)+import Data.Tuple+import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL+import Play.Engine.Types+import qualified Data.Map as M+import GHC.Generics+import Control.DeepSeq++--import Debug.Trace++data Input+  = Input+  { inputKeys :: !Keys+  , responses :: ![MySDL.Response]+  }++type Keys = M.Map Key Action++data Action+  = Idle+  | Release+  | Hold+  | Click+  deriving (Show, Eq, Ord, Generic, NFData)++data Key+  = KeyUp+  | KeyDown+  | KeyLeft+  | KeyRight+  | KeyA+  | KeyB+  | KeyC+  | KeyD+  | KeyM+  | KeyP+  | KeyStart+  | KeyQuit+  deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic, NFData)++empty :: Input+empty = Input mempty mempty++initKeyStats :: Keys+initKeyStats = M.fromList $ zip [minBound..maxBound] (cycle [Idle])++defKeyMap :: [(Key, SDL.Scancode)]+defKeyMap = map swap+  [ (SDL.ScancodeW, KeyUp)+  , (SDL.ScancodeS, KeyDown)+  , (SDL.ScancodeA, KeyLeft)+  , (SDL.ScancodeD, KeyRight)+  , (SDL.ScancodeUp, KeyUp)+  , (SDL.ScancodeDown, KeyDown)+  , (SDL.ScancodeLeft, KeyLeft)+  , (SDL.ScancodeRight, KeyRight)+  , (SDL.ScancodeReturn, KeyStart)+  , (SDL.ScancodeEscape, KeyQuit)+  , (SDL.ScancodeQ, KeyQuit)+  , (SDL.ScancodeZ, KeyA)+  , (SDL.ScancodeX, KeyB)+  , (SDL.ScancodeR, KeyC)+  , (SDL.ScancodeV, KeyD)+  , (SDL.ScancodeM, KeyM)+  , (SDL.ScancodeP, KeyP)+  ]++-- can't have more than one binding to the same key as this will create a state accumulation problem+defControllerButtonMap :: [(Key, Word8)]+defControllerButtonMap = map swap+  [ (13, KeyUp)+  , (14, KeyDown)+  , (11, KeyLeft)+  , (12, KeyRight)+  , (0, KeyB)+  , (5, KeyA)+  , (3, KeyC)+  , (7, KeyStart)+  ]++keepState :: Maybe Action -> Bool+keepState state+  | state == Just Click = True+  | state == Just Hold = True+  | state == Just Release = False+  | state == Just Idle = False++  | otherwise = False++checkControllerEvent :: Word8 -> SDL.EventPayload -> Maybe Bool+checkControllerEvent btn = \case+  SDL.JoyButtonEvent (SDL.JoyButtonEventData _ btn' SDL.JoyButtonPressed)+    | btn == btn' -> pure True+  SDL.JoyButtonEvent (SDL.JoyButtonEventData _ btn' SDL.JoyButtonReleased)+    | btn == btn' -> pure False+  SDL.JoyAxisEvent (SDL.JoyAxisEventData _ btn' _)+    | btn == btn' -> pure True+  _ -> Nothing++makeEvents+  :: Keys -- keyboard keys+  -> Keys -- joystick keys+  -> [SDL.EventPayload]+  -> (SDL.Scancode -> Bool) -> [(Key, SDL.Scancode)]+  -> (Keys, Keys) -- (keyboard keys, joystick keys)+makeEvents !current !joycurrent payload !isKeyPressed keyboardKeys =+  let+    keyboard =+      fmap (fmap isKeyPressed)+    controller =+      fmap+        (\(key, btn) ->+          ( key+          ,+            let+              es = mapMaybe (checkControllerEvent btn) payload+            in+              if null es+                then keepState (M.lookup key joycurrent)+                else any id es+          )+        )+      $ defControllerButtonMap+  in+    ( updateKeys current+      . M.fromListWith max+      . keyboard+      $ keyboardKeys+    , updateKeys joycurrent+      . M.fromListWith max+      $ controller+    )++updateKeys :: Keys -> M.Map Key Bool -> Keys+updateKeys !keys !newStates =+  flip M.mapWithKey keys $ \k s ->+    case (s, testKey k newStates) of+      (Idle, True) -> Click+      (Click, True) -> Hold+      (Hold, True) -> Hold+      (Release, True) -> Click+      (Idle, False) -> Idle+      (Click, False) -> Release+      (Hold, False) -> Release+      (Release, False) -> Idle++testKey :: Key -> M.Map Key Bool -> Bool+testKey key = maybe False id . M.lookup key++keyReleased :: Key -> Input -> Bool+keyReleased key = keyReleased' key . inputKeys++keyClicked :: Key -> Input -> Bool+keyClicked key = keyClicked' key . inputKeys++keyPressed :: Key -> Input -> Bool+keyPressed key = keyPressed' key . inputKeys++keyIdle :: Key -> Input -> Bool+keyIdle key = keyIdle' key . inputKeys++keyReleased' :: Key -> Keys -> Bool+keyReleased' key = maybe False (== Release) . M.lookup key++keyClicked' :: Key -> Keys -> Bool+keyClicked' key = maybe False (== Click) . M.lookup key++keyPressed' :: Key -> Keys -> Bool+keyPressed' key = maybe False (/= Idle) . M.lookup key++keyIdle' :: Key -> Keys -> Bool+keyIdle' key = maybe False (== Idle) . M.lookup key++keysToMovement :: Float -> Input -> FPoint+keysToMovement speed keys =+  let+      singleMove k1 k2+        | keyPressed k1 keys && not (keyPressed k2 keys) = -speed+        | keyPressed k2 keys && not (keyPressed k1 keys) =  speed+        | otherwise = 0+      hori = singleMove KeyUp KeyDown+      vert = singleMove KeyLeft KeyRight+  in Point vert hori
+ src/Play/Engine/ListZipper.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFoldable, DeriveTraversable #-}++module Play.Engine.ListZipper where++import GHC.Generics+import Control.DeepSeq++data ListZipper a+  = ListZipper [a] !a [a]+  deriving (Eq, Ord, Show, Read, Functor, Foldable, Generic, NFData)++instance Traversable ListZipper where+  traverse f (ListZipper p c n) =+    ListZipper+      <$> fmap reverse (traverse f (reverse p))+      <*> f c+      <*> traverse f n++get :: ListZipper a -> a+get (ListZipper _ x _) = x++overCurr :: (a -> a) -> ListZipper a -> ListZipper a+overCurr f (ListZipper p x n) = ListZipper p (f x) n++nextStop :: ListZipper a -> ListZipper a+nextStop = \case+  ListZipper prev curr (n:next) ->+    ListZipper (curr : prev) n next+  l -> l++nextCycle :: ListZipper a -> ListZipper a+nextCycle = \case+  ListZipper prev curr (n:next) ->+    ListZipper (curr : prev) n next+  ListZipper prev curr [] ->+    let+      (curr' : next) = reverse $ curr : prev+    in+      ListZipper [] curr' next+++prevCycle :: ListZipper a -> ListZipper a+prevCycle = \case+  ListZipper (p:prev) curr next ->+    ListZipper prev p (curr : next)+  ListZipper [] curr next ->+    let+      (curr' : prev) = reverse $ curr : next+    in+      ListZipper prev curr' []++first :: ListZipper a -> a+first = \case+  ListZipper [] curr _ ->+    curr+  ListZipper prev _ _ ->+    Prelude.last prev++last :: ListZipper a -> a+last = \case+  ListZipper _ curr [] ->+    curr+  ListZipper _ _ next ->+    Prelude.last next++diffMapM :: Applicative f => (a -> f b) -> (a -> f b) -> ListZipper a -> f (ListZipper b)+diffMapM restF currF (ListZipper prev curr next) =+  ListZipper+    <$> traverse restF prev+    <*> currF curr+    <*> traverse restF next++addIndex :: ListZipper a -> ListZipper (Int, a)+addIndex = \case+  ListZipper prev curr next ->+    ListZipper+      (reverse $ zip [0..] $ reverse prev)+      (length prev, curr)+      (zip [length prev + 1..] next)
+ src/Play/Engine/Load.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}++module Play.Engine.Load where++import SDL.Vect (V4(..))+import qualified SDL+import qualified Play.Engine.MySDL.MySDL as MySDL++import Play.Engine+import Control.Monad.Except+import Control.Lens++data State+  = State+  { _timer :: Int+  , _filepaths :: [(String, MySDL.ResourceType FilePath)]+  , _nextScene :: MySDL.Resources -> Result Scene+  }++makeLenses ''State++mkState+  :: Int+  -> [(String, MySDL.ResourceType FilePath)]+  -> (MySDL.Resources -> Result Scene)+  -> Scene+mkState time files next =+  Scene $ SceneF (initState time files next) update render++initState+  :: Int+  -> [(String, MySDL.ResourceType FilePath)]+  -> (MySDL.Resources -> Result Scene)+  -> State+initState = State++update :: Input -> State -> Result ([MySDL.Request], (StackCommand, State))+update _ s@(State t _ _)+  | t > 0 = pure ([], (None, s & over timer (\n -> n - 1)))+update input s@(State _ files next) =+  case (files, responses input) of+    ([], []) -> pure ([], (None, s))+    ([], [MySDL.Exception e]) -> throwError [e]+    ([], [MySDL.ResourcesLoaded resources]) -> do+      next' <- next resources+      pure ([], (Replace next', s))+    ([], rs) -> throwError ["Unexpected number of responses: " ++ show (length rs)]+    (files', _) -> pure ([MySDL.Load files'], (None, set filepaths [] s))++render :: SDL.Renderer -> State -> IO ()+render renderer state =+  let c = fromIntegral $ state ^. timer+  in void $ MySDL.setBGColor+    ( V4+      (20 `mod` 255)+      ((10 + (c `div` 3)) `mod` 255)+      ((20 + (c `div` 2)) `mod` 255)+      255+    )+    renderer
+ src/Play/Engine/Movement.hs view
@@ -0,0 +1,128 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE BangPatterns #-}++module Play.Engine.Movement where++import Play.Engine.Utils+import Play.Engine.Types+import Control.Lens+import Control.DeepSeq+import GHC.Generics+import Data.Typeable++data Movement+  = Movement+  { _posFloatPart :: !FPoint+  , _speed :: !FPoint+  , _minSpeed :: !FPoint+  , _maxSpeed :: !FPoint+  , _acceleration :: !FPoint+  , _accelerationTimer :: !Int+  }+  deriving (Show, Eq, Generic, Typeable, NFData)++makeFieldsNoPrefix ''Movement++data MakeArgs+  = MakeArgs+  { startspeed :: !FPoint+  , minspeed :: !FPoint+  , maxspeed :: !FPoint+  , accel :: !FPoint+  }++defArgs :: MakeArgs+defArgs = MakeArgs+  { startspeed = Point 0 0+  , minspeed = Point 0 0+  , maxspeed = Point 1 1+  , accel = Point 0.1 0.1+  }++make :: MakeArgs -> Movement+make MakeArgs{..} =+  Movement+  { _posFloatPart = Point 0 0+  , _speed = startspeed+  , _minSpeed = fmap abs minspeed+  , _maxSpeed = fmap abs maxspeed+  , _acceleration = accel+  , _accelerationTimer = 0+  }++updateMovement :: FPoint -> Movement -> Movement+updateMovement !direction !mv =+  let+    updateSpeedC c spd =+      let+        accel =+          if direction ^. c /= 0+            then (mv ^. acceleration . c) * (direction ^. c)+            else limit (abs spd) $ (mv ^. acceleration . c) * negate (normalize spd)+      in+        if mv ^. accelerationTimer == 0+          then+            let+              newSpd = limit (mv ^. maxSpeed . c) . (+ accel) $ spd+              norm = normalize newSpd * (mv ^. minSpeed . c)+            in+              if abs newSpd < abs norm+                then norm+                else newSpd+          else spd+  in+    force $ mv+    & over (speed . x) (updateSpeedC x)+    & over (speed . y) (updateSpeedC y)+    & over accelerationTimer (\t -> if t <= 0 then 1 else t - 1)++limit :: Float -> Float -> Float+limit !lim !n+  | abs n > lim = normalize n * lim+  | otherwise = n++normalize :: Float -> Float+normalize !n+  | n == 0 = 0+  | n > 0 = n / n+  | otherwise = (-1) * (n / n)++update :: FPoint -> Movement -> (Movement, IPoint)+update !dir !mv =+  let+    spd = (mv ^. speed) `addPoint` (mv ^. posFloatPart)+    addition = fmap (\s -> if s < 0 then ceiling s else floor s) spd+    pfp = spd `addPoint` fmap (fromIntegral . negate) addition+  in+    force (set posFloatPart pfp $ updateMovement dir mv, addition)+++straight :: FPoint -> Movement+straight spd = make $ defArgs+  { startspeed = spd+  , maxspeed = spd+  , accel = Point 1 1 `mulPoint` fmap abs spd+  }++fastGradualStart :: FPoint -> Movement+fastGradualStart spd = make $ defArgs+  { startspeed = spd+  , maxspeed = fmap (*4) spd+  , accel = Point 0.11 0.11 `mulPoint` fmap abs spd+  }++gradualSlowdown :: FPoint -> Movement+gradualSlowdown spd = make $ defArgs+  { startspeed = spd+  , minspeed = fmap (/4) spd+  , maxspeed = spd+  , accel = Point (-0.02) (-0.02) `mulPoint` fmap abs spd+  }
+ src/Play/Engine/MySDL/MySDL.hs view
@@ -0,0 +1,288 @@+-- MySDL: some wrappers and utility functions around SDL++{-# LANGUAGE LambdaCase, TypeFamilies #-}++module Play.Engine.MySDL.MySDL where++import Data.Word (Word8, Word32)+import Data.Text (Text)+import Control.Exception (catch, SomeException(..))+import Control.Monad.Identity+import Control.Monad.IO.Class (MonadIO, liftIO)+import System.IO+import Control.Concurrent (threadDelay)+import Control.Concurrent.STM.TQueue+import Control.Concurrent.STM+import Control.Concurrent.Async+import qualified Data.ByteString as BS+import qualified Data.Vector as V++import qualified Foreign.C.Types as C+import qualified Data.Map as M+import qualified Data.Text as T++import qualified SDL+import qualified SDL.Image as SDLI+import qualified SDL.Font as SDLF+import qualified SDL.Mixer as Mix+import SDL.Vect (V2(..), V4(..))++--import Debug.Trace++-- | Config window+myWindowConfig :: V2 C.CInt -> SDL.WindowConfig+myWindowConfig size = SDL.defaultWindow { SDL.windowInitialSize = size }++-- | Init SDL and create a Window and pass in as a parameter to function+withWindow :: Text -> SDL.WindowConfig -> (SDL.Window -> IO a) -> IO a+withWindow title winConf go = do+  SDL.initializeAll+  SDLI.initialize [minBound..maxBound]+  SDLF.initialize++  window <- SDL.createWindow title winConf+  SDL.showWindow window++  mJoystick <- getJoystick++  result <- Mix.withAudio Mix.defaultAudio 256 $ do++    go window++  sequence_ $ SDL.closeJoystick <$> mJoystick+  SDL.destroyWindow window+  SDLI.quit+  SDLF.quit+  SDL.quit++  pure result++withRenderer :: MonadIO m => SDL.Window -> ((SDL.Window, SDL.Renderer) -> m a) -> m a+withRenderer window go = do+  renderer <- SDL.createRenderer window (-1)+    $ SDL.RendererConfig+      { rendererType          = SDL.AcceleratedRenderer+      , rendererTargetTexture = False+      }+  go (window, renderer)+++-- | App loop: takes the current world and functions that updates the world renders it+-- manage ticks, events and loop+apploop+  :: ResourcesT TVar+  -> TQueue Response+  -> SDL.Renderer+  -> a+  -> ([Response] -> [SDL.EventPayload] -> (SDL.Scancode -> Bool) -> a -> IO (Either [String] ([Request], a)))+  -> (a -> IO ())+  -> IO a+apploop resources responsesQueue renderer world update render = do+  -- measure ticks at the start+  start <- SDL.ticks++  events <- collectEvents+  --unless (null events) $ print events+  keyState <- SDL.getKeyboardState+  responses <- fmap (maybe [] (:[])) $ atomically $ tryReadTQueue responsesQueue+  update responses events keyState world >>= \case+    Left errs ->+      liftIO $ mapM (hPutStrLn stderr . ("*** Error: " ++)) errs >> pure world+    Right (reqs, newWorld) -> do+      render newWorld+      void $ async $ mapConcurrently_ (runRequest resources responsesQueue renderer) reqs+      if checkEvent SDL.QuitEvent events+      then pure world+      else do+        when (isWindowHidden events) $ do+          isPlaying <- Mix.playingMusic+          when isPlaying Mix.pauseMusic+          let+            loop evs+              | isWindowExposed evs = when isPlaying Mix.resumeMusic+              | otherwise = loop =<< collectEvents+          loop events++        -- measure ticks at the end and regulate FPS+        end <- SDL.ticks+        regulateFPS 60 start end+        apploop resources responsesQueue renderer newWorld update render++-- | Will wait until ticks pass+regulateFPS :: Word32 -> Word32 -> Word32 -> IO ()+regulateFPS fps start end+  | fps == 0 = pure ()+  | otherwise = do+    let+      ticksPerFrame = 1000 `div` fps+      interval = end - start+      gap = ticksPerFrame - interval+      delayFor+        | gap < ticksPerFrame =+          fromIntegral $ max 0 gap+        | otherwise =+          fromIntegral ticksPerFrame+    threadDelay $ delayFor * 1000 -- threadDelay works in microseconds+++getJoystick :: IO (Maybe SDL.Joystick)+getJoystick = do+  joysticks <- SDL.availableJoysticks+  let+    joystick =+      if V.length joysticks == 0+        then Nothing+        else pure (joysticks V.! 0)++  sequence $ SDL.openJoystick <$> joystick++++setBGColor :: MonadIO m => V4 Word8 -> SDL.Renderer -> m SDL.Renderer+setBGColor color renderer = do+  SDL.rendererDrawColor renderer SDL.$= color+  SDL.clear renderer+  pure renderer++-- | Collect all events from inputs+collectEvents :: MonadIO m => m [SDL.EventPayload]+collectEvents = SDL.pollEvent >>= \case+    Nothing -> pure []+    Just e  -> (SDL.eventPayload e :) <$> collectEvents++-- | Checks if specific event happend+checkEvent :: SDL.EventPayload -> [SDL.EventPayload] -> Bool+checkEvent = elem++isWindowHidden :: [SDL.EventPayload] -> Bool+isWindowHidden = any $ \case+  SDL.WindowHiddenEvent{} -> True+  _ -> False++isWindowExposed :: [SDL.EventPayload] -> Bool+isWindowExposed = any $ \case+  SDL.WindowExposedEvent{} -> True+  _ -> False+++data Resource+  = RTexture SDL.Texture+  | RFont SDLF.Font+  | RMusic BS.ByteString++data ResourceType a+  = Texture a+  | Font a+  | Music a++data Request+  = Load ![(String, ResourceType FilePath)]+  | DestroyTexture SDL.Texture+  | MakeText (String, FilePath) T.Text+  | PlayMusic (String, FilePath)+  | MuteMusic+  | UnmuteMusic++data Response+  = ResourcesLoaded Resources+  | NewText SDL.Texture+  | Exception String++data ResourcesT f+  = Resources+  { textures :: HKD f (M.Map FilePath SDL.Texture)+  , fonts :: HKD f (M.Map FilePath SDLF.Font)+  , music :: HKD f (M.Map FilePath BS.ByteString)+  }++type family HKD f a where+  HKD Identity a = a+  HKD f        a = f a++type Resources = ResourcesT Identity++initResources :: IO (ResourcesT TVar)+initResources =+  Resources+    <$> newTVarIO M.empty+    <*> newTVarIO M.empty+    <*> newTVarIO M.empty++runRequest :: ResourcesT TVar -> TQueue Response -> SDL.Renderer -> Request -> IO ()+runRequest resources queue renderer req =+  flip catch (\(SomeException e) -> atomically $ writeTQueue queue $ Exception $ show e) $+    case req of+      Load files -> do+        results <-+          mapConcurrently+            (loadResource renderer resources)+            files+        atomically $ writeTQueue queue (resourcesToResponse results)+      DestroyTexture txt ->+        SDL.destroyTexture txt+      MakeText (n, p) txt -> do+        (_, RFont fnt) <- loadResource renderer resources (n, Font p)+        text <- SDL.createTextureFromSurface renderer =<< SDLF.solid fnt (V4 255 255 255 255) txt+        atomically $ writeTQueue queue $ NewText text+      PlayMusic (n, p) -> do+        (_, RMusic msc) <- loadResource renderer resources (n, Music p)+        Mix.playMusic Mix.Forever =<< Mix.decode msc+      MuteMusic -> do+        Mix.setMusicVolume 0+      UnmuteMusic -> do+        Mix.setMusicVolume 100+++loadResource renderer resources (n, r) =+  case r of+    Texture (("assets/imgs/" ++) -> f) -> do+      mTxt <- atomically $ do+        txts <- readTVar (textures resources)+        pure $ M.lookup f txts+      (n,) . RTexture <$> case mTxt of+        Just txt ->+          pure txt+        Nothing -> do+          txt <- SDLI.loadTexture renderer f+          atomically $ do+            txts' <- readTVar (textures resources)+            writeTVar (textures resources) (M.insert f txt txts')+          pure txt++    Font (("assets/fonts/" ++) -> f) -> do+      mFont <- atomically $ do+        fnts <- readTVar (fonts resources)+        pure $ M.lookup f fnts+      (n,) . RFont <$> case mFont of+        Just fnt ->+          pure fnt+        Nothing -> do+          fnt <- SDLF.load f 18+          atomically $ do+            fnts' <- readTVar (fonts resources)+            writeTVar (fonts resources) (M.insert f fnt fnts')+          pure fnt++    Music (("assets/audio/" ++) -> f) -> do+      mMusic <- atomically $ do+        msc <- readTVar (music resources)+        pure $ M.lookup f msc+      (n,) . RMusic <$> case mMusic of+        Just msc ->+          pure msc+        Nothing -> do+          contents <- BS.readFile f+          atomically $ do+            msc' <- readTVar (music resources)+            writeTVar (music resources) (M.insert f contents msc')+          pure contents++resourcesToResponse :: [(String, Resource)] -> Response+resourcesToResponse rs =+  ResourcesLoaded . foldr (flip g) initS $ rs+  where+    initS = Resources M.empty M.empty M.empty+    g s = \case+      (n, RTexture t) -> s { textures = M.insert n t (textures s) }+      (n, RFont f) -> s { fonts = M.insert n f (fonts s) }+      (n, RMusic m) -> s { music = M.insert n m (music s) }
+ src/Play/Engine/Runner.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Play.Engine.Runner where++import qualified Data.Map as M+import Control.Monad.IO.Class (MonadIO)+import Control.Monad+import qualified SDL+import SDL.Vect (V2(..), V4(..))+import Control.Lens hiding (sets)+import Control.DeepSeq+import Control.Concurrent.STM.TQueue++import qualified Play.Engine.MySDL.MySDL as MySDL+import Play.Engine.Input+import Play.Engine.Types+import Play.Engine.Utils+import Play.Engine.Settings+import Play.Engine.Scene++-----------+-- Logic --+-----------++runGame :: Settings -> Stack Scene -> IO ()+runGame sets w = do+  putStrLn "Hello Game!"+  _ <- run sets w+  putStrLn "Goodbye."++run :: Settings -> Stack Scene -> IO ()+run settings stack = do+  responsesQueue <- newTQueueIO+  resources <- MySDL.initResources+  void $ MySDL.withWindow "Game" (MySDL.myWindowConfig (V2 (winSize x) (winSize y))) $+    flip MySDL.withRenderer+      (\(window, ren) ->+          MySDL.apploop+            resources+            responsesQueue+            ren+            (settings, stack)+            update+            (render (window, ren) . snd)+      )+  where+    winSize l = fromIntegral $ settings ^. windowSize . l++update+  :: [MySDL.Response]+  -> [SDL.EventPayload]+  -> (SDL.Scancode -> Bool)+  -> (Settings, Stack Scene)+  -> IO (Either [String] ([MySDL.Request], (Settings, Stack Scene)))+update responses payload isKeyPressed (settings, stack) =+  let+    (keys, joykeys) = makeEvents (_keyStats settings) (_joyKeyStats settings) payload isKeyPressed (_keyMap settings)++    toggleMuteFlag+      | keyClicked' KeyM keys = not+      | otherwise = id++    settings' = settings+      & over muteMusic toggleMuteFlag+      & set keyStats keys+      & set joyKeyStats joykeys++    toggleMuteCmd+      | settings' ^. muteMusic = (:) MySDL.MuteMusic+      | not (settings' ^. muteMusic) = (:) MySDL.UnmuteMusic+      | otherwise = id++  in pure+    . fmap (\(setts, (reqs, states)) -> (toggleMuteCmd reqs, (setts, states)))+    . (joykeys `deepseq` keys `deepseq` runResult $! settings')+    $ updateScenes (Input (M.unionWith max keys joykeys) responses) stack+++render :: (SDL.Window, SDL.Renderer) -> Stack Scene -> IO ()+render (_, renderer) stack = do+  SDL.rendererDrawBlendMode renderer SDL.$= SDL.BlendAlphaBlend+  renderTopScene renderer stack+  SDL.present renderer++setBGColorBlack :: MonadIO m => (SDL.Window, SDL.Renderer) -> m (SDL.Window, SDL.Renderer)+setBGColorBlack sdlStuff@(_, renderer) = do+  void $ MySDL.setBGColor (V4 0 0 0 255) renderer+  pure sdlStuff+
+ src/Play/Engine/Scene.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE ExistentialQuantification #-}++module Play.Engine.Scene where++import Prelude hiding (head)+import qualified Play.Engine.MySDL.MySDL as MySDL+import SDL+import Play.Engine.Utils+import Play.Engine.Input+import Play.Engine.Settings+import Control.Monad.Except+++-----------+-- Scene --+-----------++-- | Scene describes a generic interface for a game Scene+--   * state: for the scene data+--   * update: how to update the scene+--   * render: how to render the scene+data SceneF a+  = SceneF+  { scState :: a+  , scUpdate+      :: Input+      -> a+      -- it might fail with a reason+      -> Result ([MySDL.Request], (StackCommand, a))+  , scRender :: SDL.Renderer -> a -> IO ()+  }++-- | Existentially Quantified Scene+data Scene+  = forall s. Scene (SceneF s)++-- | Create a Scene from the interface+mkScene+  :: a+  -> (Input -> a -> Result (StackCommand, a))+  -> (SDL.Renderer -> a -> IO ())+  -> Scene+mkScene s u r = Scene (SceneF s (\i a -> fmap pure $ u i a) r)++{-+-- a sample definition of a state. Does nothing.+sample :: Scene+sample = mkScene+  ()+  (\_ () -> pure (None, ()))+  (const pure)+-}++-----------------+-- State stack --+-----------------++-- | A command for the scene stack, to be returned by `update`+data StackCommand+  = Done -- ^ You can remove me from the stack+  | None -- ^ Keep me at the top of the stack+  | Push Scene -- ^ Push a new scene+  | Replace Scene -- ^ Replace me with a new scene++-- | Update the top state on the stack+updateScenes :: Input -> Stack Scene -> Result ([MySDL.Request], Stack Scene)+updateScenes input scenes = do+  (reqs, (cmd, newState)) <- updateScene input (head scenes)+  (reqs,) <$> case cmd of+    Done -> case pop scenes of+      (_, Nothing) -> throwError ["Unexpected empty stack of states"]+      (_, Just rest) -> pure rest+    None -> pure $ replace newState scenes+    Replace otherState -> pure $ replace otherState scenes+    Push otherState -> pure $ push otherState (replace newState scenes)++-- | Update an existentially quantified Scene+updateScene :: Input -> Scene -> Result ([MySDL.Request], (StackCommand, Scene))+updateScene input = \case+  Scene s ->+    flip fmap ((scUpdate s) input (scState s)) $ \case+      (reqs, (cmd, newState)) -> (reqs, (cmd, Scene $ s { scState = newState }))++-- | Render the top scene on the stack+renderTopScene :: SDL.Renderer -> Stack Scene -> IO ()+renderTopScene sdlRenderer states = case head states of+  Scene s ->+    (scRender s) sdlRenderer (scState s)
+ src/Play/Engine/ScrollingBackground.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}++module Play.Engine.ScrollingBackground where++import qualified SDL++import Play.Engine.Types+import Play.Engine.Utils+import Control.Lens++data SBG+  = SBG+  { _sbg1 :: BG+  , _sbg2 :: BG+  , _size :: !Size+  , _speed :: !Int+  , _texture :: SDL.Texture+  }++data BG+  = BG+  { _pos :: !IPoint+  }++makeFieldsNoPrefix ''BG+makeFieldsNoPrefix ''SBG++mkSBG :: SDL.Texture -> Int -> Size -> IPoint -> SBG+mkSBG txt spd sz position =+  let+    bg = BG+      { _pos = position+      }+  in+    SBG+    { _sbg1 = over (pos . y) (flip (-) (sz ^. y)) bg+    , _sbg2 = bg+    , _size = sz+    , _speed = negate spd+    , _texture = txt+    }++updateSBG :: SBG -> SBG+updateSBG sbg =+  let+    sbg' =+      if (sbg ^. sbg2 . pos . y) > (sbg ^. size . y)+        then+          sbg+            & over (sbg1 . pos . y) (flip (-) (sbg ^. size . y))+            & set sbg2 (sbg ^. sbg1) +        else+          sbg+  in+    sbg'+      & over (sbg1 . pos . y) (flip (-) (sbg' ^. speed))+      & over (sbg2 . pos . y) (flip (-) (sbg' ^. speed))++render :: SDL.Renderer -> Camera -> SBG -> IO ()+render renderer cam sbg = do+  SDL.copy renderer (sbg ^. texture) Nothing (Just $ toRect (cam $ sbg ^. sbg1 . pos) (sbg ^. size))+  SDL.copy renderer (sbg ^. texture) Nothing (Just $ toRect (cam $ sbg ^. sbg2 . pos) (sbg ^. size))
+ src/Play/Engine/Settings.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TemplateHaskell #-}++module Play.Engine.Settings where++import qualified SDL+import qualified Control.Monad.State as SM+import Control.Monad.Except++import Data.Tuple+import Play.Engine.Types+import Play.Engine.Input+import Control.Lens++data Settings+  = Settings+  { _windowSize :: !Size+  , _keyMap :: ![(Key, SDL.Scancode)]+  , _keyStats :: !Keys+  , _joyKeyStats :: !Keys+  , _muteMusic :: !Bool+  }+  deriving (Show)++makeLenses ''Settings++type Result a = SM.StateT Settings (Except [String]) a++runResult settings m = fmap swap $ runExcept $ SM.runStateT m settings++def :: Settings+def = Settings+  { _windowSize = Point 800 600+  , _keyMap = defKeyMap+  , _keyStats = initKeyStats+  , _joyKeyStats = initKeyStats+  , _muteMusic = False+  }
+ src/Play/Engine/Sprite.hs view
@@ -0,0 +1,99 @@++{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Play.Engine.Sprite where++import qualified SDL++import Data.Word (Word8)+import Play.Engine.Utils+import Play.Engine.Types+import Control.Lens+import GHC.Generics+import Data.Typeable++import SDL.Vect (V2(..))+import qualified SDL.Vect as Vect (Point(..))+import qualified Data.Map as M+import qualified Data.Text as T++data Sprite+  = Sprite+  { _actionmap :: M.Map T.Text Int+  , _action :: Int+  , _texture :: SDL.Texture+  , _size :: !Size+  , _initSpeed :: !Int+  , _speed :: !Int+  , _pos :: !Int+  , _maxPos :: !Int+  }+  deriving (Eq, Generic, Typeable)++makeFieldsNoPrefix ''Sprite+++data MakeArgs+  = MakeArgs+  { mkActionmap :: [T.Text]+  , mkAction :: !T.Text+  , mkSpeed :: !Int+  , mkTexture :: !SDL.Texture+  , mkSize :: !Size+  , mkMaxPos :: !Int+  }++simpleArgs :: Size -> SDL.Texture -> MakeArgs+simpleArgs sz t = MakeArgs+  { mkActionmap = ["normal"]+  , mkAction = "normal"+  , mkSpeed = 0+  , mkTexture = t+  , mkSize = sz+  , mkMaxPos = 1+  }++make :: MakeArgs -> Maybe Sprite+make MakeArgs{..} = do+  let actionMap = M.fromList $ zip mkActionmap [0..]+  act <- M.lookup mkAction actionMap+  pure $ Sprite+    { _actionmap = actionMap+    , _action = act+    , _texture = mkTexture+    , _initSpeed = mkSpeed+    , _speed = mkSpeed+    , _size = mkSize+    , _pos = 0+    , _maxPos = mkMaxPos+    }+++update :: Maybe T.Text -> Bool -> Sprite -> Sprite+update !act !restart !sprite =+  sprite+    & over speed (\s -> if s < 0 || restart then sprite ^. initSpeed else s - 1)+    & over action (\a -> maybe a id $ flip M.lookup (sprite ^. actionmap) =<< act)+    & over pos (\p -> if restart then 0 else if sprite ^. speed == 0 then (p + 1) `mod` (sprite ^. maxPos) else p)++render :: SDL.Renderer -> Camera -> IPoint -> Size -> Word8 -> Sprite -> IO ()+render renderer cam position sz transp sprite = do+  let+    rect = toRect (cam $ position) sz+    ssz =  (sprite ^. size . x, sprite ^. size . y)+    clip = SDL.Rectangle+      (Vect.P $ V2 (fst ssz * sprite ^. pos) (snd ssz * sprite ^. action))+      (uncurry V2 ssz)+  SDL.textureBlendMode (sprite ^. texture) SDL.$= SDL.BlendAlphaBlend+  SDL.textureAlphaMod  (sprite ^. texture) SDL.$= transp+  SDL.copy renderer (sprite ^. texture) (Just $ fmap fromIntegral clip) (Just rect)+  SDL.textureAlphaMod  (sprite ^. texture) SDL.$= 255
+ src/Play/Engine/Types.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE PatternSynonyms #-}++module Play.Engine.Types where++import qualified SDL.Vect as Vect++import Control.Lens++-----------+-- Types --+-----------++type Point a = Vect.V2 a+type IPoint = Vect.V2 Int+type FPoint = Vect.V2 Float+type Size = Vect.V2 Int++x :: Lens' (Vect.V2 a) a+x = lens (\(Vect.V2 a _) -> a) (\(Vect.V2 _ b) a -> (Vect.V2 a b))++y :: Lens' (Vect.V2 a) a+y = lens (\(Vect.V2 _ b) -> b) (\(Vect.V2 a _) b -> (Vect.V2 a b))++pattern Point :: a -> a -> Vect.V2 a+pattern Point x' y' = Vect.V2 x' y'++pointToTuple :: Point a -> (a, a)+pointToTuple (Point !x' !y') = (x', y')++sizeToTuple :: Size -> (Int, Int)+sizeToTuple (Vect.V2 !w !h) = (w, h)
+ src/Play/Engine/Utils.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- a utility module+module Play.Engine.Utils where++import Data.Word (Word8)+import SDL.Vect (V4(..), V2(..))+import qualified SDL.Vect as Vect (Point(..))+import qualified SDL+import qualified SDL.Font as SDLF+import qualified Data.Text as T+import qualified Foreign.C.Types as C (CInt)+import Control.Lens+import Control.DeepSeq++import Prelude hiding (head)+import qualified Data.List as List+import Control.Lens (over, (^.))+import Data.List (group, sort)+import qualified Data.DList as DL++import Play.Engine.Types++--import Debug.Trace++firstM :: Functor f => (a -> f c) -> (a, b) -> f (c, b)+firstM f (a, b) = (, b) <$> f a++-- |+-- replicate operation and chain it+replicateMChain :: Monad m => Int -> (a -> m a) -> a -> m a+replicateMChain n f x'+  | n <= 0 = return x'+  | otherwise = f x' >>= replicateMChain (n-1) f++-- |+-- if Maybe b is nothing, replace it with Left a. otherwise: Right b+maybeToEither :: a -> Maybe b -> Either a b+maybeToEither _ (Just y') = Right y'+maybeToEither x' Nothing  = Left x'+++-- |+-- returns the duplicates of a list+duplicates :: Ord a => [a] -> [a]+duplicates = map List.head . filter ((>1) . length) . group . sort++-- |+-- split arguments by element+splitBy :: Eq a => a -> [a] -> [[a]]+splitBy v vs = map reverse $ go [] vs+  where go ws [] = [ws]+        go ws (z:zs)+          | z == v    = ws : go [] zs+          | otherwise = go (z:ws) zs++supplyBoth :: (a -> b -> c) -> (b -> a) -> b -> c+supplyBoth = (=<<)++-- | Compose with an input function that takes two arguments+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(.:) f g a b = f (g a b)++absPoint :: IPoint -> IPoint+absPoint = fmap abs++addPoint :: (NFData a, Num a) => Point a -> Point a -> Point a+addPoint (Point x1 y1) (Point x2 y2) = force $ Point (x1 + x2) (y1 + y2)+{-# INLINE addPoint #-}++mulPoint :: (NFData a, Num a) => Point a -> Point a -> Point a+mulPoint (Point x1 y1) (Point x2 y2) = force $ Point (x1 * x2) (y1 * y2)+{-# INLINE mulPoint #-}++updateList :: (a -> [a]) -> DL.DList a -> DL.DList a+updateList f = DL.foldr (\a acc -> DL.fromList (f a) `DL.append` acc) DL.empty++updateListWith :: NFData b => b -> (b -> b -> b) -> (a -> ([a], b)) -> DL.DList a -> (DL.DList a, b)+updateListWith start combine f = flip DL.foldr (DL.empty, start) $ \a !acc ->+  case (f a, acc) of+    (([], b), (aacc, bacc)) -> (aacc, force $ combine bacc b)+    ((xs, b), (aacc, bacc)) -> (DL.fromList xs `DL.append` aacc, force $ combine bacc b)+++toRect :: IPoint -> Size -> SDL.Rectangle C.CInt+toRect posi sz =+  SDL.Rectangle+    (Vect.P . uncurry V2 . over both fromIntegral . pointToTuple $ posi)+    (uncurry V2 . over both fromIntegral . sizeToTuple $ sz)++data HasPosSize+  = HasPosSize+  { _pos :: !IPoint+  , _size :: !Size+  }+  deriving Show++makeFieldsNoPrefix ''HasPosSize++data Hitbox+  = Hitbox+  { _alignment :: {-# UNPACK #-} !IPoint+  , _size :: {-# UNPACK #-} !Size+  }+  deriving (Eq, Show)++makeFieldsNoPrefix ''Hitbox++data HasHitBox+  = HasHitBox+  { _hitbox :: !Hitbox+  }+  deriving Show++makeFieldsNoPrefix ''HasHitBox++circ' = HasPosSize+  { _pos = Point 356 795+  , _size = Point 12 12+  }+rec' = HasHitBox+  { _hitbox = Hitbox+    { _alignment = Point 346 830+    , _size = Point 21 64+    }+  }++-- https://stackoverflow.com/questions/21089959/detecting-collision-of-rectangle-with-circle+isTouchingCircleRect+  :: (HasPos circle IPoint, HasSize circle Size, HasPos rect IPoint, HasHitbox rect Hitbox)+  => circle -> rect -> Maybe (circle, rect)+isTouchingCircleRect circle rect =+  let+    circleDistance =+      Point+        ( abs+          $ circle ^. pos . x+          - (rect ^. pos . x + rect ^. hitbox . alignment . x)+          - (rect ^. hitbox . size . x) `div` 2+        )+        ( abs+          $ circle ^. pos . y+          - (rect ^. pos . y + rect ^. hitbox . alignment . y)+          - (rect ^. hitbox . size . y) `div` 2+        )++    cornerDistance_sq =+      (+)+        ((circleDistance ^. x - rect ^. hitbox . size . x `div` 2) ^ 2)+        ((circleDistance ^. y - rect ^. hitbox . size . y `div` 2) ^ 2)++  in if+    | circleDistance ^. x >  (rect ^. hitbox . size . x `div` 2) + (circle ^. size . x `div` 2) -> Nothing+    | circleDistance ^. y >  (rect ^. hitbox . size . y `div` 2) + (circle ^. size . y `div` 2) -> Nothing+    | circleDistance ^. x <= (rect ^. hitbox . size . x `div` 2) -> Just (circle, rect)+    | circleDistance ^. y <= (rect ^. hitbox . size . y `div` 2) -> Just (circle, rect)+    | cornerDistance_sq <= (circle ^. size . x `div` 2) ^ 2 -> Just (circle, rect)+    | otherwise -> Nothing++isTouchingCircleCircle+  :: (HasSize a Size, HasPos a IPoint, HasSize b Size, HasPos b IPoint)+  => a -> b -> Maybe (a,b)+isTouchingCircleCircle a b =+  let+    getCenter p = (p ^. pos) `addPoint` Point ((p ^. size . x) `div` 2) ((p ^. size . y) `div` 2)+    aCenter = getCenter a+    bCenter = getCenter b+    aRadius = (a ^. size . x) `div` 2 - (a ^. size . x) `div` 8+    bRadius = (b ^. size . x) `div` 2 - (b ^. size . x) `div` 8+    distX = (aCenter ^. x) - (bCenter ^. x)+    distY = (aCenter ^. y) - (bCenter ^. y)+    dist = sqrt $ fromIntegral ((distX * distX) + (distY * distY))+  in+    if dist < fromIntegral (aRadius + bRadius)+      then Just (a, b)+      else Nothing++fixPos :: (HasSize a Size, HasPos a IPoint) => Size -> a -> a+fixPos wsize entity =+  let+    x_ = entity ^. pos . x+    y_ = entity ^. pos . y+    x' =+      if x_ <= 0+        then 0+        else if x_ + (entity ^. size . x) <= (wsize ^. x)+          then x_+          else (wsize ^. x) - (entity ^. size . x)+    y' =+      if y_ <= 0+        then 0+        else if y_ + (entity ^. size . y) <= (wsize ^. y)+          then y_+          else (wsize ^. y) - (entity ^. size . y)+  in+    set pos (Point x' y') entity++isInWindow :: Size -> IPoint -> Size -> Bool+isInWindow = isInSquare (Point 0 0)++isInSquare :: IPoint -> Size -> IPoint -> Size -> Bool+isInSquare wpos wsize posi sz+  |  posi ^. x + sz ^. x < (wpos ^. x) || posi ^. x > wpos ^.x + wsize ^. x+  || posi ^. y + sz ^. y < (wpos ^. y) || posi ^. y > wpos ^.y + wsize ^. y+  = False++  | otherwise = True++isAround :: IPoint -> IPoint -> Size -> Bool+isAround place posi sz =+  isInSquare (place `addPoint` Point (-5) (-5)) sz posi sz++dirToPlace :: IPoint -> IPoint -> IPoint+dirToPlace posi place =+  Point (dir x) (negate $ dir y)+  where+    dir c+      | place ^. c > posi ^. c = 1+      | place ^. c < posi ^. c = -1+      | otherwise = 0++type Camera = IPoint -> IPoint++mkAngles :: Int -> Int -> [Float]+mkAngles initAngle ((`mod` 200) -> n) =+  let+    m = 360 / fromIntegral n+  in+    force $ map ((+) (fromIntegral initAngle) . (*) m . fromIntegral) [0..(n-1)]+++renderText :: SDL.Renderer -> SDLF.Font -> IPoint -> T.Text -> IO ()+renderText renderer font loc txt =+  if T.null txt+    then pure ()+    else do+      texture' <- SDL.createTextureFromSurface renderer+        =<< SDLF.solid+          font+          (V4 255 255 255 255)+          txt+      ti <- SDL.queryTexture texture'+      SDL.copy+        renderer+        texture'+        Nothing+        (Just $ toRect+          loc+          (Point (fromIntegral $ SDL.textureWidth ti) (fromIntegral $ SDL.textureHeight ti))+        )+      SDL.destroyTexture texture'++shade :: SDL.Renderer -> Camera -> Word8 -> IO ()+shade renderer cam n = do+  let+    rect = toRect (cam $ Point 0 0) (Point 800 1000)+  SDL.rendererDrawColor renderer SDL.$= V4 0 0 0 n+  SDL.fillRect renderer (Just rect)+++-----------+-- Stack --+-----------++data Stack a = Stack !a ![a]++head :: Stack a -> a+head = fst . pop++push :: a -> Stack a -> Stack a+push !new (Stack !a as) = Stack new (a:as)++init :: a -> Stack a+init = flip Stack []++pop :: Stack a -> (a, Maybe (Stack a))+pop = \case+  Stack !a [] -> (a, Nothing)+  Stack !a (!b:bs) -> (a `seq` a, pure $! Stack b bs)++replace :: a -> Stack a -> Stack a+replace a = \case+  Stack _ as -> Stack (a `seq` a) as