diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` + diff --git a/app/Attack.hs b/app/Attack.hs new file mode 100644 --- /dev/null +++ b/app/Attack.hs @@ -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 + diff --git a/app/Attack/SpiralAttack.hs b/app/Attack/SpiralAttack.hs new file mode 100644 --- /dev/null +++ b/app/Attack/SpiralAttack.hs @@ -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) + diff --git a/app/Bullet.hs b/app/Bullet.hs new file mode 100644 --- /dev/null +++ b/app/Bullet.hs @@ -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)) diff --git a/app/Credits.hs b/app/Credits.hs new file mode 100644 --- /dev/null +++ b/app/Credits.hs @@ -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 diff --git a/app/DecObj/Particle.hs b/app/DecObj/Particle.hs new file mode 100644 --- /dev/null +++ b/app/DecObj/Particle.hs @@ -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 diff --git a/app/DecObj/SplitTexture.hs b/app/DecObj/SplitTexture.hs new file mode 100644 --- /dev/null +++ b/app/DecObj/SplitTexture.hs @@ -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 + } diff --git a/app/DecorationObject.hs b/app/DecorationObject.hs new file mode 100644 --- /dev/null +++ b/app/DecorationObject.hs @@ -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' + diff --git a/app/Enemy.hs b/app/Enemy.hs new file mode 100644 --- /dev/null +++ b/app/Enemy.hs @@ -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 diff --git a/app/Enemy/CrossDown.hs b/app/Enemy/CrossDown.hs new file mode 100644 --- /dev/null +++ b/app/Enemy/CrossDown.hs @@ -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 + diff --git a/app/Enemy/Fast.hs b/app/Enemy/Fast.hs new file mode 100644 --- /dev/null +++ b/app/Enemy/Fast.hs @@ -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 + ) diff --git a/app/Enemy/SideToSideSpiral.hs b/app/Enemy/SideToSideSpiral.hs new file mode 100644 --- /dev/null +++ b/app/Enemy/SideToSideSpiral.hs @@ -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 + diff --git a/app/Enemy/Static.hs b/app/Enemy/Static.hs new file mode 100644 --- /dev/null +++ b/app/Enemy/Static.hs @@ -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 + diff --git a/app/GameState.hs b/app/GameState.hs new file mode 100644 --- /dev/null +++ b/app/GameState.hs @@ -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 []) + diff --git a/app/KeyScreen.hs b/app/KeyScreen.hs new file mode 100644 --- /dev/null +++ b/app/KeyScreen.hs @@ -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) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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) diff --git a/app/PickStage.hs b/app/PickStage.hs new file mode 100644 --- /dev/null +++ b/app/PickStage.hs @@ -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) diff --git a/app/Script.hs b/app/Script.hs new file mode 100644 --- /dev/null +++ b/app/Script.hs @@ -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 diff --git a/app/Script/Boss.hs b/app/Script/Boss.hs new file mode 100644 --- /dev/null +++ b/app/Script/Boss.hs @@ -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 + + ] + diff --git a/app/Script/End.hs b/app/Script/End.hs new file mode 100644 --- /dev/null +++ b/app/Script/End.hs @@ -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 + ] diff --git a/app/Script/Introduction.hs b/app/Script/Introduction.hs new file mode 100644 --- /dev/null +++ b/app/Script/Introduction.hs @@ -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) diff --git a/app/Script/Level1.hs b/app/Script/Level1.hs new file mode 100644 --- /dev/null +++ b/app/Script/Level1.hs @@ -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 + ] diff --git a/app/Script/Level2.hs b/app/Script/Level2.hs new file mode 100644 --- /dev/null +++ b/app/Script/Level2.hs @@ -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 + ] diff --git a/app/ShootingBox.hs b/app/ShootingBox.hs new file mode 100644 --- /dev/null +++ b/app/ShootingBox.hs @@ -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 diff --git a/app/StartScreen.hs b/app/StartScreen.hs new file mode 100644 --- /dev/null +++ b/app/StartScreen.hs @@ -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) + diff --git a/app/TextBox.hs b/app/TextBox.hs new file mode 100644 --- /dev/null +++ b/app/TextBox.hs @@ -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 diff --git a/app/VN.hs b/app/VN.hs new file mode 100644 --- /dev/null +++ b/app/VN.hs @@ -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 diff --git a/assets/audio/battle.ogg b/assets/audio/battle.ogg new file mode 100644 Binary files /dev/null and b/assets/audio/battle.ogg differ diff --git a/assets/audio/end.ogg b/assets/audio/end.ogg new file mode 100644 Binary files /dev/null and b/assets/audio/end.ogg differ diff --git a/assets/audio/store.ogg b/assets/audio/store.ogg new file mode 100644 Binary files /dev/null and b/assets/audio/store.ogg differ diff --git a/assets/fonts/unispace/read_me.html b/assets/fonts/unispace/read_me.html new file mode 100644 --- /dev/null +++ b/assets/fonts/unispace/read_me.html @@ -0,0 +1,143 @@ + + + + + LARABIE FONTS “README + + + + + + + + +

LARABIE +FONTS FREEWARE FONTS EULA (End User License Agreement) and SOFTWARE +INCLUSION AGREEMENT

+

LARABIE +FONTS FREEWARE FONTS EULA

+


+

+

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. +

+


+

+

USAGE

+

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. +

+


+

+

Some +Larabie Fonts Freeware Fonts may have enhanced and/or expanded +families available for sale at www.typodermic.com.

+


+

+

PAYMENT

+

Payment +is not required for the use of Larabie Fonts Freeware Fonts unless +they are intended to be included with software. More details +follow.

+

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 www.larabiefonts.com/donation.html +for instructions. +

+

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.

+


+

+

SUPPORT

+

Font +installation help is available at www.myfonts.com/support. +If you experience problems with any Larabie Font, please visit +www.larabiefonts.com +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. + +

+


+

+

SOFTWARE +INCLUSION AGREEMENT +

+


+

+

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.

+


+

+

1. +GRANT OF LICENSE. This document grants you the following rights:

+

- +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.

+


+

+

2. +LIMITED WARRANTY NO WARRANTIES. Larabie Fonts expressly disclaims any +warranty for the SOFTWARE PRODUCT. The SOFTWARE PRODUCT and any +related documentation is provided "as is" 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.

+

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.

+


+

+

3. +MISCELLANEOUS

+

Should +you have any questions concerning this document or you desire to +contact Larabie Fonts for any reason, please email +www.larabiefonts.com/email.html.

+


+

+

4. +GOVERNING LAW

+

This +agreement is governed by the laws of Canada and the province of +British Columbia.

+ + diff --git a/assets/fonts/unispace/unispace bold italic.ttf b/assets/fonts/unispace/unispace bold italic.ttf new file mode 100644 Binary files /dev/null and b/assets/fonts/unispace/unispace bold italic.ttf differ diff --git a/assets/fonts/unispace/unispace bold.ttf b/assets/fonts/unispace/unispace bold.ttf new file mode 100644 Binary files /dev/null and b/assets/fonts/unispace/unispace bold.ttf differ diff --git a/assets/fonts/unispace/unispace italic.ttf b/assets/fonts/unispace/unispace italic.ttf new file mode 100644 Binary files /dev/null and b/assets/fonts/unispace/unispace italic.ttf differ diff --git a/assets/fonts/unispace/unispace.ttf b/assets/fonts/unispace/unispace.ttf new file mode 100644 Binary files /dev/null and b/assets/fonts/unispace/unispace.ttf differ diff --git a/assets/imgs/VNBG.png b/assets/imgs/VNBG.png new file mode 100644 Binary files /dev/null and b/assets/imgs/VNBG.png differ diff --git a/assets/imgs/astral-avatar.png b/assets/imgs/astral-avatar.png new file mode 100644 Binary files /dev/null and b/assets/imgs/astral-avatar.png differ diff --git a/assets/imgs/astral-sprite.png b/assets/imgs/astral-sprite.png new file mode 100644 Binary files /dev/null and b/assets/imgs/astral-sprite.png differ diff --git a/assets/imgs/astral.png b/assets/imgs/astral.png new file mode 100644 Binary files /dev/null and b/assets/imgs/astral.png differ diff --git a/assets/imgs/background.png b/assets/imgs/background.png new file mode 100644 Binary files /dev/null and b/assets/imgs/background.png differ diff --git a/assets/imgs/bullet.png b/assets/imgs/bullet.png new file mode 100644 Binary files /dev/null and b/assets/imgs/bullet.png differ diff --git a/assets/imgs/crossdown.png b/assets/imgs/crossdown.png new file mode 100644 Binary files /dev/null and b/assets/imgs/crossdown.png differ diff --git a/assets/imgs/customer.png b/assets/imgs/customer.png new file mode 100644 Binary files /dev/null and b/assets/imgs/customer.png differ diff --git a/assets/imgs/keys.png b/assets/imgs/keys.png new file mode 100644 Binary files /dev/null and b/assets/imgs/keys.png differ diff --git a/assets/imgs/nyx-avatar.png b/assets/imgs/nyx-avatar.png new file mode 100644 Binary files /dev/null and b/assets/imgs/nyx-avatar.png differ diff --git a/assets/imgs/nyx-bullet.png b/assets/imgs/nyx-bullet.png new file mode 100644 Binary files /dev/null and b/assets/imgs/nyx-bullet.png differ diff --git a/assets/imgs/nyx-sprites-animated.png b/assets/imgs/nyx-sprites-animated.png new file mode 100644 Binary files /dev/null and b/assets/imgs/nyx-sprites-animated.png differ diff --git a/assets/imgs/static.png b/assets/imgs/static.png new file mode 100644 Binary files /dev/null and b/assets/imgs/static.png differ diff --git a/nyx-game.cabal b/nyx-game.cabal new file mode 100644 --- /dev/null +++ b/nyx-game.cabal @@ -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 diff --git a/src/Play/Engine.hs b/src/Play/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine.hs @@ -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 diff --git a/src/Play/Engine/Button.hs b/src/Play/Engine/Button.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Button.hs @@ -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 diff --git a/src/Play/Engine/Input.hs b/src/Play/Engine/Input.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Input.hs @@ -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 diff --git a/src/Play/Engine/ListZipper.hs b/src/Play/Engine/ListZipper.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/ListZipper.hs @@ -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) diff --git a/src/Play/Engine/Load.hs b/src/Play/Engine/Load.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Load.hs @@ -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 diff --git a/src/Play/Engine/Movement.hs b/src/Play/Engine/Movement.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Movement.hs @@ -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 + } diff --git a/src/Play/Engine/MySDL/MySDL.hs b/src/Play/Engine/MySDL/MySDL.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/MySDL/MySDL.hs @@ -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) } diff --git a/src/Play/Engine/Runner.hs b/src/Play/Engine/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Runner.hs @@ -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 + diff --git a/src/Play/Engine/Scene.hs b/src/Play/Engine/Scene.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Scene.hs @@ -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) diff --git a/src/Play/Engine/ScrollingBackground.hs b/src/Play/Engine/ScrollingBackground.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/ScrollingBackground.hs @@ -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)) diff --git a/src/Play/Engine/Settings.hs b/src/Play/Engine/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Settings.hs @@ -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 + } diff --git a/src/Play/Engine/Sprite.hs b/src/Play/Engine/Sprite.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Sprite.hs @@ -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 diff --git a/src/Play/Engine/Types.hs b/src/Play/Engine/Types.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Types.hs @@ -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) diff --git a/src/Play/Engine/Utils.hs b/src/Play/Engine/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Play/Engine/Utils.hs @@ -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