diff --git a/Haskelloids.cabal b/Haskelloids.cabal --- a/Haskelloids.cabal +++ b/Haskelloids.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1.0 +Version: 0.1.1 -- A short (one-line) description of the package. Synopsis: A reproduction of the Atari 1979 classic "Asteroids" @@ -50,13 +50,25 @@ Executable Haskelloids Hs-Source-Dirs: src + + Other-modules: + Data.IdentityList, + Haskelloids.Input, + Haskelloids.Object, + Haskelloids.Object.Asteroid, + Haskelloids.Object.Bullet, + Haskelloids.Object.Dust, + Haskelloids.Object.Ship, + Haskelloids.Geometry, + Haskelloids.Geometry.Text, + Haskelloids.Graphics + -- .hs or .lhs file containing the Main module. Main-is: Haskelloids.hs -- Packages needed in order to build this package. Build-depends: base == 4.*, - haskell98 == 1.*, containers == 0.*, random == 1.*, MonadRandom == 0.1.*, diff --git a/src/Data/IdentityList.hs b/src/Data/IdentityList.hs new file mode 100644 --- /dev/null +++ b/src/Data/IdentityList.hs @@ -0,0 +1,56 @@ +module Data.IdentityList (IList, + ILKey, + empty, + insert, + insertMany, + fromList, + elems, + assocs, + delete, + deleteMany, + mapWithKey + ) where + +import Data.Word (Word32) + +import qualified Data.Map as Map (Map, empty, insert, lookup, elems, assocs, + delete, mapWithKey) + +type ILKey = Word32 -- NB: maximum of 2^32 objects can be inserted after initialisation + +data IList a = IL { + ilNextKey :: ILKey, + ilAssocs :: Map.Map ILKey a +} deriving (Show) + +empty :: IList a +empty = IL { ilNextKey = minBound, + ilAssocs = Map.empty } + +insert :: IList a -> a -> IList a +insert (IL nxtKy assc) e = IL (succ nxtKy) assc' + where assc' = Map.insert nxtKy e assc + +insertMany :: IList a -> [a] -> IList a +insertMany = foldl insert + +fromList :: [a] -> IList a +fromList = insertMany empty + +elems :: IList a -> [a] +elems = Map.elems . ilAssocs + +assocs :: IList a -> [(ILKey, a)] +assocs = Map.assocs . ilAssocs + +delete :: IList a -> ILKey -> IList a +delete (IL nxtKy map) k = IL nxtKy (Map.delete k map) + +deleteMany :: IList a -> [ILKey] -> IList a +deleteMany = foldl delete + +mapWithKey :: (ILKey -> a -> b) -> IList a -> IList b +mapWithKey f il = il { ilAssocs = Map.mapWithKey f . ilAssocs $ il } + +instance Functor IList where + fmap f (IL nxtKy assc) = IL nxtKy (fmap f assc) diff --git a/src/Haskelloids.hs b/src/Haskelloids.hs --- a/src/Haskelloids.hs +++ b/src/Haskelloids.hs @@ -1,7 +1,6 @@ -- #### Haskelloids.hs -- TODO Implement hyperspace jump --- TODO Implement extra asteroids -- TODO Implement bonus scores -- TODO Implement bonus life diff --git a/src/Haskelloids/Geometry.hs b/src/Haskelloids/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Geometry.hs @@ -0,0 +1,139 @@ +-- Geometry.hs, A module for translating, rotating and scaling 2D shapes and simple-polygons (i.e. non-self-crossing). + +-- NB: IMPORTANT - All the operations concerning intersections of polygons assume all polygons are convex and are supplied with their vertices in clockwise order + +module Haskelloids.Geometry (Shape(..), Figure(..), origin, add, inv, len, dist, + shape, intersect, Graphic, Point, Point2, Angle, + polyline, ellipse, regularPolygon, inCircle, inPolygon + ) where + +import Graphics.HGL.Units (Point) +import Graphics.HGL.Draw.Monad (Graphic) +import Graphics.HGL.Draw.Picture (polyline, ellipse) + +import Data.Ratio ((%)) +import Data.List (nub) + +import Data.Packed.Matrix (Matrix, ident, fromLists) +import Data.Packed.Vector (Vector, (|>), toList) + +import Numeric.LinearAlgebra.Algorithms (det) +import Numeric.LinearAlgebra.Interface ((<>)) + +type Angle = Double +type Point2 = (Double,Double) +type Segment = (Point2, Point2) + +-- #### Datatype defintions #################################################### + +-- Shape - a drawable shape, either an unbroken polygon, a circle, or a line +data Shape = Poly [Point2] + | Circ Point2 Double + | Ln [Point2] + deriving (Show) + +-- Figure - purely functional representation of affine transformations of shapes and lines +data Figure = Polygon [Point2] + | Circle Point2 Double + | Line [Point2] + | Translate Point2 Figure + | Scale Double Figure + | Rotate Angle Figure + deriving (Show) + +-- #### Program constants ###################################################### + +origin :: Point2 +origin = (0, 0) + +-- #### Function definitions ################################################### + +add :: Point2 -> Point2 -> Point2 +add (x1,y1) (x2,y2) = (x1+x2, y1+y2) + +sub :: Point2 -> Point2 -> Point2 +sub (x1,y1) (x2,y2) = (x1-x2, y1-y2) + +inv :: Point2 -> Point2 +inv (x,y) = (-x,-y) + +len :: Point2 -> Double +len (x, y) = sqrt $ x^2 + y^2 + +dist :: Point2 -> Point2 -> Double +dist (x,y)(u,v) = len (u-x,v-y) + +dot :: Point2 -> Point2 -> Double +dot (x1,y1) (x2,y2) = (x1*x2 + y1*y2) + +rot :: Point2 -> Angle -> Point2 +rot (x,y) theta = + let x' = cos theta * x - sin theta * y + y' = sin theta * x + cos theta * y + in (x', y') + +segments :: [Point2] -> [Segment] +segments ps = zipWith (,) ps (tail . cycle $ ps) + +shape :: Figure -> Shape +shape f = shape' (ident 3) f + where + -- shape' - uses homogeneous coordinates so we can do affine translations (i.e. linearly dependant transformations) + shape' :: Matrix Double -> Figure -> Shape + shape' m (Polygon ps) = Poly . map (transform m) $ ps' + where ps' = makeCycle ps + shape' m (Line ps) = Ln . map (transform m) $ ps + shape' m (Circle c r) = Circ (transform m c) ((r *) . sqrt . det $ m) -- The radius changes by the sqrt of the determinant of the transformation + shape' m (Translate (x, y) f) = shape' (m <> m') f + where m' = fromLists [[1, 0, x], + [0, 1, y], + [0, 0, 1]] + shape' m (Scale s f) = shape' (m <> m') f + where m' = fromLists [[s, 0, 0], + [0, s, 0], + [0, 0, 1]] + shape' m (Rotate phi f) = shape' (m <> m') f + where m' = fromLists [[cos phi,-sin phi, 0], + [sin phi, cos phi, 0], + [0, 0, 1]] + makeCycle :: [Point2] -> [Point2] + makeCycle (p:ps) = if p == last ps + then (p:ps) + else (p:ps) ++ [p] + toHomo :: Point2 -> Vector Double + toHomo (x, y) = (3 |> [x, y, 1]) + transform :: Matrix Double -> Point2 -> Point2 + transform m p = (x, y) + where (x:y:_) = (toList . (m <>) . toHomo) p + +regularPolygon :: Int -> Double -> Figure +regularPolygon n r | n < 3 = error "regularPolygon - cannot construct a regular polygon of less than 3 sides" + | otherwise = Polygon $ take (n+1) [(r * cos t, r * sin t) | t <- [0, (2*pi)/(fromIntegral n)..]] + +intersect :: Shape -> Shape -> Bool +intersect (Ln _) _ = False +intersect _ (Ln _) = False +intersect (Circ c r) (Circ d s) = abs (dist c d) <= r + s +intersect (Poly ps) (Circ c r) = inPolygon ps c || any (inCircle c r) ps +intersect (Circ c r) (Poly ps) = inPolygon ps c || any (inCircle c r) ps +intersect (Poly ps) (Poly qs) = any (inPolygon qs) ps + || any (inPolygon ps) qs + +inPolygon :: [Point2] -> Point2 -> Bool +inPolygon ps p@(x,y) = odd . length . filter intersectRay . segments $ ps + where + intersectRay :: Segment -> Bool + intersectRay s@(p1@(x1,y1),p2@(x2,y2)) = (p `xBetween` p1 $ p2) + && x * grad s + yintrsct s >= y + xBetween :: Point2 -> Point2 -> Point2 -> Bool + xBetween (x1,_) (x2,_) (x3,_) = (x2 <= x1 && x1 <= x3) + || (x3 <= x1 && x1 <= x2) + +inCircle :: Point2 -> Double -> Point2 -> Bool +inCircle (xc,yc) r (x,y) = r^2 >= ((xc-x)^2 + (yc-y)^2) + +yintrsct :: Segment -> Double +yintrsct ((x,y),(u,v)) = y - ((x * (v - y)) / (u - x)) + +grad :: Segment -> Double +grad ((x,y),(u,v)) = (v - y) / (u - x) diff --git a/src/Haskelloids/Geometry/Text.hs b/src/Haskelloids/Geometry/Text.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Geometry/Text.hs @@ -0,0 +1,89 @@ +module Haskelloids.Geometry.Text (fromString, + Alignment(..) + )where + +import Control.Arrow (second) + +import Haskelloids.Geometry (Figure(..)) +import Haskelloids.Graphics (Graphic) + +-- #### Datatype definitions ################################################### + +data Alignment = AlignRight | AlignCentre | AlignLeft + +-- #### Constants ############################################################## + +-- all charcter figures are drawn with respect to the screen origin (top left) and are drawn within a box 20x30 pixels + +-- charWidth - the character width +charWidth :: Double +charWidth = 25 + +-- ## Character figures ######################### + +zero, one, two, three, four, five, six, seven, eight, nine :: [Figure] +zero = [Line [(0,0), (20,0), (20,30), (0,30), (0,0)]] +one = [Line [(10,0), (10,30)]] +two = [Line [(0,0), (20,0), (20,15), (0,15), (0,30), (20,30)]] +three = [Line [(0,0), (20,0), (20,15), (0,15), (20,15), (20,30), (0,30)]] +four = [Line [(0,5), (0,15), (20,15), (20,0), (20,30)]] +five = [Line [(20,0), (0,0), (0,15), (20,15), (20,30), (0,30)]] +six = [Line [(0,0), (0,30), (20,30), (20,15), (0,15)]] +seven = [Line [(0,0), (20,0), (20,30)]] +eight = [Line [(0,15), (0,0), (20,0), (20,15), (0,15), (0,30), (20,30), (20,15)]] +nine = [Line [(20,15), (0,15), (0,0), (20,0), (20,30)]] + +a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,sp :: [Figure] +a = [Line [(0,30), (0,10), (10,0), (20,10), (20,30)], Line [(0,20),(20,20)]] +b = [Line [(0,30), (0,0), (15,0), (20,5), (20,10), (15,15), (0,15)], + Line [(15,15), (20,20), (20,25), (15,30), (0,30)]] +c = [Line [(20,30), (0,30), (0,0), (20,0)]] +d = [Line [(0,0), (10,0), (20,10), (20,20), (10,30), (0,30), (0,0)]] +e = [Line [(20,30), (0,30), (0,0), (20,0)], Line [(0,15), (15,15)]] +f = [Line [(0,30), (0,0), (20,0)], Line [(0,15), (15,15)]] +g = [Line [(10,20), (20,20), (20,30), (0,30), (0,0), (20,0), (20,10)]] +h = [Line [(0,0), (0,30)], Line [(0,15), (20,15)], Line [(20,0), (20,30)]] +i = [Line [(0,0), (20,0)], Line [(10,0),(10,30)], + Line [(0,30), (20,30)]] +j = [Line [(0,20), (10,30), (20,30), (20,0)]] +k = [Line [(0,0), (0,30)], Line [(0,15), (20,0)], Line [(0,15), (20,30)]] +l = [Line [(0,0), (0,30), (20,30)]] +m = [Line [(0,0), (0,30)], Line [(0,0), (10,10), (20,0)], + Line [(20,0), (20,30)]] +n = [Line [(0,0), (0,30)], Line [(0,0), (20,30)], + Line [(20,0), (20,30)]] +o = zero +p = [Line [(0,30), (0,0), (20,0), (20,15), (0,15)]] +q = [Line [(0,0), (20,0), (20,20), (10,30), (0,30), (0,0)], Line [(10,20), (20,30)]] +r = [Line [(0,30), (0,0), (20,0), (20,15), (0,15)], Line [(0,15),(20,30)]] +s = five +t = [Line [(0,0), (20,0)], Line [(10,0), (10,30)]] +u = [Line [(20,0), (20,30), (0,30), (0,0)]] +v = [Line [(0,0), (10,30), (20,0)]] +w = [Line [(0,0), (0,30), (10,20), (20,30), (20,0)]] +x = [Line [(0,0), (20,30)], Line [(0,30), (20,0)]] +y = [Line [(0,0), (10,10), (10,30)], Line [(20,30), (10,10)]] +z = [Line [(0,0), (20,0), (0,30), (20,30)]] +sp = [] + +-- #### Function definitions ################################################### + +fromString :: Alignment -> String -> [Figure] +fromString align str = + let offset = case align of + AlignLeft -> 0 + AlignCentre -> -width / 2 + AlignRight -> -width + width = charWidth * (fromIntegral . length $ str) + in concat . zipWith (map . Translate) [(x+offset, 0.0) | x <- [0,charWidth..] ] . map charToFig $ str + +charToFig :: Char -> [Figure] +charToFig ch = case ch of + '0' -> zero; '1' -> one; '2' -> two; '3' -> three; '4' -> four + '5' -> five; '6' -> six; '7' -> seven; '8' -> eight; '9' -> nine + 'a' -> a; 'b' -> b; 'c' -> c; 'd' -> d; 'e' -> e + 'f' -> f; 'g' -> g; 'h' -> h; 'i' -> i; 'j' -> j + 'k' -> k; 'l' -> l; 'm' -> m; 'n' -> n; 'o' -> o + 'p' -> p; 'q' -> q; 'r' -> r; 's' -> s; 't' -> t + 'u' -> u; 'v' -> v; 'w' -> w; 'x' -> x; 'y' -> y + 'z' -> z; ' ' -> sp; _ -> zero diff --git a/src/Haskelloids/Graphics.hs b/src/Haskelloids/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Graphics.hs @@ -0,0 +1,22 @@ +module Haskelloids.Graphics (Graphic, + drawShape, + drawFigure + ) where + +import Control.Arrow ((***)) + +import Graphics.HGL.Draw (Graphic) +import Graphics.HGL.Draw.Picture (ellipse, polyline) + +import Haskelloids.Geometry (Figure, Shape(..), shape) + +drawFigure :: Figure -> Graphic +drawFigure f = drawShape . shape $ f + +drawShape :: Shape -> Graphic +drawShape (Ln ps) = polyline . map (round *** round) $ ps +drawShape (Poly ps) = polyline . map (round *** round) $ ps +drawShape (Circ (x,y) r) = ellipse (x'-r', y'-r') (x'+r', y'+r') + where x' = round x + y' = round y + r' = round r diff --git a/src/Haskelloids/Input.hs b/src/Haskelloids/Input.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Input.hs @@ -0,0 +1,60 @@ +module Haskelloids.Input (UserInput(..), + inputInit, + getWindowEvs, + procWindowEvs + )where + +-- import graphics +import Graphics.HGL.Window (Window, Event(..), maybeGetWindowEvent) +import Graphics.HGL.Key (Key(..), isLeftKey, isRightKey, isUpKey, isShiftLKey, + isCharKey, keyToChar) + +-- import Yampa +import qualified FRP.Yampa as FRP (Event(..)) + +-- #### Data type definitions ################################################## + +data UserInput = UserInput { -- events that correspond to user input + uiLeftClick :: FRP.Event (), + uiFire :: FRP.Event (), + uiHyperSpace :: FRP.Event (), + uiTurnLeft :: FRP.Event Bool, + uiTurnRight :: FRP.Event Bool, + uiThrust :: FRP.Event Bool +} + +-- inputInit - the user-input at time t=0 +inputInit :: UserInput +inputInit = UserInput { + uiLeftClick = FRP.NoEvent, + uiFire = FRP.NoEvent, + uiHyperSpace = FRP.NoEvent, + uiTurnLeft = FRP.NoEvent, + uiTurnRight = FRP.NoEvent, + uiThrust = FRP.NoEvent +} + +-- getWindowEvs - collect all events since last window tick +getWindowEvs :: Window -> IO [Event] +getWindowEvs w = do e <- maybeGetWindowEvent w + case e of Just x -> do es <- getWindowEvs w + return (x : es) + Nothing -> return [] + +-- procWindowEvs - process the window events passed and apply to the passed game input +procWindowEvs :: UserInput -> [Event] -> UserInput +procWindowEvs gi evs = foldl procWindowEv gi evs + +procWindowEv :: UserInput -> Event -> UserInput +procWindowEv gi Button{ isLeft = left, isDown = down } + | left && down = gi{ uiLeftClick = FRP.Event () } +procWindowEv gi Key{ keysym = k, isDown = down } + | isLeftKey k = gi{ uiTurnLeft = FRP.Event down } + | isRightKey k = gi{ uiTurnRight = FRP.Event down } + | isUpKey k = gi{ uiThrust = FRP.Event down } + | isShiftLKey k + && down = gi{ uiHyperSpace = FRP.Event () } + | isCharKey k + && keyToChar k == ' ' + && down = gi{ uiFire = FRP.Event () } +procWindowEv gi _ = gi diff --git a/src/Haskelloids/Object.hs b/src/Haskelloids/Object.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Object.hs @@ -0,0 +1,106 @@ +{-# OPTIONS_GHC -XArrows -XRankNTypes #-} +module Haskelloids.Object (Object, + ObjectClass(..), + ObjectInput(..), + ObjectOutput(..), + teleport, + reload, + hits + ) where + +import Control.Arrow ((&&&), returnA) + +import FRP.Yampa (SF, Event(..), DTime, (>>>), (>>^), integral, merge, mergeBy, + switch, attach, constant, identity, after, once, isEvent, + tag) + +import Graphics.HGL (Graphic) + +import Haskelloids.Input (UserInput) + +import Haskelloids.Geometry (Shape, Point2, Angle, intersect) + +import Data.IdentityList (IList, ILKey) +import qualified Data.IdentityList as IL (assocs, insertMany, delete, elems, + mapWithKey) +import Data.List (partition) + +import Debug.Trace (trace) + +-- #### Data type definitions ################################################## + +-- ## Game objects ############################## + +type Object = SF ObjectInput ObjectOutput + +data ObjectInput = ObjectInput { + oiUserInput :: !UserInput, + oiHit :: Event () +} + +data ObjectClass = Asteroid + | Bullet + | Ship + | Dust + deriving (Eq) + +-- ObjectOutput - a common interface for the drawing of the game state plus the addition and removal of game objects +data ObjectOutput = ObjectOutput { + ooPos :: Point2, + ooCllsnBox :: !Shape, + ooGraphic :: !Graphic, + ooSpawnReq :: Event [Object], + ooObjClass :: ObjectClass, + ooKillReq :: Event () +} + +-- #### Signal functions ####################################################### + +-- teleport - auxiliary signal function that wraps co-ordinates round in a one-dimensional co-ordinate system with a fixed buffer size +teleport :: Int -> Int -> Double -> SF Double Double +teleport sz buf x0 = switch (init &&& (init >>> evt)) (\(f, x) -> teleport sz buf . f $ x) + where + init :: SF Double Double + init = (integral >>^ (x0+)) + evt :: SF Double (Event (Double -> Double, Double)) + evt = proc x -> do + let sz' = fromIntegral sz + buf' = fromIntegral buf + lt = (\d -> if d then Event ( 2*buf' + sz' + ) else NoEvent) . (< 0 - buf') $ x + gt = (\d -> if d then Event ((2*buf' + sz') `subtract` ) else NoEvent) . (> sz' + buf') $ x + returnA -< flip attach x . merge lt $ gt + +-- reload - auxiliary signal function that yields an Event on the first Event to arrive and then waits the specified interval until yielding another Event again +reload :: DTime -> SF (Event ()) (Event ()) +reload intvl = proc e -> do + switch (constant NoEvent &&& identity) (\_ -> pause) -< e + where + pause :: SF (Event ()) (Event ()) + pause = switch (once &&& after intvl ()) (\_ -> reload intvl) + +-- ##### Function definitions ################################################# + +-- hits - calculates which objects have collided with another and returns them +hits :: [(ILKey, ObjectOutput)] -> [ILKey] +hits objs = hits' objs [] + +hits' :: [(ILKey, ObjectOutput)] -> [(ILKey, ObjectOutput)] -> [ILKey] +hits' [] _ = [] +hits' ((k, oo):rest) seen = + let cllsn = any (\x -> (collideObj (ooObjClass oo) . ooObjClass . snd $ x) + && (intersect (ooCllsnBox oo) . ooCllsnBox . snd $ x)) + (seen ++ rest) + in if cllsn + then k : hits' rest ((k,oo):seen) + else hits' rest ((k,oo):seen) + +-- collideObj - collision function +collideObj :: ObjectClass -> ObjectClass -> Bool +collideObj Dust _ = False +collideObj _ Dust = False +collideObj Asteroid Asteroid = False +collideObj Asteroid _ = True +collideObj Ship Bullet = False +collideObj Ship _ = True +collideObj Bullet Ship = False +collideObj Bullet _ = True diff --git a/src/Haskelloids/Object/Asteroid.hs b/src/Haskelloids/Object/Asteroid.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Object/Asteroid.hs @@ -0,0 +1,123 @@ +{-# OPTIONS_GHC -XArrows #-} +module Haskelloids.Object.Asteroid (RoidSz(..), + asteroidSF + )where + +import Control.Arrow (returnA, arr) +import Control.Monad (replicateM, liftM) + +import Control.Monad.Random (RandomGen, Rand, evalRand, getRandomR) +import Control.Monad.Random.Class (getSplit) + +import FRP.Yampa (Event(..), next, (<<^), isEvent, edge, tag) + +import Haskelloids.Object (Object, ObjectClass(..), ObjectInput(..), + ObjectOutput(..), teleport) +import Haskelloids.Object.Dust (makeDust) + +import Haskelloids.Geometry (Point, Point2, Angle, Figure(..), shape) +import Haskelloids.Graphics (drawShape) + +-- #### Datatype definitions ################################################### + +data RoidSz = RdSmall + | RdMedium + | RdLarge + deriving (Eq, Enum) + +-- #### Program constants ###################################################### + +roidFigure1, roidFigure2, roidFigure3, roidFigure4 :: Figure + +roidFigure1 = Polygon [(-32,-15), (-9,-15), (-16,-30), (8,-30), (31,-15), + (32,-7), (8,0), (31,15), (16,30), (7,23), (-16,30), + (-32,8), (-32,-15)] + +roidFigure2 = Polygon [(-17,-31), (0,-24), (16,-30), (31,-16), (17,-8), (31,7), + (15,29), (-8,22), (-17,29), (-32,14), (-25,-1), + (-32,-16), (-17,-31)] + +roidFigure3 = Polygon [(-10,-30), (16,-30), (31,-8), (31,7), (16,30), (0,30), + (0,8), (-16,29), (-32,7), (-17,0), (-32,-8), (-10,-30)] + +roidFigure4 = Polygon [(-16,-29), (1,-18), (18,-29), (35,-15), (23,2), (34,17), + (9, 33), (-16,33), (-32,17), (-32,-16), (-16,-29)] + +roidCllsnFigure1, roidCllsnFigure2, roidCllsnFigure3, roidCllsnFigure4 :: Figure + +roidCllsnFigure1 = Polygon [(-32,-15), (-32,8.0), (-16,30), (7,23), (16,30), + (31, 15), (32, -7), (31, -15), (8, -30), (-16, -30), + (-32,-15)] + +roidCllsnFigure2 = Polygon [(-32, -16), (-32, 14), (-17, 29), (15, 29), (31, 7), + (17, -8), (31, -16), (16, -30), (-17, -31), + (-32, -16)] + +roidCllsnFigure3 = Polygon [(-32, -8), (-32, 7), (-16, 29), (0, 30), (16, 30), + (31, 7), (31, -8), (16, -30), (-10, -30), (-32, -8)] + +roidCllsnFigure4 = Polygon [(-32, -16), (-32, 17), (-16, 33), (9, 33), (34, 17), + (23, 2), (35, -15), (18, -29), (-16, -29), + (-32, -16)] + +buffer :: Int +buffer = 40 + +minSpeed, maxSpeed :: Double +minSpeed = 30 +maxSpeed = 100 + +-- #### Signal functions ####################################################### + +-- asteroidSF - the signal function for an asteroid object NB: COULD ABSTRACT ALL THIS TO MONAD-RANDOM? +asteroidSF :: RandomGen g => g -> Point -> Point2 -> Double -> Angle -> RoidSz -> Double -> Object +asteroidSF g (w, h) (x0, y0) s o sz fig = + let s' = minSpeed + ((maxSpeed - minSpeed) * s) + !vx = s' * cos o + !vy = s' * sin o + !buf = round $ fromIntegral buffer * scale sz + (fg',cllsnFig) = case fig of + r | r <= 0.25 -> (roidFigure1, roidCllsnFigure1) + | r <= 0.5 -> (roidFigure2, roidCllsnFigure2) + | r <= 0.75 -> (roidFigure3, roidCllsnFigure3) + | otherwise -> (roidFigure4, roidCllsnFigure4) + + in proc oi -> do + x <- teleport w buf x0 -< vx + y <- teleport h buf y0 -< vy + + let roidShape = shape . Translate (x,y) . Scale (scale sz) $ fg' + + hit <- arr oiHit -< oi + + returnA -< ObjectOutput { + ooPos = (x,y), + ooCllsnBox = roidShape, + ooGraphic = drawShape roidShape, + ooSpawnReq = hit `tag` (flip evalRand g $ do { + frag <- replicateM 2 . makeFragment (w,h) (x,y) s $ sz + ; dust <- replicateM 8 . makeDust $ (x,y) + ; return (dust ++ if sz /= RdSmall + then frag + else []) + }), + ooObjClass = Asteroid, + ooKillReq = hit + } + +-- #### Function defintions #################################################### + +scale :: RoidSz -> Double +scale RdLarge = 1 +scale RdMedium = 0.5 +scale RdSmall = 0.25 + +makeFragment :: RandomGen g => Point -> Point2 -> Double -> RoidSz -> Rand g Object +makeFragment (w, h) (x, y) s sz = do + g <- getSplit + x0 <- (x+) `liftM` getRandomR (-10.0,10.0) + y0 <- (y+) `liftM` getRandomR (-10.0,10.0) + s' <- (s*) `liftM` getRandomR (0.7,1.3) + o' <- getRandomR (0, 2*pi) + fig <- getRandomR (0, 1) + return (asteroidSF g (w,h) (x0,y0) s' o' (pred sz) fig) diff --git a/src/Haskelloids/Object/Bullet.hs b/src/Haskelloids/Object/Bullet.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Object/Bullet.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -XArrows #-} +module Haskelloids.Object.Bullet (bulletSF + ) where + +-- import control structures +import Control.Arrow (returnA) + +-- import Yampa framework +import FRP.Yampa (Event(..), integral, edge, time, (^<<), (<<<), arr, merge) + +-- import graphics and geometry +import Haskelloids.Geometry (Point, Point2, Angle, Figure(..), origin, shape) +import Haskelloids.Graphics (Graphic, drawShape) + +-- import game objects and interface +import Haskelloids.Object (Object, ObjectClass(..), ObjectInput(..), + ObjectOutput(..), teleport) + +-- #### Program constants ###################################################### + +-- bulletFigure - the bullet figure +bulletFigure :: Figure +bulletFigure = Circle origin 2 + +-- buffer - window edge buffer size, stops the object appearing when teleporting from one edge to the other +buffer :: Int +buffer = 2 + +-- bulletSpeed - speed bullet travels in pixels per second +bulletSpeed :: Double +bulletSpeed = 500 + +-- bulletMaxAge - the maximum number of seconds a bullet will exist for +bulletMaxAge :: Double +bulletMaxAge = 0.75 + +-- #### Signal function ######################################################## + +bulletSF :: Point -> Point2 -> Point2 -> Angle -> Object +bulletSF (w, h) (x0, y0) (vx0, vy0) o = + let !vx = vx0 + bulletSpeed * cos o + !vy = vy0 + bulletSpeed * sin o + in proc oi -> do + x <- teleport w buffer x0 -< vx + y <- teleport h buffer y0 -< vy + + let bulShape = shape . Translate (x,y) $ bulletFigure + + die <- edge <<< (> bulletMaxAge) ^<< time -< () + hit <- arr oiHit -< oi + + returnA -< + ObjectOutput { + ooPos = (x,y), + ooCllsnBox = bulShape, + ooGraphic = drawShape bulShape, + ooSpawnReq = NoEvent, + ooObjClass = Bullet, + ooKillReq = merge die hit + } + +-- #### Function definitions ################################################### + diff --git a/src/Haskelloids/Object/Dust.hs b/src/Haskelloids/Object/Dust.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Object/Dust.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -XArrows #-} +module Haskelloids.Object.Dust (dustSF, + makeDust + ) where + +import Control.Arrow (returnA) +import Control.Monad (liftM) +import Control.Monad.Random (RandomGen, Rand, getRandomR) + +import FRP.Yampa (Event(..), after, (^<<), integral) + +import Haskelloids.Geometry (Point2, Angle, Figure(..), shape, origin) + +import Haskelloids.Graphics (drawFigure) + +import Haskelloids.Object (Object, ObjectClass(..), ObjectOutput(..)) + +-- #### Program constants ###################################################### + +speed :: Double +speed = 200 + +minAge, maxAge :: Double +minAge = 0.1 +maxAge = 0.5 + +figure :: Figure +figure = Circle origin 1 + +-- #### Signal functions ####################################################### + +dustSF :: Point2 -> Angle -> Double -> Object +dustSF (x0,y0) o age = proc _ -> do + let vx = speed * cos o + vy = speed * sin o + + x <- (x0+) ^<< integral -< vx + y <- (y0+) ^<< integral -< vy + + die <- after age () -< () + + returnA -< ObjectOutput { + ooPos = (x,y), + ooCllsnBox = shape figure, -- doesn't collide with anything + ooGraphic = drawFigure . Translate (x,y) $ figure, + ooSpawnReq = NoEvent, + ooObjClass = Dust, + ooKillReq = die + } + +-- #### Function definitions ################################################### + +makeDust :: RandomGen g => Point2 -> Rand g Object +makeDust (x, y) = do + age <- getRandomR (minAge, maxAge) + x0 <- (x+) `liftM` getRandomR (-10.0,10) + y0 <- (y+) `liftM` getRandomR (-10.0,10) + o <- getRandomR (0, 2*pi) + + return (dustSF (x0,y0) o age) + diff --git a/src/Haskelloids/Object/Ship.hs b/src/Haskelloids/Object/Ship.hs new file mode 100644 --- /dev/null +++ b/src/Haskelloids/Object/Ship.hs @@ -0,0 +1,120 @@ +{-# OPTIONS_GHC -XArrows #-} +module Haskelloids.Object.Ship (shipSF, + shipFigure + ) where + +import Control.Arrow (returnA, (***)) + +import Haskelloids.Geometry (Figure(..), Shape(..), Point, Point2, Angle, shape) +import Haskelloids.Graphics (Graphic, drawFigure, drawShape) + +import FRP.Yampa (Event(..), (^<<), (<<^), (<<<), arr, constant, hold, integral, + gate, isEvent, tag, mergeBy) + +import Haskelloids.Input (UserInput(..)) +import Haskelloids.Object (Object, ObjectClass(..), ObjectInput(..), + ObjectOutput(..), teleport, reload) +import Haskelloids.Object.Bullet (bulletSF) + +-- #### Program constants ###################################################### + +-- shipFigure - the shape of the ship relative to the origin, facing 0 radians (East) +shipFigure :: Figure +shipFigure = Polygon [(15, 0), (-15, 10), (-9, 8), (-9, -8), (-15, -10), (15, 0)] + +thrustersFig :: Figure +thrustersFig = Polygon [(-9, 8), (-16, 0), (-9, -8)] + +-- cllsnFigure - the shape of the collidable area +cllsnFigure :: Figure +cllsnFigure = Polygon [(15, 0), (-15, 10), (-15, -10), (15, 0)] + +-- buffer - window edge buffer size, stops the ship appearing when teleporting from one edge to the other +buffer :: Int +buffer = 30 + +-- bullet - the point where the bullets come out +bulletBox :: Double +bulletBox = 15 + +-- turnRate - radians per second +turnRate :: Double +turnRate = 4 + +-- accel - acceleration in pixels per second per second +accel :: Double +accel = 350 + +-- frictionLoss - proportion of velocity lost due to friction +frictionLoss :: Double +frictionLoss = 0.6 + +-- reloadTime - delay ship takes to reload between user fire events +reloadTime :: Double +reloadTime = 0.1 + +-- thrusterFlickerPeriod - the period, in seconds of the thruster's flicker +thrusterFlickerPeriod :: Double +thrusterFlickerPeriod = 0.05 + +-- #### Signal functions ####################################################### + +-- shipSF - given window dimensions and an initial position, create a space-ship signal function, the ship will teleport back to the opposite side of the screen when it passes off any of the game window edges. +shipSF :: Point -> Point2 -> Object +shipSF (w, h) (x0, y0) = proc oi -> do + let ui = oiUserInput oi + l <- (\d -> if d then -turnRate else 0.0) ^<< hold False -< uiTurnLeft ui + r <- (\d -> if d then turnRate else 0.0) ^<< hold False -< uiTurnRight ui + + -- calculate orientation... + o <- ((-pi/2)+) ^<< integral -< l + r + + -- ...velocity and acceleration... + t <- hold False -< uiThrust ui + th <- arr (\d -> if d then accel else 0.0) -< t + let tx = th * cos o + ty = th * sin o + + rec + ax <- uncurry (-) ^<< (returnA *** ((* frictionLoss) ^<< integral)) -< (tx, ax) + ay <- uncurry (-) ^<< (returnA *** ((* frictionLoss) ^<< integral)) -< (ty, ay) + + vx <- integral -< ax + vy <- integral -< ay + + -- ...position + x <- teleport w buffer x0 -< vx + y <- teleport h buffer y0 -< vy + + -- is the user firing? have we reloaded our guns? + f <- reload reloadTime -< uiFire ui + + -- are we drawing the thrusters? + dt <- reload thrusterFlickerPeriod <<^ gate (Event ()) -< t + + -- check for crash + die <- arr oiHit -< oi + + -- ...return observable state + returnA -< + ObjectOutput { + ooPos = (x,y), + ooCllsnBox = shape . Translate (x,y) . Rotate o $ cllsnFigure, + ooGraphic = do { drawFigure . Translate (x,y) . Rotate o $ shipFigure + ; if isEvent dt + then drawFigure . Translate (x,y) . Rotate o $ thrustersFig + else return () }, + ooSpawnReq = f `tag` [blltSpwn (x,y) (vx,vy) o], + ooObjClass = Ship, + ooKillReq = die + } + where + -- blltSpwn - create a new bullet signal function + blltSpwn :: Point2 -> Point2 -> Angle -> Object + blltSpwn (x0,y0) (vx, vy) o = + let (x, y) = (x0 + (bulletBox * cos o), + y0 + (bulletBox * sin o)) + in bulletSF (w, h) (x,y) (vx, vy) o + +-- #### Function definitions ################################################### +