SpaceInvaders 0.4.2 → 0.4.4
raw patch · 15 files changed
+552/−533 lines, 15 filesnew-uploader
Files
- SpaceInvaders.cabal +8/−4
- src/Animate.hs +101/−91
- src/ColorBindings.hs +6/−6
- src/Colors.hs +58/−58
- src/Command.hs +7/−7
- src/Diagnostics.hs +3/−3
- src/IdentityList.hs +27/−27
- src/Main.hs +91/−87
- src/Object.hs +38/−38
- src/ObjectBehavior.hs +47/−46
- src/Parser.hs +111/−111
- src/PhysicalDimensions.hs +20/−20
- src/RenderLandscape.hs +6/−6
- src/RenderObject.hs +24/−24
- src/WorldGeometry.hs +5/−5
SpaceInvaders.cabal view
@@ -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 <ivan.perez@keera.co.uk> 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
src/Animate.hs view
@@ -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 ------------------------------------------------------------------------------
src/ColorBindings.hs view
@@ -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 ------------------------------------------------------------------------------
src/Colors.hs view
@@ -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) ]
src/Command.hs view
@@ -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.
src/Diagnostics.hs view
@@ -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 * * *
src/IdentityList.hs view
@@ -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]
src/Main.hs view
@@ -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)
src/Object.hs view
@@ -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 }
src/ObjectBehavior.hs view
@@ -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
src/Parser.hs view
@@ -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. ------------------------------------------------------------------------------
src/PhysicalDimensions.hs view
@@ -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] ------------------------------------------------------------------------------
src/RenderLandscape.hs view
@@ -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.
src/RenderObject.hs view
@@ -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 -}
src/WorldGeometry.hs view
@@ -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)) {-