diff --git a/SpaceInvaders.cabal b/SpaceInvaders.cabal --- a/SpaceInvaders.cabal +++ b/SpaceInvaders.cabal @@ -1,14 +1,14 @@ name: SpaceInvaders -version: 0.4.2 -cabal-Version: >= 1.2 +version: 0.4.4 +cabal-Version: >= 1.6 license: BSD3 license-file: LICENSE author: Henrik Nilsson, Antony Courtney -maintainer: George Giorgidze (GGG at CS dot NOTT dot AC dot UK) +maintainer: Ivan Perez homepage: http://www.haskell.org/yampa/ category: Game synopsis: Video game -description: Video game implemented in Yampa. +description: Video game implemented in Yampa. build-type: Simple executable spaceInvaders @@ -31,3 +31,7 @@ RenderLandscape RenderObject WorldGeometry + +source-repository head + type: git + location: git://github.com/ivanperez-keera/SpaceInvaders.git diff --git a/src/Animate.hs b/src/Animate.hs --- a/src/Animate.hs +++ b/src/Animate.hs @@ -2,9 +2,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: Animate * -* Purpose: Animation of graphical signal functions. * -* Author: Henrik Nilsson * +* Module: Animate * +* Purpose: Animation of graphical signal functions. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -35,7 +35,7 @@ module Animate (WinInput, animate) where import Control.Monad (when) -import Data.Maybe (isJust, fromJust) +-- import Data.Maybe (isJust, fromJust) -- import Posix (SysVar(..), ProcessTimes, ClockTick, -- getSysVar, getProcessTimes, elapsedTime) -- import Concurrent (yield) @@ -43,7 +43,8 @@ import qualified Graphics.HGL as HGL import FRP.Yampa -import FRP.Yampa.Internals -- Breaking the Event abstraction barrier here! +import FRP.Yampa.Event +-- import FRP.Yampa.Internals -- Breaking the Event abstraction barrier here! import FRP.Yampa.Task (repeatUntil, forAll) import FRP.Yampa.Forceable @@ -59,7 +60,7 @@ ------------------------------------------------------------------------------ -- Animate a signal function --- fr ......... Frame rate. +-- fr ......... Frame rate. -- title ...... Window title. -- width ...... Window width in pixels. -- height ..... Window height in pixels. @@ -73,42 +74,40 @@ -- !!! function by means of continuations? Or maybe the IOTask monad is the -- !!! way to go, with a special "reactimateIOTask". -animate :: (Forceable a) => - Frequency -> String -> Int -> Int - -> (a -> HGL.Graphic) - -> (a -> [String]) - -> (SF WinInput a) - -> IO () -animate fr title width height render tco sf = HGL.runGraphics $ - do +animate :: (Forceable a) + => Frequency -> String -> Int -> Int + -> (a -> HGL.Graphic) + -> (a -> [String]) + -> (SF WinInput a) + -> IO () +animate fr title width height render tco sf = HGL.runGraphics $ do win <- HGL.openWindowEx title - Nothing -- Initial position. - (width, height) -- Size. - HGL.DoubleBuffered -- Painfully SLOW!!! - -- HGL.Unbuffered -- Flickers! - (Just 1) -- For scheduling!?! + Nothing -- Initial position. + (width, height) -- Size. + HGL.DoubleBuffered -- Painfully SLOW!!! + -- HGL.Unbuffered -- Flickers! + (Just 1) -- For scheduling!?! (init, getTimeInput, isClosed) <- mkInitAndGetTimeInput win {- - reactimate init + reactimate init getTimeInput (\_ ea@(e,a) -> do updateWin render win ea - forAll (tco a) putStrLn + forAll (tco a) putStrLn isClosed) - (repeatedly (1/fr) () &&& sf) + (repeatedly (1/fr) () &&& sf) -} - reactimate init - getTimeInput - (\_ (ea@(e,a), (e', c)) -> do - updateWin render win ea - forAll (tco a) putStrLn - when (isEvent e') (putStrLn ("Cycle#: " ++ show c)) - isClosed) - ((repeatedly (1/fr) () &&& sf) - &&& (repeatedly 1 () - &&& loop (arr ((+1) . snd) - >>> iPre (0 :: Int) - >>> arr dup))) + 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_ ? + when (isEvent e') (putStrLn ("Cycle#: " ++ show c)) + isClosed) + ((repeatedly (1/fr) () &&& sf) + &&& (repeatedly 1 () + &&& loop (arr ((+1) . snd) + >>> iPre (0 :: Int) + >>> arr dup))) HGL.closeWindow win @@ -126,84 +125,95 @@ wepRef <- newIORef errInitNotCalled weBufRef <- newIORef Nothing closedRef <- newIORef False + + -- Initialization and initial input let init = do + -- Initial time t0 <- getElapsedTime - writeIORef tpRef t0 + writeIORef tpRef t0 + + -- Initial input mwe <- getWinInput win weBufRef writeIORef wepRef mwe + + -- Initial signal return (maybeToEvent mwe) - let getTimeInput _ = do - 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 - 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. - 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) - where - 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 + -- 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 - -- 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 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. - maybeToEvent :: Maybe a -> Event a - maybeToEvent = maybe NoEvent Event + -- 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) + where + 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 mwe <- readIORef weBufRef case mwe of - Just _ -> do - writeIORef weBufRef Nothing - return mwe - Nothing -> do - mwe' <- gwi win - case mwe' of - Just (HGL.MouseMove {}) -> mmFilter mwe' - _ -> return mwe' + Just _ -> do + writeIORef weBufRef Nothing + return mwe + Nothing -> do + mwe' <- gwi win + case mwe' of + Just (HGL.MouseMove {}) -> mmFilter mwe' + _ -> return mwe' where - mmFilter jmme = do - mwe' <- gwi win - case mwe' of - Nothing -> return jmme - Just (HGL.MouseMove {}) -> mmFilter mwe' - Just _ -> writeIORef weBufRef mwe' - >> return jmme + mmFilter jmme = do + mwe' <- gwi win + case mwe' of + Nothing -> return jmme + Just (HGL.MouseMove {}) -> mmFilter mwe' + Just _ -> writeIORef weBufRef mwe' + >> return jmme - -- Seems as if we either have to yield or wait for a tick in order - -- to ensure that the thread receiving events gets a chance to - -- work. For some reason, yielding seems to result in window close - -- events getting through, wheras waiting often means they don't. + -- Seems as if we either have to yield or wait for a tick in order + -- to ensure that the thread receiving events gets a chance to + -- work. For some reason, yielding seems to result in window close + -- events getting through, wheras waiting often means they don't. -- Maybe the process typically dies before the waiting time is up in -- the latter case? gwi win = do - -- yield + -- yield HGL.getWindowTick win - mwe <- HGL.maybeGetWindowEvent win - return mwe + mwe <- HGL.maybeGetWindowEvent win + return mwe ------------------------------------------------------------------------------ diff --git a/src/ColorBindings.hs b/src/ColorBindings.hs --- a/src/ColorBindings.hs +++ b/src/ColorBindings.hs @@ -2,9 +2,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: ColorBindings * -* Purpose: Definition of colours for various objects. * -* Author: Henrik Nilsson * +* Module: ColorBindings * +* Purpose: Definition of colours for various objects. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -19,9 +19,9 @@ -- Landscape colors ------------------------------------------------------------------------------ -distantMountainColor = MidnightBlue -closeMountainColor = Purple -groundColor = Red +distantMountainColor = MidnightBlue +closeMountainColor = Purple +groundColor = Red ------------------------------------------------------------------------------ diff --git a/src/Colors.hs b/src/Colors.hs --- a/src/Colors.hs +++ b/src/Colors.hs @@ -2,9 +2,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: Colors * -* Purpose: Colour definitions. * -* Author: Henrik Nilsson * +* Module: Colors * +* Purpose: Colour definitions. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -84,66 +84,66 @@ colorList = [ -- Basic colours. - (Black, RGB 0 0 0), - (Blue, RGB 0 0 255), - (Green, RGB 0 255 0), - (Cyan, RGB 0 255 255), - (Red, RGB 255 0 0), - (Magenta, RGB 255 0 255), - (Yellow, RGB 255 255 0), - (White, RGB 255 255 255), + (Black, RGB 0 0 0), + (Blue, RGB 0 0 255), + (Green, RGB 0 255 0), + (Cyan, RGB 0 255 255), + (Red, RGB 255 0 0), + (Magenta, RGB 255 0 255), + (Yellow, RGB 255 255 0), + (White, RGB 255 255 255), - -- Various greys. - (DarkGrey, RGB 64 64 64), - (DimGrey, RGB 105 105 105), - (Grey, RGB 190 190 190), - (LightGrey, RGB 211 211 211), - (DarkSlateGrey, RGB 47 79 79), - (SlateGrey, RGB 112 128 144), - (LightSlateGrey, RGB 119 136 153), + -- Various greys. + (DarkGrey, RGB 64 64 64), + (DimGrey, RGB 105 105 105), + (Grey, RGB 190 190 190), + (LightGrey, RGB 211 211 211), + (DarkSlateGrey, RGB 47 79 79), + (SlateGrey, RGB 112 128 144), + (LightSlateGrey, RGB 119 136 153), - -- Various blues/cyan. - (MidnightBlue, RGB 25 25 112), - (NavyBlue, RGB 0 0 128), - (CornflowerBlue, RGB 100 149 237), - (DarkSlateBlue, RGB 72 61 139), - (SlateBlue, RGB 106 90 205), - (LightSlateBlue, RGB 132 112 255), - (MediumBlue, RGB 0 0 205), - (RoyalBlue, RGB 65 105 225), - (DeepSkyBlue, RGB 0 191 255), - (SteelBlue, RGB 70 130 180), - (CadetBlue, RGB 95 158 160), + -- Various blues/cyan. + (MidnightBlue, RGB 25 25 112), + (NavyBlue, RGB 0 0 128), + (CornflowerBlue, RGB 100 149 237), + (DarkSlateBlue, RGB 72 61 139), + (SlateBlue, RGB 106 90 205), + (LightSlateBlue, RGB 132 112 255), + (MediumBlue, RGB 0 0 205), + (RoyalBlue, RGB 65 105 225), + (DeepSkyBlue, RGB 0 191 255), + (SteelBlue, RGB 70 130 180), + (CadetBlue, RGB 95 158 160), - -- Various greens/olive greens/khaki. - (DarkGreen, RGB 0 100 0), - (DarkOliveGreen, RGB 85 107 47), - (SeaGreen, RGB 46 139 87), - (MediumSeaGreen, RGB 60 179 113), - (LawnGreen, RGB 124 252 0), - (LimeGreen, RGB 50 205 50), - (ForestGreen, RGB 34 139 34), - (OliveDrab, RGB 107 142 35), - (DarkKhaki, RGB 189 183 107), - (Khaki, RGB 240 230 140), + -- Various greens/olive greens/khaki. + (DarkGreen, RGB 0 100 0), + (DarkOliveGreen, RGB 85 107 47), + (SeaGreen, RGB 46 139 87), + (MediumSeaGreen, RGB 60 179 113), + (LawnGreen, RGB 124 252 0), + (LimeGreen, RGB 50 205 50), + (ForestGreen, RGB 34 139 34), + (OliveDrab, RGB 107 142 35), + (DarkKhaki, RGB 189 183 107), + (Khaki, RGB 240 230 140), - -- Various oranges/browns. - (Goldenrod, RGB 218 165 32), - (DarkGoldenrod, RGB 184 134 11), - (SaddleBrown, RGB 139 69 19), - (Orange, RGB 255 165 0), + -- Various oranges/browns. + (Goldenrod, RGB 218 165 32), + (DarkGoldenrod, RGB 184 134 11), + (SaddleBrown, RGB 139 69 19), + (Orange, RGB 255 165 0), - -- Various violets/purples. - (Maroon, RGB 176 48 96), - (MediumVioletRed, RGB 199 21 133), - (VioletRed, RGB 208 32 144), - (Violet, RGB 238 130 238), - (Plum, RGB 221 160 221), - (Orchid, RGB 218 112 214), - (MediumOrchid, RGB 186 85 211), - (DarkOrchid, RGB 153 50 204), - (BlueViolet, RGB 138 43 226), - (Purple, RGB 160 32 240) + -- Various violets/purples. + (Maroon, RGB 176 48 96), + (MediumVioletRed, RGB 199 21 133), + (VioletRed, RGB 208 32 144), + (Violet, RGB 238 130 238), + (Plum, RGB 221 160 221), + (Orchid, RGB 218 112 214), + (MediumOrchid, RGB 186 85 211), + (DarkOrchid, RGB 153 50 204), + (BlueViolet, RGB 138 43 226), + (Purple, RGB 160 32 240) ] diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -2,9 +2,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: Command * -* Purpose: The Invader command type. * -* Author: Henrik Nilsson * +* Module: Command * +* Purpose: The Invader command type. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -17,7 +17,7 @@ data Command = - CmdQuit -- Quit Invaders. - | CmdNewGame -- Play game. - | CmdFreeze -- Freeze game. - | CmdResume -- Resume game. + CmdQuit -- Quit Invaders. + | CmdNewGame -- Play game. + | CmdFreeze -- Freeze game. + | CmdResume -- Resume game. diff --git a/src/Diagnostics.hs b/src/Diagnostics.hs --- a/src/Diagnostics.hs +++ b/src/Diagnostics.hs @@ -2,9 +2,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: Diagnostics * -* Purpose: Standardized error-reporting for Invaders * -* Authors: Henrik Nilsson * +* Module: Diagnostics * +* Purpose: Standardized error-reporting for Invaders * +* Authors: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * diff --git a/src/IdentityList.hs b/src/IdentityList.hs --- a/src/IdentityList.hs +++ b/src/IdentityList.hs @@ -2,10 +2,10 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: IdentityList * -* Purpose: Association list with automatic key assignment and * -* identity-preserving map and filter operations. * -* Author: Henrik Nilsson * +* Module: IdentityList * +* Purpose: Association list with automatic key assignment and * +* identity-preserving map and filter operations. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -13,23 +13,23 @@ -} module IdentityList ( - ILKey, -- Identity-list key type - IL, -- Identity-list, abstract. Instance of functor. - emptyIL, -- :: IL a - insertIL_, -- :: a -> IL a -> IL a - insertIL, -- :: a -> IL a -> (ILKey, IL a) - listToIL, -- :: [a] -> IL a - keysIL, -- :: IL a -> [ILKey] - elemsIL, -- :: IL a -> [a] - assocsIL, -- :: IL a -> [(ILKey, a)] - deleteIL, -- :: ILKey -> IL a -> IL a - mapIL, -- :: ((ILKey, a) -> b) -> IL a -> IL b - filterIL, -- :: ((ILKey, a) -> Bool) -> IL a -> IL a + ILKey, -- Identity-list key type + IL, -- Identity-list, abstract. Instance of functor. + emptyIL, -- :: IL a + insertIL_, -- :: a -> IL a -> IL a + insertIL, -- :: a -> IL a -> (ILKey, IL a) + listToIL, -- :: [a] -> IL a + keysIL, -- :: IL a -> [ILKey] + elemsIL, -- :: IL a -> [a] + assocsIL, -- :: IL a -> [(ILKey, a)] + deleteIL, -- :: ILKey -> IL a -> IL a + mapIL, -- :: ((ILKey, a) -> b) -> IL a -> IL b + filterIL, -- :: ((ILKey, a) -> Bool) -> IL a -> IL a mapFilterIL, -- :: ((ILKey, a) -> Maybe b) -> IL a -> IL b - lookupIL, -- :: ILKey -> IL a -> Maybe a - findIL, -- :: ((ILKey, a) -> Bool) -> IL a -> Maybe a - mapFindIL, -- :: ((ILKey, a) -> Maybe b) -> IL a -> Maybe b - findAllIL, -- :: ((ILKey, a) -> Bool) -> IL a -> [a] + lookupIL, -- :: ILKey -> IL a -> Maybe a + findIL, -- :: ((ILKey, a) -> Bool) -> IL a -> Maybe a + mapFindIL, -- :: ((ILKey, a) -> Maybe b) -> IL a -> Maybe b + findAllIL, -- :: ((ILKey, a) -> Bool) -> IL a -> [a] mapFindAllIL -- :: ((ILKey, a) -> Maybe b) -> IL a -> [b] ) where @@ -77,7 +77,7 @@ listToIL :: [a] -> IL a listToIL as = IL {ilNextKey = length as, - ilAssocs = reverse (zip [0..] as)} -- Maintain invariant! + ilAssocs = reverse (zip [0..] as)} -- Maintain invariant! ------------------------------------------------------------------------------ @@ -104,9 +104,9 @@ deleteIL k (IL {ilNextKey = nk, ilAssocs = kas}) = IL {ilNextKey = nk, ilAssocs = deleteHlp kas} where - deleteHlp [] = [] + deleteHlp [] = [] deleteHlp kakas@(ka@(k', _) : kas) | k > k' = kakas - | k == k' = kas + | k == k' = kas | otherwise = ka : deleteHlp kas @@ -147,17 +147,17 @@ findIL :: ((ILKey, a) -> Bool) -> IL a -> Maybe a findIL p (IL {ilAssocs = kas}) = findHlp kas where - findHlp [] = Nothing + findHlp [] = Nothing findHlp (ka@(_, a) : kas) = if p ka then Just a else findHlp kas mapFindIL :: ((ILKey, a) -> Maybe b) -> IL a -> Maybe b mapFindIL p (IL {ilAssocs = kas}) = mapFindHlp kas where - mapFindHlp [] = Nothing + mapFindHlp [] = Nothing mapFindHlp (ka : kas) = case p ka of - Nothing -> mapFindHlp kas - jb@(Just _) -> jb + Nothing -> mapFindHlp kas + jb@(Just _) -> jb findAllIL :: ((ILKey, a) -> Bool) -> IL a -> [a] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -4,9 +4,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: Main * -* Purpose: Main module. * -* Author: Henrik Nilsson * +* Module: Main * +* Purpose: Main module. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -42,11 +42,13 @@ main = do g <- newStdGen animate 20 "S P A C E I N V A D E R S" worldSizeX worldSizeY - (\(score, ooss) -> - renderScore score - `HGL.overGraphic` renderObjects ooss - `HGL.overGraphic` landscape) + -- Render + (\(score, ooss) -> renderScore score + `HGL.overGraphic` renderObjects ooss + `HGL.overGraphic` landscape) + -- Text console output (\_ -> []) + -- The actual game (see note about misnomer) (parseWinInput >>> restartingGame g) @@ -55,16 +57,16 @@ restartingGame :: RandomGen g => g -> SF GameInput (Int, [ObsObjState]) restartingGame g = rgAux g nAliens0 vydAlien0 0 where - nAliens0 = 2 - vydAlien0 = -10 + nAliens0 = 2 + vydAlien0 = -10 rgAux g nAliens vydAlien score = switch (game g' nAliens vydAlien score) $ \status -> case status of - Left score' -> rgAux g'' (nAliens + 1) (vydAlien - 10) score' - Right _ -> rgAux g'' nAliens0 vydAlien0 0 - where - (g', g'') = split g + Left score' -> rgAux g'' (nAliens + 1) (vydAlien - 10) score' -- Next level + Right _ -> rgAux g'' nAliens0 vydAlien0 0 -- Game over + where + (g', g'') = split g -- How to arrange for splitting of g in general if we have spawning of aliens @@ -72,7 +74,7 @@ -- keep control over the supply of random generators. game :: RandomGen g => g -> Int -> Velocity -> Score -> - SF GameInput ((Int, [ObsObjState]), Event (Either Score Score)) + SF GameInput ((Score, [ObsObjState]), Event (Either Score Score)) game g nAliens vydAlien score0 = proc gi -> do -- One could argue that feeding back only the ObsObjState part would -- make things a little smoother. But possibly somewhat less general. @@ -101,95 +103,97 @@ score <- accumHold score0 -< aliensDied oos gameOver <- edge -< alienLanded oos newRound <- edge -< noAliensLeft oos - returnA -< ((score, map ooObsObjState (elemsIL oos)), - (newRound `tag` (Left score)) - `lMerge` (gameOver `tag` (Right score))) + returnA -< ( (score, map ooObsObjState (elemsIL oos)), + (newRound `tag` (Left score)) `lMerge` (gameOver `tag` (Right score)) + ) where - objs0 = listToIL (gun (Point2 0 50) - : mkAliens g (worldXMin + d) 900 nAliens) - d = (worldXMax - worldXMin) / fromIntegral (nAliens + 1) - - - 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 _ _ _ _ = [] + 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)) - (catEvents (map ooKillReq (findAllIL isAlien' oos))) - where - isAlien' (_, ObjOutput {ooObsObjState = oos}) = isAlien oos + aliensDied :: IL ObjOutput -> Event (Score -> Score) + aliensDied oos = + fmap (\es -> (+length es)) + (catEvents (map ooKillReq (findAllIL isAlien' oos))) + where + isAlien' (_, ObjOutput {ooObsObjState = oos}) = isAlien oos - alienLanded :: IL ObjOutput -> Bool - alienLanded oos = isJust (findIL isLanded oos) - where - isLanded (_, ObjOutput {ooObsObjState = oos}) = - isAlien oos && point2Y (oosPos oos) <= 0 + alienLanded :: IL ObjOutput -> Bool + alienLanded oos = isJust (findIL isLanded oos) + where + isLanded (_, ObjOutput {ooObsObjState = oos}) = + isAlien oos && point2Y (oosPos oos) <= 0 - noAliensLeft :: IL ObjOutput -> Bool - noAliensLeft oos = null (findAllIL isAlien' oos) - where - isAlien' (_, ObjOutput {ooObsObjState = oos}) = isAlien oos + noAliensLeft :: IL ObjOutput -> Bool + noAliensLeft oos = null (findAllIL isAlien' oos) + where + isAlien' (_, ObjOutput {ooObsObjState = oos}) = isAlien oos - -- dpSwitch for now. This makes kill/spawn events observable, - -- and allows feedback without iPre *in this case*, since only the - -- switching depends on the feedback, and hit detection does not - -- depend on any part of the fed-back output that in turn depends on - -- the hit detection. But this is a really fragile property! - -- Not that notYet is needed regardless of whether pSwictch or - -- dpSwitch is used. + -- dpSwitch for now. This makes kill/spawn events observable, + -- and allows feedback without iPre *in this case*, since only the + -- switching depends on the feedback, and hit detection does not + -- depend on any part of the fed-back output that in turn depends on + -- the hit detection. But this is a really fragile property! + -- Not that notYet is needed regardless of whether pSwictch or + -- dpSwitch is used. {- - game' :: IL Object -> SF (GameInput, IL ObjOutput) (IL ObjOutput) - game' objs = dpSwitch route - objs + game' :: IL Object -> SF (GameInput, IL ObjOutput) (IL ObjOutput) + game' objs = dpSwitch route + objs (arr killOrSpawn >>> notYet) - (\sfs' f -> game' (f sfs')) + (\sfs' f -> game' (f sfs')) -} - -- Slightly more efficient, and maybe clearer? - game' :: IL Object -> SF (GameInput, IL ObjOutput) (IL ObjOutput) - game' objs = dpSwitch route - objs + -- Slightly more efficient, and maybe clearer? + game' :: IL Object -> SF (GameInput, IL ObjOutput) (IL ObjOutput) + game' objs = dpSwitch route + objs (noEvent --> arr killOrSpawn) - (\sfs' f -> game' (f sfs')) + (\sfs' f -> game' (f sfs')) + -- IPerez: What's the difference between objs and sfs'? + -- Are sfs' the objs' continuations? 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 - then Event () - else noEvent, - oiGameInput = gi}, - obj) - hs = hits (assocsIL (fmap ooObsObjState oos)) + route (gi,oos) objs = mapIL routeAux objs + + where + routeAux (k, obj) = + (ObjInput {oiHit = if k `elem` hs + then Event () + else noEvent, + oiGameInput = gi}, + obj) + hs = hits (assocsIL (fmap ooObsObjState oos)) - -- This could be refined to full-fledged collision detection with - -- computation of proper impulses, and merging (adding) of multiple - -- impulses influencing a signle object. - hits :: [(ILKey, ObsObjState)] -> [ILKey] - hits kooss = concat (hitsAux kooss) - where - hitsAux [] = [] - 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)) + -- This could be refined to full-fledged collision detection with + -- computation of proper impulses, and merging (adding) of multiple + -- impulses influencing a single object. + hits :: [(ILKey, ObsObjState)] -> [ILKey] + hits kooss = concat (hitsAux kooss) + where + hitsAux [] = [] + 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 where - es :: [Event (IL Object -> IL Object)] + es :: [Event (IL Object -> IL Object)] es = [ mergeBy (.) (ooKillReq oo `tag` (deleteIL k)) (fmap (foldl (.) id . map insertIL_) @@ -203,4 +207,4 @@ HGL.withTextAlignment (HGL.Left', HGL.Top) $ HGL.text gp (show score) where - gp = position2ToGPoint (Point2 worldXMin worldYMax) + gp = position2ToGPoint (Point2 worldXMin worldYMax) diff --git a/src/Object.hs b/src/Object.hs --- a/src/Object.hs +++ b/src/Object.hs @@ -2,10 +2,10 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: Object * -* Purpose: Definition of objects in the world and their static * -* properties. * -* Author: Henrik Nilsson * +* Module: Object * +* Purpose: Definition of objects in the world and their static * +* properties. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -17,26 +17,26 @@ ObjInput(..), ObjOutput(..), ObsObjState(..), - oosGun, -- :: Position2 -> Velocity2 -> ObsObjState - oosMissile, -- :: Position2 -> Velocity2 -> ObsObjState - oosAlien, -- :: Position2 -> Heading -> Velocity2 -> ObsObjState - isGun, -- :: ObsObjState -> Bool - isMissile, -- :: ObsObjState -> Bool - isAlien, -- :: ObsObjState -> Bool - touches, -- :: ObsObjState -> ObsObjState -> Bool - approaches, -- :: ObsObjState -> ObsObjState -> Bool - colliding, -- :: ObsObjState -> ObsObjState -> Bool - gunRadius, -- :: Length - gunBase, -- :: Length - gunHeight, -- :: Length - gunSpeedMax, -- :: Speed - gunAccMax, -- :: Acceleration - missileRadius, -- :: Length + oosGun, -- :: Position2 -> Velocity2 -> ObsObjState + oosMissile, -- :: Position2 -> Velocity2 -> ObsObjState + oosAlien, -- :: Position2 -> Heading -> Velocity2 -> ObsObjState + isGun, -- :: ObsObjState -> Bool + isMissile, -- :: ObsObjState -> Bool + isAlien, -- :: ObsObjState -> Bool + touches, -- :: ObsObjState -> ObsObjState -> Bool + approaches, -- :: ObsObjState -> ObsObjState -> Bool + colliding, -- :: ObsObjState -> ObsObjState -> Bool + gunRadius, -- :: Length + gunBase, -- :: Length + gunHeight, -- :: Length + gunSpeedMax, -- :: Speed + gunAccMax, -- :: Acceleration + missileRadius, -- :: Length missileInitialSpeed,-- :: Speed - missileLifeSpan, -- :: Time - alienRadius, -- :: Length - alienWingRadius, -- :: Length - alienAccMax -- :: Acceleration + missileLifeSpan, -- :: Time + alienRadius, -- :: Length + alienWingRadius, -- :: Length + alienAccMax -- :: Acceleration ) where import FRP.Yampa (SF, Event) @@ -79,20 +79,20 @@ data ObsObjState = OOSGun { - oosPos :: !Position2, - oosVel :: !Velocity2, + oosPos :: !Position2, + oosVel :: !Velocity2, oosRadius :: !Length, oosAmLvl :: !Int } | OOSMissile { - oosPos :: !Position2, - oosVel :: !Velocity2, + oosPos :: !Position2, + oosVel :: !Velocity2, oosRadius :: !Length } | OOSAlien { - oosPos :: !Position2, - oosHdng :: !Heading, - oosVel :: !Velocity2, + oosPos :: !Position2, + oosHdng :: !Heading, + oosVel :: !Velocity2, oosRadius :: !Length } @@ -116,26 +116,26 @@ oosGun :: Position2 -> Velocity2 -> Int -> ObsObjState oosGun p v l = OOSGun { oosPos = p, - oosVel = v, - oosRadius = gunRadius, - oosAmLvl = l + oosVel = v, + oosRadius = gunRadius, + oosAmLvl = l } oosMissile :: Position2 -> Velocity2 -> ObsObjState oosMissile p v = OOSMissile { oosPos = p, - oosVel = v, - oosRadius = missileRadius + oosVel = v, + oosRadius = missileRadius } oosAlien :: Position2 -> Heading -> Velocity2 -> ObsObjState oosAlien p h v = OOSAlien { oosPos = p, - oosHdng = normalizeHeading h, - oosVel = v, - oosRadius = alienRadius + oosHdng = normalizeHeading h, + oosVel = v, + oosRadius = alienRadius } diff --git a/src/ObjectBehavior.hs b/src/ObjectBehavior.hs --- a/src/ObjectBehavior.hs +++ b/src/ObjectBehavior.hs @@ -2,9 +2,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: ObjectBehavior * -* Purpose: Behavior of objects. * -* Author: Henrik Nilsson * +* Module: ObjectBehavior * +* Purpose: Behavior of objects. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -12,14 +12,15 @@ -} module ObjectBehavior ( - gun, -- :: Position2 -> Object - missile, -- :: Position2 -> Velocity2 -> Object - alien -- :: RandomGen g => g -> Position2 -> Object + gun, -- :: Position2 -> Object + missile, -- :: Position2 -> Velocity2 -> Object + alien -- :: RandomGen g => g -> Position2 -> Object ) where import qualified System.Random as Random import FRP.Yampa +import FRP.Yampa.Integration import FRP.Yampa.Utilities import FRP.Yampa.Geometry @@ -36,15 +37,15 @@ gun :: Position2 -> Object gun (Point2 x0 y0) = proc (ObjInput {oiGameInput = gi}) -> do -- Position. - (Point2 xd _) <- ptrPos -< gi -- Desired position + (Point2 xd _) <- ptrPos -< gi -- Desired position rec -- Controller. - let ad = 10 * (xd - x) - 5 * v -- Desired acceleration + let ad = 10 * (xd - x) - 5 * v -- Desired acceleration -- Physics with hard limits on acceleration and speed. v <- integral -< let a = symLimit gunAccMax ad in - if (-gunSpeedMax) <= v && v <= gunSpeedMax + if (-gunSpeedMax) <= v && v <= gunSpeedMax || v < (-gunSpeedMax) && a > 0 || v > gunSpeedMax && a < 0 then a @@ -56,8 +57,8 @@ (level, fire) <- magazine 20 0.5 -< trigger returnA -< ObjOutput { - ooObsObjState = oosGun (Point2 x y0) (vector2 v 0) level, - ooKillReq = noEvent, + ooObsObjState = oosGun (Point2 x y0) (vector2 v 0) level, + ooKillReq = noEvent, ooSpawnReq = fire `tag` [missile (Point2 x (y0 + (gunHeight/2))) (vector2 v missileInitialSpeed)] @@ -67,9 +68,9 @@ -- Ammunition magazine. Reloaded up to maximal -- capacity at constant rate. -- n ... Maximal and initial number of missiles. --- f .......... Reload rate. --- input ...... Trigger. --- output ..... Tuple: +-- f .......... Reload rate. +-- input ...... Trigger. +-- output ..... Tuple: -- #1: Current number of missiles in magazine. -- #2: Missile fired event. magazine :: @@ -82,7 +83,7 @@ (trigger `tag` dec) `lMerge` (reload `tag` inc) returnA -< (level, - trigger `gate` canFire) + trigger `gate` canFire) where inc :: (Int,Bool) -> (Int, Bool) inc (l,_) | l < n = (l + 1, l > 0) @@ -92,12 +93,12 @@ | otherwise = (l, False) -- Ammunition magazine. Reloaded up to maximal capacity at constant rate. --- n .......... Maximal and initial number of missiles. --- f .......... Reload rate. --- input ...... Trigger. --- output ..... Tuple: --- #1 .... Current number of missiles in magazine. --- #2 .... Missile fired. +-- n .......... Maximal and initial number of missiles. +-- f .......... Reload rate. +-- input ...... Trigger. +-- output ..... Tuple: +-- #1 .... Current number of missiles in magazine. +-- #2 .... Missile fired. {- Henrik's original version, commented out for now: @@ -112,8 +113,8 @@ level <- hold n -< fmap fst newLevelFire returnA -< (level, filterE snd newLevelFire `tag` ()) where - -- inc, dec :: Int -> (Int, Maybe (Int, Bool)) - inc l | l < n = (l + 1, Just (l + 1, False)) + -- inc, dec :: Int -> (Int, Maybe (Int, Bool)) + inc l | l < n = (l + 1, Just (l + 1, False)) | otherwise = (l, Nothing) dec l | l > 0 = (l - 1, Just (l - 1, True)) | otherwise = (l, Nothing) @@ -133,11 +134,11 @@ vp <- iPre v0 -< v ffi <- forceField -< (p, vp) v <- (v0 ^+^) ^<< impulseIntegral -< (gravity, ffi) - p <- (p0 .+^) ^<< integral -< v + p <- (p0 .+^) ^<< integral -< v die <- after missileLifeSpan () -< () returnA -< ObjOutput { - ooObsObjState = oosMissile p v, - ooKillReq = oiHit oi `lMerge` die, + ooObsObjState = oosMissile p v, + ooKillReq = oiHit oi `lMerge` die, ooSpawnReq = noEvent } @@ -150,8 +151,8 @@ -- Alien behavior. --- g .......... Random generator. --- p0 ......... Initial position. +-- g .......... Random generator. +-- p0 ......... Initial position. -- vyd ........ Desired vertical speed. alien :: RandomGen g => g -> Position2 -> Velocity -> Object @@ -159,21 +160,21 @@ rec -- About 4% of time spent here. - -- Pick a desired horizontal position. + -- Pick a desired horizontal position. rx <- noiseR (worldXMin, worldXMax) g -< () sample <- occasionally g 5 () -< () xd <- hold (point2X p0) -< sample `tag` rx - + -- Controller. Control constants not optimized. Who says aliens know - -- anything about control theory? + -- anything about control theory? let axd = 5 * (xd - point2X p) - 3 * (vector2X v) - ayd = 20 * (vyd - (vector2Y v)) - ad = vector2 axd ayd - h = vector2Theta ad + ayd = 20 * (vyd - (vector2Y v)) + ad = vector2 axd ayd + h = vector2Theta ad -- About 46% of time spent in Physics.. - -- Physics - let a = vector2Polar (min alienAccMax (vector2Rho ad)) h + -- Physics + let a = vector2Polar (min alienAccMax (vector2Rho ad)) h vp <- iPre v0 -< v ffi <- forceField -< (p, vp) -- 28 % of time spent in the following line. @@ -181,19 +182,19 @@ -- 25 % of time spent on the following line. -- (Surprising: integral should be cheaper than impulseIntegral, -- plus it ides not add up!) - p <- (p0 .+^) ^<< integral -< v + p <- (p0 .+^) ^<< integral -< v - -- Shields - sl <- shield -< oiHit oi - die <- edge -< sl <= 0 + -- Shields + sl <- shield -< oiHit oi + die <- edge -< sl <= 0 returnA -< ObjOutput { - ooObsObjState = oosAlien p h v, - ooKillReq = die, + ooObsObjState = oosAlien p h v, + ooKillReq = die, ooSpawnReq = noEvent } where - v0 = zeroVector + v0 = zeroVector @@ -201,7 +202,7 @@ shield :: SF (Event ()) ShieldLevel shield = proc hit -> do rec - let rechargeRate = if sl < slMax then slMax / 10 else 0 + let rechargeRate = if sl < slMax then slMax / 10 else 0 sl <- (slMax +) ^<< impulseIntegral -< (rechargeRate, hit `tag` damage) returnA -< sl where @@ -224,11 +225,11 @@ field :: Position2 -> Acceleration2 field (Point2 x _) = vector2 (leftAcc - rightAcc) 0 ^+^ gravity where - leftAcc = min (if x > worldXMin + leftAcc = min (if x > worldXMin then k / (x - worldXMin)^3 else maxAcc) maxAcc - rightAcc = min (if x < worldXMax + rightAcc = min (if x < worldXMax then k / (worldXMax - x)^3 else maxAcc) maxAcc diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -2,10 +2,10 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: Parser * +* Module: Parser * * Purpose: Parsing (mainly lexical analysis) of window event * -* stream. * -* Author: Henrik Nilsson * +* stream. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -16,22 +16,22 @@ -- done better in the new AFRP framework. module Parser ( - GameInput, -- Abstract - parseWinInput, -- :: SF WinInput GameInput - command, -- :: SF GameInput (Event Command) - cmdString, -- :: SF GameInput (Event String) - ptrPos, -- :: SF GameInput Position2 - lbp, -- :: SF GameInput (Event ()) - lbpPos, -- :: SF GameInput (Event Position2) - lbDown, -- :: SF GameInput Bool - rbp, -- :: SF GameInput (Event ()) - rbpPos, -- :: SF GameInput (Event Position2) - rbDown, -- :: SF GameInput Bool - dragStart, -- :: SF GameInput (Event ()) - dragStop, -- :: SF GameInput (Event Distance2) - dragStartPos, -- :: SF GameInput Position2 - dragVec, -- :: SF GameInput Distance2 - dragging -- :: SF GameInput Bool + GameInput, -- Abstract + parseWinInput, -- :: SF WinInput GameInput + command, -- :: SF GameInput (Event Command) + cmdString, -- :: SF GameInput (Event String) + ptrPos, -- :: SF GameInput Position2 + lbp, -- :: SF GameInput (Event ()) + lbpPos, -- :: SF GameInput (Event Position2) + lbDown, -- :: SF GameInput Bool + rbp, -- :: SF GameInput (Event ()) + rbpPos, -- :: SF GameInput (Event Position2) + rbDown, -- :: SF GameInput Bool + dragStart, -- :: SF GameInput (Event ()) + dragStop, -- :: SF GameInput (Event Distance2) + dragStartPos, -- :: SF GameInput Position2 + dragVec, -- :: SF GameInput Distance2 + dragging -- :: SF GameInput Bool ) where import Data.Maybe (isNothing, isJust) @@ -62,7 +62,7 @@ parseWinInput :: SF WinInput GameInput parseWinInput = wiToCmd &&& wiToPDS >>^ \((cmdStr, cmd), pds) -> - GameInput {giCmdStr = cmdStr, giCmd = cmd, giPDS = pds} + GameInput {giCmdStr = cmdStr, giCmd = cmd, giPDS = pds} -- All event sources below are defined such that they will NOT occur at local @@ -152,7 +152,7 @@ scanChar (_, S cont) c = cont c selChar (HGL.Char {HGL.char=c}) = Just c - selChar _ = Nothing + selChar _ = Nothing -- This ought to be redone. Kont should probably be called Tranition or @@ -177,11 +177,11 @@ scanCmds = scanCmd cmds where cmds = - [ ("q", emitCmd scanCmds CmdQuit), -- Discard inp.? - ("p", emitCmd scanCmds CmdNewGame), - ("f", emitCmd scanCmds CmdFreeze), - ("r", emitCmd scanCmds CmdResume) - ] + [ ("q", emitCmd scanCmds CmdQuit), -- Discard inp.? + ("p", emitCmd scanCmds CmdNewGame), + ("f", emitCmd scanCmds CmdFreeze), + ("r", emitCmd scanCmds CmdResume) + ] -- Scan one command. @@ -189,7 +189,7 @@ -- prefix is valid. Starts over on first invalid character. Invokes success -- continuation on success. -- cmds ....... List of pairs of valid command and corresponding success --- continuation. +-- continuation. scanCmd :: [(String, Cont String)] -> Scanner scanCmd cmds = scanSubCmd "" cmds @@ -201,90 +201,90 @@ -- continuation on success. -- pfx0 ....... Initial prefix. -- cmds ....... List of pairs of valid command and corresponding success --- continuation. +-- continuation. scanSubCmd :: String -> [(String, Cont String)] -> Scanner scanSubCmd pfx0 cmds = S (scHlp pfx0 cmds) where - -- pfx ........ Command prefix. - -- sfxconts ... Command suffixes paired with success continuations. + -- pfx ........ Command prefix. + -- sfxconts ... Command suffixes paired with success continuations. -- c .......... Input character. scHlp pfx sfxconts c = - case c of - '\r' -> - case [ cont | ("", cont) <- sfxconts ] of - [] -> emitPfx (S (scHlp pfx sfxconts)) pfx - (cont : _) -> cont pfx - '.' -> - case sfxconts of - [] -> emitPfx (S (scHlp pfx0 cmds)) pfx0 - [(sfx, cont)] -> cont (pfx ++ sfx) - _ -> - let - (sfxs, conts) = unzip sfxconts - cpfx = foldr1 lcp sfxs - sfxs' = map (drop (length cpfx)) sfxs - pfx' = pfx ++ cpfx - sfxconts' = zip sfxs' conts - in - emitPfx (S (scHlp pfx' sfxconts')) pfx' - _ -> - let - pfx' = pfx ++ [c] - sfxconts' = [ (tail sfx, cont) - | (sfx, cont) <- sfxconts, - not (null sfx) && head sfx == c - ] - in - case sfxconts' of - [] -> emitPfx (S (scHlp pfx0 cmds)) - pfx0 - -- ("Invalid: " ++ [c]) - [("", cont)] -> cont pfx' - _ -> emitPfx (S (scHlp pfx' sfxconts')) - pfx' + case c of + '\r' -> + case [ cont | ("", cont) <- sfxconts ] of + [] -> emitPfx (S (scHlp pfx sfxconts)) pfx + (cont : _) -> cont pfx + '.' -> + case sfxconts of + [] -> emitPfx (S (scHlp pfx0 cmds)) pfx0 + [(sfx, cont)] -> cont (pfx ++ sfx) + _ -> + let + (sfxs, conts) = unzip sfxconts + cpfx = foldr1 lcp sfxs + sfxs' = map (drop (length cpfx)) sfxs + pfx' = pfx ++ cpfx + sfxconts' = zip sfxs' conts + in + emitPfx (S (scHlp pfx' sfxconts')) pfx' + _ -> + let + pfx' = pfx ++ [c] + sfxconts' = [ (tail sfx, cont) + | (sfx, cont) <- sfxconts, + not (null sfx) && head sfx == c + ] + in + case sfxconts' of + [] -> emitPfx (S (scHlp pfx0 cmds)) + pfx0 + -- ("Invalid: " ++ [c]) + [("", cont)] -> cont pfx' + _ -> emitPfx (S (scHlp pfx' sfxconts')) + pfx' -- Scan fixed-length integer argument. --- pfx0 ....... Initial prefix (command scanned thus far). --- n0 ......... Maximal number of digits. --- cont ....... Continuation: will be passed the new prefix and the --- integer value of the scanned argument. +-- pfx0 ....... Initial prefix (command scanned thus far). +-- n0 ......... Maximal number of digits. +-- cont ....... Continuation: will be passed the new prefix and the +-- integer value of the scanned argument. scanIntegerArg :: String -> Int -> Cont (String,Integer) -> Scanner scanIntegerArg pfx0 n0 cont | n0 > 0 = S (siaHlp (pfx0 ++ " ") n0 0) where siaHlp pfx n a c = - if c == '\r' then - cont (pfx, a) - else if isDigit c then - let a' = a * 10 + fromIntegral (ord c - ord '0') - pfx' = pfx ++ [c] - in - if n > 1 then - emitPfx (S (siaHlp pfx' (n - 1) a')) pfx' - else - cont (pfx', a') - else - emitPfx (S (siaHlp (pfx0 ++ " ") n0 0)) pfx0 + if c == '\r' then + cont (pfx, a) + else if isDigit c then + let a' = a * 10 + fromIntegral (ord c - ord '0') + pfx' = pfx ++ [c] + in + if n > 1 then + emitPfx (S (siaHlp pfx' (n - 1) a')) pfx' + else + cont (pfx', a') + else + emitPfx (S (siaHlp (pfx0 ++ " ") n0 0)) pfx0 -- Scan variable-length string argument. --- pfx0 ....... Initial prefix (command scanned thus far). --- cont ....... Continuation: will be passed the new prefix and the --- string value of the scanned argument. +-- pfx0 ....... Initial prefix (command scanned thus far). +-- cont ....... Continuation: will be passed the new prefix and the +-- string value of the scanned argument. scanStringArg :: String -> Cont (String,String) -> Scanner scanStringArg pfx0 cont = S (ssaHlp (pfx0 ++ " ") "") where ssaHlp pfx a c = - if c == '\r' then - cont (pfx, a) - else - let a' = dropWhile isSpace $ a ++ [c] - pfx' = pfx ++ [c] - in - emitPfx (S (ssaHlp pfx' a')) pfx' + if c == '\r' then + cont (pfx, a) + else + let a' = dropWhile isSpace $ a ++ [c] + pfx' = pfx ++ [c] + in + emitPfx (S (ssaHlp pfx' a')) pfx' -- Emit command (and command string), then continue scanning. @@ -307,24 +307,24 @@ data PDState = PDState { - pdsPos :: Position2, -- Current position. - pdsDragStartPos :: Position2, -- (Last) drag start position. - pdsDragVec :: Distance2, -- (Latest) drag vector. - pdsLeft :: Maybe Position2, -- Left button currently down. - pdsRight :: Maybe Position2, -- Right button currently down. - pdsDrag :: Maybe Position2 -- Currently dragging. + pdsPos :: Position2, -- Current position. + pdsDragStartPos :: Position2, -- (Last) drag start position. + pdsDragVec :: Distance2, -- (Latest) drag vector. + pdsLeft :: Maybe Position2, -- Left button currently down. + pdsRight :: Maybe Position2, -- Right button currently down. + pdsDrag :: Maybe Position2 -- Currently dragging. } -- Initial state. initPDS = PDState { - pdsPos = origin, - pdsDragStartPos = origin, - pdsDragVec = zeroVector, - pdsLeft = Nothing, - pdsRight = Nothing, - pdsDrag = Nothing - } + pdsPos = origin, + pdsDragStartPos = origin, + pdsDragVec = zeroVector, + pdsLeft = Nothing, + pdsRight = Nothing, + pdsDrag = Nothing + } wiToPDS :: SF WinInput PDState @@ -333,44 +333,44 @@ -- Compute next pointing device state. nextPDS :: PDState -> HGL.Event -> PDState -nextPDS pds (HGL.Key {}) = pds -- Currently we ignore keys. +nextPDS pds (HGL.Key {}) = pds -- Currently we ignore keys. nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = True, HGL.isDown = True}) = -- Left button pressed. pds {pdsPos = p', pdsDragVec = dv, pdsLeft = Just p'} where p' = gPointToPosition2 p - dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) (pdsDrag pds) + dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) (pdsDrag pds) nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = True, HGL.isDown = False}) = -- Left button released. pds {pdsPos = p', pdsDragVec = dv, pdsLeft = Nothing, pdsDrag = md} where p' = gPointToPosition2 p md = maybe Nothing (const (pdsDrag pds)) (pdsRight pds) - dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md + dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = False, HGL.isDown = True}) = -- Right button pressed. pds {pdsPos = p', pdsDragVec = dv, pdsRight = Just p'} where p' = gPointToPosition2 p - dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) (pdsDrag pds) + dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) (pdsDrag pds) nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = False, HGL.isDown = False}) = -- Right button released. pds {pdsPos = p', pdsDragVec = dv, pdsRight = Nothing, pdsDrag = md} where p' = gPointToPosition2 p md = maybe Nothing (const (pdsDrag pds)) (pdsLeft pds) - dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md + dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md nextPDS pds (HGL.MouseMove {HGL.pt = p}) = -- Mouse move. pds {pdsPos = p', pdsDragStartPos = dsp, pdsDragVec = dv, pdsDrag = md} where p' = gPointToPosition2 p md = case pdsLeft pds of - mlp@(Just _) -> mlp - Nothing -> pdsRight pds + mlp@(Just _) -> mlp + Nothing -> pdsRight pds dsp = maybe (pdsDragStartPos pds) id md - dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md -nextPDS pds _ = pds -- Ignore unknown events. + dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md +nextPDS pds _ = pds -- Ignore unknown events. ------------------------------------------------------------------------------ diff --git a/src/PhysicalDimensions.hs b/src/PhysicalDimensions.hs --- a/src/PhysicalDimensions.hs +++ b/src/PhysicalDimensions.hs @@ -2,13 +2,13 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: PhysicalDimensions * -* Purpose: Type synonyms for physical dimensions and some * -* related operations. * -* Author: Henrik Nilsson * +* Module: PhysicalDimensions * +* Purpose: Type synonyms for physical dimensions and some * +* related operations. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * -* * +* * ****************************************************************************** -} @@ -45,10 +45,10 @@ Acceleration3, -- Operations - normalizeAngle, -- :: Angle -> Angle - normalizeHeading, -- :: Heading -> Heading - bearingToHeading, -- :: Bearing -> Heading - headingToBearing -- :: Heading -> Bearing + normalizeAngle, -- :: Angle -> Angle + normalizeHeading, -- :: Heading -> Heading + bearingToHeading, -- :: Bearing -> Heading + headingToBearing -- :: Heading -> Bearing ) where import FRP.Yampa (Time, DTime) @@ -72,14 +72,14 @@ type Frequency = InvaderReal -- [Hz] type Mass = InvaderReal -- [kg] type Length = InvaderReal -- [m] -type Position = InvaderReal -- [m] (absolute) -type Distance = InvaderReal -- [m] (relative) +type Position = InvaderReal -- [m] (absolute) +type Distance = InvaderReal -- [m] (relative) type Speed = InvaderReal -- [m/s] (unsigned, speed = abs(velocity)) type Velocity = InvaderReal -- [m/s] (signed) type Acceleration = InvaderReal -- [m/s^2] type Angle = InvaderReal -- [rad] (relative) type Heading = InvaderReal -- [rad] (angle relative to x-axis = east) -type Bearing = InvaderReal -- [deg] (compass direction, 0 = N, 90 = E) +type Bearing = InvaderReal -- [deg] (compass direction, 0 = N, 90 = E) type RotVel = InvaderReal -- [rad/s] type RotAcc = InvaderReal -- [rad/s^2] @@ -88,20 +88,20 @@ -- Two-dimensional types ------------------------------------------------------------------------------ -type Position2 = Point2 Position -- [m] (absolute) -type Distance2 = Vector2 Distance -- [m] (relative) -type Velocity2 = Vector2 Velocity -- [m/s] -type Acceleration2 = Vector2 Acceleration -- [m/s^2] +type Position2 = Point2 Position -- [m] (absolute) +type Distance2 = Vector2 Distance -- [m] (relative) +type Velocity2 = Vector2 Velocity -- [m/s] +type Acceleration2 = Vector2 Acceleration -- [m/s^2] ------------------------------------------------------------------------------ -- Three-dimensional types ------------------------------------------------------------------------------ -type Position3 = Point3 Position -- [m] (absolute) -type Distance3 = Vector3 Distance -- [m] (relative) -type Velocity3 = Vector3 Velocity -- [m/s] -type Acceleration3 = Vector3 Acceleration -- [m/s^2] +type Position3 = Point3 Position -- [m] (absolute) +type Distance3 = Vector3 Distance -- [m] (relative) +type Velocity3 = Vector3 Velocity -- [m/s] +type Acceleration3 = Vector3 Acceleration -- [m/s^2] ------------------------------------------------------------------------------ diff --git a/src/RenderLandscape.hs b/src/RenderLandscape.hs --- a/src/RenderLandscape.hs +++ b/src/RenderLandscape.hs @@ -2,9 +2,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: RenderLandscape * -* Purpose: Rendering of the fixed backdrop. * -* Author: Henrik Nilsson * +* Module: RenderLandscape * +* Purpose: Rendering of the fixed backdrop. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -12,7 +12,7 @@ -} module RenderLandscape ( - landscape -- :: HGL.Graphic + landscape -- :: HGL.Graphic ) where import Data.Array @@ -35,10 +35,10 @@ HGL.mkBrush (colorTable ! closeMountainColor) $ \cmcBrush -> HGL.mkBrush (colorTable ! groundColor) $ \groundBrush -> HGL.overGraphics - [ HGL.withBrush groundBrush $ HGL.polygon groundPoints, + [ HGL.withBrush groundBrush $ HGL.polygon groundPoints, HGL.withBrush cmcBrush $ HGL.polygon cmPoints, HGL.withBrush dmcBrush $ HGL.polygon dmPoints - ] + ] -- Points defining the distant mountain chain. diff --git a/src/RenderObject.hs b/src/RenderObject.hs --- a/src/RenderObject.hs +++ b/src/RenderObject.hs @@ -2,9 +2,9 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: RenderObject * -* Purpose: Object rendering. * -* Author: Henrik Nilsson * +* Module: RenderObject * +* Purpose: Object rendering. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -12,7 +12,7 @@ -} module RenderObject ( - renderObjects -- :: [ObjObjState] -> HGL.Graphic + renderObjects -- :: [ObjObjState] -> HGL.Graphic ) where import Data.Array @@ -41,7 +41,7 @@ centeredText Green (p .-^ vector2 0 (gunHeight/2)) (show l) `HGL.overGraphic` triangle gunColor p1 p2 p3 where - p1 = p .+^ vector2 0 (gunHeight/2) + p1 = p .+^ vector2 0 (gunHeight/2) p2 = p .+^ vector2 (-(gunBase/2)) (-(gunHeight/2)) p3 = p .+^ vector2 (gunBase/2) (-(gunHeight/2)) renderObject (OOSMissile {oosPos = p}) = circle missileColor p missileRadius @@ -50,8 +50,8 @@ `HGL.overGraphic` (circle alienDoorColor p3 (alienRadius/3)) `HGL.overGraphic` (circle alienColor p alienRadius) where - p1 = p .+^ v - p2 = p .-^ v + p1 = p .+^ v + p2 = p .-^ v p3 = p .+^ vector2Polar (alienRadius / 2) h v = vector2Polar alienWingRadius (h + pi/2) @@ -60,45 +60,45 @@ line c p1 p2 = -- Line style and thiknes seems to be ignored completely? HGL.mkPen HGL.Dash 2 (colorTable ! c) $ \pen -> - HGL.withPen pen $ + HGL.withPen pen $ HGL.line gp1 gp2 where gp1 = position2ToGPoint p1 - gp2 = position2ToGPoint p2 + gp2 = position2ToGPoint p2 triangle :: Color -> Position2 -> Position2 -> Position2 -> HGL.Graphic triangle c p1 p2 p3 = HGL.mkBrush (colorTable ! c) $ \brush -> - HGL.withBrush brush $ + HGL.withBrush brush $ HGL.polygon [gp1, gp2, gp3] where gp1 = position2ToGPoint p1 - gp2 = position2ToGPoint p2 - gp3 = position2ToGPoint p3 + gp2 = position2ToGPoint p2 + gp3 = position2ToGPoint p3 rectangle :: Color -> Position2 -> Position2 -> HGL.Graphic rectangle c p1 p2 = HGL.mkBrush (colorTable ! c) $ \brush -> - HGL.withBrush brush $ + HGL.withBrush brush $ HGL.polygon [gp11, gp12, gp22, gp21] where gp11@(x1,y1) = position2ToGPoint p1 - gp12 = (x1, y2) - gp22@(x2,y2) = position2ToGPoint p2 - gp21 = (x2, y1) + gp12 = (x1, y2) + gp22@(x2,y2) = position2ToGPoint p2 + gp21 = (x2, y1) circle :: Color -> Position2 -> Length -> HGL.Graphic circle c p r = HGL.mkBrush (colorTable ! c) $ \brush -> - HGL.withBrush brush $ + HGL.withBrush brush $ HGL.ellipse gp11 gp22 where d = vector2 r r gp11 = position2ToGPoint (p .-^ d) - gp22 = position2ToGPoint (p .+^ d) + gp22 = position2ToGPoint (p .+^ d) {- @@ -106,13 +106,13 @@ bbox p1 p2 = -- Line style and thiknes seems to be ignored completely? HGL.mkPen HGL.Dash 2 (colorTable ! bboxColor) $ \pen -> - HGL.withPen pen $ + HGL.withPen pen $ HGL.polyline [gp11, gp12, gp22, gp21, gp11] where gp11@(x1,y1) = position2ToGPoint p1 - gp12 = (x1, y2) - gp22@(x2,y2) = position2ToGPoint p2 - gp21 = (x2, y1) + gp12 = (x1, y2) + gp22@(x2,y2) = position2ToGPoint p2 + gp21 = (x2, y1) -} centeredText :: Color -> Position2 -> String -> HGL.Graphic @@ -121,14 +121,14 @@ HGL.withTextAlignment (HGL.Center, HGL.Baseline) $ HGL.text gp s where - gp = position2ToGPoint p + gp = position2ToGPoint p {- -- Centering pretty ad hoc. centeredText :: Position2 -> String -> HGL.Graphic centeredText p s = HGL.text (x', y') s where - (x,y) = position2ToGPoint p + (x,y) = position2ToGPoint p x' = x - (445 * length s) `div` 100 y' = y - 7 -} diff --git a/src/WorldGeometry.hs b/src/WorldGeometry.hs --- a/src/WorldGeometry.hs +++ b/src/WorldGeometry.hs @@ -2,10 +2,10 @@ ****************************************************************************** * I N V A D E R S * * * -* Module: WorldGeometry * -* Purpose: Constants and functions defining the geometry of * -* the world. * -* Author: Henrik Nilsson * +* Module: WorldGeometry * +* Purpose: Constants and functions defining the geometry of * +* the world. * +* Author: Henrik Nilsson * * * * Copyright (c) Yale University, 2003 * * * @@ -78,7 +78,7 @@ gPointToPosition2 :: HGL.Point -> Position2 gPointToPosition2 (x, y) = (Point2 (pixelsToMeters x + worldXMin) - (worldYMax - pixelsToMeters y)) + (worldYMax - pixelsToMeters y)) {-