Haskelloids 0.1.0 → 0.1.1
raw patch · 12 files changed
+853/−3 lines, 12 filesdep −haskell98
Dependencies removed: haskell98
Files
- Haskelloids.cabal +14/−2
- src/Data/IdentityList.hs +56/−0
- src/Haskelloids.hs +0/−1
- src/Haskelloids/Geometry.hs +139/−0
- src/Haskelloids/Geometry/Text.hs +89/−0
- src/Haskelloids/Graphics.hs +22/−0
- src/Haskelloids/Input.hs +60/−0
- src/Haskelloids/Object.hs +106/−0
- src/Haskelloids/Object/Asteroid.hs +123/−0
- src/Haskelloids/Object/Bullet.hs +63/−0
- src/Haskelloids/Object/Dust.hs +61/−0
- src/Haskelloids/Object/Ship.hs +120/−0
Haskelloids.cabal view
@@ -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.*,
+ src/Data/IdentityList.hs view
@@ -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)
src/Haskelloids.hs view
@@ -1,7 +1,6 @@ -- #### Haskelloids.hs -- TODO Implement hyperspace jump--- TODO Implement extra asteroids -- TODO Implement bonus scores -- TODO Implement bonus life
+ src/Haskelloids/Geometry.hs view
@@ -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)
+ src/Haskelloids/Geometry/Text.hs view
@@ -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
+ src/Haskelloids/Graphics.hs view
@@ -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
+ src/Haskelloids/Input.hs view
@@ -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
+ src/Haskelloids/Object.hs view
@@ -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
+ src/Haskelloids/Object/Asteroid.hs view
@@ -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)
+ src/Haskelloids/Object/Bullet.hs view
@@ -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 ###################################################+
+ src/Haskelloids/Object/Dust.hs view
@@ -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)+
+ src/Haskelloids/Object/Ship.hs view
@@ -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 ###################################################+