SpaceInvaders 0.4.5 → 0.13.3
raw patch · 11 files changed
+123/−84 lines, 11 filesdep +deepseqdep +simple-affine-spacedep ~Yampanew-uploader
Dependencies added: deepseq, simple-affine-space
Dependency ranges changed: Yampa
Files
- CHANGELOG +12/−0
- SpaceInvaders.cabal +11/−5
- src/Animate.hs +34/−29
- src/Main.hs +8/−8
- src/Object.hs +7/−5
- src/ObjectBehavior.hs +28/−14
- src/Parser.hs +10/−12
- src/PhysicalDimensions.hs +9/−7
- src/RenderLandscape.hs +1/−2
- src/RenderObject.hs +2/−1
- src/WorldGeometry.hs +1/−1
+ CHANGELOG view
@@ -0,0 +1,12 @@+2021-10-07 Ivan Perez <ivan.perez@haskell.sexy>:+ * SpaceInvaders.cabal: Version bump (0.13.3), update constraints on Yampa+ bump cabal-version (#35).+ * src/: Fix compilation issue due to GHC bug (#30), update to new Yampa+ API (#32), fix speed problem due to threading (#33).+ * .travis.yml: Update compilation matrix (#34).++2017-11-07 Christina Zeller <chriz@keera.co.uk>:+ * SpaceInvaders.cabal: Version bump (0.4.5)++2017-11-05 Christina Zeller <chriz@keera.co.uk>:+ * SpaceInvaders.cabal: Adds gif to cabal description.
SpaceInvaders.cabal view
@@ -1,6 +1,6 @@ name: SpaceInvaders-version: 0.4.5-cabal-Version: >= 1.6+version: 0.13.3+cabal-Version: >= 1.10 license: BSD3 license-file: LICENSE author: Henrik Nilsson, Antony Courtney@@ -9,15 +9,19 @@ category: Game synopsis: Video game description: Video game implemented in Yampa.+ . <<https://github.com/ivanperez-keera/SpaceInvaders/blob/develop/screenshots/gameplay.gif?raw=true>> build-type: Simple+extra-source-files: CHANGELOG executable spaceInvaders hs-source-dirs: src- ghc-options : -threaded -O3 -Wall -fno-warn-name-shadowing- build-Depends: base >= 3 && < 5, array, random, HGL, Yampa >= 0.9.2+ ghc-options : -Wall -fno-warn-name-shadowing+ build-Depends: base >= 3 && < 5, array, random, HGL, Yampa >= 0.13.3+ , simple-affine-space >= 0.1 && < 0.2+ , deepseq >= 1.3.0 && < 1.5 main-is: Main.hs- Extensions: Arrows+ default-extensions: Arrows Other-Modules: Animate ColorBindings@@ -32,6 +36,8 @@ RenderLandscape RenderObject WorldGeometry+ default-language:+ Haskell2010 source-repository head type: git
src/Animate.hs view
@@ -34,7 +34,8 @@ module Animate (WinInput, animate) where -import Control.Monad (when)+import Control.DeepSeq (NFData, force)+import Control.Monad (forM_, when) -- import Data.Maybe (isJust, fromJust) -- import Posix (SysVar(..), ProcessTimes, ClockTick, -- getSysVar, getProcessTimes, elapsedTime)@@ -45,8 +46,6 @@ import FRP.Yampa import FRP.Yampa.Event -- import FRP.Yampa.Internals -- Breaking the Event abstraction barrier here!-import FRP.Yampa.Task (repeatUntil, forAll)-import FRP.Yampa.Forceable import Diagnostics (intErr) import PhysicalDimensions@@ -74,7 +73,7 @@ -- !!! function by means of continuations? Or maybe the IOTask monad is the -- !!! way to go, with a special "reactimateIOTask". -animate :: (Forceable a)+animate :: (NFData a) => Frequency -> String -> Int -> Int -> (a -> HGL.Graphic) -> (a -> [String])@@ -93,20 +92,20 @@ getTimeInput (\_ ea@(e,a) -> do updateWin render win ea- forAll (tco a) putStrLn+ forM_ (tco a) putStrLn isClosed) (repeatedly (1/fr) () &&& sf) -} reactimate init getTimeInput (\_ (ea@(e,a), (e', c)) -> do updateWin render win ea- forAll (tco a) putStrLn -- If this is all maybe, why not use Control.Monad.forM_ ?+ forM_ (tco a) putStrLn when (isEvent e') (putStrLn ("Cycle#: " ++ show c)) isClosed) ((repeatedly (1/fr) () &&& sf) &&& (repeatedly 1 () &&& loop (arr ((+1) . snd)- >>> iPre (0 :: Int) + >>> iPre (0 :: Int) >>> arr dup))) HGL.closeWindow win @@ -141,26 +140,26 @@ -- Next delta time and input let getTimeInput _ = do- -- Get time- tp <- readIORef tpRef- t <- getElapsedTime `repeatUntil` (/= tp) -- Wrap around possible!- let dt = if t > tp then fromIntegral (t-tp)/clkRes else 1/clkRes- writeIORef tpRef t+ -- Get time+ tp <- readIORef tpRef+ t <- getElapsedTime `repeatUntil` (/= tp) -- Wrap around possible!+ let dt = if t > tp then fromIntegral (t-tp)/clkRes else 1/clkRes+ writeIORef tpRef t - -- Get input- mwe <- getWinInput win weBufRef- mwep <- readIORef wepRef- writeIORef wepRef mwe- -- putStrLn ("dt = " ++ show dt)- -- when (isJust mwe) (putStrLn ("Event = " ++ show (fromJust mwe)))- -- Simplistic "delta encoding": detects only repeated NoEvent.+ -- Get input+ mwe <- getWinInput win weBufRef+ mwep <- readIORef wepRef+ writeIORef wepRef mwe+ -- putStrLn ("dt = " ++ show dt)+ -- when (isJust mwe) (putStrLn ("Event = " ++ show (fromJust mwe)))+ -- Simplistic "delta encoding": detects only repeated NoEvent. - -- Return time and input, possibly asking to close the program- case (mwep, mwe) of- (Nothing, Nothing) -> return (dt, Nothing)- (_, Just HGL.Closed) -> do writeIORef closedRef True- return (dt, Just (maybeToEvent mwe))- _ -> return (dt, Just (maybeToEvent mwe))+ -- Return time and input, possibly asking to close the program+ case (mwep, mwe) of+ (Nothing, Nothing) -> return (dt, Nothing)+ (_, Just HGL.Closed) -> do writeIORef closedRef True+ return (dt, Just (maybeToEvent mwe))+ _ -> return (dt, Just (maybeToEvent mwe)) return (init, getTimeInput, readIORef closedRef) @@ -168,19 +167,19 @@ errInitNotCalled = intErr "RSAnimate" "mkInitAndGetTimeInput" "Init procedure not called."- + -- Accurate enough? Resolution seems to be 0.01 s, which could lead -- to substantial busy waiting above. -- getElapsedTime :: IO ClockTick -- getElapsedTime = fmap elapsedTime getProcessTimes- + -- Use this for now. Have seen delta times down to 0.001 s. But as -- the complexity of the simulator signal function gets larger, the -- processing time for one iteration will presumably be > 0.01 s, -- and a clock resoltion of 0.01 s vs. 0.001 s becomes a non issue. getElapsedTime :: IO HGL.Time getElapsedTime = HGL.getTime- + -- Get window input, with "redundant" mouse moves removed. getWinInput :: HGL.Window -> IORef (Maybe HGL.Event) -> IO (Maybe HGL.Event) getWinInput win weBufRef = do@@ -224,6 +223,12 @@ -- We also explicitly force displayed elements in case the renderer does not -- force everything. updateWin ::- Forceable a => (a -> HGL.Graphic) -> HGL.Window -> (Event (), a) -> IO ()+ NFData a => (a -> HGL.Graphic) -> HGL.Window -> (Event (), a) -> IO () updateWin render win (e, a) = when (force a `seq` isEvent e) (HGL.setGraphic win (render a))++-- * Auxiliary function++-- | Repeat m until result satisfies the predicate p+repeatUntil :: Monad m => m a -> (a -> Bool) -> m a+m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x
src/Main.hs view
@@ -17,11 +17,11 @@ import System.Random +import Data.Point2 (Point2(..), point2Y) import Data.Maybe (isJust) import Data.Array import FRP.Yampa-import FRP.Yampa.Geometry import qualified Graphics.HGL as HGL -- Temporary, just to make sure all modules compile.@@ -110,14 +110,14 @@ objs0 = listToIL (gun (Point2 0 50) : mkAliens g (worldXMin + d) 900 nAliens) d = (worldXMax - worldXMin) / fromIntegral (nAliens + 1) -- Evenly spaced aliens- - ++ mkAliens g x y n | n > 0 = alien g' (Point2 x y) vydAlien : mkAliens g'' (x + d) y (n - 1) where (g', g'') = split g mkAliens _ _ _ 0 = [] mkAliens _ _ _ _ = []- + aliensDied :: IL ObjOutput -> Event (Score -> Score) aliensDied oos = fmap (\es -> (+length es))@@ -162,7 +162,7 @@ route :: (GameInput, IL ObjOutput) -> IL sf -> IL (ObjInput, sf) route (gi,oos) objs = mapIL routeAux objs- + where routeAux (k, obj) = (ObjInput {oiHit = if k `elem` hs@@ -183,12 +183,12 @@ hitsAux ((k,oos):kooss) = [ [k, k'] | (k', oos') <- kooss, oos `hit` oos' ] ++ hitsAux kooss- + oos1 `hit` oos2 | isMissile oos1 && isAlien oos2 || isAlien oos1 && isMissile oos2 = oos1 `colliding` oos2 | otherwise = False- + killOrSpawn :: (a, IL ObjOutput) -> (Event (IL Object -> IL Object)) killOrSpawn (_, oos) = foldl (mergeBy (.)) noEvent es@@ -202,7 +202,7 @@ renderScore :: Score -> HGL.Graphic-renderScore score = +renderScore score = HGL.withTextColor (colorTable ! White) $ HGL.withTextAlignment (HGL.Left', HGL.Top) $ HGL.text gp (show score)
src/Object.hs view
@@ -39,9 +39,11 @@ alienAccMax -- :: Acceleration ) where +import Control.DeepSeq (NFData (rnf))+import Data.AffineSpace ((.-.))+import Data.VectorSpace (dot, norm, (^-^))+ import FRP.Yampa (SF, Event)-import FRP.Yampa.Geometry-import FRP.Yampa.Forceable import Parser (GameInput) import PhysicalDimensions@@ -101,9 +103,9 @@ -- Instances ------------------------------------------------------------------------------ -instance Forceable ObsObjState where- -- If non-strict fields: oosNonStrict1 obj `seq` ... `seq` obj - force obj = obj+instance NFData ObsObjState where+ -- If non-strict fields: oosNonStrict1 obj `seq` ... `seq` obj+ rnf obj = obj `seq` () ------------------------------------------------------------------------------
src/ObjectBehavior.hs view
@@ -17,12 +17,14 @@ alien -- :: RandomGen g => g -> Position2 -> Object ) where -import qualified System.Random as Random+import Data.AffineSpace ((.+^))+import Data.Point2 (Point2 (..), point2X)+import Data.Vector2 (vector2, vector2Polar, vector2Rho,+ vector2Theta, vector2X, vector2Y)+import qualified System.Random as Random import FRP.Yampa import FRP.Yampa.Integration-import FRP.Yampa.Utilities-import FRP.Yampa.Geometry import PhysicalDimensions import WorldGeometry@@ -37,7 +39,19 @@ gun :: Position2 -> Object gun (Point2 x0 y0) = proc (ObjInput {oiGameInput = gi}) -> do -- Position.- (Point2 xd _) <- ptrPos -< gi -- Desired position+ --+ -- There is a bug in the GHC 8.* series that makes deconstructing+ -- a Point2 in the left-hand side of an arrow expression trigger a+ -- compilation error:+ --+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/15175+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/18950+ --+ -- Instead, we name the output with a variable and then use let to+ -- deconstruct the expression, which compiles correctly.+ desiredPos <- ptrPos -< gi -- Desired position+ let (Point2 xd _) = desiredPos+ rec -- Controller. let ad = 10 * (xd - x) - 5 * v -- Desired acceleration@@ -60,7 +74,7 @@ ooObsObjState = oosGun (Point2 x y0) (vector2 v 0) level, ooKillReq = noEvent, ooSpawnReq =- fire `tag` [missile (Point2 x (y0 + (gunHeight/2))) + fire `tag` [missile (Point2 x (y0 + (gunHeight/2))) (vector2 v missileInitialSpeed)] } @@ -73,16 +87,16 @@ -- output ..... Tuple: -- #1: Current number of missiles in magazine. -- #2: Missile fired event.-magazine :: - Int -> Frequency +magazine ::+ Int -> Frequency -> SF (Event ()) (Int, Event ()) magazine n f = proc trigger -> do reload <- repeatedly (1/f) () -< ()- (level,canFire) - <- accumHold (n,True) -< + (level,canFire)+ <- accumHold (n,True) -< (trigger `tag` dec) `lMerge` (reload `tag` inc)- returnA -< (level, + returnA -< (level, trigger `gate` canFire) where inc :: (Int,Bool) -> (Int, Bool)@@ -161,10 +175,10 @@ -- About 4% of time spent here. -- Pick a desired horizontal position.- rx <- noiseR (worldXMin, worldXMax) g -< () + rx <- noiseR (worldXMin, worldXMax) g -< () sample <- occasionally g 5 () -< ()- xd <- hold (point2X p0) -< sample `tag` rx - + xd <- hold (point2X p0) -< sample `tag` rx+ -- Controller. Control constants not optimized. Who says aliens know -- anything about control theory? let axd = 5 * (xd - point2X p) - 3 * (vector2X v)@@ -198,7 +212,7 @@ --- About 20% of the time spent here. +-- About 20% of the time spent here. shield :: SF (Event ()) ShieldLevel shield = proc hit -> do rec
src/Parser.hs view
@@ -34,14 +34,12 @@ dragging -- :: SF GameInput Bool ) where +import Data.AffineSpace (origin, (.-.)) import Data.Maybe (isNothing, isJust) import qualified Graphics.HGL as HGL (Event(..)) import Data.Char (ord, isSpace, isDigit) import FRP.Yampa-import FRP.Yampa.Utilities-import FRP.Yampa.Geometry--- import FRP.Yampa.Miscellany (mapFst) import PhysicalDimensions import WorldGeometry (gPointToPosition2)@@ -89,11 +87,11 @@ lbpPos :: SF GameInput (Event Position2)-lbpPos = giPDS # pdsLeft ^>> edgeJust+lbpPos = (giPDS >>> pdsLeft) ^>> edgeJust lbDown :: SF GameInput Bool-lbDown = arr (giPDS # pdsLeft # isJust)+lbDown = arr (giPDS >>> pdsLeft >>> isJust) rbp :: SF GameInput (Event ())@@ -101,22 +99,22 @@ rbpPos :: SF GameInput (Event Position2)-rbpPos = giPDS # pdsRight ^>> edgeJust+rbpPos = (giPDS >>> pdsRight) ^>> edgeJust rbDown :: SF GameInput Bool-rbDown = arr (giPDS # pdsRight # isJust)+rbDown = arr (giPDS >>> pdsRight >>> isJust) dragStart :: SF GameInput (Event ())-dragStart = giPDS # pdsDrag ^>> edgeBy detectStart (Just undefined)+dragStart = (giPDS >>> pdsDrag) ^>> edgeBy detectStart (Just undefined) where detectStart Nothing (Just _) = Just () detectStart _ _ = Nothing dragStop :: SF GameInput (Event Distance2)-dragStop = (giPDS # pdsDrag ^>> edgeBy detectStop Nothing) &&& dragVec+dragStop = ((giPDS >>> pdsDrag) ^>> edgeBy detectStop Nothing) &&& dragVec >>^ \(e, dv) -> e `tag` dv where detectStop (Just _) Nothing = Just ()@@ -125,16 +123,16 @@ -- (Last) drag start position. dragStartPos :: SF GameInput Position2-dragStartPos = arr (giPDS # pdsDragStartPos)+dragStartPos = arr (giPDS >>> pdsDragStartPos) -- (Last) drag vector. dragVec :: SF GameInput Distance2-dragVec = arr (giPDS # pdsDragVec)+dragVec = arr (giPDS >>> pdsDragVec) dragging :: SF GameInput Bool-dragging = arr (giPDS # pdsDrag # isJust)+dragging = arr (giPDS >>> pdsDrag >>> isJust) ------------------------------------------------------------------------------
src/PhysicalDimensions.hs view
@@ -51,10 +51,12 @@ headingToBearing -- :: Heading -> Bearing ) where -import FRP.Yampa (Time, DTime)-import FRP.Yampa.Miscellany (fMod)-import FRP.Yampa.Geometry (Vector2, Vector3, Point2, Point3)-+import Data.Fixed (mod')+import Data.Point2 (Point2)+import Data.Point3 (Point3)+import Data.Vector2 (Vector2)+import Data.Vector3 (Vector3)+import FRP.Yampa (DTime, Time) -- Many of the physical dimensions below are related to time, and variables -- of these types can thus be expected to occur in numerical expressions along@@ -110,7 +112,7 @@ -- The resulting angle is in the interval [-pi, pi). normalizeAngle :: Angle -> Angle-normalizeAngle d = fMod (d + pi) (2 * pi) - pi+normalizeAngle d = mod' (d + pi) (2 * pi) - pi -- The resulting heading is in the interval [-pi, pi).@@ -125,9 +127,9 @@ -- The resulting heading is in the interval [-pi, pi). bearingToHeading :: Bearing -> Heading-bearingToHeading b = (fMod (270 - b) 360 - 180) * pi / 180+bearingToHeading b = (mod' (270 - b) 360 - 180) * pi / 180 -- The resulting bearing is in the interval [0, 360). headingToBearing :: Heading -> Bearing-headingToBearing d = fMod (90 - d * 180 / pi) 360+headingToBearing d = mod' (90 - d * 180 / pi) 360
src/RenderLandscape.hs view
@@ -16,9 +16,8 @@ ) where import Data.Array+import Data.Point2 (Point2(..)) import qualified Graphics.HGL as HGL--import FRP.Yampa.Point2 (Point2(..)) import WorldGeometry import Colors
src/RenderObject.hs view
@@ -15,9 +15,10 @@ renderObjects -- :: [ObjObjState] -> HGL.Graphic ) where +import Data.AffineSpace ((.+^), (.-^)) import Data.Array+import Data.Vector2 (vector2, vector2Polar) import qualified Graphics.HGL as HGL-import FRP.Yampa.Geometry import PhysicalDimensions import WorldGeometry
src/WorldGeometry.hs view
@@ -14,7 +14,7 @@ module WorldGeometry where -import FRP.Yampa.Point2 (Point2(..))+import Data.Point2 (Point2(..)) import PhysicalDimensions import qualified Graphics.HGL as HGL (Point)