diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,12 @@ +2021-10-07 Ivan Perez : + * 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 : + * SpaceInvaders.cabal: Version bump (0.4.5) + +2017-11-05 Christina Zeller : + * SpaceInvaders.cabal: Adds gif to cabal description. diff --git a/SpaceInvaders.cabal b/SpaceInvaders.cabal --- a/SpaceInvaders.cabal +++ b/SpaceInvaders.cabal @@ -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. + . <> 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 diff --git a/src/Animate.hs b/src/Animate.hs --- a/src/Animate.hs +++ b/src/Animate.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -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` () ------------------------------------------------------------------------------ diff --git a/src/ObjectBehavior.hs b/src/ObjectBehavior.hs --- a/src/ObjectBehavior.hs +++ b/src/ObjectBehavior.hs @@ -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 diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -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) ------------------------------------------------------------------------------ diff --git a/src/PhysicalDimensions.hs b/src/PhysicalDimensions.hs --- a/src/PhysicalDimensions.hs +++ b/src/PhysicalDimensions.hs @@ -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 diff --git a/src/RenderLandscape.hs b/src/RenderLandscape.hs --- a/src/RenderLandscape.hs +++ b/src/RenderLandscape.hs @@ -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 diff --git a/src/RenderObject.hs b/src/RenderObject.hs --- a/src/RenderObject.hs +++ b/src/RenderObject.hs @@ -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 diff --git a/src/WorldGeometry.hs b/src/WorldGeometry.hs --- a/src/WorldGeometry.hs +++ b/src/WorldGeometry.hs @@ -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)