SpaceInvaders (empty) → 0.4.1
raw patch · 17 files changed
+2243/−0 lines, 17 filesdep +HGLdep +Yampadep +arraysetup-changed
Dependencies added: HGL, Yampa, array, base, random
Files
- LICENSE +29/−0
- Setup.hs +2/−0
- SpaceInvaders.cabal +33/−0
- src/Animate.hs +219/−0
- src/ColorBindings.hs +37/−0
- src/Colors.hs +150/−0
- src/Command.hs +23/−0
- src/Diagnostics.hs +19/−0
- src/IdentityList.hs +168/−0
- src/Main.hs +206/−0
- src/Object.hs +265/−0
- src/ObjectBehavior.hs +264/−0
- src/Parser.hs +385/−0
- src/PhysicalDimensions.hs +133/−0
- src/RenderLandscape.hs +82/−0
- src/RenderObject.hs +134/−0
- src/WorldGeometry.hs +94/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++- Neither name of the copyright holders nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS+OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ SpaceInvaders.cabal view
@@ -0,0 +1,33 @@+name: SpaceInvaders+version: 0.4.1+cabal-Version: >= 1.2+license: BSD3+license-file: LICENSE+author: Henrik Nilsson, Antony Courtney+maintainer: George Giorgidze (GGG at CS dot NOTT dot AC dot UK)+homepage: http://www.haskell.org/yampa/+category: Game+synopsis: Video game+description: Video game implemented in Yampa. +build-type: Simple++executable spaceInvaders+ hs-source-dirs: src+ ghc-options : -O2 -Wall -fno-warn-name-shadowing+ build-Depends: base, array, random, HGL, Yampa >= 0.9.2+ main-is: Main.hs+ Extensions: Arrows+ Other-Modules:+ Animate+ ColorBindings+ Colors+ Command+ Diagnostics+ IdentityList+ Object+ ObjectBehavior+ Parser+ PhysicalDimensions+ RenderLandscape+ RenderObject+ WorldGeometry
+ src/Animate.hs view
@@ -0,0 +1,219 @@+{- $Id: Animate.hs,v 1.3 2004/11/18 13:02:26 henrik Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: Animate *+* Purpose: Animation of graphical signal functions. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++-- Approach: The signal function is sampled as frequently as possible. It's+-- the OS's task to allocate resources, so we can just as well use up all the+-- CPU cycles we get. But since drawing is very time consuming, we draw at a+-- fixed, user-defineable, presumably lower rate, thus allowing the user to+-- control the ratio between the cycles spent on drawing and the cycles spent+-- on editing/simulation. This approach may result in rather uneven sampling+-- intervals, but embedSynch can be used to provide a stable time base when+-- that is important, e.g. for simulation, as long as there are enough cycles+-- on average to keep up.+--+-- For some reason, context switching does not work as it should unless+-- the window tick mechanism is enabled. For that reason, we use a high+-- frequency tick (1kHz). (Alternatively, passing the -C runtime flag (e.g.+-- +RTS -C1) forces regular context switches. Moreover, getting events+-- without delay seems to require yielding to ensure that the thread+-- receiving them gets a chance to run. This can be done using yield prior to+-- galling HGL.maybeGetWindowEvent. Alternatively, we can get the window tick,+-- and since the tick frequency is high, no major waiting should ensue. This+-- is the current method, although it seems as if this method means that+-- window close events often will be missed.++module Animate (WinInput, animate) where++import Control.Monad (when)+import Data.Maybe (isJust, fromJust)+-- import Posix (SysVar(..), ProcessTimes, ClockTick,+-- getSysVar, getProcessTimes, elapsedTime)+-- import Concurrent (yield)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import qualified Graphics.HGL as HGL++import FRP.Yampa+import FRP.Yampa.Internals -- Breaking the Event abstraction barrier here!+import FRP.Yampa.Task (repeatUntil, forAll)+import FRP.Yampa.Forceable++import Diagnostics (intErr)+import PhysicalDimensions+++type WinInput = Event HGL.Event+++------------------------------------------------------------------------------+-- Animation+------------------------------------------------------------------------------++-- Animate a signal function+-- fr ......... Frame rate.+-- title ...... Window title.+-- width ...... Window width in pixels.+-- height ..... Window height in pixels.+-- render ..... Renderer; invoked at the frame rate.+-- tco ........ Text Console Output; invoked at every step.+-- sf ......... Signal function to animate.++-- !!! Note: it would be easy to add an argument (a -> IO b) as well, allowing+-- !!! arbitrary I/O. One could even replace the text output by such a+-- !!! function. Could one possibly somehow get data back into the signal+-- !!! 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+ win <- HGL.openWindowEx title+ Nothing -- Initial position.+ (width, height) -- Size.+ HGL.DoubleBuffered -- Painfully SLOW!!!+ -- HGL.Unbuffered -- Flickers!+ (Just 1) -- For scheduling!?!+ (init, getTimeInput, isClosed) <- mkInitAndGetTimeInput win+{-+ reactimate init+ getTimeInput+ (\_ ea@(e,a) -> do+ updateWin render win ea+ forAll (tco a) putStrLn+ isClosed)+ (repeatedly (1/fr) () &&& sf)+-}+ reactimate init+ getTimeInput+ (\_ (ea@(e,a), (e', c)) -> do+ updateWin render win ea+ forAll (tco a) putStrLn+ 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+++------------------------------------------------------------------------------+-- Support for reading time and input+------------------------------------------------------------------------------++mkInitAndGetTimeInput+ :: HGL.Window+ -> IO (IO WinInput, Bool -> IO (DTime,Maybe WinInput), IO Bool)+mkInitAndGetTimeInput win = do+ -- clkRes <- fmap fromIntegral (getSysVar ClockTick)+ let clkRes = 1000+ tpRef <- newIORef errInitNotCalled+ wepRef <- newIORef errInitNotCalled+ weBufRef <- newIORef Nothing+ closedRef <- newIORef False+ let init = do+ t0 <- getElapsedTime+ writeIORef tpRef t0+ mwe <- getWinInput win weBufRef+ writeIORef wepRef mwe+ 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++ -- 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++ maybeToEvent :: Maybe a -> Event a+ maybeToEvent = maybe NoEvent Event+++-- 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'+ where+ 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.+ -- Maybe the process typically dies before the waiting time is up in+ -- the latter case?+ gwi win = do+ -- yield+ HGL.getWindowTick win+ mwe <- HGL.maybeGetWindowEvent win+ return mwe+++------------------------------------------------------------------------------+-- Support for output+------------------------------------------------------------------------------++-- Need to force non-displayed elements to avoid space leaks.+-- We also explicitly force displayed elements in case the renderer does not+-- force everything.+updateWin ::+ Forceable a => (a -> HGL.Graphic) -> HGL.Window -> (Event (), a) -> IO ()+updateWin render win (e, a) = when (force a `seq` isEvent e)+ (HGL.setGraphic win (render a))
+ src/ColorBindings.hs view
@@ -0,0 +1,37 @@+{- $Id: ColorBindings.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: ColorBindings *+* Purpose: Definition of colours for various objects. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module ColorBindings where++import Colors++------------------------------------------------------------------------------+-- Landscape colors+------------------------------------------------------------------------------++distantMountainColor = MidnightBlue+closeMountainColor = Purple+groundColor = Red+++------------------------------------------------------------------------------+-- Object colour bindings+------------------------------------------------------------------------------++gunColor = White++missileColor = Yellow++alienColor = LimeGreen+alienWingColor = CornflowerBlue+alienDoorColor = Orange
+ src/Colors.hs view
@@ -0,0 +1,150 @@+{- $Id: Colors.hs,v 1.3 2004/11/18 13:02:26 henrik Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: Colors *+* Purpose: Colour definitions. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module Colors (Color(..), RGB, colorTable) where++import Data.Array+import Graphics.HGL (RGB(..))+++------------------------------------------------------------------------------+-- Color definitions+------------------------------------------------------------------------------++-- Pretty arbitrary selection of colours.+data Color =+-- Basic colours.+ Black+ | Blue+ | Green+ | Cyan+ | Red+ | Magenta+ | Yellow+ | White+-- Various greys.+ | DarkGrey+ | DimGrey+ | Grey+ | LightGrey+ | DarkSlateGrey+ | SlateGrey+ | LightSlateGrey+-- Various blues/cyan.+ | MidnightBlue+ | NavyBlue+ | CornflowerBlue+ | DarkSlateBlue+ | SlateBlue+ | LightSlateBlue+ | MediumBlue+ | RoyalBlue+ | DeepSkyBlue+ | SteelBlue+ | CadetBlue+-- Various greens/olive greens/khaki.+ | DarkGreen+ | DarkOliveGreen+ | SeaGreen+ | MediumSeaGreen+ | LawnGreen+ | LimeGreen+ | ForestGreen+ | OliveDrab+ | DarkKhaki+ | Khaki+-- Various oranges/browns.+ | Goldenrod+ | DarkGoldenrod+ | SaddleBrown+ | Orange+-- Various violets/purples.+ | Maroon+ | MediumVioletRed+ | VioletRed+ | Violet+ | Plum+ | Orchid+ | MediumOrchid+ | DarkOrchid+ | BlueViolet+ | Purple+ deriving (Eq, Ord, Bounded, Enum, Ix)++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),++ -- 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 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 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)+ ]+++colorTable = array (minBound, maxBound) colorList
+ src/Command.hs view
@@ -0,0 +1,23 @@+{- $Id: Command.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: Command *+* Purpose: The Invader command type. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module Command (+ Command(..)+) where+++data Command =+ CmdQuit -- Quit Invaders.+ | CmdNewGame -- Play game.+ | CmdFreeze -- Freeze game.+ | CmdResume -- Resume game.
+ src/Diagnostics.hs view
@@ -0,0 +1,19 @@+{- $Id: Diagnostics.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: Diagnostics *+* Purpose: Standardized error-reporting for Invaders *+* Authors: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module Diagnostics where++usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)++intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "+ ++ msg)
+ src/IdentityList.hs view
@@ -0,0 +1,168 @@+{- $Id: IdentityList.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+* 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 *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++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+ 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]+ mapFindAllIL -- :: ((ILKey, a) -> Maybe b) -> IL a -> [b]+) where++import Data.List (find)+++------------------------------------------------------------------------------+-- Data type definitions+------------------------------------------------------------------------------++type ILKey = Int++-- Invariants:+-- * Sorted in descending key order. (We don't worry about+-- key wrap around).+-- * Keys are NOT reused+data IL a = IL { ilNextKey :: ILKey, ilAssocs :: [(ILKey, a)] }+++------------------------------------------------------------------------------+-- Class instances+------------------------------------------------------------------------------++instance Functor IL where+ fmap f (IL {ilNextKey = nk, ilAssocs = kas}) =+ IL {ilNextKey = nk, ilAssocs = [ (i, f a) | (i, a) <- kas ]}+++------------------------------------------------------------------------------+-- Constructors+------------------------------------------------------------------------------++emptyIL :: IL a+emptyIL = IL {ilNextKey = 0, ilAssocs = []}+++insertIL_ :: a -> IL a -> IL a+insertIL_ a il = snd (insertIL a il)+++insertIL :: a -> IL a -> (ILKey, IL a)+insertIL a (IL {ilNextKey = k, ilAssocs = kas}) = (k, il') where+ il' = IL {ilNextKey = k + 1, ilAssocs = (k, a) : kas}+++listToIL :: [a] -> IL a+listToIL as = IL {ilNextKey = length as,+ ilAssocs = reverse (zip [0..] as)} -- Maintain invariant!+++------------------------------------------------------------------------------+-- Additional selectors+------------------------------------------------------------------------------++assocsIL :: IL a -> [(ILKey, a)]+assocsIL = ilAssocs+++keysIL :: IL a -> [ILKey]+keysIL = map fst . ilAssocs+++elemsIL :: IL a -> [a]+elemsIL = map snd . ilAssocs+++------------------------------------------------------------------------------+-- Mutators+------------------------------------------------------------------------------++deleteIL :: ILKey -> IL a -> IL a+deleteIL k (IL {ilNextKey = nk, ilAssocs = kas}) =+ IL {ilNextKey = nk, ilAssocs = deleteHlp kas}+ where+ deleteHlp [] = []+ deleteHlp kakas@(ka@(k', _) : kas) | k > k' = kakas+ | k == k' = kas+ | otherwise = ka : deleteHlp kas+++------------------------------------------------------------------------------+-- Filter and map operations+------------------------------------------------------------------------------++-- These are "identity-preserving", i.e. the key associated with an element+-- in the result is the same as the key of the element from which the+-- result element was derived.++mapIL :: ((ILKey, a) -> b) -> IL a -> IL b+mapIL f (IL {ilNextKey = nk, ilAssocs = kas}) =+ IL {ilNextKey = nk, ilAssocs = [(k, f ka) | ka@(k,_) <- kas]}+++filterIL :: ((ILKey, a) -> Bool) -> IL a -> IL a+filterIL p (IL {ilNextKey = nk, ilAssocs = kas}) =+ IL {ilNextKey = nk, ilAssocs = filter p kas}+++mapFilterIL :: ((ILKey, a) -> Maybe b) -> IL a -> IL b+mapFilterIL p (IL {ilNextKey = nk, ilAssocs = kas}) =+ IL {+ ilNextKey = nk,+ ilAssocs = [(k, b) | ka@(k, _) <- kas, Just b <- [p ka]]+ }+++------------------------------------------------------------------------------+-- Lookup operations+------------------------------------------------------------------------------++lookupIL :: ILKey -> IL a -> Maybe a+lookupIL k il = lookup k (ilAssocs il)+++findIL :: ((ILKey, a) -> Bool) -> IL a -> Maybe a+findIL p (IL {ilAssocs = kas}) = findHlp kas+ where+ 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 (ka : kas) = case p ka of+ Nothing -> mapFindHlp kas+ jb@(Just _) -> jb+++findAllIL :: ((ILKey, a) -> Bool) -> IL a -> [a]+findAllIL p (IL {ilAssocs = kas}) = [ a | ka@(_, a) <- kas, p ka ]+++mapFindAllIL:: ((ILKey, a) -> Maybe b) -> IL a -> [b]+mapFindAllIL p (IL {ilAssocs = kas}) = [ b | ka <- kas, Just b <- [p ka] ]
+ src/Main.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE Arrows #-}++{-+******************************************************************************+* I N V A D E R S *+* *+* Module: Main *+* Purpose: Main module. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module Main where++import System.Random++import Data.Maybe (isJust)+import Data.Array++import FRP.Yampa+import FRP.Yampa.Geometry+import qualified Graphics.HGL as HGL++-- Temporary, just to make sure all modules compile.+import Animate+import IdentityList+import Colors+import Object+import ObjectBehavior+import Parser+import PhysicalDimensions+import RenderLandscape+import RenderObject+import WorldGeometry++type Score = Int++main :: IO ()+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)+ (\_ -> [])+ (parseWinInput >>> restartingGame g)+++-- Change name to "game"? What's now "game" would become "gameRound".+-- What about "game'"?+restartingGame :: RandomGen g => g -> SF GameInput (Int, [ObsObjState])+restartingGame g = rgAux g nAliens0 vydAlien0 0+ where+ 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+++-- How to arrange for splitting of g in general if we have spawning of aliens+-- "inside" the game? The spawner should+-- keep control over the supply of random generators.++game :: RandomGen g => g -> Int -> Velocity -> Score ->+ SF GameInput ((Int, [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.+ -- iPre not needed in the feedback path as long as dpSwitch is used,+ -- but there are many side conditions related to the game. E.g.+ -- the parts of the fed-back output used for hit detection not depending+ -- on the result of the hit detection and so on. So for robustness,+ -- maybe safest to leave the delay in.+ --+ -- BUT! We cannot have BOTH dpSwitch and iPre! That will cause e.g.+ -- hitting shots to be "seen" twice, due to a "double delay", and+ -- that in turn will inflict double dammage.+ --+ -- We could do score keeping *in this case* by simply *continusouly*+ -- counting the number of aliens. This count can be used both to detect+ -- a new round, and for computing the score as nAliens - alienCount.+ -- But this does not exactly invite to more elaborate scoring schemes.+ -- it would also be difficult to have different kinds of aliens of+ -- varying value, since the natural way to do that is to look at the+ -- actual object that is being removed in order to figure out its value,+ -- rather than tryingto figure out a score indirectly through the+ -- absence of objects!+ rec+ oos <- game' objs0 -< (gi, oos {- oosp -})+ {- oosp <- iPre emptyIL -< oos -}+ 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)))+ 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 _ _ _ _ = []+ + 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++ 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.+{-+ game' :: IL Object -> SF (GameInput, IL ObjOutput) (IL ObjOutput)+ game' objs = dpSwitch route+ objs+ (arr killOrSpawn >>> notYet)+ (\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+ (noEvent --> arr killOrSpawn)+ (\sfs' f -> game' (f sfs'))+++ 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))+++ -- 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))+ killOrSpawn (_, oos) =+ foldl (mergeBy (.)) noEvent es+ where+ es :: [Event (IL Object -> IL Object)]+ es = [ mergeBy (.)+ (ooKillReq oo `tag` (deleteIL k))+ (fmap (foldl (.) id . map insertIL_)+ (ooSpawnReq oo))+ | (k,oo) <- assocsIL oos ]+++renderScore :: Score -> HGL.Graphic+renderScore score = + HGL.withTextColor (colorTable ! White) $+ HGL.withTextAlignment (HGL.Left', HGL.Top) $+ HGL.text gp (show score)+ where+ gp = position2ToGPoint (Point2 worldXMin worldYMax)
+ src/Object.hs view
@@ -0,0 +1,265 @@+{- $Id: Object.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: Object *+* Purpose: Definition of objects in the world and their static *+* properties. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module Object (+ Object,+ 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+ missileInitialSpeed,-- :: Speed+ missileLifeSpan, -- :: Time+ alienRadius, -- :: Length+ alienWingRadius, -- :: Length+ alienAccMax -- :: Acceleration+) where++import FRP.Yampa (SF, Event)+import FRP.Yampa.Geometry+import FRP.Yampa.Forceable++import Parser (GameInput)+import PhysicalDimensions+import WorldGeometry+++------------------------------------------------------------------------------+-- Object and related types+------------------------------------------------------------------------------++-- Objects are represented by signal functions, i.e. they are reactive and+-- can carry internal state.++type Object = SF ObjInput ObjOutput++data ObjInput = ObjInput {+ oiHit :: Event (),+ oiGameInput :: GameInput+}++data ObjOutput = ObjOutput {+ ooObsObjState :: !ObsObjState,+ ooKillReq :: Event (),+ ooSpawnReq :: Event [Object]+}++-- Note: ObsObjState (Observable Object State) should only be constructed/+-- updated through the provided constructors/update functions since some of+-- the fields (e.g. if a bounding box field were added) might be dependent on+-- others. The reason ObsObjState is not exported abstractly is that it is+-- convenient to inspect it by pattern matching.+-- +-- To avoid space leaks, all fields (except possibly dependent ones) are+-- strict.++data ObsObjState =+ OOSGun {+ oosPos :: !Position2,+ oosVel :: !Velocity2,+ oosRadius :: !Length,+ oosAmLvl :: !Int+ }+ | OOSMissile {+ oosPos :: !Position2,+ oosVel :: !Velocity2,+ oosRadius :: !Length+ }+ | OOSAlien {+ oosPos :: !Position2,+ oosHdng :: !Heading,+ oosVel :: !Velocity2,+ oosRadius :: !Length+ }+++------------------------------------------------------------------------------+-- Instances+------------------------------------------------------------------------------++instance Forceable ObsObjState where+ -- If non-strict fields: oosNonStrict1 obj `seq` ... `seq` obj + force obj = obj+++------------------------------------------------------------------------------+-- Smart constructors+------------------------------------------------------------------------------++-- If dependent fields (such as a bounding box) are added, these should also+-- be computed here.++oosGun :: Position2 -> Velocity2 -> Int -> ObsObjState+oosGun p v l = OOSGun {+ oosPos = p,+ oosVel = v,+ oosRadius = gunRadius,+ oosAmLvl = l+ }+++oosMissile :: Position2 -> Velocity2 -> ObsObjState+oosMissile p v = OOSMissile {+ oosPos = p,+ oosVel = v,+ oosRadius = missileRadius+ }+++oosAlien :: Position2 -> Heading -> Velocity2 -> ObsObjState+oosAlien p h v = OOSAlien {+ oosPos = p,+ oosHdng = normalizeHeading h,+ oosVel = v,+ oosRadius = alienRadius+ }+++------------------------------------------------------------------------------+-- Recognizers+------------------------------------------------------------------------------++isGun :: ObsObjState -> Bool+isGun (OOSGun {}) = True+isGun _ = False+++isMissile :: ObsObjState -> Bool+isMissile (OOSMissile {}) = True+isMissile _ = False+++isAlien :: ObsObjState -> Bool+isAlien (OOSAlien {}) = True+isAlien _ = False+++------------------------------------------------------------------------------+-- Object and bounding box geometrical predicates+------------------------------------------------------------------------------+++-- Check if two objects touch each other.+-- Currently only a radius-based intersection test.+touches :: ObsObjState -> ObsObjState -> Bool+oos1 `touches` oos2 =+ norm ((oosPos oos2) .-. (oosPos oos1)) < (oosRadius oos2 + oosRadius oos1)+++-- Check if two objects are approaching each other.+approaches :: ObsObjState -> ObsObjState -> Bool+oos1 `approaches` oos2 =+ (oosVel oos2 ^-^ oosVel oos1) `dot` (oosPos oos2 .-. oosPos oos1) < 0.0+++-- Check if two objects are colliding.+colliding :: ObsObjState -> ObsObjState -> Bool+oos1 `colliding` oos2 = oos1 `touches` oos2 && oos1 `approaches` oos2+++------------------------------------------------------------------------------+-- Constants defining various object properties+------------------------------------------------------------------------------++-- All objects are treated as round as far as intersection tests etc. are+-- concerned, but they may be drawn using a different shape. It is assumed+-- that that shape is centered around the position of the object, and that+-- its size roughly corresponds to the size implied by the object radius.++-- Constants for gun.++-- Gun: drawn triangular+gunRadius, gunBase, gunHeight :: Length+gunRadius = 25+gunBase = 2 * gunRadius+gunHeight = gunBase++gunSpeedMax :: Speed+gunSpeedMax = 500++gunAccMax :: Acceleration+gunAccMax = 500+++-- Constants for missile.++-- Missiles: drawn circular.+missileRadius :: Length+missileRadius = 5.0++missileInitialSpeed :: Speed+missileInitialSpeed = 200++missileLifeSpan :: Time+missileLifeSpan = 5.0+++-- Constants for alien.++-- Alien: drawn as a sphere with equatorial wing plane ("saturn-shaped")+alienRadius, alienWingRadius :: Length+alienRadius = 25+alienWingRadius = 2 * alienRadius++alienAccMax :: Acceleration+alienAccMax = 100+++------------------------------------------------------------------------------+-- Support functions+------------------------------------------------------------------------------++{-+-- Old stuff++-- Bounding box is calculated once and cached inside object.++computeObjBBox :: Object -> BBox+computeObjBBox (ObjBlock {objPos = p}) = BBox (p .-^ d) (p .+^ d)+ where+ d = vector2 (blockSide / 2) (blockSide / 2)+computeObjBBox (ObjNSWall {objPos = p}) = BBox (p .-^ d) (p .+^ d)+ where+ d = vector2 (nsWallXSide / 2) (nsWallYSide / 2)+computeObjBBox (ObjEWWall {objPos = p}) = BBox (p .-^ d) (p .+^ d)+ where+ d = vector2 (ewWallXSide / 2) (ewWallYSide / 2)+computeObjBBox (ObjSimbotA {objPos = p}) = BBox (p .-^ d) (p .+^ d)+ where+ d = vector2 simbotARadius simbotARadius+computeObjBBox (ObjSimbotB {objPos = p, objHdng = d}) = BBox p1 p2+ where+ Point2 x1 y1 = p .+^ (vector2Polar simbotBRadius d) -- Nose+ Point2 x2 y2 = p .+^ (vector2Polar simbotBRadius (d + 2*pi/3))+ Point2 x3 y3 = p .+^ (vector2Polar simbotBRadius (d - 2*pi/3))++ p1 = Point2 (minimum [x1,x2,x3]) (minimum [y1,y2,y3])+ p2 = Point2 (maximum [x1,x2,x3]) (maximum [y1,y2,y3])+computeObjBBox (ObjBall {objPos = p}) = BBox (p .-^ d) (p .+^ d)+ where+ d = vector2 ballRadius ballRadius+-}
+ src/ObjectBehavior.hs view
@@ -0,0 +1,264 @@+{- $Id: ObjectBehavior.as,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: ObjectBehavior *+* Purpose: Behavior of objects. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module ObjectBehavior (+ 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.Utilities+import FRP.Yampa.Geometry++import PhysicalDimensions+import WorldGeometry+import Parser+import Object+++------------------------------------------------------------------------------+-- Gun+------------------------------------------------------------------------------++gun :: Position2 -> Object+gun (Point2 x0 y0) = proc (ObjInput {oiGameInput = gi}) -> do+ -- Position.+ (Point2 xd _) <- ptrPos -< gi -- Desired position+ rec+ -- Controller.+ 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+ || v < (-gunSpeedMax) && a > 0+ || v > gunSpeedMax && a < 0+ then a+ else 0+ x <- (x0+) ^<< integral -< v++ -- Fire mechanism and ammunition level.+ trigger <- lbp -< gi+ (level, fire) <- magazine 20 0.5 -< trigger++ returnA -< ObjOutput {+ ooObsObjState = oosGun (Point2 x y0) (vector2 v 0) level,+ ooKillReq = noEvent,+ ooSpawnReq =+ fire `tag` [missile (Point2 x (y0 + (gunHeight/2))) + (vector2 v missileInitialSpeed)]+ }+++-- 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 event.+magazine :: + Int -> Frequency + -> SF (Event ()) (Int, Event ())+magazine n f = proc trigger -> do+ reload <- repeatedly (1/f) () -< ()+ (level,canFire) + <- accumHold (n,True) -< + (trigger `tag` dec)+ `lMerge` (reload `tag` inc)+ returnA -< (level, + trigger `gate` canFire)+ where+ inc :: (Int,Bool) -> (Int, Bool)+ inc (l,_) | l < n = (l + 1, l > 0)+ | otherwise = (l, True)+ dec :: (Int,Bool) -> (Int, Bool)+ dec (l,_) | l > 0 = (l - 1, True)+ | 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.++{-+ Henrik's original version, commented out for now:++magazine :: Int -> Frequency -> SF (Event ()) (Int, Event ())+magazine n f = proc trigger -> do+ reload <- repeatedly (1/f) () -< ()+ -- We have a reverse application operator #, but for some reason arrowp+ -- chokes on (#).+ newLevelFire <- accumFilter (flip ($)) n -< (trigger `tag` dec)+ `lMerge` (reload `tag` inc)+ 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))+ | otherwise = (l, Nothing)+ dec l | l > 0 = (l - 1, Just (l - 1, True))+ | otherwise = (l, Nothing)++-}++------------------------------------------------------------------------------+-- Missile+------------------------------------------------------------------------------++-- Of course, this would be much better if we used the real impulse stuff:+-- No bogus iPre, for instance.+missile :: Position2 -> Velocity2 -> Object+missile p0 v0 = proc oi -> do+ rec+ -- Basic physics+ vp <- iPre v0 -< v+ ffi <- forceField -< (p, vp)+ v <- (v0 ^+^) ^<< impulseIntegral -< (gravity, ffi)+ p <- (p0 .+^) ^<< integral -< v+ die <- after missileLifeSpan () -< ()+ returnA -< ObjOutput {+ ooObsObjState = oosMissile p v,+ ooKillReq = oiHit oi `lMerge` die,+ ooSpawnReq = noEvent+ }+++------------------------------------------------------------------------------+-- Alien+------------------------------------------------------------------------------++type ShieldLevel = Double+++-- Alien behavior.+-- g .......... Random generator.+-- p0 ......... Initial position.+-- vyd ........ Desired vertical speed.++alien :: RandomGen g => g -> Position2 -> Velocity -> Object+alien g p0 vyd = proc oi -> do+ rec++ -- About 4% of time spent here.+ -- 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?+ let axd = 5 * (xd - point2X p) - 3 * (vector2X v)+ 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+ vp <- iPre v0 -< v+ ffi <- forceField -< (p, vp)+ -- 28 % of time spent in the following line.+ v <- (v0 ^+^) ^<< impulseIntegral -< (gravity ^+^ a, ffi)+ -- 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++ -- Shields+ sl <- shield -< oiHit oi+ die <- edge -< sl <= 0++ returnA -< ObjOutput {+ ooObsObjState = oosAlien p h v,+ ooKillReq = die,+ ooSpawnReq = noEvent+ }+ where+ v0 = zeroVector++++-- About 20% of the time spent here. +shield :: SF (Event ()) ShieldLevel+shield = proc hit -> do+ rec+ let rechargeRate = if sl < slMax then slMax / 10 else 0+ sl <- (slMax +) ^<< impulseIntegral -< (rechargeRate, hit `tag` damage)+ returnA -< sl+ where+ slMax = 100+ damage = -50+++------------------------------------------------------------------------------+-- Force fields acting on objects+------------------------------------------------------------------------------++-- Object are subject to gravity and a strange repellent forcefield that+-- drives objects away from the edges, effectively creating a corridor.+-- The strange field is inversely proportional to the cube of the distance+-- from either edge. It is thought that the field is a remnant of a defence+-- system put in place by the mythical and technologically advanced+-- "Predecessors" eons ago.++{-+field :: Position2 -> Acceleration2+field (Point2 x _) = vector2 (leftAcc - rightAcc) 0 ^+^ gravity+ where+ leftAcc = min (if x > worldXMin+ then k / (x - worldXMin)^3+ else maxAcc)+ maxAcc+ rightAcc = min (if x < worldXMax+ then k / (worldXMax - x)^3+ else maxAcc)+ maxAcc+ k = 10000000+ maxAcc = 10000+-}++-- New attempt. Force fields act like invisible walls.+-- The fact that this is a stateful *signal* function (Fields having state?+-- Come on ...), can be attributed to the fact that we are cheating in the+-- first place by abstracting events of short duration to instantaneous+-- events. "field" being a stateful signal functio is part of the price+-- one have to pay for that to make this work in practice.++-- Not much time spent here, it seems.++forceField :: SF (Position2, Velocity2) (Event Acceleration2)+forceField = proc (p, v) -> do+ lfi <- edge -< point2X p < worldXMin && vector2X v < 0+ rfi <- edge -< point2X p > worldXMax && vector2X v > 0+ returnA -< (mergeBy (^+^) (lfi `tag` (vector2 (-2 * vector2X v) 0))+ (rfi `tag` (vector2 (-2 * vector2X v) 0)))++gravity = vector2 0 (-20)+++------------------------------------------------------------------------------+-- Support+------------------------------------------------------------------------------++limit ll ul x = if x < ll then ll else if x > ul then ul else x++symLimit l = let absl = abs l in limit (-absl) absl
+ src/Parser.hs view
@@ -0,0 +1,385 @@+{- $Id: Parser.hs,v 1.3 2004/11/18 13:02:26 henrik Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: Parser *+* Purpose: Parsing (mainly lexical analysis) of window event *+* stream. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++-- Quick 'n dirty adaptation from old robot simulator. Could probably be+-- 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+) where++import Data.Maybe (isNothing, isJust)+import qualified Graphics.HGL as HGL (Event(..))+import Data.Char (ord, isSpace, isDigit)++import FRP.Yampa+import FRP.Yampa.Utilities+import FRP.Yampa.Geometry+-- import FRP.Yampa.Miscellany (mapFst)++import PhysicalDimensions+import WorldGeometry (gPointToPosition2)+import Command+import Animate (WinInput)++------------------------------------------------------------------------------+-- Exported entities+------------------------------------------------------------------------------++data GameInput = GameInput {+ giCmdStr :: String,+ giCmd :: Event Command,+ giPDS :: PDState+}+++parseWinInput :: SF WinInput GameInput+parseWinInput = wiToCmd &&& wiToPDS+ >>^ \((cmdStr, cmd), pds) ->+ GameInput {giCmdStr = cmdStr, giCmd = cmd, giPDS = pds}+++-- All event sources below are defined such that they will NOT occur at local+-- time 0 (immediately after a switch). Sometimes explicitly using a "notYet".+-- Sometimes using through careful use of "edge" and relatives. Is this the+-- right approach?++-- A valid command has been read.+command :: SF GameInput (Event Command)+command = giCmd ^>> notYet+++-- Continuous parser feed back.+cmdString :: SF GameInput String+cmdString = arr giCmdStr+++ptrPos :: SF GameInput Position2+ptrPos = arr (pdsPos . giPDS)+++lbp :: SF GameInput (Event ())+lbp = lbpPos >>^ (`tag` ())+++lbpPos :: SF GameInput (Event Position2)+lbpPos = giPDS # pdsLeft ^>> edgeJust+++lbDown :: SF GameInput Bool+lbDown = arr (giPDS # pdsLeft # isJust)+++rbp :: SF GameInput (Event ())+rbp = rbpPos >>^ (`tag` ())+++rbpPos :: SF GameInput (Event Position2)+rbpPos = giPDS # pdsRight ^>> edgeJust+++rbDown :: SF GameInput Bool+rbDown = arr (giPDS # pdsRight # isJust)+++dragStart :: SF GameInput (Event ())+dragStart = giPDS # pdsDrag ^>> edgeBy detectStart (Just undefined)+ where+ detectStart Nothing (Just _) = Just ()+ detectStart _ _ = Nothing+++dragStop :: SF GameInput (Event Distance2)+dragStop = (giPDS # pdsDrag ^>> edgeBy detectStop Nothing) &&& dragVec+ >>^ \(e, dv) -> e `tag` dv+ where+ detectStop (Just _) Nothing = Just ()+ detectStop _ _ = Nothing+++-- (Last) drag start position.+dragStartPos :: SF GameInput Position2+dragStartPos = arr (giPDS # pdsDragStartPos)+++-- (Last) drag vector.+dragVec :: SF GameInput Distance2+dragVec = arr (giPDS # pdsDragVec)+++dragging :: SF GameInput Bool+dragging = arr (giPDS # pdsDrag # isJust)+++------------------------------------------------------------------------------+-- Lexical analysis of character input +------------------------------------------------------------------------------++-- Currently overkill, but being able to enter multi-character commands+-- could possibly be useful.++wiToCmd :: SF WinInput (String, Event Command)+wiToCmd = arr (mapFilterE selChar)+ >>> (accumBy scanChar (undefined,scanCmds) >>^ fmap fst >>^ splitE)+ >>> hold "" *** arr (mapFilterE id)+ where+ scanChar (_, S cont) c = cont c++ selChar (HGL.Char {HGL.char=c}) = Just c+ selChar _ = Nothing+++-- This ought to be redone. Kont should probably be called Tranition or+-- somethinig.++-- We define a continuation to be the command recognized thus far (a String+-- and maybe a complete Command), and a scanner to be applied to the rest+-- of the input. (I.e., there's output at every step.)++type Kont = ((String, Maybe Command), Scanner)+type Cont a = a -> Kont++-- Since a scanner is applied to one character at a time (typically, on+-- Char events), we recursively define a scanner to be a character+-- continuation.++newtype Scanner = S (Cont Char)++-- Scan commands++scanCmds :: Scanner+scanCmds = scanCmd cmds+ where+ cmds =+ [ ("q", emitCmd scanCmds CmdQuit), -- Discard inp.?+ ("p", emitCmd scanCmds CmdNewGame), + ("f", emitCmd scanCmds CmdFreeze),+ ("r", emitCmd scanCmds CmdResume)+ ]+++-- Scan one command.+-- Looks for a valid command. Outputs prefix as long as the current+-- 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. ++scanCmd :: [(String, Cont String)] -> Scanner+scanCmd cmds = scanSubCmd "" cmds+++-- Scan one subcommand/keyword argument.+-- Looks for a valid command. Outputs prefix as long as the current+-- prefix is valid. Starts over on first invalid character. Invokes success+-- continuation on success.+-- pfx0 ....... Initial prefix.+-- cmds ....... List of pairs of valid command and corresponding success+-- 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.+ -- 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'+++-- 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.++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+++-- 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.++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'+++-- Emit command (and command string), then continue scanning.+emitCmd :: Scanner -> Command -> String -> Kont+emitCmd scanner cmd cmdStr = ((cmdStr, Just cmd), scanner)+++-- Emit current prefix, then scan next character.+emitPfx :: Scanner -> String -> Kont+emitPfx scanner pfx = ((pfx, Nothing), scanner)+++------------------------------------------------------------------------------+-- Pointing device processing+------------------------------------------------------------------------------++-- State of the pointing device.+-- The points for pdsLeft, pdsRight, and pdsDrag reflect where the button+-- was initially pressed.+++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.+}+++-- Initial state.+initPDS = PDState {+ pdsPos = origin,+ pdsDragStartPos = origin,+ pdsDragVec = zeroVector,+ pdsLeft = Nothing,+ pdsRight = Nothing,+ pdsDrag = Nothing+ }+++wiToPDS :: SF WinInput PDState+wiToPDS = accumHoldBy nextPDS initPDS+++-- Compute next pointing device state.+nextPDS :: PDState -> HGL.Event -> PDState+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)+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+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)+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+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+ dsp = maybe (pdsDragStartPos pds) id md+ dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md+nextPDS pds _ = pds -- Ignore unknown events.+++------------------------------------------------------------------------------+-- General utilities+------------------------------------------------------------------------------++-- Longest common prefix.+lcp :: Eq a => [a] -> [a] -> [a]+lcp [] _ = []+lcp _ [] = []+lcp (x:xs) (y:ys) | x == y = x : lcp xs ys+ | otherwise = []
+ src/PhysicalDimensions.hs view
@@ -0,0 +1,133 @@+{- $Id: PhysicalDimensions.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: PhysicalDimensions *+* Purpose: Type synonyms for physical dimensions and some *+* related operations. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module PhysicalDimensions (+ InvaderReal,++-- One dimensional+ Time,+ DTime,+ Frequency,+ Mass,+ Length,+ Distance,+ Position,+ Speed,+ Velocity,+ Acceleration,+ Angle,+ Heading,+ Bearing,+ RotVel,+ RotAcc,++-- Two dimensional+ Distance2,+ Position2,+ Velocity2,+ Acceleration2,++-- Three dimensional+ Distance3,+ Position3,+ Velocity3,+ Acceleration3,++-- Operations+ normalizeAngle, -- :: Angle -> Angle+ normalizeHeading, -- :: Heading -> Heading+ bearingToHeading, -- :: Bearing -> Heading+ headingToBearing -- :: Heading -> Bearing+) where++import FRP.Yampa (Time, DTime)+import FRP.Yampa.Miscellany (fMod)+import FRP.Yampa.Geometry (Vector2, Vector3, Point2, Point3)+++-- Many of the physical dimensions below are related to time, and variables+-- of these types can thus be expected to occur in numerical expressions along+-- with variables of type time. To facilitate things, they should thus share+-- the same representation. Maybe it is a mistake that AFRP has fixed the+-- type of Time (currently to Double)?++-- Dimensionless type. Same representation as AFRP's Time.+type InvaderReal = Time++------------------------------------------------------------------------------+-- One-dimensional types+------------------------------------------------------------------------------++type Frequency = InvaderReal -- [Hz]+type Mass = InvaderReal -- [kg]+type Length = InvaderReal -- [m]+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 RotVel = InvaderReal -- [rad/s]+type RotAcc = InvaderReal -- [rad/s^2]+++------------------------------------------------------------------------------+-- 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]+++------------------------------------------------------------------------------+-- 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]+++------------------------------------------------------------------------------+-- Operations+------------------------------------------------------------------------------++-- The resulting angle is in the interval [-pi, pi).+normalizeAngle :: Angle -> Angle+normalizeAngle d = fMod (d + pi) (2 * pi) - pi+++-- The resulting heading is in the interval [-pi, pi).+normalizeHeading :: Heading -> Heading+normalizeHeading = normalizeAngle+++-- Bearings in degrees are understood as on a compass; i.e., north is 0,+-- east is 90, south is 180, west is 270.+-- Heading is understood as the angle (in radians) relative to the "x-axis"+-- which is supposed to point East.++-- The resulting heading is in the interval [-pi, pi).+bearingToHeading :: Bearing -> Heading+bearingToHeading b = (fMod (270 - b) 360 - 180) * pi / 180+++-- The resulting bearing is in the interval [0, 360).+headingToBearing :: Heading -> Bearing+headingToBearing d = fMod (90 - d * 180 / pi) 360
+ src/RenderLandscape.hs view
@@ -0,0 +1,82 @@+{- $Id: RenderLandscape.hs,v 1.3 2004/11/18 13:02:26 henrik Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: RenderLandscape *+* Purpose: Rendering of the fixed backdrop. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module RenderLandscape (+ landscape -- :: HGL.Graphic+) where++import Data.Array+import qualified Graphics.HGL as HGL++import FRP.Yampa.Point2 (Point2(..))++import WorldGeometry+import Colors+import ColorBindings+++------------------------------------------------------------------------------+-- Landscape rendering+------------------------------------------------------------------------------++landscape :: HGL.Graphic+landscape =+ HGL.mkBrush (colorTable ! distantMountainColor) $ \dmcBrush ->+ HGL.mkBrush (colorTable ! closeMountainColor) $ \cmcBrush ->+ HGL.mkBrush (colorTable ! groundColor) $ \groundBrush ->+ HGL.overGraphics+ [ HGL.withBrush groundBrush $ HGL.polygon groundPoints,+ HGL.withBrush cmcBrush $ HGL.polygon cmPoints,+ HGL.withBrush dmcBrush $ HGL.polygon dmPoints+ ]+++-- Points defining the distant mountain chain.+dmPoints :: [HGL.Point]+dmPoints = map relativeToGPoint+ [ (0.00, 0.00),+ (0.00, 0.62),+ (0.11, 0.20),+ (0.42, 0.33),+ (0.51, 0.24),+ (0.60, 0.37),+ (0.68, 0.17),+ (0.81, 0.26),+ (0.94, 0.39),+ (1.00, 0.50),+ (1.00, 0.00)+ ]++-- Points defining the close mountain chanin.+cmPoints :: [HGL.Point]+cmPoints = map relativeToGPoint+ [ (0.00, 0.00),+ (0.15, 0.25),+ (0.35, 0.00),+ (0.80, 0.20),+ (0.90, 0.00)+ ]++-- Points defining the ground.+groundPoints :: [HGL.Point]+groundPoints = map relativeToGPoint+ [ (0.00, 0.00),+ (0.00, 0.05),+ (1.00, 0.05),+ (1.00, 0.00)+ ]+++relativeToGPoint :: (Double, Double) -> HGL.Point+relativeToGPoint (x,y) = (round (x * fromIntegral worldSizeX),+ round ((1.0 - y) * fromIntegral worldSizeY))
+ src/RenderObject.hs view
@@ -0,0 +1,134 @@+{- $Id: RenderObject.hs,v 1.3 2004/11/18 13:02:26 henrik Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: RenderObject *+* Purpose: Object rendering. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module RenderObject (+ renderObjects -- :: [ObjObjState] -> HGL.Graphic+) where++import Data.Array+import qualified Graphics.HGL as HGL+import FRP.Yampa.Geometry++import PhysicalDimensions+import WorldGeometry+import Colors+import ColorBindings+import Object++------------------------------------------------------------------------------+-- Object rendering+------------------------------------------------------------------------------++-- This interface allows optimization. E.g. pen/brush creation can be+-- lifted to the top level.++renderObjects :: [ObsObjState] -> HGL.Graphic+renderObjects ooss = HGL.overGraphics (map renderObject ooss)+++renderObject :: ObsObjState -> HGL.Graphic+renderObject (OOSGun {oosPos = p, oosAmLvl = l}) =+ centeredText Green (p .-^ vector2 0 (gunHeight/2)) (show l)+ `HGL.overGraphic` triangle gunColor p1 p2 p3+ where+ 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+renderObject (OOSAlien {oosPos = p, oosHdng = h}) =+ line alienWingColor p1 p2+ `HGL.overGraphic` (circle alienDoorColor p3 (alienRadius/3))+ `HGL.overGraphic` (circle alienColor p alienRadius)+ where+ p1 = p .+^ v+ p2 = p .-^ v+ p3 = p .+^ vector2Polar (alienRadius / 2) h+ v = vector2Polar alienWingRadius (h + pi/2)+++line :: Color -> Position2 -> Position2 -> HGL.Graphic+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.line gp1 gp2+ where+ gp1 = position2ToGPoint p1+ gp2 = position2ToGPoint p2+++triangle :: Color -> Position2 -> Position2 -> Position2 -> HGL.Graphic+triangle c p1 p2 p3 =+ HGL.mkBrush (colorTable ! c) $ \brush ->+ HGL.withBrush brush $+ HGL.polygon [gp1, gp2, gp3]+ where+ gp1 = position2ToGPoint p1+ 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.polygon [gp11, gp12, gp22, gp21]+ where+ gp11@(x1,y1) = position2ToGPoint p1+ 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.ellipse gp11 gp22+ where+ d = vector2 r r+ gp11 = position2ToGPoint (p .-^ d)+ gp22 = position2ToGPoint (p .+^ d)+++{-+bbox :: Position2 -> Position2 -> HGL.Graphic+bbox p1 p2 =+ -- Line style and thiknes seems to be ignored completely?+ HGL.mkPen HGL.Dash 2 (colorTable ! bboxColor) $ \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)+-}++centeredText :: Color -> Position2 -> String -> HGL.Graphic+centeredText c p s =+ HGL.withTextColor (colorTable ! c) $+ HGL.withTextAlignment (HGL.Center, HGL.Baseline) $+ HGL.text gp s+ where+ 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' = x - (445 * length s) `div` 100+ y' = y - 7+-}
+ src/WorldGeometry.hs view
@@ -0,0 +1,94 @@+{- $Id: WorldGeometry.hs,v 1.3 2004/11/18 13:02:26 henrik Exp $+******************************************************************************+* I N V A D E R S *+* *+* Module: WorldGeometry *+* Purpose: Constants and functions defining the geometry of *+* the world. *+* Author: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module WorldGeometry where++import FRP.Yampa.Point2 (Point2(..))+import PhysicalDimensions+import qualified Graphics.HGL as HGL (Point)+++-- Everything in the world is measured in meters.++pixelsPerMeter :: InvaderReal+pixelsPerMeter = 0.5++pixelsToMeters :: Int -> Length+pixelsToMeters p = (fromIntegral p) / pixelsPerMeter ++metersToPixels :: Length -> Int+metersToPixels m = round (m * pixelsPerMeter)+++-- The world is assumed to be rectangular.++worldXMin, worldXMax :: Position+worldYMin, worldYMax :: Position+worldXMin = -500.0+worldYMin = 0.0+worldXMax = 500.0+worldYMax = 1000.0+++-- World size in pixels.++worldSizeX, worldSizeY :: Int+worldSizeX = metersToPixels (worldXMax - worldXMin)+worldSizeY = metersToPixels (worldYMax - worldYMin)+++{-+-- !!! We don't need any walls???++-- Positions of the walls.++worldNorthWall, worldSouthWall :: Position+worldEastWall, worldWestWall :: Position+worldNorthWall = worldYMax - 0.2+worldEastWall = worldXMax - 0.2+worldSouthWall = worldYMin + 0.2+worldWestWall = worldXMin + 0.2+-}+++-- Co-ordinate translations++-- Re-visit these definitions if/once affine transforms are introduced in AFRP.+-- Maybe use affine transformations also for the basic conversions HGL.Point+-- <-> Position2?++{-+pointToPositionT :: Transform2+pointToPositionT = translate2 (vector2XY worldXMin worldYMax) `compose2` + uscale2 (1 / pixelsPerMeter) `compose2` + mirrorY2 +-}+++gPointToPosition2 :: HGL.Point -> Position2+gPointToPosition2 (x, y) = (Point2 (pixelsToMeters x + worldXMin)+ (worldYMax - pixelsToMeters y))+++{-+positionToPointT :: Transform2+positionToPointT = uscale2 pixelsPerMeter `compose2`+ translate2 (vector2XY (-worldXMin) worldYMax) `compose2`+ mirrorY2+-}+++position2ToGPoint :: Position2 -> HGL.Point+position2ToGPoint (Point2 x y) =+ (metersToPixels (x - worldXMin), metersToPixels (worldYMax - y))