diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SpaceInvaders.cabal b/SpaceInvaders.cabal new file mode 100644 --- /dev/null +++ b/SpaceInvaders.cabal @@ -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 diff --git a/src/Animate.hs b/src/Animate.hs new file mode 100644 --- /dev/null +++ b/src/Animate.hs @@ -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)) diff --git a/src/ColorBindings.hs b/src/ColorBindings.hs new file mode 100644 --- /dev/null +++ b/src/ColorBindings.hs @@ -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 diff --git a/src/Colors.hs b/src/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Colors.hs @@ -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 diff --git a/src/Command.hs b/src/Command.hs new file mode 100644 --- /dev/null +++ b/src/Command.hs @@ -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. diff --git a/src/Diagnostics.hs b/src/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/Diagnostics.hs @@ -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) diff --git a/src/IdentityList.hs b/src/IdentityList.hs new file mode 100644 --- /dev/null +++ b/src/IdentityList.hs @@ -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] ] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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) diff --git a/src/Object.hs b/src/Object.hs new file mode 100644 --- /dev/null +++ b/src/Object.hs @@ -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 +-} diff --git a/src/ObjectBehavior.hs b/src/ObjectBehavior.hs new file mode 100644 --- /dev/null +++ b/src/ObjectBehavior.hs @@ -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 diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -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 = [] diff --git a/src/PhysicalDimensions.hs b/src/PhysicalDimensions.hs new file mode 100644 --- /dev/null +++ b/src/PhysicalDimensions.hs @@ -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 diff --git a/src/RenderLandscape.hs b/src/RenderLandscape.hs new file mode 100644 --- /dev/null +++ b/src/RenderLandscape.hs @@ -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)) diff --git a/src/RenderObject.hs b/src/RenderObject.hs new file mode 100644 --- /dev/null +++ b/src/RenderObject.hs @@ -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 +-} diff --git a/src/WorldGeometry.hs b/src/WorldGeometry.hs new file mode 100644 --- /dev/null +++ b/src/WorldGeometry.hs @@ -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))