diff --git a/AfterEffect.hs b/AfterEffect.hs
new file mode 100644
--- /dev/null
+++ b/AfterEffect.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module AfterEffect ( AfterEffect (..) ) where
+
+import Animation
+import Updating
+import Moving
+
+data AfterEffect =
+ forall a. ( Animation a
+ , Locatable a
+ , Transient a
+ , Audible a
+ ) => AfterEffect a
+ -- to be expanded algebraically
+
+instance InternallyUpdating AfterEffect where
+ preUpdate (AfterEffect a) et = AfterEffect (preUpdate a et)
+ postUpdate (AfterEffect a) et = AfterEffect (postUpdate a et)
+
+instance Transient AfterEffect where
+
+ expired' (AfterEffect a) = expired' a
+
+instance Audible AfterEffect where
+ processAudio (AfterEffect a) wp = do a' <- processAudio a wp
+ return (AfterEffect a')
+
+ terminateAudio (AfterEffect a) = do a' <- terminateAudio a
+ return (AfterEffect a')
+
diff --git a/AfterEffect.hs-boot b/AfterEffect.hs-boot
new file mode 100644
--- /dev/null
+++ b/AfterEffect.hs-boot
@@ -0,0 +1,3 @@
+module AfterEffect where
+
+data AfterEffect
diff --git a/AfterEffect/MineExplosion.hs b/AfterEffect/MineExplosion.hs
new file mode 100644
--- /dev/null
+++ b/AfterEffect/MineExplosion.hs
@@ -0,0 +1,86 @@
+module AfterEffect.MineExplosion where
+
+import Data.WrapAround
+import Animation
+import Updating
+import qualified Moving as M
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Sound.ALUT
+import Data.Maybe
+import ResourceTracker
+import GHC.Float
+
+data MineExplosion =
+ MineExplosion { center :: WrapPoint
+ , timeRemaining :: Double
+ , soundSource :: Maybe Source
+ , wrapMap :: WrapMap
+ , resourceTracker :: ResourceTracker
+ , animClock :: Double
+ }
+
+new :: ResourceTracker -> WrapMap -> WrapPoint -> MineExplosion
+new rt wmap center' =
+ MineExplosion { center = center'
+ , timeRemaining = 3.0
+ , soundSource = Nothing
+ , wrapMap = wmap
+ , resourceTracker = rt
+ , animClock = 0.0
+ }
+
+instance Animation MineExplosion where
+ image self t =
+ let dFrame = Color white (Scale 0.10 0.10 (Text "boom!")) in
+ let rt = resourceTracker self in
+ let at = animClock self in
+ if at < 0.1 then fromMaybe dFrame $ getImage rt "mine-explosion.bmp"
+ else Blank
+
+instance M.Locatable MineExplosion where
+ center = center
+
+instance Transient MineExplosion where
+
+ expired' self = if timeRemaining self <= 0.0
+ then Just []
+ else Nothing
+
+instance InternallyUpdating MineExplosion where
+
+ preUpdate self t = self { timeRemaining = timeRemaining self - t }
+
+ postUpdate self t = self { animClock = animClock self + t }
+
+instance Audible MineExplosion where
+
+ processAudio self lcenter =
+ if isNothing (soundSource self)
+ then do self' <- initializeSoundSource self
+ let (x, y) = vectorRelation
+ (wrapMap self')
+ (lcenter)
+ (center self')
+ let s = fromJust $ soundSource self'
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self'
+ else return self
+
+ terminateAudio self =
+ if isNothing (soundSource self)
+ then return self
+ else do stop [fromJust (soundSource self)]
+ return self
+
+initializeSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "explosion.wav"
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+ rolloffFactor source $= audioRolloffFactor
+ sourceGain source $= 0.5
+ return self { soundSource = Just source }
diff --git a/AfterEffect/SimpleExplosion.hs b/AfterEffect/SimpleExplosion.hs
new file mode 100644
--- /dev/null
+++ b/AfterEffect/SimpleExplosion.hs
@@ -0,0 +1,107 @@
+module AfterEffect.SimpleExplosion where
+
+import Data.WrapAround
+import Animation
+import Updating
+import qualified Moving as M
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Sound.ALUT
+import Data.Maybe
+import ResourceTracker
+import GHC.Float
+
+data SimpleExplosion =
+ SimpleExplosion { center :: WrapPoint
+ , timeRemaining :: Double
+ , soundSource :: Maybe Source
+ , wrapMap :: WrapMap
+ , resourceTracker :: ResourceTracker
+ , animClock :: Double
+ , velocity :: (Double, Double)
+ }
+
+new :: ResourceTracker -> WrapMap -> WrapPoint -> (Double, Double) -> SimpleExplosion
+new rt wmap center' velocity' =
+ SimpleExplosion { center = center'
+ , timeRemaining = 3.0
+ , soundSource = Nothing
+ , wrapMap = wmap
+ , resourceTracker = rt
+ , animClock = 0.0
+ , velocity = velocity'
+ }
+
+instance Animation SimpleExplosion where
+ image self t =
+ let dFrame = Color white (Scale 0.10 0.10 (Text "boom!")) in
+ let rt = resourceTracker self in
+ let f00 = fromMaybe dFrame $ getImage rt "explosion-00.bmp" in
+ let f01 = fromMaybe dFrame $ getImage rt "explosion-01.bmp" in
+ let f02 = fromMaybe dFrame $ getImage rt "explosion-02.bmp" in
+ let f03 = fromMaybe dFrame $ getImage rt "explosion-03.bmp" in
+ let f04 = fromMaybe dFrame $ getImage rt "explosion-04.bmp" in
+ let f05 = fromMaybe dFrame $ getImage rt "explosion-05.bmp" in
+ let f06 = fromMaybe dFrame $ getImage rt "explosion-06.bmp" in
+ let at = animClock self in
+ let fspace = 0.07 in
+ if at < fspace * 1 then f00
+ else if at < fspace * 2 then f01
+ else if at < fspace * 3 then f02
+ else if at < fspace * 4 then f03
+ else if at < fspace * 5 then f04
+ else if at < fspace * 6 then f05
+ else if at < fspace * 7 then f06
+ else Blank
+
+instance M.Locatable SimpleExplosion where
+ center = center
+
+instance Transient SimpleExplosion where
+
+ expired' self = if timeRemaining self <= 0.0
+ then Just []
+ else Nothing
+
+instance InternallyUpdating SimpleExplosion where
+
+ preUpdate self t = self { timeRemaining = timeRemaining self - t
+ , center = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t
+ }
+
+ postUpdate self t = self { animClock = animClock self + t }
+
+instance Audible SimpleExplosion where
+
+ processAudio self lcenter =
+ if isNothing (soundSource self)
+ then do self' <- initializeSoundSource self
+ let (x, y) = vectorRelation
+ (wrapMap self')
+ (lcenter)
+ (center self')
+ let s = fromJust $ soundSource self'
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self'
+ else return self
+
+ terminateAudio self =
+ if isNothing (soundSource self)
+ then return self
+ else do stop [fromJust (soundSource self)]
+ return self
+
+initializeSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "explosion.wav"
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+ rolloffFactor source $= audioRolloffFactor
+ sourceGain source $= 0.5
+ return self { soundSource = Just source }
diff --git a/Animation.hs b/Animation.hs
new file mode 100644
--- /dev/null
+++ b/Animation.hs
@@ -0,0 +1,30 @@
+module Animation where
+
+import Graphics.Gloss.Data.Picture
+import Moving
+import Data.WrapAround
+import Sound.ALUT
+
+class Animation a where
+ image :: a -> Double -> Picture
+
+class Audible a where
+ processAudio :: a -> WrapPoint -> IO a
+ terminateAudio :: a -> IO a
+
+{-
+ Note to self: I need to terminateAudio for the purpose of stopping sound
+ from Audible objects before they vanish (e.g., before a level change).
+ However, I am also concerned about the fact that the Sound.OpenAL API
+ doesn't seem to have any call for destroying a Source. I wonder if this is
+ handled automatically somehow, if I this will lead to a memory leak, with
+ Source objects accumulating in whatever system stores them.
+-}
+
+audioReferenceDistance = 300.0 :: Float
+
+-- audioMaxDistance = 800.0 :: Float
+
+audioRolloffFactor = 3.0 :: Float
+
+audioDistanceModel = InverseDistanceClamped
diff --git a/Asteroid.hs b/Asteroid.hs
new file mode 100644
--- /dev/null
+++ b/Asteroid.hs
@@ -0,0 +1,82 @@
+module Asteroid where
+
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import qualified Moving as M
+import Data.WrapAround
+import ResourceTracker
+import GHC.Float
+import Combat
+import Data.Maybe
+import SpaceJunk
+
+asteroidRadius = 15.0
+
+damageEnergy' = 100.0
+
+data Asteroid =
+ Asteroid { location :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , velocity :: (Double, Double)
+ , wrapMap :: WrapMap
+ , animDefault0 :: Picture
+ }
+
+new :: ResourceTracker -> WrapMap -> WrapPoint -> (Double, Double) -> Asteroid
+new rt wmap location velocity =
+ let pic = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "asteroid.bmp") in
+ Asteroid { location = location
+ , velocity = velocity
+ , wrapMap = wmap
+ , idealTargetLocation = Nothing
+ , animDefault0 = pic
+ }
+
+
+instance Animation Asteroid where
+ image self _ = animDefault0 self
+
+instance M.Locatable Asteroid where
+ center = location
+
+instance M.Moving Asteroid where
+ velocity = velocity
+
+instance M.Colliding Asteroid where
+ collisionRadius _ = asteroidRadius
+
+instance InternallyUpdating Asteroid where
+
+ preUpdate asteroid t = updateIdealTargetLocation t asteroid
+
+ postUpdate asteroid t =
+ let location' = fromMaybe
+ (location asteroid)
+ (idealTargetLocation asteroid) in
+ asteroid { location = location'
+ , idealTargetLocation = Nothing
+ }
+
+
+updateIdealTargetLocation t asteroid =
+ asteroid { idealTargetLocation = Just (M.idealNewLocation (wrapMap asteroid)
+ (location asteroid)
+ (velocity asteroid)
+ t)
+ }
+
+instance Damageable Asteroid where
+
+ inflictDamage = const
+
+
+instance Damaging Asteroid where
+
+ damageEnergy _ = damageEnergy'
+
diff --git a/BigAsteroid.hs b/BigAsteroid.hs
new file mode 100644
--- /dev/null
+++ b/BigAsteroid.hs
@@ -0,0 +1,80 @@
+module BigAsteroid where
+
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import qualified Moving as M
+import Data.WrapAround
+import ResourceTracker
+import GHC.Float
+import Combat
+import Data.Maybe
+
+asteroidRadius = 30.0
+
+punch = 100.0
+
+data BigAsteroid =
+ BigAsteroid { location :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , velocity :: (Double, Double)
+ , wrapMap :: WrapMap
+ , animDefault0 :: Picture
+ }
+
+new :: ResourceTracker -> WrapMap -> WrapPoint -> (Double, Double) -> BigAsteroid
+new rt wmap location velocity =
+ let pic = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "asteroidbig.bmp") in
+ BigAsteroid { location = location
+ , velocity = velocity
+ , wrapMap = wmap
+ , idealTargetLocation = Nothing
+ , animDefault0 = pic
+ }
+
+
+instance Animation BigAsteroid where
+ image self _ = animDefault0 self
+
+instance M.Locatable BigAsteroid where
+ center = location
+
+instance M.Moving BigAsteroid where
+ velocity = velocity
+
+instance M.Colliding BigAsteroid where
+ collisionRadius _ = asteroidRadius
+
+instance InternallyUpdating BigAsteroid where
+
+ preUpdate asteroid t = updateIdealTargetLocation t asteroid
+
+ postUpdate asteroid t =
+ let location' = fromMaybe
+ (location asteroid)
+ (idealTargetLocation asteroid) in
+ asteroid { location = location'
+ , idealTargetLocation = Nothing
+ }
+
+
+updateIdealTargetLocation t asteroid =
+ asteroid { idealTargetLocation = Just (M.idealNewLocation (wrapMap asteroid)
+ (location asteroid)
+ (velocity asteroid)
+ t)
+ }
+
+instance Damageable BigAsteroid where
+
+ inflictDamage = const
+
+
+instance Damaging BigAsteroid where
+
+ damageEnergy _ = punch
diff --git a/COPYING b/COPYING
new file mode 100644
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ Copyright (C)
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+.
diff --git a/Combat.hs b/Combat.hs
new file mode 100644
--- /dev/null
+++ b/Combat.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Combat where
+
+import Updating
+import Animation
+import Moving
+import Data.WrapAround
+
+data Projectile = forall a. ( Animation a
+ , Colliding a
+ , Transient a
+ , Damaging a
+ , Damageable a
+ ) => Projectile a
+
+instance Colliding Projectile where
+
+ collisionRadius (Projectile a) = collisionRadius a
+
+instance Moving Projectile where
+
+ velocity (Projectile a) = velocity a
+
+instance Locatable Projectile where
+ center (Projectile a) = center a
+
+instance Damaging Projectile where
+ damageEnergy (Projectile a) = damageEnergy a
+
+instance Damageable Projectile where
+ inflictDamage (Projectile a) et = Projectile (inflictDamage a et)
+
+instance Transient Projectile where
+ expired' (Projectile a) = expired' a
+
+instance InternallyUpdating Projectile where
+ preUpdate (Projectile a) et = Projectile (preUpdate a et)
+ postUpdate (Projectile a) et = Projectile (postUpdate a et)
+
+class Damaging a where
+
+ damageEnergy :: a -> Double
+
+class Damageable a where
+
+ inflictDamage :: a -> Double -> a
+
+inflictDamage' :: (Damaging a, Damageable b) => a -> b -> b
+inflictDamage' a b = inflictDamage b (damageEnergy a)
+
+class Launcher a where
+
+ deployProjectiles :: a -> ([Projectile], a)
+
+handleCollisionDamage :: ( Damaging a
+ , Damageable a
+ , Colliding a
+ , Damaging b
+ , Damageable b
+ , Colliding b
+ ) => WrapMap -> Double -> a -> [b] -> (a, [b])
+
+handleCollisionDamage wmap tw x ys = handleCollisionDamage' x ys []
+
+ where handleCollisionDamage' x [] nys = (x, nys)
+ handleCollisionDamage' x (y:ys) nys =
+ if not $ collisionWindow wmap (max
+ (maxExpectedVelocity * tw)
+ (collisionRadius x + collisionRadius y)) x y
+ then handleCollisionDamage' x ys (nys ++ [y])
+ else
+ case collision wmap tw x y of
+ Nothing -> handleCollisionDamage' x ys (nys ++ [y])
+ Just _ -> let (nx, ny) = ( inflictDamage' y x
+ , inflictDamage' x y
+ ) in
+ handleCollisionDamage' nx ys (nys ++ [ny])
+
+handleCollisionDamage' :: ( Damaging a
+ , Damageable a
+ , Colliding a
+ , Damaging b
+ , Damageable b
+ , Colliding b
+ ) => WrapMap -> Double -> [a] -> [b] -> ([a], [b])
+
+handleCollisionDamage' wmap tw xs ys = handleCollisionDamage'' xs ys []
+
+ where handleCollisionDamage'' [] ys nxs = (nxs, ys)
+ handleCollisionDamage'' (x:xs) ys nxs =
+ let (rx, rys) = handleCollisionDamage wmap tw x ys in
+ handleCollisionDamage'' xs rys (nxs ++ [rx])
+
+data Impacting = forall a. (Damaging a, Damageable a, Colliding a) => Impacting a
+
+
diff --git a/DONATE b/DONATE
new file mode 100644
--- /dev/null
+++ b/DONATE
@@ -0,0 +1,5 @@
+Care to support this free software project with a small donation? Visit:
+
+https://frigidcode.com/donate
+
+ -- Christopher Howard
diff --git a/Display.hs b/Display.hs
new file mode 100644
--- /dev/null
+++ b/Display.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Display (displayUniverse) where
+
+import Animation
+import Universe
+import Lance
+import Data.Maybe
+import Moving
+import Star
+import Data.WrapAround
+import Graphics.Gloss.Interface.IO.Game
+import GHC.Float
+import Combat
+import AfterEffect ( AfterEffect ( AfterEffect ) )
+import Unit
+import Item
+import ResourceTracker
+
+data Displayable = forall a. (Locatable a, Animation a) => Displayable a
+
+displayUniverse u
+ = let arena' = arena u in
+ let wmap = Universe.wrapMap arena' in
+ let pship = do lance' <- lance arena'
+ Just (image lance' undefined) in
+ let pship' = fromMaybe Blank pship in
+ let viewCenterWp = case lance arena' of
+ Just x -> Moving.center x
+ Nothing -> lastFocus arena' in
+ let displayables =
+ do (Displayable displayable)
+ <- map Displayable (stars arena')
+ ++ map Displayable (asteroids arena')
+ ++ [ Displayable a
+ | Projectile a <- lanceProjectiles arena'
+ ++ unitProjectiles arena'
+ ]
+ ++ [ case effect of
+ AfterEffect a -> Displayable a
+ | effect <- afterFX arena' ]
+ ++ [ Displayable a | SimpleUnit a <- simpleUnits arena' ]
+ ++ [ Displayable a | SmartUnit a <- smartUnits arena' ]
+ ++ [ Displayable a | a <- items arena' ]
+ let wp = Moving.center displayable in
+ let (x, y) = vectorRelation wmap wp viewCenterWp in
+ let pic = image displayable undefined in
+ [ Translate (double2Float x) (double2Float y) pic ] in
+ let deflectorBar' = Translate 65.0 370.0
+ (case lance arena' of
+ Just x -> deflectorBar (deflectorCharge x)
+ Nothing -> deflectorBar 0.8
+ ) in
+ let deflectorText' = Translate (-65.0) 365.0 deflectorText in
+ let levelText = Translate 140.0 365.0
+ (Color white
+ (Scale 0.14 0.14
+ (Text ("level " ++ show (level u + 1))))) in
+ let livesText = Translate (-140.0) 365.0
+ (Color white
+ (Scale 0.14 0.14
+ (Text (show (lives u) ++ " lives")))) in
+ let godText = case lance arena' of
+ Nothing -> Blank
+ Just l -> if not (godMode l)
+ then Blank
+ else Translate (-20.0) 335.0
+ (Color yellow
+ (Scale 0.14 0.14
+ (Text "god mode"))) in
+ let integrityText = Translate (-500.0) 365.0
+ (Color white
+ (Scale 0.14 0.14
+ (Text "structural integrity"))) in
+ let integrityAssessment =
+ case lance arena' of
+ Nothing -> Blank
+ Just l -> if integrity l >= 3.0
+ then Color green (Text "optimal")
+ else if integrity l >= 2.0
+ then Color yellow (Text "light damage")
+ else Color red (Text "heavy damage") in
+ let integrityTextL2 = Translate (-330.0) 365.0
+ (Scale 0.14 0.14
+ integrityAssessment) in
+ let sP = Translate 450.0 330.0
+ (sensorPanel arena' (100.0, 100.0)) in
+ return $ Pictures $ displayables
+ ++ [ pship'
+ , deflectorText'
+ , deflectorBar'
+ , levelText
+ , livesText
+ , sP
+ , godText
+ , integrityText
+ , integrityTextL2
+ , Translate (-400.0) 340.0 (inventoryDisplay
+ (lance arena')
+ (resourceTracker u))
+ ]
+
+inventoryDisplay :: Maybe Lance -> ResourceTracker -> Picture
+inventoryDisplay mLance rt =
+ let spacing = 40.0 in
+ case mLance of
+ Nothing -> Blank
+ Just l -> let i = inventory l in
+ let pFourWay =
+ if not (i !! 0)
+ then Blank
+ else let p = fromMaybe Blank
+ (getImage rt "item-fourway.bmp") in
+ Translate ((-2.0) * spacing) 0.0 p in
+ let pCannon =
+ if not (i !! 1)
+ then Blank
+ else let p = fromMaybe Blank
+ (getImage rt "item-cannon.bmp") in
+ Translate ((-1.0) * spacing) 0.0 p in
+ let pSpread =
+ if not (i !! 2)
+ then Blank
+ else let p = fromMaybe Blank
+ (getImage rt "item-spread.bmp") in
+ p in
+ let pRapidFire =
+ if not (i !! 3)
+ then Blank
+ else let p = fromMaybe Blank
+ (getImage rt "item-rapidfire.bmp") in
+ Translate spacing 0.0 p in
+ let pNuke =
+ if not (i !! 4)
+ then Blank
+ else let p = fromMaybe Blank
+ (getImage rt "item-nuke.bmp") in
+ Translate (2.0 * spacing) 0.0 p in
+ let c = currentWeapon l in
+ let pSelected =
+ if c == 0
+ then Blank
+ else Translate
+ ((fromIntegral c - 3.0) * spacing) 0.0
+ (Line [ (12.0, 13.0)
+ , (12.0, -12.0)
+ , (-13.0, -12.0)
+ , (-13.0, 13.0)
+ , (12.0, 13.0)
+ ]) in
+ Pictures [ pFourWay
+ , pCannon, pSpread, pRapidFire, pNuke, pSelected]
+
+sensorPanel :: Arena -> (Double, Double) -> Picture
+sensorPanel arena (w, h) =
+ let wmap = wrapmap w h in
+ let (w', h') = (double2Float w, double2Float h) in
+ let (w'', h'') = (w' * 0.5, h' * 0.5) in
+ -- let outline = Color white (Line [ (w' * 0.5, h' * 0.5)
+ -- , (w' * 0.5, (-h') * 0.5)
+ -- , ((-w') * 0.5,(-h') * 0.5)
+ -- , ((-w') * 0.5, h' * 0.5)
+ -- , (w' * 0.5, h' * 0.5)
+ -- ]) in
+ let outline = Color white
+ (Pictures
+ [ (Line [ (w'' - 4.0, h'')
+ , (w'', h'')
+ , (w'', h'' - 4.0)
+ ])
+ , (Line [ (w'', (-h'') + 4.0)
+ , (w'', (-h''))
+ , (w'' - 4.0, (-h''))
+ ])
+ , (Line [ ((-w''), (-h'') + 4.0)
+ , ((-w''), (-h''))
+ , ((-w'') + 4.0, (-h''))
+ ])
+ , (Line [ ((-w''), h'' - 4.0)
+ , ((-w''), h'')
+ , ((-w'') + 4.0, h'')
+ ])
+ ]) in
+
+ let focalPoint = Color white (Line [ (2.0, 0.0)
+ , (0.0, 2.0)
+ , (-2.0, 0.0)
+ , (0.0, -2.0)
+ , (2.0, 0.0)
+ ]) in
+ let unitDots =
+ [ let cp = case lance arena of
+ Nothing -> lastFocus arena
+ Just l -> Moving.center l in
+ let (x, y) = vectorRelation wmap cp c in
+ Translate
+ (double2Float (-x))
+ (double2Float (-y))
+ (Color white (Polygon [ (2.0, 0.0)
+ , (0.0, 2.0)
+ , (-2.0, 0.0)
+ , (0.0, -2.0)
+ ]))
+ | c <- map Moving.center (simpleUnits arena)
+ ++ map Moving.center (smartUnits arena)
+ ] in
+ let itemDots =
+ [ let cp = case lance arena of
+ Nothing -> lastFocus arena
+ Just l -> Moving.center l in
+ let (x, y) = vectorRelation wmap cp c in
+ Translate
+ (double2Float (-x))
+ (double2Float (-y))
+ (Color cyan (Polygon [ (2.0, 0.0)
+ , (0.0, 2.0)
+ , (-2.0, 0.0)
+ , (0.0, -2.0)
+ ]))
+ | c <- map Moving.center (items arena)
+ ] in
+ Pictures $ [ outline
+ , focalPoint
+ ] ++ unitDots ++ itemDots
+
+deflectorText = Color white (Scale 0.14 0.14 (Text "deflector"))
+
+deflectorBar charge =
+ let width = 100.0 in
+ let height = 20.0 in
+ let outline = Line [ ((-width) / 2.0, height / 2.0)
+ , (width / 2.0, height / 2.0)
+ , (width / 2.0, (-height) / 2.0)
+ , ((-width) / 2.0, (-height) / 2.0)
+ , ((-width) / 2.0, height / 2.0)
+ ] in
+ let portion = (double2Float charge - 0.8) / (2.0 - 0.8) in
+ let barColor = if charge < 1.0 then red
+ else white in
+ let bar = Polygon [ ((-width) / 2.0, height / 2.0)
+ , ((-width) / 2.0 + portion * width, height / 2.0)
+ , ((-width) / 2.0 + portion * width, (-height) / 2.0)
+ , ((-width) / 2.0, (-height) / 2.0)
+ ] in
+ Pictures [Color barColor bar
+ , Color white outline
+ ]
diff --git a/Input.hs b/Input.hs
new file mode 100644
--- /dev/null
+++ b/Input.hs
@@ -0,0 +1,188 @@
+module Input where
+
+import Universe
+import Graphics.Gloss.Interface.IO.Game
+import Lance
+
+handleInput :: Event -> Universe -> IO Universe
+
+handleInput (EventKey (Char ':') Down Modifiers { shift = Down
+ , ctrl = Down
+ , alt = Down
+ } _) u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { godMode = True } } }
+
+handleInput (EventKey (Char '"') Down Modifiers { shift = Down
+ , ctrl = Down
+ , alt = Down
+ } _) u
+ = return u { skipLevel = True }
+
+--- two-hand keys ---
+
+handleInput (EventKey (SpecialKey KeyLeft) Down _ _) u
+ = ccwThrusters u
+
+handleInput (EventKey (SpecialKey KeyLeft) Up _ _) u
+ = stabilizeThrusters u
+
+handleInput (EventKey (SpecialKey KeyRight) Down _ _) u
+ = cwThrusters u
+
+handleInput (EventKey (SpecialKey KeyRight) Up _ _) u
+ = stabilizeThrusters u
+
+handleInput (EventKey (SpecialKey KeyUp) Down _ _) u
+ = activateForwardThrusters u
+
+handleInput (EventKey (SpecialKey KeyUp) Up _ _) u
+ = deactivateForwardThrusters u
+
+handleInput (EventKey (SpecialKey KeySpace) Down _ _) u
+ = activateDeflector u
+
+handleInput (EventKey (SpecialKey KeySpace) Up _ _) u
+ = deactivateDeflector u
+
+handleInput (EventKey (Char 'a') Down _ _) u
+ = setFireTrigger u
+
+handleInput (EventKey (Char 'a') Up _ _) u
+ = releaseFireTrigger u
+
+handleInput (EventKey (SpecialKey KeyTab) Down _ _) u
+ = switchWeapon u
+
+--------------------- keypad keys
+
+handleInput (EventKey (Char '4') Down _ _) u
+ = ccwThrusters u
+
+handleInput (EventKey (Char '4') Up _ _) u
+ = stabilizeThrusters u
+
+handleInput (EventKey (Char '6') Down _ _) u
+ = cwThrusters u
+
+handleInput (EventKey (Char '6') Up _ _) u
+ = stabilizeThrusters u
+
+handleInput (EventKey (Char '8') Down _ _) u
+ = activateForwardThrusters u
+
+handleInput (EventKey (Char '8') Up _ _) u
+ = deactivateForwardThrusters u
+
+handleInput (EventKey (Char '0') Down _ _) u
+ = setFireTrigger u
+
+handleInput (EventKey (Char '0') Up _ _) u
+ = releaseFireTrigger u
+
+handleInput (EventKey (SpecialKey KeyEnter) Down _ _) u
+ = activateDeflector u
+
+handleInput (EventKey (SpecialKey KeyEnter) Up _ _) u
+ = deactivateDeflector u
+
+handleInput (EventKey (Char '5') Down _ _) u
+ = switchWeapon u
+
+handleInput _ u = return u
+
+setFireTrigger u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { fireTrigger = True } } }
+
+releaseFireTrigger u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { fireTrigger = False } } }
+
+activateDeflector u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { deflector = True } } }
+
+deactivateDeflector u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { deflector = False } } }
+
+ccwThrusters u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { rotationalThrusters = CCW } } }
+
+stabilizeThrusters u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { rotationalThrusters = Stable } } }
+
+cwThrusters u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { rotationalThrusters = CW } } }
+
+activateForwardThrusters u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { linearThrusters = True } } }
+
+deactivateForwardThrusters u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just l
+ { linearThrusters = False } } }
+
+switchWeapon u
+ = let a = arena u in
+ let mL = lance a in
+ case mL of
+ Nothing -> return u
+ Just l -> return u { arena = a
+ { lance = Just (changeCurrentWeapon l) }
+ }
+
diff --git a/Item.hs b/Item.hs
new file mode 100644
--- /dev/null
+++ b/Item.hs
@@ -0,0 +1,58 @@
+module Item where
+
+import Data.WrapAround
+import Moving
+import Animation
+import Data.Maybe
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import ResourceTracker
+import System.Random
+
+data ItemType = Health
+ | FourWay
+ | Cannon
+ | Spread
+ | RapidFire
+ | Nuke
+ deriving (Show)
+
+data Item = Item ItemType ResourceTracker WrapPoint
+ deriving (Show)
+
+instance Colliding Item where
+ collisionRadius _ = 11.0
+
+instance Locatable Item where
+ center (Item _ _ a) = a
+
+instance Moving Item where
+
+ velocity _ = (0.0, 0.0)
+
+instance Animation Item where
+ image (Item ty rt _) _ = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt pic)
+ where pic = case ty of
+ Health -> "item-health.bmp"
+ FourWay -> "item-fourway.bmp"
+ Cannon -> "item-cannon.bmp"
+ Spread -> "item-spread.bmp"
+ RapidFire -> "item-rapidfire.bmp"
+ Nuke -> "item-nuke.bmp"
+
+randomItemType :: IO (ItemType)
+randomItemType = do let min = (0 :: Int)
+ let max = (5 :: Int)
+ r <- randomRIO (min, max)
+ return $
+ case r of
+ 0 -> Health
+ 1 -> FourWay
+ 2 -> Cannon
+ 3 -> Spread
+ 4 -> RapidFire
+ otherwise -> Nuke
diff --git a/Lance.hs b/Lance.hs
new file mode 100644
--- /dev/null
+++ b/Lance.hs
@@ -0,0 +1,416 @@
+module Lance ( Lance ( rotationalThrusters
+ , linearThrusters
+ , deflector
+ , fireTrigger
+ , deflectorCharge
+ , center
+ , angle
+ , velocity
+ , godMode
+ , integrity
+ , inventory
+ , currentWeapon
+ )
+ , new
+ , RotationDirection (..)
+ , shielded
+ , processItem
+ , changeCurrentWeapon
+ ) where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Trigonometry
+import ResourceTracker
+import Data.Maybe
+import Updating
+import qualified Moving as M
+import Combat
+import qualified Projectile.BulletMkI as P.BulletMkI
+import qualified Projectile.Cannon as P.Cannon
+import qualified Projectile.Nuke as P.Nuke
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Sound.ALUT
+import Item
+
+radialVelocity = pi -- radians per second
+
+accelerationRate = 200 -- points per second
+
+maxVelocity = 500 -- points per second
+
+kamikazeDamage = 8.0
+
+deflectorChargeLossFactor = 0.8
+
+data RotationDirection = Stable | CW | CCW
+ deriving (Eq)
+
+type LanceInventory = [Bool]
+
+data Lance = Lance { angle :: Double -- radians
+ , center :: WrapPoint
+ , rotationalThrusters :: RotationDirection
+ , idealTargetCenter :: Maybe WrapPoint
+ , velocity :: (Double, Double)
+ , linearThrusters :: Bool
+ , wrapMap :: WrapMap
+ , resourceTracker :: ResourceTracker
+
+ -- deflector
+ , deflectorCharge :: Double
+ , deflector :: Bool
+
+ -- firing
+ , launchTube :: [Projectile]
+ , sinceLastShot :: Double
+ , fireTrigger :: Bool
+ , currentWeapon :: Int
+ , inventory :: LanceInventory
+
+ -- death
+ , integrity :: Double
+
+ -- Sound
+ , queueShotSound :: Bool
+ , shotSoundSource :: Maybe Source
+
+ , godMode :: Bool
+ }
+
+new :: ResourceTracker -> WrapMap -> WrapPoint -> Lance
+new rt wmap center =
+ Lance { center = center
+ , angle = 0.0
+ , rotationalThrusters = Stable
+ , idealTargetCenter = Nothing
+ , velocity = (0.0, 0.0)
+ , linearThrusters = False
+ , wrapMap = wmap
+ , resourceTracker = rt
+ , deflector = False
+ , deflectorCharge = 2.0
+ , launchTube = []
+ , sinceLastShot = 0.0
+ , fireTrigger = False
+ , currentWeapon = 0
+ , inventory = [False, False, False, False, False]
+ , queueShotSound = False
+ , shotSoundSource = Nothing
+ , godMode = False
+ , integrity = 3.0
+ }
+
+changeCurrentWeapon self =
+ let i = inventory self in
+ let c = currentWeapon self in
+ let c' = if c + 1 > 5
+ then if i !! 0
+ then 1
+ else 0
+ else c + 1 in
+ if c' /= 0 && not (i !! (c' - 1))
+ then changeCurrentWeapon self { currentWeapon = c' }
+ else self { currentWeapon = c' }
+
+replaceAt :: Int -> a -> [a] -> [a]
+replaceAt i a as
+ | i < 0 = as
+ | i >= length as = as
+ | otherwise = let x = take i as in
+ let y = drop (i + 1) as in
+ x ++ [a] ++ y
+
+processItem :: Lance -> Item -> Lance
+processItem self (Item typ _ _) =
+ case typ of
+ Health -> self { integrity = 3.0 }
+ FourWay -> self { inventory = replaceAt 0 True (inventory self)
+ , currentWeapon = 1
+ }
+ Cannon -> self { inventory = replaceAt 1 True (inventory self)
+ , currentWeapon = 2
+ }
+ Spread -> self { inventory = replaceAt 2 True (inventory self)
+ , currentWeapon = 3
+ }
+ RapidFire -> self { inventory = replaceAt 3 True (inventory self)
+ , currentWeapon = 4
+ }
+ Nuke -> self { inventory = replaceAt 4 True (inventory self)
+ , currentWeapon = 5
+ }
+
+instance Audible Lance where
+
+ processAudio self lcenter =
+ do self' <- if isNothing (shotSoundSource self)
+ then initializeShotSoundSource self
+ else return self
+ if not (queueShotSound self)
+ then return self'
+ else do play [fromJust $ shotSoundSource self]
+ return self' { queueShotSound = False }
+
+ terminateAudio self =
+ if isNothing (shotSoundSource self)
+ then return self
+ else do stop [fromJust (shotSoundSource self)]
+ return self
+
+initializeShotSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "simple-energy-shot.wav"
+ -- ...
+ return self { shotSoundSource = Just source }
+
+shielded :: Lance -> Bool
+shielded lance = deflectorCharge lance >= 1.0 && deflector lance
+
+updateAngle :: Double -> Lance -> Lance
+updateAngle t lance
+ | rotationalThrusters lance == CW
+ = lance { angle = angle lance - radialVelocity * t}
+ | rotationalThrusters lance == CCW
+ = lance { angle = angle lance + radialVelocity * t}
+ | otherwise = lance
+
+instance Animation Lance where
+ image lance _ = let rt = resourceTracker lance in
+ let lancePic = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "lance.bmp") in
+ let lanceThrustingPic =
+ fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "lance-thrusting.bmp") in
+ let pic = if linearThrusters lance then lanceThrustingPic
+ else lancePic in
+ let deflector' = if deflector lance
+ && deflectorCharge lance >= 1.0
+ then Color white (Circle 40.0)
+ else Blank in
+ Pictures [ deflector'
+ , Rotate (radToDeg
+ (double2Float
+ (angle lance)) * (-1) - 90) pic
+ ]
+
+instance M.Locatable Lance where
+ center = Lance.center
+
+instance M.Moving Lance where
+ velocity = velocity
+
+instance M.Colliding Lance where
+ collisionRadius _ = 20.0
+
+instance InternallyUpdating Lance where
+
+ preUpdate lance t = (updateFiringInformation t .
+ updateIdealTargetCenter t .
+ updateVelocity t .
+ updateAngle t) lance
+
+ postUpdate lance t =
+ let center' = fromMaybe (center lance) (idealTargetCenter lance) in
+ updateDeflectorCharge t
+ lance { center = center'
+ , idealTargetCenter = Nothing
+ }
+
+updateFiringInformation t lance =
+ let sinceLastShot' = sinceLastShot lance + t in
+ case currentWeapon lance of
+ 1 -> handleFourWayWeapon lance sinceLastShot'
+ 2 -> handleCannonWeapon lance sinceLastShot'
+ 3 -> handleSpreadWeapon lance sinceLastShot'
+ 4 -> handleRapidFireWeapon lance sinceLastShot'
+ 5 -> handleNukeWeapon lance sinceLastShot'
+ otherwise -> handleDefaultWeapon lance sinceLastShot'
+
+handleDefaultWeapon self ls =
+ if ls >= 0.4 && fireTrigger self
+ then self { sinceLastShot = 0.0
+ , launchTube =
+ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self)
+ (center self)
+ (velocity self) ) : launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = ls }
+
+handleFourWayWeapon self ls =
+ if ls >= 0.4 && fireTrigger self
+ then self { sinceLastShot = 0.0
+ , launchTube =
+ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self)
+ (center self)
+ (velocity self) ) ]
+ ++ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self + pi / 2)
+ (center self)
+ (velocity self) ) ]
+ ++ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self + pi)
+ (center self)
+ (velocity self) ) ]
+ ++ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self + 3 * pi / 2)
+ (center self)
+ (velocity self) ) ]
+ ++ launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = ls }
+
+handleCannonWeapon self ls =
+ if ls >= 0.7 && fireTrigger self
+ then self { sinceLastShot = 0.0
+ , launchTube =
+ Projectile ( P.Cannon.new
+ (wrapMap self)
+ (angle self)
+ (center self)
+ (velocity self) ) : launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = ls }
+
+handleSpreadWeapon self ls =
+ let spreadAngle = pi / 10 in
+ if ls >= 0.4 && fireTrigger self
+ then self { sinceLastShot = 0.0
+ , launchTube =
+ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self)
+ (center self)
+ (velocity self) ) ]
+ ++ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self + spreadAngle)
+ (center self)
+ (velocity self) ) ]
+ ++ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self + spreadAngle * 2)
+ (center self)
+ (velocity self) ) ]
+ ++ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self - spreadAngle)
+ (center self)
+ (velocity self) ) ]
+ ++ [ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self - spreadAngle * 2)
+ (center self)
+ (velocity self) ) ]
+ ++ launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = ls }
+
+handleRapidFireWeapon self ls =
+ if ls >= 0.2 && fireTrigger self
+ then self { sinceLastShot = 0.0
+ , launchTube =
+ Projectile ( P.BulletMkI.new
+ (wrapMap self)
+ (angle self)
+ (center self)
+ (velocity self) ) : launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = ls }
+
+handleNukeWeapon self ls =
+ if ls >= 3.0 && fireTrigger self
+ then self { sinceLastShot = 0.0
+ , launchTube =
+ Projectile ( P.Nuke.new
+ (wrapMap self)
+ (resourceTracker self)
+ (angle self)
+ (center self)
+ (velocity self) ) : launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = ls }
+
+updateDeflectorCharge t lance =
+ let charge = deflectorCharge lance in
+ let charge' = if deflector lance then max 0.8 (charge - t
+ * deflectorChargeLossFactor)
+ else min 2.0 (charge + t * 0.05) in
+ lance { deflectorCharge = charge' }
+
+updateIdealTargetCenter :: Double -> Lance -> Lance
+updateIdealTargetCenter t lance =
+ lance { idealTargetCenter = Just (M.idealNewLocation (wrapMap lance)
+ (center lance)
+ (velocity lance)
+ t)
+ }
+
+updateVelocity :: Double -> Lance -> Lance
+updateVelocity t lance
+ | linearThrusters lance =
+ lance { velocity = M.calcNewVelocity
+ (velocity lance)
+ accelerationRate
+ (angle lance)
+ maxVelocity
+ t
+ }
+ | otherwise = lance
+
+instance Launcher Lance where
+
+ deployProjectiles self = (launchTube self, self { launchTube = []
+ -- , sinceLastShot = 0.0
+ })
+
+instance Damaging Lance where
+
+ damageEnergy self =
+ if not (deflector self) || deflectorCharge self < 1.0
+ then kamikazeDamage
+ else 0.0
+
+instance Damageable Lance where
+
+ inflictDamage self d =
+ let d' = if godMode self then 0 else d in
+ if d' > 0 && (not (deflector self) || deflectorCharge self < 1.0)
+ then self { integrity = integrity self - d }
+ else self
+
+instance Transient Lance where
+
+ expired' self = if not (integrity self <= 0.0)
+ then Nothing
+ else Just [ef]
+ where ef = AfterEffect (SimpleExplosion.new (resourceTracker self)
+ (wrapMap self)
+ (Lance.center self)
+ (Lance.velocity self))
+
+-- instance Audible Lance where
+-- processAudio self = queueShotFX
diff --git a/Moving.hs b/Moving.hs
new file mode 100644
--- /dev/null
+++ b/Moving.hs
@@ -0,0 +1,97 @@
+module Moving where
+
+import Data.WrapAround
+import qualified Data.WrapAround as W
+import Trigonometry
+import Data.List (find)
+import Control.Monad (join)
+
+maxExpectedVelocity = 1000 -- should equal max velocity of fastest object in arena
+
+calcNewVelocity
+ :: (Double, Double) -> Double -> Double -> Double -> Double -> (Double, Double)
+calcNewVelocity oVelocity accelerationRate thrustAngle maxVelocity t =
+ let (vXo, vYo) = oVelocity in
+ let acceleration = t * accelerationRate in
+ let dX = cos thrustAngle * acceleration in
+ let dY = sin thrustAngle * acceleration in
+ let vXn = vXo + dX in
+ let vYn = vYo + dY in
+ let magVN' = sqrt (vXn ** 2 + vYn ** 2) in
+ let magVN = if magVN' == 0 then 0.1 -- erm... necessary?
+ else magVN' in
+ let aVN = if vXn >= 0 then asin (vYn / magVN)
+ else pi - asin (vYn / magVN) in
+ let finalMag = min magVN maxVelocity in
+ let finalX = cos aVN * finalMag in
+ let finalY = sin aVN * finalMag in
+ (finalX, finalY)
+
+idealNewLocation :: WrapMap -> WrapPoint -> (Double, Double) -> Double -> WrapPoint
+idealNewLocation wmap oLocation (velX, velY) t =
+ addPoints' wmap oLocation velocity'
+ where velocity' = (velX * t, velY * t)
+
+class Locatable a where
+ center :: a -> WrapPoint
+
+class (Locatable a) => Moving a where
+
+ velocity :: a -> (Double, Double)
+
+class (Moving a) => Colliding a where
+
+ collisionRadius :: a -> Double
+
+data Collision = Collision { time :: Double -- since start of collision detection
+ -- window frame
+ , center1 :: WrapPoint -- at point of collision
+ , center2 :: WrapPoint -- likewise
+ }
+
+-- Double refers to time window for checking for collision
+collision :: (Colliding a, Colliding b)
+ => WrapMap
+ -> Double
+ -> a
+ -> b
+ -> Maybe Collision
+collision wmap tw obj1 obj2 =
+ let r1 = collisionRadius obj1 in
+ let r2 = collisionRadius obj2 in
+ let v1 = velocity obj1 in
+ let v2 = velocity obj2 in
+ let dD = Trigonometry.distance v1 v2 in
+ let ts = fromIntegral $ ceiling (dD / (r1 + r2)) in
+ let ti = tw / ts in
+ let tpoints = [ x * ti | x <- [0..ts] ] in
+ let o1 = center obj1 in
+ let o2 = center obj2 in
+ let points = [ ( addPoints' wmap o1 (mulSV t v1)
+ , addPoints' wmap o2 (mulSV t v2)
+ ) | t <- tpoints ] in
+ let distances = [ W.distance wmap p1 p2 | (p1, p2) <- points ] in
+ let zipped = zip3 tpoints points distances in
+ do (t, (p1, p2), _) <- find (\(_, _, d) -> d <= r1 + r2) zipped
+ Just Collision { time = t
+ , center1 = p1
+ , center2 = p2
+ }
+
+collisionWindow :: (Colliding a, Colliding b) => WrapMap -> Double -> a -> b -> Bool
+collisionWindow wmap range obj1 obj2 =
+ W.distance wmap (center obj1) (center obj2) <= range
+
+collisionScan :: (Colliding a, Colliding b) => WrapMap -> a -> [b] -> Double -> Maybe Collision
+collisionScan wmap c cs t =
+ let relAsteroids =
+ [ a | a <- cs
+ , let range = max (maxExpectedVelocity * 2 * t)
+ (collisionRadius c + collisionRadius a) in
+ collisionWindow wmap range c a
+ ] in
+ let collisions = map (collision wmap t c) relAsteroids in
+ join (find (\a -> case a of
+ Nothing -> False
+ otherwise -> True) collisions)
+
diff --git a/Projectile/Blade.hs b/Projectile/Blade.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/Blade.hs
@@ -0,0 +1,114 @@
+module Projectile.Blade ( Blade(..)
+ , new
+ , range
+ , speed
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+import Trigonometry
+import Data.Maybe
+import ResourceTracker
+import GHC.Float
+
+velocityC = 250.0
+rangeC = 1500.0
+punch = 4.0
+
+range = rangeC
+speed = velocityC
+
+data Blade =
+ Blade { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , rangeLeft :: Double
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , clock :: Double
+ , resourceTracker :: ResourceTracker
+ }
+
+-- angle is radians
+new :: WrapMap -> ResourceTracker -> Double -> WrapPoint -> (Double, Double) -> Blade
+new wmap rt angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ Blade { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , rangeLeft = rangeC
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , clock = 0.0
+ , resourceTracker = rt
+ }
+
+instance Animation Blade where
+
+ image self t = Rotate (double2Float deg) p
+ where deg = radToDeg ((clock self * 4 * pi) `doubleRem` (2 * pi))
+ p = fromMaybe
+ (Color white
+ (Line [(-40, 0), (40, 0)]))
+ (getImage rt "blade.bmp")
+ rt = resourceTracker self
+
+instance M.Colliding Blade where
+
+ collisionRadius self = 20.0
+
+instance M.Moving Blade where
+
+ velocity self = Projectile.Blade.velocity self
+
+instance M.Locatable Blade where
+
+ center self = Projectile.Blade.center self
+
+instance SimpleTransient Blade where
+
+ expired self = rangeLeft self <= 0.0
+
+instance InternallyUpdating Blade where
+
+ preUpdate self t = updateIdealTargetCenter t self
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ , clock = clock self + t
+ }
+
+updateIdealTargetCenter :: Double -> Blade -> Blade
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ , rangeLeft = max 0.0 $ rangeLeft self
+ - Data.WrapAround.distance (wrapMap self)
+ (center self)
+ (newLoc)
+ }
+
+instance Damaging Blade where
+
+ damageEnergy b = punch
+
+instance Transient Blade where
+
+ expired' self = if rangeLeft self <= 0.0
+ then Just []
+ else Nothing
+
+instance Damageable Blade where
+
+ inflictDamage self d = self
diff --git a/Projectile/BulletMI.hs b/Projectile/BulletMI.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/BulletMI.hs
@@ -0,0 +1,111 @@
+module Projectile.BulletMI ( BulletMI(..)
+ , new
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+
+velocityC = 400.0
+rangeC = 500.0
+
+data BulletMI =
+ BulletMI { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , rangeLeft :: Double
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , impacted :: Bool
+ , clock :: Double
+ }
+
+-- angle is radians
+new :: WrapMap -> Double -> WrapPoint -> (Double, Double) -> BulletMI
+new wmap angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ BulletMI { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , rangeLeft = rangeC
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , impacted = False
+ , clock = 0.0
+ }
+
+instance Animation BulletMI where
+
+ image self t = let r = fromInteger (ceiling (clock self)) - clock self in
+ Color (c r)
+ (Rotate 45.0
+ (Circle 4.0))
+ where c x | x < 0.10 = red
+ | x < 0.20 = yellow
+ | x < 0.30 = red
+ | x < 0.40 = yellow
+ | x < 0.50 = red
+ | x < 0.60 = yellow
+ | x < 0.70 = red
+ | x < 0.80 = yellow
+ | x < 0.90 = red
+ | otherwise = yellow
+
+instance M.Colliding BulletMI where
+
+ collisionRadius b = 2.0
+
+instance M.Moving BulletMI where
+
+ velocity b = Projectile.BulletMI.velocity b
+
+instance M.Locatable BulletMI where
+
+ center b = Projectile.BulletMI.center b
+
+instance SimpleTransient BulletMI where
+
+ expired b = rangeLeft b <= 0.0
+
+instance InternallyUpdating BulletMI where
+
+ preUpdate self t = let s' = updateIdealTargetCenter t self in
+ s' { clock = clock self + t }
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ }
+
+updateIdealTargetCenter :: Double -> BulletMI -> BulletMI
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ , rangeLeft = max 0.0 $ rangeLeft self - distance (wrapMap self)
+ (center self)
+ (newLoc)
+ }
+
+instance Damaging BulletMI where
+
+ damageEnergy b = 2.0
+
+instance Transient BulletMI where
+
+ expired' self = if impacted self || rangeLeft self <= 0.0
+ then Just []
+ else Nothing
+
+instance Damageable BulletMI where
+
+ inflictDamage self d = if d > 0 then self { impacted = True }
+ else self
diff --git a/Projectile/BulletMII.hs b/Projectile/BulletMII.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/BulletMII.hs
@@ -0,0 +1,111 @@
+module Projectile.BulletMII ( BulletMII(..)
+ , new
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+
+velocityC = 400.0
+rangeC = 700.0
+
+data BulletMII =
+ BulletMII { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , rangeLeft :: Double
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , impacted :: Bool
+ , clock :: Double
+ }
+
+-- angle is radians
+new :: WrapMap -> Double -> WrapPoint -> (Double, Double) -> BulletMII
+new wmap angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ BulletMII { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , rangeLeft = rangeC
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , impacted = False
+ , clock = 0.0
+ }
+
+instance Animation BulletMII where
+
+ image self t = let r = fromInteger (ceiling (clock self)) - clock self in
+ Color (c r)
+ (Rotate 45.0
+ (Circle 4.0))
+ where c x | x < 0.10 = red
+ | x < 0.20 = yellow
+ | x < 0.30 = red
+ | x < 0.40 = yellow
+ | x < 0.50 = red
+ | x < 0.60 = yellow
+ | x < 0.70 = red
+ | x < 0.80 = yellow
+ | x < 0.90 = red
+ | otherwise = yellow
+
+instance M.Colliding BulletMII where
+
+ collisionRadius b = 2.0
+
+instance M.Moving BulletMII where
+
+ velocity b = Projectile.BulletMII.velocity b
+
+instance M.Locatable BulletMII where
+
+ center b = Projectile.BulletMII.center b
+
+instance SimpleTransient BulletMII where
+
+ expired b = rangeLeft b <= 0.0
+
+instance InternallyUpdating BulletMII where
+
+ preUpdate self t = let s' = updateIdealTargetCenter t self in
+ s' { clock = clock self + t }
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ }
+
+updateIdealTargetCenter :: Double -> BulletMII -> BulletMII
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ , rangeLeft = max 0.0 $ rangeLeft self - distance (wrapMap self)
+ (center self)
+ (newLoc)
+ }
+
+instance Damaging BulletMII where
+
+ damageEnergy b = 2.0
+
+instance Transient BulletMII where
+
+ expired' self = if impacted self || rangeLeft self <= 0.0
+ then Just []
+ else Nothing
+
+instance Damageable BulletMII where
+
+ inflictDamage self d = if d > 0 then self { impacted = True }
+ else self
diff --git a/Projectile/BulletMkI.hs b/Projectile/BulletMkI.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/BulletMkI.hs
@@ -0,0 +1,111 @@
+module Projectile.BulletMkI ( BulletMkI(..)
+ , new
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+
+velocityC = 700.0
+rangeC = 1000.0
+
+data BulletMkI =
+ BulletMkI { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , rangeLeft :: Double
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , impacted :: Bool
+ , clock :: Double
+ }
+
+-- angle is radians
+new :: WrapMap -> Double -> WrapPoint -> (Double, Double) -> BulletMkI
+new wmap angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ BulletMkI { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , rangeLeft = rangeC
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , impacted = False
+ , clock = 0.0
+ }
+
+instance Animation BulletMkI where
+
+ image self t = let r = fromInteger (ceiling (clock self)) - clock self in
+ Color (c r)
+ (Rotate 45.0
+ (Circle 2.0))
+ where c x | x < 0.10 = blue
+ | x < 0.20 = cyan
+ | x < 0.30 = blue
+ | x < 0.40 = cyan
+ | x < 0.50 = blue
+ | x < 0.60 = cyan
+ | x < 0.70 = blue
+ | x < 0.80 = cyan
+ | x < 0.90 = blue
+ | otherwise = cyan
+
+instance M.Colliding BulletMkI where
+
+ collisionRadius b = 1.0
+
+instance M.Moving BulletMkI where
+
+ velocity b = Projectile.BulletMkI.velocity b
+
+instance M.Locatable BulletMkI where
+
+ center b = Projectile.BulletMkI.center b
+
+instance SimpleTransient BulletMkI where
+
+ expired b = rangeLeft b <= 0.0
+
+instance InternallyUpdating BulletMkI where
+
+ preUpdate self t = let s' = updateIdealTargetCenter t self in
+ s' { clock = clock self + t }
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ }
+
+updateIdealTargetCenter :: Double -> BulletMkI -> BulletMkI
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ , rangeLeft = max 0.0 $ rangeLeft self - distance (wrapMap self)
+ (center self)
+ (newLoc)
+ }
+
+instance Damaging BulletMkI where
+
+ damageEnergy b = 1.0
+
+instance Transient BulletMkI where
+
+ expired' self = if impacted self || rangeLeft self <= 0.0
+ then Just []
+ else Nothing
+
+instance Damageable BulletMkI where
+
+ inflictDamage self d = if d > 0 then self { impacted = True }
+ else self
diff --git a/Projectile/BulletSI.hs b/Projectile/BulletSI.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/BulletSI.hs
@@ -0,0 +1,111 @@
+module Projectile.BulletSI ( BulletSI(..)
+ , new
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+
+velocityC = 400.0
+rangeC = 500.0
+
+data BulletSI =
+ BulletSI { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , rangeLeft :: Double
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , impacted :: Bool
+ , clock :: Double
+ }
+
+-- angle is radians
+new :: WrapMap -> Double -> WrapPoint -> (Double, Double) -> BulletSI
+new wmap angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ BulletSI { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , rangeLeft = rangeC
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , impacted = False
+ , clock = 0.0
+ }
+
+instance Animation BulletSI where
+
+ image self t = let r = fromInteger (ceiling (clock self)) - clock self in
+ Color (c r)
+ (Rotate 45.0
+ (Circle 2.0))
+ where c x | x < 0.10 = red
+ | x < 0.20 = yellow
+ | x < 0.30 = red
+ | x < 0.40 = yellow
+ | x < 0.50 = red
+ | x < 0.60 = yellow
+ | x < 0.70 = red
+ | x < 0.80 = yellow
+ | x < 0.90 = red
+ | otherwise = yellow
+
+instance M.Colliding BulletSI where
+
+ collisionRadius b = 1.0
+
+instance M.Moving BulletSI where
+
+ velocity b = Projectile.BulletSI.velocity b
+
+instance M.Locatable BulletSI where
+
+ center b = Projectile.BulletSI.center b
+
+instance SimpleTransient BulletSI where
+
+ expired b = rangeLeft b <= 0.0
+
+instance InternallyUpdating BulletSI where
+
+ preUpdate self t = let s' = updateIdealTargetCenter t self in
+ s' { clock = clock self + t }
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ }
+
+updateIdealTargetCenter :: Double -> BulletSI -> BulletSI
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ , rangeLeft = max 0.0 $ rangeLeft self - distance (wrapMap self)
+ (center self)
+ (newLoc)
+ }
+
+instance Damaging BulletSI where
+
+ damageEnergy b = 1.0
+
+instance Transient BulletSI where
+
+ expired' self = if impacted self || rangeLeft self <= 0.0
+ then Just []
+ else Nothing
+
+instance Damageable BulletSI where
+
+ inflictDamage self d = if d > 0 then self { impacted = True }
+ else self
diff --git a/Projectile/BulletSII.hs b/Projectile/BulletSII.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/BulletSII.hs
@@ -0,0 +1,114 @@
+module Projectile.BulletSII ( BulletSII(..)
+ , new
+ , speed
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+
+velocityC = 600.0
+rangeC = 1000.0
+
+speed = velocityC
+
+data BulletSII =
+ BulletSII { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , rangeLeft :: Double
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , impacted :: Bool
+ , clock :: Double
+ }
+
+-- angle is radians
+new :: WrapMap -> Double -> WrapPoint -> (Double, Double) -> BulletSII
+new wmap angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ BulletSII { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , rangeLeft = rangeC
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , impacted = False
+ , clock = 0.0
+ }
+
+instance Animation BulletSII where
+
+ image self t = let r = fromInteger (ceiling (clock self)) - clock self in
+ Color (c r)
+ (Rotate 45.0
+ (Circle 2.0))
+ where c x | x < 0.10 = green
+ | x < 0.20 = yellow
+ | x < 0.30 = green
+ | x < 0.40 = yellow
+ | x < 0.50 = green
+ | x < 0.60 = yellow
+ | x < 0.70 = green
+ | x < 0.80 = yellow
+ | x < 0.90 = green
+ | otherwise = yellow
+
+instance M.Colliding BulletSII where
+
+ collisionRadius b = 1.0
+
+instance M.Moving BulletSII where
+
+ velocity b = Projectile.BulletSII.velocity b
+
+instance M.Locatable BulletSII where
+
+ center b = Projectile.BulletSII.center b
+
+instance SimpleTransient BulletSII where
+
+ expired b = rangeLeft b <= 0.0
+
+instance InternallyUpdating BulletSII where
+
+ preUpdate self t = let s' = updateIdealTargetCenter t self in
+ s' { clock = clock self + t }
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ }
+
+updateIdealTargetCenter :: Double -> BulletSII -> BulletSII
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ , rangeLeft = max 0.0 $ rangeLeft self - distance (wrapMap self)
+ (center self)
+ (newLoc)
+ }
+
+instance Damaging BulletSII where
+
+ damageEnergy b = 1.0
+
+instance Transient BulletSII where
+
+ expired' self = if impacted self || rangeLeft self <= 0.0
+ then Just []
+ else Nothing
+
+instance Damageable BulletSII where
+
+ inflictDamage self d = if d > 0 then self { impacted = True }
+ else self
diff --git a/Projectile/Cannon.hs b/Projectile/Cannon.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/Cannon.hs
@@ -0,0 +1,117 @@
+module Projectile.Cannon ( Cannon(..)
+ , new
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+import GHC.Float
+
+velocityC = 500.0
+rangeC = 800.0
+
+integrityMax = 60.0
+
+punch = 4.0
+
+radiusC = 12.0
+
+data Cannon =
+ Cannon { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , rangeLeft :: Double
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , integrity :: Double
+ , clock :: Double
+ }
+
+-- angle is radians
+new :: WrapMap -> Double -> WrapPoint -> (Double, Double) -> Cannon
+new wmap angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ Cannon { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , rangeLeft = rangeC
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , clock = 0.0
+ , integrity = integrityMax
+ }
+
+instance Animation Cannon where
+
+ image self t = let r = fromInteger (ceiling (clock self)) - clock self in
+ Color (c r)
+ (Rotate 45.0
+ (Circle (double2Float radiusC)))
+ where c x | x < 0.10 = blue
+ | x < 0.20 = cyan
+ | x < 0.30 = blue
+ | x < 0.40 = cyan
+ | x < 0.50 = blue
+ | x < 0.60 = cyan
+ | x < 0.70 = blue
+ | x < 0.80 = cyan
+ | x < 0.90 = blue
+ | otherwise = cyan
+
+instance M.Colliding Cannon where
+
+ collisionRadius self = radiusC
+
+instance M.Moving Cannon where
+
+ velocity self = Projectile.Cannon.velocity self
+
+instance M.Locatable Cannon where
+
+ center self = Projectile.Cannon.center self
+
+instance SimpleTransient Cannon where
+
+ expired self = rangeLeft self <= 0.0 || integrity self <= 0.0
+
+instance InternallyUpdating Cannon where
+
+ preUpdate self t = let s' = updateIdealTargetCenter t self in
+ s' { clock = clock self + t }
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ }
+
+updateIdealTargetCenter :: Double -> Cannon -> Cannon
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ , rangeLeft = max 0.0 $ rangeLeft self - distance (wrapMap self)
+ (center self)
+ (newLoc)
+ }
+
+instance Damaging Cannon where
+
+ damageEnergy self = punch
+
+instance Transient Cannon where
+
+ expired' self = if rangeLeft self <= 0.0 || integrity self <= 0.0
+ then Just []
+ else Nothing
+
+instance Damageable Cannon where
+
+ inflictDamage self d = self { integrity = integrity self - d }
diff --git a/Projectile/Mine.hs b/Projectile/Mine.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/Mine.hs
@@ -0,0 +1,116 @@
+module Projectile.Mine ( Mine(..)
+ , new
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+import ResourceTracker
+import Data.Maybe
+import qualified AfterEffect.MineExplosion as MineExplosion
+import AfterEffect
+
+detRadius = 100.0
+punch = 1.0
+
+data Mine =
+ Mine { center :: WrapPoint
+ , impacted :: Bool
+ , clock :: Double
+ , resourceTracker :: ResourceTracker
+ , wrapMap :: WrapMap
+ }
+
+-- angle is radians
+new :: ResourceTracker -> WrapMap -> WrapPoint -> Mine
+new rt wmap center' =
+ Mine { center = center'
+ , impacted = False
+ , clock = 0.0
+ , resourceTracker = rt
+ , wrapMap = wmap
+ }
+
+instance Animation Mine where
+
+ image self _ =
+ -- assumes t >= 0
+ let t = clock self in
+ let adjt = let a = t * 0.1 in
+ let b = fromIntegral (truncate a) in
+ let c = a - b in
+ c * 10.0 in
+ c adjt
+ where c x | x <= 0.1 = plit
+ | x > 5 && x <= 5.1 = plit
+ | otherwise = p
+ p = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "mine.bmp")
+ plit = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "mine-lit.bmp")
+ rt = resourceTracker self
+
+ -- image self t = let r = fromInteger (ceiling (clock self)) - clock self in
+ -- Color (c r)
+ -- (Rotate 45.0
+ -- (Circle 2.0))
+ -- where c x | x < 0.10 = red
+ -- | x < 0.20 = yellow
+ -- | x < 0.30 = red
+ -- | x < 0.40 = yellow
+ -- | x < 0.50 = red
+ -- | x < 0.60 = yellow
+ -- | x < 0.70 = red
+ -- | x < 0.80 = yellow
+ -- | x < 0.90 = red
+ -- | otherwise = yellow
+
+instance M.Colliding Mine where
+
+ collisionRadius _ = detRadius
+
+instance M.Moving Mine where
+
+ velocity _ = (0.0, 0.0)
+
+instance M.Locatable Mine where
+
+ center self = Projectile.Mine.center self
+
+instance SimpleTransient Mine where
+
+ expired self = impacted self
+
+instance InternallyUpdating Mine where
+
+ preUpdate self t = self { clock = clock self + t }
+
+ postUpdate self _ = self
+
+instance Damaging Mine where
+
+ damageEnergy _ = punch
+
+instance Transient Mine where
+
+ expired' self = if impacted self
+ then Just [mE]
+ else Nothing
+ where mE = AfterEffect $ MineExplosion.new rt wmap center'
+ rt = resourceTracker self
+ wmap = wrapMap self
+ center' = center self
+
+instance Damageable Mine where
+
+ inflictDamage self d = self { impacted = d > 0 }
diff --git a/Projectile/Nuke.hs b/Projectile/Nuke.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/Nuke.hs
@@ -0,0 +1,132 @@
+module Projectile.Nuke ( Nuke(..)
+ , new
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+import ResourceTracker
+import Data.Maybe
+
+velocityC = 200.0
+
+punch = 8.0
+residualPunch = 0.1
+
+detTime = 1.5
+
+data Nuke =
+ Nuke { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , clock :: Double
+ , initialBlastCompleted :: Bool
+ , resourceTracker :: ResourceTracker
+ }
+
+-- angle is radians
+new :: WrapMap -> ResourceTracker -> Double -> WrapPoint -> (Double, Double) -> Nuke
+new wmap rt angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ Nuke { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , clock = 0.0
+ , initialBlastCompleted = False
+ , resourceTracker = rt
+ }
+
+instance Animation Nuke where
+ image self t =
+ let c = clock self in
+ if c < detTime
+ then Color green (Circle 2.0)
+ else if c < detTime + 0.05
+ then p0
+ else if c < detTime + 0.1
+ then p1
+ else if c < detTime + 0.15
+ then p2
+ else if c < detTime + 0.2
+ then p3
+ else Blank
+ where p0 = failImg (getImage rt "nuke-0.bmp")
+ p1 = failImg (getImage rt "nuke-1.bmp")
+ p2 = failImg (getImage rt "nuke-2.bmp")
+ p3 = failImg (getImage rt "nuke-3.bmp")
+ rt = resourceTracker self
+ failImg = \x -> Scale 2.0 2.0 (fromMaybe (Color white (Circle 125.0)) x)
+
+
+instance M.Colliding Nuke where
+
+ collisionRadius self =
+ if clock self < detTime
+ then 2.0
+ else 200
+
+instance M.Moving Nuke where
+
+ velocity b = Projectile.Nuke.velocity b
+
+instance M.Locatable Nuke where
+
+ center b = Projectile.Nuke.center b
+
+instance SimpleTransient Nuke where
+
+ expired self = clock self >= detTime + 0.5
+
+instance InternallyUpdating Nuke where
+
+ preUpdate self t = let s' = updateIdealTargetCenter t self in
+ s' { clock = clock self + t
+ , velocity = if clock self >= detTime
+ then (0.0, 0.0)
+ else velocity self
+ }
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ , initialBlastCompleted = clock self >= detTime
+ }
+
+updateIdealTargetCenter :: Double -> Nuke -> Nuke
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ }
+
+instance Damaging Nuke where
+
+ damageEnergy self =
+ let c = clock self in
+ if c < detTime
+ then 0.0
+ else if initialBlastCompleted self
+ then residualPunch
+ else punch
+
+instance Transient Nuke where
+
+ expired' self = if clock self >= detTime + 0.5
+ then Just []
+ else Nothing
+
+instance Damageable Nuke where
+
+ inflictDamage self _ = self
diff --git a/Projectile/Pellet.hs b/Projectile/Pellet.hs
new file mode 100644
--- /dev/null
+++ b/Projectile/Pellet.hs
@@ -0,0 +1,99 @@
+module Projectile.Pellet ( Pellet(..)
+ , new
+ , range
+ ) where
+
+import Combat
+import Animation
+import Updating
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import Data.WrapAround
+import qualified Moving as M
+
+velocityC = 600.0
+rangeC = 300.0
+punch = 0.3
+
+range = rangeC
+
+data Pellet =
+ Pellet { velocity :: (Double, Double)
+ , center :: WrapPoint
+ , rangeLeft :: Double
+ , wrapMap :: WrapMap
+ , idealNewCenter :: Maybe WrapPoint
+ , impacted :: Bool
+ }
+
+-- angle is radians
+new :: WrapMap -> Double -> WrapPoint -> (Double, Double) -> Pellet
+new wmap angle center' (vpx, vpy) =
+ let x = cos angle * velocityC in
+ let y = sin angle * velocityC in
+ Pellet { velocity = (x + vpx, y + vpy)
+ , center = center'
+ , rangeLeft = rangeC
+ , wrapMap = wmap
+ , idealNewCenter = Nothing
+ , impacted = False
+ }
+
+instance Animation Pellet where
+
+ image self t = Color (makeColor8 172 172 172 255) (Circle 1.0)
+
+instance M.Colliding Pellet where
+
+ collisionRadius b = 1.0
+
+instance M.Moving Pellet where
+
+ velocity b = Projectile.Pellet.velocity b
+
+instance M.Locatable Pellet where
+
+ center b = Projectile.Pellet.center b
+
+instance SimpleTransient Pellet where
+
+ expired b = rangeLeft b <= 0.0
+
+instance InternallyUpdating Pellet where
+
+ preUpdate self t = updateIdealTargetCenter t self
+
+ postUpdate self t =
+ let center' = case idealNewCenter self of
+ Nothing -> center self
+ Just x -> x in
+ self { center = center'
+ , idealNewCenter = Nothing
+ }
+
+updateIdealTargetCenter :: Double -> Pellet -> Pellet
+updateIdealTargetCenter t self =
+ let newLoc = M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t in
+ self { idealNewCenter = Just (newLoc)
+ , rangeLeft = max 0.0 $ rangeLeft self - distance (wrapMap self)
+ (center self)
+ (newLoc)
+ }
+
+instance Damaging Pellet where
+
+ damageEnergy b = punch
+
+instance Transient Pellet where
+
+ expired' self = if impacted self || rangeLeft self <= 0.0
+ then Just []
+ else Nothing
+
+instance Damageable Pellet where
+
+ inflictDamage self d = if d > 0 then self { impacted = True }
+ else self
diff --git a/ResourceTracker.hs b/ResourceTracker.hs
new file mode 100644
--- /dev/null
+++ b/ResourceTracker.hs
@@ -0,0 +1,39 @@
+module ResourceTracker ( ResourceTracker()
+ , emptyResourceTracker
+ , getImage
+ , storeImage
+ , getSound
+ , storeSound
+ ) where
+
+import Graphics.Gloss.Data.Picture (Picture)
+import qualified Graphics.Gloss.Data.Picture as GP
+import Data.Map (Map)
+import qualified Data.Map as M
+-- import Control.Monad.State
+import Sound.ALUT
+
+data ResourceTracker = ResourceTracker { images :: Map String Picture
+ , sounds :: Map String Buffer
+-- , defaultSound :: Buffer
+ }
+ deriving (Show)
+
+emptyResourceTracker = ResourceTracker { images = M.empty
+ , sounds = M.empty
+ }
+
+getImage :: ResourceTracker -> String -> Maybe Picture
+getImage rt filename = M.lookup filename (images rt)
+
+storeImage :: ResourceTracker -> String -> Picture -> ResourceTracker
+storeImage rt filename pic = let nimages = M.insert filename pic (images rt) in
+ rt { images = nimages }
+
+getSound :: ResourceTracker -> String -> Maybe Buffer
+getSound rt filename = M.lookup filename (sounds rt)
+
+storeSound :: ResourceTracker -> String -> Buffer -> ResourceTracker
+storeSound rt filename buffer = let buffers' = M.insert filename buffer (sounds rt) in
+ rt { sounds = buffers' }
+
diff --git a/Resources.hs b/Resources.hs
new file mode 100644
--- /dev/null
+++ b/Resources.hs
@@ -0,0 +1,469 @@
+module Resources where
+
+import Paths_edge
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import ResourceTracker
+import SpaceJunk
+import qualified Asteroid as Asteroid
+import qualified BigAsteroid as BigAsteroid
+import Data.WrapAround
+import Star
+import Sound.ALUT
+import Universe
+import Unit
+import qualified Unit.Simple.Turret as Turret
+import qualified Unit.Smart.Tank as Tank
+import qualified Unit.Smart.ATank as ATank
+import qualified Unit.Smart.Death as Death
+import qualified Unit.Smart.Ninja as Ninja
+import qualified Unit.Smart.Saucer as Saucer
+import qualified Unit.Smart.Sniper as Sniper
+import Combat
+import qualified Projectile.Mine as Mine
+import Item
+import System.Random
+
+initResources = let imageFiles = [ "asteroid.bmp"
+ , "asteroidbig.bmp"
+ , "atank.bmp"
+ , "blade.bmp"
+ , "death.bmp"
+ , "item-default.bmp"
+ , "item-health.bmp"
+ , "item-fourway.bmp"
+ , "item-cannon.bmp"
+ , "item-spread.bmp"
+ , "item-rapidfire.bmp"
+ , "item-nuke.bmp"
+ , "lance.bmp"
+ , "lance-thrusting.bmp"
+ , "mine.bmp"
+ , "mine-explosion.bmp"
+ , "mine-lit.bmp"
+ , "ninja.bmp"
+ , "nuke-0.bmp"
+ , "nuke-1.bmp"
+ , "nuke-2.bmp"
+ , "nuke-3.bmp"
+ , "turret.bmp"
+ , "tank.bmp"
+ , "explosion-00.bmp"
+ , "explosion-01.bmp"
+ , "explosion-02.bmp"
+ , "explosion-03.bmp"
+ , "explosion-04.bmp"
+ , "explosion-05.bmp"
+ , "explosion-06.bmp"
+ , "saucer.bmp"
+ , "sniper.bmp"
+ ] in
+ let imageFiles' = map ("image/" ++) imageFiles in
+ let soundFiles = [ "test.wav"
+ , "energy-shot-02.wav"
+ , "explosion.wav"
+ , "simple-energy-shot.wav"
+ ] in
+ let soundFiles' = map ("sound/" ++) soundFiles in
+ do imagePaths <- mapM getDataFileName imageFiles'
+ pics <- mapM loadBMP imagePaths
+ soundPaths <- mapM getDataFileName soundFiles'
+ sounds <- mapM (createBuffer . File) soundPaths
+ let rt = foldr go emptyResourceTracker
+ (zip imageFiles pics)
+ return $ foldr go' rt (zip soundFiles sounds)
+ where go (file, pic) rt = storeImage rt file pic
+ go' (file, sound) rt = storeSound rt file sound
+
+-- loadBuffer path = do buf <- createBuffer (File path)
+-- [source] <- genObjectNames 1
+-- buffer source $= Just buf
+-- return source
+
+startingAsteroids rt wmap =
+ let positionsVelocities = [ ((1900, 500), (200, -120))
+ , (( 100, 2900), ( 90, 10))
+ , ((2500, 1100), (-100, 100))
+ , (( 700, 300), (80, 60))
+ , ((1300, 1400), (-30, 240))
+ , ((1000, 2400), (110, 100))
+ ] in
+ map (\(p, v) -> Asteroid.new rt wmap (wrappoint wmap p) v) positionsVelocities
+
+defaultStars =
+ [ Star { Star.location = wrappoint wmap (40.0, 93.0), Star.color = rose }
+ , Star { Star.location = wrappoint wmap (54.0, 74.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (86.0, 38.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (30.0, 52.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap ( 2.0, 24.0), Star.color = orange }
+ , Star { Star.location = wrappoint wmap (85.0, 76.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (27.0, 32.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (53.0, 94.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (66.0, 37.0), Star.color = green }
+ , Star { Star.location = wrappoint wmap (39.0, 73.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (88.0, 67.0), Star.color = chartreuse }
+ , Star { Star.location = wrappoint wmap (50.0, 50.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (93.0, 33.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (25.0, 57.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (36.0, 6.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (65.0, 61.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (43.0, 24.0), Star.color = blue }
+ , Star { Star.location = wrappoint wmap (54.0, 52.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (66.0, 45.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (41.0, 67.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (37.0, 25.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (62.0, 48.0), Star.color = green }
+ , Star { Star.location = wrappoint wmap (88.0, 73.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap ( 4.0, 54.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (59.0, 77.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (73.0, 83.0), Star.color = yellow }
+ , Star { Star.location = wrappoint wmap (34.0, 24.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (58.0, 48.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (03.0, 99.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (57.0, 46.0), Star.color = aquamarine }
+ , Star { Star.location = wrappoint wmap (66.0, 67.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (31.0, 2.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (85.0, 53.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (23.0, 77.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (97.0, 16.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (16.0, 83.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (42.0, 45.0), Star.color = magenta }
+ , Star { Star.location = wrappoint wmap ( 9.0, 67.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (33.0, 33.0), Star.color = azure }
+ , Star { Star.location = wrappoint wmap (27.0, 75.0), Star.color = violet }
+ , Star { Star.location = wrappoint wmap (36.0, 64.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (74.0, 2.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (48.0, 46.0), Star.color = cyan }
+ , Star { Star.location = wrappoint wmap (20.0, 98.0), Star.color = rose }
+ , Star { Star.location = wrappoint wmap (52.0, 44.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (16.0, 38.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (32.0, 72.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (21.0, 23.0), Star.color = orange }
+ , Star { Star.location = wrappoint wmap (75.0, 86.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (67.0, 34.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (55.0, 64.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (46.0, 38.0), Star.color = green }
+ , Star { Star.location = wrappoint wmap (37.0, 73.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (38.0, 69.0), Star.color = chartreuse }
+ , Star { Star.location = wrappoint wmap (52.0, 90.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (43.0, 31.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (26.0, 27.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (86.0, 8.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (69.0, 91.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (13.0, 22.0), Star.color = blue }
+ , Star { Star.location = wrappoint wmap (58.0, 72.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (96.0, 48.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (42.0, 97.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (77.0, 28.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (63.0, 78.0), Star.color = green }
+ , Star { Star.location = wrappoint wmap (68.0, 71.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap ( 2.0, 84.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (49.0, 73.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (72.0, 83.0), Star.color = yellow }
+ , Star { Star.location = wrappoint wmap (94.0, 29.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (52.0, 98.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (73.0, 92.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (52.0, 36.0), Star.color = aquamarine }
+ , Star { Star.location = wrappoint wmap (46.0, 64.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (32.0, 82.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (35.0, 53.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (24.0, 87.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (87.0, 17.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (16.0, 93.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (72.0, 42.0), Star.color = magenta }
+ , Star { Star.location = wrappoint wmap ( 4.0, 97.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (93.0, 33.0), Star.color = azure }
+ , Star { Star.location = wrappoint wmap (22.0, 5.0), Star.color = violet }
+ , Star { Star.location = wrappoint wmap (46.0, 68.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (76.0, 92.0), Star.color = white }
+ , Star { Star.location = wrappoint wmap (78.0, 41.0), Star.color = cyan }
+ ]
+ where wmap = wrapmap 100.0 100.0
+
+initLevels rt =
+ do let b = blankArena 3000.0 3000.0
+ let a = b { stars = defaultStars
+ }
+ let wmap = Universe.wrapMap a
+ let pL = [
+ -- 0
+ a { asteroids = asteroidGen rt wmap
+ [ ((1900, 500), (200, -120))
+ , (( 100, 2900), ( 90, 10))
+ -- , ((2500, 1100), ((-100), 100))
+ -- , (( 700, 300), (80, 60))
+ -- , ((1300, 1400), ((-30), 240))
+ -- , ((1000, 2400), (110, 100))
+ ]
+ , simpleUnits = turretGen rt wmap
+ [ ((-700.0, 300.0), 0.0, 7 * pi / 4)
+ , ((500.0, 800.0), pi / 3, 7 * pi / 4)
+ ]
+ }
+ ,
+ -- 1
+ a { asteroids = asteroidGen rt wmap
+ [ ((1900, 500), (200, -120))
+ , (( 100, 2900), ( 90, 10))
+ , ((2500, 1100), (-100, 100))
+ ]
+ , simpleUnits = turretGen rt wmap
+ [ ((1000.0, 200.0), 0.0, pi / 3)
+ ]
+
+ , smartUnits = tankGen rt wmap
+ [ ((-1000.0, 800.0), 0.0)
+ , ((-1200.0, 500.0), pi)
+ ]
+ }
+ ,
+ -- 2
+ a { asteroids = asteroidGen rt wmap
+ [ ((900, 340), (230, -120))
+ , ((1200, 1400), (110, 30))
+ , ((200, 500), (-180, 110))
+ ]
+ , simpleUnits = turretGen rt wmap
+ [ ((-500.0, 200.0), 0.0, 3 * pi / 2 )
+ ]
+
+ , smartUnits = tankGen rt wmap
+ [ ((-1000.0, 800.0), 0.0)
+ , ((900.0, 600.0), pi)
+ , ((700.0, -500.0), pi / 2)
+ ] ++
+ aTankGen rt wmap
+ [ ((-1100.0, -900.0), pi + pi / 3)
+ ]
+ }
+ ,
+ -- 3
+ a { asteroids = asteroidGen rt wmap
+ [ ((800, -340), (130, 120))
+ , ((700, 200), (10, -130))
+ , ((-300, 900), (70, 110))
+ ]
+ , smartUnits = tankGen rt wmap
+ [ ((-700.0, 600.0), 0.0)
+ , ((500.0, -1100.0), pi / 2)
+ ] ++
+ aTankGen rt wmap
+ [ ((-1000.0, 900.0), pi + pi / 3)
+ ] ++
+ saucerGen rt wmap
+ [ ((400.0, 1400.0), 0.0) ]
+
+ }
+ ,
+ -- 4
+ a { asteroids = asteroidGen rt wmap
+ [ ((800, -340), (130, 120))
+ , ((700, 200), (10, -130))
+ , ((-300, 900), (70, 110))
+ ]
+ , smartUnits = tankGen rt wmap
+ [ ((-400.0, 900.0), 0.0)
+ ] ++
+ aTankGen rt wmap
+ [ ((1400.0, -800.0), pi)
+ ] ++
+ saucerGen rt wmap
+ [ ((400.0, 1400.0), 0.0)
+ , ((-1200.0, -1000.0), pi)
+ , ((100.0, -500.0), pi)
+ , ((-600.0, 800.0), 0.0)
+ ]
+
+ }
+ ,
+ -- 5
+ a { asteroids = asteroidGen rt wmap
+ [ ((800, -340), (-130, 120))
+ , ((700, 200), (-130, 120))
+ , ((-300, 900), (-130, 120))
+ , ((1340, -1230), (-130, 120))
+ , ((-420, 990), (-130, 120))
+ , ((370, -130), (-130, 120))
+ , ((-1220, 1090), (-130, 120))
+ , ((400, 1300), (-130, 120))
+ , ((-700, -500), (-130, 120))
+ , ((-1320, 1290), (-130, 120))
+ , ((100, 400), (-130, 120))
+ , ((-800, -400), (-130, 120))
+ , ((1440, -1330), (-130, 120))
+ , ((-520, 120), (-130, 120))
+ , ((1100, 40), (-130, 120))
+ , ((500, 100), (-130, 120))
+ , ((-1100, -20), (-130, 120))
+ , ((-520, -70), (-130, 120))
+ , ((40, 1100), (-130, 120))
+ , ((100, 500), (-130, 120))
+ , ((-20,-1100), (-130, 120))
+ , ((-70, -520), (-130, 120))
+ , ((-600, 1500), (-130, 120))
+ , ((-1000, 500), (-130, 120))
+ , ((-400, -600), (-130, 120))
+ , ((1200, -600), (-130, 120))
+ , ((500, -1400), (-130, 120))
+ ] ++
+ bigAsteroidGen rt wmap
+ [ ((500, -840), (-130, 120))
+ , ((900, 300), (-130, 120))
+ , ((-200, 1100), (-130, 120))
+ , ((600, -200), (-130, 120))
+ , ((-600, 700), (-130, 120))
+ , ((-900, -1100), (-130, 120))
+ , ((-100, -900), (-130, 120))
+ , ((-200, -200), (-130, 120))
+ , ((600, 600), (-130, 120))
+ , ((900, -900), (-130, 120))
+ , ((-1400, -1400), (-130, 120))
+ , ((1100, 1300), (-130, 120))
+ , ((-1000, -800), (-130, 120))
+ , ((400, -600), (-130, 120))
+ , ((-500, -1300), (-130, 120))
+ ]
+ , simpleUnits = turretGen rt wmap
+ [ ((700.0, 650.0), 0.0, pi )
+ , ((-550.0, -300.0), 0.0, 0.0 )
+ ]
+ , smartUnits = tankGen rt wmap
+ [ ((-450.0, 821.0), 0.0)
+ ] ++
+ aTankGen rt wmap
+ [ ((40.0, -1400.0), pi)
+ ] ++
+ saucerGen rt wmap
+ [ ((540.0, 1320.0), 0.0)
+ , ((-1000.0, -1200.0), pi)
+ , ((40.0, 1200.0), pi)
+ , ((-200.0, -1000.0), 0)
+ ]
+ }
+ ,
+ -- 6
+ a { asteroids = asteroidGen rt wmap
+ [ ((800, -340), (-30, 20))
+ , ((-1320, 1290), (200, 100))
+ , ((-400, -600), (-80, -40))
+ , ((500, -1400), (30, 80))
+ ] ++
+ bigAsteroidGen rt wmap
+ [ ((-100, -900), (40, 120))
+ , ((-1000, -800), (50, -60))
+ ]
+ , simpleUnits = turretGen rt wmap
+ [ ((900.0, -650.0), 0.0, pi )
+ ]
+ , smartUnits = tankGen rt wmap
+ [ ((-450.0, 821.0), 0.0)
+ , ((40.0, -1400.0), pi)
+ ] ++
+ sniperGen rt wmap
+ [ ((-1200.0, 0.0), 0.0)
+ , ((1200.0, 0.0), 0.0)
+ ]
+ , unitProjectiles = mineGen rt wmap
+ [ (300.0, 400.0)
+ , (-700.0, 200.0)
+ , (1300.0, -500.0)
+ ]
+ }
+ ,
+ -- 7
+ a { asteroids = asteroidGen rt wmap
+ [ ((840, -440), (-30, 20))
+ , ((-1320, 1290), (120, -100))
+ , ((600, 1400), (30, 80))
+ ] ++
+ bigAsteroidGen rt wmap
+ [ ((-100, -900), (40, 30))
+ , ((-900, 800), (80, -60))
+ , ((-1000, 400), (-50, -80))
+ ]
+ , smartUnits = ninjaGen rt wmap
+ [ ((100.0, 600.0), 0.0)
+ , ((-200.0, -700.0), pi)
+ , ((700.0, 800.0), 0.0)
+ , ((600.0, -900.0), pi)
+ , ((-800.0, 1300.0), 0.0)
+ , ((-1400.0, -1400.0), pi)
+ ]
+
+ , unitProjectiles = mineGen rt wmap
+ [ (200.0, 800.0)
+ , (-500.0, -200.0)
+ , (-1300.0, 1000.0)
+ ]
+ }
+ ,
+ -- 8
+ a { asteroids = asteroidGen rt wmap
+ [ ((640, -440), (-20, 30))
+ , ((-1320, 1190), (110, -90))
+ , ((700, 1200), (40, 70))
+ ] ++
+ bigAsteroidGen rt wmap
+ [ ((-100, -900), (30, 40))
+ , ((-500, 1000), (70, -70))
+ ]
+ , smartUnits = deathGen rt wmap
+ [ ((0.0, -1000.0), 0.0)
+ ]
+ }
+ ]
+ let addItems a = do it1 <- randomItemType
+ it2 <- randomItemType
+ x1 <- randomRIO (0, 2999)
+ x2 <- randomRIO (0, 2999)
+ y1 <- randomRIO (0, 2999)
+ y2 <- randomRIO (0, 2999)
+ let wp1 = wrappoint wmap (x1, y1)
+ let wp2 = wrappoint wmap (x2, y2)
+ let i1 = Item it1 rt wp1
+ let i2 = Item it2 rt wp2
+ return a { items = [i1, i2] }
+ mapM addItems pL
+
+asteroidGen rt wmap p =
+ let positionsVelocities = p in
+ map (\(p, v) -> (SpaceJunk (Asteroid.new
+ rt
+ wmap
+ (wrappoint wmap p)
+ v)))
+ positionsVelocities
+
+bigAsteroidGen rt wmap p =
+ let positionsVelocities = p in
+ map (\(p, v) -> (SpaceJunk (BigAsteroid.new
+ rt
+ wmap
+ (wrappoint wmap p)
+ v)))
+ positionsVelocities
+
+turretGen rt wmap =
+ map (\(x, y, z) -> SimpleUnit (Turret.new rt wmap (wrappoint wmap x) y z))
+
+tankGen rt wmap =
+ map (\(x, y) -> SmartUnit (Tank.new rt wmap (wrappoint wmap x) y))
+
+aTankGen rt wmap =
+ map (\(x, y) -> SmartUnit (ATank.new rt wmap (wrappoint wmap x) y))
+
+mineGen rt wmap =
+ map (\x -> Projectile (Mine.new rt wmap (wrappoint wmap x)))
+
+sniperGen rt wmap =
+ map (\(x, y) -> SmartUnit (Sniper.new rt wmap (wrappoint wmap x) y))
+
+deathGen rt wmap =
+ map (\(x, y) -> SmartUnit (Death.new rt wmap (wrappoint wmap x) y))
+
+saucerGen rt wmap =
+ map (\(x, y) -> SmartUnit (Saucer.new rt wmap (wrappoint wmap x) y))
+
+ninjaGen rt wmap =
+ map (\(x, y) -> SmartUnit (Ninja.new rt wmap (wrappoint wmap x) y))
+
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/SpaceJunk.hs b/SpaceJunk.hs
new file mode 100644
--- /dev/null
+++ b/SpaceJunk.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module SpaceJunk where
+
+import Animation
+import Updating
+import qualified Moving as M
+import Combat
+
+data SpaceJunk = forall a. ( InternallyUpdating a
+ , M.Colliding a
+ , Damaging a
+ , Damageable a
+ , Animation a
+ ) => SpaceJunk a
+
+instance Damaging SpaceJunk where
+ damageEnergy (SpaceJunk a) = damageEnergy a
+
+instance Damageable SpaceJunk where
+ inflictDamage (SpaceJunk a) et = SpaceJunk (inflictDamage a et)
+
+instance InternallyUpdating SpaceJunk where
+ preUpdate (SpaceJunk a) et = SpaceJunk (preUpdate a et)
+ postUpdate (SpaceJunk a) et = SpaceJunk (postUpdate a et)
+
+instance M.Colliding SpaceJunk where
+
+ collisionRadius (SpaceJunk a) = M.collisionRadius a
+
+instance M.Moving SpaceJunk where
+
+ velocity (SpaceJunk a) = M.velocity a
+
+instance M.Locatable SpaceJunk where
+ center (SpaceJunk a) = M.center a
+
+instance Animation SpaceJunk where
+ image (SpaceJunk a) = image a
+
diff --git a/Star.hs b/Star.hs
new file mode 100644
--- /dev/null
+++ b/Star.hs
@@ -0,0 +1,19 @@
+module Star where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Moving
+
+data Star = Star { location :: WrapPoint
+ , color :: Color
+ }
+
+instance Animation Star where
+ image star _ = Color (Star.color star) (rectangleSolid 1.0 1.0)
+
+instance Locatable Star where
+ center = location
+
diff --git a/Step.hs b/Step.hs
new file mode 100644
--- /dev/null
+++ b/Step.hs
@@ -0,0 +1,456 @@
+{-# LANGUAGE ExistentialQuantification, Rank2Types #-}
+
+module Step (stepUniverse) where
+
+import Universe
+import SpaceJunk
+import Moving
+import Data.WrapAround
+import Updating
+import GHC.Float
+import Lance
+import Data.List (find)
+import Combat
+import Data.Maybe ( fromMaybe
+ , isNothing
+ , fromJust
+ , isJust
+ )
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Unit
+import Animation
+import Control.Monad
+import System.IO
+import System.Exit
+import Resources
+import Sound.ALUT
+
+stepUniverse :: Float -> Universe -> IO Universe
+stepUniverse t u =
+ let t' = float2Double t in
+ do (_, u') <- (handleNewLevel
+ >=> handleLives
+ >=> handlePureUpdates
+ >=> handleSound) (t', u)
+ return u'
+
+
+handleLives :: (Double, Universe) -> IO (Double, Universe)
+handleLives (t, u) =
+ do let a = arena u
+ let wmap = Universe.wrapMap a
+ let rt = resourceTracker u
+ if isJust (lance (arena u))
+ then return (t, u)
+ else if delayRemaining u > 0
+ then return ( t
+ , u { delayRemaining = delayRemaining u - t }
+ )
+ else if lives u > 0
+ then return
+ ( t
+ , u { arena =
+ a { lance = Just (Lance.new rt wmap
+ (wrappoint wmap (0, 0)))
+ }
+ , delayRemaining = 2.0
+ }
+ )
+ else return
+ ( t
+ , u { arena =
+ (head (levels u))
+ { lance = Just (Lance.new rt wmap
+ (wrappoint wmap (0, 0)))
+ }
+ , level = 0
+ , lives = 3
+ , delayRemaining = 2.0
+ }
+ )
+
+handleNewLevel :: (Double, Universe) -> IO (Double, Universe)
+handleNewLevel (t, u)
+ | not (null (simpleUnits (arena u)) && null (smartUnits (arena u)))
+ && not (skipLevel u)
+ = return (t, u)
+ | level u + 1 >= length (Universe.levels u) =
+ do hPutStrLn stderr "Out of levels! Game over."
+ exitSuccess
+ | otherwise =
+ do silenceMost (arena u)
+ let a = Universe.levels u !! (level u + 1)
+ let l = lance (arena u)
+ let wmap = Universe.wrapMap a
+ let u'
+ = u { arena =
+ a { lance =
+ fmap
+ (\ l ->
+ l { Lance.center = wrappoint wmap
+ (0.0, 0.0)
+ , angle = 0.0
+ , Lance.velocity = (0.0, 0.0)})
+ l
+ }
+ , level = level u + 1
+ , skipLevel = False
+ }
+ return (t, u')
+
+{-
+ Here we'll terminateAudio everything in the arena that can receive it, not
+ including the Lance, which is carried across level changes.
+-}
+silenceMost a = return ()
+
+-- newLevel u = -- let mProcessAudio = mapM processAudio in
+-- let a = arena in
+-- if level u >= length (levels u)
+-- then
+
+handlePureUpdates :: (Double, Universe) -> IO (Double, Universe)
+handlePureUpdates (t, u) = return $ ( handleExpiration
+ . handlePostUpdates
+ . handleCollisions
+ . handleUnitLaunches
+ . handleLanceLaunches
+ . handlePreUpdates
+ . handleVisionUpdates
+ . fixFocus
+ ) (t, u)
+
+
+handleSound :: (Double, Universe) -> IO (Double, Universe)
+handleSound (t, u) =
+ let arena' = arena u in
+ do let listenerCoords = case lance arena' of
+ Nothing -> lastFocus arena'
+ Just l -> Moving.center l
+ lance' <- case lance arena' of
+ Nothing -> return Nothing
+ Just l -> do l' <- processAudio l listenerCoords
+ return (Just l')
+ simpleUnits' <- mapM (\x -> processAudio x listenerCoords) (simpleUnits arena')
+ smartUnits' <- mapM (\x -> processAudio x listenerCoords) (smartUnits arena')
+ afterFX' <- mapM (\x -> processAudio x listenerCoords) (afterFX arena')
+ let u' = u { arena = arena' { lance = lance'
+ , simpleUnits = simpleUnits'
+ , smartUnits = smartUnits'
+ , afterFX = afterFX'
+ }
+ }
+ -- case lance' of
+ -- Nothing -> return ()
+ -- Just l -> do let (x, y) = toCoords
+ -- (Universe.wrapMap arena')
+ -- (Moving.center l)
+ -- listenerPosition $= (Vertex3
+ -- (double2Float x)
+ -- (double2Float y)
+ -- 0)
+ return (t, u')
+
+
+handleExpiration :: (Double, Universe) -> (Double, Universe)
+handleExpiration (t, u) =
+ let arena' = arena u in
+
+ let (lance', aFX_lance) = case lance arena' of
+ Nothing -> (Nothing, [])
+ Just l -> case expired' l of
+ Nothing -> (Just l, [])
+ Just a -> (Nothing, a) in
+
+ let lives' = if isJust (lance arena') && isNothing lance'
+ then lives u - 1
+ else lives u in
+
+ let (lanceProjectiles', aFX_lanceProjectiles) =
+ expirationFold (lanceProjectiles arena') in
+
+ let (unitProjectiles', aFX_unitProjectiles) =
+ expirationFold (unitProjectiles arena') in
+
+ let (afterFX', aFX_afterFX) =
+ expirationFold (afterFX arena') in
+
+ let (simpleUnits', aFX_simpleUnits) =
+ expirationFold (simpleUnits arena') in
+
+ let (smartUnits', aFX_smartUnits) =
+ expirationFold (smartUnits arena') in
+
+ let u' = u { arena = arena' { lance = lance'
+ , lanceProjectiles = lanceProjectiles'
+ , unitProjectiles = unitProjectiles'
+ , simpleUnits = simpleUnits'
+ , smartUnits = smartUnits'
+ , afterFX = afterFX'
+ ++ aFX_afterFX
+ ++ aFX_lance
+ ++ aFX_lanceProjectiles
+ ++ aFX_unitProjectiles
+ ++ aFX_simpleUnits
+ ++ aFX_smartUnits
+ }
+ , lives = lives'
+ } in
+ (t, u')
+
+ where expirationFold xs = foldr foldF ([], []) xs
+
+ foldF x (nxs, nAFX) = case expired' x of
+ Nothing -> (nxs ++ [x], nAFX)
+ Just a -> (nxs, nAFX ++ a)
+
+
+handleLanceLaunches :: (Double, Universe) -> (Double, Universe)
+handleLanceLaunches (t, u) =
+ let arena' = arena u in
+ case lance arena' of
+ Nothing -> (t, u)
+ Just llance -> let (nProj, nLance) = deployProjectiles llance in
+ let u' = u { arena = arena' { lanceProjectiles =
+ lanceProjectiles arena'
+ ++ nProj
+ , lance = Just nLance
+ }
+ } in
+ (t, u')
+
+handleUnitLaunches :: (Double, Universe) -> (Double, Universe)
+handleUnitLaunches (t, u) =
+ let arena' = arena u in
+ let (simpleUnits', unitProjectiles') =
+ foldr foldDepl ([], []) (simpleUnits arena') in
+ let (smartUnits', unitProjectiles'') =
+ foldr foldDepl ([], []) (smartUnits arena') in
+ let u' = u { arena = arena' { unitProjectiles = unitProjectiles arena'
+ ++ unitProjectiles'
+ ++ unitProjectiles''
+ , simpleUnits = simpleUnits'
+ , smartUnits = smartUnits'
+ }
+ } in
+ (t, u')
+
+ where foldDepl s (units, projectiles) =
+ let (nProjectiles, updatedUnit) = deployProjectiles s in
+ (units ++ [updatedUnit], projectiles ++ nProjectiles)
+
+fixFocus (t, u) =
+ let arena' = arena u in
+ let oldFocus = lastFocus arena' in
+ let mFocus = do llance <- lance arena'
+ Just (Moving.center llance) in
+ let newFocus = fromMaybe oldFocus mFocus in
+ let u' = u { arena = arena' { lastFocus = newFocus } } in
+ (t, u')
+
+handleUpdatesCore :: (forall a. (InternallyUpdating a
+ => (a -> Double -> a)))
+ -> (Double, Universe)
+ -> (Double, Universe)
+handleUpdatesCore f (t, u) =
+ let arena' = arena u in
+ let lance' = do llance <- lance arena'
+ Just (f llance t) in
+ let asteroids' = [ f a t | a <- asteroids arena' ] in
+ let lanceProjectiles' = [ Projectile (f a t)
+ | Projectile a <- lanceProjectiles arena' ] in
+ let unitProjectiles' = [ Projectile (f a t)
+ | Projectile a <- unitProjectiles arena' ] in
+ let afterFX' = [ case effect of
+ AfterEffect a -> AfterEffect (f a t)
+ | effect <- afterFX arena' ] in
+ let simpleUnits' = [ f s t | s <- simpleUnits arena' ] in
+ let smartUnits' = [ f s t | s <- smartUnits arena' ] in
+ let u' = u { arena = arena' { lance = lance'
+ , asteroids = asteroids'
+ , lanceProjectiles = lanceProjectiles'
+ , afterFX = afterFX'
+ , simpleUnits = simpleUnits'
+ , smartUnits = smartUnits'
+ , unitProjectiles = unitProjectiles'
+ }
+ } in
+ (t, u')
+
+handlePreUpdates :: (Double, Universe) -> (Double, Universe)
+handlePreUpdates (t, u) = handleUpdatesCore Updating.preUpdate (t, u)
+
+handlePostUpdates :: (Double, Universe) -> (Double, Universe)
+handlePostUpdates (t, u) = handleUpdatesCore Updating.postUpdate (t, u)
+
+handleVisionUpdates :: (Double, Universe) -> (Double, Universe)
+handleVisionUpdates (t, u) =
+ let a = arena u in
+ let u' = u { arena =
+ a { smartUnits = [ updateVision s a | s <- smartUnits a ] }
+ } in
+ (t, u')
+
+handleCollisionsLanceAsteroids (t, u) =
+ let lance' = case lance a of
+ Nothing -> Nothing
+ Just l -> let (x, _) = handleCollisionDamage
+ wmap t l (asteroids a) in
+ Just x in
+ let u' = u { arena = a { lance = lance' } } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+
+handleCollisionsLanceUnitProjectiles (t, u) =
+ let (lance', unitProjectiles') =
+ case lance a of
+ Nothing -> (Nothing, unitProjectiles a)
+ Just l -> let (x, ys) = handleCollisionDamage
+ wmap t l (unitProjectiles a) in
+ (Just x, ys) in
+ let u' = u { arena = a { lance = lance'
+ , unitProjectiles = unitProjectiles'
+ }
+ } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+
+handleCollisionsLanceProjectilesAsteroids (t, u) =
+ let (lanceProjectiles', _) = handleCollisionDamage'
+ wmap t
+ (lanceProjectiles a)
+ (asteroids a) in
+ let u' = u { arena = a { lanceProjectiles = lanceProjectiles'
+ }
+ } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+
+handleCollisionsLanceProjectilesSimpleUnits (t, u) =
+ let (lanceProjectiles', simpleUnits') = handleCollisionDamage'
+ wmap t
+ (lanceProjectiles a)
+ (simpleUnits a) in
+
+ let u' = u { arena = a { lanceProjectiles = lanceProjectiles'
+ , simpleUnits = simpleUnits'
+ }
+ } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+
+handleCollisionsUnitProjectilesAsteroids (t, u) =
+ let (unitProjectiles', _) = handleCollisionDamage'
+ wmap t
+ (unitProjectiles a)
+ (asteroids a) in
+
+ let u' = u { arena = a { unitProjectiles = unitProjectiles'
+ }
+ } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+
+handleCollisionsLanceSimpleUnits (t, u) =
+ let (lance', simpleUnits') =
+ case (lance a) of
+ Nothing -> (Nothing, (simpleUnits a))
+ Just l -> let (x, ys) = handleCollisionDamage
+ wmap t l (simpleUnits a) in
+ (Just x, ys) in
+
+ let u' = u { arena = a { lance = lance'
+ , simpleUnits = simpleUnits'
+ }
+ } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+
+handleCollisionsLanceProjectilesSmartUnits (t, u) =
+ let (lanceProjectiles', smartUnits') = handleCollisionDamage'
+ wmap t
+ (lanceProjectiles a)
+ (smartUnits a) in
+
+ let u' = u { arena = a { lanceProjectiles = lanceProjectiles'
+ , smartUnits = smartUnits'
+ }
+ } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+
+handleCollisionsLanceSmartUnits (t, u) =
+ let (lance', smartUnits') =
+ case (lance a) of
+ Nothing -> (Nothing, (smartUnits a))
+ Just l -> let (x, ys) = handleCollisionDamage
+ wmap t l (smartUnits a) in
+ (Just x, ys) in
+
+ let u' = u { arena = a { lance = lance'
+ , smartUnits = smartUnits'
+ }
+ } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+
+handleCollisionsLanceItems (t, u) =
+ let (lance', items') =
+ case (lance a) of
+ Nothing -> (Nothing, (items a))
+ Just l -> let (x, ys) = collisionHandler l (items a) [] in
+ (Just x, ys) in
+
+ let u' = u { arena = a { lance = lance'
+ , items = items'
+ }
+ } in
+ (t, u')
+ where
+ a = arena u
+ wmap = Universe.wrapMap a
+ collisionHandler x [] nys = (x, nys)
+ collisionHandler x (y:ys) nys =
+ if not (collisionWindow wmap (max
+ (maxExpectedVelocity * t)
+ (collisionRadius x + collisionRadius y)) x y)
+ then collisionHandler x ys (nys ++ [y])
+ else
+ case collision wmap t x y of
+ Nothing -> collisionHandler x ys (nys ++ [y])
+ Just _ -> let nx = processItem x y in
+ collisionHandler nx ys nys
+
+handleCollisions :: (Double, Universe) -> (Double, Universe)
+handleCollisions (t, u) =
+
+ ( handleCollisionsLanceItems
+ . handleCollisionsLanceSmartUnits
+ . handleCollisionsLanceProjectilesSmartUnits
+ . handleCollisionsLanceSimpleUnits
+ . handleCollisionsUnitProjectilesAsteroids
+ . handleCollisionsLanceProjectilesSimpleUnits
+ . handleCollisionsLanceProjectilesAsteroids
+ . handleCollisionsLanceUnitProjectiles
+ . handleCollisionsLanceAsteroids
+ ) (t, u)
+
+
+
diff --git a/Trigonometry.hs b/Trigonometry.hs
new file mode 100644
--- /dev/null
+++ b/Trigonometry.hs
@@ -0,0 +1,57 @@
+module Trigonometry where
+
+import Data.Maybe
+
+radToDeg :: Floating a => a -> a
+radToDeg x = x * 180 / pi
+
+mulSV :: Double -> (Double, Double) -> (Double, Double)
+mulSV s (x, y) = (s * x, s * y)
+
+distance :: (Double, Double) -> (Double, Double) -> Double
+distance (x1, y1) (x2, y2) = sqrt ((x2 - x1)**2 + (y2 - y1)**2)
+
+normAngle :: Double -> Double -- radians
+normAngle x = if x >= 0 then asin (sin x)
+ else 2 * pi + asin (sin x)
+
+vectorDirection :: (Double, Double) -- vector
+ -> Double -- angle in radians
+vectorDirection (0, 0) = 0.0 / 0.0 -- NaN
+vectorDirection (x, y)
+ | x >= 0 && y >= 0 = a
+ | x < 0 && y >= 0 = pi - a
+ | x < 0 && y < 0 = pi + a
+ | otherwise = 2 * pi - a
+ where a = atan (abs y / abs x)
+
+-- let x = 2 * pi + pi / 2 in asin (sin x)
+-- let x = (- (2*pi)) + (- (pi / 2)) in 2*pi + asin (sin x)
+
+{-
+ Assumes source (origin of projectile) is at origin of grid (0, 0) and so
+ target center is relative to this. Assumes source is stationary and so
+ velocity of target is relative to source.
+-}
+targetingA :: Double -> (Double, Double) -> (Double, Double) -> Double
+targetingA pSpeed tCenter tVelocity = targetingA'
+ pSpeed tCenter tVelocity Nothing 3
+
+ where targetingA' pSpeed oCenter tVelocity nCenter iter =
+ let eCenter = fromMaybe oCenter nCenter in
+ let d = distance (0, 0) eCenter in
+ let t = d / pSpeed in
+ let aCenter = addV oCenter (mulSV t tVelocity) in
+ if iter > 0
+ then targetingA' pSpeed oCenter tVelocity (Just aCenter) (iter - 1)
+ else vectorDirection aCenter
+
+addV :: (Double, Double) -> (Double, Double) -> (Double, Double)
+addV (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
+
+subV :: (Double, Double) -> (Double, Double) -> (Double, Double)
+subV (x1, y1) (x2, y2) = (x1 - x2, y1 - y2)
+
+doubleRem :: Double -> Double -> Double
+doubleRem x y = let a = x / y in
+ (a - (fromIntegral (truncate a))) * y
diff --git a/Unit.hs b/Unit.hs
new file mode 100644
--- /dev/null
+++ b/Unit.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Unit ( SimpleUnit (..)
+ , SmartUnit (..)
+ ) where
+
+import Animation
+import Moving
+import Combat
+import Updating
+
+-- Simple, i.e., no sensory awareness and related A.I.
+data SimpleUnit = forall a. ( Animation a
+ , Colliding a
+ , Transient a
+ , Damageable a
+ , Damaging a
+ , Launcher a
+ , Audible a
+ ) => SimpleUnit a
+
+instance Colliding SimpleUnit where
+
+ collisionRadius (SimpleUnit a) = collisionRadius a
+
+instance Moving SimpleUnit where
+
+ velocity (SimpleUnit a) = velocity a
+
+instance Locatable SimpleUnit where
+ center (SimpleUnit a) = center a
+
+instance Damaging SimpleUnit where
+ damageEnergy (SimpleUnit a) = damageEnergy a
+
+instance Damageable SimpleUnit where
+ inflictDamage (SimpleUnit a) et = SimpleUnit (inflictDamage a et)
+
+instance Transient SimpleUnit where
+ expired' (SimpleUnit a) = expired' a
+
+instance InternallyUpdating SimpleUnit where
+ preUpdate (SimpleUnit a) et = SimpleUnit (preUpdate a et)
+ postUpdate (SimpleUnit a) et = SimpleUnit (postUpdate a et)
+
+data SmartUnit = forall a. ( Animation a
+ , Colliding a
+ , Transient a
+ , Damageable a
+ , Damaging a
+ , Launcher a
+ , Audible a
+ , Observant a
+ ) => SmartUnit a
+
+instance Colliding SmartUnit where
+
+ collisionRadius (SmartUnit a) = collisionRadius a
+
+instance Moving SmartUnit where
+
+ velocity (SmartUnit a) = velocity a
+
+instance Locatable SmartUnit where
+ center (SmartUnit a) = center a
+
+instance Damaging SmartUnit where
+ damageEnergy (SmartUnit a) = damageEnergy a
+
+instance Damageable SmartUnit where
+ inflictDamage (SmartUnit a) et = SmartUnit (inflictDamage a et)
+
+instance Transient SmartUnit where
+ expired' (SmartUnit a) = expired' a
+
+instance InternallyUpdating SmartUnit where
+ preUpdate (SmartUnit a) et = SmartUnit (preUpdate a et)
+ postUpdate (SmartUnit a) et = SmartUnit (postUpdate a et)
+
+instance Observant SmartUnit where
+ updateVision (SmartUnit a) arena = SmartUnit (updateVision a arena)
+
+instance Launcher SimpleUnit where
+ deployProjectiles (SimpleUnit a) = let (ps, a') = deployProjectiles a in
+ (ps, SimpleUnit a')
+
+instance Launcher SmartUnit where
+ deployProjectiles (SmartUnit a) = let (ps, a') = deployProjectiles a in
+ (ps, SmartUnit a')
+
+instance Audible SimpleUnit where
+ processAudio (SimpleUnit a) wp = do a' <- processAudio a wp
+ return (SimpleUnit a')
+
+ terminateAudio (SimpleUnit a) = do a' <- terminateAudio a
+ return (SimpleUnit a')
+
+instance Audible SmartUnit where
+ processAudio (SmartUnit a) wp = do a' <- processAudio a wp
+ return (SmartUnit a')
+
+ terminateAudio (SmartUnit a) = do a' <- terminateAudio a
+ return (SmartUnit a')
+
diff --git a/Unit/Simple/Turret.hs b/Unit/Simple/Turret.hs
new file mode 100644
--- /dev/null
+++ b/Unit/Simple/Turret.hs
@@ -0,0 +1,184 @@
+module Unit.Simple.Turret ( Turret(..)
+ , new
+ ) where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Trigonometry
+import ResourceTracker
+import Updating
+import qualified Moving as M
+import Combat
+import qualified Projectile.BulletSI as P.BulletSI
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Data.Maybe
+import Sound.ALUT
+
+radialVelocity = pi/6 -- radians per second
+
+velocityMagnitude = 40
+
+kamikazeDamage = 6.0
+
+maxIntegrity = 2.0
+
+data Turret = Turret { turretAngle :: Double -- radians
+ , velocity :: (Double, Double)
+ , center :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , wrapMap :: WrapMap
+ , launchTube :: [Projectile]
+ , sinceLastShot :: Double
+ , integrity :: Double
+ , animDefault0 :: Picture
+ , resourceTracker :: ResourceTracker
+
+ -- Sound
+ , queueShotSound :: Bool
+ , shotSoundSource :: Maybe Source
+ }
+
+instance Audible Turret where
+
+ processAudio self lcenter =
+ do self' <- if isNothing (shotSoundSource self)
+ then initializeShotSoundSource self
+ else return self
+ if not (queueShotSound self)
+ then return self'
+ else do let (x, y) = vectorRelation
+ (wrapMap self)
+ (lcenter)
+ (center self)
+ let s = fromJust $ shotSoundSource self
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self' { queueShotSound = False }
+
+ terminateAudio self =
+ if isNothing (shotSoundSource self)
+ then return self
+ else do stop [fromJust (shotSoundSource self)]
+ return self
+
+initializeShotSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "energy-shot-02.wav"
+ -- ...
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+-- maxDistance source $= audioMaxDistance
+ rolloffFactor source $= audioRolloffFactor
+ return self { shotSoundSource = Just source }
+
+new :: ResourceTracker
+ -> WrapMap
+ -> WrapPoint
+ -> Double
+ -> Double
+ -> Turret
+new rt wmap center' tAngle mAngle =
+ let pic = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "turret.bmp") in
+ Turret { center = center'
+ , turretAngle = tAngle
+ , idealTargetLocation = Nothing
+ , velocity = velocity'
+ , wrapMap = wmap
+ , launchTube = []
+ , sinceLastShot = 0.0
+ , integrity = maxIntegrity
+ , animDefault0 = pic
+ , resourceTracker = rt
+
+ , queueShotSound = False
+ , shotSoundSource = Nothing
+ }
+ where velocity' =( sin mAngle * velocityMagnitude
+ , cos mAngle * velocityMagnitude
+ )
+
+updateAngle t self
+ = self { turretAngle = turretAngle self - radialVelocity * t}
+
+instance Animation Turret where
+ image self _ = Rotate (radToDeg
+ (double2Float
+ (turretAngle self)) * (-1) - 90)
+ (animDefault0 self)
+
+instance M.Locatable Turret where
+ center = center
+
+instance M.Moving Turret where
+ velocity = velocity
+
+instance M.Colliding Turret where
+ collisionRadius _ = 16.0
+
+instance InternallyUpdating Turret where
+
+ preUpdate self t = (updateFiringInformation t
+ . updateIdealTargetLocation t
+ . updateAngle t) self
+
+ postUpdate self t =
+ let center' = fromMaybe (center self) (idealTargetLocation self) in
+ self { center = center'
+ , idealTargetLocation = Nothing
+ }
+
+updateFiringInformation t self =
+ let sinceLastShot' = sinceLastShot self + t in
+ if sinceLastShot' >= 1.5
+ then self { sinceLastShot = 0.0
+ , launchTube = launchTube self ++ projectiles
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = sinceLastShot' }
+ where projectiles = map projectile [ 0.0, pi / 2, pi, 3 * pi / 2 ]
+ projectile x = Projectile ( P.BulletSI.new
+ (wrapMap self)
+ (turretAngle self + x)
+ (center self)
+ (velocity self) )
+
+
+updateIdealTargetLocation :: Double -> Turret -> Turret
+updateIdealTargetLocation t self =
+ self { idealTargetLocation = Just (M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t)
+ }
+
+instance Launcher Turret where
+
+ deployProjectiles self = (launchTube self, self { launchTube = [] })
+
+instance Transient Turret where
+
+ expired' self = if integrity self > 0.0
+ then Nothing
+ else Just [aeffect]
+ where aeffect = AfterEffect (SimpleExplosion.new (resourceTracker self)
+ (wrapMap self)
+ (center self)
+ (velocity self))
+
+instance Damageable Turret where
+
+ inflictDamage self d = self { integrity = max 0.0 (integrity self - d) }
+
+instance Damaging Turret where
+
+ damageEnergy self = kamikazeDamage
diff --git a/Unit/Smart/ATank.hs b/Unit/Smart/ATank.hs
new file mode 100644
--- /dev/null
+++ b/Unit/Smart/ATank.hs
@@ -0,0 +1,223 @@
+module Unit.Smart.ATank ( ATank(..)
+ , new
+ ) where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Trigonometry
+import ResourceTracker
+import Updating
+import qualified Moving as M
+import Combat
+import qualified Projectile.BulletMI as P.BulletMI
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Data.Maybe
+import Universe hiding (wrapMap, resourceTracker)
+import qualified Universe as U
+import Sound.ALUT
+
+radialVelocity = pi/4 -- radians per second
+
+maxVelocityMag = 60
+
+kamikazeDamage = 14.0
+
+maxIntegrity = 4
+
+accelerationRate = 40
+
+data ATank = ATank { angle :: Double -- radians
+ , velocity :: (Double, Double)
+ , center :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , wrapMap :: WrapMap
+ , launchTube :: [Projectile]
+ , sinceLastShot :: Double
+ , integrity :: Double
+ , vision :: Maybe Arena
+ , resourceTracker :: ResourceTracker
+
+ -- Sound
+ , queueShotSound :: Bool
+ , shotSoundSource :: Maybe Source
+ }
+
+instance Audible ATank where
+
+ processAudio self lcenter =
+ do self' <- if isNothing (shotSoundSource self)
+ then initializeShotSoundSource self
+ else return self
+ if not (queueShotSound self)
+ then return self'
+ else do let (x, y) = vectorRelation
+ (wrapMap self)
+ (lcenter)
+ (center self)
+ let s = fromJust $ shotSoundSource self
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self' { queueShotSound = False }
+
+ terminateAudio self =
+ if isNothing (shotSoundSource self)
+ then return self
+ else do stop [fromJust (shotSoundSource self)]
+ return self
+
+initializeShotSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "energy-shot-02.wav"
+ -- ...
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+-- maxDistance source $= audioMaxDistance
+ rolloffFactor source $= audioRolloffFactor
+ return self { shotSoundSource = Just source }
+
+new :: ResourceTracker
+ -> WrapMap
+ -> WrapPoint
+ -> Double
+ -> ATank
+new rt wmap center' angle' =
+ ATank { center = center'
+ , angle = angle'
+ , idealTargetLocation = Nothing
+ , velocity = (0.0, 0.0)
+ , wrapMap = wmap
+ , launchTube = []
+ , sinceLastShot = 0.0
+ , integrity = maxIntegrity
+ , vision = Nothing
+ , resourceTracker = rt
+
+ , queueShotSound = False
+ , shotSoundSource = Nothing
+ }
+
+instance Observant ATank where
+
+ updateVision self arena = self { vision = Just arena }
+
+updateAngle t self
+ = case vision self of
+ Nothing -> self
+ Just arena -> if isNothing (lance arena)
+ then self
+ else let sDir = vectorDirection (velocity self) in
+ let tDir = vectorDirection
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center (fromJust (lance arena)))) in
+ let adj
+ | tDir - sDir > pi / 6 = radialVelocity * t
+ | tDir -sDir < (-pi) / 6 = (-radialVelocity) * t
+ | otherwise = 0.0 in
+ self { angle = angle self + adj }
+
+updateVelocity :: Double -> ATank -> ATank
+updateVelocity t self =
+ self { velocity = M.calcNewVelocity
+ (velocity self)
+ accelerationRate
+ (angle self)
+ maxVelocityMag
+ t
+ }
+
+instance Animation ATank where
+ image self _ = Rotate (radToDeg
+ (double2Float
+ (angle self)) * (-1) - 90)
+ pic
+ where pic = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "atank.bmp")
+ rt = resourceTracker self
+
+instance M.Locatable ATank where
+ center = center
+
+instance M.Moving ATank where
+ velocity = velocity
+
+instance M.Colliding ATank where
+ collisionRadius _ = 20.0
+
+instance InternallyUpdating ATank where
+
+ preUpdate self t = (updateFiringInformation t
+ . updateIdealTargetLocation t
+ . updateVelocity t
+ . updateAngle t) self
+
+ postUpdate self t =
+ let center' = fromMaybe (center self) (idealTargetLocation self) in
+ self { center = center'
+ , idealTargetLocation = Nothing
+ }
+
+updateFiringInformation t self =
+ let sinceLastShot' = sinceLastShot self + t in
+ if sinceLastShot' >= 2.5
+ then self { sinceLastShot = 0.0
+ , launchTube = projectile : launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = sinceLastShot' }
+ where projectile = Projectile
+ (P.BulletMI.new
+ (wrapMap self)
+ pAngle
+ (center self)
+ (velocity self))
+ pAngle = case vision self of
+ Nothing -> angle self
+ Just arena ->
+ case lance arena of
+ Nothing -> angle self
+ Just l -> vectorDirection
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center l))
+
+updateIdealTargetLocation :: Double -> ATank -> ATank
+updateIdealTargetLocation t self =
+ self { idealTargetLocation = Just (M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t)
+ }
+
+instance Launcher ATank where
+
+ deployProjectiles self = (launchTube self, self { launchTube = [] })
+
+instance Transient ATank where
+
+ expired' self = if integrity self > 0.0
+ then Nothing
+ else Just [aeffect]
+ where aeffect = AfterEffect (SimpleExplosion.new (resourceTracker self)
+ (wrapMap self)
+ (center self)
+ (velocity self))
+
+instance Damageable ATank where
+
+ inflictDamage self d = self { integrity = max 0.0 (integrity self - d) }
+
+instance Damaging ATank where
+
+ damageEnergy self = kamikazeDamage
diff --git a/Unit/Smart/Death.hs b/Unit/Smart/Death.hs
new file mode 100644
--- /dev/null
+++ b/Unit/Smart/Death.hs
@@ -0,0 +1,279 @@
+module Unit.Smart.Death ( Death(..)
+ , new
+ ) where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Trigonometry
+import ResourceTracker
+import Updating
+import qualified Moving as M
+import Combat
+import qualified Projectile.BulletSII as P.BulletSII
+import qualified Projectile.BulletMII as P.BulletMII
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Data.Maybe
+import Universe hiding (wrapMap, resourceTracker)
+import qualified Universe as U
+import Sound.ALUT
+
+radialVelocity = pi -- radians per second
+
+maxVelocityMag = 200.0
+
+kamikazeDamage = 100.0
+
+maxIntegrity = 12
+
+accelerationRate = 200.0
+
+adjAngle = pi / 8
+
+shotDelay_sniper = 3.0
+
+shotDelay_spread = 2.0
+
+data Death = Death { angle :: Double -- radians
+ , velocity :: (Double, Double)
+ , center :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , wrapMap :: WrapMap
+ , launchTube :: [Projectile]
+ , sinceLastShot_sniper :: Double
+ , sinceLastShot_spread :: Double
+ , integrity :: Double
+ , vision :: Maybe Arena
+ , resourceTracker :: ResourceTracker
+
+ -- Sound
+ , queueShotSound :: Bool
+ , shotSoundSource :: Maybe Source
+ }
+
+instance Audible Death where
+
+ processAudio self lcenter =
+ do self' <- if isNothing (shotSoundSource self)
+ then initializeShotSoundSource self
+ else return self
+ if not (queueShotSound self)
+ then return self'
+ else do let (x, y) = vectorRelation
+ (wrapMap self)
+ (lcenter)
+ (center self)
+ let s = fromJust $ shotSoundSource self
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self' { queueShotSound = False }
+
+ terminateAudio self =
+ if isNothing (shotSoundSource self)
+ then return self
+ else do stop [fromJust (shotSoundSource self)]
+ return self
+
+initializeShotSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "energy-shot-02.wav"
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+ rolloffFactor source $= audioRolloffFactor
+ return self { shotSoundSource = Just source }
+
+new :: ResourceTracker
+ -> WrapMap
+ -> WrapPoint
+ -> Double
+ -> Death
+new rt wmap center' angle' =
+ Death { center = center'
+ , angle = angle'
+ , idealTargetLocation = Nothing
+ , velocity = (0.0, 0.0)
+ , wrapMap = wmap
+ , launchTube = []
+ , sinceLastShot_sniper = 0.0
+ , sinceLastShot_spread = 0.0
+ , integrity = maxIntegrity
+ , vision = Nothing
+ , resourceTracker = rt
+
+ , queueShotSound = False
+ , shotSoundSource = Nothing
+ }
+
+instance Observant Death where
+
+ updateVision self arena = self { vision = Just arena }
+
+updateAngle t self
+ = case vision self of
+ Nothing -> self
+ Just a -> case lance a of
+ Nothing -> self
+ Just l -> let sDir = angle self in
+ let sDir' = if sDir == 0.0 / 0.0
+ then 0.1
+ else sDir in
+ let tDir = vectorDirection
+ (vectorRelation
+ (wrapMap self)
+ (center self)
+ (M.center l)) in
+ let adj
+ | tDir - sDir' > adjAngle = radialVelocity * t
+ | tDir - sDir' < (-1) * adjAngle = (-radialVelocity) * t
+ | otherwise = 0.0 in
+ self { angle = angle self + adj }
+
+updateVelocity t self =
+ let thrustingVelocity = M.calcNewVelocity
+ (velocity self)
+ accelerationRate
+ (angle self)
+ maxVelocityMag
+ t in
+ let velocity' = case vision self of
+ Nothing -> velocity self
+ Just a ->
+ case lance a of
+ Nothing -> velocity self
+ Just l -> let sDir = angle self in
+ let sDir' = if sDir == 0.0 / 0.0
+ then 0.1
+ else sDir in
+ let tDir = vectorDirection
+ (vectorRelation
+ (wrapMap self)
+ (center self)
+ (M.center l)) in
+ if abs (tDir - sDir') <= adjAngle
+ then thrustingVelocity
+ else velocity self in
+ self { velocity = velocity' }
+
+instance Animation Death where
+ image self _ = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "death.bmp")
+ where rt = resourceTracker self
+
+instance M.Locatable Death where
+ center = center
+
+instance M.Moving Death where
+ velocity = velocity
+
+instance M.Colliding Death where
+ collisionRadius _ = 60.0
+
+instance InternallyUpdating Death where
+
+ preUpdate self t = (updateFiringInformation t
+ . updateIdealTargetLocation t
+ . updateVelocity t
+ . updateAngle t) self
+
+ postUpdate self t =
+ let center' = fromMaybe (center self) (idealTargetLocation self) in
+ self { center = center'
+ , idealTargetLocation = Nothing
+ }
+
+updateFiringInformation t self =
+ fst $ (handleSpreadFiring . handleSniperFiring) (self, t)
+
+handleSniperFiring (self, t) =
+ let sinceLastShot_sniper' = sinceLastShot_sniper self + t in
+ if sinceLastShot_sniper' >= shotDelay_sniper
+ then (self { sinceLastShot_sniper = 0.0
+ , launchTube = projectile : launchTube self
+ , queueShotSound = True
+ }, t)
+ else (self { sinceLastShot_sniper = sinceLastShot_sniper' }, t)
+ where projectile = Projectile
+ (P.BulletSII.new
+ (wrapMap self)
+ pAngle
+ (center self)
+ (velocity self))
+ pSpeed = P.BulletSII.speed
+ pAngle = case vision self of
+ Nothing -> angle self
+ Just arena ->
+ case lance arena of
+ Nothing -> angle self
+ Just l -> targetingA
+ pSpeed
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center l))
+ (subV
+ (M.velocity l)
+ (M.velocity self))
+
+handleSpreadFiring (self, t) =
+ let sinceLastShot_spread' = sinceLastShot_spread self + t in
+ if sinceLastShot_spread' >= shotDelay_spread
+ then (self { sinceLastShot_spread = 0.0
+ , launchTube = projectiles ++ launchTube self
+ , queueShotSound = True
+ }, t)
+ else (self { sinceLastShot_spread = sinceLastShot_spread' }, t)
+ where projectiles = map projectile [ x * pi / 8.0 - pi / 4.0 | x <- [0..7] ]
+ projectile x = Projectile
+ (P.BulletMII.new
+ (wrapMap self)
+ (pAngle + x)
+ (center self)
+ (velocity self))
+ pAngle = case vision self of
+ Nothing -> angle self
+ Just arena ->
+ case lance arena of
+ Nothing -> angle self
+ Just l -> vectorDirection
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center l))
+
+updateIdealTargetLocation :: Double -> Death -> Death
+updateIdealTargetLocation t self =
+ self { idealTargetLocation = Just (M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t)
+ }
+
+instance Launcher Death where
+
+ deployProjectiles self = (launchTube self, self { launchTube = [] })
+
+instance Transient Death where
+
+ expired' self = if integrity self > 0.0
+ then Nothing
+ else Just [aeffect]
+ where aeffect = AfterEffect (SimpleExplosion.new (resourceTracker self)
+ (wrapMap self)
+ (center self)
+ (velocity self))
+
+instance Damageable Death where
+
+ inflictDamage self d = self { integrity = max 0.0 (integrity self - d) }
+
+instance Damaging Death where
+
+ damageEnergy self = kamikazeDamage
diff --git a/Unit/Smart/Ninja.hs b/Unit/Smart/Ninja.hs
new file mode 100644
--- /dev/null
+++ b/Unit/Smart/Ninja.hs
@@ -0,0 +1,252 @@
+module Unit.Smart.Ninja ( Ninja(..)
+ , new
+ ) where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Trigonometry
+import ResourceTracker
+import Updating
+import qualified Moving as M
+import Combat
+import qualified Projectile.Blade as P.Blade
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Data.Maybe
+import Universe hiding (wrapMap, resourceTracker)
+import qualified Universe as U
+import Sound.ALUT
+
+radialVelocity = pi/2 -- radians per second
+
+maxVelocityMag = 200.0
+
+kamikazeDamage = 8.0
+
+maxIntegrity = 2
+
+accelerationRate = 200.0
+
+adjAngle = pi / 8
+
+shotDelay = 5.0
+
+data Ninja = Ninja { angle :: Double -- radians
+ , velocity :: (Double, Double)
+ , center :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , wrapMap :: WrapMap
+ , launchTube :: [Projectile]
+ , sinceLastShot :: Double
+ , integrity :: Double
+ , vision :: Maybe Arena
+ , resourceTracker :: ResourceTracker
+
+ -- Sound
+ , queueShotSound :: Bool
+ , shotSoundSource :: Maybe Source
+ }
+
+instance Audible Ninja where
+
+ processAudio self lcenter =
+ do self' <- if isNothing (shotSoundSource self)
+ then initializeShotSoundSource self
+ else return self
+ if not (queueShotSound self)
+ then return self'
+ else do let (x, y) = vectorRelation
+ (wrapMap self)
+ (lcenter)
+ (center self)
+ let s = fromJust $ shotSoundSource self
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self' { queueShotSound = False }
+
+ terminateAudio self =
+ if isNothing (shotSoundSource self)
+ then return self
+ else do stop [fromJust (shotSoundSource self)]
+ return self
+
+initializeShotSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "energy-shot-02.wav"
+ -- ...
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+ rolloffFactor source $= audioRolloffFactor
+ return self { shotSoundSource = Just source }
+
+new :: ResourceTracker
+ -> WrapMap
+ -> WrapPoint
+ -> Double
+ -> Ninja
+new rt wmap center' angle' =
+ Ninja { center = center'
+ , angle = angle'
+ , idealTargetLocation = Nothing
+ , velocity = (0.0, 0.0)
+ , wrapMap = wmap
+ , launchTube = []
+ , sinceLastShot = 0.0
+ , integrity = maxIntegrity
+ , vision = Nothing
+ , resourceTracker = rt
+ , queueShotSound = False
+ , shotSoundSource = Nothing
+ }
+
+instance Observant Ninja where
+
+ updateVision self arena = self { vision = Just arena }
+
+
+updateAngle t self
+ = case vision self of
+ Nothing -> self
+ Just a -> case lance a of
+ Nothing -> self
+ Just l -> let sDir = angle self in
+ let sDir' = if sDir == 0.0 / 0.0
+ then 0.1
+ else sDir in
+ let tDir = vectorDirection
+ (vectorRelation
+ (wrapMap self)
+ (center self)
+ (M.center l)) in
+ let adj
+ | tDir - sDir' > adjAngle = radialVelocity * t
+ | tDir - sDir' < (-1) * adjAngle = (-radialVelocity) * t
+ | otherwise = 0.0 in
+ self { angle = angle self + adj }
+
+updateVelocity :: Double -> Ninja -> Ninja
+updateVelocity t self =
+ let thrustingVelocity = M.calcNewVelocity
+ (velocity self)
+ accelerationRate
+ (angle self)
+ maxVelocityMag
+ t in
+ let velocity' = case vision self of
+ Nothing -> velocity self
+ Just a ->
+ case lance a of
+ Nothing -> velocity self
+ Just l -> let sDir = angle self in
+ let sDir' = if sDir == 0.0 / 0.0
+ then 0.1
+ else sDir in
+ let tDir = vectorDirection
+ (vectorRelation
+ (wrapMap self)
+ (center self)
+ (M.center l)) in
+ if abs (tDir - sDir') <= adjAngle
+ then thrustingVelocity
+ else velocity self in
+ self { velocity = velocity' }
+
+instance Animation Ninja where
+ image self _ = Rotate (radToDeg
+ (double2Float
+ (angle self)) * (-1) - 90)
+ pic
+ where pic = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "ninja.bmp")
+ rt = resourceTracker self
+
+instance M.Locatable Ninja where
+ center = center
+
+instance M.Moving Ninja where
+ velocity = velocity
+
+instance M.Colliding Ninja where
+ collisionRadius _ = 40.0
+
+instance InternallyUpdating Ninja where
+
+ preUpdate self t = (updateFiringInformation t
+ . updateIdealTargetLocation t
+ . updateVelocity t
+ . updateAngle t) self
+
+ postUpdate self t =
+ let center' = fromMaybe (center self) (idealTargetLocation self) in
+ self { center = center'
+ , idealTargetLocation = Nothing
+ }
+
+updateFiringInformation t self =
+ let sinceLastShot' = sinceLastShot self + t in
+ if sinceLastShot' >= shotDelay
+ then self { sinceLastShot = 0.0
+ , launchTube = projectile : launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = sinceLastShot' }
+ where projectile = Projectile
+ (P.Blade.new
+ (wrapMap self)
+ (resourceTracker self)
+ pAngle
+ (center self)
+ (velocity self))
+ pSpeed = P.Blade.speed
+ pAngle = case vision self of
+ Nothing -> angle self
+ Just arena ->
+ case lance arena of
+ Nothing -> angle self
+ Just l -> targetingA
+ pSpeed
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center l))
+ (subV
+ (M.velocity l)
+ (M.velocity self))
+
+updateIdealTargetLocation :: Double -> Ninja -> Ninja
+updateIdealTargetLocation t self =
+ self { idealTargetLocation = Just (M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t)
+ }
+
+instance Launcher Ninja where
+
+ deployProjectiles self = (launchTube self, self { launchTube = [] })
+
+instance Transient Ninja where
+
+ expired' self = if integrity self > 0.0
+ then Nothing
+ else Just [aeffect]
+ where aeffect = AfterEffect (SimpleExplosion.new (resourceTracker self)
+ (wrapMap self)
+ (center self)
+ (velocity self))
+
+instance Damageable Ninja where
+
+ inflictDamage self d = self { integrity = max 0.0 (integrity self - d) }
+
+instance Damaging Ninja where
+
+ damageEnergy self = kamikazeDamage
diff --git a/Unit/Smart/Saucer.hs b/Unit/Smart/Saucer.hs
new file mode 100644
--- /dev/null
+++ b/Unit/Smart/Saucer.hs
@@ -0,0 +1,257 @@
+module Unit.Smart.Saucer ( Saucer(..)
+ , new
+ ) where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Trigonometry
+import ResourceTracker
+import Updating
+import qualified Moving as M
+import Combat
+import qualified Projectile.Pellet as P.Pellet
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Data.Maybe
+import Universe hiding (wrapMap, resourceTracker)
+import qualified Universe as U
+import Sound.ALUT
+
+radialVelocity = pi -- radians per second
+
+maxVelocityMag = 300
+
+kamikazeDamage = 6.0
+
+maxIntegrity = 1
+
+accelerationRate = 300
+
+adjAngle = pi / 8
+
+shotDelay = 0.10
+
+data Saucer = Saucer { angle :: Double -- radians
+ , velocity :: (Double, Double)
+ , center :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , wrapMap :: WrapMap
+ , launchTube :: [Projectile]
+ , sinceLastShot :: Double
+ , integrity :: Double
+ , vision :: Maybe Arena
+ , resourceTracker :: ResourceTracker
+ , firingAnglesIndex :: Int
+
+ -- Sound
+ , queueShotSound :: Bool
+ , shotSoundSource :: Maybe Source
+ }
+
+instance Audible Saucer where
+
+ processAudio self lcenter =
+ do self' <- if isNothing (shotSoundSource self)
+ then initializeShotSoundSource self
+ else return self
+ if not (queueShotSound self)
+ then return self'
+ else do let (x, y) = vectorRelation
+ (wrapMap self)
+ (lcenter)
+ (center self)
+ let s = fromJust $ shotSoundSource self
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self' { queueShotSound = False }
+
+ terminateAudio self =
+ if isNothing (shotSoundSource self)
+ then return self
+ else do stop [fromJust (shotSoundSource self)]
+ return self
+
+initializeShotSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "energy-shot-02.wav"
+ -- ...
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+-- maxDistance source $= audioMaxDistance
+ rolloffFactor source $= audioRolloffFactor
+ return self { shotSoundSource = Just source }
+
+new :: ResourceTracker
+ -> WrapMap
+ -> WrapPoint
+ -> Double
+ -> Saucer
+new rt wmap center' angle' =
+ Saucer { center = center'
+ , angle = angle'
+ , idealTargetLocation = Nothing
+ , velocity = (0.0, 0.0)
+ , wrapMap = wmap
+ , launchTube = []
+ , sinceLastShot = 0.0
+ , integrity = maxIntegrity
+ , vision = Nothing
+ , resourceTracker = rt
+ , firingAnglesIndex = 0
+
+ , queueShotSound = False
+ , shotSoundSource = Nothing
+ }
+
+instance Observant Saucer where
+
+ updateVision self arena = self { vision = Just arena }
+
+updateAngle t self
+ = case vision self of
+ Nothing -> self
+ Just a -> case lance a of
+ Nothing -> self
+ Just l -> let sDir = angle self in
+ let sDir' = if sDir == 0.0 / 0.0
+ then 0.1
+ else sDir in
+ let tDir = vectorDirection
+ (vectorRelation
+ (wrapMap self)
+ (center self)
+ (M.center l)) in
+ let adj
+ | tDir - sDir' > adjAngle = radialVelocity * t
+ | tDir - sDir' < (-1) * adjAngle = (-radialVelocity) * t
+ | otherwise = 0.0 in
+ self { angle = angle self + adj }
+
+updateVelocity :: Double -> Saucer -> Saucer
+updateVelocity t self =
+ let thrustingVelocity = M.calcNewVelocity
+ (velocity self)
+ accelerationRate
+ (angle self)
+ maxVelocityMag
+ t in
+ let velocity' = case vision self of
+ Nothing -> velocity self
+ Just a ->
+ case lance a of
+ Nothing -> velocity self
+ Just l -> let sDir = angle self in
+ let sDir' = if sDir == 0.0 / 0.0
+ then 0.1
+ else sDir in
+ let tDir = vectorDirection
+ (vectorRelation
+ (wrapMap self)
+ (center self)
+ (M.center l)) in
+ if abs (tDir - sDir') <= adjAngle
+ then thrustingVelocity
+ else velocity self in
+ self { velocity = velocity' }
+
+instance Animation Saucer where
+ image self _ = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "saucer.bmp")
+ where rt = resourceTracker self
+
+instance M.Locatable Saucer where
+ center = center
+
+instance M.Moving Saucer where
+ velocity = velocity
+
+instance M.Colliding Saucer where
+ collisionRadius _ = 20.0
+
+instance InternallyUpdating Saucer where
+
+ preUpdate self t = (updateFiringInformation t
+ . updateIdealTargetLocation t
+ . updateVelocity t
+ . updateAngle t) self
+
+ postUpdate self t =
+ let center' = fromMaybe (center self) (idealTargetLocation self) in
+ self { center = center'
+ , idealTargetLocation = Nothing
+ }
+
+updateFiringInformation t self =
+ let inRange = case vision self of
+ Nothing -> False
+ Just a -> case lance a of
+ Nothing -> False
+ Just l -> Data.WrapAround.distance
+ (wrapMap self)
+ (center self)
+ (M.center l) <= P.Pellet.range in
+ let sinceLastShot' = sinceLastShot self + t in
+ if sinceLastShot' >= shotDelay && inRange
+ then self { sinceLastShot = 0.0
+ , launchTube = projectile : launchTube self
+ , queueShotSound = True
+ , firingAnglesIndex =
+ if firingAnglesIndex self >= length firingAngles - 1
+ then 0
+ else firingAnglesIndex self + 1
+ }
+ else self { sinceLastShot = sinceLastShot' }
+ where projectile = Projectile
+ (P.Pellet.new
+ (wrapMap self)
+ pAngle
+ (center self)
+ (velocity self))
+ pAngle = firingAngles !! firingAnglesIndex self
+ firingAngles = [ 0.0
+ , 3.142
+ , 0.785
+ , 3.927
+ , 1.571
+ , 4.712
+ , 2.356
+ , 5.498
+ ]
+
+updateIdealTargetLocation :: Double -> Saucer -> Saucer
+updateIdealTargetLocation t self =
+ self { idealTargetLocation = Just (M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t)
+ }
+
+instance Launcher Saucer where
+
+ deployProjectiles self = (launchTube self, self { launchTube = [] })
+
+instance Transient Saucer where
+
+ expired' self = if integrity self > 0.0
+ then Nothing
+ else Just [aeffect]
+ where aeffect = AfterEffect (SimpleExplosion.new (resourceTracker self)
+ (wrapMap self)
+ (center self)
+ (velocity self))
+
+instance Damageable Saucer where
+
+ inflictDamage self d = self { integrity = max 0.0 (integrity self - d) }
+
+instance Damaging Saucer where
+
+ damageEnergy self = kamikazeDamage
diff --git a/Unit/Smart/Sniper.hs b/Unit/Smart/Sniper.hs
new file mode 100644
--- /dev/null
+++ b/Unit/Smart/Sniper.hs
@@ -0,0 +1,232 @@
+module Unit.Smart.Sniper ( Sniper(..)
+ , new
+ ) where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Trigonometry
+import ResourceTracker
+import Updating
+import qualified Moving as M
+import Combat
+import qualified Projectile.BulletSII as P.BulletSII
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Data.Maybe
+import Universe hiding (wrapMap, resourceTracker)
+import qualified Universe as U
+import Sound.ALUT
+
+radialVelocity = pi/6 -- radians per second
+
+maxVelocityMag = 20
+
+kamikazeDamage = 2.0
+
+maxIntegrity = 1
+
+accelerationRate = 30
+
+adjAngle = pi / 8
+
+shotDelay = 4.0
+
+data Sniper = Sniper { angle :: Double -- radians
+ , velocity :: (Double, Double)
+ , center :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , wrapMap :: WrapMap
+ , launchTube :: [Projectile]
+ , sinceLastShot :: Double
+ , integrity :: Double
+ , vision :: Maybe Arena
+ , resourceTracker :: ResourceTracker
+
+ -- Sound
+ , queueShotSound :: Bool
+ , shotSoundSource :: Maybe Source
+ }
+
+instance Audible Sniper where
+
+ processAudio self lcenter =
+ do self' <- if isNothing (shotSoundSource self)
+ then initializeShotSoundSource self
+ else return self
+ if not (queueShotSound self)
+ then return self'
+ else do let (x, y) = vectorRelation
+ (wrapMap self)
+ (lcenter)
+ (center self)
+ let s = fromJust $ shotSoundSource self
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self' { queueShotSound = False }
+
+ terminateAudio self =
+ if isNothing (shotSoundSource self)
+ then return self
+ else do stop [fromJust (shotSoundSource self)]
+ return self
+
+initializeShotSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "energy-shot-02.wav"
+ -- ...
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+-- maxDistance source $= audioMaxDistance
+ rolloffFactor source $= audioRolloffFactor
+ return self { shotSoundSource = Just source }
+
+new :: ResourceTracker
+ -> WrapMap
+ -> WrapPoint
+ -> Double
+ -> Sniper
+new rt wmap center' angle' =
+ Sniper { center = center'
+ , angle = angle'
+ , idealTargetLocation = Nothing
+ , velocity = (0.0, 0.0)
+ , wrapMap = wmap
+ , launchTube = []
+ , sinceLastShot = 0.0
+ , integrity = maxIntegrity
+ , vision = Nothing
+ , resourceTracker = rt
+
+ , queueShotSound = False
+ , shotSoundSource = Nothing
+ }
+
+instance Observant Sniper where
+
+ updateVision self arena = self { vision = Just arena }
+
+updateAngle t self
+ = case vision self of
+ Nothing -> self
+ Just arena -> if isNothing (lance arena)
+ then self
+ else let sDir = vectorDirection (velocity self) in
+ let tDir = vectorDirection
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center (fromJust (lance arena)))) in
+ let adj
+ | tDir - sDir > adjAngle = radialVelocity * t
+ | tDir -sDir < (-1) * adjAngle = (-radialVelocity) * t
+ | otherwise = 0.0 in
+ self { angle = angle self + adj }
+
+updateVelocity :: Double -> Sniper -> Sniper
+updateVelocity t self =
+ self { velocity = M.calcNewVelocity
+ (velocity self)
+ accelerationRate
+ (angle self)
+ maxVelocityMag
+ t
+ }
+
+instance Animation Sniper where
+ image self _ = Rotate (radToDeg
+ (double2Float
+ (angle self)) * (-1) - 90)
+ pic
+ where pic = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "sniper.bmp")
+ rt = resourceTracker self
+
+instance M.Locatable Sniper where
+ center = center
+
+instance M.Moving Sniper where
+ velocity = velocity
+
+instance M.Colliding Sniper where
+ collisionRadius _ = 20.0
+
+instance InternallyUpdating Sniper where
+
+ preUpdate self t = (updateFiringInformation t
+ . updateIdealTargetLocation t
+ . updateVelocity t
+ . updateAngle t) self
+
+ postUpdate self t =
+ let center' = fromMaybe (center self) (idealTargetLocation self) in
+ self { center = center'
+ , idealTargetLocation = Nothing
+ }
+
+updateFiringInformation t self =
+ let sinceLastShot' = sinceLastShot self + t in
+ if sinceLastShot' >= shotDelay
+ then self { sinceLastShot = 0.0
+ , launchTube = projectile : launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = sinceLastShot' }
+ where projectile = Projectile
+ (P.BulletSII.new
+ (wrapMap self)
+ pAngle
+ (center self)
+ (velocity self))
+ pSpeed = P.BulletSII.speed
+ pAngle = case vision self of
+ Nothing -> angle self
+ Just arena ->
+ case lance arena of
+ Nothing -> angle self
+ Just l -> targetingA
+ pSpeed
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center l))
+ (subV
+ (M.velocity l)
+ (M.velocity self))
+
+updateIdealTargetLocation :: Double -> Sniper -> Sniper
+updateIdealTargetLocation t self =
+ self { idealTargetLocation = Just (M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t)
+ }
+
+instance Launcher Sniper where
+
+ deployProjectiles self = (launchTube self, self { launchTube = [] })
+
+instance Transient Sniper where
+
+ expired' self = if integrity self > 0.0
+ then Nothing
+ else Just [aeffect]
+ where aeffect = AfterEffect (SimpleExplosion.new (resourceTracker self)
+ (wrapMap self)
+ (center self)
+ (velocity self))
+
+instance Damageable Sniper where
+
+ inflictDamage self d = self { integrity = max 0.0 (integrity self - d) }
+
+instance Damaging Sniper where
+
+ damageEnergy self = kamikazeDamage
diff --git a/Unit/Smart/Tank.hs b/Unit/Smart/Tank.hs
new file mode 100644
--- /dev/null
+++ b/Unit/Smart/Tank.hs
@@ -0,0 +1,223 @@
+module Unit.Smart.Tank ( Tank(..)
+ , new
+ ) where
+
+import Data.WrapAround
+import Animation
+import Graphics.Gloss.Data.Picture
+import Graphics.Gloss.Data.Color
+import GHC.Float
+import Trigonometry
+import ResourceTracker
+import Updating
+import qualified Moving as M
+import Combat
+import qualified Projectile.BulletSI as P.BulletSI
+import AfterEffect
+import qualified AfterEffect.SimpleExplosion as SimpleExplosion
+import Data.Maybe
+import Universe hiding (wrapMap, resourceTracker)
+import qualified Universe as U
+import Sound.ALUT
+
+radialVelocity = pi/6 -- radians per second
+
+maxVelocityMag = 40
+
+kamikazeDamage = 10.0
+
+maxIntegrity = 3
+
+accelerationRate = 30
+
+data Tank = Tank { angle :: Double -- radians
+ , velocity :: (Double, Double)
+ , center :: WrapPoint
+ , idealTargetLocation :: Maybe WrapPoint
+ , wrapMap :: WrapMap
+ , launchTube :: [Projectile]
+ , sinceLastShot :: Double
+ , integrity :: Double
+ , vision :: Maybe Arena
+ , resourceTracker :: ResourceTracker
+
+ -- Sound
+ , queueShotSound :: Bool
+ , shotSoundSource :: Maybe Source
+ }
+
+instance Audible Tank where
+
+ processAudio self lcenter =
+ do self' <- if isNothing (shotSoundSource self)
+ then initializeShotSoundSource self
+ else return self
+ if not (queueShotSound self)
+ then return self'
+ else do let (x, y) = vectorRelation
+ (wrapMap self)
+ (lcenter)
+ (center self)
+ let s = fromJust $ shotSoundSource self
+ sourcePosition s $= (Vertex3 (double2Float x)
+ (double2Float (-y))
+ 0)
+ play [s]
+ return self' { queueShotSound = False }
+
+ terminateAudio self =
+ if isNothing (shotSoundSource self)
+ then return self
+ else do stop [fromJust (shotSoundSource self)]
+ return self
+
+initializeShotSoundSource self =
+ do [source] <- genObjectNames 1
+ buffer source $= getSound (resourceTracker self) "energy-shot-02.wav"
+ -- ...
+ sourceRelative source $= Listener
+ referenceDistance source $= audioReferenceDistance
+-- maxDistance source $= audioMaxDistance
+ rolloffFactor source $= audioRolloffFactor
+ return self { shotSoundSource = Just source }
+
+new :: ResourceTracker
+ -> WrapMap
+ -> WrapPoint
+ -> Double
+ -> Tank
+new rt wmap center' angle' =
+ Tank { center = center'
+ , angle = angle'
+ , idealTargetLocation = Nothing
+ , velocity = (0.0, 0.0)
+ , wrapMap = wmap
+ , launchTube = []
+ , sinceLastShot = 0.0
+ , integrity = maxIntegrity
+ , vision = Nothing
+ , resourceTracker = rt
+
+ , queueShotSound = False
+ , shotSoundSource = Nothing
+ }
+
+instance Observant Tank where
+
+ updateVision self arena = self { vision = Just arena }
+
+updateAngle t self
+ = case vision self of
+ Nothing -> self
+ Just arena -> if isNothing (lance arena)
+ then self
+ else let sDir = vectorDirection (velocity self) in
+ let tDir = vectorDirection
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center (fromJust (lance arena)))) in
+ let adj
+ | tDir - sDir > pi / 6 = radialVelocity * t
+ | tDir -sDir < (-pi) / 6 = (-radialVelocity) * t
+ | otherwise = 0.0 in
+ self { angle = angle self + adj }
+
+updateVelocity :: Double -> Tank -> Tank
+updateVelocity t self =
+ self { velocity = M.calcNewVelocity
+ (velocity self)
+ accelerationRate
+ (angle self)
+ maxVelocityMag
+ t
+ }
+
+instance Animation Tank where
+ image self _ = Rotate (radToDeg
+ (double2Float
+ (angle self)) * (-1) - 90)
+ pic
+ where pic = fromMaybe
+ (Scale 0.20 0.20
+ (Color white
+ (Text "Error! Missing image!")))
+ (getImage rt "tank.bmp")
+ rt = resourceTracker self
+
+instance M.Locatable Tank where
+ center = center
+
+instance M.Moving Tank where
+ velocity = velocity
+
+instance M.Colliding Tank where
+ collisionRadius _ = 20.0
+
+instance InternallyUpdating Tank where
+
+ preUpdate self t = (updateFiringInformation t
+ . updateIdealTargetLocation t
+ . updateVelocity t
+ . updateAngle t) self
+
+ postUpdate self t =
+ let center' = fromMaybe (center self) (idealTargetLocation self) in
+ self { center = center'
+ , idealTargetLocation = Nothing
+ }
+
+updateFiringInformation t self =
+ let sinceLastShot' = sinceLastShot self + t in
+ if sinceLastShot' >= 3
+ then self { sinceLastShot = 0.0
+ , launchTube = projectile : launchTube self
+ , queueShotSound = True
+ }
+ else self { sinceLastShot = sinceLastShot' }
+ where projectile = Projectile
+ (P.BulletSI.new
+ (wrapMap self)
+ pAngle
+ (center self)
+ (velocity self))
+ pAngle = case vision self of
+ Nothing -> angle self
+ Just arena ->
+ case lance arena of
+ Nothing -> angle self
+ Just l -> vectorDirection
+ (vectorRelation
+ (U.wrapMap arena)
+ (center self)
+ (M.center l))
+
+updateIdealTargetLocation :: Double -> Tank -> Tank
+updateIdealTargetLocation t self =
+ self { idealTargetLocation = Just (M.idealNewLocation (wrapMap self)
+ (center self)
+ (velocity self)
+ t)
+ }
+
+instance Launcher Tank where
+
+ deployProjectiles self = (launchTube self, self { launchTube = [] })
+
+instance Transient Tank where
+
+ expired' self = if integrity self > 0.0
+ then Nothing
+ else Just [aeffect]
+ where aeffect = AfterEffect (SimpleExplosion.new (resourceTracker self)
+ (wrapMap self)
+ (center self)
+ (velocity self))
+
+instance Damageable Tank where
+
+ inflictDamage self d = self { integrity = max 0.0 (integrity self - d) }
+
+instance Damaging Tank where
+
+ damageEnergy self = kamikazeDamage
diff --git a/Universe.hs b/Universe.hs
new file mode 100644
--- /dev/null
+++ b/Universe.hs
@@ -0,0 +1,49 @@
+module Universe where
+import Lance
+import Star
+import Data.WrapAround
+import SpaceJunk
+import Combat
+import AfterEffect
+import Unit ( SimpleUnit
+ , SmartUnit
+ )
+import ResourceTracker
+import Item
+
+data Arena = Arena { lance :: Maybe Lance
+ , lastFocus :: WrapPoint
+ , stars :: [Star]
+ , wrapMap :: WrapMap
+ , asteroids :: [SpaceJunk]
+ , lanceProjectiles :: [Projectile]
+ , afterFX :: [AfterEffect]
+ , simpleUnits :: [SimpleUnit]
+ , smartUnits :: [SmartUnit]
+ , unitProjectiles :: [Projectile]
+ , items :: [Item]
+ }
+
+data Universe = Universe { arena :: Arena
+ , level :: Int
+ , levels :: [Arena]
+ , lives :: Integer
+ , delayRemaining :: Double
+ , resourceTracker :: ResourceTracker
+ , skipLevel :: Bool
+ }
+
+blankArena width height =
+ let wmap = wrapmap width height in
+ Arena { lance = Nothing
+ , lastFocus = wrappoint wmap (0, 0)
+ , stars = []
+ , Universe.wrapMap = wmap
+ , asteroids = []
+ , lanceProjectiles = []
+ , afterFX = []
+ , simpleUnits = []
+ , smartUnits = []
+ , unitProjectiles = []
+ , items = []
+ }
diff --git a/Universe.hs-boot b/Universe.hs-boot
new file mode 100644
--- /dev/null
+++ b/Universe.hs-boot
@@ -0,0 +1,3 @@
+module Universe where
+
+data Arena
diff --git a/Updating.hs b/Updating.hs
new file mode 100644
--- /dev/null
+++ b/Updating.hs
@@ -0,0 +1,28 @@
+module Updating where
+
+import {-# SOURCE #-} AfterEffect ( AfterEffect )
+import {-# SOURCE #-} Universe ( Arena )
+
+-- Double is elapsed time in seconds
+class InternallyUpdating a where
+ preUpdate :: a -> Double -> a
+ postUpdate :: a -> Double -> a
+
+{-
+ Objects that exist temporarily or that may die after being wounded a certain
+ amount. Should be used for objects whose continued existence depends on some
+ internal variable, e.g., a lifeforce or countdown that may reach zero.
+-}
+class (InternallyUpdating a) => Transient a where
+
+ {- Whether or not the object should be removed from existence -}
+ expired' :: a -> Maybe [AfterEffect]
+
+class (InternallyUpdating a) => SimpleTransient a where
+
+ expired :: a -> Bool
+
+class Observant a where
+
+ updateVision :: a -> Arena -> a
+
diff --git a/edge.cabal b/edge.cabal
new file mode 100644
--- /dev/null
+++ b/edge.cabal
@@ -0,0 +1,115 @@
+-- edge.cabal auto-generated by cabal init. For additional options,
+-- see
+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
+-- The name of the package.
+Name: edge
+
+-- 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.8
+
+-- A short (one-line) description of the package.
+Synopsis: Top view space combat arcade game
+
+-- A longer description of the package.
+Description: The Edge has always been a rough patch of interstellar
+ space filled with innumerable bad guys of every nefarious
+ sort, and dangerous debris flying in every direction at
+ high speeds. But now it has grown out of control and is
+ threatening to overflow into colonial space. Central
+ command has decided to send in their newest super weapon,
+ the Mark II Lance fighter, piloted by their top ace pilot.
+ Good luck commander!
+
+-- URL for the project homepage or repository.
+Homepage: http://frigidcode.com
+
+-- The license under which the package is released.
+License: GPL-3
+
+-- The file containing the license text.
+License-file: COPYING
+
+-- The package author(s).
+Author: Christopher Howard
+
+-- An email address to which users can send suggestions, bug reports,
+-- and patches.
+Maintainer: christopher.howard@frigidcode.com
+
+-- A copyright notice.
+-- Copyright:
+
+Category: Game
+
+Build-type: Simple
+
+-- Extra files to be distributed with the package, such as examples or
+-- a README.
+Extra-source-files: DONATE
+
+-- Constraint on the version of Cabal needed to build this package.
+Cabal-version: >=1.10
+
+data-files: image/*.bmp
+ sound/*.wav
+
+Executable edge
+ -- .hs or .lhs file containing the Main module.
+ Main-is: edge.hs
+
+ Default-language: Haskell2010
+ -- Packages needed in order to build this package.
+ Build-depends: gloss >= 1.7.4.1 && < 1.8
+ , wraparound >= 0.0.1.1 && < 0.1
+ , base >= 4 && < 5
+ , containers >= 0.4.2.1 && < 0.5
+ , ALUT >= 2.2 && < 2.3
+ , random >= 1.0.1.1 && < 1.1
+
+ -- Modules not exported by this package.
+ Other-modules: Lance
+ , Asteroid
+ , BigAsteroid
+ , Trigonometry
+ , Animation
+ , Star
+ , Paths_edge
+ , ResourceTracker
+ , Resources
+ , Input
+ , Item
+ , Universe
+ , Updating
+ , Moving
+ , SpaceJunk
+ , Display
+ , Step
+ , AfterEffect
+ , AfterEffect.SimpleExplosion
+ , AfterEffect.MineExplosion
+ , Projectile.Blade
+ , Projectile.BulletMkI
+ , Projectile.BulletSI
+ , Projectile.BulletSII
+ , Projectile.BulletMI
+ , Projectile.BulletMII
+ , Projectile.Cannon
+ , Projectile.Mine
+ , Projectile.Nuke
+ , Projectile.Pellet
+ , Combat
+ , Unit
+ , Unit.Simple.Turret
+ , Unit.Smart.Tank
+ , Unit.Smart.ATank
+ , Unit.Smart.Death
+ , Unit.Smart.Ninja
+ , Unit.Smart.Saucer
+ , Unit.Smart.Sniper
+
+ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
+ -- Build-tools:
+
+ ghc-options: -O2 -threaded
diff --git a/edge.hs b/edge.hs
new file mode 100644
--- /dev/null
+++ b/edge.hs
@@ -0,0 +1,52 @@
+import Data.WrapAround
+import Graphics.Gloss.Interface.IO.Game
+import Lance
+import Resources
+import Input
+import Universe
+import Display
+import Step
+import Unit
+import Unit.Simple.Turret (Turret)
+import qualified Unit.Simple.Turret as Turret
+import ResourceTracker
+import Sound.ALUT
+import Data.Maybe
+import System.IO
+import Data.List ( intersperse )
+import Animation
+
+displayMode = InWindow "The Edge" (1024, 768) (0, 0)
+
+main = withProgNameAndArgs runALUT $ \progName args -> do
+ universe <- initUniverse
+ distanceModel $= audioDistanceModel
+-- listenerPosition $= (Vertex3 0 0 0)
+ errs <- get alErrors
+ if not (null errs)
+ then hPutStrLn
+ stderr
+ (concat
+ (intersperse "," [ d | ALError _ d <- errs ]))
+ else return ()
+ playIO displayMode black 20 universe displayUniverse handleInput stepUniverse
+
+initUniverse =
+ do rt <- initResources
+ rLevels <- initLevels rt
+ let sArena = head rLevels
+ let wmap = Universe.wrapMap sArena
+ return Universe { arena = sArena
+
+ { lance = Just (Lance.new rt wmap
+ (wrappoint wmap (0, 0)))
+ }
+
+ , level = 0
+ , Universe.levels = rLevels
+ , lives = 3
+ , delayRemaining = 2.0
+ , resourceTracker = rt
+ , skipLevel = False
+ }
+
diff --git a/image/asteroid.bmp b/image/asteroid.bmp
new file mode 100644
Binary files /dev/null and b/image/asteroid.bmp differ
diff --git a/image/asteroidbig.bmp b/image/asteroidbig.bmp
new file mode 100644
Binary files /dev/null and b/image/asteroidbig.bmp differ
diff --git a/image/atank.bmp b/image/atank.bmp
new file mode 100644
Binary files /dev/null and b/image/atank.bmp differ
diff --git a/image/blade.bmp b/image/blade.bmp
new file mode 100644
Binary files /dev/null and b/image/blade.bmp differ
diff --git a/image/death.bmp b/image/death.bmp
new file mode 100644
Binary files /dev/null and b/image/death.bmp differ
diff --git a/image/explosion-00.bmp b/image/explosion-00.bmp
new file mode 100644
Binary files /dev/null and b/image/explosion-00.bmp differ
diff --git a/image/explosion-01.bmp b/image/explosion-01.bmp
new file mode 100644
Binary files /dev/null and b/image/explosion-01.bmp differ
diff --git a/image/explosion-02.bmp b/image/explosion-02.bmp
new file mode 100644
Binary files /dev/null and b/image/explosion-02.bmp differ
diff --git a/image/explosion-03.bmp b/image/explosion-03.bmp
new file mode 100644
Binary files /dev/null and b/image/explosion-03.bmp differ
diff --git a/image/explosion-04.bmp b/image/explosion-04.bmp
new file mode 100644
Binary files /dev/null and b/image/explosion-04.bmp differ
diff --git a/image/explosion-05.bmp b/image/explosion-05.bmp
new file mode 100644
Binary files /dev/null and b/image/explosion-05.bmp differ
diff --git a/image/explosion-06.bmp b/image/explosion-06.bmp
new file mode 100644
Binary files /dev/null and b/image/explosion-06.bmp differ
diff --git a/image/item-cannon.bmp b/image/item-cannon.bmp
new file mode 100644
Binary files /dev/null and b/image/item-cannon.bmp differ
diff --git a/image/item-default.bmp b/image/item-default.bmp
new file mode 100644
Binary files /dev/null and b/image/item-default.bmp differ
diff --git a/image/item-fourway.bmp b/image/item-fourway.bmp
new file mode 100644
Binary files /dev/null and b/image/item-fourway.bmp differ
diff --git a/image/item-health.bmp b/image/item-health.bmp
new file mode 100644
Binary files /dev/null and b/image/item-health.bmp differ
diff --git a/image/item-nuke.bmp b/image/item-nuke.bmp
new file mode 100644
Binary files /dev/null and b/image/item-nuke.bmp differ
diff --git a/image/item-rapidfire.bmp b/image/item-rapidfire.bmp
new file mode 100644
Binary files /dev/null and b/image/item-rapidfire.bmp differ
diff --git a/image/item-spread.bmp b/image/item-spread.bmp
new file mode 100644
Binary files /dev/null and b/image/item-spread.bmp differ
diff --git a/image/lance-thrusting.bmp b/image/lance-thrusting.bmp
new file mode 100644
Binary files /dev/null and b/image/lance-thrusting.bmp differ
diff --git a/image/lance.bmp b/image/lance.bmp
new file mode 100644
Binary files /dev/null and b/image/lance.bmp differ
diff --git a/image/mine-explosion.bmp b/image/mine-explosion.bmp
new file mode 100644
Binary files /dev/null and b/image/mine-explosion.bmp differ
diff --git a/image/mine-lit.bmp b/image/mine-lit.bmp
new file mode 100644
Binary files /dev/null and b/image/mine-lit.bmp differ
diff --git a/image/mine.bmp b/image/mine.bmp
new file mode 100644
Binary files /dev/null and b/image/mine.bmp differ
diff --git a/image/ninja.bmp b/image/ninja.bmp
new file mode 100644
Binary files /dev/null and b/image/ninja.bmp differ
diff --git a/image/nuke-0.bmp b/image/nuke-0.bmp
new file mode 100644
Binary files /dev/null and b/image/nuke-0.bmp differ
diff --git a/image/nuke-1.bmp b/image/nuke-1.bmp
new file mode 100644
Binary files /dev/null and b/image/nuke-1.bmp differ
diff --git a/image/nuke-2.bmp b/image/nuke-2.bmp
new file mode 100644
Binary files /dev/null and b/image/nuke-2.bmp differ
diff --git a/image/nuke-3.bmp b/image/nuke-3.bmp
new file mode 100644
Binary files /dev/null and b/image/nuke-3.bmp differ
diff --git a/image/saucer.bmp b/image/saucer.bmp
new file mode 100644
Binary files /dev/null and b/image/saucer.bmp differ
diff --git a/image/sniper.bmp b/image/sniper.bmp
new file mode 100644
Binary files /dev/null and b/image/sniper.bmp differ
diff --git a/image/tank.bmp b/image/tank.bmp
new file mode 100644
Binary files /dev/null and b/image/tank.bmp differ
diff --git a/image/turret.bmp b/image/turret.bmp
new file mode 100644
Binary files /dev/null and b/image/turret.bmp differ
diff --git a/sound/energy-shot-02.wav b/sound/energy-shot-02.wav
new file mode 100644
Binary files /dev/null and b/sound/energy-shot-02.wav differ
diff --git a/sound/explosion.wav b/sound/explosion.wav
new file mode 100644
Binary files /dev/null and b/sound/explosion.wav differ
diff --git a/sound/simple-energy-shot.wav b/sound/simple-energy-shot.wav
new file mode 100644
Binary files /dev/null and b/sound/simple-energy-shot.wav differ
diff --git a/sound/test.wav b/sound/test.wav
new file mode 100644
Binary files /dev/null and b/sound/test.wav differ