packages feed

frag (empty) → 1.1

raw patch · 113 files changed

+11181/−0 lines, 113 filesdep +GLUTdep +OpenGLdep +arraysetup-changedbinary-added

Dependencies added: GLUT, OpenGL, array, base, haskell98

Files

+ LICENSE view
@@ -0,0 +1,340 @@+		    GNU GENERAL PUBLIC LICENSE+		       Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++			    Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users.  This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.)  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+this service 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 make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have.  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.++  We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software.  If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++  Finally, any free program is threatened constantly by software+patents.  We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++  The precise terms and conditions for copying, distribution and+modification follow.++		    GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++  1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++  2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) You must cause the modified files to carry prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or in part contains or is derived from the Program or any+    part thereof, to be licensed as a whole at no charge to all third+    parties under the terms of this License.++    c) If the modified program normally reads commands interactively+    when run, you must cause it, when started running for such+    interactive use in the most ordinary way, to print or display an+    announcement including an appropriate copyright notice and a+    notice that there is no warranty (or else, saying that you provide+    a warranty) and that users may redistribute the program under+    these conditions, and telling the user how to view a copy of this+    License.  (Exception: if the Program itself is interactive but+    does not normally print such an announcement, your work based on+    the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) Accompany it with the complete corresponding machine-readable+    source code, which must be distributed under the terms of Sections+    1 and 2 above on a medium customarily used for software interchange; or,++    b) Accompany it with a written offer, valid for at least three+    years, to give any third party, for a charge no more than your+    cost of physically performing source distribution, a complete+    machine-readable copy of the corresponding source code, to be+    distributed under the terms of Sections 1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the information you received as to the offer+    to distribute corresponding source code.  (This alternative is+    allowed only for noncommercial distribution and only if you+    received the program in object code or executable form with such+    an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable.  However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++  4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++  5. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++  6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++  7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+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+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++  9. The Free Software Foundation may publish revised and/or new versions+of the 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 a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation.  If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++  10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission.  For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this.  Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++			    NO WARRANTY++  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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.++  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE 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.++		     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+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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 2 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, write to the Free Software+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year name of author+    Gnomovision 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, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This 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 Library General+Public License instead of this License.
+ README view
@@ -0,0 +1,27 @@+Author: Mun Hon Cheong (mhch295@cse.unsw.edu.au)++Program: Frag - a FPS i put together using Haskell and with Yampa++Year: 2005, 2007-8++License: GPL++Usage: $ frag leveleg++'leveleg' can be an arbitrary Quake III Arena level; a default level is provided in this package, and is installed in 'share/frag-1.1', wherever that is. For example, if it's installed into ~/bin, and frag occupies ~/bin/frag, a successful invocation might be 'frag ../share/frag-1.1/leveleg'.++Requirements: A graphics card with support for multitexturing and vertex arrays++Building:+    ghc --make -O2 -fglasgow-exts main.hs+or+    runhaskell Setup configure --user --prefix=/home/foo+    runhaskell Setup build+    runhaskell Setup install++Controls: mouse moves around the view, 'w'\'a'\'s'\'d' to move and strafe, 'e to jump, 'z' and 'x' to lock and unlock the mouse, left click to fire.++cheers,+Mun++
+ README-leveleg view
@@ -0,0 +1,26 @@+
+================================================================
+			   Monastery At Night
+		   Level for Quake III Arena
+================================================================
+
+<http://openarena.ws/svn/source/assets/maps/czest1dm.txt>
+
+---
+
+czest1dm.bsp - "Monastery at night" - An OpenArena deathmatch map
+Copyright (C) 2007, 2008 Cestmir "Czestmyr" Houska
+
+This map 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 2 of the License, or
+(at your option) any later version.
+
+This map 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, write to the Free Software Foundation, Inc.,
+51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ frag.cabal view
@@ -0,0 +1,65 @@+Name:                frag+Version:             1.1+License:             GPL+License-file:        LICENSE+Synopsis:            3-D First Person Shooter (FPS)+Description:         A fast and basic reimplementation of the Quake III Arena engine+                     in Haskell; supports many Quake III Arena maps.+Category:            Game+Author:              Mun Hon Cheong+Maintainer:          dons@galois.com+Homepage:            http://haskell.org/haskellwiki/Frag++Build-Depends:       base, haskell98, GLUT, OpenGL>=2.0, array+Build-Type:          Simple+Cabal-Version:       >= 1.2+Tested-with:         GHC==6.8.2+data-files:          README, README-leveleg+                     -- Graphics files+                     leveleg.bsp, leveleg.cfg, leveleg.med+                     tga/models/players/klesk/lower_default.skin, tga/models/players/klesk/lower.md3+                     tga/models/players/klesk/head_default.skin, tga/models/players/klesk/l_red.tga+                     tga/models/players/klesk/h_red.tga, tga/models/players/klesk/animation.cfg+                     tga/models/players/klesk/head.md3, tga/models/players/klesk/u_red.tga+                     tga/models/players/klesk/upper_default.skin, tga/models/players/klesk/upper.md3+                     tga/models/weapons/railgun.shader, tga/models/weapons/railgun.md3+                     tga/font.tga, tga/7.tga, tga/3.tga, tga/4.tga, tga/5.tga, tga/2.tga+                     tga/crosshaira.tga, tga/0.tga, tga/hyphen.tga, tga/9.tga, tga/1.tga, tga/6.tga+                     tga/tga/models/weapons/railgun4.tga, tga/tga/models/weapons/railgun2.tga+                     tga/tga/models/weapons/railgun.tga, tga/tga/models/weapons/railgun3.tga+                     tga/8.tga, tga/textures/gothic_floor/q1metal7_99.tga+                     tga/textures/gothic_floor/largerblock3b3.tga, tga/textures/gothic_floor/largerblock3b3dim.tga+                     tga/textures/e7/e7brickfloor01.tga, tga/textures/e7/e7bmtrim.tga+                     tga/textures/e7/e7bricks01.tga, tga/textures/e7/e7sbrickfloor.tga+                     tga/textures/e7/e7panelwood.tga, tga/textures/e7/e7swindow.tga+                     tga/textures/e7/e7panelwood2.tga, tga/textures/organics/dirt2.tga+                     tga/textures/common/trigger.tga, tga/textures/common/clip.tga+                     tga/textures/skies/nitesky.tga, tga/textures/gothic_trim/border7.tga+                     tga/textures/gothic_trim/pitted_rust3.tga, tga/textures/gothic_trim/km_arena1tower4.tga+                     tga/textures/gothic_trim/wood2.tga, tga/textures/gothic_trim/metalsupport4i_bit.tga+                     tga/textures/gothic_light/ironcrosslt2_10000.tga, tga/textures/stone/pjrock6.tga+                     tga/textures/base_support/flat1_1.tga, tga/textures/skin/pjwal2k.tga+                     tga/textures/gothic_wall/slateroofc.tga, tga/textures/gothic_wall/proto_brik.tga+                     tga/textures/gothic_wall/oct20c.tga, tga/textures/evil8_floor/e8cretefloor01b.tga+                     tga/textures/gothic_block/killblock.tga, tga/textures/gothic_block/killblock_j2.tga+                     tga/textures/gothic_block/blocks15_blue.tga, tga/textures/gothic_block/blocks11b.tga+                     tga/textures/gothic_block/blocks18d.tga, tga/textures/gothic_block/blocks18b.tga++Library+        Hs-source-dirs:      src+        Build-Depends:       base, haskell98, GLUT, OpenGL>=2.0, array+        exposed-modules:     AFRPAffineSpace, AFRPDiagnostics, AFRPEvent, AFRPForceable, AFRPGeometry,+                             AFRP, AFRPInternals, AFRPMiscellany, AFRPPoint2, AFRPPoint3, AFRPTask,+                             AFRPUtilities, AFRPVector2, AFRPVector3, AFRPVectorSpace, BitSet, BSP,+                             Camera, Collision, Command, Curves, Diagnostics, Frustum, Game, HGL,+                             IdentityList, MapCfg, Matrix, MD3, ObjectBehavior, Object, Parser,+                             PhysicalDimensions, Quaternion, Raybox, ReadImage, Render, RenderObject,+                             TextureFonts, Textures, TGA, Visibility++Executable frag+           Main-is:             Main.hs+           Hs-source-dirs:      src++           Ghc-options:         -O2 -funbox-strict-fields -optl-Wl,-s -fno-glasgow-exts+           Extensions:          BangPatterns, FunctionalDependencies, FlexibleInstances,+                                MultiParamTypeClasses, TypeOperators, Rank2Types
+ leveleg.bsp view

file too large to diff

+ leveleg.cfg view
@@ -0,0 +1,15 @@+ConsAICube {startPosition =(1123,50,38),size =(20,45,20),wayPoints =[(1811,50,52),(1585,50,-158),(738,50,-222)],modlName = "klesk"}
+ConsAICube {startPosition =(51,-41,-921),size =(20,45,20),wayPoints =[(-467,59,-150),(-761,59,-179),(-903,59,-193)],modlName = "klesk"}
+ConsAICube {startPosition =(-1560,-62,-565),size =(20,45,20),wayPoints =[(-1561,-62,-566),(-1787,-94,-572),(-1946,-62,-576)],modlName = "klesk"}
+ConsAICube {startPosition =(-1571,-9,-1605),size =(20,45,20),wayPoints =[(-1416,-6,-1584),(-1257,-7,-1582)],modlName = "klesk"}
+ConsAICube {startPosition =(-1246,-5,-1250),size =(20,45,20),wayPoints =[(-1306,-3,-1252),(-1361,-7,-1231),(-1429,-3,-1248),(-1503,-5,-1274)],modlName = "klesk"}
+ConsAICube {startPosition =(-1719,-102,-2050),size =(20,45,20),wayPoints =[(-1706,-100,-2070),(-1705,-101,-2147),(-1712,-101,-2256)],modlName = "klesk"}
+ConsAICube {startPosition =(-1096,-102,-2267),size =(20,45,20),wayPoints =[(-1101,-100,-2235),(-1097,-102,-2209),(-1095,-102,-2147)],modlName = "klesk"}
+ConsAICube {startPosition =(-1144,-102,-2163),size =(20,45,20),wayPoints =[(-1286,-100,-2230),(-1426,-100,-2280)],modlName = "klesk"}
+ConsAICube {startPosition =(-1717,98,-726),size =(20,45,20),wayPoints =[(-1788,96,-706),(-1866,97,-733),(-1889,99,-728)],modlName = "klesk"}
+ConsAICube {startPosition =(-502,26,-612),size =(20,45,20),wayPoints =[(-502,60,-857),(-510,57,-901)],modlName = "klesk"}
+ConsAICube {startPosition =(-511,97,483),size =(20,45,20),wayPoints =[(-513,163,607),(-527,282,909)],modlName = "klesk"}
+ConsAICube {startPosition =(-531,282,1551),size =(20,45,20),wayPoints =[(-519,278,1384),(-513,284,1286)],modlName = "klesk"}
+ConsAICube {startPosition =(-2065,-6,-1529),size =(20,45,20),wayPoints =[(-2053,-5,-1334),(-2049,-4,-1247),(-2045,-3,-1158)],modlName = "klesk"}
+ConsAICube {startPosition =(-1404,81,314),size =(20,45,20),wayPoints =[(-1424,81,201),(-1423,83,122),(-1419,107,27)],modlName = "klesk"}
+ConsCamera (Camera {cpos = (60,50,-50), viewPos = (70,511,50) ,upVec = (0,1,0)})
+ leveleg.med view
@@ -0,0 +1,2 @@+MMap "leveleg.bsp"
+MPlayerModel "klesk" "railgun"
+ src/AFRP.hs view
@@ -0,0 +1,1546 @@+{-# LANGUAGE TypeOperators, Rank2Types #-}++{- $Id: AFRP.hs,v 1.37 2004/03/22 19:46:40 antony Exp $+******************************************************************************+*                                                       A F R P                                                   *+*                                                                                                                         *+*          Module:          AFRP                                                                                  *+*          Purpose:         The AFRP core.                                              *+*       Authors:        Henrik Nilsson and Antony Courtney              *+*                                                                                                                         *+*                   Copyright (c) Yale University, 2003                                           *+*                                                                                                                         *+******************************************************************************+-}++-- ToDo:+-- * Check embedSynch for space leaks. It might be a good idea to force+--      "dropped frames".+-- * The internal "streamToSignal" is interesting, and a version somehow+--      accepting a time stamped stream/assuming equidistant samples, possibly+--      with an interpolation function, might be even more interesting. Perhaps+--      consider a version that applies "cycle" to the supplied list? Note that+--      there is a relation to "embedSynch" since a partial application of+--      "embedSynch" to "identity" would yield something similar. Or it is+--      in some sense the inverse of "embed".+-- * It seems the use of VectorSpace-based integrals causes more ambiguity+--      problems than before. Investigate (comments in AFRPTest.hs).+-- * Maybe "now", "after", "repeatedly" should return ().+--      There could be a bunch of utilities "nowTag", "afterTag", "repeatedlyTag",+--      and "edgeTag". Decide based on API consistency. E.g. edge already+--      returns ().+-- * Reconsider the semantics of "edgeBy". Does not disallow an edge+--      condition that persists between consecutive samples. OTOH, consider+--      a signal that alternates between two discrete values (True, False, say).+--      Surely we could then see edges on every sample. It's not really for us+--      to say whether the edge detecting function does a good job or not?+-- * We should probably introduce a type synonym Frequency here.+--      It might be most natural to give some parameters in terms of frequency+--      (like for "repeatedly" and "occasionally"). On the other hand, there+--      is "after", and it would be good if "after" and "repeatedly" are+--      mutually consistent, if "repeatedly" and "occasionally" are consistent,+--      and if the user knows that "Time" is the only dimension he or she needs+--      to worry about.+-- * Here's an argument for why "now", "after", etc. should return "()".+--      The event value has to be a static entity anyway in these cases. So,+--      if we need them to something DYNAMIC, then the extra argument is useless.+--      Or if we don't care. If it is decided to change the interface in that+--      way, I guess we could also change Time to Frequency where that makes+--      sense. On the other hand, what's the point of "now" always returning+--      "()"? Would one not usually want to say what to return? If yes, then+--      There is something to be said for making "after" consistent with "now".+--      After all, we should have "now = after 0".+-- * Maybe "reactimate" should be parametrized on the monad type?+-- * Revisit the "reactimate" interfaces along with embedding.+-- * Revisit integration and differentiation. Valery suggests:+--+--        integral :: VectorSpace a s => SF a a+--        integral = (\ a _ dt v -> v ^+^ realToFrac dt *^ a) `iterFrom`+--                         zeroVector+--+--        -- non-delayed integration (using the function's value at the current+--        -- time)+--        ndIntegral :: VectorSpace a s => SF a a+--        ndIntegral = (\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`+--                              zeroVector+--+--        derivative :: VectorSpace a s => SF a a+--        derivative = (\ a a' dt _ -> (a' ^-^ a) ^/ realToFrac dt) `iterFrom`+--                              zeroVector+--+--        iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b+--        f `iterFrom` b = SF (iterAux b) where+--               iterAux b a = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)+--      See also the original e-mail discussion.++module AFRP (+-- Re-exported module, classes, and types+    module Control.Arrow,+    module AFRPVectorSpace,+    RandomGen(..),+    Random(..),++-- Reverse function composition and arrow plumbing aids+    ( # ),              -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9+    dup,                -- :: a -> (a,a)+    swap,       -- :: (a,b) -> (b,a)++-- main types+    Time, -- [s] Both for time w.r.t. some reference and intervals.+    SF,         -- Signal Function.+    Event(..), -- Events; conceptually similar to Maybe (but abstract).++-- main instances+    -- SF is an instance of Arrow and ArrowLoop. Method instances:+    -- arr      :: (a -> b) -> SF a b+    -- (>>>)    :: SF a b -> SF b c -> SF a c+    -- (<<<)    :: SF b c -> SF a b -> SF a c+    -- first    :: SF a b -> SF (a,c) (b,c)+    -- second   :: SF a b -> SF (c,a) (c,b)+    -- (***)    :: SF a b -> SF a' b' -> SF (a,a') (b,b')+    -- (&&&)    :: SF a b -> SF a b' -> SF a (b,b')+    -- returnA :: SF a a+    -- loop     :: SF (a,c) (b,c) -> SF a b++    -- Event is an instance of Functor, Eq, and Ord. Some method instances:+    -- fmap     :: (a -> b) -> Event a -> Event b+    -- (==)      :: Event a -> Event a -> Bool+    -- (<=)     :: Event a -> Event a -> Bool++-- Basic signal functions+    identity,           -- :: SF a a+    constant,           -- :: b -> SF a b+    localTime,  -- :: SF a Time+    time,                   -- :: SF a Time,    Other name for localTime.++-- Initialization+    (-->),              -- :: b -> SF a b -> SF a b,            infixr 0+    (>--),              -- :: a -> SF a b -> SF a b,            infixr 0+    (-=>),                  -- :: (b -> b) -> SF a b -> SF a b      infixr 0+    (>=-),                  -- :: (a -> a) -> SF a b -> SF a b      infixr 0+    initially,  -- :: a -> SF a a++-- Basic event sources+    never,              -- :: SF a (Event b)+    now,                -- :: b -> SF a (Event b)+    after,              -- :: Time -> b -> SF a (Event b)+    repeatedly,         -- :: Time -> b -> SF a (Event b)+    afterEach,  -- :: [(Time,b)] -> SF a (Event b)+    edge,       -- :: SF Bool (Event ())+    iEdge,              -- :: Bool -> SF Bool (Event ())+    edgeTag,            -- :: a -> SF Bool (Event a)+    edgeJust,           -- :: SF (Maybe a) (Event a)+    edgeBy,             -- :: (a -> a -> Maybe b) -> a -> SF a (Event b)++-- Stateful event suppression+    notYet,             -- :: SF (Event a) (Event a)+    once,       -- :: SF (Event a) (Event a)+    takeEvents,         -- :: Int -> SF (Event a) (Event a)+    dropEvents,         -- :: Int -> SF (Event a) (Event a)++-- Basic switchers+    switch,  dSwitch,   -- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+    rSwitch, drSwitch,  -- :: SF a b -> SF (a,Event (SF a b)) b+    kSwitch, dkSwitch,  -- :: SF a b+                        --       -> SF (a,b) (Event c)+                        --       -> (SF a b -> c -> SF a b)+                        --       -> SF a b++-- Parallel composition and switching over collections with broadcasting+    parB,       -- :: Functor col => col (SF a b) -> SF a (col b)+    pSwitchB,dpSwitchB, -- :: Functor col =>+                        --              col (SF a b)+                        --        -> SF (a, col b) (Event c)+                        --        -> (col (SF a b) -> c -> SF a (col b))+                        --        -> SF a (col b)+    rpSwitchB,drpSwitchB,-- :: Functor col =>+                        --              col (SF a b)+                        --        -> SF (a, Event (col (SF a b)->col (SF a b)))+                        --                 (col b)++-- Parallel composition and switching over collections with general routing+    par,                -- Functor col =>+                        --        (forall sf . (a -> col sf -> col (b, sf)))+                        --        -> col (SF b c)+                        --        -> SF a (col c)+    pSwitch, dpSwitch,  -- pSwitch :: Functor col =>+                        --        (forall sf . (a -> col sf -> col (b, sf)))+                        --        -> col (SF b c)+                        --        -> SF (a, col c) (Event d)+                        --        -> (col (SF b c) -> d -> SF a (col c))+                        --        -> SF a (col c)+    rpSwitch,drpSwitch, -- Functor col =>+                        --       (forall sf . (a -> col sf -> col (b, sf)))+                        --       -> col (SF b c)+                        --       -> SF (a, Event (col (SF b c) -> col (SF b c)))+                        --          (col c)++-- Wave-form generation+    hold,       -- :: a -> SF (Event a) a+    trackAndHold,       -- :: a -> SF (Maybe a) a++-- Accumulators+    accum,              -- :: a -> SF (Event (a -> a)) (Event a)+    accumBy,            -- :: (b -> a -> b) -> b -> SF (Event a) (Event b)+    accumFilter,        -- :: (c -> a -> (c, Maybe b)) -> c+                        --       -> SF (Event a) (Event b)++-- Delays+    pre,                -- :: SF a a+    iPre,       -- :: a -> SF a a++-- Integration and differentiation+    integral,           -- :: VectorSpace a s => SF a a+    derivative,         -- :: VectorSpace a s => SF a a         -- Crude!+    imIntegral,         -- :: VectorSpace a s => a -> SF a a++-- Loops with guaranteed well-defined feedback+    loopPre,            -- :: c -> SF (a,c) (b,c) -> SF a b+    loopIntegral,       -- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b++-- Pointwise functions on events+    noEvent,            -- :: Event a+    noEventFst,         -- :: (Event a, b) -> (Event c, b)+    noEventSnd,         -- :: (a, Event b) -> (a, Event c)+    event,              -- :: a -> (b -> a) -> Event b -> a+    fromEvent,  -- :: Event a -> a+    isEvent,            -- :: Event a -> Bool+    isNoEvent,  -- :: Event a -> Bool+    tag,                -- :: Event a -> b -> Event b,          infixl 8+    attach,             -- :: Event a -> b -> Event (a, b),     infixl 8+    lMerge,             -- :: Event a -> Event a -> Event a,    infixl 6+    rMerge,             -- :: Event a -> Event a -> Event a,    infixl 6+    merge,              -- :: Event a -> Event a -> Event a,    infixl 6+    mergeBy,            -- :: (a -> a -> a) -> Event a -> Event a -> Event a+    mapMerge,               -- :: (a -> c) -> (b -> c) -> (a -> b -> c)+                                    --  -> Event a -> Event b -> Event c+    mergeEvents,            -- :: [Event a] -> Event a+    catEvents,  -- :: [Event a] -> Event [a]+    joinE,              -- :: Event a -> Event b -> Event (a,b),infixl 7+    splitE,             -- :: Event (a,b) -> (Event a, Event b)+    filterE,            -- :: (a -> Bool) -> Event a -> Event a+    mapFilterE,         -- :: (a -> Maybe b) -> Event a -> Event b+    gate,       -- :: Event a -> Bool -> Event a,       infixl 8++-- Noise (random signal) sources and stochastic event sources+    noise,              -- :: noise :: (RandomGen g, Random b) =>+                        --              g -> SF a b+    noiseR,             -- :: noise :: (RandomGen g, Random b) =>+                        --              (b,b) -> g -> SF a b+    occasionally,       -- :: RandomGen g => g -> Time -> b -> SF a (Event b)++-- Reactimation+    reactimate,         -- :: IO a+                                --       -> (Bool -> IO (DTime, Maybe a))+                                --       -> (Bool -> b -> IO Bool)+                                --       -> SF a b+                                --       -> IO ()+    ReactHandle,+    reactInit,      --  IO a -- init+                                    --  -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate+                                    --  -> SF a b+                                    --  -> IO (ReactHandle a b)+-- process a single input sample:+    react,                  --  ReactHandle a b+                                    --  -> (DTime,Maybe a)+                                    --  -> IO Bool++-- Embedding (tentative: will be revisited)+    DTime,              -- [s] Sampling interval, always > 0.+    embed,              -- :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]+    embedSynch,         -- :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b+    deltaEncode,        -- :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])+    deltaEncodeBy       -- :: (a -> a -> Bool) -> DTime -> [a]+                        --       -> (a, [(DTime, Maybe a)])+) where++import Monad (unless)+import Random (RandomGen(..), Random(), randoms, randomRs)+import Data.IORef+import Control.Arrow+import AFRPDiagnostics+import AFRPMiscellany (( # ), dup, swap)+import AFRPEvent+import AFRPVectorSpace+++infixr 0 -->, >--, -=>, >=-++------------------------------------------------------------------------------+-- Basic type definitions with associated utilities+------------------------------------------------------------------------------++-- The time type is really a bit bogus, since, as time passes, the minimal+-- interval between two consecutive floating-point-represented time points+-- increases. A better approach is probably to pick a reasonable resolution+-- and represent time and time intervals by Integer (giving the number of+-- "ticks").++-- Time is used both for time intervals (duration), and time w.r.t. some+-- agreed reference point in time. Conceptually, Time = R, i.e. time can be 0+-- or even negative.+type Time = Double      -- [s]+++-- DTime is the time type for lengths of sample intervals. Conceptually,+-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the+-- same representation.++type DTime = Double -- [s]+++-- Representation of signal function in initial state.+-- (Naming: "TF" stands for Transition Function.)++data SF a b = SF {sfTF :: a -> Transition a b}+++-- Representation of signal function in running state.+-- It would have been nice to have a constructor SFId representing (arr id):+--+--        SFId {sfTF' :: DTime -> a -> Transition a b}+--+-- But it seems as if we need dependent types as soon as we try to exploit+-- that constructor (note that the type above is too general!), and a+-- work-around based on keeping around an extra function as a "proof" that we+-- can do the required coercions, yields code which is no more efficient+-- than using SFArr in the first place.+-- (Naming: "TIVar" stands for "time-input-variable".)++data SF' a b+    = SFConst {sfTF' :: DTime -> a -> Transition a b, sfCVal :: b}+    | SFArr   {sfTF' :: DTime -> a -> Transition a b, sfAFun :: a -> b}+    | SFTIVar {sfTF' :: DTime -> a -> Transition a b}+++-- A transition is a pair of the next state (in the form of a signal+-- function) and the output at the present time step.++type Transition a b = (SF' a b, b)+++-- "Smart" constructors. The corresponding "raw" constructors should not+-- be used directly for construction.++sfConst :: b -> SF' a b+sfConst b = sf+    where+        sf = SFConst {sfTF' = \_ _ -> (sf, b), sfCVal = b}+++sfNever :: SF' a (Event b)+sfNever = sfConst NoEvent+++sfId :: SF' a a+sfId = sf+    where+        sf = SFArr {sfTF' = \_ a -> (sf, a), sfAFun = id}+++sfArr :: (a -> b) -> SF' a b+sfArr f = sf+    where+        sf = SFArr {sfTF' = \_ a -> (sf, f a), sfAFun = f}+++-- Freezes a "running" signal function, i.e., turns it into a continuation in+-- the form of a plain signal function.+freeze :: SF' a b -> DTime -> SF a b+freeze sf dt = SF {sfTF = (sfTF' sf) dt}+++freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)+freezeCol sfs dt = fmap (flip freeze dt) sfs+++------------------------------------------------------------------------------+-- Arrow instance and implementation+------------------------------------------------------------------------------++instance Arrow SF where+    arr  = arrPrim+    (>>>)  = compPrim+    first  = firstPrim+    second = secondPrim+    (***)  = parSplitPrim+    (&&&)  = parFanOutPrim+++-- Lifting.+arrPrim :: (a -> b) -> SF a b+arrPrim f = SF {sfTF = \a -> (sfArr f, f a)}+++-- Composition.+-- The definition exploits the following identities:+--        sf       >>> constant c = constant c+--        constant c >>> arr f     = constant (f c)+--        arr f    >>> arr g       = arr (g . f)+-- (It would have been nice to explit e.g. identity >>> sf = sf, but it would+-- seem that we need dependent types for that.)+compPrim :: SF a b -> SF b c -> SF a c+{-# INLINE compPrim #-}+compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+    where+        tf0 a0 = (cpAux sf1 sf2, c0)+            where+                (sf1, b0) = tf10 a0+                (sf2, c0) = tf20 b0++        cpAux _           sf2@(SFConst {}) = sfConst (sfCVal sf2)+        cpAux sf1@(SFConst {}) sf2                      = cpAuxC1 (sfCVal sf1) sf2+        cpAux sf1@(SFArr {})   sf2                      = cpAuxA1 (sfAFun sf1) sf2+        cpAux sf1                  sf2@(SFArr {})       = cpAuxA2 sf1 (sfAFun sf2)+        cpAux sf1                  sf2                  = SFTIVar {sfTF' = tf}+            where+                   tf dt a = (cpAux sf1' sf2', c)+                    where+                           (sf1', b) = (sfTF' sf1) dt a+                           (sf2', c) = (sfTF' sf2) dt b++        cpAuxC1 _ (SFConst {sfCVal = c})        = sfConst c+        cpAuxC1 b (SFArr   {sfAFun = f2})       = sfConst (f2 b)+        cpAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}+            where+                tf dt _ = (cpAuxC1 b sf2', c)+                    where+                        (sf2', c) = tf2 dt b++        cpAuxA1 _  (SFConst {sfCVal = c})        = sfConst c+        cpAuxA1 f1 (SFArr       {sfAFun = f2})  = sfArr (f2 . f1)+        cpAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}+            where+                tf dt a = (cpAuxA1 f1 sf2', c)+                    where+                        (sf2', c) = tf2 dt (f1 a)++        cpAuxA2 (SFConst {sfCVal = b})   f2 = sfConst (f2 b)+        cpAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (f2 . f1)+        cpAuxA2 (SFTIVar {sfTF' = tf1}) f2 = SFTIVar {sfTF' = tf}+            where+                tf dt a = (cpAuxA2 sf1' f2, f2 b)+                    where+                        (sf1', b) = tf1 dt a+++-- Widening.+-- The definition exploits the following identities:+--        first (constant b) = arr (\(_, c) -> (b, c))+--        (first (arr f))        = arr (\(a, c) -> (f a, c))+-- (It would have been nice to exploit first identity = identity, but it would+-- seem that we need dependent types for that.)+firstPrim :: SF a b -> SF (a,c) (b,c)+firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+    where+           tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))+            where+                (sf1, b0) = tf10 a0+                fpAux (SFConst {sfCVal = b}) = sfArr (\(~(_, c)) -> (b, c))+                fpAux (SFArr    {sfAFun = f}) = sfArr (\(~(a, c)) -> (f a, c))+                fpAux sf11                          = SFTIVar {sfTF' = tf}+                 where+                   tf dt ~(a, c) = (fpAux sf1', (b, c))+                    where+                        (sf1', b) = (sfTF' sf11) dt a+++-- Mirror image of first.+secondPrim :: SF a b -> SF (c,a) (c,b)+secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+    where+           tf0 ~(c0, a0) = (spAux sf1, (c0, b0))+            where+                (sf1, b0) = tf10 a0+                spAux (SFConst {sfCVal = b}) = sfArr (\(~(c, _)) -> (c, b))+                spAux (SFArr    {sfAFun = f}) = sfArr (\(~(c, a)) -> (c, f a))+                spAux sf11                          = SFTIVar {sfTF' = tf}+                 where+                   tf dt ~(c, a) = (spAux sf1', (c, b))+                    where+                        (sf1', b) = (sfTF' sf11) dt a++-- Parallel composition.+-- The definition exploits the following identities (which hold for SF):+--        constant b *** constant d = constant (b, d)+--        constant b *** arr f2    = arr (\(_, c) -> (b, f2 c)+--        arr f1           *** constant d = arr (\(a, _) -> (f1 a, d)+--        arr f1           *** arr f2      = arr (\(a, b) -> (f1 a, f2 b)+parSplitPrim :: SF a b -> SF c d  -> SF (a,c) (b,d)+parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+    where+        tf0 ~(a0, c0) = (psAux sf1 sf2, (b0, d0))+            where+                (sf1, b0) = tf10 a0+                (sf2, d0) = tf20 c0++        psAux sf1@(SFConst {}) sf2                      = psAuxC1 (sfCVal sf1) sf2+        psAux sf1                  sf2@(SFConst {}) = psAuxC2 sf1 (sfCVal sf2)+        psAux sf1@(SFArr {})   sf2                      = psAuxA1 (sfAFun sf1) sf2+        psAux sf1                  sf2@(SFArr    {}) = psAuxA2 sf1 (sfAFun sf2)+        psAux sf1         sf2           = SFTIVar {sfTF' = tf}+            where+                tf dt ~(a, c) = (psAux sf1' sf2', (b, d))+                    where+                           (sf1', b) = (sfTF' sf1) dt a+                           (sf2', d) = (sfTF' sf2) dt c++        psAuxC1 b (SFConst {sfCVal = d})        = sfConst (b, d)+        psAuxC1 b (SFArr   {sfAFun = f2})       = sfArr (\(~(_, c)) -> (b, f2 c))+        psAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}+            where+                tf dt ~(_, c) = (psAuxC1 b sf2', (b, d))+                    where+                        (sf2', d) = tf2 dt c++        psAuxC2 (SFConst {sfCVal = b})   d = sfConst (b, d)+        psAuxC2 (SFArr   {sfAFun = f1})  d = sfArr (\(~(a, _)) -> (f1 a, d))+        psAuxC2 (SFTIVar {sfTF' = tf1}) d = SFTIVar {sfTF' = tf}+            where+                tf dt ~(a, _) = (psAuxC2 sf1' d, (b, d))+                    where+                        (sf1', b) = tf1 dt a++        psAuxA1 f1 (SFConst {sfCVal = d})        = sfArr (\(~(a,_)) -> (f1 a, d))+        psAuxA1 f1 (SFArr       {sfAFun = f2})  = sfArr (\(~(a,c)) -> (f1 a, f2 c))+        psAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}+            where+                tf dt ~(a, c) = (psAuxA1 f1 sf2', (f1 a, d))+                    where+                        (sf2', d) = tf2 dt c++        psAuxA2 (SFConst {sfCVal = b})   f2 = sfArr (\(~(_,c)) -> (b, f2 c))+        psAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (\(~(a,c)) -> (f1 a, f2 c))+        psAuxA2 (SFTIVar {sfTF' = tf1}) f2 = SFTIVar {sfTF' = tf}+            where+                tf dt ~(a, c) = (psAuxA2 sf1' f2, (b, f2 c))+                    where+                        (sf1', b) = tf1 dt a+++parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)+parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+    where+        tf0 a0 = (pfoAux sf1 sf2, (b0, c0))+            where+                (sf1, b0) = tf10 a0+                (sf2, c0) = tf20 a0++        pfoAux sf1@(SFConst {}) sf2                      = pfoAuxC1 (sfCVal sf1) sf2+        pfoAux sf1                  sf2@(SFConst {}) = pfoAuxC2 sf1 (sfCVal sf2)+        pfoAux sf1@(SFArr {})   sf2                      = pfoAuxA1 (sfAFun sf1) sf2+        pfoAux sf1                  sf2@(SFArr   {}) = pfoAuxA2 sf1 (sfAFun sf2)+        pfoAux sf1                 sf2           = SFTIVar {sfTF' = tf}+            where+                tf dt a = (pfoAux sf1' sf2', (b, c))+                    where+                           (sf1', b) = (sfTF' sf1) dt a+                           (sf2', c) = (sfTF' sf2) dt a++        pfoAuxC1 b (SFConst {sfCVal = c})        = sfConst (b, c)+        pfoAuxC1 b (SFArr       {sfAFun = f2})  = sfArr (\a -> (b, f2 a))+        pfoAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}+            where+                tf dt a = (pfoAuxC1 b sf2', (b, c))+                    where+                        (sf2', c) = tf2 dt a++        pfoAuxC2 (SFConst {sfCVal = b})   c = sfConst (b, c)+        pfoAuxC2 (SFArr   {sfAFun = f1})  c = sfArr (\a -> (f1 a, c))+        pfoAuxC2 (SFTIVar {sfTF'  = tf1}) c = SFTIVar {sfTF' = tf}+            where+                tf dt a = (pfoAuxC2 sf1' c, (b, c))+                    where+                        (sf1', b) = tf1 dt a++        pfoAuxA1 f1 (SFConst {sfCVal = c})   = sfArr (\a -> (f1 a, c))+        pfoAuxA1 f1 (SFArr       {sfAFun = f2})  = sfArr (\a -> (f1 a ,f2 a))+        pfoAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}+            where+                tf dt a = (pfoAuxA1 f1 sf2', (f1 a, c))+                    where+                        (sf2', c) = tf2 dt a++        pfoAuxA2 (SFConst {sfCVal = b})   f2 = sfArr (\a -> (b, f2 a))+        pfoAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (\a -> (f1 a, f2 a))+        pfoAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}+            where+                tf dt a = (pfoAuxA2 sf1' f2, (b, f2 a))+                    where+                        (sf1', b) = tf1 dt a+++------------------------------------------------------------------------------+-- ArrowLoop instance and implementation+------------------------------------------------------------------------------++instance ArrowLoop SF where+    loop = loopPrim+++loopPrim :: SF (a,c) (b,c) -> SF a b+loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+    where+        tf0 a0 = (loopAux sf1, b0)+            where+                   (sf1, (b0, c0)) = tf10 (a0, c0)++                   loopAux (SFConst {sfCVal = (b, _)}) = sfConst b+                   loopAux (SFArr       {sfAFun = f1})     = sfArr (\a -> let (b,c) = f1 (a,c)+                                                                                            in b)+                   loopAux sf11 = SFTIVar {sfTF' = tf}+                        where+                         tf dt a = (loopAux sf1', b)+                          where+                           (sf1', (b, c)) = (sfTF' sf11) dt (a, c)+++------------------------------------------------------------------------------+-- Basic signal functions+------------------------------------------------------------------------------++-- Identity: identity = arr id+identity :: SF a a+identity = SF {sfTF = \a -> (sfId, a)}+++-- Identity: constant b = arr (const b)+constant :: b -> SF a b+constant b = SF {sfTF = \_ -> (sfConst b, b)}+++-- Outputs the time passed since the signal function instance was started.+localTime :: SF a Time+localTime = constant 1.0 >>> integral+++-- Alternative name for localTime.+time :: SF a Time+time = localTime+++------------------------------------------------------------------------------+-- Initialization+------------------------------------------------------------------------------++-- Initialization operator (cf. Lustre/Lucid Synchrone).+(-->) :: b -> SF a b -> SF a b+b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}+++-- Input initialization operator.+(>--) :: a -> SF a b -> SF a b+a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}+++-- Transform initial output value.+(-=>) :: (b -> b) -> SF a b -> SF a b+f -=> (SF {sfTF = tf10}) =+    SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}+++-- Transform initial input value.+(>=-) :: (a -> a) -> SF a b -> SF a b+f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}+++-- Override initial value of input signal.+initially :: a -> SF a a+initially = (--> identity)+++------------------------------------------------------------------------------+-- Basic event sources+------------------------------------------------------------------------------++-- Event source which never occurs.+never :: SF a (Event b)+never = SF {sfTF = \_ -> (sfNever, NoEvent)}+++-- Event source with a single occurrence at time 0. The value of the event+-- is given by the function argument.+now :: b -> SF a (Event b)+now b0 = (Event b0 --> never)+++-- Event source with a single occurrence at or as soon after (local) time q+-- as possible.+after :: Time -> b -> SF a (Event b)+after q x = afterEach [(q,x)]+++-- Event source with repeated occurrences with interval q.+-- Note: If the interval is too short w.r.t. the sampling intervals,+-- the result will be that events occur at every sample. However, no more+-- than one event results from any sampling interval, thus avoiding an+-- "event backlog" should sampling become more frequent at some later+-- point in time.+repeatedly :: Time -> b -> SF a (Event b)+repeatedly q x | q > 0 = afterEach qxs+                        | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."+    where+           qxs = (q,x):qxs+++-- Event source with consecutive occurrences at the given intervals.+-- Should more than one event be scheduled to occur in any sampling interval,+-- only the first will in fact occur to avoid an event backlog.+-- Question: Should positive periods except for the first one be required?+-- Note that periods of length 0 will always be skipped except for the first.+-- Right now, periods of length 0 is allowed on the grounds that no attempt+-- is made to forbid simultaneous events elsewhere.+afterEach :: [(Time,b)] -> SF a (Event b)+afterEach [] = never+afterEach ((q,x):qxs)+    | q < 0      = usrErr "AFRP" "afterEach" "Negative period."+    | otherwise = SF {sfTF = tf0}+    where+        tf0 _ = if q <= 0 then+                                (scheduleNextEvent 0.0 qxs, Event x)+                         else+                    (awaitNextEvent (-q) x qxs, NoEvent)++        scheduleNextEvent _ [] = sfNever+        scheduleNextEvent t ((r,y):qs)+            | r < 0      = usrErr "AFRP" "afterEach" "Negative period."+            | t' >= 0    = scheduleNextEvent t' qs+            | otherwise = awaitNextEvent t' y qs+            where+                   t' = t - r+        awaitNextEvent t y qs = SFTIVar {sfTF' = tf}+            where+                tf dt _ | t' >= 0       = (scheduleNextEvent t' qs, Event y)+                           | otherwise = (awaitNextEvent t' y qs, NoEvent)+                    where+                           t' = t + dt++-- A rising edge detector. Useful for things like detecting key presses.+-- Note that we initialize the loop with state set to True so that there+-- will not be an occurence at t0 in the logical time frame in which+-- this is started.+edge :: SF Bool (Event ())+edge = iEdge True++iEdge :: Bool -> SF Bool (Event ())+iEdge i = edgeBy (isBoolRaisingEdge ()) i++-- Like edge, but parameterized on the tag value.+edgeTag :: a -> SF Bool (Event a)+edgeTag a = edgeBy (isBoolRaisingEdge a) True+++-- Internal utility.+isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a+isBoolRaisingEdge _ False False = Nothing+isBoolRaisingEdge a False True  = Just a+isBoolRaisingEdge _ True  True  = Nothing+isBoolRaisingEdge _ True  False = Nothing+++-- Detects an edge where a maybe signal is changing from nothing to something.+edgeJust :: SF (Maybe a) (Event a)+edgeJust = edgeBy isJustEdge (Just undefined)+    where+           isJustEdge Nothing  Nothing  = Nothing+           isJustEdge Nothing  ma@(Just _) = ma+           isJustEdge (Just _) (Just _) = Nothing+           isJustEdge (Just _) Nothing  = Nothing+++-- Edge detector parameterized on the edge detection function and initial+-- state, i.e., the previous input sample. The first argument to the+-- edge detection function is the previous sample, the second the current one.++-- !!! Is this broken!?! Does not disallow an edge condition that persists+-- !!! between consecutive samples. See discussion in ToDo list above.++edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)+edgeBy isEdge a_init = SF {sfTF = tf0}+    where+        tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))++        ebAux a_prev = SFTIVar {sfTF' = tf}+            where+                tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a))+++------------------------------------------------------------------------------+-- Stateful event suppression+------------------------------------------------------------------------------++-- Suppression of initial (at local time 0) event.+notYet :: SF (Event a) (Event a)+notYet = initially NoEvent+++-- Suppress all but first event.+once :: SF (Event a) (Event a)+once = takeEvents 1+++-- Suppress all but first n events.+takeEvents :: Int -> SF (Event a) (Event a)+takeEvents 0       = never+takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1)))+++{-+-- More complicated using "switch" that "dSwitch".+takeEvents :: Int -> SF (Event a) (Event a)+takeEvents 0        = never+takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n)+    where+           takeEvents' 0           a = now a+           takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n)+-}+++-- Suppress first n events.+-- Here dSwitch or switch does not really matter.+dropEvents :: Int -> SF (Event a) (Event a)+dropEvents 0        = identity+dropEvents (n + 1) = dSwitch (never &&& identity)+                                            (const (NoEvent >-- dropEvents n))+++------------------------------------------------------------------------------+-- Basic switchers+------------------------------------------------------------------------------++-- Basic switch.+switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+    where+        tf0 a0 =+            case tf10 a0 of+                (sf1, (b0, NoEvent))  -> (switchAux sf1, b0)+                (_,      (_,  Event c0)) -> sfTF (k c0) a0++        switchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b+        switchAux (SFArr   {sfAFun = f1})                   = switchAuxA1 f1+        switchAux sf1                                               = SFTIVar {sfTF' = tf}+            where+                tf dt a =+                    case (sfTF' sf1) dt a of+                        (sf1', (b, NoEvent)) -> (switchAux sf1', b)+                        (_,       (_, Event c)) -> sfTF (k c) a++        -- Note: While switch behaves as a stateless arrow at this point, that+        -- could change after a switch. Hence, SFTIVar overall.+        switchAuxA1 f1 = sf+            where+                sf        = SFTIVar {sfTF' = tf}+                tf _ a =+                    case f1 a of+                        (b, NoEvent) -> (sf, b)+                        (_, Event c) -> sfTF (k c) a+++-- Switch with delayed observation.+dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+    where+        tf0 a0 =+            let (sf1, (b0, ec0)) = tf10 a0+                  in (case ec0 of+                           NoEvent  -> dSwitchAux sf1+                           Event c0 -> fst (sfTF (k c0) a0),b0)++        dSwitchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b+        dSwitchAux (SFArr       {sfAFun = f1})          = dSwitchAuxA1 f1+        dSwitchAux sf1                                          = SFTIVar {sfTF' = tf}+            where+                tf dt a =+                    let (sf1', (b, ec)) = (sfTF' sf1) dt a+                                in (case ec of+                            NoEvent -> dSwitchAux sf1'+                            Event c -> fst (sfTF (k c) a),++                        b)++        -- Note: While dSwitch behaves as a stateless arrow at this point, that+        -- could change after a switch. Hence, SFTIVar overall.+        dSwitchAuxA1 f1 = sf+            where+                sf = SFTIVar {sfTF' = tf}+                tf _ a =+                    let (b, ec) = f1 a+                                in (case ec of+                            NoEvent -> sf+                            Event c -> fst (sfTF (k c) a),++                        b)+++-- Recurring switch.+rSwitch :: SF a b -> SF (a, Event (SF a b)) b+rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)++{-+-- Old version. New is more efficient. Which one is clearer?+rSwitch :: SF a b -> SF (a, Event (SF a b)) b+rSwitch sf = switch (first sf) rSwitch'+    where+           rSwitch' sf = switch (sf *** notYet) rSwitch'+-}+++-- Recurring switch with delayed observation.+drSwitch :: SF a b -> SF (a, Event (SF a b)) b+drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)++{-+-- Old version. New is more efficient. Which one is clearer?+drSwitch :: SF a b -> SF (a, Event (SF a b)) b+drSwitch sf = dSwitch (first sf) drSwitch'+    where+           drSwitch' sf = dSwitch (sf *** notYet) drSwitch'+-}+++-- "Call-with-current-continuation" switch.+kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}+    where+           tf0 a0 =+            let (sf1, b0) = tf10 a0+                  in+                   case tfe0 (a0, b0) of+                    (sfe, NoEvent)      -> (kSwitchAux sf1 sfe, b0)+                    (_, Event c0) -> sfTF (k sf10 c0) a0++           kSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1+           kSwitchAux sf1 sfe                                     = SFTIVar {sfTF' = tf}+            where+                tf dt a =+                    let (sf1', b) = (sfTF' sf1) dt a+                    in+                           case (sfTF' sfe) dt (a, b) of+                            (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)+                            (_,  Event c) -> sfTF (k (freeze sf1 dt) c) a+++-- kSwitch with delayed observation.+dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}+    where+           tf0 a0 =+            let (sf1, b0) = tf10 a0+                  in (case tfe0 (a0, b0) of+                    (sfe, NoEvent)      -> dkSwitchAux sf1 sfe+                    (_, Event c0) -> fst (sfTF (k sf10 c0) a0),+                         b0)++           dkSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1+           dkSwitchAux sf1 sfe                                     = SFTIVar {sfTF' = tf}+            where+                tf dt a =+                    let (sf1', b) = (sfTF' sf1) dt a+                    in (case (sfTF' sfe) dt (a, b) of+                            (sfe', NoEvent) -> dkSwitchAux sf1' sfe'+                            (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),+                           b)+++------------------------------------------------------------------------------+-- Parallel composition and switching over collections with broadcasting+------------------------------------------------------------------------------++broadcast :: Functor col => a -> col sf -> col (a, sf)+broadcast a sfs = fmap (\sf -> (a, sf)) sfs+++-- Spatial parallel composition of a signal function collection.+parB :: Functor col => col (SF a b) -> SF a (col b)+parB = par broadcast+++-- Parallel switch (dynamic collection of signal functions spatially composed+-- in parallel).+pSwitchB :: Functor col =>+    col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b))+    -> SF a (col b)+pSwitchB = pSwitch broadcast+++dpSwitchB :: Functor col =>+    col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b))+    -> SF a (col b)+dpSwitchB = dpSwitch broadcast+++rpSwitchB :: Functor col =>+    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)+rpSwitchB = rpSwitch broadcast+++drpSwitchB :: Functor col =>+    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)+drpSwitchB = drpSwitch broadcast+++------------------------------------------------------------------------------+-- Parallel composition and switching over collections with general routing+------------------------------------------------------------------------------++-- Spatial parallel composition of a signal function collection parameterized+-- on the routing function.+-- rf ......... Routing function: determines the input to each signal function+--              in the collection. IMPORTANT! The routing function MUST+--              preserve the structure of the signal function collection.+-- sfs0 ....... Signal function collection.+-- Returns the spatial parallel composition of the supplied signal functions.++par :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> col (SF b c)+    -> SF a (col c)+par rf sfs0 = SF {sfTF = tf0}+    where+        tf0 a0 =+            let bsfs0 = rf a0 sfs0+                sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+                sfs      = fmap fst sfcs0+                cs0      = fmap snd sfcs0+            in+                (parAux rf sfs, cs0)+++-- Internal definition. Also used in parallel swithers.+parAux :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> col (SF' b c)+    -> SF' a (col c)+parAux rf sfs = SFTIVar {sfTF' = tf}+    where+        tf dt a =+            let bsfs  = rf a sfs+                sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+                sfs'  = fmap fst sfcs'+                cs       = fmap snd sfcs'+            in+                   (parAux rf sfs', cs)+++-- Parallel switch parameterized on the routing function. This is the most+-- general switch from which all other (non-delayed) switches in principle+-- can be derived. The signal function collection is spatially composed in+-- parallel and run until the event signal function has an occurrence. Once+-- the switching event occurs, all signal function are "frozen" and their+-- continuations are passed to the continuation function, along with the+-- event value.+-- rf ......... Routing function: determines the input to each signal function+--              in the collection. IMPORTANT! The routing function has an+--              obligation to preserve the structure of the signal function+--              collection.+-- sfs0 ....... Signal function collection.+-- sfe0 ....... Signal function generating the switching event.+-- k .......... Continuation to be invoked once event occurs.+-- Returns the resulting signal function.++pSwitch :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> col (SF b c)+    -> SF (a, col c) (Event d)+    -> (col (SF b c) -> d -> SF a (col c))+    -> SF a (col c)+pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}+    where+        tf0 a0 =+            let bsfs0 = rf a0 sfs0+                sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+                sfs      = fmap fst sfcs0+                cs0      = fmap snd sfcs0+            in+                case (sfTF sfe0) (a0, cs0) of+                    (sfe, NoEvent)      -> (pSwitchAux sfs sfe, cs0)+                    (_, Event d0) -> sfTF (k sfs0 d0) a0++        pSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs+        pSwitchAux sfs sfe = SFTIVar {sfTF' = tf}+            where+                tf dt a =+                    let bsfs  = rf a sfs+                        sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+                        sfs'  = fmap fst sfcs'+                        cs       = fmap snd sfcs'+                    in+                        case (sfTF' sfe) dt (a, cs) of+                            (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)+                            (_,  Event d) -> sfTF (k (freezeCol sfs dt) d) a+++-- Parallel switch with delayed observation parameterized on the routing+-- function.+dpSwitch :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> col (SF b c)+    -> SF (a, col c) (Event d)+    -> (col (SF b c) -> d -> SF a (col c))+    -> SF a (col c)+dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}+    where+        tf0 a0 =+            let bsfs0 = rf a0 sfs0+                sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+                cs0      = fmap snd sfcs0+            in+                (case (sfTF sfe0) (a0, cs0) of+                        (sfe, NoEvent)  -> dpSwitchAux (fmap fst sfcs0) sfe+                        (_,      Event d0) -> fst (sfTF (k sfs0 d0) a0),+                    cs0)++        dpSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs+        dpSwitchAux sfs sfe = SFTIVar {sfTF' = tf}+            where+                tf dt a =+                    let bsfs  = rf a sfs+                        sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+                        cs       = fmap snd sfcs'+                    in+                        (case (sfTF' sfe) dt (a, cs) of+                                (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')+                                                            sfe'+                                (_,       Event d) -> fst (sfTF (k (freezeCol sfs dt)+                                                                d)+                                                          a),+                                        cs)+++-- Recurring parallel switch parameterized on the routing function.+-- rf ......... Routing function: determines the input to each signal function+--              in the collection. IMPORTANT! The routing function has an+--              obligation to preserve the structure of the signal function+--              collection.+-- sfs ........ Initial signal function collection.+-- Returns the resulting signal function.++rpSwitch :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+rpSwitch rf sfs =+    pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+    noEventSnd >=- rpSwitch rf (f sfs')+++{-+rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) k+    where+        k sfs f = rpSwitch' (f sfs)+        rpSwitch' sfs = pSwitch (rf . fst) sfs (NoEvent --> arr (snd . fst)) k+-}++-- Recurring parallel switch with delayed observation parameterized on the+-- routing function.+drpSwitch :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+drpSwitch rf sfs =+    dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+    noEventSnd >=- drpSwitch rf (f sfs')++{-+drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) k+    where+        k sfs f = drpSwitch' (f sfs)+        drpSwitch' sfs = dpSwitch (rf . fst) sfs (NoEvent-->arr (snd . fst)) k+-}++------------------------------------------------------------------------------+-- Wave-form generation+------------------------------------------------------------------------------++-- Zero-order hold.+hold :: a -> SF (Event a) a+hold a_init = switch (constant a_init &&& identity) ((NoEvent >--) . hold)+++-- Tracks input signal when available, holds last value when disappears.+trackAndHold :: a -> SF (Maybe a) a+trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init+++------------------------------------------------------------------------------+-- Accumulators+------------------------------------------------------------------------------++accum :: a -> SF (Event (a -> a)) (Event a)+accum = accumBy (flip ($))++accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)+accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a)+    where+           abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a)+++{-+-- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b'))+accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)+accumBy f b_init = SF {sfTF = tf0}+    where+           tf0 NoEvent    = (abAux b_init, NoEvent)+           tf0 (Event a0) = let b' = f b_init a0+                            in (abAux b', Event b')++           abAux b = SFTIVar {sfTF' = tf}+            where+                tf _ NoEvent    = (abAux b, NoEvent)+                tf _ (Event a) = let b' = f b a+                                    in (abAux b', Event b')+-}++{-+accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+accumFilter f c_init = SF {sfTF = tf0}+    where+           tf0 NoEvent    = (afAux c_init, NoEvent)+           tf0 (Event a0) = case f c_init a0 of+                                   (c', Nothing) -> (afAux c', NoEvent)+                                (c', Just b0) -> (afAux c', Event b0)++           afAux c = SFTIVar {sfTF' = tf}+            where+                tf _ NoEvent    = (afAux c, NoEvent)+                tf _ (Event a) = case f c a of+                                           (c', Nothing) -> (afAux c', NoEvent)+                                        (c', Just b)  -> (afAux c', Event b)+-}+++accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a)+    where+           afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a)+           afAux (c, Just b)  = switch (now b &&& notYet) $ \a -> afAux (f c a)+++------------------------------------------------------------------------------+-- Delays+------------------------------------------------------------------------------++-- Uninitialized delay operator.+-- !!! The seq helps in the dynamic delay line example. But is it a good+-- !!! idea in general? Are there other accumulators which should be seq'ed+-- !!! as well? E.g. accum? Switch? Anywhere else? What's the underlying+-- !!! design principle? What can the user assume?+pre :: SF a a+pre = SF {sfTF = tf0}+    where+           tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")+           preAux a_prev = SFTIVar {sfTF' = tf}+            where+                tf _ a = {- a_prev `seq` -} (preAux a, a_prev)+++-- Initialized delay operator.+iPre :: a -> SF a a+iPre = (--> pre)+++------------------------------------------------------------------------------+-- Integraltion and differentiation+------------------------------------------------------------------------------++-- Integration using the rectangle rule.+integral :: VectorSpace a s => SF a a+integral = SF {sfTF = tf0}+    where+           igrl0        = zeroVector+           tf0 a0 = (integralAux igrl0 a0, igrl0)+           integralAux igrl a_prev = SFTIVar {sfTF' = tf}+            where+                   tf dt a = (integralAux igrl' a, igrl')+                    where+                          igrl' = igrl ^+^ realToFrac dt *^ a_prev++++-- "immediate" integration (using the function's value at the current time)+imIntegral :: VectorSpace a s => a -> SF a a+imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`)++iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b+f `iterFrom` b = SF (iterAux b) where+  iterAux c d = (SFTIVar (\ dt a' -> iterAux (f d a' dt c) a'), c)++{-+integral :: Fractional a => SF a a+integral = SF {sfTF = tf0}+    where+           igrl0        = 0.0++        tf0 a0 = (integralAux igrl0 a0, igrl0)++        integralAux igrl a_prev = SFTIVar {sfTF' = tf}+            where+                   tf dt a = (integralAux igrl' a, igrl')+                    where+                          igrl' = igrl + a_prev * realToFrac dt+-}++-- This is extremely crude. Use at your own risk.+derivative :: VectorSpace a s => SF a a+derivative = SF {sfTF = tf0}+    where+        tf0 a0 = (derivativeAux a0, zeroVector)++        derivativeAux a_prev = SFTIVar {sfTF' = tf}+            where+                   tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)+++------------------------------------------------------------------------------+-- Loops with guaranteed well-defined feedback+------------------------------------------------------------------------------++loopPre :: c -> SF (a,c) (b,c) -> SF a b+loopPre c_init sf = loop (second (iPre c_init) >>> sf)++++loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b+loopIntegral sf = loop (second integral >>> sf)+++------------------------------------------------------------------------------+-- Noise (i.e. random signal generators) and stochastic processes+------------------------------------------------------------------------------++-- Noise (random signal) with default range for type in question;+-- based on "randoms".+noise :: (RandomGen g, Random b) => g -> SF a b+noise g0 = streamToSF (randoms g0)+++-- Noise (random signal) with specified range; based on "randomRs".+noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b+noiseR range g0 = streamToSF (randomRs range g0)+++-- Internal. Not very useful for other purposes since we do not have any+-- control over the intervals between each "sample". Or? A version with+-- time-stamped samples would be similar to embedSynch (applied to identity).+-- The list argument must be a stream (infinite list) at present.++streamToSF :: [b] -> SF a b+streamToSF []      = intErr "AFRP" "streamToSF" "Empty list!"+streamToSF (b:bs) = SF {sfTF = tf0}+    where+           tf0 _ = (stsfAux bs, b)++           stsfAux []      = intErr "AFRP" "streamToSF" "Empty list!"+           stsfAux (c:cs) = SFTIVar {sfTF' = tf}+            where+                tf _ _ = (stsfAux cs, c)+++-- Stochastic event source with events occurring on average once every t_avg+-- seconds. However, no more than one event results from any one sampling+-- interval in the case of relatively sparse sampling, thus avoiding an+-- "event backlog" should sampling become more frequent at some later+-- point in time.+-- !!! Maybe it would better to give a frequency? But like this to make+-- !!! consitent with "repeatedly".+occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b)+occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0}+                                   | otherwise = usrErr "AFRP" "occasionally"+                                                  "Non-positive average interval."+    where+        -- Generally, if events occur with an average frequency of f, the+        -- probability of at least one event occurring in an interval of t+           -- is given by (1 - exp (-f*t)). The goal in the following is to+        -- decide whether at least one event occurred in the interval of size+        -- dt preceding the current sample point. For the first point,+        -- we can think of the preceding interval as being 0, implying+        -- no probability of an event occurring.++        tf0 _ = (occAux ((randoms g) :: [Double]), NoEvent)++        occAux (r:rs) = SFTIVar {sfTF' = tf}+            where+                tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at+                          in                    -- least one event.+                                 (occAux rs, if r < p then Event x else NoEvent)+++------------------------------------------------------------------------------+-- Reactimation+------------------------------------------------------------------------------++-- Reactimation of a signal function.+-- init ....... IO action for initialization. Will only be invoked once,+--              at (logical) time 0, before first call to "sense".+--              Expected to return the value of input at time 0.+-- sense ...... IO action for sensing of system input.+--      arg. #1 ....... True: action may block, waiting for an OS event.+--                      False: action must not block.+--      res. #1 ....... Time interval since previous invocation of the sensing+--                      action (or, the first time round, the init action),+--                      returned. The interval must be _strictly_ greater+--                      than 0. Thus even a non-blocking invocation must+--                      ensure that time progresses.+--      res. #2 ....... Nothing: input is unchanged w.r.t. the previously+--                      returned input sample.+--                      Just i: the input is currently i.+--                      It is OK to always return "Just", even if input is+--                      unchanged.+-- actuate .... IO action for outputting the system output.+--      arg. #1 ....... True: output may have changed from previous output+--                      sample.+--                      False: output is definitely unchanged from previous+--                      output sample.+--                      It is OK to ignore argument #1 and assume that the+--                      the output has always changed.+--      arg. #2 ....... Current output sample.+--      result ....... Termination flag. Once True, reactimate will exit+--                      the reactimation loop and return to its caller.+-- sf ......... Signal function to reactimate.++reactimate :: IO a+                 -> (Bool -> IO (DTime, Maybe a))+                 -> (Bool -> b -> IO Bool)+                    -> SF a b+                 -> IO ()+reactimate int sense actuate (SF {sfTF = tf0}) =+    do     a0 <- int+           let (sf, b0) = tf0 a0+           lp sf a0 b0+    where+           lp sf a b = do+                  done <- actuate True b+                  unless (a `seq` b `seq` done) $ do+                  (dt, ma') <- sense False+                  let+                   a' = maybe a id ma'+                   (sf', b') = (sfTF' sf) dt a'+                  lp sf' a' b'++-- An API for animating a signal function when some other library+-- needs to own the top-level control flow:++-- reactimate's state, maintained across samples:+data ReactState a b = ReactState {+    rsActuate :: (ReactHandle a b -> Bool -> b -> IO Bool),+    rsSF :: (SF' a b),+    rsA :: a,+    rsB :: b+  }++type ReactHandle a b = IORef (ReactState a b)++-- initialize top-level reaction handle+reactInit :: IO a -- init+                   -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate+                   -> SF a b+                   -> IO (ReactHandle a b)+reactInit int actuate (SF {sfTF = tf0}) =+  do+   a0 <- int+        --print "blah1"+   let (sf,b0) = tf0 a0+        --print "blah2"+        -- TODO: really need to fix this interface, since right now we+        -- just ignore termination at time 0:+   r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,+                                rsA = a0, rsB = b0 })+        --print "blah3"+   actuate r True b0+        --print "blah4"+   return r++-- process a single input sample:+react :: ReactHandle a b+         -> (DTime,Maybe a)+         -> IO Bool+react rh (dt,ma') =+  do+   rs@(ReactState {rsActuate = actuate,+                           rsSF = sf,+                        rsA = a,+                        rsB = _ }) <- readIORef rh+   let+    a' = maybe a id ma'+    (sf',b') = (sfTF' sf) dt a'+   writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'})+   done <- actuate rh True b'+   return done+++------------------------------------------------------------------------------+-- Embedding+------------------------------------------------------------------------------++-- New embed interface. We will probably have to revisit this. To run an+-- embedded signal function while retaining full control (e.g. start and+-- stop at will), one would probably need a continuation based interface+-- (as well as a continuation based underlying implementation).+--+-- E.g. here are interesting alternative (or maybe complementary)+-- signatures:+--+--       sample :: SF a b -> SF (Event a) (Event b)+--       sample' :: SF a b -> SF (Event (DTime, a)) (Event b)++embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]+embed sf0 (a0, dtas) = b0 : lp a0 sf dtas+    where+        (sf, b0) = (sfTF sf0) a0++        lp _ _ [] = []+        lp a_prev fs ((dt, ma) : dts) =+            b : (a `seq` b `seq` (lp a sf' dts))+            where+                a           = maybe a_prev id ma+                (sf', b) = (sfTF' fs) dt a+++-- Synchronous embedding. The embedded signal function is run on the supplied+-- input and time stream at a given (but variable) ratio >= 0 to the outer+-- time flow. When the ratio is 0, the embedded signal function is paused.++-- !!! Should "dropped frames" be forced to avoid space leaks?+-- !!! It's kind of hard to se why, but "frame dropping" was a problem+-- !!! in the old robot simulator. Try to find an example!++embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b+embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}+    where+        tts             = scanl (\t (dt, _) -> t + dt) 0 dtas+        bbs@(b:_) = embed sf0 (a0, dtas)++        tf0 _ = (esAux 0 (zip tts bbs), b)++        esAux _     []  = intErr "AFRP" "embedSynch" "Empty list!"+        esAux tp_prev tbtbs = SFTIVar {sfTF' = tf}+            where+                tf dt r | r < 0 = usrErr "AFRP" "embedSynch"+                                                "Negative ratio."+                        | otherwise = let tp = tp_prev + dt * r+                                          (c, tbtbs') = advance tp tbtbs+                                         in+                                          (esAux tp tbtbs', c)++                -- Advance the time stamped stream to the perceived time tp.+                -- Under the assumption that the perceived time never goes+                -- backwards (non-negative ratio), advance maintains the+                -- invariant that the perceived time is always >= the first+                -- time stamp.+                advance _ ttbs@[(_, n)] = (n, ttbs)+                advance tp ((_, c) : ts@((t', _) : _))+                    | tp <  t' = (c, ts)+                    | t' <= tp = advance tp ts+++deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])+deltaEncode _   []              = usrErr "AFRP" "deltaEncode" "Empty input list."+deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas+++deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])+deltaEncodeBy _  _      []         = usrErr "AFRP" "deltaEncodeBy" "Empty input list."+deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))+    where+        debAux _ []                               = []+        debAux a_prev (b:bs) | b `eq` a_prev = Nothing : debAux b bs+                                            | otherwise = Just b : debAux b bs
+ src/AFRPAffineSpace.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+{- $Id: AFRPAffineSpace.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPAffineSpace                                      *+*       Purpose:        Affine space type relation.                          *+*       Authors:        Henrik Nilsson and Antony Courtney                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPAffineSpace where++import AFRPVectorSpace++------------------------------------------------------------------------------+-- Affine Space type relation+------------------------------------------------------------------------------++infix 6 .+^, .-^, .-.++-- Maybe origin should not be a class method, even though an origin+-- can be assocoated with any affine space.+-- Maybe distance should not be a class method, in which case the constraint+-- on the coefficient space (a) could be Fractional (i.e., a Field), which+-- seems closer to the mathematical definition of affine space, provided+-- the constraint on the coefficient space for VectorSpace is also Fractional.++-- Minimal instance: origin, .+^, .^.+class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where+    origin   :: p+    (.+^)    :: p -> v -> p+    (.-^)    :: p -> v -> p+    (.-.)    :: p -> p -> v+    distance :: p -> p -> a++    p .-^ v = p .+^ (negateVector v)++    distance p1 p2 = norm (p1 .-. p2)
+ src/AFRPDiagnostics.hs view
@@ -0,0 +1,21 @@+{- $Id: AFRPDiagnostics.hs,v 1.3 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPDiagnostics                                      *+*       Purpose:        Standardized error-reporting for AFRP                *+*       Authors:        Henrik Nilsson and Antony Courtney                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPDiagnostics where++usrErr :: String -> String -> String -> a+usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)++intErr :: String -> String -> String -> a+intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "+                          ++ msg)
+ src/AFRPEvent.hs view
@@ -0,0 +1,284 @@+{- $Id: AFRPEvent.hs,v 1.17 2003/12/19 15:31:50 henrik Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPEvent                                            *+*       Purpose:        Definition of AFRP Event type.                       *+*       Authors:        Antony Courtney and Henrik Nilsson                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++-- Note on naming conventions used in this module.+--+-- Names here might have to be rethought. It's really a bit messy.+-- In general, the aim has been short and convenient names (like "tag",+-- "attach", "lMerge") and thus we have tried to stay away from suffixing/+-- prefixing conventions. E.g. "Event" as a common suffix would be very+-- verbose.+--+-- However, part of the names come from a desire to stay close to similar+-- functions for the Maybe type. e.g. "event", "fromEvent", "isEvent".+-- In many cases, this use of "Event" can could understood to refer to the+-- *constructor* "Event", not to the type name "Event". Thus this use of+-- event should not be seen as a suffixing-with-type-name convention. But+-- that is obviously not easy to see, and, more over, interpreting "Event"+-- as the name of the type might make equally good or better sense. E.g.+-- "fromEvent" can also be seen as a function taking an event signal,+-- which is a *partial* function on time, to a normal signal. The latter is+-- then undefined when the source event function is undefined.+--+-- In other cases, it has been necessary to somehow stay out of the way of+-- names used by the prelude or other commonly imported modules/modules+-- which could be expected to be used heavily in AFRP code. In those cases+-- a suffix "E" have been added. Examples are "filterE" (exists in Prelude)+-- and "joinE" (exists in Monad). Maybe the suffix isn't necessary in the+-- last case.+--+-- Some functions (actually only one currently, mapFilterE") have got an "E"+-- suffix just because they're closely related (by name or semantics) to one+-- which already has an "E" suffix. Another candidate would be "splitE" to+-- complement "joinE". But events carrying pairs could obviously have other+-- sources than a "joinE", so currently it is called "split".+--+-- 2003-05-19: Actually, have now changed to "splitE" to avoid a clash+-- with the method "split" in the class RandomGen.+--+-- 2003-05-19: What about "gate"? Stands out compared to e.g. "filterE".+--+-- Currently the "E" suffix is considered an exception. Maybe we should use+-- completely different names to avoid the "E" suffix. If the functions+-- are not used that often, "Event" might be approriate. Alternatively the+-- suffix "E" should be adopted globally (except if the name already contains+-- "event" in some form?).+--+-- Arguably, having both a type "Event" and a constructor "Event" is confusing+-- since there are more than one constructor. But the name "Event" for the+-- constructor is quite apt. It's really the type name that is wrong. But+-- no one has found a better name, and changing it would be a really major+-- undertaking. Yes, the constructor "Event" is not exported, but we still+-- need to talk conceptually about them. On the other hand, if we consider+-- Event-signals as partial functions on time, maybe it isn't so confusing:+-- they just don't have a value between events, so "NoEvent" does not really+-- exist conceptually.+--+-- ToDo:+-- - Either: reveal NoEvent and Event+--   or:     introcuce "event = Event", call what's now "event" "fromEvent",+--           and call what's now called "fromEvent" something else, like+--           "unsafeFromEvent"??? Better, dump it! After all, using current+--           names, "fromEvent = event undefined"!++module AFRPEvent where++import AFRPDiagnostics+import AFRPForceable+++infixl 8 `tag`, `attach`, `gate`+infixl 7 `joinE`+infixl 6 `lMerge`, `rMerge`, `merge`+++------------------------------------------------------------------------------+-- The Event type+------------------------------------------------------------------------------++-- The type Event represents a single possible event occurrence.+-- It is isomorphic to Maybe, but its constructors are not exposed outside+-- the AFRP implementation.+-- There could possibly be further constructors, but note that the NeverEvent-+-- idea does not work, at least not in the current AFRP implementation.+-- Also note that it unfortunately is possible to partially break the+-- abstractions through judicious use of e.g. snap and switching.++data Event a = NoEvent+             | Event a+++-- Make the NoEvent constructor available. Useful e.g. for initialization,+-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []).+noEvent :: Event a+noEvent = NoEvent+++-- Suppress any event in the first component of a pair.+noEventFst :: (Event a, b) -> (Event c, b)+noEventFst (_, b) = (NoEvent, b)+++-- Suppress any event in the second component of a pair.+noEventSnd :: (a, Event b) -> (a, Event c)+noEventSnd (a, _) = (a, NoEvent)+++------------------------------------------------------------------------------+-- Eq instance+------------------------------------------------------------------------------++-- Right now, we could derive this instance. But that could possibly change.++instance Eq a => Eq (Event a) where+    NoEvent   == NoEvent   = True+    (Event x) == (Event y) = x == y+    _         == _         = False+++------------------------------------------------------------------------------+-- Ord instance+------------------------------------------------------------------------------++instance Ord a => Ord (Event a) where+    compare NoEvent   NoEvent   = EQ+    compare NoEvent   (Event _) = LT+    compare (Event _) NoEvent   = GT+    compare (Event x) (Event y) = compare x y+++------------------------------------------------------------------------------+-- Functor instance+------------------------------------------------------------------------------++instance Functor Event where+    fmap _ NoEvent   = NoEvent+    fmap f (Event a) = Event (f a)+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance Forceable a => Forceable (Event a) where+    force ea@NoEvent   = ea+    force ea@(Event a) = force a `seq` ea+++------------------------------------------------------------------------------+-- Internal utilities for event construction+------------------------------------------------------------------------------++-- These utilities are to be considered strictly internal to AFRP for the+-- time being.++maybeToEvent :: Maybe a -> Event a+maybeToEvent Nothing  = NoEvent+maybeToEvent (Just a) = Event a+++------------------------------------------------------------------------------+-- Utility functions similar to those available for Maybe+------------------------------------------------------------------------------++-- An event-based version of the maybe function.+event :: a -> (b -> a) -> Event b -> a+event a _ NoEvent   = a+event _ f (Event b) = f b++fromEvent :: Event a -> a+fromEvent (Event a) = a+fromEvent NoEvent   = usrErr "AFRP" "fromEvent" "Not an event."++isEvent :: Event a -> Bool+isEvent NoEvent   = False+isEvent (Event _) = True++isNoEvent :: Event a -> Bool+isNoEvent = not . isEvent+++------------------------------------------------------------------------------+-- Event tagging+------------------------------------------------------------------------------++-- Tags an (occurring) event with a value ("replacing" the old value).+tag :: Event a -> b -> Event b+e `tag` b = fmap (const b) e+++-- Attaches an extra value to the value of an occurring event.+attach :: Event a -> b -> Event (a, b)+e `attach` b = fmap (\a -> (a, b)) e+++------------------------------------------------------------------------------+-- Event merging (disjunction) and joining (conjunction)+------------------------------------------------------------------------------++-- Left-biased event merge.+lMerge :: Event a -> Event a -> Event a+le `lMerge` re = event re Event le+++-- Right-biased event merge.+rMerge :: Event a -> Event a -> Event a+le `rMerge` re = event le Event re+++-- Unbiased event merge: simultaneous occurrence is an error.+merge :: Event a -> Event a -> Event a+merge = mergeBy $ usrErr "AFRP" "merge" "Simultaneous event occurrence."+++-- Event merge paramterezied on the conflict resolution function.+mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a+mergeBy _       NoEvent      NoEvent      = NoEvent+mergeBy _       le@(Event _) NoEvent      = le+mergeBy _       NoEvent      re@(Event _) = re+mergeBy resolve (Event l)    (Event r)    = Event (resolve l r)+++-- A generic event merge utility:+mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c)+            -> Event a -> Event b -> Event c+mapMerge _  _  _   NoEvent   NoEvent = NoEvent+mapMerge lf _  _   (Event l) NoEvent = Event (lf l)+mapMerge _  rf _   NoEvent  (Event r) = Event (rf r)+mapMerge _  _  lrf (Event l) (Event r) = Event (lrf l r)++-- Merging of a list of events; foremost event has priority.+mergeEvents :: [Event a] -> Event a+mergeEvents = foldr lMerge NoEvent+++-- Collects simultaneous event occurrences; no event if none.+catEvents :: [Event a] -> Event [a]+catEvents eas = case [ a | Event a <- eas ] of+                    [] -> NoEvent+                    as -> Event as+++-- Join (conjucntion) of two events.+joinE :: Event a -> Event b -> Event (a,b)+joinE NoEvent   _         = NoEvent+joinE _         NoEvent   = NoEvent+joinE (Event l) (Event r) = Event (l,r)+++-- Split event carrying pairs into two events.+splitE :: Event (a,b) -> (Event a, Event b)+splitE NoEvent       = (NoEvent, NoEvent)+splitE (Event (a,b)) = (Event a, Event b)+++------------------------------------------------------------------------------+-- Event filtering+------------------------------------------------------------------------------++-- Filter out events that don't satisfy some predicate.+filterE :: (a -> Bool) -> Event a -> Event a+filterE p e@(Event a) = if (p a) then e else NoEvent+filterE _ NoEvent     = NoEvent++-- Combined event mapping and filtering.+mapFilterE :: (a -> Maybe b) -> Event a -> Event b+mapFilterE _ NoEvent   = NoEvent+mapFilterE f (Event a) = case f a of+                            Nothing -> NoEvent+                            Just b  -> Event b++-- Enable/disable event occurences based on an external condition.+gate :: Event a -> Bool -> Event a+_ `gate` False = NoEvent+e `gate` True  = e
+ src/AFRPForceable.hs view
@@ -0,0 +1,63 @@+{- $Id: AFRPForceable.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPForceable                                        *+*       Purpose:        Hyperstrict evaluation.				     *+*	Author:		Zhanyong Wan					     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPForceable where+++class Forceable a where+    force :: a -> a++instance Forceable Int where+  force = id++instance Forceable Integer where+  force = id++instance Forceable Double where+  force = id++instance Forceable Float where+  force = id++instance Forceable Bool where+  force = id++instance Forceable () where+  force = id++instance Forceable Char where+  force = id++instance (Forceable a, Forceable b) => Forceable (a, b) where+  force p@(a, b) = force a `seq` force b `seq` p++instance (Forceable a, Forceable b, Forceable c) => Forceable (a, b, c) where+  force p@(a, b, c) = force a `seq` force b `seq` force c `seq` p++instance (Forceable a, Forceable b, Forceable c, Forceable d) =>+         Forceable (a, b, c, d) where+  force p@(a, b, c, d) =+      force a `seq` force b `seq` force c `seq` force d `seq` p++instance (Forceable a, Forceable b, Forceable c, Forceable d, Forceable e) =>+         Forceable (a, b, c, d, e) where+  force p@(a, b, c, d, e) =+      force a `seq` force b `seq` force c `seq` force d `seq` force e `seq` p++instance (Forceable a) => Forceable [a] where+  force nil@[] = nil+  force xs@(x:xs') = force x `seq` force xs' `seq` xs++instance (Forceable a) => Forceable (Maybe a) where+  force mx@Nothing  = mx+  force mx@(Just x) = force x `seq` mx
+ src/AFRPGeometry.hs view
@@ -0,0 +1,30 @@+{- $Id: AFRPGeometry.hs,v 1.3 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPGeometry                                         *+*       Purpose:        Basic geometrical abstractions.                      *+*       Authors:        Henrik Nilsson and Antony Courtney                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPGeometry (+    module AFRPVectorSpace,+    module AFRPAffineSpace,+    module AFRPVector2,+    module AFRPVector3,+    module AFRPPoint2,+    module AFRPPoint3+) where++import AFRPVectorSpace+import AFRPAffineSpace+import AFRPVector2+import AFRPVector3+import AFRPPoint2+import AFRPPoint3++
+ src/AFRPInternals.hs view
@@ -0,0 +1,37 @@+{- $Id: AFRPInternals.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPInternals                                        *+*       Purpose:        An interface giving access to some of the internal   *+*			details of the AFRP implementation.		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++-- This interface is indended to be used when the need arises to break+-- abstraction barriers, e.g. for interfacing AFRP to the real world, for+-- debugging purposes, or the like. Be aware that the internal details+-- may change. Relying on this interface means that your code is not+-- insulated against such changes.++module AFRPInternals (+    Event(..)		-- The event type, its constructors, and instances.+) where++import AFRPEvent+++------------------------------------------------------------------------------+-- Extra Event instances+------------------------------------------------------------------------------++instance Show a => Show (Event a) where+    showsPrec _ NoEvent   = showString "NoEvent"+    showsPrec d (Event a) = showParen (d >= 10)+				      (showString "Event " . showsPrec 10 a)++
+ src/AFRPMiscellany.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE TypeOperators, RankNTypes #-}+{- $Id: AFRPMiscellany.hs,v 1.4 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPMiscellany                                       *+*       Purpose:        Collection of entities that really should be part    *+*                       of the Haskell 98 prelude or simply have no better   *+*                       home.                                                *+*       Authors:        Henrik Nilsson and Antony Courtney                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPMiscellany (+-- Reverse function composition+    ( # ),      -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9++-- Arrow plumbing aids+    dup,        -- :: a -> (a,a)+    swap,       -- :: (a,b) -> (b,a)++-- Maps over lists of pairs+    mapFst,     -- :: (a -> b) -> [(a,c)] -> [(b,c)]+    mapSnd,     -- :: (a -> b) -> [(c,a)] -> [(c,b)]++-- Generalized tuple selectors+    sel3_1, sel3_2, sel3_3,+    sel4_1, sel4_2, sel4_3, sel4_4,+    sel5_1, sel5_2, sel5_3, sel5_4, sel5_5,++-- Floating point utilities+    fDiv,       -- :: (RealFrac a, Integral b) => a -> a -> b+    fMod,       -- :: RealFrac a => a -> a -> a+    fDivMod     -- :: (RealFrac a, Integral b) => a -> a -> (b, a)+) where++infixl 9 #+infixl 7 `fDiv`, `fMod`+++------------------------------------------------------------------------------+-- Reverse function composition+------------------------------------------------------------------------------++( # ) :: (a -> b) -> (b -> c) -> (a -> c)+f # g = g . f+++------------------------------------------------------------------------------+-- Arrow plumbing aids+------------------------------------------------------------------------------++dup :: a -> (a,a)+dup x = (x,x)++swap :: (a,b) -> (b,a)+swap ~(x,y) = (y,x)+++------------------------------------------------------------------------------+-- Maps over lists of pairs+------------------------------------------------------------------------------++mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]+mapFst _ []             = []+mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys++mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]+mapSnd _ []             = []+mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys+++------------------------------------------------------------------------------+-- Generalized tuple selectors+------------------------------------------------------------------------------++-- Triples++sel3_1 :: forall t t1 t2. (t, t1, t2) -> t++sel3_2 :: forall t t1 t2. (t, t1, t2) -> t1+sel3_1 (x,_,_) = x++sel3_3 :: forall t t1 t2. (t, t1, t2) -> t2+sel3_2 (_,x,_) = x+sel3_3 (_,_,x) = x+++-- 4-tuples++sel4_1 :: forall t t1 t2 t3. (t, t1, t2, t3) -> t++sel4_2 :: forall t t1 t2 t3. (t, t1, t2, t3) -> t1+sel4_1 (x,_,_,_) = x++sel4_3 :: forall t t1 t2 t3. (t, t1, t2, t3) -> t2+sel4_2 (_,x,_,_) = x++sel4_4 :: forall t t1 t2 t3. (t, t1, t2, t3) -> t3+sel4_3 (_,_,x,_) = x+sel4_4 (_,_,_,x) = x+++-- 5-tuples+sel5_1 ::(t, t1, t2, t3, t4) -> t+sel5_1 (x,_,_,_,_) = x+sel5_2 :: (t, t1, t2, t3, t4) -> t1+sel5_2 (_,x,_,_,_) = x+sel5_3 :: (t, t1, t2, t3, t4) -> t2+sel5_3 (_,_,x,_,_) = x+sel5_4 :: (t, t1, t2, t3, t4) -> t3+sel5_4 (_,_,_,x,_) = x+sel5_5 :: (t, t1, t2, t3, t4) -> t4+sel5_5 (_,_,_,_,x) = x+++------------------------------------------------------------------------------+-- Floating point utilities+------------------------------------------------------------------------------++-- Floating-point div and modulo operators.++-- fDiv :: (RealFrac a, Integral b) => a -> a -> b+fDiv :: (RealFrac a) => a -> a -> Int+fDiv x y = fst (fDivMod x y)++fMod :: RealFrac a => a -> a -> a+fMod x y = snd $ fDivMod x y++fDivMod :: (RealFrac a) => a -> a -> (Int, a)+fDivMod x y = (q, r)+    where+        q = (floor (x/y))+        r = x - fromIntegral q * y
+ src/AFRPPoint2.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE BangPatterns, FlexibleInstances, MultiParamTypeClasses #-}++{- $Id: AFRPPoint2.hs,v 1.3 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPPoint2                                           *+*       Purpose:        2D point abstraction (R^2).                          *+*       Authors:        Henrik Nilsson and Antony Courtney                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPPoint2 (+    module AFRPVectorSpace,+    module AFRPAffineSpace,+    Point2(..), -- Non-abstract, instance of AffineSpace+    point2X,    -- :: RealFloat a => Point2 a -> a+    point2Y     -- :: RealFloat a => Point2 a -> a+) where++import AFRPVectorSpace+import AFRPAffineSpace+import AFRPVector2+import AFRPForceable++------------------------------------------------------------------------------+-- 2D point, constructors and selectors.+------------------------------------------------------------------------------++data RealFloat a => Point2 a = Point2 !a !a deriving (Eq, Show)++point2X :: RealFloat a => Point2 a -> a+point2X (Point2 x _) = x++point2Y :: RealFloat a => Point2 a -> a+point2Y (Point2 _ y) = y+++------------------------------------------------------------------------------+-- Affine space instance+------------------------------------------------------------------------------++instance RealFloat a => AffineSpace (Point2 a) (Vector2 a) a where+    origin = Point2 0 0++    (Point2 x y) .+^ v = Point2 (x + vector2X v) (y + vector2Y v)++    (Point2 x y) .-^ v = Point2 (x - vector2X v) (y - vector2Y v)++    (Point2 x1 y1) .-. (Point2 x2 y2) = vector2 (x1 - x2) (y1 - y2)+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance RealFloat a => Forceable (Point2 a) where+     force = id
+ src/AFRPPoint3.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++{- $Id: AFRPPoint3.hs,v 1.3 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPPoint3                                           *+*       Purpose:        3D point abstraction (R^3).                          *+*       Authors:        Henrik Nilsson and Antony Courtney                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPPoint3 (+    module AFRPVector3,+    Point3(..), -- Non-abstract, instance of AffineSpace+    point3X,    -- :: RealFloat a => Point3 a -> a+    point3Y,    -- :: RealFloat a => Point3 a -> a+    point3Z     -- :: RealFloat a => Point3 a -> a+) where++import AFRPVectorSpace+import AFRPAffineSpace+import AFRPVector3+import AFRPForceable++------------------------------------------------------------------------------+-- 3D point, constructors and selectors.+------------------------------------------------------------------------------++data RealFloat a => Point3 a = Point3 !a !a !a deriving Eq++point3X :: RealFloat a => Point3 a -> a+point3X (Point3 x _ _) = x++point3Y :: RealFloat a => Point3 a -> a+point3Y (Point3 _ y _) = y++point3Z :: RealFloat a => Point3 a -> a+point3Z (Point3 _ _ z) = z+++------------------------------------------------------------------------------+-- Affine space instance+------------------------------------------------------------------------------++instance RealFloat a => AffineSpace (Point3 a) (Vector3 a) a where+    origin = Point3 0 0 0++    (Point3 x y z) .+^ v =+        Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v)++    (Point3 x y z) .-^ v =+        Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v)++    (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) =+        vector3 (x1 - x2) (y1 - y2) (z1 - z2)+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance RealFloat a => Forceable (Point3 a) where+     force = id
+ src/AFRPTask.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE TypeOperators, Rank2Types #-}++{- $Id: AFRPTask.hs,v 1.6 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTask                                             *+*       Purpose:        Task abstraction on top of signal transformers.      *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTask (+    Task,+    mkTask,	-- :: SF a (b, Event c) -> Task a b c+    runTask,	-- :: Task a b c -> SF a (Either b c)	-- Might change.+    runTask_,	-- :: Task a b c -> SF a b+    taskToSF,	-- :: Task a b c -> SF a (b, Event c)	-- Might change.+    constT,	-- :: b -> Task a b c+    sleepT, 	-- :: Time -> b -> Task a b ()+    snapT, 	-- :: Task a b a+    timeOut, 	-- :: Task a b c -> Time -> Task a b (Maybe c)+    abortWhen, 	-- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)+    repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a+    for, 	-- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()+    forAll, 	-- :: Monad m => [a] -> (a -> m b) -> m ()+    forEver 	-- :: Monad m => m a -> m b+) where++import AFRP+import AFRPUtilities (snap)+import AFRPDiagnostics++infixl 0 `timeOut`, `abortWhen`, `repeatUntil`+++------------------------------------------------------------------------------+-- The Task type+------------------------------------------------------------------------------++-- CPS-based representation allowing a termination to be detected.+-- (Note the rank 2 polymorphic type!)+-- The representation can be changed if necessary, but the Monad laws+-- follow trivially in this case.+newtype Task a b c =+    Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))+++unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d))+unTask (Task f) = f+++mkTask :: SF a (b, Event c) -> Task a b c+mkTask st = Task (switch (st >>> first (arr Left)))+++-- "Runs" a task (unusually bad name?). The output from the resulting+-- signal transformer is tagged with Left while the underlying task is+-- running. Once the task has terminated, the output goes constant with+-- the value Right x, where x is the value of the terminating event.+runTask :: Task a b c -> SF a (Either b c)+runTask tk = (unTask tk) (\c -> constant (Right c))+++-- Runs a task. The output becomes undefined once the underlying task has+-- terminated. Convenient e.g. for tasks which are known not to terminate.+runTask_ :: Task a b c -> SF a b+runTask_ tk = runTask tk+              >>> arr (either id (usrErr "AFRPTask" "runTask_"+                                         "Task terminated!"))+++-- Seems as if the following is convenient after all. Suitable name???+-- Maybe that implies a representation change for Tasks?+-- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.)+taskToSF :: Task a b c -> SF a (b, Event c)+taskToSF tk = runTask tk+	      >>> (arr (either id ((usrErr "AFRPTask" "runTask_"+                                           "Task terminated!")))+		   &&& edgeBy isEdge (Left undefined))+    where+        isEdge (Left _)  (Left _)  = Nothing+	isEdge (Left _)  (Right c) = Just c+	isEdge (Right _) (Right _) = Nothing+	isEdge (Right _) (Left _)  = Nothing+++------------------------------------------------------------------------------+-- Monad instance+------------------------------------------------------------------------------++instance Monad (Task a b) where+    tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))+    return x = Task (\k -> k x)++{-+Let's check the monad laws:++    t >>= return+    = \k -> t (\c -> return c k)+    = \k -> t (\c -> (\x -> \k -> k x) c k)+    = \k -> t (\c -> (\x -> \k' -> k' x) c k)+    = \k -> t (\c -> k c)+    = \k -> t k+    = t+    QED++    return x >>= f+    = \k -> (return x) (\c -> f c k)+    = \k -> (\k -> k x) (\c -> f c k)+    = \k -> (\k' -> k' x) (\c -> f c k)+    = \k -> (\c -> f c k) x+    = \k -> f x k+    = f x+    QED++    (t >>= f) >>= g+    = \k -> (t >>= f) (\c -> g c k)+    = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k)+    = \k -> t (\c' -> f c' (\c -> g c k))+    = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k)+    = \k -> t (\c' -> (\x -> f x >>= g) c' k)+    = t >>= (\x -> f x >>= g)+    QED++No surprises (obviously, since this is essentially just the CPS monad).+-}+++------------------------------------------------------------------------------+-- Basic tasks+------------------------------------------------------------------------------++-- Non-terminating task with constant output b.+constT :: b -> Task a b c+constT b = mkTask (constant b &&& never)+++-- "Sleeps" for t seconds with constant output b.+sleepT :: Time -> b -> Task a b ()+sleepT t b = mkTask (constant b &&& after t ())+++-- Takes a "snapshot" of the input and terminates immediately with the input+-- value as the result. No time passes; law:+--+--    snapT >> snapT = snapT+--+snapT :: Task a b a+snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)+++------------------------------------------------------------------------------+-- Basic tasks combinators+------------------------------------------------------------------------------++-- Impose a time out on a task.+timeOut :: Task a b c -> Time -> Task a b (Maybe c)+tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)+    where+        aux ((b, ec), et) = (b, (lMerge (fmap Just ec)+					(fmap (const Nothing) et)))+++-- Run a "guarding" event source (SF a (Event b)) in parallel with a+-- (possibly non-terminating) task. The task will be aborted at the+-- first occurrence of the event source (if it has not terminated itself+-- before that). Useful for separating sequencing and termination concerns.+-- E.g. we can do something "useful", but in parallel watch for a (exceptional)+-- condition which should terminate that activity, whithout having to check+-- for that condition explicitly during each and every phase of the activity.+-- Example: tsk `abortWhen` lbp+abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)+tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux)+    where+        aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))+++------------------------------------------------------------------------------+-- Loops+------------------------------------------------------------------------------++-- These are general monadic combinators. Maybe they don't really belong here.++-- Repeat m until result satisfies the predicate p+repeatUntil :: Monad m => m a -> (a -> Bool) -> m a+m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x+++-- C-style for-loop.+-- Example: for 0 (+1) (>=10) ...+for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()+for i f p m = if p i then m >> for (f i) f p m else return ()+++-- Perform the monadic operation for each element in the list.+forAll :: Monad m => [a] -> (a -> m b) -> m ()+forAll = flip mapM_+++-- Repeat m for ever.+forEver :: Monad m => m a -> m b+forEver m = m >> forEver m+++-- Alternatives/other potentially useful signatures:+-- until :: a -> (a -> M a) -> (a -> Bool) -> M a+-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b+-- while??? It could be:+-- while :: a -> (a -> Bool) -> (a -> M a) -> M a+++------------------------------------------------------------------------------+-- Monad transformers?+------------------------------------------------------------------------------++-- What about monad transformers if we want to compose this monad with+-- other capabilities???
+ src/AFRPUtilities.hs view
@@ -0,0 +1,304 @@+{- $Id: AFRPUtilities.hs,v 1.8 2003/12/19 15:31:50 henrik Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPUtilities                                        *+*       Purpose:        Derived utility definitions.                         *+*       Authors:        Antony Courtney and Henrik Nilsson                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++-- ToDo:+-- * Possibly add+--       impulse :: VectorSpace a k => a -> Event a+--   But to do that, we need access to Event, which we currently do not have.+-- * The general arrow utilities should be moved to a module+--   AFRPArrowUtilities.+-- * I'm not sure structuring the AFRP "core" according to what is+--   core functionality and what's not is all that useful. There are+--   many cases where we want to implement combinators that fairly+--   easily could be implemented in terms of others as primitives simply+--   because we expect that that implementation is going to be much more+--   efficient, and that the combinators are used sufficiently often to+--   warrant doing this. E.g. "switch" should be a primitive, even though+--   it could be derived from "pSwitch".+-- * Reconsider "recur". If an event source has an immediate occurrence,+--   we'll get into a loop. For example: recur now. Maybe suppress+--   initial occurrences? Initial occurrences are rather pointless in this+--   case anyway.+++module AFRPUtilities (+-- General arrow utilities+    --(^>>),            -- :: Arrow a => (b -> c) -> a c d -> a b d+    --(>>^),            -- :: Arrow a => a b c -> (c -> d) -> a b d+    --(^<<),            -- :: Arrow a => (c -> d) -> a b c -> a b d+    --(<<^),            -- :: Arrow a => a c d -> (b -> c) -> a b d++-- Liftings+    arr2,               -- :: Arrow a => (b->c->d) -> a (b,c) d+    arr3,               -- :: Arrow a => (b->c->d->e) -> a (b,c,d) e+    arr4,               -- :: Arrow a => (b->c->d->e->f) -> a (b,c,d,e) f+    arr5,               -- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g+    lift0,              -- :: Arrow a => c -> a b c+    lift1,              -- :: Arrow a => (c->d) -> (a b c->a b d)+    lift2,              -- :: Arrow a => (c->d->e) -> (a b c->a b d->a b e)+    lift3,              -- :: Arrow a => (c->d->e->f) -> (a b c-> ... ->a b f)+    lift4,              -- :: Arrow a => (c->d->e->f->g) -> (a b c->...->a b g)+    lift5,              -- :: Arrow a => (c->d->e->f->g->h)->(a b c->...a b h)++-- Event sources+    snap,               -- :: SF a (Event a)+    snapAfter,          -- :: Time -> SF a (Event a)+    sample,             -- :: Time -> SF a (Event a)+    recur,              -- :: SF a (Event b) -> SF a (Event b)++-- Parallel composition/switchers with "zip" routing+    parZ,               -- [SF a b] -> SF [a] [b]+    pSwitchZ,           -- [SF a b] -> SF ([a],[b]) (Event c)+                        -- -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b]+    dpSwitchZ,          -- [SF a b] -> SF ([a],[b]) (Event c)+                        -- -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b]+    rpSwitchZ,          -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]+    drpSwitchZ,         -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]++-- Guards and automata-oriented combinators+    provided,           -- :: (a -> Bool) -> SF a b -> SF a b -> SF a b++-- Wave-form generation+    dHold,              -- :: a -> SF (Event a) a+    dTrackAndHold,      -- :: a -> SF (Maybe a) a++-- Accumulators+    accumHold,          -- :: a -> SF (Event (a -> a)) a+    dAccumHold,         -- :: a -> SF (Event (a -> a)) a+    accumHoldBy,        -- :: (b -> a -> b) -> b -> SF (Event a) b+    dAccumHoldBy,       -- :: (b -> a -> b) -> b -> SF (Event a) b+    count,              -- :: Integral b => SF (Event a) (Event b)++-- Delays+    fby,                -- :: b -> SF a b -> SF a b,    infixr 0++-- Integrals+    impulseIntegral     -- :: VectorSpace a k => SF (a, Event a) a+) where++import AFRPDiagnostics+import AFRP+++--infixr 1 ^<<, ^>>+--infixl 1 <<^, >>^+--infixr 0 `fby`+++------------------------------------------------------------------------------+-- General arrow utilities+------------------------------------------------------------------------------++--(^>>) :: Arrow a => (b -> c) -> a c d -> a b d+--f ^>> a = arr f >>> a++--(>>^) :: Arrow a => a b c -> (c -> d) -> a b d+--a >>^ f = a >>> arr f+++--(^<<) :: Arrow a => (c -> d) -> a b c -> a b d+--f ^<< a = arr f <<< a+++--(<<^) :: Arrow a => a c d -> (b -> c) -> a b d+--a <<^ f = a <<< arr f+++------------------------------------------------------------------------------+-- Liftings+------------------------------------------------------------------------------++arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d+arr2 = arr . uncurry+++arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e+arr3 = arr . \h (b, c, d) -> h b c d+++arr4 :: Arrow a => (b -> c -> d -> e -> f) -> a (b, c, d, e) f+arr4 = arr . \h (b, c, d, e) -> h b c d e+++arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g+arr5 = arr . \h (b, c, d, e, f) -> h b c d e f+++lift0 :: Arrow a => c -> a b c+lift0 c = arr (const c)+++lift1 :: Arrow a => (c -> d) -> (a b c -> a b d)+lift1 f = \a -> a >>> arr f+++lift2 :: Arrow a => (c -> d -> e) -> (a b c -> a b d -> a b e)+lift2 f = \a1 a2 -> a1 &&& a2 >>> arr2 f+++lift3 :: Arrow a => (c -> d -> e -> f) -> (a b c -> a b d -> a b e -> a b f)+lift3 f = \a1 a2 a3 -> (lift2 f) a1 a2 &&& a3 >>> arr2 ($)+++lift4 :: Arrow a => (c->d->e->f->g) -> (a b c->a b d->a b e->a b f->a b g)+lift4 f = \a1 a2 a3 a4 -> (lift3 f) a1 a2 a3 &&& a4 >>> arr2 ($)+++lift5 :: Arrow a =>+    (c->d->e->f->g->h) -> (a b c->a b d->a b e->a b f->a b g->a b h)+lift5 f = \a1 a2 a3 a4 a5 ->(lift4 f) a1 a2 a3 a4 &&& a5 >>> arr2 ($)+++------------------------------------------------------------------------------+-- Event sources+------------------------------------------------------------------------------++-- Event source with a single occurrence at time 0. The value of the event+-- is obtained by sampling the input at that time.+snap :: SF a (Event a)+snap = switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now+++-- Event source with a single occurrence at or as soon after (local) time t_ev+-- as possible. The value of the event is obtained by sampling the input a+-- that time.+snapAfter :: Time -> SF a (Event a)+snapAfter t_ev = switch (never+                         &&& (identity+                              &&& after t_ev () >>^ \(a, e) -> e `tag` a))+                        now+++-- Sample a signal at regular intervals.+sample :: Time -> SF a (Event a)+sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a+++-- Makes an event source recurring by restarting it as soon as it has an+-- occurrence.+recur :: SF a (Event b) -> SF a (Event b)+recur sfe = switch (never &&& sfe) recurAux+    where+        recurAux b = switch (now b &&& sfe) recurAux+++------------------------------------------------------------------------------+-- Parallel composition/switchers with "zip" routing+------------------------------------------------------------------------------++safeZip :: String -> [a] -> [b] -> [(a,b)]+safeZip fn as bs = safeZip' as bs+    where+        safeZip' _ []     = []+        safeZip' cs (d:ds) = (head' cs, d) : safeZip' (tail' cs) ds++        head' []    = err+        head' (e:_) = e++        tail' []     = err+        tail' (_:es) = es++        err = usrErr "AFRPUtilities" fn "Input list too short."+++parZ :: [SF a b] -> SF [a] [b]+parZ = par (safeZip "parZ")+++pSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c -> SF [a] [b])+            -> SF [a] [b]+pSwitchZ = pSwitch (safeZip "pSwitchZ")+++dpSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c ->SF [a] [b])+             -> SF [a] [b]+dpSwitchZ = dpSwitch (safeZip "dpSwitchZ")+++rpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+rpSwitchZ = rpSwitch (safeZip "rpSwitchZ")+++drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+drpSwitchZ = drpSwitch (safeZip "drpSwitchZ")+++------------------------------------------------------------------------------+-- Guards and automata-oriented combinators+------------------------------------------------------------------------------++-- Runs sft only when the predicate p is satisfied, otherwise runs sff.+provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b+provided p sft sff =+    switch (constant undefined &&& snap) $ \a0 ->+    if p a0 then stt else stf+    where+        stt = switch (sft &&& (not . p ^>> edge)) (const stf)+        stf = switch (sff &&& (p ^>> edge)) (const stt)+++------------------------------------------------------------------------------+-- Wave-form generation+------------------------------------------------------------------------------++-- Zero-order hold with delay.+-- Identity: dHold a0 = hold a0 >>> iPre a0).+dHold :: a -> SF (Event a) a+dHold a0 = dSwitch (constant a0 &&& identity) dHold'+    where+        dHold' a = dSwitch (constant a &&& notYet) dHold'+++dTrackAndHold :: a -> SF (Maybe a) a+dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init+++------------------------------------------------------------------------------+-- Accumulators+------------------------------------------------------------------------------++accumHold :: a -> SF (Event (a -> a)) a+accumHold a_init = accum a_init >>> hold a_init+++dAccumHold :: a -> SF (Event (a -> a)) a+dAccumHold a_init = accum a_init >>> dHold a_init+++accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+accumHoldBy f b_init = accumBy f b_init >>> hold b_init+++dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+dAccumHoldBy f b_init = accumBy f b_init >>> dHold b_init+++count :: Integral b => SF (Event a) (Event b)+count = accumBy (\n _ -> n + 1) 0+++------------------------------------------------------------------------------+-- Delays+------------------------------------------------------------------------------++-- Lucid-Synchrone-like initialized delay (read "followed by").+fby :: b -> SF a b -> SF a b+b0 `fby` sf = b0 --> sf >>> pre+++------------------------------------------------------------------------------+-- Integrals+------------------------------------------------------------------------------++impulseIntegral :: VectorSpace a k => SF (a, Event a) a+impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^)
+ src/AFRPVector2.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE BangPatterns, FlexibleInstances, MultiParamTypeClasses #-}++{- $Id: AFRPVector2.hs,v 1.5 2004/03/22 19:46:40 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPVector2                                          *+*       Purpose:        2D vector abstraction (R^2).                         *+*       Authors:        Henrik Nilsson and Antony Courtney                   *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPVector2 (+    module AFRPVectorSpace,+    Vector2,            -- Abstract, instance of VectorSpace+    vector2,            -- :: RealFloat a => a -> a -> Vector2 a+    vector2X,           -- :: RealFloat a => Vector2 a -> a+    vector2Y,           -- :: RealFloat a => Vector2 a -> a+    vector2XY,          -- :: RealFloat a => Vector2 a -> (a, a)+    vector2Polar,       -- :: RealFloat a => a -> a -> Vector2 a+    vector2Rho,         -- :: RealFloat a => Vector2 a -> a+    vector2Theta,       -- :: RealFloat a => Vector2 a -> a+    vector2RhoTheta,    -- :: RealFloat a => Vector2 a -> (a, a)+    vector2Rotate       -- :: RealFloat a => a -> Vector2 a -> Vector2 a+) where++import AFRPVectorSpace+import AFRPForceable+++------------------------------------------------------------------------------+-- 2D vector, constructors and selectors.+------------------------------------------------------------------------------++-- Restrict coefficient space to RealFloat (rather than Floating) for now.+-- While unclear if a complex coefficient space would be useful (and if the+-- result really would be a 2d vector), the only thing causing trouble is the+-- use of atan2 in vector2Theta. Maybe atan2 can be generalized?++data RealFloat a => Vector2 a = Vector2 !a !a deriving (Eq,Show)++vector2 :: RealFloat a => a -> a -> Vector2 a+vector2 x y = Vector2 x y++vector2X :: RealFloat a => Vector2 a -> a+vector2X (Vector2 x _) = x++vector2Y :: RealFloat a => Vector2 a -> a+vector2Y (Vector2 _ y) = y++vector2XY :: RealFloat a => Vector2 a -> (a, a)+vector2XY (Vector2 x y) = (x, y)++vector2Polar :: RealFloat a => a -> a -> Vector2 a+vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta)++vector2Rho :: RealFloat a => Vector2 a -> a+vector2Rho (Vector2 x y) = sqrt (x * x + y * y)++vector2Theta :: RealFloat a => Vector2 a -> a+vector2Theta (Vector2 x y) = atan2 y x++vector2RhoTheta :: RealFloat a => Vector2 a -> (a, a)+vector2RhoTheta v = (vector2Rho v, vector2Theta v)++------------------------------------------------------------------------------+-- Vector space instance+------------------------------------------------------------------------------++instance RealFloat a => VectorSpace (Vector2 a) a where+    zeroVector = Vector2 0 0++    a *^ (Vector2 x y) = Vector2 (a * x) (a * y)++    (Vector2 x y) ^/ a = Vector2 (x / a) (y / a)++    negateVector (Vector2 x y) = (Vector2 (-x) (-y))++    (Vector2 x1 y1) ^+^ (Vector2 x2 y2) = Vector2 (x1 + x2) (y1 + y2)++    (Vector2 x1 y1) ^-^ (Vector2 x2 y2) = Vector2 (x1 - x2) (y1 - y2)++    (Vector2 x1 y1) `dot` (Vector2 x2 y2) = x1 * x2 + y1 * y2+++------------------------------------------------------------------------------+-- Additional operations+------------------------------------------------------------------------------++vector2Rotate :: RealFloat a => a -> Vector2 a -> Vector2 a+vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta')+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance RealFloat a => Forceable (Vector2 a) where+     force = id
+ src/AFRPVector3.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE BangPatterns #-}++{- $Id: AFRPVector3.hs,v 1.3 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:		AFRPVector3					     *+*       Purpose:	3D vector abstraction (R^3).			     *+*	Authors:	Henrik Nilsson and Antony Courtney		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++module AFRPVector3 (+    module AFRPVectorSpace,+    Vector3,		-- Abstract, instance of VectorSpace+    vector3,		-- :: RealFloat a => a -> a -> a -> Vector3 a+    vector3X,		-- :: RealFloat a => Vector3 a -> a+    vector3Y,		-- :: RealFloat a => Vector3 a -> a+    vector3Z,		-- :: RealFloat a => Vector3 a -> a+    vector3XYZ,		-- :: RealFloat a => Vector3 a -> (a, a, a)+    vector3Spherical,	-- :: RealFloat a => a -> a -> a -> Vector3 a+    vector3Rho,		-- :: RealFloat a => Vector3 a -> a+    vector3Theta,	-- :: RealFloat a => Vector3 a -> a+    vector3Phi,		-- :: RealFloat a => Vector3 a -> a+    vector3RhoThetaPhi,	-- :: RealFloat a => Vector3 a -> (a, a, a)+    vector3Rotate 	-- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a+) where++import AFRPVectorSpace+import AFRPForceable++------------------------------------------------------------------------------+-- 3D vector, constructors and selectors.+------------------------------------------------------------------------------++-- Restrict coefficient space to RealFloat (rather than Floating) for now.+-- While unclear if a complex coefficient space would be useful (and if the+-- result really would be a 3d vector), the only thing causing trouble is the+-- use of atan2 in vector3Theta and vector3Phi. Maybe atan2 can be generalized?++data RealFloat a => Vector3 a = Vector3 !a !a !a deriving Eq++vector3 :: RealFloat a => a -> a -> a -> Vector3 a+vector3 x y z = Vector3 x y z++vector3X :: RealFloat a => Vector3 a -> a+vector3X (Vector3 x _ _) = x++vector3Y :: RealFloat a => Vector3 a -> a+vector3Y (Vector3 _ y _) = y++vector3Z :: RealFloat a => Vector3 a -> a+vector3Z (Vector3 _ _ z) = z++vector3XYZ :: RealFloat a => Vector3 a -> (a, a, a)+vector3XYZ (Vector3 x y z) = (x, y, z)++vector3Spherical :: RealFloat a => a -> a -> a -> Vector3 a+vector3Spherical rho theta phi =+    Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi)+    where+	rhoSinPhi = rho * sin phi++vector3Rho :: RealFloat a => Vector3 a -> a+vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z)++vector3Theta :: RealFloat a => Vector3 a -> a+vector3Theta (Vector3 x y _) = atan2 y x++vector3Phi :: RealFloat a => Vector3 a -> a+vector3Phi v@(Vector3 _ _ z) = acos (z / vector3Rho v)++vector3RhoThetaPhi :: RealFloat a => Vector3 a -> (a, a, a)+vector3RhoThetaPhi (Vector3 x y z) = (rho, theta, phi)+    where+        rho   = sqrt (x * x + y * y + z * z)+        theta = atan2 y x+	phi   = acos (z / rho)+++------------------------------------------------------------------------------+-- Vector space instance+------------------------------------------------------------------------------++instance RealFloat a => VectorSpace (Vector3 a) a where+    zeroVector = Vector3 0 0 0++    a *^ (Vector3 x y z) = Vector3 (a * x) (a * y) (a * z)++    (Vector3 x y z) ^/ a = Vector3 (x / a) (y / a) (z / a)++    negateVector (Vector3 x y z) = (Vector3 (-x) (-y) (-z))++    (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2)++    (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2)++    (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2+++------------------------------------------------------------------------------+-- Additional operations+------------------------------------------------------------------------------++vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a+vector3Rotate theta' phi' v =+    vector3Spherical (vector3Rho v)+		     (vector3Theta v + theta')+		     (vector3Phi v + phi')+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance RealFloat a => Forceable (Vector3 a) where+     force = id
+ src/AFRPVectorSpace.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}++{- $Id: AFRPVectorSpace.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:		AFRPVectorSpace					     *+*       Purpose:	Vector space type relation and basic instances.	     *+*	Authors:	Henrik Nilsson and Antony Courtney		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPVectorSpace where++------------------------------------------------------------------------------+-- Vector space type relation+------------------------------------------------------------------------------++infixr *^+infixl ^/+infix 7 `dot`+infixl 6 ^+^, ^-^++-- Maybe norm and normalize should not be class methods, in which case+-- the constraint on the coefficient space (a) should (or, at least, could)+-- be Fractional (roughly a Field) rather than Floating.++-- Minimal instance: zeroVector, (*^), (^+^), dot+class Floating a => VectorSpace v a | v -> a where+    zeroVector   :: v+    (*^)         :: a -> v -> v+    (^/)         :: v -> a -> v+    negateVector :: v -> v+    (^+^)        :: v -> v -> v+    (^-^)        :: v -> v -> v+    dot          :: v -> v -> a+    norm	 :: v -> a+    normalize	 :: v -> v++    v ^/ a = (1/a) *^ v++    negateVector v = (-1) *^ v++    v1 ^-^ _ = v1 ^+^ v1 -- (negateVector v2)++    norm v = sqrt (v `dot` v)++    normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector"+        where+	    nv = norm v++------------------------------------------------------------------------------+-- Vector space instances for Float and Double+------------------------------------------------------------------------------++instance VectorSpace Float Float where+    zeroVector = 0++    a *^ x = a * x++    x ^/ a = x / a++    negateVector x = (-x)++    x1 ^+^ x2 = x1 + x2++    x1 ^-^ x2 = x1 - x2++    x1 `dot` x2 = x1 * x2+++instance VectorSpace Double Double where+    zeroVector = 0++    a *^ x = a * x++    x ^/ a = x / a++    negateVector x = (-x)++    x1 ^+^ x2 = x1 + x2++    x1 ^-^ x2 = x1 - x2++    x1 `dot` x2 = x1 * x2+++------------------------------------------------------------------------------+-- Vector space instances for small tuples of Floating+------------------------------------------------------------------------------++instance Floating a => VectorSpace (a,a) a where+    zeroVector = (0,0)++    a *^ (x,y) = (a * x, a * y)++    (x,y) ^/ a = (x / a, y / a)++    negateVector (x,y) = (-x, -y)++    (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2)++    (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2)++    (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2+++instance Floating a => VectorSpace (a,a,a) a where+    zeroVector = (0,0,0)++    a *^ (x,y,z) = (a * x, a * y, a * z)++    (x,y,z) ^/ a = (x / a, y / a, z / a)++    negateVector (x,y,z) = (-x, -y, -z)++    (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2)++    (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2)++    (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2+++instance Floating a => VectorSpace (a,a,a,a) a where+    zeroVector = (0,0,0,0)++    a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u)++    (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a)++    negateVector (x,y,z,u) = (-x, -y, -z, -u)++    (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2)++    (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2)++    (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2+++instance Floating a => VectorSpace (a,a,a,a,a) a where+    zeroVector = (0,0,0,0,0)++    a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v)++    (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a)++    negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v)++    (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2)++    (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2)++    (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) =+        x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2+++
+ src/BSP.hs view
@@ -0,0 +1,1052 @@+{-# LANGUAGE BangPatterns #-}
+
+{- BSP.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+A module for loading Quake 3 BSP files
+
+source code in C++ can be found at
+
+http://www.paulsprojects.net/opengl/q3bsp/q3bsp.html
+
+credits also go to Ben Humphrey for his excellent BSP tutorial
+
+I might split this module up. Perhaps rendering performance
+could be increased if i used Vertex Buffer Objects instead of
+vertex arrays?
+
+-}
+
+module BSP (
+   BSPMap(..),
+   readBSP,
+   renderBSP,
+   Tree(..),
+   BSPNode(..),
+   BSPLeaf(..),
+   BSPBrush(..),
+   BSPBrushSide(..),
+   isObjectVisible
+  ) where
+
+import Data.IORef
+import Control.Exception ( bracket )
+import Control.Monad ( liftM, when )
+import System.IO hiding (withBinaryFile)
+import System.IO.Error ( mkIOError, eofErrorType )
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Data.List
+import Data.Typeable
+import Graphics.UI.GLUT
+import BitSet
+import Textures
+import Data.Array
+import qualified Data.Array.MArray  as Arr (readArray, newListArray)
+import qualified Data.Array.IO as IOArr hiding (readArray, newListArray)
+import Frustum
+import Matrix
+import Curves
+import Data.Maybe
+
+-------------------------------------------------------------------------------
+-- lump directory indices
+
+-- Stores texture information
+kTextures :: Int
+kTextures    = 1
+
+-- Stores the splitting planes
+kPlanes     :: Int
+kPlanes      = 2
+
+-- Stores the BSP nodes
+kNodes      :: Int
+kNodes       = 3
+
+-- Stores the leafs of the nodes
+kLeafs :: Int
+kLeafs = 4
+
+-- Stores the leaf's indices into the faces
+kLeafFaces :: Int
+kLeafFaces = 5
+
+-- Stores the leaf's indices into the brushes
+kLeafBrushes :: Int
+kLeafBrushes = 6
+
+-- Stores the brushes info (for collision)
+kBrushes :: Int
+kBrushes = 8
+
+-- Stores the brush surfaces
+kBrushSides :: Int
+kBrushSides = 9
+
+-- Stores the level vertices
+kVertices :: Int
+kVertices = 10
+
+-- Stores the level indices
+kIndices :: Int
+kIndices = 11
+
+-- Stores the faces for the level
+kFaces :: Int
+kFaces = 13
+
+-- Stores the lightmaps for the level
+kLightmaps :: Int
+kLightmaps = 14
+
+-- Stores PVS and cluster info (visibility)
+kVisData      :: Int
+kVisData    = 16
+
+-- A constant to store the number of lumps
+kMaxLumps     :: Int
+kMaxLumps   = 17
+
+-------------------------------------------------------------------------------
+-- types used in this module
+
+data BSPMap = BSPMap {
+     vertexData :: !VertexArrays,
+     vindices   :: !(Ptr GLint),
+     leaves     :: ![BSPLeaf],
+     tree     :: !Tree,
+     visData    :: !(Maybe BSPVisData),
+     bitset     :: !BitSet
+}
+
+type VertexArrays = (Ptr Float,Ptr Float,Ptr Float,Ptr Float,Ptr Word8)
+
+data BSPLeaf = BSPLeaf {
+    cluster    :: !Int,
+    area       :: Int,
+    leafMin    :: (Double,Double,Double),
+    leafMax    :: (Double,Double,Double),
+    leafface     :: Int,
+    numOfLeafFaces   :: Int,
+    leafBrush    :: Int,
+    numOfLeafBrushes :: Int,
+    leafFaces    :: [BSPFace],
+    leafBrushes  :: [BSPBrush]
+} deriving Show
+
+data BSPFace = BSPFace {
+    -- The index into the texture array
+    textureObj     :: Maybe TextureObject,
+    -- The index for the effects (or -1 = n/a)
+    effect         :: Int,
+    -- 1=polygon, 2=patch, 3=mesh, 4=billboard
+    faceType       :: Int,
+    -- The starting index into this face's first vertex
+    startVertIndex :: Int,
+    -- The number of vertices for this face
+    numOfVerts     :: Int,
+    -- The starting index into the indices array for this face
+    startIndex     :: Int,
+    -- The number of indices for this face
+    numOfIndices   :: GLint,
+    -- The texture index for the lightmap
+    lightmapObj    :: Maybe TextureObject,
+    -- The face's lightmap corner in the image
+    lMapCorner     :: (Int,Int),
+    -- The size of the lightmap section
+    lMapSize       :: (Int,Int),
+    -- The 3D origin of lightmap.
+    lMapPos        :: (Float,Float,Float),
+    -- The 3D space for s and t unit vectors.
+    lMapVecs       :: [(Float,Float,Float)],
+    -- The face normal.
+    vNormal        :: (Float,Float,Float),
+    -- The bezier patch dimensions.
+    size           :: (Int,Int),
+    faceNo         :: Int,
+    patch          :: [BSPPatch],
+    arrayPtrs      :: VertexPointers
+} deriving Show
+
+data BSPBrush = BSPBrush {
+    brushSide      :: Int,
+    numOfBrushSides    :: Int,
+    brushSides     :: [BSPBrushSide],
+    bTextureID     :: Int,
+    textureType    :: Int
+} deriving Show
+
+data BSPBrushSide = BSPBrushSide {
+    bsPlane     :: Int,
+    bsPlaneNorm    :: (Double,Double,Double),
+    bsPlaneDist    :: Double,
+    bsTextureID    :: Int
+} deriving Show
+
+data Tree  = Leaf BSPLeaf | Branch BSPNode Tree Tree
+
+data BSPNode = BSPNode {
+    planeNormal :: (Double,Double,Double),
+    dist     :: Double,
+    front    :: Int,
+    back     :: Int,
+    nodeMin  :: (Int,Int,Int),
+    nodeMax  :: (Int,Int,Int)
+} deriving Show
+
+data BSPVisData = BSPVisData {
+    numOfClusters :: Int,
+    bytesPerCluster :: Int,
+    bitSets   :: IOArr.IOUArray Int Bool
+}
+
+data BSPLump = BSPLump {
+    offset :: Int,
+    len  :: Int
+}  deriving Show
+
+data BSPHeader = BSPHeader {
+    strID   :: String,
+    version :: Int
+}  deriving Show
+
+data BSPTexInfo = BSPTexInfo {
+    strName  :: String,
+    flags    :: Int,
+    contents :: Int
+} deriving Show
+
+type VertexData = ([Float],[Float],[Float],[Float],[Word8])
+
+type VertexPointers = (Ptr GLfloat, Ptr GLfloat, Ptr GLfloat, Ptr GLint)
+
+type BSPLeafFace = Int
+
+data BSPPlane = BSPPlane {
+    pNormal  :: (Double,Double,Double),
+    distance :: Double
+} deriving Show
+
+-------------------------------------------------------------------------------
+--BSP rendering
+
+renderBSP :: IORef(BSPMap) -> (Double,Double,Double)-> IO()
+renderBSP mapRef (x,y,z) = do
+   activeTexture $= TextureUnit 0
+   clientActiveTexture $= TextureUnit 0
+   clientState TextureCoordArray $= Enabled
+   texture Texture2D $= Enabled
+
+   activeTexture $= TextureUnit 1
+   clientActiveTexture $= TextureUnit 1
+   clientState TextureCoordArray $= Enabled
+   texture Texture2D $= Enabled
+
+   mp <- readIORef mapRef
+   leaf <- findLeaf (x,y,z) (tree mp)
+   renderBSP' leaf mp
+   return ()
+
+
+-- given a position finds a in the tree where the position lies in
+findLeaf :: (Double, Double,Double) -> Tree -> IO BSPLeaf
+findLeaf (x,y,z) (Branch node left right) = do
+   let (px,py,pz) = (planeNormal node)
+   let d = (dist node)
+   let dstnc = (px*x)+(py*y)+(pz*z)-d
+   case (dstnc >= 0) of
+      True  -> do
+                 leaf <- findLeaf (x,y,z) left
+                 return leaf
+      False -> do
+                 leaf <- findLeaf (x,y,z) right
+                 return leaf
+findLeaf (_,_,_) (Leaf leaf) = return leaf
+
+
+-- we are actually going across all the leaves in the tree
+-- instead of walking the tree and pushing the leaves that
+-- we want to render into a stack
+renderBSP' :: BSPLeaf -> BSPMap -> IO()
+renderBSP' leaf mp = do
+   sze <- sizeBS $ bitset mp
+   newbs <- emptyBS sze
+   frstm <- getFrustum
+   mapM_ (renderLeaves frstm newbs visFunc mp) (leaves mp)
+   renderBSPCleanUp
+       where visFunc = (isClusterVisible (visData mp) (cluster leaf))
+
+
+-- we have to reset the openGL state after rendering
+renderBSPCleanUp :: IO()
+renderBSPCleanUp = do
+    activeTexture $= TextureUnit 1
+    clientState TextureCoordArray $= Disabled
+    texture Texture2D $= Disabled
+    activeTexture $= TextureUnit 0
+    clientActiveTexture $= TextureUnit 0
+    clientState TextureCoordArray $= Disabled
+    texture Texture2D $= Disabled
+
+
+-- renders a BSP leaf if it is visible
+renderLeaves ::
+   Frustum -> BitSet -> (Int -> IO Bool) -> BSPMap -> BSPLeaf -> IO()
+renderLeaves  frstm bitSet func mp leaf  = do
+   clusterVisible <- func (cluster leaf)
+   case (clusterVisible) of
+      True -> case ((boxInFrustum frstm (leafMin leaf) (leafMax leaf))) of
+         True -> renderFaces bitSet mp (leafFaces leaf)
+         _ -> return ()
+      _   -> return()
+
+
+-- is an object visible
+isObjectVisible :: BSPMap -> Vec3 -> Vec3 -> IO Bool
+isObjectVisible bsp (x,y,z) (ox,oy,oz) = do
+   currentLeaf <- findLeaf (x,y,z) (tree bsp)
+   objectLeaf  <- findLeaf (ox,oy,oz) (tree bsp)
+   isVis   <- isClusterVisible
+     (visData bsp) (cluster currentLeaf) (cluster objectLeaf)
+   return (isVis)
+
+isClusterVisible ::Maybe BSPVisData -> Int -> Int -> IO Bool
+isClusterVisible (Just visdata) current target
+    | current < 0 = do
+     return True
+    | target  < 0 = do
+     return False
+    | otherwise   = do
+     Arr.readArray
+       (bitSets visdata)
+          (((bytesPerCluster visdata)*current*8) + target)
+isClusterVisible _ _ _ = return False
+
+renderFaces :: BitSet -> BSPMap -> [BSPFace] -> IO()
+renderFaces _ _ [] = return ()
+renderFaces bitSet mp (face:faces) = do
+    isSet <- (isSetBS bitSet (faceNo face))
+    case (isSet, (faceType face)) of
+      (False, 1) -> do
+          setBS bitSet (faceNo face)
+          renderPolygonFace face (vertexData mp) (vindices mp)
+          renderFaces bitSet mp faces
+      (False, 2) -> do
+          setBS bitSet (faceNo face)
+          renderPatches face
+          renderFaces bitSet mp faces
+      (False, 3) -> do
+          setBS bitSet (faceNo face)
+          renderMeshFace face (vertexData mp) (vindices mp)
+          renderFaces bitSet mp faces
+      (_  , _) -> do
+          renderFaces bitSet mp faces
+
+
+
+
+-------------------------------------------------------------------------------
+-- surface rendering
+
+-- renders a polygon surface
+renderPolygonFace :: BSPFace -> VertexArrays -> Ptr GLint -> IO ()
+renderPolygonFace face (_,_,_,_,_) _ =  do
+   let (a,b,c,d) = arrayPtrs face
+   arrayPointer VertexArray $=
+      VertexArrayDescriptor 3 Float 0 a
+   clientState VertexArray $= Enabled
+
+   activeTexture $= TextureUnit 0
+   clientActiveTexture $= TextureUnit 0
+   arrayPointer TextureCoordArray $=
+      VertexArrayDescriptor 2 Float 0 b
+   textureBinding Texture2D $= (textureObj face)
+
+   activeTexture $= TextureUnit 1
+   clientActiveTexture $= TextureUnit 1
+   arrayPointer TextureCoordArray $=
+      VertexArrayDescriptor 2 Float 0 c
+   textureBinding Texture2D $= (lightmapObj face)
+
+   drawRangeElements Triangles (0,(numOfIndices face))
+      (numOfIndices face) UnsignedInt d
+   --drawElements Triangles (numOfIndices face) UnsignedInt d
+
+
+-- renders a mesh face
+renderMeshFace :: BSPFace -> VertexArrays -> Ptr GLint -> IO ()
+renderMeshFace face (vertexPtr,texturePtr,c,_,_)  vIndex =  do
+   startVIndex <- return (startVertIndex face)
+   arrayPointer VertexArray $=
+      VertexArrayDescriptor 3 Float 0
+         (plusPtr vertexPtr (12*(startVIndex)))
+   clientState VertexArray  $= Enabled
+
+   activeTexture $= TextureUnit 0
+   clientActiveTexture $= TextureUnit 0
+   arrayPointer TextureCoordArray $=
+      VertexArrayDescriptor 2 Float 0
+         (advancePtr texturePtr (2*(startVertIndex face)))
+   clientState TextureCoordArray $= Enabled
+   texture Texture2D $= Enabled
+   textureBinding Texture2D $= (textureObj face)
+
+   activeTexture $= TextureUnit 1
+   clientActiveTexture $= TextureUnit 1
+   arrayPointer TextureCoordArray $=
+      VertexArrayDescriptor 2 Float 0 (plusPtr c (8*(startVIndex)))
+   clientState TextureCoordArray $= Enabled
+   texture Texture2D $= Enabled
+   textureBinding Texture2D $= (lightmapObj face)
+
+   drawRangeElements Triangles (0,fromIntegral (numOfVerts face))
+      (numOfIndices face ) UnsignedInt (plusPtr vIndex (4*(startIndex face)))
+
+
+-- renders patch surfaces
+renderPatches :: BSPFace -> IO()
+renderPatches face = do
+   mapM_ (renderPatch face) (patch face)
+
+
+renderPatch :: BSPFace -> BSPPatch -> IO()
+renderPatch face bsppatch=  do
+   arrayPointer VertexArray $=
+      VertexArrayDescriptor 3 Float 28 (patchPtr bsppatch)
+   clientState VertexArray $= Enabled
+
+   activeTexture $= TextureUnit 0
+   clientActiveTexture $= TextureUnit 0
+   arrayPointer TextureCoordArray $=
+      VertexArrayDescriptor 2 Float 28 (plusPtr (patchPtr bsppatch) 12)
+   clientState TextureCoordArray $= Enabled
+   texture Texture2D $= Enabled
+   textureBinding Texture2D $= (textureObj face)
+
+   activeTexture $= TextureUnit 1
+   clientActiveTexture $= TextureUnit 1
+   arrayPointer TextureCoordArray $=
+      VertexArrayDescriptor 2 Float 28 (plusPtr (patchPtr bsppatch) 20)
+   clientState TextureCoordArray $= Enabled
+   texture Texture2D $= Enabled
+   textureBinding Texture2D $= (lightmapObj face)
+
+   multiDrawElements TriangleStrip (numIndexPtr bsppatch)
+      UnsignedInt (indexPtrPtr bsppatch)
+         (fromIntegral (patchLOD bsppatch))
+
+
+
+-------------------------------------------------------------------------------
+-- reading functions
+
+-- reads a BSP file
+readBSP :: FilePath -> IO(IORef(BSPMap))
+readBSP filePath = withBinaryFile filePath $ \handle -> do
+   readHeader handle
+   lumps           <- mapM (readLump handle)
+                        [ 0 .. (kMaxLumps -1)] :: IO [BSPLump]
+   (a,b,c,d,e)     <- readVertices handle lumps
+   indcs           <- readIndices  handle lumps
+   newbitset       <- createBitset lumps
+   newVertexArrays <- dataToPointers (a,b,c,d,e)
+   indexPtr        <- newArray indcs
+   newNodes        <- readNodes handle lumps
+   newLeaves       <- readLeaves handle lumps newVertexArrays indexPtr
+   newVisData      <- readVisData handle lumps
+   let leafArray = listArray (0,((length newLeaves)-1)) newLeaves
+   let nodeArray = listArray (0,((length newNodes)-1)) newNodes
+   ntree <- constructTree nodeArray leafArray 0
+   bsp <-  (newIORef ( BSPMap  {
+                          vertexData = newVertexArrays,
+                          vindices   = indexPtr,
+                          leaves     = (reverse newLeaves),
+                          tree       = ntree,
+                          visData    = newVisData,
+                          bitset     = newbitset
+   }))
+   return bsp
+
+constructTree :: Array Int BSPNode -> Array Int BSPLeaf -> Int -> IO(Tree)
+constructTree nodes lvs ind = do
+   case (ind >= 0) of
+      True  -> do
+         let currentNode = (nodes ! ind)
+         leftNode  <- constructTree nodes lvs (front currentNode)
+         rightNode <- constructTree nodes lvs (back currentNode)
+         return (Branch currentNode leftNode rightNode)
+      False -> do
+         let currentLeaf = (lvs ! ((-1)*(ind+1)))
+         return (Leaf currentLeaf)
+
+
+createBitset :: [BSPLump] -> IO BitSet
+createBitset lumps = do
+   (_,lngth) <- (getLumpData (lumps !! kFaces))
+   newbitset  <- emptyBS (lngth `div` 104)
+   return newbitset
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the BSP files header information
+
+
+readHeader :: Handle -> IO BSPHeader
+readHeader handle = do
+   buf <- mallocBytes 4
+   hGetBuf handle buf 4
+   iD <- mapM (peekByteOff buf) [ 0 ..  3] :: IO [CChar]
+   hGetBuf handle buf cIntSize
+   ver <- (peek (castPtr buf :: Ptr CInt)) :: IO CInt
+   free buf
+   return (BSPHeader {
+              strID   = map castCCharToChar iD,
+              version = (fromIntegral ver)})
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the lumps in our bsp
+
+readLump :: Handle -> Int -> IO BSPLump
+readLump handle _ = do
+   buf  <- mallocBytes cIntSize
+   hGetBuf handle buf cIntSize
+   offs <- (peek (castPtr buf :: Ptr CInt)) :: IO CInt
+   hGetBuf handle buf cIntSize
+   l    <- (peek (castPtr buf :: Ptr CInt)) :: IO CInt
+   free buf
+   return (BSPLump {offset = (fromIntegral offs),
+                    len    = (fromIntegral l)})
+
+getLumpData :: BSPLump -> IO (Int, Int)
+getLumpData lump = return (offset lump,len lump)
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the nodes
+
+readNodes :: Handle -> [BSPLump] -> IO [BSPNode]
+readNodes handle lumps = do
+   planes <- readPlanes handle lumps
+   let planeArray = listArray (0,((length planes)-1)) planes
+   (offst,lngth) <- (getLumpData (lumps !! kNodes))
+   offs <- getOffsets lngth offst 36
+   nodes <- mapM (readNode handle planeArray) offs
+   return  nodes
+
+readNode :: Handle -> Array Int BSPPlane -> Int -> IO (BSPNode)
+readNode handle planeArray offst = do
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes 4
+   let getCInt  =
+          getAndPeek handle (castPtr buf :: Ptr CInt) (undefined :: CInt)
+   let getCInts =
+          getAndPeeks handle (castPtr buf :: Ptr CInt) (undefined :: CInt)
+   let ints    = liftM toInts (getCInts 3)
+   let get3Ints   = liftM get3t ints
+   plnIndex  <- getCInt
+   frt  <- getCInt
+   bck  <- getCInt
+   nMin <- get3Ints
+   nMax <- get3Ints
+   let pln = planeArray ! (fromIntegral plnIndex)
+   return $ BSPNode {
+               planeNormal = (pNormal pln),
+               dist        = (distance pln),
+               front       = fromIntegral frt,
+               back        = fromIntegral bck,
+               nodeMin     = nMin,
+               nodeMax     = nMax
+            }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the planes in the nodes
+
+readPlanes :: Handle -> [BSPLump] -> IO [BSPPlane]
+readPlanes handle lumps = do
+   (offst,lngth) <- (getLumpData (lumps !! kPlanes))
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes lngth
+   hGetBuf handle buf lngth
+   let ptrs = getPtrs buf lngth 16
+   planes <- mapM readPlane ptrs
+   free buf
+   return planes
+
+readPlane :: Ptr a -> IO (BSPPlane)
+readPlane ptr = do
+   [e1,e2,e3,e4] <- getFloats ptr 4
+   return $ BSPPlane {
+        pNormal  = (fromRational (toRational e1),
+           fromRational (toRational e3),
+           fromRational (toRational ((-1)*e2))),
+        distance = (fromRational (toRational e4))
+   }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the leaves
+
+readLeaves :: Handle -> [BSPLump] -> VertexArrays -> Ptr GLint -> IO [BSPLeaf]
+readLeaves handle lumps vertArrays indcs = do
+   faces              <- readFaces handle lumps vertArrays  indcs
+   let faceArray      =  listArray (0,((length faces)-1))  faces
+   leaffaces          <- readLeafFaces handle lumps
+   let leafFaceArray  =  listArray (0,((length leaffaces)-1)) leaffaces
+   brushes            <- readBrushes handle lumps
+   let brushArray     =  listArray (0,((length brushes)-1)) brushes
+   leafbrushes        <- readLeafBrushes handle lumps
+   let leafBrushArray =  listArray (0,((length leafbrushes)-1)) leafbrushes
+   (offst,lngth)    <- getLumpData (lumps !! kLeafs)
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes lngth
+   hGetBuf handle buf lngth
+   let ptrs = getPtrs buf lngth 48
+   nodes <-
+      mapM (readLeaf leafFaceArray faceArray leafBrushArray brushArray) ptrs
+   free buf
+   return nodes
+
+
+readLeaf ::
+   Array Int Int -> Array Int BSPFace ->
+      Array Int Int -> Array Int BSPBrush ->Ptr a ->IO (BSPLeaf)
+readLeaf leafFaceArray faceArray leafBrushArray brushArray ptr = do
+   [e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12] <- getInts ptr 12
+   let leafIndices  = map (leafFaceArray !) [((e9+e10)-1),((e9+e10)-2)..e9]
+   let faceList     = map (faceArray !) leafIndices
+   let brushIndices = map (leafBrushArray !) [e11..(e11+e12-1)]
+   let brushList    = map (brushArray !) brushIndices
+   return $ BSPLeaf {
+        cluster          = e1,
+        area             = e2,
+        leafMin          = (realToFrac e3,
+                            realToFrac e5,
+                            realToFrac ((-1)*e4)),
+        leafMax          = (realToFrac e6,
+                            realToFrac e8,
+                            realToFrac ((-1)*e7)),
+        leafface         = e9,
+        numOfLeafFaces   = e10,
+        leafBrush        = e11,
+        numOfLeafBrushes = e12,
+        leafFaces        = faceList,
+        leafBrushes      = brushList
+   }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- huge function for reading the faces in our leaves
+
+
+readFaces :: Handle -> [BSPLump] -> VertexArrays -> Ptr GLint -> IO [BSPFace]
+readFaces handle lumps vertArrays indcs = do
+   lightMaps         <- readLightMaps handle lumps
+   let lightMapArray =  listArray (0,((length lightMaps)-1)) lightMaps
+   texInfos          <- readTexInfos handle lumps
+   texFileNames      <- return (map strName texInfos)
+   texObjs           <- getAndCreateTextures texFileNames
+   let texObjArray   =  listArray (0,((length texObjs)-1)) texObjs
+   (offst,lngth)   <- (getLumpData (lumps !! kFaces))
+   offs              <- getOffsets lngth offst 104
+   faces             <- mapM
+     (readFace handle offst lightMapArray texObjArray vertArrays indcs) offs
+   return  faces
+
+
+readFace ::
+  Handle -> Int -> Array Int TextureObject -> Array Int (Maybe TextureObject)->
+     VertexArrays -> Ptr GLint -> Int ->  IO (BSPFace)
+readFace handle origin  lightmaps textures
+  vertArrays@(a1,b1,c1,_,_) indcs offst = do
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes 4
+   let getCInts   =
+          getAndPeeks handle (castPtr buf :: Ptr CInt) (undefined :: CInt)
+   let getCFloats =
+          getAndPeeks handle (castPtr buf :: Ptr CFloat) (undefined :: CFloat)
+   let ints       = liftM toInts (getCInts 4)
+   let get4Ints   = liftM get4t ints
+   let floats     = liftM toFloats (getCFloats 3)
+   let get3Floats = liftM get3t floats
+   let twoInts    = liftM toInts (getCInts 2)
+   let get2Ints   = liftM get2t twoInts
+   (a,b,c,d) <- get4Ints
+   (e,f,g,h) <- get4Ints
+   (i,j,k,l) <- get4Ints
+   lMPos     <- get3Floats
+   lMVec1    <- get3Floats
+   lMVec2    <- get3Floats
+   norms     <- get3Floats
+   sz        <- get2Ints
+   free buf
+   bspPatch <- checkForPatch c d sz vertArrays
+   return BSPFace {
+    textureObj     = textures ! a,
+    effect         = b,
+    faceType       = c,
+    startVertIndex = d,
+    numOfVerts     = e,
+    startIndex     = f,
+    numOfIndices   = fromIntegral g,
+    lightmapObj    = fixLightmap h lightmaps,
+    lMapCorner     = (i, j),
+    lMapSize       = (k, l),
+    lMapPos        = lMPos,
+    lMapVecs       = [lMVec1,lMVec2],
+    vNormal        = norms,
+    size           = sz,
+    faceNo         = (offst - origin)`div` 104,
+    patch          = bspPatch,
+    arrayPtrs      = (plusPtr a1 (12*d),
+                      plusPtr b1 (8*d),
+                      plusPtr c1 (8*d),
+                      plusPtr indcs (4*f))
+    }
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the leafaces that refer to the faces
+
+readLeafFaces :: Handle -> [BSPLump] -> IO [BSPLeafFace]
+readLeafFaces handle lumps = do
+   (offst,lngth) <- (getLumpData (lumps !! kLeafFaces))
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes lngth
+   hGetBuf handle buf lngth
+   leaffaces <- getInts buf (lngth `div` 4)
+   free buf
+   return leaffaces
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the brushes
+
+readBrushes :: Handle -> [BSPLump] -> IO [BSPBrush]
+readBrushes handle lumps = do
+   brushsides         <- readBrushSides handle lumps
+   let brushSideArray =  listArray (0,((length brushsides)-1)) brushsides
+   texInfos           <- readTexInfos handle lumps
+   let texInfoArray   =  listArray (0,((length texInfos)-1)) texInfos
+   (offst,lngth)    <- (getLumpData (lumps !! kBrushes))
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf                <- mallocBytes (lngth)
+   hGetBuf handle buf (lngth)
+   let ptrs           = getPtrs buf (lngth) 12
+   brushes            <- mapM (readBrush brushSideArray texInfoArray) ptrs
+   free buf
+   return brushes
+
+readBrush ::  Array Int BSPBrushSide ->
+   Array Int BSPTexInfo -> Ptr a ->IO (BSPBrush)
+readBrush brushSideArray texInfos ptr = do
+   [e1,e2,e3] <- getInts ptr 3
+   let bSides = map (brushSideArray !) [e1..(e1+e2-1)]
+   return $ BSPBrush {
+      brushSide        = e1,
+      numOfBrushSides  = e2,
+      brushSides       = bSides,
+      bTextureID       = e3,
+      textureType      = (contents (texInfos ! e3))
+   }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the brush sides in our brushes
+
+readBrushSides :: Handle -> [BSPLump] -> IO [BSPBrushSide]
+readBrushSides handle lumps = do
+   planes          <- readPlanes handle lumps
+   let planeArray  =  listArray (0,((length planes)-1)) planes
+   (offst,lngth) <- (getLumpData (lumps !! kBrushSides))
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf             <- mallocBytes (lngth)
+   hGetBuf handle buf (lngth)
+   let ptrs        =  getPtrs buf (lngth) 8
+   brushsides      <- mapM (readBrushSide planeArray) ptrs
+   free buf
+   return brushsides
+
+readBrushSide ::  Array Int BSPPlane -> Ptr a ->IO (BSPBrushSide)
+readBrushSide planeArray ptr = do
+   [e1,e2] <- getInts ptr 2
+   let pln = planeArray ! (fromIntegral e1)
+   return $ BSPBrushSide {
+      bsPlane     = e1,
+      bsPlaneNorm = (pNormal pln),
+      bsPlaneDist = (distance pln),
+      bsTextureID = e2
+   }
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the leaf brushes that refer to the brushes
+
+readLeafBrushes :: Handle -> [BSPLump] -> IO [BSPLeafFace]
+readLeafBrushes handle lumps = do
+   (offst,lngth) <- (getLumpData (lumps !! kLeafBrushes))
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes lngth
+   hGetBuf handle buf lngth
+   leafbrushes <- getInts buf (lngth `div` 4)
+   free buf
+   return leafbrushes
+
+-- - - - - - - - - - - - - - - - - - -
+-- read the PVS visibility information
+
+readVisData :: Handle -> [BSPLump] -> IO (Maybe BSPVisData)
+readVisData handle lumps = do
+   (offst,lngth) <- (getLumpData (lumps !! kVisData))
+   case lngth of
+     0  -> return Nothing
+     _  -> do
+        hSeek handle AbsoluteSeek (fromIntegral offst)
+        buf <- mallocBytes lngth
+        hGetBuf handle buf lngth
+        cInts <- peekArray 2 (castPtr buf :: Ptr CInt)
+        let [numC, bytesPerC] = toInts cInts
+        bitst <- peekArray (numC*bytesPerC) $ plusPtr (castPtr buf :: Ptr Word8) 8
+        bs <-
+           Arr.newListArray (0 ,(numC*bytesPerC*8-1)) (toBools bitst)
+        return (Just BSPVisData {
+                        numOfClusters   = numC,
+                        bytesPerCluster = bytesPerC,
+                        bitSets         = bs
+               })
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads vertex information
+
+
+readVertices :: Handle -> [BSPLump] -> IO VertexData
+readVertices handle lumps = do
+   (offst,lngth) <- getLumpData (lumps !! kVertices)
+   offs            <- getOffsets lngth offst 44
+   verts           <- mapM (readVertex handle) offs
+   (v,t,l,n,r)     <- seperateArrays verts
+   return $ toVertexData (concat v, concat t, concat l, concat n, concat r)
+
+
+readVertex :: Handle -> Int -> IO ([CFloat],[CFloat],[CFloat],[CFloat],[Word8])
+readVertex handle offst = do
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes 4
+   let getCFloats =
+          getAndPeeks handle (castPtr buf :: Ptr CFloat) (undefined :: CFloat)
+   let getWord8s  =
+          getAndPeeks handle (castPtr buf :: Ptr Word8) (undefined :: Word8)
+   let floats = (getCFloats 3)
+   let get3Floats = liftM get3t floats
+   (x,y,z)        <- get3Floats
+   texCoords      <- getCFloats 2
+   lightMapCoords <- getCFloats 2
+   normals        <- getCFloats 3
+   rgbaVal           <- getWord8s  4
+   free buf
+   return ([x,z,(-1)*y],texCoords,lightMapCoords,normals,rgbaVal)
+
+dataToPointers :: VertexData -> IO VertexArrays
+dataToPointers (a,b,c,d,e) = do
+   a1 <- (newArray a)
+   b1 <- (newArray b)
+   c1 <- (newArray c)
+   d1 <- (newArray d)
+   e1 <- (newArray e)
+   return (a1,b1,c1,d1,e1)
+
+seperateArrays :: [([CFloat],[CFloat],[CFloat],[CFloat],[Word8])] ->
+   IO ([[CFloat]],[[CFloat]],[[CFloat]],[[CFloat]],[[Word8]])
+seperateArrays verts = return (unzip5 verts)
+
+toVertexData :: ([CFloat],[CFloat],[CFloat],[CFloat],[Word8]) -> VertexData
+toVertexData (a,b,c,d,e) = (toFloats a,toFloats b,toFloats c,toFloats d,e)
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads lightmaps
+
+
+readLightMaps :: Handle -> [BSPLump] -> IO [TextureObject]
+readLightMaps handle lumps = do
+   (offst,lngth) <- (getLumpData (lumps !! kLightmaps))
+   offs <- getOffsets lngth offst 49152
+   mapM (readLightMap handle) offs
+
+readLightMap :: Handle -> Int -> IO TextureObject
+readLightMap handle offst = do
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes 49152 :: IO (Ptr Word8)
+   hGetBuf handle buf 49152
+   mapM (adjustRGB buf 5.0) [0..((16384)-1)]
+   texObj <-createLightmapTexture buf
+   return texObj
+
+createLightmapTexture :: Ptr Word8 -> IO TextureObject
+createLightmapTexture ptr = do
+   [texName] <- genObjectNames 1
+   rowAlignment  Unpack $= 1
+   textureBinding Texture2D $= Just texName
+   build2DMipmaps
+     Texture2D RGB'
+        (fromIntegral (128 :: Int)) (fromIntegral (128 :: Int))
+            (PixelData RGB UnsignedByte ptr)
+   textureFilter  Texture2D $= ((Linear', Just Nearest), Linear')
+   textureFunction $= Modulate
+   free ptr
+   return texName
+
+
+-- adjusts the brightness of the lightmap
+adjustRGB :: Ptr Word8 -> Float -> Int -> IO ()
+adjustRGB lightMap factor offst = do
+   ptr <- return (advancePtr lightMap (3*offst))
+   [r,g,b] <- (peekArray 3 ptr)
+   (r2,tempr) <- scaleRGB (((realToFrac r)*factor)/255) 1
+   (g2,tempg) <- scaleRGB (((realToFrac g)*factor)/255) tempr
+   (b2,tempb) <- scaleRGB (((realToFrac b)*factor)/255) tempg
+   byter2 <- return $ fromIntegral $ (truncate (r2 *  tempb * 255.0) :: Int)
+   byteg2 <- return $ fromIntegral $ (truncate (g2 * tempb * 255.0) :: Int)
+   byteb2 <- return $ fromIntegral $ (truncate (b2 * tempb * 255.0) :: Int)
+   pokeArray (advancePtr lightMap (3*offst)) [byter2,byteg2,byteb2]
+
+
+scaleRGB :: Float -> Float -> IO (Float,Float)
+scaleRGB clr scl = do
+                     if ((clr > 1.0) && ((1.0/clr) < scl))
+                        then return (clr, 1.0/clr)
+                      else
+                         return (clr, scl)
+
+fixLightmap ::
+    Int -> Array Int TextureObject -> Maybe TextureObject
+fixLightmap ind arr
+    | ind < 0 = Nothing
+    | otherwise = Just (arr ! ind)
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the texture information
+
+
+readTexInfos :: Handle -> [BSPLump] -> IO [BSPTexInfo]
+readTexInfos handle lumps = do
+   (offst,lngth) <- (getLumpData (lumps !! kTextures))
+   offs <- getOffsets lngth offst 72
+   mapM (readTexInfo handle) offs
+
+readTexInfo :: Handle -> Int -> IO (BSPTexInfo)
+readTexInfo handle offst = do
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf <- mallocBytes 64 :: IO (Ptr CChar)
+   hGetBuf handle buf 64
+   str <- peekCAString buf
+   hSeek handle AbsoluteSeek ((fromIntegral offst) + 64)
+   let getCInt =
+         getAndPeek handle (castPtr buf :: Ptr CInt) (undefined :: CInt)
+   flgs <- getCInt
+   cons <- getCInt
+   free buf
+   return BSPTexInfo {
+      strName  = str,
+      flags  = (fromIntegral flgs),
+      contents = (fromIntegral cons)
+    }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the indices to the vertex array
+
+
+readIndices :: Handle -> [BSPLump] -> IO [GLint]
+readIndices handle lumps = do
+   (offst,lngth) <- (getLumpData (lumps !! kIndices))
+   hSeek handle AbsoluteSeek (fromIntegral offst)
+   buf   <- mallocBytes lngth
+   hGetBuf handle buf lngth
+   indces <- mapM
+     (peekElemOff (castPtr buf :: Ptr CInt))
+         [ 0 .. ((lngth `div` 4)-1)] :: IO [CInt]
+   free buf
+   return $ map fromIntegral indces
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+
+getAndPeek :: (Storable a, Typeable a) => Handle -> Ptr a -> a -> IO a
+getAndPeek handle buf be = do
+   bytesRead <- hGetBuf handle buf (sizeOf be)
+   when (bytesRead /= (sizeOf be)) $
+      ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing
+   val <- (peek buf)
+   return val
+
+getAndPeeks :: (Storable a, Typeable a) =>
+   Handle -> Ptr a -> a -> Int -> IO [a]
+getAndPeeks handle buf be i =
+   mapM (\_ -> getAndPeek handle buf be) [1..i]
+
+withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a
+withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose
+
+getOffsets :: Int -> Int -> Int -> IO [Int]
+getOffsets lngth off sze = return $ map ((off+) . (sze*)) [0.. ((lngth `div` sze)-1)]
+
+toInts :: (Integral a)=>[a] -> [Int]
+toInts a = map fromIntegral a
+
+toFloats :: (Real a) => [a] -> [Float]
+toFloats a = map realToFrac a
+
+get2t :: [a] -> (a, a)
+get2t list = (list !! 0, list !! 1)
+
+get3t :: [a] -> (a, a, a)
+get3t list = (list !! 0, list !! 1, list !! 2)
+
+get4t :: [a] -> (a, a, a, a)
+get4t list = (list !! 0, list !! 1, list !! 2, list !! 3)
+
+toBools :: [Word8] -> [Bool]
+toBools list =
+   [ y | x<-list, y <- map (testBit x) [0..7]]
+
+getInts :: Ptr a -> Int -> IO [Int]
+getInts ptr n = do
+   ints <- peekArray n (castPtr ptr:: Ptr CInt)
+   return $ toInts ints
+
+getFloats :: Ptr a -> Int -> IO [Float]
+getFloats ptr n = do
+   floats <- peekArray n (castPtr ptr :: Ptr CFloat)
+   return $ toFloats floats
+
+cIntSize :: Int
+cIntSize = (sizeOf (undefined :: CInt))
+
+getPtrs :: Ptr a -> Int -> Int -> [Ptr a]
+getPtrs ptr lngth sze = map ((plusPtr ptr) . (sze *)) [0.. ((lngth `div` sze) - 1)]
+
+
+ src/BitSet.hs view
@@ -0,0 +1,30 @@+{-+   An extremely simple and inefficient implementation of bit sets.+   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de+-}++module BitSet where++import Monad (liftM)+import Data.Array.IO (IOUArray, newArray, writeArray, readArray, getBounds, rangeSize)++newtype BitSet = BitSet (IOUArray Int Bool)++emptyBS :: Int -> IO BitSet+emptyBS size = liftM BitSet $ newArray (0, size-1) False++clearBS :: BitSet -> Int -> IO ()+clearBS (BitSet bs) i = writeArray bs i False++clearAllBS :: BitSet -> IO ()+clearAllBS bs = sizeBS bs >>= \size -> mapM_ (clearBS bs) [0 .. size - 1]++setBS :: BitSet -> Int -> IO ()+setBS (BitSet bs) i = writeArray bs i True++isSetBS :: BitSet -> Int -> IO Bool+isSetBS (BitSet bs) = readArray bs++sizeBS :: BitSet -> IO Int+sizeBS (BitSet bs) = getBounds bs >>= return . rangeSize+
+ src/Camera.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns #-}
+
+-- Camera.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+-- Functions to manipulate a camera
+
+module Camera where
+
+import Matrix
+import qualified AFRPGeometry as P
+import PhysicalDimensions
+import Graphics.UI.GLUT
+
+data Camera = Camera {cpos      :: !(Double,Double,Double),
+                      viewPos   :: !(Double,Double,Double),
+                      upVec     :: !(Double,Double,Double)
+                     } deriving (Show,Read)
+
+-- initialise a camera
+initCamera ::(Real a) => (a, a, a)-> (a, a, a) -> (a, a, a) -> Camera
+initCamera  (a,b,c) (d,e,f) (g,h,i) =
+   Camera {cpos    = ((realToFrac a),(realToFrac b),(realToFrac c)),
+           viewPos = ((realToFrac d),(realToFrac e),(realToFrac f)),
+           upVec   = ((realToFrac g),(realToFrac h),(realToFrac i))}
+
+
+-- convert from a tuple of doubles to an OpenGL vector
+toVector3 :: Vec3 -> Vector3 GLdouble
+toVector3 (a,b,c) =  Vector3 a b c
+
+
+-- convert from a tuple of doubles to an OpenGL vertex
+toVertex3 :: Vec3 -> Vertex3 GLdouble
+toVertex3 (a,b,c) =  Vertex3 a b c
+
+
+-- gets OpenGL to assume the view of the camera
+cameraLook :: Camera -> IO()
+cameraLook camera = do
+   let headPos  = vectorAdd (0,30,0) (cpos camera)
+   let headView = vectorAdd (0,30,0) (viewPos camera)
+   lookAt (toVertex3 headPos) (toVertex3 headView) (toVector3 (upVec camera))
+
+
+-- sets the view vector of the camera based on the displacement
+-- of the cursor from the center of the screent. Hardcoded to
+-- work at resolutions of 640x480
+setView :: (Position2, Camera) -> (Camera)
+setView ((P.Point2 x y),cam) =
+  let cam1 =
+        rotateView cam ((realToFrac (240 - y))/ 250.0)
+          (normalise (crossProd (vectorSub (viewPos cam) (cpos cam)) (upVec cam)))
+  in rotateView cam1 ((realToFrac (320 - x))/ 250.0) (0,1,0)
+
+
+-- gets the vector from the players "muzzle point" to
+-- infinity along the view vector. The muzzle point
+-- isn't at the tip of the gun, its actually close
+-- just a bit to the right of the start of the view vector
+-- . It just creates the illusion that its being fired from
+-- the players gun
+firePos :: Vec3 -> Vec3 -> (Vec3,Vec3)
+firePos (x,y,z) (vx,vy,vz) =
+      let (sx,sy,sz) = normalise $
+              crossProd (normalise $ vectorSub (vx,vy,vz) (x,y,z)) (0,1,0)
+          (vsx,vsy,vsz) = normalise $
+              crossProd (normalise $ vectorSub (vx,vy,vz) (x,y,z)) (sx,sy,sz)
+          (sx1,sy1,sz1) = vectorAdd (2*sx,2*sy,2*sz) (x,(y+30),z)
+          (sx2,sy2,sz2) = vectorAdd (2*vsx,2*vsy,2*vsz) (sx1,sy1,sz1)
+          infin = ((x+(15000000*(vx-x))),
+                   ((y+30)+(15000000*((vy+30)-(y+30)))),
+                   (z+(15000000*(vz-z))))
+          (_,_,_) = normalise $ vectorSub (sx2,sy2,sz2) infin
+      in ((sx2,sy2,sz2),infin)
+
+
+-- rotates the view vector along a vector
+rotateView :: Camera -> Double -> Vec3 -> Camera
+rotateView cam angle (x,y,z)=
+   let
+     (viewX,viewY,viewZ) = vectorSub (viewPos cam) (cpos cam)
+     cosTheta = cos angle
+     sinTheta = sin angle
+     minusCosTheta = 1 - cosTheta
+     nextViewX = (cosTheta   + minusCosTheta*x*x)*viewX +
+                 (minusCosTheta*x*y - z*sinTheta)*viewY +
+                 (minusCosTheta*x*z + y*sinTheta)*viewZ
+     nextViewY = (minusCosTheta*x*y + z*sinTheta)*viewX +
+                 (cosTheta   + minusCosTheta*y*y)*viewY +
+                 (minusCosTheta*y*z - x*sinTheta)*viewZ
+     nextViewZ = (minusCosTheta*x*y - y*sinTheta)*viewX +
+                 (minusCosTheta*y*z + x*sinTheta)*viewY +
+                 (cosTheta   + minusCosTheta*z*z)*viewZ
+     (nVx,nVy,nVz) = vectorAdd (cpos cam) (nextViewX, nextViewY, nextViewZ)
+   in Camera {cpos=(cpos cam), viewPos=(nVx, nVy, nVz), upVec = (upVec cam)}
+
+
+-- moves the camera along the view vector
+move :: (Double,Camera) -> Camera
+move (speed,cam) =
+  let
+     (x,y,z)       = (cpos cam)
+     (vpx,vpy,vpz) = (viewPos cam)
+     (vx,vy,vz)    = normalise (vectorSub (viewPos cam) (cpos cam))
+     newx = (vx*speed)
+     newy = (vy*speed)
+     newz = (vz*speed)
+     newvx = (vx*speed)
+     newvy = (vy*speed)
+     newvz = (vz*speed)
+  in Camera {cpos    = (x+newx,y+newy,z+newz),
+             viewPos = (vpx+newvx,vpy+newvy,vpz+newvz),
+             upVec   = (upVec cam)}
+
+
+-- moves the camera pependicular to the view vector
+strafe :: (Double,Camera) -> Camera
+strafe (speed,cam) =
+   let
+      (sx,_,sz) =
+         normalise (crossProd (vectorSub (viewPos cam) (cpos cam)) (upVec cam))
+      (x,y,z) = (cpos cam)
+      (vx,vy,vz) = (viewPos cam)
+      newx = x + (sx*speed)
+      newz = z + (sz*speed)
+      newvx = vx + (sx*speed)
+      newvz = vz + (sz*speed)
+   in Camera {cpos    = (newx, y, newz),
+              viewPos = (newvx, vy, newvz),
+              upVec   = (upVec cam)}
+
+
+-- sets the position of the camera
+setPos :: Vec3 -> Camera-> Camera
+setPos vec cam =
+   Camera {cpos    = vec,
+           viewPos = (viewPos cam),
+           upVec   = (upVec cam)}
+
+
+-- lowers the camera along the y-axis
+dropCam :: (Camera,Double) -> Camera
+dropCam (cam,vel) =
+   let cam1 = setPos (vectorAdd (cpos cam) (0,vel,0)) cam
+   in setViewPos (vectorAdd (viewPos cam1) (0,vel,0)) cam1
+
+
+-- sets the target position the camera is looking at
+setViewPos :: Vec3 -> Camera-> Camera
+setViewPos vec cam =
+   Camera {cpos    = (cpos cam),
+           viewPos = vec,
+           upVec   = (upVec cam)}
+
+
+ src/Collision.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE BangPatterns #-}
+
+{- Collision.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+Collision detection with BSP
+
+A tutorial for collision detection along with source code can be found at
+
+http://www.devmaster.net/articles/quake3collision/
+-}
+
+module Collision (clipCamera, clipObject, clipRay, CollisionType(..)) where
+
+
+import BSP
+import Matrix
+import Camera
+
+data CollisionType = Box !Vec3 !Vec3 !Vec3 | SphereT !Double
+
+epsilon :: Double
+epsilon = 0.03125
+
+-------------------------------------------------------------------------------
+-- Movement clipping
+
+
+-- clips a camera against the environment
+clipCamera :: BSPMap -> Camera -> Camera -> (Camera, Bool)
+clipCamera mp newcam oldcam =
+   let
+     (colPos,_,ground,nsteps) =
+         traceStep (createBox (-20, -50, -20) (20, 50, 20))
+            mp (cpos oldcam) (cpos newcam)
+     diffp    = vectorSub colPos (cpos oldcam)
+     newv     = vectorAdd diffp  (viewPos oldcam)
+     stepPos  = vectorAdd colPos (0,nsteps,0)
+     stepView = vectorAdd newv   (0,nsteps,0)
+   in (Camera {cpos    = stepPos,
+               viewPos = stepView,
+               upVec   = (0,1,0)}, ground)
+
+-- clips an object against the environment
+clipObject :: BSPMap -> Vec3 -> Vec3 -> Vec3 -> (Vec3, Bool)
+clipObject mp pos oldpos (sx,sy,sz) =
+   let
+     (colPos,_,ground,_) =
+         traceStep (createBox (-sx, -sy, -sz) (sx,sy,sz)) mp oldpos pos
+   in (colPos, ground)
+
+
+-- clips a ray against the environment
+clipRay :: BSPMap -> Vec3 -> Vec3 -> Vec3 -> (Vec3, Bool)
+clipRay mp pos oldpos (_,_,_) =
+   let
+     (colPos,collided,_,_) =
+         traceo (createSphere 0) mp oldpos pos
+   in (colPos, collided)
+
+
+-------------------------------------------------------------------------------
+-- Tracing functions
+
+-- Note: If your movement vector is too small you might move through walls
+-- or fall through the floor. If your movement vector is too large you won't
+-- be able to move at all.
+
+
+-- allows an object to step across low obstacles
+traceStep :: CollisionType -> BSPMap -> Vec3 -> Vec3 -> (Vec3,Bool,Bool,Double)
+traceStep cType mp start end
+   | (col && step) =
+     let (nsteps,finalPos) = tryToStep cType mp newPos end 1 15
+     in (finalPos, col, ground, nsteps)
+   |otherwise = (newPos, col, ground, 0)
+   where (newPos, col,step,ground,_) =  trace cType mp start end
+
+
+-- returns the point where the collision occured, no sliding or stepping
+traceo ::  CollisionType -> BSPMap -> Vec3 -> Vec3 -> (Vec3,Bool,Bool,Bool)
+traceo cType mp start end
+   |(newRatio /= 1.0) = (
+       vectorAdd
+          start
+            (vectorMult (vectorSub end start) newRatio),hasCol,step,grounded)
+   | otherwise = (end,False,step,grounded)
+   where
+      (hasCol,step,grounded,newRatio,(_,_,_)) =
+          fixCheck $
+            (checkNode cType
+                  (False,False,False,1.0,(0.0,0.0,0.0))
+                      (tree mp) 0.0 1.0 start end)
+
+
+-- allows an object to slide against the environment
+trace ::  CollisionType -> BSPMap -> Vec3 -> Vec3 -> (Vec3,Bool,Bool,Bool,Vec3)
+trace  cType mp start end
+   | (newRatio /= 1.0) =
+      let newPos  = vectorAdd start (vectorMult (vectorSub end start) newRatio)
+          moveVec = vectorSub end newPos
+          dst    = dotProd moveVec newNorm
+          end2    = vectorSub end $ vectorMult newNorm dst
+          (newPos2,_,_,_,(n2x,n2y,n2z)) = trace cType mp newPos end2
+      in case (n2y > 0.2 || (grounded)) of
+          True -> (newPos2, True,step,True ,(n2x,n2y,n2z))
+          _    -> (newPos2, True,step,False,(n2x,n2y,n2z))
+   | otherwise = (end,False,step,grounded,newNorm)
+   where
+      (_,step,grounded,newRatio,newNorm@(_,_,_)) =
+         fixCheck $
+            (checkNode
+                cType
+                   (False,False,False,1.0, (0.0,0.0,0.0))
+                      (tree mp) 0.0 1.0 start end)
+
+
+
+
+-------------------------------------------------------------------------------
+
+
+-- creates an AABB for use in collision detection
+createBox :: Vec3 -> Vec3 -> CollisionType
+createBox v1 v2 = Box v1 v2 (getBoxExtents v1 v2)
+
+
+-- creates a sphere for collision detection
+createSphere :: Double ->  CollisionType
+createSphere rad = SphereT rad
+
+
+-- gets the largest ends of the box
+getBoxExtents :: Vec3 -> Vec3 -> Vec3
+getBoxExtents (x,y,z) (x1,y1,z1) =
+   (max (-x) x1,max (-y) y1, max (-z) z1)
+
+
+getBoxOffs :: Vec3 -> Vec3 -> Double
+getBoxOffs (x,y,z) (x1,y1,z1) =
+   (abs (x*x1))+(abs (y*y1))+(abs (z*z1))
+
+
+getOffset :: CollisionType -> Vec3 -> Double
+getOffset (Box _ _ extents) plane = getBoxOffs extents plane
+getOffset (SphereT rad) _ = rad
+
+
+fixCheck ::
+   Maybe (Bool, Bool, Bool, Double, Vec3) ->
+      (Bool, Bool, Bool, Double, Vec3)
+fixCheck (Just a) = a
+fixCheck Nothing = (False,False,False,1.0, (0.0,0.0,0.0))
+
+
+-- checks if we can step across a low obstacle
+tryToStep ::
+   CollisionType -> BSPMap ->
+      Vec3 -> Vec3 ->
+         Double -> Double  -> (Double,Vec3)
+tryToStep  cType mp (x,y,z) (x1,y1,z1) i maxheight
+   | i < maxheight =
+     let (pos,col,_,_,_) = trace cType mp  (x,y+i,z) (x1,y1+i,z1)
+     in case (col) of
+           False -> (i,pos)
+           _     -> tryToStep cType mp (x,y,z) (x1,y1,z1) (i+1) maxheight
+   | otherwise = (0,(x,y,z))
+
+-------------------------------------------------------------------------------
+-- checks for collisions with brushes
+
+checkBrushes ::
+   CollisionType -> (Bool, Bool, Bool, Double,Vec3) ->
+      Tree -> Vec3 -> Vec3 ->
+         Maybe (Bool, Bool, Bool, Double, Vec3)
+checkBrushes cType _ (Leaf leaf) start end =
+   case (map (checkBrush start end cType) (leafBrushes leaf)) of
+      []     -> Nothing
+      [r]    -> r
+      (r:rs) -> foldr brushCompare r rs
+checkBrushes _ _ (Branch _ _ _) _ _ = Nothing
+
+checkBrush ::
+   Vec3-> Vec3 -> CollisionType ->
+      BSPBrush -> Maybe (Bool,Bool,Bool,Double,Vec3)
+checkBrush  start end cType brush
+   |((numOfBrushSides brush) > 0) && ((textureType brush)==1) =
+     let colout =
+            checkBrushSides
+               start end cType
+                  False False False False
+                     (-1.0) (1.0) (0,0,0) (brushSides brush)
+     in case colout of
+           Just (out,collided,step,grounded,startR,endR,newNorm) ->
+              case (startR < endR && startR > -1  && out) of
+                 True -> Just (collided,step,grounded,fixRatio startR,newNorm)
+                 _    -> Nothing
+           _  -> Nothing
+   |otherwise = Nothing
+   where
+      fixRatio x
+        | x < 0.0 = 0.0
+        | otherwise = x
+
+
+-- we use this function to compare the results
+-- of a brush check so that we get the closest
+-- collision
+brushCompare ::
+   Maybe (Bool, Bool, Bool, Double, Vec3) ->
+      Maybe (Bool, Bool, Bool, Double, Vec3) ->
+         Maybe (Bool, Bool, Bool, Double, Vec3)
+brushCompare (Just (a1,b1,c1,d1,e1)) (Just(a2,b2,c2,d2,e2))
+     | d1 < d2   = Just (a1 || a2, b1 || b2, c1 || c2, d1, e1)
+     | otherwise = Just (a1 || a2, b1 || b2, c1 || c2, d2, e2)
+brushCompare (Just a) Nothing = Just a
+brushCompare Nothing (Just b) = Just b
+brushCompare Nothing Nothing = Nothing
+
+
+-- this checks if we have collided with a brush
+checkBrushSides ::
+   Vec3 -> Vec3 -> CollisionType->
+      Bool -> Bool -> Bool -> Bool -> Double ->
+         Double -> Vec3 -> [BSPBrushSide] ->
+            (Maybe (Bool,Bool,Bool,Bool,Double,Double,Vec3))
+checkBrushSides  (_,_,_) (_,_,_)
+   _ out collided step ground startR endR cNorm [] =
+      Just (out,collided,step,ground,startR,endR,cNorm)
+checkBrushSides  start@(x,_,z) end@(x1,_,z1)
+   cType out collided step ground startR endR cNorm (b:bs)
+   | startDist >  0 && endDist >  0 = Nothing
+   | startDist <= 0 && endDist <= 0 = continue
+   | startDist > endDist =
+         case (ratio1 > startR) of
+            True -> (checkBrushSides start end cType checkout
+                        True mayStep grounded ratio1 endR (bsPlaneNorm b) bs)
+            _    -> continue
+   | otherwise =
+         case (ratio2 < endR) of
+            True -> (checkBrushSides start end cType checkout
+                        collided step ground startR ratio2 cNorm bs)
+            _    -> continue
+   where
+      checkout
+          | startDist > 0 = True
+          | otherwise = out
+      mayStep
+          | ((x /= x1 || z /= z1) && planey /= 1) = True
+          | otherwise = step
+      grounded
+          | planey >= 0.2 = True
+          | otherwise = ground
+      get2nd3 (_,q,_) = q
+      planey    = get2nd3 (bsPlaneNorm b)
+      ratio1    = (startDist - epsilon) / (startDist - endDist)
+      ratio2    = (startDist + epsilon) / (startDist - endDist)
+      continue  = checkBrushSides start end cType checkout
+                        collided step ground startR endR cNorm bs
+      startDist = vDist start cType (bsPlaneNorm b) (bsPlaneDist b)
+      endDist   = vDist end   cType (bsPlaneNorm b) (bsPlaneDist b)
+
+
+vDist :: Vec3 -> CollisionType -> Vec3 -> Double  ->  Double
+vDist vec box@(Box _ _ _) pnorm pdist =
+   (dotProd (vectorAdd vec (getVOffs pnorm box)) pnorm) - pdist
+vDist vec (SphereT rad) pnorm pdist =
+   (dotProd vec pnorm) - (pdist + rad)
+
+
+getVOffs:: Vec3 -> CollisionType  -> Vec3
+getVOffs (p1,p2,p3) (Box (x,y,z) (x1,y1,z1) _) =
+   (chooseMin' p1 x x1,chooseMin' p2 y y1, chooseMin' p3 z z1)
+   where
+      chooseMin' p mn mx
+         | p < 0 = mx
+         | otherwise = mn
+getVOffs (_, _, _) (SphereT _) = (0,0,0)
+
+-------------------------------------------------------------------------------
+-- recurse down the bsp tree checking for collisions
+
+checkNode ::
+   CollisionType -> (Bool,Bool,Bool,Double,Vec3) ->
+      Tree -> Double-> Double -> Vec3 -> Vec3 ->
+         Maybe (Bool,Bool,Bool,Double,Vec3)
+checkNode cType cState (Leaf leaf) _ _ start end =
+   checkBrushes cType cState (Leaf leaf)  start end
+checkNode cType cState (Branch node left right) startRatio endRatio start end =
+   let
+     sDist = (dotProd (planeNormal node) start) - (dist node)
+     eDist = (dotProd (planeNormal node) end)   - (dist node)
+   in recurse sDist eDist
+   where
+      boffset = getOffset cType (planeNormal node)
+      recurse sDist eDist
+         |(sDist >= boffset && eDist >= boffset) =
+            checkNode cType cState left  sDist eDist start end
+         |(sDist < ((-1)*boffset) && eDist < ((-1)*boffset)) =
+            checkNode cType cState right sDist eDist start end
+         |otherwise = split cType cState sDist eDist
+                         startRatio endRatio
+                            start end (Branch node left right)
+
+
+-- splits the movement vector if it lies on both sides of a splitting plane
+split ::
+   CollisionType -> (Bool,Bool,Bool,Double,Vec3) ->
+      Double -> Double -> Double -> Double ->
+         Vec3 -> Vec3 -> Tree -> Maybe (Bool,Bool,Bool,Double,Vec3)
+split cType cState startDist endDist startRatio endRatio
+   start end (Branch node left right)
+   | startDist < endDist =
+       let
+          result1 =
+             checkNode cType cState
+                right startRatio (middleR r1) start (middleV r1)
+          result2 =
+             checkNode cType cState
+                left (middleR r2) endRatio (middleV r2) end
+       in brushCompare result1 result2
+   | startDist > endDist =
+       let
+          result1 =
+             checkNode cType cState
+                left  startRatio (middleR r2) start (middleV r2)
+          result2 =
+             checkNode cType cState
+                right (middleR r1) endRatio (middleV r1) end
+       in brushCompare result1 result2
+   | otherwise =
+       let
+          result1 =
+             checkNode cType cState
+                left  startRatio (middleR 1.0) start (middleV 1.0)
+          result2 =
+             checkNode cType cState
+                right (middleR 0.0) endRatio (middleV 0.0) end
+     in brushCompare result1 result2
+   where
+      inverseDist = 1.0/(startDist - endDist)
+      boffset = getOffset cType (planeNormal node)
+      r1 = fixDouble $ (startDist - boffset - epsilon)*inverseDist
+      r2 = fixDouble $ (startDist + boffset + epsilon)*inverseDist
+      middleR = getMiddleRatio startRatio endRatio
+      middleV = getHalfVec start end
+      fixDouble x
+         | x < 0.0 = 0.0
+         | x > 1.0 = 1.0
+         | otherwise = x
+split _ _ _ _ _ _ _ _ (Leaf _) = Nothing
+
+getMiddleRatio :: Double -> Double -> Double -> Double
+getMiddleRatio startRatio endRatio ratio =
+   startRatio + (ratio * (endRatio - startRatio))
+
+
+getHalfVec :: Vec3 -> Vec3 -> Double -> Vec3
+getHalfVec start end ratio =
+   vectorAdd start (mapTup (ratio*) (vectorSub end start))
+
+
+ src/Command.hs view
@@ -0,0 +1,27 @@+{- $Id: Command.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*						 I N V A D E R S						  *+*															  *+*	   Module:		Command							*+*	   Purpose:	The Invader command type.				*+*	   Author:		Henrik Nilsson 					*+*															  *+*		    Copyright (c) Yale University, 2003 					  *+*															  *+******************************************************************************+-}++module Command (+    Command(..)+) where+++data Command =+	 CmdQuit				-- Quit Invaders.+    | CmdNewGame			-- Play game.+    | CmdFreeze				-- Freeze game.+    | CmdResume				-- Resume game.+    -- | CmdUp 			   -- Move Up.+    -- | CmdDown			   -- Move Down.+    -- | CmdLeft			   -- Move Left.+    -- | CmdRight			   -- Move Right.
+ src/Curves.hs view
@@ -0,0 +1,201 @@+{-Curves.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This modules is used to generate a biquadratic patch used in the
+Q3Map2 format.
+
+The code for this was translated from
+
+http://graphics.cs.brown.edu/games/quake/quake3.html
+
+it can also be found in the source code for Paul's Quake 3 BSP loader
+
+http://www.paulsprojects.net/opengl/q3bsp/q3bsp.html
+
+-}
+
+
+module Curves (checkForPatch, BSPPatch(..)) where
+
+import Foreign hiding (newArray)
+import Data.Array.IArray
+-- import Data.Array.MArray (newArray)
+import Data.Array.IO
+import Graphics.UI.GLUT (GLint, GLsizei)
+import Foreign.Storable
+
+
+data BSPPatch = BSPPatch {
+           patchLOD    :: Int,               -- the level of tesselation
+           patchPtr    :: Ptr Float,         -- points to patch vertices
+           indexPtrPtr :: Ptr (Ptr GLint),  -- points to indices
+           numIndexPtr :: Ptr GLsizei       -- the number of indices
+           } deriving Show
+
+
+-- given a face type return a list of patches if the facetype is 2.
+-- Otherwise return an empty list.
+checkForPatch :: Int -> Int -> (Int, Int) ->
+   (Ptr Float, Ptr Float, Ptr Float,Ptr Float, Ptr Word8)
+          -> IO [BSPPatch]
+checkForPatch faceType startVIndex (width,height) vertData
+   |faceType == 2 = do
+          patches <- createPatches vertData startVIndex width height 4
+          return patches
+   |otherwise = return []
+
+
+-- Create control points for each patch.
+-- Each patch has 9 control points.
+getControlPointIndices :: Int -> Int -> Int -> [Int]
+getControlPointIndices  i width height =
+   concat [(create3x3ControlPoints x y)|
+                    y <-[0..(((height-1) `div` 2)-1)],
+                    x <-[0..(((width-1)  `div` 2)-1)]]
+   where
+         create3x3ControlPoints x y =
+            [(i+((y*2*width)+(x*2))+(row*width)+point) |
+                   row   <- [0..2],
+                   point <- [0..2]]
+
+
+-- Take a list of control points and split them into lists of 9
+splitControlPoints :: [VertTup] -> [[VertTup]]
+splitControlPoints [] = []
+splitControlPoints tups = (take 9 tups):(splitControlPoints $ drop 9 tups)
+
+
+-- gets the control points
+getControlPoints  :: (Ptr Float, Ptr Float, Ptr Float, Ptr Float, Ptr Word8) ->
+   Int -> Int -> Int -> IO [Array Int VertTup]
+getControlPoints vertexData startIndex width height = do
+   -- get the indices for the control points
+   let indcs = getControlPointIndices  startIndex width  height
+   -- get the vertices at those indices
+   controlPoints <- mapM (readControlPoints vertexData) indcs
+   -- divide the lists into arrays of 9 control points
+   return $ map (listArray (0,8)) (splitControlPoints controlPoints)
+
+-- reads the control point information from the vertex arrays
+readControlPoints :: (Ptr Float, Ptr Float, Ptr Float,Ptr Float, Ptr Word8) ->
+   Int -> IO VertTup
+readControlPoints  (vert, uv, lmuv, _, _) i = do
+   x   <- peekElemOff vert  vertIndex     -- vertex coord
+   y   <- peekElemOff vert (vertIndex+1)
+   z   <- peekElemOff vert (vertIndex+2)
+   u   <- peekElemOff uv    uvIndex       -- tex coord
+   v   <- peekElemOff uv   (uvIndex+1)
+   lmu <- peekElemOff lmuv  lmIndex       -- lightmap coord
+   lmv <- peekElemOff lmuv (lmIndex+1)
+   return (x,y,z,u,v,lmu,lmv)
+   where
+         vertIndex = i*3
+         uvIndex         = i*2
+         lmIndex         = i*2
+
+
+-- write the coordinate, texture coordinate and lightmap coordinates
+-- for the cntrol points
+writeControlPointData :: [VertTup] -> Int -> Ptr Float -> IO ()
+writeControlPointData  [] _ _ = return()
+writeControlPointData  ((a,b,c,d,e,f,g):rest) indx ptr = do
+   let i = (indx*7)
+   pokeElemOff ptr i       a
+   pokeElemOff ptr (i+1) b
+   pokeElemOff ptr (i+2) c
+   pokeElemOff ptr (i+3) d
+   pokeElemOff ptr (i+4) e
+   pokeElemOff ptr (i+5) f
+   pokeElemOff ptr (i+6) g
+   writeControlPointData rest (indx+1) ptr
+
+type VertTup = (Float,Float,Float,Float,Float,Float,Float)
+
+-- multiplies a set of floats by n
+mul7 :: VertTup -> Float -> VertTup
+mul7 (a,b,c,d,e,f,g) n = ((n*a),(n*b),(n*c),(n*d),(n*e),(n*f),(n*g))
+
+
+-- adds to sets of floats together
+add7 :: VertTup -> VertTup -> VertTup
+add7 (u1,u2,u3,u4,u5,u6,u7) (v1,v2,v3,v4,v5,v6,v7) =
+            (u1+v1,u2+v2,u3+v3,u4+v4,u5+v5,u6+v6,u7+v7)
+
+
+-- create a set of patches
+createPatches :: (Ptr Float, Ptr Float, Ptr Float, Ptr Float, Ptr Word8) ->
+   Int -> Int -> Int -> Int -> IO [BSPPatch]
+createPatches vertData startVert width height tesselation = do
+   controlPoints <- getControlPoints vertData startVert width height
+   patches <- mapM (createPatch tesselation) controlPoints
+   return patches
+
+
+createPatch :: Int -> Array Int VertTup -> IO BSPPatch
+createPatch tesselation controlPoints  = do
+   ptr <- mallocBytes (((tesselation+1)*(tesselation+1))*28)
+   createPatch' tesselation ptr controlPoints
+   createPatch'' tesselation ptr controlPoints
+   (numiptr,iptrptr)<- generateIndices tesselation
+   return (BSPPatch {
+                    patchLOD = tesselation,
+                    patchPtr = ptr,
+                    indexPtrPtr = iptrptr,
+                    numIndexPtr = numiptr
+                 })
+
+
+createPatch' ::Int ->  Ptr Float -> Array Int VertTup -> IO()
+createPatch' tess ptr arr = do
+   let patchVerts = map (bezier tess (arr!0) (arr!3) (arr!6)) [0..tess]
+   writeControlPointData patchVerts 0 ptr
+
+
+createPatch'' ::Int ->  Ptr Float -> Array Int VertTup -> IO()
+createPatch'' tess ptr arr = do
+   mapM_        (createPatch''' tess ptr arr) [1..tess]
+
+
+createPatch''' ::Int -> Ptr Float -> Array Int VertTup -> Int -> IO()
+createPatch''' tess ptr arr u = do
+   let tup1 = bezier tess (arr!0) (arr!1) (arr!2) u
+   let tup2 = bezier tess (arr!3) (arr!4) (arr!5) u
+   let tup3 = bezier tess (arr!6) (arr!7) (arr!8) u
+   let patchVerts = map (bezier tess tup1 tup2 tup3) [0..tess]
+   writeControlPointData patchVerts 0 (plusPtr ptr (((tess+1)*u)*28))
+
+
+bezier :: Int -> VertTup -> VertTup -> VertTup -> Int -> VertTup
+bezier tes cp1 cp2 cp3 i = add7 (add7 d1 d2) d3
+   where
+         d1 = mul7 cp1 ((1-p)*(1-p))
+         d2 = mul7 cp2 ((1-p)*p*2)
+         d3 = mul7 cp3 (p*p)
+         p  = (realToFrac i)/(realToFrac tes)
+
+
+-- generate indices
+generateIndices :: Int -> IO (Ptr GLsizei, Ptr (Ptr GLint))
+generateIndices tess = do
+   indexArray <- newArray (0,((tess*(tess+1)*2)-1)) 0
+   let pt1 = [ ((((row*(tess+1))+point)*2)+1, fromIntegral ((row*(tess+1))+point)) |
+                         row<-[0..(tess-1)],
+                         point<-[0..tess]]
+   let pt2 = [ ((((row*(tess+1))+point)*2), fromIntegral (((row+1)*(tess+1))+point)) |
+                         row<-[0..(tess-1)],
+                         point<-[0..tess]]
+   mapM_ (writeIndices indexArray) pt1
+   mapM_ (writeIndices indexArray) pt2
+   indexList <- (getElems indexArray)
+   indexPtr <- mallocBytes ((tess * (tess+1)*2) * (sizeOf (undefined :: GLint)))
+   pokeArray indexPtr indexList
+   numArrayIndicesPtr <- mallocBytes (tess * (sizeOf (undefined :: GLsizei)))
+   pokeArray numArrayIndicesPtr (map (\_->(fromIntegral (2*(tess+1)))) [0..(tess-1)])
+   indexptrptr <- mallocBytes (tess * (sizeOf (undefined :: Ptr GLint)))
+   let ptrPtr = map (plusPtr indexPtr) [((sizeOf (undefined :: GLint)) * (row*2*(tess+1))) | row <-[0..(tess-1)]]
+   pokeArray indexptrptr ptrPtr
+   return (numArrayIndicesPtr, indexptrptr)
+
+
+-- writes the indices to memory
+writeIndices :: IOUArray Int GLint -> (Int,GLint) -> IO ()
+writeIndices indcs (pos,content) = writeArray indcs pos content
+ src/Diagnostics.hs view
@@ -0,0 +1,21 @@+{- $Id: Diagnostics.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                              I N V A D E R S                               *+*                                                                            *+*       Module:         Diagnostics					     *+*       Purpose:        Standardized error-reporting for Invaders	     *+*	Authors:	Henrik Nilsson					     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module Diagnostics where++usrErr :: String -> String -> String -> a+usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)++intErr :: String -> String -> String -> a+intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "+                          ++ msg)
+ src/Frustum.hs view
@@ -0,0 +1,120 @@+{- Frustum.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+Provides a function to extract the frustum and test
+whether an AABB intersects it
+
+-}
+
+module Frustum where
+
+import Graphics.UI.GLUT
+import Graphics.Rendering.OpenGL.GL.CoordTrans
+
+
+type FPlane =  (Double, Double, Double, Double)
+type Frustum = (FPlane,FPlane,FPlane,FPlane,FPlane,FPlane)
+
+
+normalisePlane :: FPlane -> IO FPlane
+normalisePlane (x,y,z,d) = do
+   let reciMag = (1/(sqrt(x*x+y*y+z*z)))
+   return (x*reciMag, y*reciMag, z*reciMag, d*reciMag)
+
+
+-- gets the frustum from the current view
+getFrustum :: IO Frustum
+getFrustum = do
+
+   mvMatrix <- get (matrix (Just (Modelview 0))) :: IO (GLmatrix GLdouble)
+   [m00,m01,m02,m03,
+    m10,m11,m12,m13,
+    m20,m21,m22,m23,
+    m30,m31,m32,m33] <- getMatrixComponents ColumnMajor mvMatrix
+   pjMatrix <- get (matrix (Just (Projection))) :: IO (GLmatrix GLdouble)
+   [p00,p01,p02,p03,
+    p10,p11,p12,p13,
+    p20,p21,p22,p23,
+    p30,p31,p32,p33] <- getMatrixComponents ColumnMajor pjMatrix
+
+   let clip00 = m00*p00 + m01*p10 + m02*p20 + m03*p30
+   let clip01 = m00*p01 + m01*p11 + m02*p21 + m03*p31
+   let clip02 = m00*p02 + m01*p12 + m02*p22 + m03*p32
+   let clip03 = m00*p03 + m01*p13 + m02*p23 + m03*p33
+
+   let clip10 = m10*p00 + m11*p10 + m12*p20 + m13*p30
+   let clip11 = m10*p01 + m11*p11 + m12*p21 + m13*p31
+   let clip12 = m10*p02 + m11*p12 + m12*p22 + m13*p32
+   let clip13 = m10*p03 + m11*p13 + m12*p23 + m13*p33
+
+   let clip20 = m20*p00 + m21*p10 + m22*p20 + m23*p30
+   let clip21 = m20*p01 + m21*p11 + m22*p21 + m23*p31
+   let clip22 = m20*p02 + m21*p12 + m22*p22 + m23*p32
+   let clip23 = m20*p03 + m21*p13 + m22*p23 + m23*p33
+
+   let clip30 = m30*p00 + m31*p10 + m32*p20 + m33*p30
+   let clip31 = m30*p01 + m31*p11 + m32*p21 + m33*p31
+   let clip32 = m30*p02 + m31*p12 + m32*p22 + m33*p32
+   let clip33 = m30*p03 + m31*p13 + m32*p23 + m33*p33
+
+   let rightX = clip03 - clip00
+   let rightY = clip13 - clip10
+   let rightZ = clip23 - clip20
+   let rightD = clip33 - clip30
+
+   let leftX  = clip03 + clip00
+   let leftY  = clip13 + clip10
+   let leftZ  = clip23 + clip20
+   let leftD  = clip33 + clip30
+
+   let bottomX  = clip03 + clip01
+   let bottomY  = clip13 + clip11
+   let bottomZ  = clip23 + clip21
+   let bottomD  = clip33 + clip31
+
+   let topX  = clip03 - clip01
+   let topY  = clip13 - clip11
+   let topZ  = clip23 - clip21
+   let topD  = clip33 - clip31
+
+   let backX  = clip03 - clip02
+   let backY  = clip13 - clip12
+   let backZ  = clip23 - clip22
+   let backD  = clip33 - clip32
+
+   let frontX  = clip03 + clip02
+   let frontY  = clip13 + clip12
+   let frontZ  = clip23 + clip22
+   let frontD  = clip33 + clip32
+
+   rightPlane  <- normalisePlane (rightX ,rightY ,rightZ ,rightD)
+   leftPlane   <- normalisePlane (leftX  ,leftY  ,leftZ  ,leftD)
+   bottomPlane <- normalisePlane (bottomX,bottomY,bottomZ,bottomD)
+   topPlane    <- normalisePlane (topX   ,topY   ,topZ   ,topD)
+   backPlane   <- normalisePlane (backX  ,backY  ,backZ  ,backD)
+   frontPlane  <- normalisePlane (frontX ,frontY ,frontZ,frontD)
+
+   return (rightPlane,leftPlane,bottomPlane,topPlane,backPlane,frontPlane)
+
+
+-- tests if a box intersects a plane
+testBox :: (Double,Double,Double)->(Double,Double,Double) -> FPlane ->Bool
+testBox (x,y,z) (x2,y2,z2) (a,b,c,d)
+   | (a * x  + b * y  + c * z  + d > 0) = True
+   | (a * x2 + b * y  + c * z  + d > 0) = True
+   | (a * x  + b * y2 + c * z  + d > 0) = True
+   | (a * x2 + b * y2 + c * z  + d > 0) = True
+   | (a * x  + b * y  + c * z2 + d > 0) = True
+   | (a * x2 + b * y  + c * z2 + d > 0) = True
+   | (a * x  + b * y2 + c * z2 + d > 0) = True
+   | (a * x2 + b * y2 + c * z2 + d > 0) = True
+   | otherwise = False
+
+
+-- tests if an AABB lies within a frustum
+boxInFrustum :: Frustum -> (Double,Double,Double) -> (Double,Double,Double) -> Bool
+boxInFrustum (a,b,c,d,e,f) mn mx
+   | not(test a) || not(test b) || not(test c)
+     || not(test d) || not(test e) || not(test f) = False
+   | otherwise = True
+   where test = testBox mn mx
+
+ src/Game.hs view
@@ -0,0 +1,199 @@+module Game where
+
+import AFRP
+import AFRPInternals (Event(..))
+import Collision
+import Raybox
+import BSP
+import List
+import IdentityList
+import Object
+import Parser
+import Camera
+import Matrix
+import Visibility (aiVisTest)
+
+game :: BSPMap -> [ILKey -> Object] -> SF GameInput [ObsObjState]
+game bspmap objs
+  = (loop
+       (game'
+          (case (listToILA $ objs) of
+               x -> x)
+          bspmap
+          >>> arr (\ oos -> (oos, oos)))
+       >>>
+       arr
+         (\ oos ->
+            case (map ooObsObjState (elemsIL oos)) of
+                y -> y))
+
+game' ::
+      IL Object -> BSPMap -> SF (GameInput, IL ObjOutput) (IL ObjOutput)
+game' objs bspmap
+  = dpSwitch (route bspmap) objs (noEvent --> arr killOrSpawn)
+      (\ sfs' f -> game' (f sfs') bspmap)
+
+route ::
+      BSPMap -> (GameInput, IL ObjOutput) -> IL sf -> IL (ObjInput, sf)
+route bspmap (gi, oos) objs = mapIL routeAux objs
+  where routeAux (k, obj)
+          = case (find (\ (x, _, _) -> k == x) states) of
+                Just (_, _, z) -> (z, obj)
+                Nothing -> (ObjInput{oiHit = noEvent, oiMessage = noEvent,
+                                     oiCollisionPos = (0, 0, 0), oiCollision = dummy,
+                                     oiOnLand = False, oiVisibleObjs = noEvent, oiGameInput = gi},
+                            obj)
+        messages
+          = concat $ map eventToList $ elemsIL $ fmap ooSendMessage oos
+        states
+          = (clips bspmap gi (assocsIL $ fmap ooObsObjState oos)
+               (assocsIL $ fmap ooObsObjState oos))
+              messages
+        dummy = initCamera (80::Int, 611::Int, 60::Int) (80::Int, 611::Int, 59::Int) (0::Int, 1::Int, 0::Int)
+
+killOrSpawn :: (a, IL ObjOutput) -> Event (IL Object -> IL Object)
+killOrSpawn (_, oos)
+  = case (foldl (mergeBy (.)) noEvent es) of
+        y -> y
+  where
+        es :: [Event (IL Object -> IL Object)]
+        es
+          = case
+              ([mergeBy (.) (ooKillReq oo `tag` (deleteIL k))
+                  (fmap (foldl (.) id . map insertILA_) (ooSpawnReq oo))
+                | (k, oo) <- assocsIL oos])
+              of
+                x -> x
+
+clips ::
+      BSPMap ->
+        GameInput ->
+          [(ILKey, ObsObjState)] ->
+            [(ILKey, ObsObjState)] ->
+              [(ILKey, (ILKey, Message))] -> [(ILKey, ObsObjState, ObjInput)]
+clips _ _ [] _ _ = []
+clips mp gi ((k, oos) : kooss) ooses msgs
+  = case (clip mp gi oos ooses k msgs) of
+        x -> (k, oos, x) : (clips mp gi kooss ooses msgs)
+
+clip :: BSPMap -> GameInput -> ObsObjState -> [(ILKey, ObsObjState)] ->
+       ILKey -> [(ILKey, (ILKey, Message))] -> ObjInput
+clip mp gi cam@(OOSCamera{newCam = cam1, oldCam = cam2}) ooses k msgs
+  = let (camera, grounded) = clipCamera mp cam1 cam2 in
+      ObjInput{oiHit = listToEvent $ findCollidingObjects ooses (k, cam),
+               oiMessage = findMessages k msgs, oiCollisionPos = (0, 0, 0),
+               oiCollision = camera, oiOnLand = grounded, oiVisibleObjs = noEvent,
+               oiGameInput = gi}
+clip mp gi
+  acube@(OOSAICube{oosNewCubePos = pos1, oosOldCubePos = pos2,
+                   oosCubeSize = sz, health = h, target = t})
+  ooses k msgs
+  = let (clippedPos, grounded) = clipObject mp pos1 pos2 sz in
+      ObjInput{oiHit =
+                 listToEvent $ findCollidingObjects ooses (k, acube),
+               oiCollision = initCamera (80::Int, 611, 60) (80::Int, 611, 59) (0, 1, 0),
+               oiMessage = findMessages k msgs, oiCollisionPos = clippedPos,
+               oiOnLand = grounded,
+               oiVisibleObjs =
+                 (case (h == 100 && t == (0, 0, 0)) of
+                      True -> (listToEvent $ findVisibleTargets mp ooses (k, acube) 600)
+                      _ -> (listToEvent $ findVisibleTargets mp ooses (k, acube) 1800)),
+               oiGameInput = gi}
+clip mp gi
+  OOSRay{rayStart = pos1, rayEnd = pos2, rayUC = pos3, clipped = ff}
+  _ k msgs
+  | ff == False =
+    let (_, hasCol) = clipRay mp pos3 pos1 (0, 0, 0) in
+      ObjInput{oiHit = noEvent, oiMessage = findMessages k msgs,
+               oiCollision = dummy, oiCollisionPos = fix hasCol pos2 pos3 pos1,
+               oiOnLand = hasCol, oiVisibleObjs = noEvent, oiGameInput = gi}
+  | otherwise =
+    ObjInput{oiHit = noEvent, oiMessage = findMessages k msgs,
+             oiCollision = dummy, oiCollisionPos = pos2, oiOnLand = True,
+             oiVisibleObjs = noEvent, oiGameInput = gi}
+  where fix clpped p2 p3 p1
+          | clpped == True = tryAccurate mp 4 p2 p3 p1
+          | otherwise = pos3
+        dummy = initCamera (80::Int, 611, 60) (80::Int, 611, 59) (0, 1, 0)
+clip mp gi
+  projectile@(OOSProjectile{projectileNewPos = pos3,
+                            projectileOldPos = pos1})
+  ooses k _
+  = let (clippedPos, hasCol) = clipRay mp pos3 pos1 (0, 0, 0) in
+      ObjInput{oiHit =
+                 listToEvent $ findCollidingObjects ooses (k, projectile),
+               oiMessage = noEvent,
+               oiCollision = (initCamera (80::Int, 611, 60) (80::Int, 611, 59) (0, 1, 0)),
+               oiCollisionPos = clippedPos, oiOnLand = hasCol,
+               oiVisibleObjs = noEvent, oiGameInput = gi}
+
+listToEvent :: [a] -> Event [a]
+listToEvent [] = noEvent
+listToEvent list = Event list
+
+eventToList :: Event [a] -> [a]
+eventToList ev
+  | isEvent ev = fromEvent ev
+  | otherwise = []
+
+tryAccurate :: BSPMap -> Int -> Vec3 -> Vec3 -> Vec3 -> Vec3
+tryAccurate mp n dv1 dv2 vec
+  | n == 0 = (middle dv1 dv2 vec)
+  | snd (clipRay mp (middle dv1 dv2 vec) vec (0, 0, 0)) == True =
+    tryAccurate mp (n - 1) dv1 (middle dv1 dv2 vec) vec
+  | otherwise = tryAccurate mp (n - 1) (middle dv1 dv2 vec) dv2 vec
+  where middle v1 v2 _ = vectorAdd v1 (vectorMult (vectorSub v2 v1) 0.5)
+
+findCollidingObjects ::
+                     [(ILKey, ObsObjState)] ->
+                       (ILKey, ObsObjState) -> [(ILKey, ObsObjState)]
+findCollidingObjects ooses (k, obj)
+  | isProjectile obj =
+    [(k', oos') | (k', oos') <- ooses, k /= k', isCamera oos',
+     checkCollision obj oos']
+  | isCamera obj =
+    [(k', oos') | (k', oos') <- ooses, k /= k', isProjectile oos',
+     checkCollision obj oos']
+  | isAICube obj =
+    [(k', oos') | (k', oos') <- ooses, k /= k', isRay oos',
+     checkCollision obj oos']
+
+checkCollision :: ObsObjState -> ObsObjState -> Bool
+checkCollision obj1 obj2
+  | isCamera obj2 && isProjectile obj1 =
+    pointBox (cpos (oldCam (obj2))) (projectileOldPos obj1)
+      (20, 50, 20)
+  | isCamera obj1 && isProjectile obj2 =
+    pointBox (cpos (oldCam (obj1))) (projectileOldPos obj2)
+      (20, 50, 20)
+  | isAICube obj1 && isRay obj2 =
+    let (x, y, z) = oosOldCubePos obj1
+        (cx, cy, cz) = oosCubeSize obj1
+      in
+      rayBox (rayStart obj2) (rayEnd obj2) (x - cx, y - cy, z - cz)
+        (x + cx, y + cy, z + cz)
+checkCollision _ _ = False
+
+findVisibleTargets ::
+                   BSPMap ->
+                     [(ILKey, ObsObjState)] ->
+                       (ILKey, ObsObjState) -> Int -> [(ILKey, ObsObjState)]
+findVisibleTargets bsp ooses (k, obj) range
+  | isAICube obj =
+    [(k', oos') | (k', oos') <- ooses, k /= k', isCamera oos',
+     checkVisible bsp obj oos' range]
+  | otherwise = []
+
+checkVisible :: BSPMap -> ObsObjState -> ObsObjState -> Int -> Bool
+checkVisible bsp obj1 obj2 range
+  | isAICube obj1 && isCamera obj2 =
+    let (x, y, z) = oosOldCubePos obj1
+        (cx, cy, cz) = cpos (oldCam obj2)
+      in aiVisTest bsp (x, y, z) (oosCubeAngle obj1) (cx, cy, cz) range
+checkVisible _ _ _ _ = True
+
+findMessages ::
+             ILKey -> [(ILKey, (ILKey, Message))] -> Event [(ILKey, Message)]
+findMessages key messages
+  = listToEvent $
+      map snd (filter (\ (destkey, _) -> destkey == key) messages)
+ src/HGL.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE BangPatterns #-}++module HGL where++data Event+  = Char      { char :: !Char, isDown :: !Bool }+  | Button    { pt   :: !Point, isLeft, isDown :: !Bool }+  | MouseMove { pt   :: !Point }++ deriving Show++data Point = Point !(Int,Int) deriving Show
+ src/IdentityList.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE BangPatterns #-}++-- This is the idenity list module that came with the space invaders source+-- i just added insertILA_, listToILA++{- $Id: IdentityList.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                                I N V A D E R S                                                  *+*                                                                                                                         *+*          Module:              IdentityList                                            *+*          Purpose:     Association list with automatic key assignment and   *+*                       identity-preserving map and filter operations.          *+*          Author:              Henrik Nilsson                                  *+*                                                                                                                         *+*                   Copyright (c) Yale University, 2003                                           *+*                                                                                                                         *+******************************************************************************+-}++module IdentityList (+    ILKey,        -- Identity-list key type+    IL,           -- Identity-list, abstract. Instance of functor.+    emptyIL,      -- :: IL a+    insertIL_,   -- :: a -> IL a -> IL a+    insertIL,     -- :: a -> IL a -> (ILKey, IL a)+    listToIL,     -- :: [a] -> IL a+    keysIL,       -- :: IL a -> [ILKey]+    elemsIL,      -- :: IL a -> [a]+    assocsIL,     -- :: IL a -> [(ILKey, a)]+    deleteIL,     -- :: ILKey -> IL a -> IL a+    mapIL,        -- :: ((ILKey, a) -> b) -> IL a -> IL b+    filterIL,     -- :: ((ILKey, a) -> Bool) -> IL a -> IL a+    mapFilterIL,  -- :: ((ILKey, a) -> Maybe b) -> IL a -> IL b+    lookupIL,     -- :: ILKey -> IL a -> Maybe a+    findIL,       -- :: ((ILKey, a) -> Bool) -> IL a -> Maybe a+    mapFindIL,   -- :: ((ILKey, a) -> Maybe b) -> IL a -> Maybe b+    findAllIL,   -- :: ((ILKey, a) -> Bool) -> IL a -> [a]+    mapFindAllIL,  -- :: ((ILKey, a) -> Maybe b) -> IL a -> [b]+    insertILA_,+    listToILA++) where++------------------------------------------------------------------------------+-- Data type definitions+------------------------------------------------------------------------------++type ILKey = Int++-- Invariants:+-- * Sorted in descending key order. (We don't worry about+--      key wrap around).+-- * Keys are NOT reused+data IL a = IL { ilNextKey :: !ILKey, ilAssocs :: ![(ILKey, a)] }+++------------------------------------------------------------------------------+-- Class instances+------------------------------------------------------------------------------++instance Functor IL where+    fmap f (IL {ilNextKey = nk, ilAssocs = kas}) =+           IL {ilNextKey = nk, ilAssocs = [ (i, f a) | (i, a) <- kas ]}+++------------------------------------------------------------------------------+-- Constructors+------------------------------------------------------------------------------++emptyIL :: IL a+emptyIL = IL {ilNextKey = 0, ilAssocs = []}+++insertIL_ :: a -> IL a -> IL a+insertIL_ a il = snd (insertIL a il)+++insertIL :: a -> IL a -> (ILKey, IL a)+insertIL a (IL {ilNextKey = k, ilAssocs = kas}) = (k, il') where+    il' = IL {ilNextKey = k + 1, ilAssocs = (k, a) : kas}++-- inserts an object into an identity list and gives the object its key+insertILA_ :: (ILKey -> a) -> IL a -> IL a+insertILA_ f (IL {ilNextKey = k, ilAssocs = kas}) = il' where+    il' = IL {ilNextKey = k + 1, ilAssocs = (k, f k) : kas}++listToIL :: [a] -> IL a+listToIL as = IL {ilNextKey = length as,+                  ilAssocs = reverse (zip [0..] as)} -- Maintain invariant!++-- converts a list to an identity list and gives every object in the list its ILkey+listToILA :: [(ILKey -> a)] -> IL a+listToILA as = IL {ilNextKey = length as,+                  ilAssocs = reverse (zip [0..] (appFunc as [0..] ))} -- Maintain invariant!++appFunc :: [(ILKey -> a)] -> [ILKey] -> [a]+appFunc [] _ = []+appFunc (f:fs) (k:ks) = (f k):(appFunc fs ks)+appFunc _ _ = []++------------------------------------------------------------------------------+-- Additional selectors+------------------------------------------------------------------------------++assocsIL :: IL a -> [(ILKey, a)]+assocsIL = ilAssocs+++keysIL :: IL a -> [ILKey]+keysIL = map fst . ilAssocs+++elemsIL :: IL a -> [a]+elemsIL = map snd . ilAssocs+++------------------------------------------------------------------------------+-- Mutators+------------------------------------------------------------------------------++deleteIL :: ILKey -> IL a -> IL a+deleteIL k (IL {ilNextKey = nk, ilAssocs = kas}) =+    IL {ilNextKey = nk, ilAssocs = deleteHlp kas}+    where+        deleteHlp []                                                      = []+        deleteHlp kakas@(ka@(k', _) : ks) | k > k'        = kakas+          | k == k'   = ks+          | otherwise = ka : deleteHlp ks+++------------------------------------------------------------------------------+-- Filter and map operations+------------------------------------------------------------------------------++-- These are "identity-preserving", i.e. the key associated with an element+-- in the result is the same as the key of the element from which the+-- result element was derived.++mapIL :: ((ILKey, a) -> b) -> IL a -> IL b+mapIL f (IL {ilNextKey = nk, ilAssocs = kas}) =+    IL {ilNextKey = nk, ilAssocs = [(k, f ka) | ka@(k,_) <- kas]}+++filterIL :: ((ILKey, a) -> Bool) -> IL a -> IL a+filterIL p (IL {ilNextKey = nk, ilAssocs = kas}) =+    IL {ilNextKey = nk, ilAssocs = filter p kas}+++mapFilterIL :: ((ILKey, a) -> Maybe b) -> IL a -> IL b+mapFilterIL p (IL {ilNextKey = nk, ilAssocs = kas}) =+    IL {+           ilNextKey = nk,+           ilAssocs = [(k, b) | ka@(k, _) <- kas, Just b <- [p ka]]+    }+++------------------------------------------------------------------------------+-- Lookup operations+------------------------------------------------------------------------------++lookupIL :: ILKey -> IL a -> Maybe a+lookupIL k il = lookup k (ilAssocs il)+++findIL :: ((ILKey, a) -> Bool) -> IL a -> Maybe a+findIL p (IL {ilAssocs = kas}) = findHlp kas+    where+        findHlp []                       = Nothing+        findHlp (ka@(_, a) : ks) = if p ka then Just a else findHlp ks+++mapFindIL :: ((ILKey, a) -> Maybe b) -> IL a -> Maybe b+mapFindIL p (IL {ilAssocs = kas}) = mapFindHlp kas+    where+        mapFindHlp []             = Nothing+        mapFindHlp (ka : ks) = case p ka of+                                 Nothing      -> mapFindHlp ks+                                 jb@(Just _) -> jb+++findAllIL :: ((ILKey, a) -> Bool) -> IL a -> [a]+findAllIL p (IL {ilAssocs = kas}) = [ a | ka@(_, a) <- kas, p ka ]+++mapFindAllIL:: ((ILKey, a) -> Maybe b) -> IL a -> [b]+mapFindAllIL p (IL {ilAssocs = kas}) = [ b | ka <- kas, Just b <- [p ka] ]
+ src/MD3.hs view
@@ -0,0 +1,1206 @@+{-# LANGUAGE BangPatterns #-}
+
+{- MD3.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This module has functions to read and animate MD3 models.
+
+credits go to Ben Humphrey who wrote the MD3 tutorial
+
+Yet another module where i'm thinking of using
+vertex buffer objects instead of vertex arrays
+
+-}
+
+module MD3 (
+   readModel,
+   readWeaponModel,
+   updateAnim,
+   setAnim,
+   MD3Model(..),
+   Model(..),
+   MD3Animation(..),
+   AnimState(..),
+   drawModel,
+   death1,
+   dead1,
+   death2,
+   dead2,
+   death3,
+   dead3,
+   gesture,
+   attack1,
+   attack2,
+   dropWeap,
+   raiseWeap,
+   stand,
+   stand2,
+   walkcr,
+   walk,
+   run,
+   back,
+   swim,
+   jump,
+   land,
+   jumpb,
+   landb,
+   idleLegs,
+   idlecrLegs,
+   turn
+  )where
+
+import Graphics.UI.GLUT
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import System.IO hiding (withBinaryFile)
+import Control.Exception ( bracket )
+import Textures
+import Data.HashTable
+import Data.Maybe
+import Data.List
+import Data.Array
+import Quaternion
+import Data.IORef
+import Foreign.Storable
+import Foreign.Marshal.Array
+
+
+
+-------------------------------------------------------------------------------
+-- Types
+
+data MD3Bone =
+        MD3Bone {
+           minPos  :: (Float,Float,Float),
+           maxPos  :: (Float,Float,Float),
+           bonePos :: (Float,Float,Float),
+           bscale  :: Float,
+           creator :: String
+        }  deriving Show
+
+data MD3Header =
+        MD3Header {
+           fileID       :: String,
+           version      :: Int,
+           md3FileName :: String,
+           numFrames    :: Int,
+           numTags      :: Int,
+           numMeshes    :: Int,
+           numMaxSkins :: Int,
+           headerSize   :: Int,
+           tagStart     :: Int,
+           tagEnd       :: Int,
+           fileSize     :: Int
+        } deriving Show
+
+data MD3Tag =
+        MD3Tag {
+           tagName  :: String,
+           tagPos   :: (Float,Float,Float),
+           rotation :: (Float,Float,Float,Float)
+        } deriving Show
+
+data MD3MeshHeader =
+        MD3MeshHeader {
+           meshID         :: String,
+           strName        :: String,
+           numMeshFrames :: Int,
+           numSkins       :: Int,
+           numVertices   :: Int,
+           numTriangles  :: Int,
+           triStart       :: Int,
+           meshHeaderSize:: Int,
+           uvStart        :: Int,
+           vertexStart   :: Int,
+           meshSize       :: Int
+        } deriving Show
+
+data MD3Vertex =
+        MD3Vertex {
+           vert :: (Float,Float,Float),
+           norm :: (CUChar,CUChar)
+} deriving Show
+
+data Model =
+        Model {
+           modelRef   :: !MD3Model,
+           weapFire   :: IORef (Maybe (IO())),
+           pitch            :: IORef (Maybe (IO())),
+           upperState :: IORef AnimState,
+           lowerState :: IORef AnimState
+}
+
+data MD3Model =
+        MD3Model {
+           numOfTags     :: Int,
+           modelObjects :: [MeshObject],
+           links                 :: [(MD3Model,IORef(AnimState))],
+           auxFunc       :: IORef(Maybe (IO())),
+           auxFunc2      :: IORef(Maybe (IO())),
+           tags          :: Array Int [((Float,Float,Float),
+                                                          (Float,Float,Float,Float))]
+        } |
+        MD3Weapon {
+           wmodelObjects :: IORef [MeshObject]
+        }
+
+data MeshObject =
+        MeshObject {
+           numOfVerts    :: Int,
+           numOfFaces    :: NumArrayIndices,
+           numTexVertex :: Int,
+           materialID    :: Maybe TextureObject,
+           bHasTexture  :: Bool,
+           objName       :: String,
+           verticesp     :: Array Int (Ptr Float),
+           normals       :: [(Float,Float,Float)],
+           texCoordsl    :: [((Float,Float),(Float,Float),(Float,Float))],
+           texCoords     :: Ptr Float,
+           vertPtr       :: Ptr Float,
+           numIndices    :: GLsizei,
+           vertIndex     :: Ptr CInt,
+           indexBuf      :: BufferObject,
+           texBuf        :: BufferObject,
+           vertBuf       :: BufferObject
+}
+
+data MD3Animation =
+        MD3Animation {
+           animName   :: String,
+           startFrame :: Int,
+           endFrame   :: Int,
+           loopFrames :: Int,
+           fp      :: Float
+} deriving Show
+
+data AnimState =
+        AnimState {
+           anims                   :: !(Array Int MD3Animation),
+           currentAnim    :: !MD3Animation,
+           currentFrame   :: !Int,
+           nextFrame       :: !Int,
+           currentTime    :: !Float,
+           lastTime        :: !Float
+        }
+
+type MD3Face = (Int,Int,Int)
+
+type MD3TexCoord = (Float,Float)
+
+
+-------------------------------------------------------------------------------
+-- A list of animations stored in MD3 files
+
+animList :: [String]
+animList = ["BOTH_DEATH1",      --The first twirling death animation
+                  "BOTH_DEAD1", --The end of the first twirling death animation
+                  "BOTH_DEATH2",        --The second twirling death animation
+                  "BOTH_DEAD2", --The end of the second twirling death animation
+                  "BOTH_DEATH3",        --The back flip death animation
+                  "BOTH_DEAD3", --The end of the back flip death animation
+                  "TORSO_GESTURE",      --The torso's gesturing animation
+                  "TORSO_ATTACK",       --The torso's attack1 animation
+                  "TORSO_ATTACK2",      --The torso's attack2 animation
+                  "TORSO_DROP", --The torso's weapon drop animation
+                  "TORSO_RAISE",        --The torso's weapon pickup animation
+                  "TORSO_STAND",        --The torso's idle stand animation
+                  "TORSO_STAND2",       --The torso's idle stand2 animation
+                  "LEGS_WALKCR",        --The legs's crouching walk animation
+                  "LEGS_WALK",  --The legs's walk animation
+                  "LEGS_RUN",           --The legs's run animation
+                  "LEGS_BACK",  --The legs's running backwards animation
+                  "LEGS_SWIM",  --The legs's swimming animation
+                  "LEGS_JUMP",  --The legs's jumping animation
+                  "LEGS_LAND",  --The legs's landing animation
+                  "LEGS_JUMPB", --The legs's jumping back animation
+                  "LEGS_LANDB", --The legs's landing back animation
+                  "LEGS_IDLE",  --The legs's idle stand animation
+                  "LEGS_IDLECR",        --The legs's idle crouching animation
+                  "LEGS_TURN"]  --The legs's turn animation
+
+-- animation index
+
+death1 :: Int
+death1 = 0
+
+dead1 :: Int
+dead1 = 1
+
+death2 :: Int
+death2 = 2
+
+dead2 :: Int
+dead2 = 3
+
+death3 :: Int
+death3 = 4
+
+dead3 :: Int
+dead3 = 5
+
+gesture :: Int
+gesture = 6
+
+attack1 :: Int
+attack1 = 7
+
+attack2 :: Int
+attack2 = 8
+
+dropWeap :: Int
+dropWeap = 9
+
+raiseWeap :: Int
+raiseWeap = 10
+
+stand :: Int
+stand = 11
+
+stand2 :: Int
+stand2 = 12
+
+walkcr :: Int
+walkcr = 6
+
+walk :: Int
+walk = 7
+
+run :: Int
+run = 8
+
+back :: Int
+back = 9
+
+swim :: Int
+swim = 10
+
+jump :: Int
+jump = 11
+
+land :: Int
+land = 12
+
+jumpb :: Int
+jumpb = 13
+
+landb :: Int
+landb = 14
+
+idleLegs :: Int
+idleLegs = 15
+
+idlecrLegs :: Int
+idlecrLegs = 16
+
+turn :: Int
+turn = 17
+
+
+-------------------------------------------------------------------------------
+-- Functions for updating animations
+
+
+-- sets the animation in the animation state
+setAnim :: (Int,AnimState) -> AnimState
+setAnim (animIndex,animState)
+   | (animName newAnim) == (animName (currentAnim animState)) = animState
+   | otherwise = AnimState {
+                        anims      = anims animState,
+                        currentAnim  = newAnim,
+                        currentFrame = startFrame newAnim,
+                        nextFrame    = nextFrame animState,
+                        currentTime  = currentTime animState,
+                        lastTime           = lastTime animState
+         }
+         where newAnim = (anims animState)!  animIndex
+
+
+-- updates the animation
+updateAnim :: (Int,Double,AnimState) -> (Bool,AnimState)
+updateAnim (animIndex,time,animState)
+   | snd(Data.Array.bounds(anims animState)) == 0 =
+         let
+           (haslooped,nextNF) =
+                  cycleFrame cAnim 0 1 (currentFrame animStateN)
+           (t,lastT,nextCF) =
+                  updateTime (lastTime animStateN)
+                        (currentFrame animStateN) nextNF cAnim time
+         in (haslooped,AnimState {
+                   anims                 = anims animStateN ,
+                   currentAnim  = currentAnim animStateN,
+                   currentFrame = nextCF + 0,
+                   nextFrame     = nextNF + 0,
+                   currentTime  = t + 0,
+                   lastTime      = lastT + 0
+         })
+   | otherwise =
+         let
+          (haslooped,nextNF) =
+                 cycleFrame cAnim (startFrame cAnim)
+                    (endFrame cAnim) (currentFrame animStateN)
+          (t,lastT,nextCF) =
+                 updateTime (lastTime animStateN)
+                    (currentFrame animStateN) nextNF cAnim time
+         in (haslooped,AnimState {
+                   anims                 = anims animStateN,
+                   currentAnim  = currentAnim animStateN ,
+                   currentFrame = nextCF + 0,
+                   nextFrame     = nextNF + 0,
+                   currentTime  = t + 0,
+                   lastTime      = lastT + 0
+         })
+   where
+         animStateN = setAnim (animIndex,animState)
+         cAnim    = (currentAnim animStateN)
+
+-- increment the frame
+cycleFrame :: MD3Animation -> Int -> Int -> Int -> (Bool,Int)
+cycleFrame _ startframe endframe currentframe
+   | currentframe == (endframe-2) = (True,nextFrme)
+   | nextFrme    == 0 = (False,startframe)
+   | otherwise    = (False,nextFrme)
+   where
+    nextFrme = (currentframe + 1) `mod` endframe
+
+updateTime :: Float -> Int -> Int -> MD3Animation-> Double ->(Float,Float,Int)
+updateTime lasttime currentframe nextframe anim presentTime =
+   let
+        animSpeed    = (fp anim)
+        presentTimef = 1000*(realToFrac presentTime)
+        elapsedtime  = presentTimef - lasttime
+        t            = elapsedtime/animSpeed
+   in case ((realToFrac elapsedtime) >= animSpeed) of
+            True -> (t,presentTimef ,nextframe)
+            _    -> (t,lasttime,currentframe)
+
+-------------------------------------------------------------------------------
+-- renders the model
+drawModel :: (MD3Model,IORef(AnimState)) -> IO( )
+drawModel (model,stateRef) = do
+   texture Texture2D                    $= Enabled
+   --texture Texture2D                  $= Disabled
+   clientState TextureCoordArray        $= Enabled
+   clientState VertexArray              $= Enabled
+   --clientState VertexArray            $= Disabled
+   --clientState TextureCoordArray $= Disabled
+   animState <- readIORef stateRef
+   mapM (drawObject animState) (modelObjects model)
+   let currentTag = (tags model)!(currentFrame animState)
+   let nextTag    = (tags model)!(nextFrame animState)
+   aux  <- readIORef (auxFunc model)
+   aux2 <- readIORef (auxFunc2 model)
+   case aux2 of
+         Just func -> func
+         Nothing -> return ()
+   recurseDraw (currentTime animState) aux (links model) currentTag nextTag
+   texture Texture2D $= Disabled
+
+recurseDraw :: Float ->
+   Maybe (IO())-> [(MD3Model,IORef(AnimState))] ->
+         [((Float,Float,Float),(Float,Float,Float,Float))] ->
+            [((Float,Float,Float),(Float,Float,Float,Float))] ->  IO()
+recurseDraw _ _ [] _ _  = return ()
+recurseDraw t func ((model,state):mss)
+   (((c1,c2,c3),quat1):ccqs) (((n1,n2,n3),quat2):ncqs) = do
+                  let (i1,i2,i3) = (c1+(t*(n1-c1)), c2+(t*(n2-c2)), c3+(t*(n3-c3)))
+                  let iquat = slerp quat1 quat2 t
+                  mat <- quat2Mat iquat (i1,i2,i3)
+                  unsafePreservingMatrix $ do
+                         multMatrix mat
+                         case func of
+                           Just f -> f
+                           Nothing -> return ()
+                         drawModel (model,state)
+                  recurseDraw t func mss ccqs ncqs
+
+
+-- draws a mesh object with vertex arrays
+drawObject :: AnimState -> MeshObject -> IO ()
+drawObject animState obj = do
+   let curindex = (currentFrame animState)
+   let nextIndex =        (nextFrame animState)
+   case (curindex /= nextIndex) of
+          True -> do
+                convertToVertArray
+                   (currentTime animState)
+                          ((verticesp obj)!curindex)
+                                 ((verticesp obj)!nextIndex)
+                                         (vertPtr obj) 0 (numOfVerts obj)
+                arrayPointer VertexArray $=
+                   VertexArrayDescriptor 3 Float 0 (vertPtr obj)
+          _       -> do
+                arrayPointer VertexArray $=
+                   VertexArrayDescriptor 3 Float 0 ((verticesp obj)!curindex)
+
+   {-clientState VertexArray            $= Enabled
+        lockArrays                              $= (Just (0, (numOfFaces obj)))-}
+
+   arrayPointer TextureCoordArray       $=
+         VertexArrayDescriptor 2 Float 0 (texCoords obj)
+
+   {-clientState TextureCoordArray $= Enabled
+        texture Texture2D                       $= Enabled-}
+
+   textureBinding Texture2D             $= (materialID obj)
+
+   {-lockArrays                         $= (Just (0, (numOfFaces obj)))
+        drawElements Triangles  (numOfFaces obj) UnsignedInt (vertIndex obj)-}
+
+   drawRangeElements Triangles (0,(numOfFaces obj))
+         (numOfFaces obj) UnsignedInt (vertIndex obj)
+
+   {-lockArrays $= Nothing
+        clientState VertexArray $= Disabled
+        clientState TextureCoordArray $= Disabled
+        texture Texture2D $= Disabled-}
+
+
+convertToVertArray ::
+   Float -> Ptr Float -> Ptr Float -> Ptr Float -> Int -> Int ->IO()
+convertToVertArray t cs ns arr ind limit
+    | ind == limit= return()
+    | otherwise = do
+         c <- peekElemOff cs ind
+         n <- peekElemOff ns ind
+         pokeElemOff arr ind (i c n)
+         convertToVertArray t cs ns arr (ind+1) limit
+   where i x y = x+(t*(y-x))
+
+
+-------------------------------------------------------------------------------
+-- reads the MD3 files
+
+readMD3Header :: Handle -> IO MD3Header
+readMD3Header handle = do
+   buf <- mallocBytes 108
+   hGetBuf handle buf 108
+   fID <- getString buf 4
+   ver <- peek (plusPtr (castPtr buf :: Ptr CInt) 4)
+   mfilename <- getString (plusPtr buf 8) 68
+   [i1,i2,i3,i4,i5,i6,i7,i8] <-  getInts (plusPtr buf 76) 8
+   free buf
+   return $ MD3Header {
+                        fileID    = fID,
+                        version   = ver,
+                        md3FileName = mfilename,
+                        numFrames   = i1,
+                        numTags   = i2,
+                        numMeshes   = i3,
+                        numMaxSkins = i4,
+                        headerSize  = i5,
+                        tagStart          = i6,
+                        tagEnd    = i7,
+                        fileSize          = i8
+                  }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the .skin files
+
+
+readMD3Skin :: FilePath -> IO [(String,String)]
+readMD3Skin filepath = withBinaryFile filepath $ \handle -> do
+            contents <- hGetContents handle
+            let filteredStr =  (words (replace contents))
+            let files = findfiles (stripTags filteredStr)
+            case (files == []) of
+                    True -> return []
+                    False -> return files
+
+stripTags :: [String] -> [String]
+stripTags [] = []
+stripTags (s:ss)
+                | (head (words(map (replace' ['_']) s))) == "tag" = stripTags ss
+                | otherwise = s:(stripTags ss)
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the shader file for the weapon
+
+
+readMD3Shader :: FilePath -> IO [String]
+readMD3Shader filepath = withBinaryFile filepath $ \handle -> do
+   contents <- hGetContents handle
+   let filteredStr =  (words (replace contents))
+   let files = map stripExt filteredStr
+   case (files == []) of
+         True -> return []
+         False -> return files
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- used by readShader and readSkin
+
+
+stripExt :: String -> String
+stripExt str = (head (words(map (replace' ['.']) str)))
+
+
+findfiles :: [String] -> [(String,String)]
+findfiles [] = []
+findfiles (s:ss) = (s,(stripExt(stripPath (head ss)))):(findfiles (tail ss))
+
+replace :: String -> String
+replace str = map (replace' [',','\n','\r']) str
+
+replace' ::  [Char] -> Char -> Char
+replace' list char
+          | elem char list = ' '
+          | otherwise = char
+
+
+stripPath :: String -> String
+stripPath str = splitPath!!((length splitPath)-1)
+                where splitPath = (words (map (replace' ['/']) str))
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+--  reads the textures
+
+
+readMD3Textures ::
+   [FilePath] -> String ->
+         IO (HashTable String (Maybe TextureObject))
+readMD3Textures files dir = do
+                texs <- mapM readMD3Skin files
+                let texF = concat texs
+                let unqtex = nub (map snd texF)
+                textures <- mapM getAndCreateTexture (map (dir++) unqtex)
+                let nmobj = concat $ map (assoc texF) (zip unqtex textures)
+                fromList hashString nmobj
+
+assoc ::
+   [(String,String)] -> (String,Maybe TextureObject) ->
+         [(String,Maybe TextureObject)]
+assoc list (c,d) = zip (map fst (filter ((c ==).snd) list)) (cycle[d])
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the entire model
+
+
+
+readModel :: String -> Model -> IO (Model)
+readModel modelname weaponModel = do
+   hash <- readMD3Textures
+        (map (("tga/models/players/"++modelname)++)
+           ["/head_default.skin",
+            "/upper_default.skin",
+            "/lower_default.skin"])
+                  ("models/players/"++modelname++"/")
+   get elapsedTime
+   weaponAS <- noAnims
+   headAS   <- noAnims
+   (upperanims,loweranims) <-
+          readAnimations ("tga/models/players/"++modelname++"/animation.cfg")
+   let lowerS = AnimState {
+                                 anims      = loweranims,
+                                 currentAnim  = loweranims!8,
+                                 currentFrame = (startFrame (loweranims!8)),
+                                 nextFrame    = 0,
+                                 currentTime  = 0,
+                                 lastTime     = 0
+                          }
+   let upperS = AnimState {
+                                 anims      = upperanims,
+                                 currentAnim  = upperanims!6,
+                                 currentFrame = (startFrame (upperanims!6)),
+                                 nextFrame    = 0,
+                                 currentTime  = 0,
+                                 lastTime     = 0
+                          }
+   lowerstate <- newIORef lowerS
+   upperstate <- newIORef upperS
+   hed  <- readMD3 ("tga/models/players/"++modelname++"/head.md3") hash []
+   let weapon = modelRef weaponModel
+   upper <- readMD3
+         ("tga/models/players/"++modelname++"/upper.md3")
+            hash [("tag_weapon",(weapon,weaponAS)),("tag_head",(hed,headAS))]
+   lower <- readMD3
+         ("tga/models/players/"++modelname++"/lower.md3")
+            hash [("tag_torso",(upper,upperstate))]
+   return Model {
+         modelRef   = lower,
+         pitch    = auxFunc lower,
+         weapFire   = auxFunc2 weapon,
+         upperState = upperstate,
+         lowerState = lowerstate
+   }
+
+-- just returns an empty animation
+noAnims :: IO (IORef(AnimState))
+noAnims = do
+   let noanim =
+            MD3Animation {
+                  animName   = "",
+                  startFrame = 0,
+                  endFrame   = 0,
+                  loopFrames = 0,
+                  fp         = 0
+            }
+   let noanimState =
+                AnimState {
+                   anims                 = listArray (0,0) [],
+                   currentAnim  = noanim,
+                   currentFrame = 0,
+                   nextFrame     = 0,
+                   currentTime  = 0,
+                   lastTime      = 0
+   }
+   newIORef noanimState
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads a .MD3 file
+
+
+readMD3 :: FilePath ->
+   (HashTable String (Maybe TextureObject))->
+          [(String,(MD3Model,IORef(AnimState)))] -> IO MD3Model
+readMD3 filePath hashtable lns  = withBinaryFile filePath $ \handle -> do
+                header <- readMD3Header handle
+                readBones handle header
+                tag    <- readTags handle header
+                objs   <- readMeshes handle header hashtable
+                let splittedTags = splitTags (numTags header) tag
+                orderedlinks      <- scanTag lns tag
+                let trimmedTags  = trimTags (map fst orderedlinks) splittedTags
+                let trimmedArray = listArray (0,((length trimmedTags)-1)) trimmedTags
+                aux     <- newIORef (Nothing)
+                aux2 <- newIORef (Nothing)
+                return MD3Model {
+                                 numOfTags    = numTags header,
+                                 modelObjects = objs,
+                                 links      = (map snd orderedlinks),
+                                 auxFunc            = aux,
+                                 auxFunc2     = aux2,
+                                 tags       = trimmedArray
+                }
+
+
+scanTag :: [(String,(MD3Model,IORef(AnimState)))] -> [MD3Tag] -> IO [(Int,(MD3Model,IORef(AnimState)))]
+scanTag [] _ = return []
+scanTag ((s,m):sms) tgs = do
+   case (findIndex ((s==) . tagName)tgs) of
+         Just x -> do
+            rest <- (scanTag sms tgs)
+            return ((x,m):rest)
+
+splitTags :: Int -> [MD3Tag] -> [[MD3Tag]]
+splitTags _ [] = []
+splitTags n tgs = (take n tgs):(splitTags n $ drop n tgs)
+
+trimTags ::
+   [Int] ->
+          [[MD3Tag]] ->
+                [[((Float,Float,Float),(Float,Float,Float,Float))]]
+trimTags _ [] = []
+trimTags n (t:ts) = (map (getTagpos.(t!!)) n):(trimTags n ts)
+   where getTagpos u = (tagPos u, rotation u)
+
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- read the weapon models
+
+
+readWeaponModel :: FilePath -> FilePath -> IO Model
+readWeaponModel filePath shader = do
+   weapon <- readWeapon filePath shader
+   anim <- noAnims
+   p <- newIORef (Nothing)
+   wf <- newIORef (Nothing)
+   return Model {
+         modelRef   = weapon,
+         pitch    = p,
+         weapFire   = wf,
+         upperState =anim,
+         lowerState =anim
+   }
+
+
+readWeapon :: FilePath  -> FilePath -> IO MD3Model
+readWeapon filePath shader = withBinaryFile filePath $ \handle -> do
+   header    <- readMD3Header handle
+   weaponTex <- (readMD3Shader shader)
+   texObj    <- mapM getAndCreateTexture (map ("tga/models/weapons/"++) weaponTex)
+   readBones handle header
+   readTags handle header
+   hash1           <- (fromList hashString [])
+   objs    <- readMeshes handle header hash1
+   let objs2      = map attachTex (zip texObj objs)
+   let emptyList = listArray (0,0) []
+   aux     <- newIORef (Nothing)
+   aux2    <- newIORef (Nothing)
+   return MD3Model {
+                   numOfTags     = 0,
+                   modelObjects = objs2,
+                   links                 = [],
+                   auxFunc       = aux,
+                   auxFunc2      = aux2,
+                   tags          = emptyList
+   }
+
+-- attaches the texture to the weapon
+attachTex :: (Maybe TextureObject,MeshObject) -> MeshObject
+attachTex (texObj,object) =
+   MeshObject {
+         numOfVerts     = numOfVerts    object,
+         numOfFaces     = numOfFaces    object,
+         numTexVertex   = numTexVertex object,
+         materialID     = texObj,
+         bHasTexture    = True,
+         objName                = objName    object,
+         verticesp      = verticesp  object,
+         normals                = normals    object,
+         texCoordsl     = texCoordsl object,
+         texCoords      = texCoords  object,
+         vertPtr                = vertPtr    object,
+         numIndices     = numIndices object,
+         vertIndex      = vertIndex  object,
+         indexBuf       = indexBuf   object,
+         texBuf         = texBuf           object,
+         vertBuf                = vertBuf    object
+   }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the mesh information
+
+
+readMeshes ::
+   Handle -> MD3Header ->
+         (HashTable String (Maybe TextureObject)) -> IO [MeshObject]
+readMeshes handle header hashTable= do
+                 posn <- hTell handle
+                 meshObjects <- readMeshData handle posn (numMeshes header) hashTable
+                 return meshObjects
+
+
+readMeshData ::
+   Handle -> Integer -> Int ->
+         (HashTable String (Maybe TextureObject)) -> IO [MeshObject]
+readMeshData handle posn meshesLeft hashTable
+    | meshesLeft <= 0 = return []
+    | otherwise = do
+                header <- readMD3MeshHeader handle
+                readSkins handle header
+                faces <- readFaces handle posn header
+                texcoords <- readTexCoords handle posn header
+                vertices <- readVertices handle posn header
+                hSeek handle AbsoluteSeek (posn+(fromIntegral (meshSize header)))
+                object <- convertMesh header faces texcoords vertices hashTable
+                objects <-
+                   readMeshData handle
+                        (posn+(fromIntegral (meshSize header))) (meshesLeft-1) hashTable
+                return (object:objects)
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- converts the vertex, texture, face information into
+-- a meshobject
+
+
+convertMesh :: MD3MeshHeader ->
+   [MD3Face] -> [MD3TexCoord] -> [MD3Vertex] ->
+          (HashTable String (Maybe TextureObject)) -> IO MeshObject
+convertMesh header faceIndex texcoords vertices hashTable = do
+    let verts           = map vert vertices
+    let scaledVerts = map devideBy64 verts
+    let keyframes       = devideIntoKeyframes (numVertices  header) scaledVerts
+
+    imPTR <- mapM (Foreign.Marshal.Array.newArray) (map convertVert keyframes)
+    let facesArrayp = listArray (0,((length imPTR)-1)) imPTR
+
+    uvs     <- convertTex faceIndex texcoords
+    uvptr   <- Foreign.Marshal.Array.newArray (convertTex2 texcoords)
+    indces  <- Foreign.Marshal.Array.newArray (convertInd faceIndex)
+    vPtr          <- mallocBytes ((length (head keyframes))*12)
+
+    [a] <- genObjectNames 1
+    {-bindBuffer ArrayBuffer $= Just a
+         bufferData ArrayBuffer $=
+          (fromIntegral (3*((length (head keyframes))*3)*4),
+                 facesArrayp!0 , StaticDraw)
+         arrayPointer VertexArray $=
+           VertexArrayDescriptor 3 Float 0 nullPtr-}
+
+    [b] <- genObjectNames 1
+    {-bindBuffer ArrayBuffer $= Just b
+         bufferData ArrayBuffer $=
+            (fromIntegral (4*(length (convertTex2 texcoords))),
+                    uvptr, StaticDraw)
+         arrayPointer TextureCoordArray $=
+            VertexArrayDescriptor 2 Float 0 nullPtr-}
+
+    [c] <- genObjectNames 1
+    {-bindBuffer ElementArrayBuffer $= Just c
+         bufferData ElementArrayBuffer $=
+            (fromIntegral ((fromIntegral (length (head faces)))*12),
+                   indices, StaticDraw)
+         arrayPointer TextureCoordArray $=
+            VertexArrayDescriptor 2 Float 0 nullPtr-}
+
+    tex <- (Data.HashTable.lookup hashTable (strName header))
+    return MeshObject {
+            numOfVerts    = (length (head keyframes))*3,
+            numOfFaces    = 3*(fromIntegral (numTriangles header)),
+            numTexVertex  = numVertices  header,
+            materialID    = fromJust tex,
+            bHasTexture   = False,
+            objName        = strName header,
+            verticesp      = facesArrayp,
+            normals        = [],
+            texCoords      = uvptr,
+            texCoordsl    = uvs,
+            vertPtr        = vPtr,
+            numIndices    = fromIntegral  ((numTriangles header)*3),
+            vertIndex      = indces,
+            indexBuf = c,
+            texBuf = b,
+            vertBuf = a
+        }
+
+
+convertInd :: [(Int,Int,Int)] -> [CInt]
+convertInd [] = []
+convertInd ((i1,i2,i3):is) =
+   [fromIntegral i1,fromIntegral  i2,fromIntegral  i3]++(convertInd is)
+
+
+convertTex2 :: [(Float,Float)] -> [Float]
+convertTex2 [] = []
+convertTex2 ((u,v):uvs) = [u,v]++(convertTex2 uvs)
+
+
+convertVert :: [(Float,Float,Float)] -> [Float]
+convertVert [] = []
+convertVert ((x,y,z):xyzs) = [x,y,z]++(convertVert xyzs)
+
+
+convertTex ::
+   [(Int,Int,Int)] ->
+          [(Float,Float)] ->
+                IO [((Float,Float),(Float,Float),(Float,Float))]
+convertTex indces uvs = do
+   let uvarray = listArray (0,((length uvs)-1)) uvs
+   let uv = map (getUVs uvarray) indces
+   return uv
+
+
+getUVs ::
+   Array Int (Float,Float) ->
+         (Int,Int,Int) ->
+            ((Float,Float),(Float,Float),(Float,Float))
+getUVs uvs (i1,i2,i3) = (uvs ! i1, uvs ! i2 , uvs ! i3)
+
+
+devideIntoKeyframes :: Int ->
+   [(Float,Float,Float)] -> [[(Float,Float,Float)]]
+devideIntoKeyframes _ [] = []
+devideIntoKeyframes n verts =
+   (take n verts):(devideIntoKeyframes n (drop n verts))
+
+
+devideBy64 :: (Float,Float,Float) -> (Float,Float,Float)
+devideBy64 (x,y,z) = (x / 64,y /64,z / 64)
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the vertices
+
+readVertices ::
+   Handle -> Integer -> MD3MeshHeader -> IO [MD3Vertex]
+readVertices handle posn header = do
+   hSeek handle AbsoluteSeek (posn+(fromIntegral (vertexStart header)))
+   buf <- mallocBytes ((numMeshFrames header)*(numVertices header)*8)
+   hGetBuf handle buf ((numMeshFrames header)*(numVertices header)*8)
+   let ptrs = getPtrs buf ((numMeshFrames header)*(numVertices header)) 8
+   triangles <- mapM readVertex ptrs
+   free buf
+   return triangles
+
+readVertex :: Ptr a -> IO MD3Vertex
+readVertex ptr = do
+   [f1,f2,f3] <- peekArray 3 (castPtr ptr :: Ptr CShort)
+   [n1,n2] <- peekArray 2 (plusPtr (castPtr ptr :: Ptr CUChar) 6)
+   return MD3Vertex {
+                   vert =(realToFrac f1,realToFrac f2,realToFrac        f3),
+                   norm = (n1,n2)
+   }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the texture coordinates
+
+
+readTexCoords :: Handle -> Integer -> MD3MeshHeader -> IO [MD3TexCoord]
+readTexCoords handle posn header = do
+   hSeek handle AbsoluteSeek (posn+(fromIntegral (uvStart header)))
+   buf <- mallocBytes ((numVertices header)*8)
+   hGetBuf handle buf ((numVertices header)*8)
+   let ptrs = getPtrs buf (numVertices header) 8
+   texcoords <- mapM readTexCoord ptrs
+   free buf
+   return texcoords
+
+readTexCoord :: Ptr a -> IO MD3TexCoord
+readTexCoord ptr = do [f1,f2] <- getFloats ptr 2
+                      return (f1,f2)
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the models faces
+
+
+readFaces :: Handle -> Integer -> MD3MeshHeader -> IO [MD3Face]
+readFaces handle posn header = do
+   hSeek handle AbsoluteSeek (posn+(fromIntegral (triStart header)))
+   buf <- mallocBytes ((numTriangles header)*12)
+   hGetBuf handle buf ((numTriangles header)*12)
+   let ptrs = getPtrs buf (numTriangles header) 12
+   faces <- mapM readFace ptrs
+   free buf
+   return faces
+
+
+readFace :: Ptr a -> IO MD3Face
+readFace ptr = do
+   [f1,f2,f3] <- getInts ptr 3
+   return (f1,f2,f3)
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the MD3 skins
+
+
+readSkins ::Handle -> MD3MeshHeader -> IO [String]
+readSkins handle header = do
+   buf <- mallocBytes ((numSkins header)*68)
+   hGetBuf handle buf ((numSkins header)*68)
+   let skinPtrs = getPtrs buf (numSkins header) 68
+   skins <- mapM readSkin skinPtrs
+   free buf
+   return skins
+
+
+readSkin :: Ptr a -> IO String
+readSkin buf = do
+   skin <- getString buf 68
+   return skin
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads a meshheader
+
+
+readMD3MeshHeader :: Handle -> IO MD3MeshHeader
+readMD3MeshHeader handle = do
+   buf <- mallocBytes 108
+   hGetBuf handle buf 108
+   mID <- getString buf 4
+   meshName <- getString (plusPtr buf 4) 68
+   [i1,i2,i3,i4,i5,i6,i7,i8,i9] <- getInts (plusPtr buf 72) 9
+   free buf
+   return $
+         MD3MeshHeader {
+            meshID         = mID,
+            strName        = meshName,
+            numMeshFrames = i1,
+            numSkins       = i2,
+            numVertices   = i3,
+            numTriangles  = i4,
+            triStart       = i5,
+            meshHeaderSize= i6,
+            uvStart        = i7,
+            vertexStart   = i8,
+            meshSize       = i9
+        }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the tags
+
+
+readTags :: Handle -> MD3Header -> IO [MD3Tag]
+readTags handle header = do
+   buf <- mallocBytes (112*(numFrames header)*(numTags header))
+   hGetBuf handle buf (112*(numFrames header)*(numTags header))
+   let ptrs = getPtrs buf ((numFrames header)*(numTags header)) 112
+   tgs <- mapM readTag ptrs
+   free buf
+   return tgs
+
+readTag :: Ptr a -> IO MD3Tag
+readTag buf = do
+   tName <- getString buf 64
+   [f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12] <- getFloats (plusPtr buf 64) 12
+   let quat = mat2Quat ((f4,f5,f6),(f7,f8,f9),(f10,f11,f12))
+   return $ MD3Tag {
+                    tagName = tName,
+                    tagPos =(f1,f2,f3),
+                    rotation = quat
+   }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads the bones which we don't use
+
+
+readBones :: Handle -> MD3Header -> IO [MD3Bone]
+readBones handle header = do
+   buf <- mallocBytes (56*(numFrames header))
+   hGetBuf handle buf (56*(numFrames header))
+   let ptrs = getPtrs buf (numFrames header) 56
+   bones <- mapM readBone ptrs
+   free buf
+   return bones
+
+
+readBone :: Ptr a-> IO MD3Bone
+readBone buf = do
+   [f1,f2,f3,f4,f5,f6,f7,f8,f9,f10] <- getFloats buf 10
+   string <- getString (plusPtr buf 40) 16
+   return MD3Bone {
+                           minPos = (f1,f2,f3),
+                           maxPos = (f4,f5,f6),
+                           bonePos = (f7,f8,f9),
+                           bscale = f10,
+                           creator = string
+                }
+
+
+
+
+-- - - - - - - - - - - - - - - - - - -
+-- reads animations from the animation.cfg file
+
+
+readAnimations ::
+   FilePath -> IO (Array Int MD3Animation,Array Int MD3Animation)
+readAnimations filepath = withBinaryFile filepath $ \handle -> do
+           lnes <- readLines handle
+           animsl <- mapM readAnimation lnes
+           let anms = concat animsl
+           let upperAnims = filter (matchPrefix "TORSO") anms
+           let lowerAnims = filter (matchPrefix "LEGS") anms
+           let bothAnims  = filter (matchPrefix "BOTH") anms
+           let fixedLower =
+                   map (fixLower $ (startFrame $ head lowerAnims)-
+                                            (startFrame $ head upperAnims)) lowerAnims
+           return (listArray
+                            (0,((length (bothAnims++upperAnims))-1))
+                            (bothAnims++upperAnims),
+                         listArray (0,((length (bothAnims++fixedLower))-1))
+                            (bothAnims++fixedLower))
+
+
+readAnimation :: String -> IO [MD3Animation]
+readAnimation line
+    | length subStrings <= 0 = do
+                return []
+    | length subStrings >= 5 =
+          case (elem (subStrings !! 4) animList) of
+                True -> do
+                   let startF = (read $ subStrings!!0):: Int
+                   let numF   = (read $ subStrings!!1):: Int
+                   let loopF  = (read $ subStrings!!2):: Int
+                   let f      = (read $ subStrings!!3):: Int
+                   let aName  = subStrings!!4
+                   return [MD3Animation {
+                                    animName    = aName,
+                                    startFrame = startF,
+                                    endFrame    = startF + numF,
+                                    loopFrames = loopF,
+                                    fp         = 1000 * (1 / realToFrac f)
+                   }]
+                _ -> return []
+    | otherwise = do
+                return []
+    where
+          replc str  = map (replace' ['/','\n','\r']) str
+          subStrings = (words (replc line))
+
+
+fixLower :: Int -> MD3Animation -> MD3Animation
+fixLower offset anim = MD3Animation {
+                                           animName   = animName anim,
+                                           startFrame = (startFrame anim) - offset,
+                                           endFrame   = (endFrame anim) - offset,
+                                           loopFrames = loopFrames anim,
+                                           fp         = fp anim
+                                   }
+
+
+matchPrefix :: String -> MD3Animation -> Bool
+matchPrefix prefix anim =
+   prefix == head (words (map (replace' ['_']) (animName anim)))
+
+
+readLines :: Handle -> IO [String]
+readLines handle = do
+            eof <- hIsEOF handle
+            case (eof) of
+                 False -> do
+                                 lne <- hGetLine handle
+                                 lnes <- readLines handle
+                                 return (lne:lnes)
+                 _        -> return []
+
+-------------------------------------------------------------------------------
+
+
+withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a
+withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose
+
+toInts :: (Integral a)=>[a] -> [Int]
+toInts a = map fromIntegral a
+
+toFloats :: (Real a) => [a] -> [Float]
+toFloats a = map realToFrac a
+
+getInts :: Ptr a -> Int -> IO [Int]
+getInts ptr n = do ints <- peekArray n (castPtr ptr:: Ptr CInt)
+                   return $ toInts ints
+
+getFloats :: Ptr a -> Int -> IO [Float]
+getFloats ptr n = do floats <- peekArray n (castPtr ptr :: Ptr CFloat)
+                     return $ toFloats floats
+
+getString :: Ptr a -> Int -> IO String
+getString ptr _ = do string <- peekCString (castPtr ptr :: Ptr CChar)
+                     return string
+
+getPtrs :: Ptr a -> Int -> Int -> [Ptr a]
+getPtrs ptr lngth size= map ((plusPtr ptr).(size*)) [0.. (lngth-1)]
+
+
+ src/Main.hs view
@@ -0,0 +1,426 @@+{- Main.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005++Main module++-}++module Main where+++import TextureFonts+import Graphics.UI.GLUT+import Graphics.Rendering.OpenGL+import Data.IORef+import Data.Maybe+import Monad+import qualified HGL as HGL+import AFRP+import AFRPInternals+import AFRPForceable+import Game+import Parser+import Object+import BSP+import Camera+import System(ExitCode(..), exitWith)+import Matrix+import MD3+import Data.HashTable+import Frustum+import Data.List (find)+import Textures+import MapCfg+import Render++msInterval :: Int+msInterval = 16++clkRes :: Double+clkRes = 1000++data Input+  = KBMInput  { key :: Key,+                         keyState :: KeyState,+                         modifiers :: Modifiers,+                         pos :: Position}+  | MouseMove { pos :: Position }+ deriving Show++type OGLInput = Maybe Input+type WinInput = Event HGL.Event++main :: IO ()+main = do+   (progName,names) <-getArgsAndInitialize+   case names of+    []     -> printUsage progName+    [name] -> do createAWindow "FRAG" name+                 mainLoop+    _      -> printUsage progName++printUsage :: String -> IO ()+printUsage n = do putStrLn $ "Usage: "   ++ n ++ " <level>"+                  putStrLn $ "Example: " ++ n ++ " leveleg"++createAWindow :: String -> String -> IO ()+createAWindow windowName level = do+   initialDisplayMode $= [WithDepthBuffer, DoubleBuffered, RGBAMode]+   drawBuffer             $= BackBuffers+   initialWindowSize  $= (Size 640 480)+   createWindow windowName+   clear [ColorBuffer]+   viewport               $= ((Position 0 0), Size 640 480)+   matrixMode             $= Projection+   loadIdentity+   perspective 70.0 (640/480) 10.0  4000.0+   matrixMode             $= Modelview 0+   loadIdentity+   depthFunc              $= Just Less+   texture Texture2D  $=  Enabled+   cullFace               $= Just Front+   cursor                 $= None++   --load our level objects from the *.cfg file+   iobjs <- readMapCfg (level ++ ".cfg")++   let cam = initCamera (80::Int,61::Int,60::Int) (80::Int,611::Int,59::Int) (0::Int,1::Int,0::Int)+   camRef <- newIORef(cam)++   --read the BSP files and player models specified in the *.med files+   (mapRef,modls) <- readMapMedia (level ++ ".med")++   listModels <- toList modls+   animList   <- mapM getAnims listModels++   --complete the objects+   let objs = toCompleteObjects animList iobjs++   --build the fonts+   (tex,base)<- buildFonts+   numbase <- buildBigNums++   --create a hashmap  for textures+   texs <- fromList hashString []++   --create the crosshair+   crosshair <- getAndCreateTexture "crosshaira"+   insert texs "crosshair" crosshair++   --set up the variables needed by our callbacks and game loop+   tme            <- get elapsedTime+   lasttime        <- newIORef(tme)+   lastDTime       <- newIORef(tme)+   lastDTime2      <- newIORef(tme)+   fpsc1                   <- newIORef(0,0)+   fps1            <- newIORef(0,0,0)+   newIORef(0::Int)+   _      <- newIORef(tme)+   --hold new keyboard input+   newInput        <- newIORef(Nothing)+   inpState        <- newIORef (False)+   --hold the new mouse input+   newMouseInput  <- newIORef(Nothing)+   --lock the mouse or not+   lck             <- newIORef(True)+   (_, _)       <- getWinInput+                                    (lasttime, (newInput,newMouseInput)) inpState True tme+   hasReact        <- newIORef(False)+   mp             <- readIORef mapRef++   let gd = GameData {+          gamemap        = mapRef,+          models         = modls,+          textures       = texs,+          camera         = camRef,+          lastDrawTime   = lastDTime,+          lastDrawTime2  = lastDTime2,+          hasReacted     = hasReact,+          fonts          = (tex,base),+          nbase          = numbase,+          lock           = lck,+          fpsc           = fpsc1,+          fpss           = fps1,+          nems           = ((length objs)-1)+   }+++   rh <-+         reactInit+            (initr lasttime (newInput,newMouseInput) inpState)+            (actuate gd)+            (repeatedly (0.016) () &&&(parseWinInput >>> game mp objs))+++   --set up the callbacks+   displayCallback              $= display+   keyboardMouseCallback $= Just (keyboardMouse newInput newMouseInput lck)+   motionCallback               $= Just (dragMotion    newMouseInput)+   passiveMotionCallback $= Just (mouseMotion   newMouseInput)+   idleCallback         $=+        Just (idle lasttime (newInput,newMouseInput)+           hasReact (tex,base) inpState rh)++   where getAnims (x,y) = do+            us <- readIORef (upperState y)+            ls <- readIORef (lowerState y)+            return (x,us,ls)+++++-------------------------------------------------------------------------------+-- functions to connect Haskell and Yampa+++actuate :: GameData -> ReactHandle a b ->+   Bool -> (Event (), [ObsObjState]) -> IO Bool+actuate  gd _ _ (e, noos) = do+   when (force (noos) `seq` isEvent e)+        (render gd noos)+   return False+++initr :: IORef(Int) -> (IORef(OGLInput),IORef(OGLInput)) ->+   (IORef(Bool))  -> IO (WinInput,WinInput)+initr lasttime newInput inpState = do+         tme     <- get elapsedTime+         writeIORef lasttime 1+         (_, inp) <- getWinInput (lasttime, newInput)  inpState True tme+         case inp of+            Just i -> return i+            Nothing -> return (noEvent,noEvent)++-------------------------------------------------------------------------------+-- graphics++render :: GameData -> [ObsObjState] -> IO()+render gd oos = do+  -- get the last time we drew the screen+  lastime <- readIORef (lastDrawTime gd)+  -- the current time+  tme   <- get elapsedTime+  l <- readIORef (lock gd)++  -- if the last time is at least greater than 0.016+  -- seconds and the mouse is locked reset the position+  -- to the middle of the screen+  case ((realToFrac ((tme - lastime) :: Int)) / (1000))+        >= (1/60) && l == True of+        True -> do+           pointerPosition      $= (Position 320 240)+           writeIORef (lastDrawTime gd) tme+        _ -> return ()++  _ <- readIORef (lastDrawTime2 gd)+  _ <- readIORef (hasReacted gd)++  --case (((realToFrac (time - lastTime2))/1000) <= (1/60)) of+  case (True) of+        True -> do+                    -- initial setup+                    clear [ ColorBuffer, DepthBuffer ]+                    loadIdentity++                    --find the camera and set our view+                    let playerState = findCam oos+                    case (cood playerState) of+                         [] -> return ()+                         _ -> print (getPos (cood playerState))+                    let cam = setCam $ playerState+                    writeIORef (camera gd) cam+                    cameraLook cam++                    --render the map+                    renderBSP (gamemap gd) (cpos cam)++                    --render the objects+                    mp <- readIORef (gamemap gd)+                    frust <- getFrustum+                    mapM_ (renderObjects (camera gd) (models gd) frust mp) oos++                    --render the gun+                    renderGun cam (models gd)++                    --set up orthographics mode so we can draw the fonts+                    renderHud gd playerState (length oos) tme++                    writeIORef (lastDrawTime2 gd) tme+                    writeIORef (hasReacted gd) False+                    swapBuffers+        _       -> do+                    writeIORef (lastDrawTime2 gd) tme+                    return()+++getPos :: [(Double,Double,Double)] -> [(Int,Int,Int)]+getPos coords = map ints l+        where+          l = map (vectorAdd (0,90,0)) coords+          ints (x,y,z)= (truncate x,truncate y,truncate z)+++findCam :: [ObsObjState] -> ObsObjState+findCam states = fromJust $ find (\x -> (isCamera x)) states+++setCam :: ObsObjState -> Camera+setCam (OOSCamera {oldCam = cam, newCam = _}) =  cam+++-------------------------------------------------------------------------------+--callbacks++display :: (Monad t) => t ()+display = return ()+++keyboardMouse ::+   IORef(OGLInput) -> IORef(OGLInput) -> IORef(Bool) ->  KeyboardMouseCallback+keyboardMouse _ _ lck (Char 'z') _ _ _  = do+   readIORef lck+   writeIORef lck (False)+keyboardMouse _ _ lck (Char 'x') _ _ _  = do+   _ <- readIORef lck+   writeIORef lck (True)+keyboardMouse _ _ _ (Char '\27') _ _ _  = exitWith ExitSuccess+keyboardMouse _ newMouse _ newKey@(MouseButton _)+   newKeyState newModifiers newPosition = do+         writeIORef  newMouse (Just KBMInput{+                                                        key             = newKey,+                                                        keyState        = newKeyState,+                                                        modifiers = newModifiers,+                                                        pos             = newPosition})+keyboardMouse newInput _ _ newKey+   newKeyState newModifiers newPosition = do+         writeIORef newInput (Just KBMInput{+                                                        key              = newKey,+                                                        keyState         = newKeyState,+                                                        modifiers  = newModifiers,+                                                        pos              = newPosition})+++mouseMotion :: IORef(OGLInput) -> MotionCallback+mouseMotion newInput newCursorPos = do+   lst <- readIORef newInput+   case lst of+         (Just inp) -> writeIORef newInput (Just inp)+         _          -> writeIORef newInput (Just MouseMove {pos=newCursorPos})+++dragMotion :: IORef(OGLInput) -> MotionCallback+dragMotion newInput newCursorPos = do+   lst <- readIORef newInput+   case lst of+         (Just inp) -> writeIORef newInput (Just inp)+         _          -> writeIORef newInput (Just MouseMove {pos=newCursorPos})+++idle :: IORef(Int) -> (IORef(OGLInput),IORef(OGLInput)) ->IORef(Bool) ->+  (Maybe TextureObject,DisplayList) -> (IORef(Bool)) ->+        ReactHandle (WinInput,WinInput) (Event (), ([Object.ObsObjState])) -> IO()+idle lasttime newInput hasreacted _ inputState rh = do+   lTime <- readIORef lasttime+   currenttime <- get elapsedTime+   case (currenttime - lTime >= 16) of+         True -> do+            (dt, input) <-+                  getWinInput (lasttime,newInput) inputState True currenttime+            react rh (dt,input)+            writeIORef hasreacted True+            writeIORef lasttime currenttime+            return ()+         _ -> return ()++++++-------------------------------------------------------------------------------+-- input handling+-- mimic HGL so the parser from Space Invaders can be used+getWinInput ::+   (IORef(Int),(IORef(OGLInput),IORef(OGLInput))) ->+         (IORef(Bool)) -> Bool -> Int-> IO(DTime,(Maybe (WinInput,WinInput)))+getWinInput (lasttime, (newInput,newMouseInput)) inpState _ currenttime = do+   lTime <- readIORef lasttime+   newIn <- readIORef newInput+   newMouseIn <- readIORef newMouseInput+   writeIORef newInput Nothing+   writeIORef newMouseInput Nothing++   -- we try to get rid of redundant events+   hasReset <- readIORef inpState+   mmin <-+         case (coalesce newIn, coalesce newMouseIn,hasReset) of+           (NoEvent, NoEvent,_) -> return Nothing+           (NoEvent, Event HGL.MouseMove {HGL.pt =HGL.Point (320,240)},False)-> do+                  writeIORef inpState False+                  return Nothing+           (NoEvent, Event HGL.MouseMove {HGL.pt =HGL.Point (320,240)},True) -> do+                  writeIORef inpState False+                  return $  Just (coalesce newIn,coalesce newMouseIn)+           (NoEvent, Event HGL.MouseMove {HGL.pt = _ },True) -> do+                  writeIORef inpState True+                  return $ Just (coalesce newIn,coalesce newMouseIn)+           (NoEvent, Event HGL.MouseMove {HGL.pt = _ },False) -> do+                  writeIORef inpState True+                  return $ Just (coalesce newIn,coalesce newMouseIn)+           (Event _, Event HGL.MouseMove {HGL.pt =HGL.Point (320,240)},False)-> do+                  writeIORef inpState False+                  return $ Just (coalesce newIn,noEvent)+           (Event _, Event HGL.MouseMove {HGL.pt =HGL.Point (320,240)},True) -> do+                  writeIORef inpState False+                  return $ Just (coalesce newIn,coalesce newMouseIn)+           (Event _, Event HGL.MouseMove {HGL.pt = _},True) -> do+                  writeIORef inpState True+                  return $ Just (coalesce newIn,coalesce newMouseIn)+           (Event _, Event HGL.MouseMove {HGL.pt = _},False) -> do+                  writeIORef inpState True+                  return $ Just (coalesce newIn,coalesce newMouseIn)+           (_,_,_) -> do+                  writeIORef inpState True+                  return $ Just (coalesce newIn,coalesce newMouseIn)++   return ((fromIntegral (currenttime-lTime))/clkRes, mmin)+++coalesce :: OGLInput -> WinInput+coalesce Nothing = NoEvent+coalesce (Just KBMInput {key            = (MouseButton button),+                                        keyState        = ks,+                                        pos             = p}) =+   (Event HGL.Button {+          HGL.pt           = (pos2Point p),+          HGL.isLeft = (isMBLeft (MouseButton button)),+          HGL.isDown = (isKeyDown ks)})+coalesce (Just KBMInput {key            = (Char a),+                                        keyState        = ks}) =+   (Event HGL.Char {HGL.char = a,+                                HGL.isDown = (isKeyDown ks)})+coalesce (Just MouseMove {pos= p}) =+   (Event HGL.MouseMove { HGL.pt = pos2Point p })+coalesce _ = NoEvent+++pos2Point :: Position -> HGL.Point+pos2Point (Position a b) = HGL.Point (fromIntegral a, fromIntegral b)+++isMBLeft :: Key -> Bool+isMBLeft (MouseButton LeftButton) = True+isMBLeft _ = False+++isKeyDown :: KeyState -> Bool+isKeyDown Down = True+isKeyDown _     = False+++filter :: Eq a => a -> a -> Maybe(a)+filter a b =+   if (a == b) then+         Just(a)+   else+         Nothing++
+ src/MapCfg.hs view
@@ -0,0 +1,153 @@+-- MapCfg.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+{-
+
+reads the level configuration files and map media files
+
+-}
+
+
+module MapCfg where
+
+import BSP
+import Camera
+import Control.Exception ( bracket )
+import Data.HashTable (HashTable,lookup,insert,fromList,hashString)
+import Data.IORef
+import Data.List (find)
+import Data.Maybe
+import IdentityList
+import MD3
+import Object
+import Object
+import ObjectBehavior
+import Prelude
+import System.IO hiding (withBinaryFile)
+
+
+data ObjectConstructor =
+   ConsCamera Camera |
+   ConsAICube {startPosition :: (Double,Double,Double),
+               size          :: (Double,Double,Double),
+               wayPoints     :: [(Double,Double,Double)],
+               modlName      :: String}
+               deriving (Read,Show)
+
+
+readMapCfg :: FilePath -> IO [IntermediateObject]
+readMapCfg filepath = withBinaryFile filepath $ \handle -> do
+   lnes <- readLines handle
+   print lnes
+   let objects  = map lines2ObjectCons lnes
+   return $ map objectCons2IntermediateObjects objects
+
+readMapMedia :: FilePath -> IO (IORef BSPMap,(HashTable String Model))
+readMapMedia filepath = withBinaryFile filepath $ \handle -> do
+   lnes <- readLines handle
+   print lnes
+   let levelModels = lines2LevelModels lnes
+   let (MMap lvlName) = head levelModels
+   bsp <- readBSP lvlName
+   hash <- fromList hashString []
+   mapM_ (readLevelModels hash) (tail levelModels)
+   return (bsp,hash)
+
+
+readLevelModels :: HashTable String Model -> LevelModel -> IO ()
+readLevelModels hash (MWeapon name) =
+   getWeaponModel hash name
+readLevelModels hash (MPlayerModel name weaponName) =
+   getModel hash name weaponName
+
+
+getModel :: HashTable String Model -> String -> String -> IO ()
+getModel hash name weaponName = do
+   getWeaponModel hash weaponName
+   Just weapon <- Data.HashTable.lookup hash weaponName
+   model       <- readModel name weapon
+   insert hash name model
+
+
+getWeaponModel :: HashTable String Model -> String -> IO ()
+getWeaponModel hash name = do
+   model <- Data.HashTable.lookup hash name
+   case model of
+      Just _ -> return ()
+      Nothing -> do
+                weaponModel <-
+                  readWeaponModel
+                    ("tga/models/weapons/"++name++".md3") ("tga/models/weapons/"++name++".shader")
+                insert hash name weaponModel
+
+
+readLines :: Handle -> IO [String]
+readLines handle = do
+         eof <- hIsEOF handle
+         case (eof) of
+           False -> do
+                     line <- hGetLine handle
+                     lnes <- readLines handle
+                     return (line:lnes)
+           _     -> return []
+
+withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a
+withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose
+
+
+data LevelModel = MWeapon String |
+                  MPlayerModel String String |
+                  MMap String deriving (Read,Show)
+
+
+data IntermediateObject =
+   ICamera ([(String, AnimState, AnimState)] ->
+      [(ILKey, Message)] -> ILKey -> Object) |
+   IAICube ((AnimState,AnimState) -> ILKey -> Object) String
+
+
+lines2ObjectCons :: String -> ObjectConstructor
+lines2ObjectCons str
+ | head (words str) == "ConsCamera" = read str :: ObjectConstructor
+ | head (words str) == "ConsAICube" = read str :: ObjectConstructor
+
+
+lines2LevelModels :: [String] -> [LevelModel]
+lines2LevelModels [] = []
+lines2LevelModels (str:strs) = (read str): (lines2LevelModels  strs)
+
+
+objectCons2IntermediateObjects :: ObjectConstructor -> IntermediateObject
+objectCons2IntermediateObjects (ConsCamera cam) =
+   ICamera (camera cam)
+objectCons2IntermediateObjects c@(ConsAICube {}) =
+   IAICube
+     (aicube (startPosition c) (size c) (wayPoints c)(modlName c)) (modlName c)
+
+
+toCompleteObjects ::
+   [(String, AnimState, AnimState)] ->
+      [IntermediateObject] -> [ILKey->Object]
+toCompleteObjects animList iobjs =
+   map (toCompleteObject animList) iobjs
+
+
+toCompleteObject ::
+   [(String, AnimState, AnimState)] ->
+      IntermediateObject -> (ILKey->Object)
+toCompleteObject animList (ICamera func) =
+   func animList []
+toCompleteObject animList (IAICube func modelname) =
+   func (findModelAnim modelname animList)
+
+
+findModelAnim ::
+   String ->
+      [(String,AnimState,AnimState)] ->
+          (AnimState,AnimState)
+findModelAnim name anms = (ua,la)
+   where
+      (_,ua,la) =
+          fromJust $ find (\(x,_,_)->(x==name)) anms
+
+
+
+ src/Matrix.hs view
@@ -0,0 +1,86 @@+-- Matrix.hs; Hugh Rayner (hnra275@cse.unsw.edu.au) 2004++-- This module performs several linear algebra functions which are necessary for the game.+-- The are used for functions such as rotation of the player and collision detection.++module Matrix where++import Graphics.UI.GLUT++--type Vec3 = (GLdouble,GLdouble,GLdouble)+type Vec3 = (Double,Double,Double)+type Mat3 = (Vec3,Vec3,Vec3)++mapTup::(a->b)->(a,a,a)->(b,b,b)+mapTup f (a,b,c) = (f a, f b, f c)++-- Finds the dot product of two vectors+dotProd :: Vec3->Vec3->Double+dotProd (a,b,c) (aa,bb,cc) = a*aa + b*bb + c*cc++-- Finds the cross product of two 3-vectors+crossProd::Vec3->Vec3->Vec3+crossProd (a,b,c) (aa,bb,cc) = (b*cc-c*bb,c*aa-a*cc,a*bb-b*aa)++-- Finds the transpose of a 3*3 matrix+transpose3 :: Mat3->Mat3+transpose3 ((a1,a2,a3),(b1,b2,b3),(c1,c2,c3)) = ((a1,b1,c1),(a2,b2,c2),(a3,b3,c3))++-- Multiplies a 3*3 matrix with a 3-vector+matrixVectorMult ::Mat3->Vec3->Vec3+matrixVectorMult m v = mapTup (dotProd v) m++-- As above, but arguments swapped+matrixVectorMult2 ::Vec3->Mat3->Vec3+matrixVectorMult2 v m = mapTup (dotProd v) m++-- Multiplies two 3*3 matrices+matrixMult :: Mat3->Mat3->Mat3+matrixMult m1 m2 = (mapTup (matrixVectorMult (transpose3 m1)) m2)++-- As above, but arguments swapped+matrixMult2 :: Mat3->Mat3->Mat3+matrixMult2 m2 m1 = (mapTup (matrixVectorMult (transpose3 m1)) m2)++-- Adds two vectors+vectorAdd :: Vec3->Vec3->Vec3+vectorAdd (a1,a2,a3) (b1,b2,b3) = (a1+b1,a2+b2,a3+b3)++-- Subtracts two vectors+vectorSub :: Vec3->Vec3->Vec3+vectorSub (a1,a2,a3) (b1,b2,b3) = (a1-b1,a2-b2,a3-b3)++-- As above, but arguments swapped+vectorSub2 :: Vec3->Vec3->Vec3+vectorSub2 a b = vectorSub b a++-- Multiplies a vecotor by a scalar+vectorMult :: Vec3->Double->Vec3+vectorMult v s = mapTup (s*) v++-- finds the normal of a flat polygon+findNormal :: [Vec3] -> Vec3+findNormal (a:(b:(c:_))) = normalise (crossProd (vectorSub a b) (vectorSub c b))+findNormal _ = (0,0,0)++-- Normalises a vector+normalise :: Vec3 -> Vec3+normalise a = vectorMult a (sqrt (1/len a))+    where+       len (va,vb,vc) = va*va+vb*vb+vc*vc++-- Makes a Vertex3 (GLdouble) from a Vec3+vert::Vec3->Vertex3(GLdouble)+vert (x,y,z) = Vertex3 x y z++-- Makes a TexCoord2 (GLdouble) from a Vec3+coord::(Double,Double)->TexCoord2(GLdouble)+coord (x,y) = TexCoord2 x y++-- Makes a Vector3 (GLdouble) from a Vec3+vect::Vec3->Vector3(GLdouble)+vect (x,y,z) = Vector3 x y z++-- Makes a Normal3 (GLdouble) from a Vec3+norm3::Vec3->Normal3(GLdouble)+norm3 (x,y,z) = Normal3 x y z
+ src/Object.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE BangPatterns #-}++-- Object.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005++module Object (+    Object,+    ObjInput(..),+    ObjOutput(..),+    ObsObjState(..),+    Message(..),+    isRay,          -- :: ObsObjState -> Bool+    isAICube,       -- :: ObsObjState -> Bool+    isProjectile,  -- :: ObsObjState -> Bool+    isCamera,       -- :: ObsObjState -> Bool+) where++import AFRP (SF, Event)+import AFRPForceable (Forceable(), force)+import Camera+import IdentityList+import MD3 (AnimState)+import Parser (GameInput)+++type Object = SF ObjInput ObjOutput++data ObjInput = ObjInput {+          oiHit           :: !(Event [(ILKey,ObsObjState)]),+          oiMessage       :: !(Event [(ILKey,Message)]),+          oiCollision     :: !Camera,+          oiCollisionPos :: !(Double,Double,Double),+          oiOnLand        :: !Bool,+          oiGameInput     :: !GameInput,+          oiVisibleObjs  :: !(Event [(ILKey,ObsObjState)])+        }++data ObjOutput = ObjOutput {+    ooObsObjState :: !ObsObjState,+    ooSendMessage :: !(Event [(ILKey,(ILKey,Message))]),+    ooKillReq      :: (Event ()),+    ooSpawnReq    :: (Event [ILKey->Object])+}++data Message = Coord !(Double,Double,Double) |+                        PlayerLockedOn |+                        PlayerLockedOn2 |+                        TargetPosition !(Double,Double,Double) |+                        TargetPosition2 !(Double,Double,Double) |+                        EnemyDown++-- most fields are strict to prevent space leaks++data ObsObjState =+    OOSCamera {+          newCam          ::  !Camera,+          oldCam          ::  !Camera,+          health          ::  !Double,+          ammo    ::  !Double,+          score   ::  !Int,+          cood    ::  ![(Double,Double,Double)]+         }+    | OOSRay {+          rayStart ::    !(Double,Double,Double),+          rayEnd         ::      !(Double,Double,Double),+          rayUC  ::      !(Double,Double,Double),+          clipped  ::    !Bool,+          firedFrom :: !ILKey+         }+    | OOSProjectile {+          projectileOldPos :: !(Double,Double,Double),+          projectileNewPos :: !(Double,Double,Double),+          firedFrom :: !ILKey+         }+    | OOSWayPoint !(Double,Double,Double)+    | OOSAICube {+          oosOldCubePos  :: !(Double,Double,Double),+          oosNewCubePos  :: !(Double,Double,Double),+          oosCubeSize     :: !(Double,Double,Double),+          oosCubeAngle :: !Double,+          oosCubePitch :: !Double,+          upperAnim     :: !AnimState,+          lowerAnim     :: !AnimState,+          health                :: !Double,+          modelName     :: !String,+          target                :: !(Double,Double,Double),+          fade          :: !Float+         }++instance Forceable ObsObjState where+    -- If non-strict fields: oosNonStrict1 obj `seq` ... `seq` obj+    force obj = obj++isRay :: ObsObjState -> Bool+isRay (OOSRay {}) = True+isRay _            = False++isCamera :: ObsObjState -> Bool+isCamera (OOSCamera {}) = True+isCamera _                      = False++isAICube :: ObsObjState -> Bool+isAICube (OOSAICube {}) = True+isAICube _                 = False++isProjectile :: ObsObjState -> Bool+isProjectile (OOSProjectile {}) = True+isProjectile _            = False+
+ src/ObjectBehavior.hs view
@@ -0,0 +1,1358 @@+module ObjectBehavior (aicube, camera) where++import Maybe (fromJust)++import AFRP+import Camera+import IdentityList+import MD3+import Matrix+import Object+import Parser++ray ::+    (Double, Double, Double) ->+      (Double, Double, Double) -> ILKey -> ILKey -> Object+ray (x, y, z) (vx, vy, vz) firedfrom iD+  = (arr+       (\ oi ->+          let clippedPos = oiCollisionPos oi in+            let grounded = oiOnLand oi in ((), (clippedPos, grounded)))+       >>>+       (first (after 0.25 ()) >>>+          arr+            (\ (timeout, (clippedPos, grounded)) ->+               (grounded, (clippedPos, timeout))))+         >>>+         (first ((iPre False) <<< identity) >>>+            arr+              (\ (cl, (clippedPos, timeout)) ->+                 let (vvx, vvy, vvz) = normalise $ vectorSub end start in+                   (clippedPos, (cl, timeout, vvx, vvy, vvz))))+           >>>+           (first ((iPre start) <<< (arr not0)) >>>+              arr+                (\ (clip, (cl, timeout, vvx, vvy, vvz)) ->+                   (vvx, (cl, clip, timeout, vvy, vvz))))+             >>>+             (first (arr (\ vvx -> 7500 * vvx) >>> integral) >>>+                arr+                  (\ (ucx, (cl, clip, timeout, vvy, vvz)) ->+                     (vvy, (cl, clip, timeout, ucx, vvz))))+               >>>+               (first (arr (\ vvy -> 7500 * vvy) >>> integral) >>>+                  arr+                    (\ (ucy, (cl, clip, timeout, ucx, vvz)) ->+                       (vvz, (cl, clip, timeout, ucx, ucy))))+                 >>>+                 (first (arr (\ vvz -> 7500 * vvz) >>> integral) >>>+                    arr+                      (\ (ucz, (cl, clip, timeout, ucx, ucy)) ->+                         (cl, (cl, clip, timeout, ucx, ucy, ucz))))+                   >>>+                   (first edge >>>+                      arr+                        (\ (clipev, (cl, clip, timeout, ucx, ucy, ucz)) ->+                           ObjOutput{ooObsObjState =+                                       OOSRay{rayStart = start, rayEnd = clip,+                                              rayUC = vectorAdd start (ucx, ucy, ucz), clipped = cl,+                                              firedFrom = firedfrom},+                                     ooKillReq = timeout, ooSpawnReq = noEvent,+                                     ooSendMessage =+                                       clipev `tag` [(firedfrom, (iD, Coord clip))]})))+  where (start, end) = firePos (x, y, z) (vx, vy, vz)+        (_, _, _) = normalise $ vectorSub end start+        not0 c+          | c /= (0, 0, 0) = c+          | otherwise = (x, y, z)++projectile :: (Vec3, Vec3) -> ILKey -> ILKey -> Object+projectile ((sx, sy, sz), (vx, vy, vz)) firedfrom _+  = (arr+       (\ oi ->+            let grounded = oiOnLand oi in+              let hits = oiHit oi in (hits, grounded))+       >>>+       (first identity >>> arr (\ (hit, grounded) -> (grounded, hit))) >>>+         ((first ((iPre False) <<< identity) >>> first edge) >>>+            arr (\ (clipEv, hit) -> ((), (clipEv, hit))))+           >>>+           (first (arr (\ () -> 1500 * vx) >>> imIntegral sx) >>>+              arr (\ (x, (clipEv, hit)) -> ((), (clipEv, hit, x))))+             >>>+             (first (arr (\ () -> 1500 * vy) >>> imIntegral sy) >>>+                arr (\ (y, (clipEv, hit, x)) -> ((), (clipEv, hit, x, y))))+               >>>+               (first (arr (\ () -> 1500 * vz) >>> imIntegral sz) >>>+                  arr+                    (\ (z, (clipEv, hit, x, y)) ->+                       ((x, y, z), (clipEv, hit, x, y, z))))+                 >>>+                 (first (iPre (sx, sy, sz) <<< identity) >>>+                    arr+                      (\ (oldpos, (clipEv, hit, x, y, z)) ->+                         ((clipEv, hit), (oldpos, x, y, z))))+                   >>>+                   (first+                      (arr (\ (clipEv, hit) -> (isEvent clipEv || isEvent hit)) >>> edge)+                      >>>+                      arr+                        (\ (hitEv, (oldpos, x, y, z)) ->+                           ObjOutput{ooObsObjState =+                                       OOSProjectile{projectileOldPos = oldpos,+                                                     projectileNewPos = (x, y, z),+                                                     firedFrom = firedfrom},+                                     ooKillReq = hitEv, ooSpawnReq = noEvent,+                                     ooSendMessage = noEvent})))++camera ::+       Camera ->+         [(String, AnimState, AnimState)] ->+           [(ILKey, Message)] -> ILKey -> Object+camera cam _ _ iD+  = (arr+       (\ oi ->+          let gi = oiGameInput oi in+            let clippedcam = oiCollision oi in+              let grounded = oiOnLand oi in+                let msgs = oiMessage oi in+                  (gi, (clippedcam, gi, grounded, msgs, oi)))+       >>>+       (first ptrPos >>>+          arr+            (\ (pPos, (clippedcam, gi, grounded, msgs, oi)) ->+               (gi, (clippedcam, gi, grounded, msgs, oi, pPos))))+         >>>+         (first (movementKS 400) >>>+            arr+              (\ (forwardVel, (clippedcam, gi, grounded, msgs, oi, pPos)) ->+                 (gi, (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos))))+           >>>+           (first (strafeKS 400) >>>+              arr+                (\ (strafeVel,+                    (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos))+                   ->+                   (gi,+                    (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos,+                     strafeVel))))+             >>>+             (first lbp >>>+                arr+                  (\ (trigger,+                      (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, strafeVel))+                     ->+                     (gi,+                      (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, strafeVel,+                       trigger))))+               >>>+               (first rbp >>>+                  arr+                    (\ (rtrigger,+                        (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, strafeVel,+                         trigger))+                       ->+                       (gi,+                        (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, rtrigger,+                         strafeVel, trigger))))+                 >>>+                 (first getDt >>>+                    arr+                      (\ (dt,+                          (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, rtrigger,+                           strafeVel, trigger))+                         ->+                         ((clippedcam, pPos),+                          (clippedcam, dt, forwardVel, gi, grounded, msgs, oi, rtrigger,+                           strafeVel, trigger))))+                   >>>+                   (first+                      (arr (\ (clippedcam, pPos) -> (pPos, clippedcam)) >>>+                         ((iPre cam) <<< (arr setView)))+                      >>>+                      arr+                        (\ (cam1,+                            (clippedcam, dt, forwardVel, gi, grounded, msgs, oi, rtrigger,+                             strafeVel, trigger))+                           ->+                           ((cam1, dt, forwardVel),+                            (cam1, clippedcam, dt, gi, grounded, msgs, oi, rtrigger, strafeVel,+                             trigger))))+                     >>>+                     (first+                        (arr (\ (cam1, dt, forwardVel) -> (forwardVel * dt, cam1)) >>>+                           moves)+                        >>>+                        arr+                          (\ (cam2,+                              (cam1, clippedcam, dt, gi, grounded, msgs, oi, rtrigger, strafeVel,+                               trigger))+                             ->+                             ((cam2, dt, strafeVel),+                              (cam1, clippedcam, gi, grounded, msgs, oi, rtrigger, trigger))))+                       >>>+                       (first+                          (arr (\ (cam2, dt, strafeVel) -> (strafeVel * dt, cam2)) >>>+                             strafes)+                          >>>+                          arr+                            (\ (cam3,+                                (cam1, clippedcam, gi, grounded, msgs, oi, rtrigger, trigger))+                               ->+                               ((gi, grounded),+                                (cam1, cam3, clippedcam, msgs, oi, rtrigger, trigger))))+                         >>>+                         (first (arr (\ (gi, grounded) -> (grounded, gi)) >>> fallingp) >>>+                            arr+                              (\ (yVel, (cam1, cam3, clippedcam, msgs, oi, rtrigger, trigger)) ->+                                 ((cam3, yVel), (cam1, clippedcam, msgs, oi, rtrigger, trigger))))+                           >>>+                           ((first (arr dropCam) >>>+                               loop+                                 (arr+                                    (\ ((cam4, (cam1, clippedcam, msgs, oi, rtrigger, trigger)),+                                        msgn)+                                       ->+                                       ((msgn, msgs, rtrigger),+                                        (cam1, cam4, clippedcam, msgs, oi, rtrigger, trigger)))+                                    >>>+                                    (first+                                       (arr+                                          (\ (msgn, msgs, rtrigger) ->+                                             case (isEvent rtrigger) of+                                                 True -> ([], msgn)+                                                 False -> ((getMsg0 msgs msgn), msgn))+                                          >>> ((iPre ([], [])) <<< identity))+                                       >>>+                                       arr+                                         (\ ((msgn, msgi),+                                             (cam1, cam4, clippedcam, msgs, oi, rtrigger, trigger))+                                            ->+                                            ((cam1, cam4, clippedcam, msgi, msgs, oi, rtrigger,+                                              trigger),+                                             msgn)))))+                              >>>+                              arr+                                (\ (cam1, cam4, clippedcam, msgi, msgs, oi, rtrigger, trigger) ->+                                   (oi, (cam1, cam4, clippedcam, msgi, msgs, rtrigger, trigger))))+                             >>>+                             ((first (arr (\ oi -> oiHit oi) >>> (iPre (noEvent) <<< identity))+                                 >>>+                                 loop+                                   (arr+                                      (\ ((hitEv,+                                           (cam1, cam4, clippedcam, msgi, msgs, rtrigger, trigger)),+                                          currentHealth)+                                         ->+                                         ((currentHealth, hitEv),+                                          (cam1, cam4, clippedcam, msgi, msgs, rtrigger, trigger)))+                                      >>>+                                      (first+                                         (arr+                                            (\ (currentHealth, hitEv) ->+                                               case (isEvent hitEv) of+                                                   True -> currentHealth -+                                                             (realToFrac+                                                                ((length (fromEvent hitEv)) * 3))+                                                   False -> currentHealth)+                                            >>> ((iPre 100) <<< identity))+                                         >>>+                                         arr+                                           (\ (currentHealth,+                                               (cam1, cam4, clippedcam, msgi, msgs, rtrigger,+                                                trigger))+                                              ->+                                              ((cam1, cam4, clippedcam, currentHealth, msgi, msgs,+                                                rtrigger, trigger),+                                               currentHealth)))))+                                >>>+                                arr+                                  (\ (cam1, cam4, clippedcam, currentHealth, msgi, msgs, rtrigger,+                                      trigger)+                                     ->+                                         (msgs,+                                          (cam1, cam4, clippedcam, currentHealth, msgi, rtrigger,+                                           trigger))))+                               >>>+                               ((first ((iPre noEvent) <<< identity) >>>+                                   loop+                                     (arr+                                        (\ ((msges,+                                             (cam1, cam4, clippedcam, currentHealth, msgi, rtrigger,+                                              trigger)),+                                            kills)+                                           ->+                                           ((kills, msges),+                                            (cam1, cam4, clippedcam, currentHealth, msges, msgi,+                                             rtrigger, trigger)))+                                        >>>+                                        (first+                                           (arr+                                              (\ (kills, msges) ->+                                                 kills + (length (findKills (event2List msges))))+                                              >>> ((iPre 0) <<< identity))+                                           >>>+                                           arr+                                             (\ (kills,+                                                 (cam1, cam4, clippedcam, currentHealth, msges,+                                                  msgi, rtrigger, trigger))+                                                ->+                                                ((cam1, cam4, clippedcam, currentHealth, kills,+                                                  msges, msgi, rtrigger, trigger),+                                                 kills)))))+                                  >>>+                                  arr+                                    (\ (cam1, cam4, clippedcam, currentHealth, kills, msges, msgi,+                                        rtrigger, trigger)+                                       ->+                                       ((msgi, rtrigger),+                                        (cam1, cam4, clippedcam, currentHealth, kills, msges,+                                         trigger))))+                                 >>>+                                 (first+                                    (arr (\ (msgi, rtrigger) -> (rtrigger, msgi)) >>>+                                       ((iPre (noEvent, [])) <<< identity))+                                    >>>+                                    arr+                                      (\ ((rev, msgi2),+                                          (cam1, cam4, clippedcam, currentHealth, kills, msges,+                                           trigger))+                                         ->+                                         (clippedcam,+                                          (cam1, cam4, currentHealth, kills, msges, msgi2, rev,+                                           trigger))))+                                   >>>+                                   (first ((iPre cam) <<< identity) >>>+                                      arr+                                        (\ (ccam,+                                            (cam1, cam4, currentHealth, kills, msges, msgi2, rev,+                                             trigger))+                                           ->+                                           ObjOutput{ooSpawnReq =+                                                       (trigger `tag`+                                                          [(ray (cpos cam1) (viewPos cam1) iD)]),+                                                     ooObsObjState =+                                                       OOSCamera{newCam = cam4, oldCam = cam1,+                                                                 health = currentHealth, ammo = 100,+                                                                 score = kills,+                                                                 cood =+                                                                   case (isEvent rev) of+                                                                       True -> reverse $+                                                                                 map getCoordFromMsg+                                                                                   (msgi2)+                                                                       _ -> []},+                                                     ooKillReq = noEvent,+                                                     ooSendMessage =+                                                       case (event2List msges) of+                                                           [] -> noEvent+                                                           _ -> (Event ()) `tag`+                                                                  (case+                                                                     (findEnemies+                                                                        (event2List msges))+                                                                     of+                                                                       [] -> []+                                                                       _ -> [toTargetPosition iD+                                                                               (cpos ccam)+                                                                               (head+                                                                                  (findEnemies+                                                                                     (event2List+                                                                                        msges)))])})))++event2List :: Event [a] -> [a]+event2List ev+  | isEvent ev = fromEvent ev+  | otherwise = []++getMsg0 ::+        Event [(ILKey, Message)] ->+          [(ILKey, Message)] -> [(ILKey, Message)]+getMsg0 (ev) ls+  = case (isEvent ev) of+        True -> case ((findCoords (fromEvent ev)) ++ ls) of+                    x -> x+        _ -> ls++findKills :: [(ILKey, Message)] -> [ILKey]+findKills ((k, EnemyDown) : kmsgs) = k : (findKills kmsgs)+findKills ((_, _) : kmsgs) = (findKills kmsgs)+findKills [] = []++findEnemies :: [(ILKey, Message)] -> [ILKey]+findEnemies ((k, PlayerLockedOn) : kmsgs) = k : (findEnemies kmsgs)+findEnemies ((_, _) : kmsgs) = (findEnemies kmsgs)+findEnemies [] = []++toTargetPosition ::+                 ILKey -> Vec3 -> ILKey -> (ILKey, (ILKey, Message))+toTargetPosition iD position contact+  = (contact, (iD, TargetPosition position))++findCoords :: [(ILKey, Message)] -> [(ILKey, Message)]+findCoords ((k, Coord x) : kmsgs)+  = (k, Coord x) : (findCoords kmsgs)+findCoords ((_, _) : kmsgs) = findCoords kmsgs+findCoords [] = []++getCoordFromMsg :: (ILKey, Message) -> Vec3+getCoordFromMsg (_, (Coord xyz)) = xyz+getCoordFromMsg _                = (0,0,0)++aicube ::+       (Double, Double, Double) ->+         (Double, Double, Double) ->+           [(Double, Double, Double)] ->+             String -> (AnimState, AnimState) -> ILKey -> Object+aicube (x, y, z) size waypoints modelname (ua, la) iD+  = (((arr (\ oi -> let gi = oiGameInput oi in (gi, oi)) >>>+         first getT)+        >>>+        arr+          (\ (t, oi) ->+             let hitList = oiHit oi in+               let enemySighted = oiVisibleObjs oi in+                   (hitList, (enemySighted, hitList, oi, t))))+       >>>+       (first+          (arr+             (\ hitList ->+                case (isEvent hitList) of+                    True -> getFire (snd (head (fromEvent hitList)))+                    _ -> Nothing)+             >>> (iPre Nothing <<< identity))+          >>>+          arr+            (\ (hitSource, (enemySighted, hitList, oi, t)) ->+               (hitSource, (enemySighted, hitList, hitSource, oi, t))))+         >>>+         ((first (arr (\ hitSource -> (hitSource /= Nothing)) >>> edge) >>>+             loop+               (arr+                  (\ ((hitev1, (enemySighted, hitList, hitSource, oi, t)),+                      currentHealth)+                     ->+                     ((currentHealth, hitList),+                      (enemySighted, hitSource, hitev1, oi, t)))+                  >>>+                  (first+                     (arr+                        (\ (currentHealth, hitList) ->+                           case (isEvent hitList) of+                               True -> currentHealth - (3)+                               False -> currentHealth)+                        >>> ((iPre 100) <<< identity))+                     >>>+                     arr+                       (\ (currentHealth, (enemySighted, hitSource, hitev1, oi, t)) ->+                          ((currentHealth, enemySighted, hitSource, hitev1, oi, t),+                           currentHealth)))))+            >>>+            arr+              (\ (currentHealth, enemySighted, hitSource, hitev1, oi, t) ->+                 (currentHealth,+                  (currentHealth, enemySighted, hitSource, hitev1, oi, t))))+           >>>+           ((first (arr (\ currentHealth -> (currentHealth <= 0)) >>> edge)+               >>>+               loop+                 (arr+                    (\ ((hitev,+                         (currentHealth, enemySighted, hitSource, hitev1, oi, t)),+                        isDead)+                       ->+                       ((hitev, isDead),+                        (currentHealth, enemySighted, hitSource, hitev, hitev1, oi, t)))+                    >>>+                    (first+                       (arr+                          (\ (hitev, isDead) ->+                             case (isEvent hitev) of+                                 True -> True+                                 _ -> isDead)+                          >>> ((iPre False) <<< identity))+                       >>>+                       arr+                         (\ (isDead,+                             (currentHealth, enemySighted, hitSource, hitev, hitev1, oi, t))+                            ->+                            ((currentHealth, enemySighted, hitSource, hitev, hitev1, isDead,+                              oi, t),+                             isDead)))))+              >>>+              arr+                (\ (currentHealth, enemySighted, hitSource, hitev, hitev1, isDead,+                    oi, t)+                   ->+                   ((enemySighted, isDead),+                    (currentHealth, enemySighted, hitSource, hitev, hitev1, isDead, oi,+                     t))))+             >>>+             (((first+                  (arr+                     (\ (enemySighted, isDead) ->+                        (isEvent enemySighted) && (isDead == False))+                     >>> ((iPre noEvent) <<< edge))+                  >>>+                  loop+                    (arr+                       (\ ((enemyS,+                            (currentHealth, enemySighted, hitSource, hitev, hitev1, isDead, oi,+                             t)),+                           enemy)+                          ->+                          ((enemy, enemySighted),+                           (currentHealth, enemyS, enemySighted, hitSource, hitev, hitev1,+                            isDead, oi, t)))+                       >>>+                       (first+                          (arr+                             (\ (enemy, enemySighted) ->+                                case (isEvent enemySighted) of+                                    True -> enemySighted+                                    False -> enemy)+                             >>> ((iPre noEvent) <<< identity))+                          >>>+                          arr+                            (\ (enemy,+                                (currentHealth, enemyS, enemySighted, hitSource, hitev, hitev1,+                                 isDead, oi, t))+                               ->+                               ((currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                                 hitev1, isDead, oi, t),+                                enemy)))))+                 >>>+                 loop+                   (arr+                      (\ ((currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                           hitev1, isDead, oi, t),+                          targ)+                         ->+                         ((enemySighted, targ),+                          (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                           hitev1, isDead, oi, t)))+                      >>>+                      (first+                         (arr+                            (\ (enemySighted, targ) ->+                               case (isEvent enemySighted) of+                                   True -> (cpos (oldCam (snd (head (fromEvent enemySighted)))))+                                   False -> targ)+                            >>> ((iPre (0, 0, 0)) <<< identity))+                         >>>+                         arr+                           (\ (targ,+                               (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                                hitev1, isDead, oi, t))+                              ->+                              ((currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                                hitev1, isDead, oi, t, targ),+                               targ)))))+                >>>+                arr+                  (\ (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                      hitev1, isDead, oi, t, targ)+                     ->+                     (oi,+                      (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                       hitev1, isDead, oi, t, targ))))+               >>>+               (first+                  (arr (\ oi -> oiMessage oi) >>> ((iPre noEvent) <<< identity))+                  >>>+                  arr+                    (\ (msgs,+                        (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                         hitev1, isDead, oi, t, targ))+                       ->+                       ((isDead, msgs),+                        (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                         hitev1, isDead, msgs, oi, t, targ))))+                 >>>+                 (first+                    (arr+                       (\ (isDead, msgs) ->+                          case (isEvent msgs) && (isDead == False) of+                              True -> case (getTargetPosition (fromEvent msgs)) of+                                          Just _ -> True+                                          _ -> False+                              _ -> False)+                       >>> edge)+                    >>>+                    arr+                      (\ (msgReceived,+                          (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                           hitev1, isDead, msgs, oi, t, targ))+                         ->+                         ((isDead, msgs),+                          (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                           hitev1, isDead, msgReceived, oi, t, targ))))+                   >>>+                   (first+                      (arr+                         (\ (isDead, msgs) ->+                            case (isEvent msgs) && (isDead == False) of+                                True -> case (getTargetPosition2 (fromEvent msgs)) of+                                            Just _ -> True+                                            _ -> False+                                _ -> False)+                         >>> edge)+                      >>>+                      arr+                        (\ (respond2Attack,+                            (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,+                             hitev1, isDead, msgReceived, oi, t, targ))+                           ->+                           ((enemySighted, msgReceived),+                            (currentHealth, enemy, enemyS, hitSource, hitev, hitev1, isDead,+                             oi, respond2Attack, t, targ))))+                     >>>+                     (first+                        (arr+                           (\ (enemySighted, msgReceived) ->+                              (isNoEvent enemySighted) && (isNoEvent msgReceived))+                           >>> ((iPre noEvent) <<< edge))+                        >>>+                        arr+                          (\ (targetLost1,+                              (currentHealth, enemy, enemyS, hitSource, hitev, hitev1, isDead,+                               oi, respond2Attack, t, targ))+                             ->+                             ((enemyS, targetLost1),+                              (currentHealth, enemy, enemyS, hitSource, hitev, hitev1, isDead,+                               oi, respond2Attack, t, targ, targetLost1))))+                       >>>+                       (first+                          (arr+                             (\ (enemyS, targetLost1) ->+                                ((),+                                 (enemyS `tag` (constant noEvent)) `lMerge`+                                   (targetLost1 `tag` (repeatedly (0.5) (Event ())))))+                             >>> rSwitch (constant noEvent))+                          >>>+                          loop+                            (arr+                               (\ ((_,+                                    (currentHealth, enemy, enemyS, hitSource, hitev, hitev1, isDead,+                                     oi, respond2Attack, t, targ, targetLost1)),+                                   ~(angle, lEndEv, oldPos, uEndEv))+                                  ->+                                  ((angle, enemyS, hitev, lEndEv, oi, oldPos, respond2Attack,+                                    uEndEv),+                                   (currentHealth, enemy, hitSource, hitev, hitev1, isDead, t, targ,+                                    targetLost1)))+                               >>>+                               (first+                                  (arr+                                     (\ (angle, enemyS, hitev, lEndEv, oi, oldPos, respond2Attack,+                                         uEndEv)+                                        ->+                                        ((oi, uEndEv, lEndEv),+                                         (enemyS `tag` (turnToFaceTarget (oldPos, angle))) `lMerge`+                                           respond2Attack+                                           `tag` (turnToFaceTarget (oldPos, angle))+                                           `lMerge` hitev+                                           `tag` playDead oldPos angle))+                                     >>> drSwitch (followWayPoints (x, y, z) waypoints))+                                  >>>+                                  arr+                                    (\ ((newPos, oldPos, angle, ptch, attack,+                                         (upperIdx, lowerIdx)),+                                        (currentHealth, enemy, hitSource, hitev, hitev1, isDead, t,+                                         targ, targetLost1))+                                       ->+                                       ((t, upperIdx),+                                        (angle, attack, currentHealth, enemy, hitSource, hitev,+                                         hitev1, isDead, lowerIdx, newPos, oldPos, ptch, t, targ,+                                         targetLost1))))+                                 >>>+                                 (first (updateAnimSF ua) >>>+                                    arr+                                      (\ ((uEndEv, upperstate),+                                          (angle, attack, currentHealth, enemy, hitSource, hitev,+                                           hitev1, isDead, lowerIdx, newPos, oldPos, ptch, t, targ,+                                           targetLost1))+                                         ->+                                         ((lowerIdx, t),+                                          (angle, attack, currentHealth, enemy, hitSource, hitev,+                                           hitev1, isDead, newPos, oldPos, ptch, targ, targetLost1,+                                           uEndEv, upperstate))))+                                   >>>+                                   (first+                                      (arr (\ (lowerIdx, t) -> (t, lowerIdx)) >>> updateAnimSF la)+                                      >>>+                                      arr+                                        (\ ((lEndEv, lowerstate),+                                            (angle, attack, currentHealth, enemy, hitSource, hitev,+                                             hitev1, isDead, newPos, oldPos, ptch, targ,+                                             targetLost1, uEndEv, upperstate))+                                           ->+                                           ((angle, attack, currentHealth, enemy, hitSource, hitev,+                                             hitev1, isDead, lowerstate, newPos, oldPos, ptch,+                                             targ, targetLost1, upperstate),+                                            (angle, lEndEv, oldPos, uEndEv))))))+                         >>>+                         arr+                           (\ (angle, attack, currentHealth, enemy, hitSource, hitev, hitev1,+                               isDead, lowerstate, newPos, oldPos, ptch, targ, targetLost1,+                               upperstate)+                              ->+                              let f = 1 in+                                ObjOutput{ooObsObjState =+                                            OOSAICube{oosNewCubePos = newPos,+                                                      oosOldCubePos = oldPos, oosCubeSize = size,+                                                      oosCubeAngle = angle, oosCubePitch = ptch,+                                                      upperAnim = upperstate,+                                                      lowerAnim = lowerstate,+                                                      health = currentHealth, target = targ,+                                                      fade = f, modelName = modelname},+                                          ooKillReq = noEvent,+                                          ooSpawnReq =+                                            attack `tag`+                                              [projectile (getMuzzlePoint (oldPos, targ)) iD],+                                          ooSendMessage =+                                            hitev `tag`+                                              (case isDead of+                                                   False -> [(fromJust hitSource, (iD, EnemyDown))]+                                                   _ -> [])+                                              `lMerge` targetLost1+                                              `tag`+                                              [(fst (head (fromEvent enemy)), (iD, PlayerLockedOn))]+                                              `lMerge` hitev1+                                              `tag` [(fromJust hitSource, (iD, PlayerLockedOn2))]}))++getFire :: ObsObjState -> Maybe ILKey+getFire obj+  | isRay obj = Just (firedFrom obj)+  | otherwise = Nothing++getTargetPosition :: [(ILKey, Message)] -> Maybe Vec3+getTargetPosition ((_, TargetPosition pos) : _) = Just pos+getTargetPosition (_ : rest) = getTargetPosition rest+getTargetPosition [] = Nothing++getTargetPosition2 :: [(ILKey, Message)] -> Maybe Vec3+getTargetPosition2 ((_, TargetPosition2 pos) : _) = Just pos+getTargetPosition2 (_ : rest) = getTargetPosition2 rest+getTargetPosition2 [] = Nothing++getMuzzlePoint :: (Vec3, Vec3) -> (Vec3, Vec3)+getMuzzlePoint ((x, y, z), (ox, oy, oz))+  = let (x3, _, z3)+          = normalise $ (vectorSub (ox, oy + 45, oz) (x, y, z))+        (x7, _, z7) = normalise $ (vectorSub (ox, 0, oz) (x, 0, z))+        (x4, _, z4) = normalise $ crossProd (x3, 0, z3) (0, 1, 0)+        (x5, y5, z5)+          = (x + (x7 * (- 18.55)) + (x4 * (9.6)), y + 4,+             z + (z7 * (- 18.55)) + (z4 * (9.6)))+        (x12, y12, z12)+          = normalise $ (vectorSub (ox, oy - 5, oz) (x, y, z))+        (x6, y6, z6)+          = vectorAdd (x5, y5, z5) (x12 * 42, y12 * 42, z12 * 42)+        (x9, y9, z9) = normalise $ (vectorSub (x6, y6, z6) (x5, y5, z5))+        (x10, y10, z10) = normalise $ crossProd (x9, y9, z9) (0, 1, 0)+        (x13, y13, z13)+          = normalise $ crossProd (x9, y9, z9) (x10, y10, z10)+        muzzlePoint+          = vectorAdd (x6, y6, z6)+              (x13 * (- 9.5), y13 * (- 9.5), z13 * (- 9.5))+        muzzleEnd+          = vectorAdd (x5, y5, z5)+              (x13 * (- 9.5), y13 * (- 9.5), z13 * (- 9.5))+        fireVec = normalise $ (vectorSub muzzlePoint muzzleEnd)+      in (muzzlePoint, fireVec)++falling :: SF (Bool, GameInput, Double) Double+falling+  = (loop+       (arr+          (\ ((lnd, _, dt), pos) ->+             case lnd of+                 True -> (- 0.5)+                 False -> (pos - (6 * 200 * dt)))+          >>> (((iPre 0) <<< identity) >>> arr (\ pos -> (pos, pos)))))++turnToFaceTarget ::+                 (Vec3, Double) ->+                   SF (ObjInput, Event (), Event ())+                     (Vec3, Vec3, Double, Double, Event (), (Int, Int))+turnToFaceTarget (currentPos, initialAngle)+  = (arr+       (\ (oi, ev1, ev2) ->+          let gi = oiGameInput oi in+            let clippedPos = oiCollisionPos oi in+              let grounded = oiOnLand oi in+                (gi, (clippedPos, ev1, ev2, gi, grounded, oi)))+       >>>+       ((first getDt >>>+           loop+             (arr+                (\ ((dt, (clippedPos, ev1, ev2, gi, grounded, oi)), count) ->+                   (count, (clippedPos, dt, ev1, ev2, gi, grounded, oi)))+                >>>+                (first (arr (\ count -> count + 1) >>> ((iPre 0) <<< identity)) >>>+                   arr+                     (\ (count, (clippedPos, dt, ev1, ev2, gi, grounded, oi)) ->+                        ((clippedPos, count, dt, ev1, ev2, gi, grounded, oi), count)))))+          >>>+          arr+            (\ (clippedPos, count, dt, ev1, ev2, gi, grounded, oi) ->+               (clippedPos, (count, dt, ev1, ev2, gi, grounded, oi))))+         >>>+         (first ((iPre currentPos) <<< identity) >>>+            arr+              (\ ((ox1, oy1, oz1), (count, dt, ev1, ev2, gi, grounded, oi)) ->+                 ((count, ox1, oy1, oz1), (dt, ev1, ev2, gi, grounded, oi))))+           >>>+           (first+              (arr+                 (\ (count, ox1, oy1, oz1) ->+                    case (count > (3 :: Int) && (ox1, oy1, oz1) /= currentPos) of+                        True -> (ox1, oy1, oz1)+                        _ -> currentPos)+                 >>> identity)+              >>>+              arr+                (\ ((ox, oy, oz), (dt, ev1, ev2, gi, grounded, oi)) ->+                   ((dt, gi, grounded), (ev1, ev2, oi, ox, oy, oz))))+             >>>+             ((((((first+                     (arr (\ (dt, gi, grounded) -> (grounded, gi, dt)) >>>+                        ((iPre 0) <<< falling))+                     >>>+                     arr+                       (\ (yVel, (ev1, ev2, oi, ox, oy, oz)) ->+                          let enemySighted = oiVisibleObjs oi in+                            (enemySighted, ev1, ev2, ox, oy, oz, yVel)))+                    >>>+                    loop+                      (arr+                         (\ ((enemySighted, ev1, ev2, ox, oy, oz, yVel), targetAnglei) ->+                            ((enemySighted, ox, oy, oz, targetAnglei),+                             (enemySighted, ev1, ev2, ox, oy, oz, yVel)))+                         >>>+                         (first+                            (arr+                               (\ (enemySighted, ox, oy, oz, targetAnglei) ->+                                  case (isEvent enemySighted) of+                                      True -> getAngle+                                                ((ox, oy, oz),+                                                 (cpos+                                                    (oldCam (snd (head (fromEvent enemySighted))))))+                                      _ -> targetAnglei)+                               >>> ((iPre initialAngle) <<< identity))+                            >>>+                            arr+                              (\ (targetAnglei, (enemySighted, ev1, ev2, ox, oy, oz, yVel)) ->+                                 ((enemySighted, ev1, ev2, ox, oy, oz, targetAnglei, yVel),+                                  targetAnglei)))))+                   >>>+                   loop+                     (arr+                        (\ ((enemySighted, ev1, ev2, ox, oy, oz, targetAnglei, yVel),+                            angle)+                           ->+                           let targetAngle+                                 = case+                                     (abs (angle - targetAnglei) <+                                        abs (angle - (targetAnglei + 360)))+                                     of+                                       True -> targetAnglei+                                       False -> targetAnglei + 360+                             in+                             let angularV+                                   = case (True) of+                                         True -> case (abs (angle - targetAngle) > 2) of+                                                     True -> case (angle < targetAngle) of+                                                                 True -> 270+                                                                 _ -> - 270+                                                     False -> (targetAngle - angle)+                                         False -> 0+                               in+                               (angularV,+                                (enemySighted, ev1, ev2, ox, oy, oz, targetAngle, yVel)))+                        >>>+                        (first ((initialAngle +) ^<< integral) >>>+                           arr+                             (\ (angle, (enemySighted, ev1, ev2, ox, oy, oz, targetAngle, yVel))+                                ->+                                let legState+                                      = case (abs (angle - targetAngle) < 2) of+                                            True -> idleLegs+                                            _ -> turn+                                  in+                                  ((ev2, legState),+                                   (angle, enemySighted, ev1, legState, ox, oy, oz, targetAngle,+                                    yVel))))+                          >>>+                          (first+                             (arr+                                (\ (ev2, legState) -> ((legState == idleLegs) && (isEvent ev2)))+                                >>> edge)+                             >>>+                             arr+                               (\ (switch2idle,+                                   (angle, enemySighted, ev1, legState, ox, oy, oz, targetAngle,+                                    yVel))+                                  ->+                                  (legState,+                                   (angle, enemySighted, ev1, ox, oy, oz, switch2idle, targetAngle,+                                    yVel))))+                            >>>+                            (first (arr (\ legState -> (legState == turn)) >>> edge) >>>+                               arr+                                 (\ (turning,+                                     (angle, enemySighted, ev1, ox, oy, oz, switch2idle,+                                      targetAngle, yVel))+                                    ->+                                    ((switch2idle, turning),+                                     (angle, enemySighted, ev1, ox, oy, oz, targetAngle, yVel))))+                              >>>+                              (first+                                 (arr+                                    (\ (switch2idle, turning) ->+                                       ((),+                                        turning `tag` (constant turn) `lMerge` switch2idle `tag`+                                          (constant idleLegs)))+                                    >>> drSwitch (constant stand))+                                 >>>+                                 arr+                                   (\ (legsAnim,+                                       (angle, enemySighted, ev1, ox, oy, oz, targetAngle, yVel))+                                      ->+                                      ((angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,+                                        yVel),+                                       angle)))))+                  >>>+                  loop+                    (arr+                       (\ ((angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,+                            yVel),+                           targetPitch)+                          ->+                          ((enemySighted, ox, oy, oz, targetPitch),+                           (angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,+                            yVel)))+                       >>>+                       (first+                          (arr+                             (\ (enemySighted, ox, oy, oz, targetPitch) ->+                                case (isEvent enemySighted) of+                                    True -> getVertAngle+                                              ((ox, oy, oz),+                                               vectorAdd+                                                 (cpos+                                                    (oldCam (snd (head (fromEvent enemySighted)))))+                                                 (0, - 5, 0))+                                    _ -> targetPitch)+                             >>> ((iPre 0) <<< identity))+                          >>>+                          arr+                            (\ (targetPitch,+                                (angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,+                                 yVel))+                               ->+                               ((angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,+                                 targetPitch, yVel),+                                targetPitch)))))+                 >>>+                 loop+                   (arr+                      (\ ((angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,+                           targetPitch, yVel),+                          ptch)+                         ->+                         let angularVP+                               = case (abs (ptch - targetPitch) > 2) of+                                     True -> case (targetPitch < ptch) of+                                                 True -> - 90+                                                 _ -> 90+                                     False -> (targetPitch - ptch)+                           in+                           (angularVP,+                            (angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,+                             targetPitch, yVel)))+                      >>>+                      (first ((0 +) ^<< integral) >>>+                         arr+                           (\ (ptch,+                               (angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,+                                targetPitch, yVel))+                              ->+                              ((angle, enemySighted, ev1, legsAnim, ox, oy, oz, ptch,+                                targetAngle, targetPitch, yVel),+                               ptch)))))+                >>>+                arr+                  (\ (angle, enemySighted, ev1, legsAnim, ox, oy, oz, ptch,+                      targetAngle, targetPitch, yVel)+                     ->+                     (ev1,+                      (angle, enemySighted, legsAnim, ox, oy, oz, ptch, targetAngle,+                       targetPitch, yVel))))+               >>>+               (first (arr (\ ev1 -> (isEvent ev1)) >>> ((iPre noEvent) <<< edge))+                  >>>+                  arr+                    (\ (attack,+                        (angle, enemySighted, legsAnim, ox, oy, oz, ptch, targetAngle,+                         targetPitch, yVel))+                       ->+                       ((angle, enemySighted, ptch, targetAngle, targetPitch),+                        (angle, attack, legsAnim, ox, oy, oz, ptch, yVel))))+                 >>>+                 (first+                    (arr+                       (\ (angle, enemySighted, ptch, targetAngle, targetPitch) ->+                          case+                            ((abs (ptch - targetPitch) < 6) && (abs (angle - targetAngle) < 6)+                               && isEvent enemySighted)+                            of+                              True -> attack1+                              False -> stand)+                       >>> ((iPre stand) <<< identity))+                    >>>+                    arr+                      (\ (torsoAnim, (angle, attack, legsAnim, ox, oy, oz, ptch, yVel))+                         ->+                         ((ox, oy + yVel, oz), (ox, oy, oz), angle, ptch, attack,+                          (torsoAnim, legsAnim)))))++followWayPoints ::+                Vec3 ->+                  [Vec3] ->+                    SF (ObjInput, Event (), Event ())+                      (Vec3, Vec3, Double, Double, Event (), (Int, Int))+followWayPoints (x, y, z) waypoints+  = (arr+       (\ (oi, ev1, ev2) ->+          let gi = oiGameInput oi in+            let clippedPos = oiCollisionPos oi in+              let grounded = oiOnLand oi in+                (clippedPos, (ev1, ev2, gi, grounded, oi)))+       >>>+       (first ((iPre (x, y, z)) <<< identity) >>>+          arr+            (\ ((ox, oy, oz), (ev1, ev2, gi, grounded, oi)) ->+               (gi, (ev1, ev2, gi, grounded, oi, ox, oy, oz))))+         >>>+         (first getT >>>+            arr+              (\ (_, (ev1, ev2, gi, grounded, oi, ox, oy, oz)) ->+                 (gi, (ev1, ev2, gi, grounded, oi, ox, oy, oz))))+           >>>+           (first getDt >>>+              arr+                (\ (dt, (ev1, ev2, gi, grounded, oi, ox, oy, oz)) ->+                   ((dt, gi, grounded), (dt, ev1, ev2, oi, ox, oy, oz))))+             >>>+             (first+                (arr (\ (dt, gi, grounded) -> (grounded, gi, dt)) >>>+                   ((iPre 0) <<< falling))+                >>>+                loop+                  (arr+                     (\ ((yVel, (dt, ev1, ev2, oi, ox, oy, oz)), wpl) ->+                        (wpl, (dt, ev1, ev2, oi, ox, oy, oz, yVel)))+                     >>>+                     (first ((iPre (cycle waypoints)) <<< identity) >>>+                        arr+                          (\ (wps, (dt, ev1, ev2, oi, ox, oy, oz, yVel)) ->+                             let [wp1, wp2] = take 2 wps in+                               let (pastWp, (dx, _, dz)) = stepdist wp1 wp2 (ox, oy, oz) 100 dt+                                 in+                                 (pastWp,+                                  (dx, dz, ev1, ev2, oi, ox, oy, oz, pastWp, wp2, wps, yVel))))+                       >>>+                       (first edge >>>+                          arr+                            (\ (pastEv,+                                (dx, dz, ev1, ev2, oi, ox, oy, oz, pastWp, wp2, wps, yVel))+                               ->+                               let angle = getAngle ((ox, oy, oz), (ox + dx, oy + yVel, oz + dz))+                                 in+                                 let newPos = (ox + dx, oy + yVel, oz + dz) in+                                   ((angle, ev1, ev2, newPos, oi, pastEv, wp2),+                                    (angle, newPos, ox, oy, oz, pastWp, wps))))+                         >>>+                         (first+                            (arr+                               (\ (angle, ev1, ev2, newPos, oi, pastEv, wp2) ->+                                  ((oi, ev1, ev2),+                                   pastEv `tag` (turnToNextWp angle (getAngle (newPos, wp2)))))+                               >>>+                               rSwitch+                                 (constant (True, False, (getAngle ((x, y, z), head waypoints)))))+                            >>>+                            arr+                              (\ ((notturning, largeEnough, turnAngle),+                                  (angle, newPos, ox, oy, oz, pastWp, wps))+                                 ->+                                 let wpl+                                       = case (pastWp) of+                                             True -> case (not largeEnough) of+                                                         True -> (tail wps)+                                                         _ -> case notturning of+                                                                  True -> (tail wps)+                                                                  _ -> wps+                                             _ -> wps+                                   in+                                   ((angle, largeEnough, newPos, notturning, ox, oy, oz, turnAngle),+                                    wpl)))))+               >>>+               arr+                 (\ (angle, largeEnough, newPos, notturning, ox, oy, oz, turnAngle)+                    ->+                    let holdAngle+                          = case (not largeEnough) of+                                True -> angle+                                _ -> case notturning of+                                         False -> turnAngle+                                         _ -> angle+                      in+                      let legAnim+                            = case (not largeEnough) of+                                  True -> walk+                                  _ -> case (notturning) of+                                           True -> walk+                                           _ -> turn+                        in+                        (newPos, (ox, oy, oz), holdAngle, 0, noEvent, (stand, legAnim))))++turnToNextWp ::+             Double ->+               Double -> SF (ObjInput, Event (), Event ()) (Bool, Bool, Double)+turnToNextWp currentangle nextAngle+  = (((arr+         (\ (_, _, lev) ->+            let targetAngle+                  = case+                      (abs (currentangle - nextAngle) <+                         abs (currentangle - (nextAngle + 360)))+                      of+                        True -> nextAngle+                        False -> nextAngle + 360+              in (lev, targetAngle))+         >>>+         loop+           (arr+              (\ ((lev, targetAngle), angle) ->+                 let angularV+                       = case (abs (angle - targetAngle) > 3) of+                             True -> case (angle < targetAngle) of+                                         True -> 360+                                         _ -> - 360+                             False -> (targetAngle - angle)+                   in (angularV, (lev, targetAngle)))+              >>>+              (first ((currentangle +) ^<< integral) >>>+                 arr+                   (\ (angle, (lev, targetAngle)) ->+                      ((angle, lev, targetAngle), angle)))))+        >>>+        arr+          (\ (angle, lev, targetAngle) ->+             let legState+                   = case (abs (angle - targetAngle) < 3) of+                         True -> idleLegs+                         _ -> turn+               in ((legState, lev), (angle, targetAngle))))+       >>>+       (first+          (arr (\ (legState, lev) -> (legState == idleLegs && isEvent lev))+             >>> ((iPre noEvent) <<< edge))+          >>>+          first+            (arr (\ switch2idle -> ((), switch2idle `tag` (constant True))) >>>+               rSwitch (constant False)))+         >>>+         arr+           (\ (ret, (angle, targetAngle)) ->+              (ret, (abs (currentangle - targetAngle) > 30), angle)))++stepdist ::+         Vec3 -> Vec3 -> Vec3 -> Double -> Double -> (Bool, Vec3)+stepdist (wx1, _, wz1) (_, _, _) (x, _, z) vel dt+  = let (dx, _, dz) = normalise $ vectorSub (wx1, 0, wz1) (x, 0, z)+        distance = sqrt (((x - wx1) * (x - wx1)) + ((z - wz1) * (z - wz1)))+        remvel = distance * (distance / (vel * dt))+      in+      case (distance > (vel * dt)) of+          True -> (False, (dx * vel * dt, 0, dz * vel * dt))+          False -> (True, (dx * remvel, 0, dz * remvel))++playDead ::+         Vec3 ->+           Double ->+             SF (ObjInput, Event (), Event ())+               (Vec3, Vec3, Double, Double, Event (), (Int, Int))+playDead start angle+  = (arr (\ (_, ev1, _) -> ev1) >>>+       (notYet >>> arr (\ ev -> ((), ev `tag` (constant dead1)))) >>>+         (drSwitch (constant death1) >>>+            arr+              (\ death -> (start, start, angle, 0, noEvent, (death, death)))))++getAngle :: (Vec3, Vec3) -> Double+getAngle ((x, _, z), (vx, _, vz))+  = let angle+          = acos $+              dotProd (normalise $ vectorSub (vx, 0, vz) (x, 0, z)) (1, 0, 0)+      in+      case (vz > z) of+          False -> (angle * 180 / pi)+          True -> (360 - (angle * 180 / pi))++getVertAngle :: (Vec3, Vec3) -> Double+getVertAngle ((x, y, z), (vx, vy, vz))+  = let angle1+          = acos $+              dotProd (normalise $ vectorSub (vx, vy, vz) (x, y, z)) (0, 1, 0)+      in ((angle1 * 180 / pi) - 90)++updateAnimSF :: AnimState -> SF (Double, Int) (Event (), AnimState)+updateAnimSF iAnim+  = (loop+       (arr+          (\ ((tme, animIndex), anim2) ->+             ((anim2, animIndex, tme), animIndex))+          >>>+          (first+             (arr (\ (anim2, animIndex, tme) -> (animIndex, tme, anim2)) >>>+                ((iPre (False, iAnim)) <<< arr updateAnim))+             >>>+             arr+               (\ ((hasLooped, anim2), animIndex) ->+                  ((anim2, animIndex, hasLooped), anim2))))+       >>>+       arr+         (\ (anim2, animIndex, hasLooped) ->+            (case hasLooped of+                 True -> case (animIndex == dead1) of+                             True -> (noEvent, anim2)+                             False -> (Event (), anim2)+                 False -> (noEvent, anim2))))++moves :: SF (Double, Camera) Camera+moves+  = (arr+       (\ (speed, cam) ->+          let (x, y, z) = (cpos cam)+              (vpx, vpy, vpz) = (viewPos cam)+              strafevec+                = normalise+                    (crossProd (vectorSub (viewPos cam) (cpos cam)) (upVec cam))+              (vx, _, vz) = normalise (crossProd (upVec cam) strafevec)+              newx = (vx * speed)+              newz = (vz * speed)+              newvx = (vx * speed)+              newvz = (vz * speed)+            in+            Camera{cpos = (x + newx, y, z + newz),+                   viewPos = (vpx + newvx, vpy, vpz + newvz), upVec = (upVec cam)}))++strafes :: SF (Double, Camera) Camera+strafes+  = (arr+       (\ (speed, cam) ->+          let (sx, _, sz)+                = normalise+                    (crossProd (vectorSub (viewPos cam) (cpos cam)) (upVec cam))+              (x, y, z) = (cpos cam)+              (vx, vy, vz) = (viewPos cam)+              newx = (sx * speed)+              newz = (sz * speed)+              newvx = (sx * speed)+              newvz = (sz * speed)+            in+            Camera{cpos = (x + newx, y, z + newz),+                   viewPos = (vx + newvx, vy, vz + newvz), upVec = (upVec cam)}))++movementKS :: Double -> SF GameInput Double+movementKS speed+  = (keyStat >>>+       loop+         (arr (\ (key, v) -> nextSpeed key v) >>>+            (((iPre 0) <<< identity) >>> arr (\ v -> (v, v)))))+  where nextSpeed key v+          | key == Event ('w', True) = speed+          | key == Event ('s', True) = - speed+          | (key == Event ('w', False) || key == Event ('s', False)) = 0+          | otherwise = v++strafeKS :: Double -> SF GameInput Double+strafeKS speed+  = (keyStat >>>+       loop+         (arr (\ (key, v) -> nextSpeed key v) >>>+            (((iPre 0) <<< identity) >>> arr (\ v -> (v, v)))))+  where nextSpeed key v+          | key == Event ('d', True) = speed+          | key == Event ('a', True) = - speed+          | (key == Event ('d', False) || key == Event ('a', False)) = 0+          | otherwise = v++fallingp :: SF (Bool, GameInput) Double+fallingp+  = (arr (\ (lnd, gi) -> (gi, lnd)) >>>+       (first keyStat >>> arr (\ (key, lnd) -> (key, (key, lnd)))) >>>+         (first (arr (\ key -> key == Event ('e', True)) >>> arr jump2Vel)+            >>> arr (\ (_, (key, lnd)) -> ((key, lnd), (key, lnd))))+           >>>+           (first+              (arr (\ (key, lnd) -> key == Event ('e', True) && (lnd == True))+                 >>> arr bool2Ev)+              >>> arr (\ (jumping, (key, lnd)) -> (lnd, (jumping, key, lnd))))+             >>>+             ((first (arr (\ lnd -> (lnd == True)) >>> edge) >>>+                 loop+                   (arr+                      (\ ((landed, (jumping, key, lnd)), middleOfJump) ->+                         ((key, lnd, middleOfJump), (jumping, lnd, landed)))+                      >>>+                      (first+                         (arr+                            (\ (key, lnd, middleOfJump) ->+                               case+                                 (middleOfJump == False && key == Event ('e', True) && lnd == True)+                                 of+                                   True -> True+                                   False -> case (lnd == True) of+                                                True -> False+                                                False -> middleOfJump)+                            >>> (iPre False <<< identity))+                         >>>+                         arr+                           (\ (middleOfJump, (jumping, lnd, landed)) ->+                              ((jumping, lnd, landed, middleOfJump), middleOfJump)))))+                >>>+                arr+                  (\ (jumping, lnd, landed, middleOfJump) ->+                     ((lnd, middleOfJump), (jumping, landed))))+               >>>+               (first+                  (arr+                     (\ (lnd, middleOfJump) ->+                        (lnd == False && middleOfJump == False))+                     >>> edge)+                  >>>+                  arr+                    (\ (notlanded, (jumping, landed)) ->+                       ((),+                        (jumping `tag` falling' (- 200 :: Double) (40 :: Double)) `lMerge`+                          (landed `tag` constant (- 5.0e-2))+                          `lMerge`+                          (notlanded `tag` falling' (- 200 :: Double) (0 :: Double)))))+                 >>> drSwitch (falling' (- 200 :: Double) (0 :: Double)))++falling' :: Double -> Double -> SF () Double+falling' grav int+  = (arr (\ () -> grav) >>> (integral >>> arr (\ vel -> (vel + int))) >>> integral)++bool2Ev :: Bool -> Event ()+bool2Ev b+  | b = Event ()+  | otherwise = noEvent++jump2Vel :: Bool -> Double+jump2Vel b+  | b == True = 40+  | otherwise = 0
+ src/Parser.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE BangPatterns #-}++{- $Id: Parser.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                                I N V A D E R S                                                  *+*                                                                                                                         *+*          Module:          Parser                                                      *+*          Purpose:         Parsing (mainly lexical analysis) of window event     *+*                       stream.                                                    *+*          Author:              Henrik Nilsson                                  *+*                                                                                                                         *+*                   Copyright (c) Yale University, 2003                                           *+*                                                                                                                         *+******************************************************************************+-}++-- Quick 'n dirty adaptation from old robot simulator. Could probably be+-- done better in the new AFRP framework.+module Parser (+    GameInput,  -- Abstract+    parseWinInput,      -- :: SF WinInput GameInput+    command,            -- :: SF GameInput (Event Command)+    cmdString,  -- :: SF GameInput (Event String)+    ptrPos,             -- :: SF GameInput Position2+    lbp,                -- :: SF GameInput (Event ())+    lbpPos,             -- :: SF GameInput (Event Position2)+    lbDown,             -- :: SF GameInput Bool+    rbp,                -- :: SF GameInput (Event ())+    rbpPos,             -- :: SF GameInput (Event Position2)+    rbDown,             -- :: SF GameInput Bool+    dragStart,  -- :: SF GameInput (Event ())+    dragStop,           -- :: SF GameInput (Event Distance2)+    dragStartPos,       -- :: SF GameInput Position2+    dragVec,            -- :: SF GameInput Distance2+    dragging,            -- :: SF GameInput Bool+    keyStat,+    getT,+    getDt++) where++import Maybe (isJust)+import qualified HGL as HGL (Event(..))+import qualified HGL as HGL (Point(..))+import AFRP+import AFRPUtilities+import AFRPGeometry+-- import AFRPMiscellany (mapFst)++import PhysicalDimensions+import Command++type WinInput = Event HGL.Event+++------------------------------------------------------------------------------+-- Exported entities+------------------------------------------------------------------------------++data GameInput = GameInput {+    giCmdStr :: !String,+    giCmd    :: !(Event Command),+    giPDS    :: !PDState,+    giKS           :: !(Event (Char, Bool)),+    giDt           :: !Time,+    giT    :: !Time+}+++parseWinInput :: SF (WinInput,WinInput) GameInput+parseWinInput = (wiToCmd <<< (arr fst))&&&+                         (wiToPDS <<<(arr snd)) &&&+                         (wiToKs <<< (arr fst)) &&& (gDt)+                         >>^ \((cmdStr, cmd), (pds, (ks,(dt,t)))) ->+                           GameInput {giCmdStr = cmdStr,+                                            giCmd    = cmd,+                                            giPDS    = pds,+                                            giKS           = ks,+                                            giDt           = dt,+                                            giT    = t}+++-- All event sources below are defined such that they will NOT occur at local+-- time 0 (immediately after a switch). Sometimes explicitly using a "notYet".+-- Sometimes using through careful use of "edge" and relatives. Is this the+-- right approach?++-- A valid command has been read.+command :: SF GameInput (Event Command)+command = giCmd ^>> notYet++gDt :: SF a (Double,Double)+gDt+  = (arr (\_ -> 1) >>>+          (imIntegral 0 >>> arr (\ t -> (t, t))) >>>+         (first ((iPre 0) <<< identity) >>> arr (\ (lt, t) -> (t - lt + 0.005,t))))++-- Continuous parser feed back.+cmdString :: SF GameInput String+cmdString = arr giCmdStr++getT :: SF GameInput Time+getT = (iPre 0) <<< (arr giT)++getDt :: SF GameInput Time+getDt = (iPre 0) <<< (arr giDt)++ptrPos :: SF GameInput Position2+ptrPos = arr (pdsPos . giPDS)+++lbp :: SF GameInput (Event ())+lbp = lbpPos >>^ (`tag` ())++keyStat :: SF GameInput (Event (Char, Bool))+keyStat = giKS ^>> notYet++lbpPos :: SF GameInput (Event Position2)+lbpPos = giPDS # pdsLeft ^>> edgeJust+++lbDown :: SF GameInput Bool+lbDown = arr (giPDS # pdsLeft # isJust)+++rbp :: SF GameInput (Event ())+rbp = rbpPos >>^ (`tag` ())+++rbpPos :: SF GameInput (Event Position2)+rbpPos = giPDS # pdsRight ^>> edgeJust+++rbDown :: SF GameInput Bool+rbDown = arr (giPDS # pdsRight # isJust)+++dragStart :: SF GameInput (Event ())+dragStart = giPDS # pdsDrag ^>> edgeBy detectStart (Just undefined)+    where+           detectStart Nothing  (Just _) = Just ()+           detectStart _            _      = Nothing+++dragStop :: SF GameInput (Event Distance2)+dragStop = (giPDS # pdsDrag ^>> edgeBy detectStop Nothing) &&& dragVec+                 >>^ \(e, dv) -> e `tag` dv+    where+           detectStop (Just _) Nothing = Just ()+           detectStop _    _     = Nothing+++-- (Last) drag start position.+dragStartPos :: SF GameInput Position2+dragStartPos = arr (giPDS # pdsDragStartPos)+++-- (Last) drag vector.+dragVec :: SF GameInput Distance2+dragVec = arr (giPDS # pdsDragVec)+++dragging :: SF GameInput Bool+dragging = arr (giPDS # pdsDrag # isJust)+++++------------------------------------------------------------------------------+-- Lexical analysis of character input+------------------------------------------------------------------------------++-- Currently overkill, but being able to enter multi-character commands+-- could possibly be useful.++wiToKs :: SF WinInput (Event (Char,Bool))+wiToKs = arr (mapFilterE getKs)+    where+           getKs (HGL.Char {HGL.char=c, HGL.isDown = ks}) = Just (c,ks)+           getKs _                        = Nothing+++wiToCmd :: SF WinInput (String, Event Command)+wiToCmd = arr (mapFilterE selChar)+                >>> (accumBy scanChar (undefined,scanCmds) >>^ fmap fst >>^ splitE)+                >>> hold "" *** arr (mapFilterE id)+    where+           scanChar (_, S cont) c = cont c+           selChar (HGL.Char {HGL.char=c, HGL.isDown = True}) = Just c+           selChar _                        = Nothing+++-- This ought to be redone. Kont should probably be called Tranition or+-- somethinig.++-- We define a continuation to be the command recognized thus far (a String+-- and maybe a complete Command), and a scanner to be applied to the rest+-- of the input. (I.e., there's output at every step.)++type Kont = ((String, Maybe Command), Scanner)+type Cont a = a -> Kont++-- Since a scanner is applied to one character at a time (typically, on+-- Char events), we recursively define a scanner to be a character+-- continuation.++newtype Scanner = S (Cont Char)++-- Scan commands++scanCmds :: Scanner+scanCmds = scanCmd cmds+    where+           cmds =+            [ ("q", emitCmd scanCmds CmdQuit), -- Discard inp.?+                 ("p", emitCmd scanCmds CmdNewGame),+                 ("f", emitCmd scanCmds CmdFreeze),+                 ("r", emitCmd scanCmds CmdResume)+            ]+++-- Scan one command.+-- Looks for a valid command. Outputs prefix as long as the current+-- prefix is valid. Starts over on first invalid character. Invokes success+-- continuation on success.+-- cmds ....... List of pairs of valid command and corresponding success+--              continuation.++scanCmd :: [(String, Cont String)] -> Scanner+scanCmd cmds = scanSubCmd "" cmds+++-- Scan one subcommand/keyword argument.+-- Looks for a valid command. Outputs prefix as long as the current+-- prefix is valid. Starts over on first invalid character. Invokes success+-- continuation on success.+-- pfx0 ....... Initial prefix.+-- cmds ....... List of pairs of valid command and corresponding success+--              continuation.++scanSubCmd :: String -> [(String, Cont String)] -> Scanner+scanSubCmd pfx0 cmds = S (scHlp pfx0 cmds)+    where+           -- pfx ........      Command prefix.+           -- sfxconts ...      Command suffixes paired with success continuations.+           -- c .......... Input character.+           scHlp pfx sfxconts c =+            case c of+                '\r' ->+                    case [ cont | ("", cont) <- sfxconts ] of+                          []       -> emitPfx (S (scHlp pfx sfxconts)) pfx+                          (cont : _) -> cont pfx+                '.'     ->+                    case sfxconts of+                          []             -> emitPfx (S (scHlp pfx0 cmds)) pfx0+                          [(sfx, cont)] -> cont (pfx ++ sfx)+                          _                      ->+                            let+                                 (sfxs, conts) = unzip sfxconts+                                 cpfx           = foldr1 lcp sfxs+                                 sfxs'          = map (drop (length cpfx)) sfxs+                                 pfx'     = pfx ++ cpfx+                                 sfxconts'      = zip sfxs' conts+                            in+                                 emitPfx (S (scHlp pfx' sfxconts')) pfx'+                _       ->+                    let+                           pfx' = pfx ++ [c]+                           sfxconts' = [ (tail sfx, cont) | (sfx, cont) <- sfxconts, not (null sfx) && head sfx == c]+                    in+                           case sfxconts' of+                            []            -> emitPfx (S (scHlp pfx0 cmds))+                                                    pfx0+                                                    -- ("Invalid: " ++ [c])+                            [("", cont)] -> cont pfx'+                            _             -> emitPfx (S (scHlp pfx' sfxconts'))+                                                    pfx'++-- Emit command (and command string), then continue scanning.+emitCmd :: Scanner -> Command -> String -> Kont+emitCmd scanner cmd cmdStr = ((cmdStr, Just cmd), scanner)++-- Emit current prefix, then scan next character.+emitPfx :: Scanner -> String -> Kont+emitPfx scanner pfx = ((pfx, Nothing), scanner)+++------------------------------------------------------------------------------+-- Pointing device processing+------------------------------------------------------------------------------++-- State of the pointing device.+-- The points for pdsLeft, pdsRight, and pdsDrag reflect where the button+-- was initially pressed.+++data PDState = PDState {+    pdsPos              :: !Position2,    -- Current position.+    pdsDragStartPos :: !Position2,        -- (Last) drag start position.+    pdsDragVec  :: !Distance2,    -- (Latest) drag vector.+    pdsLeft             :: !(Maybe Position2),      -- Left button currently down.+    pdsRight            :: !(Maybe Position2),      -- Right button currently down.+    pdsDrag             :: !(Maybe Position2)       -- Currently dragging.+}+++-- Initial state.+initPDS :: PDState+initPDS = PDState {+                 pdsPos           = origin,+                 pdsDragStartPos = origin,+                 pdsDragVec       = zeroVector,+                 pdsLeft                  = Nothing,+                 pdsRight         = Nothing,+                 pdsDrag                  = Nothing+          }+++wiToPDS :: SF WinInput PDState+wiToPDS = (accumHoldBy nextPDS initPDS)+++-- Compute next pointing device state.+nextPDS :: PDState -> HGL.Event -> PDState+--nextPDS pds (HGL.Key {}) = pds                          -- Currently we ignore keys.+nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = True, HGL.isDown = True}) =+    -- Left button pressed.+    pds {pdsPos = p', pdsDragVec = dv, pdsLeft = Just p'}+    where+           p' = gPointToPosition2 p+           dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) (pdsDrag pds)+nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = True, HGL.isDown = False}) =+    -- Left button released.+    pds {pdsPos = p', pdsDragVec = dv, pdsLeft = Nothing, pdsDrag = md}+    where+           p' = gPointToPosition2 p+           md = maybe Nothing (const (pdsDrag pds)) (pdsRight pds)+           dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md+nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = False, HGL.isDown = True}) =+    -- Right button pressed.+    pds {pdsPos = p', pdsDragVec = dv, pdsRight = Just p'}+    where+           p' = gPointToPosition2 p+           dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) (pdsDrag pds)+nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = False, HGL.isDown = False}) =+    -- Right button released.+    pds {pdsPos = p', pdsDragVec = dv, pdsRight = Nothing, pdsDrag = md}+    where+           p' = gPointToPosition2 p+           md = maybe Nothing (const (pdsDrag pds)) (pdsLeft pds)+           dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md+nextPDS pds (HGL.MouseMove {HGL.pt = p}) =+    -- Mouse move.+    pds {pdsPos = p', pdsDragStartPos = dsp, pdsDragVec = dv, pdsDrag = md}+    where+           p' = gPointToPosition2 p+           md = case pdsLeft pds of+                    mlp@(Just _) -> mlp+                    Nothing       -> pdsRight pds+           dsp = maybe (pdsDragStartPos pds) id md+           dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md+nextPDS pds _ = pds                     -- Ignore unknown events.++gPointToPosition2 :: HGL.Point -> Position2+gPointToPosition2 (HGL.Point (x, y)) = (Point2 (fromIntegral x) (fromIntegral y))+------------------------------------------------------------------------------+-- General utilities+------------------------------------------------------------------------------++-- Longest common prefix.+lcp :: Eq a => [a] -> [a] -> [a]+lcp []   _                              = []+lcp _    []                             = []+lcp (x:xs) (y:ys) | x == y      = x : lcp xs ys+                           | otherwise = []
+ src/PhysicalDimensions.hs view
@@ -0,0 +1,130 @@+{- $Id: PhysicalDimensions.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                              I N V A D E R S                               *+*                                                                            *+*       Module:         PhysicalDimensions                                   *+*       Purpose:        Type synonyms for physical dimensions and some       *+*                       related operations.                                  *+*       Author:         Henrik Nilsson                                       *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module PhysicalDimensions (+    InvaderReal,++-- One dimensional+    Time,+    DTime,+    Frequency,+    Mass,+    Length,+    Distance,+    Position,+    Speed,+    Velocity,+    Acceleration,+    Angle,+    Heading,+    Bearing,+    RotVel,+    RotAcc,++-- Two dimensional+    Distance2,+    Position2,+    Velocity2,+    Acceleration2,++-- Three dimensional+    Distance3,+    Position3,+    Velocity3,+    Acceleration3,++-- Operations+    normalizeAngle,     -- :: Angle -> Angle+    normalizeHeading,   -- :: Heading -> Heading+    bearingToHeading,   -- :: Bearing -> Heading+    headingToBearing    -- :: Heading -> Bearing+) where++import AFRP (Time, DTime)+import AFRPMiscellany (fMod)+import AFRPGeometry (Vector2, Vector3, Point2, Point3)+++-- Many of the physical dimensions below are related to time, and variables+-- of these types can thus be expected to occur in numerical expressions along+-- with variables of type time. To facilitate things, they should thus share+-- the same representation. Maybe it is a mistake that AFRP has fixed the+-- type of Time (currently to Double)?++-- Dimensionless type. Same representation as AFRP's Time.+type InvaderReal = Time++------------------------------------------------------------------------------+-- One-dimensional types+------------------------------------------------------------------------------++type Frequency    = InvaderReal -- [Hz]+type Mass         = InvaderReal -- [kg]+type Length       = InvaderReal -- [m]+type Position     = InvaderReal -- [m]   (absolute)+type Distance     = InvaderReal -- [m]   (relative)+type Speed        = InvaderReal -- [m/s] (unsigned, speed = abs(velocity))+type Velocity     = InvaderReal -- [m/s] (signed)+type Acceleration = InvaderReal -- [m/s^2]+type Angle        = InvaderReal -- [rad] (relative)+type Heading      = InvaderReal -- [rad] (angle relative to x-axis = east)+type Bearing      = InvaderReal -- [deg] (compass direction, 0 = N, 90 = E)+type RotVel       = InvaderReal -- [rad/s]+type RotAcc       = InvaderReal -- [rad/s^2]+++------------------------------------------------------------------------------+-- Two-dimensional types+------------------------------------------------------------------------------++type Position2     = Point2 Position                    -- [m]     (absolute)+type Distance2     = Vector2 Distance                   -- [m]     (relative)+type Velocity2     = Vector2 Velocity                   -- [m/s]+type Acceleration2 = Vector2 Acceleration               -- [m/s^2]+++------------------------------------------------------------------------------+-- Three-dimensional types+------------------------------------------------------------------------------++type Position3     = Point3 Position                    -- [m]     (absolute)+type Distance3     = Vector3 Distance                   -- [m]     (relative)+type Velocity3     = Vector3 Velocity                   -- [m/s]+type Acceleration3 = Vector3 Acceleration               -- [m/s^2]+++------------------------------------------------------------------------------+-- Operations+------------------------------------------------------------------------------++-- The resulting angle is in the interval [-pi, pi).+normalizeAngle :: Angle -> Angle+normalizeAngle d = fMod (d + pi) (2 * pi) - pi++-- The resulting heading is in the interval [-pi, pi).+normalizeHeading :: Heading -> Heading+normalizeHeading =  normalizeAngle++-- Bearings in degrees are understood as on a compass; i.e., north is 0,+-- east is 90, south is 180, west is 270.+-- Heading is understood as the angle (in radians) relative to the "x-axis"+-- which is supposed to point East.++-- The resulting heading is in the interval [-pi, pi).+bearingToHeading :: Bearing -> Heading+bearingToHeading b = (fMod (270 - b) 360 - 180) * pi / 180++-- The resulting bearing is in the interval [0, 360).+headingToBearing :: Heading -> Bearing+headingToBearing d = fMod (90 - d * 180 / pi) 360
+ src/Quaternion.hs view
@@ -0,0 +1,90 @@+{- Quaternion.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This module just performs some basic
+converions between quaternions and matrices
+
+-}
+
+
+module Quaternion where
+
+import Graphics.UI.GLUT -- (GLmatrix, GLfloat, newMatrix, ColumnMajor)
+
+type Quaternion = (Float,Float,Float,Float)
+
+type Matrix3x3 = ((Float,Float,Float),
+                  (Float,Float,Float),
+                  (Float,Float,Float))
+
+-- converts from quaternion to matrix
+quat2Mat :: Quaternion -> (Float,Float,Float) -> IO (GLmatrix GLfloat)
+quat2Mat (x,y,z,w) (t1,t2,t3)=
+   newMatrix ColumnMajor [(r00 :: GLfloat),r01,r02,r03,
+                          r10,r11,r12,r13,
+                          r20,r21,r22,r23,
+                          r30,r31,r32,r33]
+   where r00 = 1 - (2*((y*y)+(z*z)))
+         r01 = 2 * ((x*y)-(w*z))
+         r02 = 2 * ((x*z)+(w*y))
+         r03 = 0
+
+         r10 = 2 * ((x*y)+(w*z))
+         r11 = 1 - (2*((x*x)+(z*z)))
+         r12 = 2 * ((y*z)-(w*x))
+         r13 = 0
+
+         r20 = 2 * ((x*z)-(w*y))
+         r21 = 2 * ((y*z)+(w*x))
+         r22 = 1 - (2*((x*x)+(y*y)))
+         r23 = 0
+
+         r30 = t1
+         r31 = t2
+         r32 = t3
+         r33 = 1
+
+-- converts from matrix to quaternion
+mat2Quat :: Matrix3x3 -> Quaternion
+mat2Quat ((r00,r01,r02),
+          (r10,r11,r12),
+          (r20,r21,r22))
+   | diag > 0.00000001      = ((r21-r12)/scale0,
+                              (r02-r20)/scale0,
+                              (r10-r01)/scale0,
+                              0.25*scale0)
+   | r00 > r11 && r00 > r22 = (0.25*scale1,
+                              (r10+r01)/scale1,
+                              (r02+r20)/scale1,
+                              (r21-r12)/scale1)
+   | r11 > r22              = ((r10+r01)/scale2,
+                              0.25*scale2,
+                              (r21+r12)/scale2,
+                              (r02-r20)/scale2)
+   | otherwise              = ((r02+r20)/scale3,
+                              (r21+r12)/scale3,
+                              0.25*scale3,
+                              (r10-r01)/scale3)
+   where
+      diag   = r00+r11+r22+1
+      scale0 = 2*(sqrt diag)
+      scale1 = 2*(sqrt (r00-r11-r22+1))
+      scale2 = 2*(sqrt (r11-r00-r22+1))
+      scale3 = 2*(sqrt (r22-r00-r11+1))
+
+
+-- does not really perform spherical linaer interpolation
+-- but the difference isn't really noticeable
+slerp :: Quaternion -> Quaternion -> Float -> Quaternion
+slerp q1@(x0,y0,z0,w0) q2@(x1,y1,z1,w1) t
+   | q1 == q2 = q1
+   |otherwise = ((scale0*x0)+(scale1*x1),
+                 (scale0*y0)+(scale1*y1),
+                 (scale0*z0)+(scale1*z1),
+                 (scale0*w0)+(scale1*w1))
+   where
+      scale0 = 1 - t
+      scale1 = t
+
+
+
+
+ src/Raybox.hs view
@@ -0,0 +1,67 @@+{- Raybox.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This module performs collision tests between AABBs, spheres and rays.
+
+-}
+
+module Raybox where
+
+import Matrix
+
+-- tests if a ray intersects a box
+rayBox :: (Double,Double,Double) ->  (Double,Double,Double) ->
+               (Double,Double,Double) -> (Double,Double,Double) -> Bool
+rayBox (rayOx,rayOy,rayOz) (rayDx,rayDy,rayDz) (minx,miny,minz)(maxx,maxy,maxz)
+   | (rayOx,rayOy,rayOz) == (rayDx,rayDy,rayDz) = False
+   | otherwise =
+       case ((txmin > tymax) || (tymin > txmax)) of
+          True -> False
+          _    -> intersectz
+    where (txmin,txmax) = getT rayOx rayDx minx maxx
+          (tymin,tymax) = getT rayOy rayDy miny maxy
+          (tzmin,tzmax) = getT rayOz rayDz minz maxz
+          intersectz    =
+             not (((max txmin tymin) > tzmax) || (tzmin > (min txmax tymax)))
+
+getT :: Double ->  Double -> Double -> Double -> (Double, Double)
+getT rayO rayD mn mx
+   | dd >= 0   = ((mn-rayO)*dd, (mx-rayO)*dd)
+   | otherwise = ((mx-rayO)*dd, (mn-rayO)*dd)
+   where dd = (1/(rayO-rayD))
+
+
+-- tests if 2 AABBs intersect
+boxBox :: Vec3 -> Vec3 -> Vec3 -> Vec3  -> Bool
+boxBox (x1,y1,z1) (w1,h1,d1) (x2,y2,z2) (w2,h2,d2)
+   | abs (x1 - x2) <= w1+w2 = True
+   | abs (y1 - y2) <= h1+h2 = True
+   | abs (z1 - z2) <= d1+d2 = True
+   | otherwise = False
+
+
+-- tests if an AABB intersects a sphere
+boxSphere :: Vec3 -> Vec3 -> Vec3 -> Double  -> Bool
+boxSphere (x1,y1,z1) (w1,h1,d1) (x2,y2,z2) rad
+   | (abs (x1 - x2)) <= (w1+rad) = True
+   | (abs (y1 - y2)) <= (h1+rad) = True
+   | (abs (z1 - z2)) <= (d1+rad) = True
+   | otherwise = False
+
+
+-- test if two spheres intersect
+sphereSphere ::  Vec3 -> Vec3 -> Double -> Double -> Bool
+sphereSphere (x1,y1,z1) (x2,y2,z2) rad1 rad2 =
+   (sqrt ((x1-x2)*(x1-x2))+((y1-y2)*(y1-y2))+((z1-z2)*(z1-z2))) <= (rad1+rad2)
+
+
+-- tests if a point lies within a sphere
+spherePoint :: Vec3 -> Vec3 -> Double -> Bool
+spherePoint (x1,y1,z1) (x2,y2,z2) rad =
+   (sqrt $ ((x1-x2)*(x1-x2)) + ((y1-y2)*(y1-y2)) + ((z1-z2)*(z1-z2))) <= rad
+
+
+-- test if a point lies in an AABB
+pointBox :: Vec3 -> Vec3 -> Vec3   -> Bool
+pointBox (x1,y1,z1) (x2,y2,z2) (w,h,d)
+   | abs (x1 - x2) <= w && abs (y1 - y2) <= h && abs (z1 - z2) <= d = True
+   | otherwise = False
+ src/ReadImage.hs view
@@ -0,0 +1,68 @@+{-+   ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2004 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This module has been modified to read both color and alpha data necessary for transparent textures in OpenGL.++   Support for reading a file of raw RGB data:+      4 bytes big-endian width+      4 bytes big-endian height+      width * height RGBA byte quadruples (the original module reads width * height RGB byte triples)+-}++module ReadImage ( readImage ) where++import Data.Word ( Word8, Word32 )+import Control.Exception ( bracket )+import Control.Monad ( liftM, when )+import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose )+import System.IO.Error ( mkIOError, eofErrorType )+import Foreign ( Ptr, alloca, mallocBytes, Storable(..) )+import Graphics.UI.GLUT++-- This is probably overkill, but anyway...+newtype Word32BigEndian = Word32BigEndian Word32++word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei+word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x++instance Storable Word32BigEndian where+   sizeOf ~(Word32BigEndian x) = sizeOf x+   alignment ~(Word32BigEndian x) = alignment x+   peek ptr = do+      let numBytes = sizeOf (undefined :: Word32BigEndian)+      bytes <- mapM (peekByteOff ptr) [ 0 ..  numBytes - 1 ] :: IO [Word8]+      let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes+      return $ Word32BigEndian value+   poke = error ""++-- This is the reason for all this stuff above...+readGLsizei :: Handle -> IO GLsizei+readGLsizei handle =+   alloca $ \buf -> do+      hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian))+      liftM word32BigEndianToGLsizei $ peek buf++-- A handy variant of hGetBuf with additional error checking+hGetBufFully :: Handle -> Ptr a -> Int -> IO ()+hGetBufFully handle ptr numBytes = do+   bytesRead <- hGetBuf handle ptr numBytes+   when (bytesRead /= numBytes) $+      ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing+++-- Closing a file is nice, even when an error occurs during reading.+withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a+withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose++readImage :: FilePath -> IO (Maybe (Size, PixelData a))+readImage filePath =+   withBinaryFile filePath $ \handle -> do+      width <- readGLsizei handle+      height <- readGLsizei handle+      let numBytes = fromIntegral (4 * width * height)  -- changed the 3 to a 4 to make space for our alpha data.+      buf <- mallocBytes numBytes+      hGetBufFully handle buf numBytes+      return $ Just (Size width height, PixelData RGBA UnsignedByte buf)  -- changed the PixelFormat constructor here from RGB to RGBA, to account for our alpha data.
+ src/Render.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE BangPatterns #-}++module Render (+    renderObjects,+    renderGun,+    renderHud,+    GameData(..)+) where++import MD3+import Object+import Graphics.Rendering.OpenGL+import Data.IORef+import Data.Maybe+import Camera+import Matrix+import Frustum+import BSP+import Data.HashTable+import Visibility+import TextureFonts++data GameData = GameData {+                            gamemap        :: IORef(BSPMap),+                            models         :: HashTable String Model,+                            textures       :: HashTable String (Maybe TextureObject),+                            camera         :: IORef(Camera),+                            lastDrawTime   :: IORef(Int),+                            lastDrawTime2  :: IORef(Int),+                            hasReacted     :: IORef(Bool),+                            fonts          :: (Maybe TextureObject,DisplayList),+                            nbase          :: DisplayList,+                            lock           :: IORef(Bool),+                            fpsc           :: IORef(Double,Double),+                            fpss           :: IORef(Double,Double,Double),+                            nems           :: !Int+                         }++-- renders the playerstate, gun and crosshairs+renderHud :: GameData -> ObsObjState -> Int -> Int -> IO()+renderHud gd playerState noos tme = do+   setUpOrtho $ do+          --show the framerate+          lastTime3 <- readIORef (lastDrawTime2 gd)+          let dt = ((realToFrac(tme - lastTime3))/1000)+          color $ Color4 255 255 255 (255 :: GLubyte)+          printFonts' 0 464 (fonts gd) 1 $+                "framerate = " ++ (show $ ((truncate ((1/dt) :: Double)) :: Int))++          --print the player's score+          printFonts' 0 448 (fonts gd) 1+                ("ezpks = " ++(show (score playerState)))++          --print the position of the player+          let (q,w,e) = (cpos (oldCam playerState))+          printFonts' 0 432 (fonts gd) 1+                ("position = " ++(show ((truncate q :: Int),(truncate w :: Int),(truncate e :: Int))))++          --print the number of objects+          printFonts' 0 416 (fonts gd) 1 ("No. of objs = " ++(show noos))++          --print a message if the player has eliminated all enemies+          color $ Color4 0 255 0 (255 :: GLubyte)+          case ((score playerState) == (nems gd) && (nems gd) > 0) of+                True ->  do+                   printFonts' 96 272 (fonts gd) 1 ("You've killed everybody! (You monster.)")+                   --printFonts' 248 256 (fonts gd) 1 ("Happy Now?")+                _ -> return ()++          --print a message if the player has died+          case (health playerState <= 0) of+                True -> do+                            color $ Color4 255 0 0 (255 :: GLubyte)+                            printFonts' 210 240 (fonts gd) 1 ("Oh, botheration. You died.")+                            color $ Color4 255 255 255 (255 :: GLubyte)+                _ -> return ()+++          --render the health and score of the player with big fonts+          color $ Color4 255 255 255 (255 :: GLubyte)+          printFonts' 4 50 (fonts gd) 1 ("health")+          printFonts' 540 50 (fonts gd) 1 ("score")+          color $ Color4 232 192 0 (255 :: GLubyte)+          case (health playerState > 0) of+            True        -> renderNum  4 1 (nbase gd) (truncate(health playerState))+            False  -> renderNum 4 1 (nbase gd) (0)+          color $ Color4 232 192 0 (255 :: GLubyte)+          renderNum  540 1      (nbase gd) (score playerState)++          --render a smiley at the middle of the screen+          unsafePreservingMatrix $ do+            scale 20 10 (20 :: GLfloat)+            color $ Color4 255 255 255 (255 :: GLubyte)+            printLife (fonts gd) (truncate(health playerState))+            color $ Color4 255 255 255 (255 :: GLubyte)++          --render the crosshair+          renderCrosshair (textures gd)++          depthFunc              $= Just Less++++--print a smiley representing the health of the player+printLife :: (Maybe TextureObject,DisplayList) -> Int -> IO()+printLife font life+   | life <= 0  = do printf ("(x_x)")+   | life <= 19  = do printf ("(T_T)")+   | life <= 19  = do printf ("(~_~)")+   | life <= 39  = do printf ("(-_-)")+   | life <= 59  = do printf ("(o_0)")+   | life <= 79  = do printf ("(o_o)")+   | otherwise = do printf ("(^_^)")+   where printf str = printFonts' 292 32 font 1 (str)+++renderObjects :: IORef(Camera) -> HashTable String Model ->+   Frustum -> BSPMap  -> ObsObjState -> IO()+renderObjects camRef mdels frust mp oos+   | isRay oos        = renderRay oos+   | isProjectile oos = renderProjectile oos+   | isAICube oos     = renderEnemy camRef mdels frust mp oos+   | otherwise        = return ()+++renderGun :: Camera -> HashTable String Model -> IO()+renderGun cam mdels = do+   Just weapon <- Data.HashTable.lookup mdels "railgun"+   let (x,y,z)    = cpos cam+   let (vx,vy,vz) = viewPos cam+   unsafePreservingMatrix $ do+          --clear the depth buffer so the gun will appear+          --on top of the graphics in the scene+          clear [DepthBuffer ]++          --translate and rotate the gun so it is aligned with players view vector+          translate (Vector3 x (y+30) (z :: Double))+          let angle2 =+                    acos $ dotProd (normalise $ vectorSub (vx,0,vz) (x,0,z)) (1,0,0)+          case (vz > z ) of+                False -> rotate ((angle2*180/pi) :: GLdouble) (Vector3 0 1 0)+                True  -> rotate ((360 - (angle2*180/pi)) :: GLdouble) (Vector3 0 1 0)+          let angle1 =+                    acos $ dotProd (normalise $ vectorSub (vx,vy,vz) (x,y,z)) (0,1,0)+          rotate (90-(angle1*180/pi) :: GLdouble) (Vector3 0 0 1)+          rotate (-90 :: Double) (Vector3 1 0 0)+          translate (Vector3 (4.8) (-9.5) ((-20) :: Double))+          scale 2 2 (2 :: GLfloat)++          --setup the animation state and drw the model+          writeIORef (auxFunc2 (modelRef weapon)) Nothing+          drawModel (modelRef weapon,lowerState weapon)+   depthFunc              $= Just Always+++renderRay :: ObsObjState -> IO()+renderRay (OOSRay {rayStart = (x1,y1,z1),+                            rayEnd   = (x2,y2,z2),+                            clipped  = cl}) = do+    cullFace               $= Nothing+    color $ Color4 255 0 0 (255 :: GLubyte)+    depthFunc              $= Just Always+    unsafeRenderPrimitive Quads $ do+          vertex (Vertex3 x2 (y2+0.3) z2)+          vertex (Vertex3 x2 (y2-0.3) z2)+          vertex (Vertex3 x1 (y1-0.3) z1)+          vertex (Vertex3 x1 (y1+0.3) z1)+    color $ Color4 255 255 255 (255 :: GLubyte)+    unsafeRenderPrimitive Quads $ do+          vertex (Vertex3 x2 (y2+0.12) z2)+          vertex (Vertex3 x2 (y2-0.12) z2)+          vertex (Vertex3 x1 (y1-0.12) z1)+          vertex (Vertex3 x1 (y1+0.12) z1)+    depthFunc              $= Just Less+    cullFace               $= Just Front+    case cl of+          True -> do+                cullFace                    $= Nothing+                unsafePreservingMatrix $ do+                   translate (Vector3 x2 y2 z2)+                   renderQuadric+                         (QuadricStyle Nothing NoTextureCoordinates Outside FillStyle)+                            (Sphere 3 12 12)+                cullFace                    $= Just Front+          _ -> return()+    color $ Color4 255 255 255 (255 :: GLubyte)+++renderProjectile :: ObsObjState -> IO()+renderProjectile (OOSProjectile {projectileOldPos = (x,y,z)}) = do+   unsafePreservingMatrix $ do+         translate (Vector3 x y z)+         depthFunc              $= Just Always+         cullFace               $= Nothing+         color $ Color4 0 0 80 (255 :: GLubyte)+         renderQuadric+            (QuadricStyle Nothing NoTextureCoordinates Outside FillStyle)+                   (Sphere 4 12 12)+         color $ Color4 50 50 160 (255 :: GLubyte)+         renderQuadric+            (QuadricStyle Nothing NoTextureCoordinates Outside FillStyle)+                   (Sphere 3.5 12 12)+         color $ Color4 255 255 255 (255 :: GLubyte)+         renderQuadric+            (QuadricStyle Nothing NoTextureCoordinates Outside FillStyle)+                   (Sphere 2.5 12 12)+         cullFace               $= Just Front+         depthFunc              $= Just Less+++renderEnemy ::+  IORef(Camera) -> HashTable String Model ->+        Frustum -> BSPMap  -> ObsObjState -> IO()+renderEnemy camRef mdels frust bspmap (OOSAICube {oosOldCubePos = (x,y,z),+                                                                            oosCubeSize = (sx,sy,sz),+                                                                            oosCubeAngle        = angle,+                                                                            oosCubePitch        = p,+                                                                            upperAnim           = ua,+                                                                            fade                        = f,+                                                                            lowerAnim           = la,+                                                                            modelName           = name}) = do++   --perform a test to see if the object is visible from the player's location+   cam    <- readIORef camRef+   clustVis <- isObjectVisible bspmap (cpos cam) (x,y,z)+   case (clustVis) of+         False -> return()+         True -> do+         -- a second check to see if the object is within the player's frustum+         let frusTest = boxInFrustum frust+                                    (vectorAdd (x,y,z) (-sx,-sy,-sz))+                                    (vectorAdd (x,y,z) (sx,sy,sz))+         case (frusTest) of+            True -> do+                  -- a third check to see if a ray can be fired to+                  --the objects position without colliding+                  let rayVis = rayTest bspmap (cpos cam) (x,y,z)+                  case (rayVis) of+                        False -> return()+                        _ -> do+                           unsafePreservingMatrix $ do+                                 lineWidth $= 5.0+                                 translate (Vector3 x y z)+                                 Just model <- Data.HashTable.lookup mdels name+                                 writeIORef (pitch model)+                                    (Just $ do+                                                    cullFace $=  Nothing+                                                    cullFace $=  Just Front+                                                    (rotate p (Vector3 0 1 0)))+                                 writeIORef (lowerState model)  la+                                 writeIORef (upperState model)  ua+                                 currentColor $= Color4 (f*60) (f*60) (f*60) (1 :: Float)+                                 unsafePreservingMatrix $ do+                                    rotate ((-90) :: GLdouble) (Vector3 1 0 0)+                                    rotate (angle) (Vector3 0 0 1)+                                    translate (Vector3 (-10) 0 (-10 :: Double))+                                    scale 1.5 1.5 (1.5 :: GLfloat)+                                    drawModel (modelRef model,lowerState model)+                                 currentColor $= Color4 1 1 1 (1 :: Float)+                                 writeIORef (pitch model) Nothing+            False -> return ()
+ src/RenderObject.hs view
@@ -0,0 +1,137 @@+++module RenderObject (+    renderObjects+) where++import MD3+import Object+import Graphics.UI.GLUT+import Graphics.Rendering.OpenGL+import Data.IORef+import Data.Maybe+import Camera+import Matrix+import Frustum+import BSP+import Data.HashTable+import Visibility++renderObjects :: IORef(Camera) -> HashTable String Model -> Frustum -> BSPMap  -> ObsObjState -> IO()+renderObjects camRef models frust map oos+  | isRay oos = renderRay oos+  | isProjectile oos = renderProjectile oos+  | isAICube oos = renderEnemy camRef models frust map oos+  | otherwise = return()+++renderRay :: ObsObjState -> IO()+renderRay (OOSRay {rayStart = (x1,y1,z1),+                            rayEnd   = (x2,y2,z2),+                            clipped  = cl}) = do+    cullFace               $= Nothing+    color $ Color4 255 0 0 (255 :: GLubyte)+    depthFunc              $= Just Always+    unsafeRenderPrimitive Quads $ do+          vertex (Vertex3 x2 (y2+0.3) z2)+          vertex (Vertex3 x2 (y2-0.3) z2)+          vertex (Vertex3 x1 (y1-0.3) z1)+          vertex (Vertex3 x1 (y1+0.3) z1)+    color $ Color4 255 255 255 (255 :: GLubyte)+    unsafeRenderPrimitive Quads $ do+          vertex (Vertex3 x2 (y2+0.12) z2)+          vertex (Vertex3 x2 (y2-0.12) z2)+          vertex (Vertex3 x1 (y1-0.12) z1)+          vertex (Vertex3 x1 (y1+0.12) z1)+    depthFunc              $= Just Less+    cullFace               $= Just Front+    case cl of+          True -> do+                cullFace                    $= Nothing+                unsafePreservingMatrix $ do+                   translate (Vector3 x2 y2 z2)+                   renderQuadric+                         (QuadricStyle Nothing NoTextureCoordinates Outside FillStyle)+                            (Sphere 3 12 12)+                   cullFace               $= Just Front+          _ -> return()+    color $ Color4 255 255 255 (255 :: GLubyte)+++renderProjectile :: ObsObjState -> IO()+renderProjectile (OOSProjectile {projectileOldPos = (x,y,z)}) = do+   unsafePreservingMatrix $ do+         translate (Vector3 x y z)+         depthFunc              $= Just Always+         cullFace               $= Nothing+         color $ Color4 0 0 80 (255 :: GLubyte)+         renderQuadric+            (QuadricStyle Nothing NoTextureCoordinates Outside FillStyle)+                   (Sphere 4 12 12)+         color $ Color4 50 50 160 (255 :: GLubyte)+         renderQuadric+            (QuadricStyle Nothing NoTextureCoordinates Outside FillStyle)+                   (Sphere 3.5 12 12)+         color $ Color4 255 255 255 (255 :: GLubyte)+         renderQuadric+            (QuadricStyle Nothing NoTextureCoordinates Outside FillStyle)+                   (Sphere 2.5 12 12)+         cullFace               $= Just Front+         depthFunc              $= Just Less+++renderEnemy ::+  IORef(Camera) -> HashTable String Model ->+        Frustum -> BSPMap  -> ObsObjState -> IO()+renderEnemy camRef models frust bspmap (OOSAICube {oosOldCubePos = (x,y,z),+                                                                            oosCubeSize   = (sx,sy,sz),+                                                                            oosCubeAngle  = angle,+                                                                            oosCubePitch  = p,+                                                                            target         = targ,+                                                                            upperAnim      = ua,+                                                                            fade                   = f,+                                                                            lowerAnim      = la,+                                                                            modelName      = name}) = do++   --perform a test to see if the object is visible from the player's location+   cam    <- readIORef camRef+   clustVis <- isObjectVisible bspmap (cpos cam) (x,y,z)+   case (clustVis) of+         False -> return ()+         True -> do+         -- a second check to see if the object is within the player's frustum+         let frusTest = boxInFrustum frust+                                    (vectorAdd (x,y,z) (-sx,-sy,-sz))+                                    (vectorAdd (x,y,z) (sx,sy,sz))+         case (frusTest) of+            True -> do+                  -- a third check to see if a ray can be fired to+                  --the objects position without colliding+                  let rayVis = rayTest bspmap (cpos cam) (x,y,z)+                  case (rayVis) of+                        False -> return()+                        _ -> do+                           unsafePreservingMatrix $ do+                                 lineWidth $= 5.0+                                 translate (Vector3 x y z)+                                 Just model <- Data.HashTable.lookup models name+                                 writeIORef (pitch model)+                                    (Just $ do+                                                    cullFace $=  Nothing+                                                    cullFace $=  Just Front+                                                    (rotate p (Vector3 0 1 0)))+                                 writeIORef (lowerState model)  la+                                 writeIORef (upperState model)  ua+                                 currentColor $= Color4 (f*60) (f*60) (f*60) (1 :: Float)+                                 unsafePreservingMatrix $ do+                                    rotate ((-90) :: GLdouble) (Vector3 1 0 0)+                                    rotate (angle) (Vector3 0 0 1)+                                    translate (Vector3 (-10) 0 (-10 :: Double))+                                    scale 1.5 1.5 (1.5 :: GLfloat)+                                    drawModel (modelRef model,lowerState model)+                                 currentColor $= Color4 1 1 1 (1 :: Float)+                                 writeIORef (pitch model) Nothing+            False -> return()+++
+ src/TGA.hs view
@@ -0,0 +1,94 @@+{- TGA.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This module was based on lesson 24 from neon helium productions
+http://nehe.gamedev.net/data/lessons/lesson.asp?lesson=24
+
+The TGA format is a used bitmap image file format. They are
+quite easy to load compared to other formats and have
+good support in image editors. All that has to be done is
+read the header to determine the dimensions and pixel format.
+Then the bytes have to be swapped and can be used by OPenGL.
+
+If you see a texture that is upside down, just open it in your
+editor and flip it vertically. Somtimes the TGA file is stored
+with its pixels upside down.
+
+-}
+
+
+
+module TGA where
+
+import Data.Word ( Word8 )
+import Control.Exception ( bracket )
+import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose )
+import Foreign.Marshal.Array (peekArray, pokeArray)
+import Foreign.Marshal.Alloc (free, mallocBytes)
+import Foreign.Ptr (plusPtr, Ptr())
+import Graphics.UI.GLUT -- (Size, PixelData, UnsignedByte, PixelFormat, RGBA, RGB)
+
+
+withBinaryFile' :: FilePath -> (Handle -> IO a) -> IO a
+withBinaryFile' filePath = bracket (openBinaryFile filePath ReadMode) hClose
+
+-- reads a *.tga file
+readTga :: FilePath -> IO (Maybe (Size, PixelData Word8))
+readTga filePath =
+   withBinaryFile' filePath $ \handle -> do
+   buf <- mallocBytes 6 :: IO(Ptr Word8)
+   --the first 12 bytes of the header aren't used
+   hGetBuf handle buf 6
+   hGetBuf handle buf 6
+   hGetBuf handle buf 6
+   header <- peekArray 6 buf
+   let w1       = (fromIntegral (header!!1))*256 :: Int
+   let width    = w1 + (fromIntegral (header!!0))
+   let h1       = (fromIntegral (header!!3))*256 :: Int
+   let height   = h1 + (fromIntegral (header!!2))
+   let bitspp   = (fromIntegral (header!!4))
+   let numBytes = (bitspp `div` 8) * width * height
+   --allocate memory for the image
+   image <- mallocBytes numBytes
+   hGetBuf handle image numBytes
+   --define whether the pixels are in RGB or RGBA format.
+   pixelFormat <- getFormat (fromIntegral bitspp)
+   free buf
+   --convert the pixels which are in BGR/BGRA to RGB/RGBA
+   swapBytes' image (bitspp `div` 8) (width * height)
+   print ("loaded "++filePath)
+   return $ Just (Size (fromIntegral width) (fromIntegral height),
+               PixelData pixelFormat UnsignedByte image)
+
+-- converts the image from bgr/bgra to rgb/rgba
+-- perhaps the opengl bgra extension could be
+-- used to avoid this
+swapBytes' :: Ptr Word8 -> Int -> Int -> IO()
+swapBytes' image bytespp size =
+   case bytespp of
+      3 -> do mapM_ (swapByteRGB.(plusPtr image).(bytespp*)) [0..(size-1)]
+      _ -> do mapM_ (swapByteRGBA.(plusPtr image).(bytespp*)) [0..(size-1)] -- 4
+
+-- converts from bgr to rgb
+swapByteRGB :: Ptr Word8 -> IO()
+swapByteRGB ptr = do
+   [b,g,r] <- peekArray 3 ptr
+   pokeArray ptr [r,g,b]
+
+-- converts from bgra to rgba
+swapByteRGBA :: Ptr Word8 -> IO()
+swapByteRGBA ptr = do
+   [b,g,r,a] <- peekArray 4 ptr
+   pokeArray ptr [r,g,b,a]
+
+-- returns the pixel format given the bits per pixel
+getFormat :: Int ->  IO(PixelFormat)
+getFormat bpp = do
+   case bpp of
+      32 ->  return RGBA
+      _ ->  return RGB -- 24
+
+
+
+
+
+
+ src/TextureFonts.hs view
@@ -0,0 +1,150 @@+{- TextureFonts.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This module handles the fonts and crosshairs of the game
+
+--credits go to NeHe tutorials for their texturefonts tutorial
+
+-}
+
+module TextureFonts where
+
+import Graphics.UI.GLUT
+import Textures
+import Maybe
+import Char
+import Data.HashTable
+
+
+-- build a display list for the fonts
+buildFonts :: IO(Maybe TextureObject,DisplayList)
+buildFonts = do
+  lists <- genObjectNames $ fromIntegral (256 :: Int)
+  let lists2 = concat $ splitList lists
+  fontTex <- getAndCreateTexture "font"
+  textureBinding Texture2D $= fontTex
+  let cxcys = [((realToFrac(x `mod` 16))/16 ,
+        ((realToFrac (x `div` 16))/16))| x<-[0..(255 :: Int)]]
+  mapM_ genFontList (zip cxcys lists2)
+  return (fontTex,head lists)
+
+
+splitList :: [DisplayList] -> [[DisplayList]]
+splitList [] = []
+splitList list = (splitList (drop 16 list))++[(take 16 list)]
+
+
+-- the steps needed to display every font
+genFontList :: ((Float,Float),DisplayList) -> IO()
+genFontList ((cx,cy),list) = do
+   defineList list Compile $ do
+     unsafeRenderPrimitive Quads $ do
+         texCoord (TexCoord2 cx (1-cy-0.0625))
+         vertex   (Vertex2 0 (16 :: Float))
+         texCoord (TexCoord2 (cx+0.0625) (1-cy-0.0625))
+         vertex   (Vertex2 16 (16 :: Float))
+         texCoord (TexCoord2 (cx+0.0625) (1-cy-0.001))
+         vertex   (Vertex2 16 (0 :: Float))
+         texCoord (TexCoord2 cx (1-cy-0.001))
+         vertex   (Vertex2 0 (0 :: Float))
+     translate (Vector3 (14 :: Float) 0 0)
+
+
+-- generates a displaylist for displaying large digits
+buildBigNums :: IO DisplayList
+buildBigNums = do
+  lists <- genObjectNames $ fromIntegral (11 :: Int)
+  texs <- getAndCreateTextures ["0","1","2","3","4","5","6","7","8","9","hyphen"]
+  mapM_ genBigNumList (zip texs lists)
+  return $ head lists
+
+
+-- steps needed to render a big digit
+genBigNumList :: (Maybe TextureObject,DisplayList) -> IO()
+genBigNumList (tex,list) = do
+   defineList list Compile $ do
+      textureBinding Texture2D $= tex
+      unsafeRenderPrimitive Quads $ do
+         texCoord (TexCoord2  0 ( 1 :: Float))
+         vertex   (Vertex2    0 ( 0 :: Float))
+         texCoord (TexCoord2  0 ( 0 :: Float))
+         vertex   (Vertex2    0 (45 :: Float))
+         texCoord (TexCoord2  1 ( 0 :: Float))
+         vertex   (Vertex2   30 (45 :: Float))
+         texCoord (TexCoord2  1 ( 1 :: Float))
+         vertex   (Vertex2   30 ( 0 :: Float))
+      translate   (Vector3 (32 :: Float) 0 0)
+
+
+-- renders a large digit
+renderNum :: Float -> Float -> DisplayList -> Int -> IO()
+renderNum x y (DisplayList base) n = unsafePreservingMatrix $ do
+   loadIdentity
+   texture Texture2D $= Enabled
+   alphaFunc $= Just (Greater,0.1:: Float)
+   let list = map toDList (show n)
+   unsafePreservingMatrix $ do
+      translate (Vector3 x y (0::Float))
+      mapM_ callList list
+   alphaFunc $= Nothing
+   texture Texture2D $= Disabled
+   where
+      toDList c = DisplayList (base +(fromIntegral((ord c)-48)))
+
+
+-- print a string starting at a 2D screen position
+printFonts' :: Float -> Float ->
+   (Maybe TextureObject,DisplayList)->
+       Int-> String -> IO()
+printFonts' x y (fontTex,DisplayList _) st string =
+   unsafePreservingMatrix $ do
+      loadIdentity
+      texture Texture2D $= Enabled
+      textureBinding Texture2D $= fontTex
+      translate (Vector3 x y (0::Float))
+      let lists = map (toDisplayList (128*(fromIntegral st))) string
+      alphaFunc $= Just (Greater,0.1:: Float)
+      mapM_ callList lists --(map DisplayList [17..(32:: GLuint)])
+      alphaFunc $= Nothing
+      texture Texture2D $= Disabled
+
+
+-- sets up the orthographic mode so we can
+-- draw at 2D screen coordinates
+setUpOrtho :: IO a -> IO()
+setUpOrtho func = do
+   matrixMode   $= Projection
+   unsafePreservingMatrix $ do
+     loadIdentity
+     ortho 0 640 0 480 (-1) 1
+     matrixMode $= Modelview 0
+     func
+     matrixMode $= Projection
+   matrixMode   $= Modelview 0
+
+-- just renders the crosshair
+renderCrosshair :: HashTable String (Maybe TextureObject) -> IO()
+renderCrosshair texs = do
+   Just  crosshairTex <- Data.HashTable.lookup texs "crosshair"
+   texture Texture2D $= Enabled
+   textureBinding Texture2D $= crosshairTex
+   unsafePreservingMatrix $ do
+      loadIdentity
+      translate (Vector3 304 224 (0::Float))
+      alphaFunc $= Just (Greater,0.1:: Float)
+      unsafeRenderPrimitive Quads $ do
+         texCoord (TexCoord2 0 (1 :: Float))
+         vertex   (Vertex2 0 (0 :: Float))
+         texCoord (TexCoord2 0 (0 :: Float))
+         vertex   (Vertex2 0 (32 :: Float))
+         texCoord (TexCoord2 1 (0 :: Float))
+         vertex   (Vertex2 32 (32 :: Float))
+         texCoord (TexCoord2 1 (1 :: Float))
+         vertex   (Vertex2 32 (0 :: Float))
+      alphaFunc $= Nothing
+   texture Texture2D $= Disabled
+
+toDisplayList ::  GLuint -> Char -> DisplayList
+toDisplayList _ c = DisplayList (fromIntegral (ord c) - 31)
+
+
+
+ src/Textures.hs view
@@ -0,0 +1,54 @@+{- Textures.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This module is for loading textures
+
+-}
+
+module Textures where
+
+import Graphics.UI.GLUT
+import TGA (readTga)
+import Data.Word (Word8)
+import Foreign.Marshal.Alloc (free)
+
+
+-- read a list of images and returns a list of textures
+-- all images are assumed to be in the TGA image format
+getAndCreateTextures :: [String] -> IO [Maybe TextureObject]
+getAndCreateTextures fileNames = do
+   fileNamesExts <- return (map (("tga/" ++) . (++ ".tga")) fileNames)
+   texData <- mapM readImageC fileNamesExts
+   texObjs <- mapM createTexture texData
+   return texObjs
+
+
+-- read a single texture
+getAndCreateTexture :: String -> IO (Maybe TextureObject)
+getAndCreateTexture fileName = do
+   texData <- readImageC ("tga/" ++ fileName ++ ".tga")
+   texObj <- createTexture texData
+   return texObj
+
+
+-- read the image data
+readImageC :: String -> IO (Maybe (Size, PixelData Word8))
+readImageC path = catch (readTga path) (\_ -> do print ("missing texture: "++path)
+                                                 return Nothing)
+
+
+-- creates the texture
+createTexture :: (Maybe (Size, PixelData a)) -> IO (Maybe TextureObject)
+createTexture (Just ((Size x y), pixels@(PixelData _ _ ptr))) = do
+   [texName] <- genObjectNames 1  -- generate our texture.
+   --rowAlignment  Unpack $= 1
+   textureBinding Texture2D $= Just texName  -- make our new texture the current texture.
+   --generateMipmap Texture2D $= Enabled
+   build2DMipmaps Texture2D RGBA' (fromIntegral x) (fromIntegral y) pixels
+   textureFilter  Texture2D $= ((Linear', Just Nearest), Linear')
+   --textureWrapMode Texture2D S $= (Repeated, Repeat)
+   --textureWrapMode Texture2D T $= (Repeated, Repeat)
+   textureFunction $= Modulate
+   free ptr
+   return (Just texName)
+createTexture Nothing = return Nothing
+
+ src/Visibility.hs view
@@ -0,0 +1,322 @@+{- Visibility.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+Visibility tests with BSP
+
+(A lot of the code is rewritten from the collision detection module)
+
+-}
+
+module Visibility where
+
+import Matrix (Vec3,
+               crossProd,
+               dotProd,
+               mapTup,
+               normalise,
+               vectorAdd,
+               vectorMult,
+               vectorSub)
+import BSP -- (bsPlaneNorm, bsPlaneDist, numOfBrushSides, textureType, brushside, BSPBrushSide(..), tree, planeNormal, dist, Tree(..))
+import Collision(CollisionType(..))
+
+
+epsilon :: Double
+epsilon = 0.03125
+
+getOffset :: CollisionType -> Vec3 -> Double
+getOffset (Box _ _ extents) plane = getBoxOffs extents plane
+getOffset (SphereT rad) _ = rad
+
+getBoxOffs :: Vec3 -> Vec3 -> Double
+getBoxOffs (x,y,z) (x1,y1,z1) =
+   (abs (x*x1))+(abs (y*y1))+(abs (z*z1))
+
+
+-------------------------------------------------------------------------------
+-- visibility tests
+
+aiVisTest :: BSPMap -> Vec3 -> Double -> Vec3 -> Int -> Bool
+aiVisTest bsp currentPos angle targetPos range =
+  case (fieldTest currentPos angle targetPos range) of
+     False -> False
+     _ -> rayTest bsp currentPos targetPos
+
+
+-- test if the objct lies wihitn the field of view
+fieldTest :: (Double,Double,Double) ->Double ->
+  (Double,Double,Double) -> Int -> Bool
+fieldTest  (x,y,z) angle (ox,oy,oz) range =
+  (distance < (realToFrac range)  &&
+  (horizangle <= 30) &&
+  (abs verticalangle) <= 60 ) || distance < 300
+  where
+    distance = sqrt (((x-ox)^(2 :: Int))+((y-oy)^(2 :: Int))+((z-oz)^(2 :: Int)))
+    horizanglei =
+       let ha=acos $ dotProd (normalise $ vectorSub (ox,0,oz) (x,0,z)) (1,0,0)
+       in case (oz > z) of
+          False -> (ha*180/pi)
+          True  -> (360 - (ha*180/pi))
+    horizangle =
+       min (abs (horizanglei - angle))  (abs (horizanglei - (angle + 360)))
+    verticalangle =
+       let va=acos $ dotProd (normalise $ vectorSub (ox,oy,oz) (x,y,z)) (0,1,0)
+       in ((va*180/pi)-90)
+
+
+-- fires rays to the target to determine visibility
+rayTest :: BSPMap ->  Vec3 -> Vec3 -> Bool
+rayTest bsp (x,y,z) vec2@(_,_,_) =
+  let
+   (x1,y1,z1) = normalise $ crossProd (vectorSub vec2 (x,y+30,z)) (0,1,0)
+   (x2,y2,z2) = normalise $ crossProd (vectorSub vec2 (x,y+30,z)) (x1,y1,z1)
+   v1 = vectorAdd vec2 (vectorMult (x1-x2,y1-y2,z1-z2) 45)
+   v2 = vectorAdd vec2 (vectorMult (x1+x2,y1+y2,z1+z2) 45)
+   v3 = vectorAdd vec2 (vectorMult (-x1-x2,-y1-y2,-z1-z2) 45)
+   in case (snd $ clipRay2 bsp vec2 (x,y,z) (0,0,0)) of
+       False -> True
+       _ -> case (snd $ clipRay2 bsp v1 (x,y+30,z) (0,0,0)) of
+              False -> True
+              _ -> case (snd $ clipRay2 bsp v2 (x,y+30,z)(0,0,0)) of
+                     False -> True
+                     _ -> case (snd $ clipRay2 bsp v3 (x,y+30,z)(0,0,0)) of
+                            False -> True
+                            _ ->case(snd $ clipRay2 bsp v3 (x,y+30,z)(0,0,0))of
+                                    False -> True
+                                    True -> False
+
+
+createSphere :: Double ->  CollisionType
+createSphere rad = SphereT rad
+
+
+clipRay2 :: BSPMap -> Vec3 -> Vec3 ->  Vec3 -> (Vec3, Bool)
+clipRay2 mp pos oldpos (_,_,_) =
+  let (colPos,collided,_,_) = traceo (createSphere 0) mp oldpos pos
+  in (colPos, collided)
+
+
+traceo ::  CollisionType -> BSPMap ->
+   Vec3 -> Vec3 -> (Vec3,Bool,Bool,Bool)
+traceo cType mp start end
+  | (newRatio /= 1.0) =
+        (vectorAdd start
+            (vectorMult (vectorSub end start) newRatio),hasCol,step,grounded)
+  | otherwise = (end,False,step,grounded)
+  where
+     (hasCol,step,grounded,newRatio,(_,_,_)) =
+         fixCheck $ (checkNode cType (False,False,False,1.0, (0.0,0.0,0.0))
+            (tree mp) 0.0 1.0 start end)
+     fixCheck x =
+        case x of
+          (Just a) ->  a
+          Nothing  -> (False,False,False,1.0, (0.0,0.0,0.0))
+
+
+{-
+drawTest :: BSPMap ->  Vec3 -> Vec3 ->IO()
+drawTest bsp vec1@(x,y,z) vec2@(ox,oy,oz) = do
+  let (x1,y1,z1) = normalise $ crossProd (vectorSub vec2 (x,y+30,z)) (0,1,0)
+  let (x2,y2,z2) = normalise $ crossProd (vectorSub vec2 (x,y+30,z)) (x1,y1,z1)
+  let (a1,b1,c1) = vectorAdd vec2 (vectorMult (x1-x2,y1-y2,z1-z2) 45)
+  let (a2,b2,c2) = vectorAdd vec2 (vectorMult (x1+x2,y1+y2,z1+z2) 45)
+  let (a3,b3,c3) = vectorAdd vec2 (vectorMult (-x1-x2,-y1-y2,-z1-z2) 45)
+  let (a4,b4,c4) = vectorAdd vec2 (vectorMult (-x1+x2,-y1+y2,-z1+z2) 45)
+  pointSize $= 13
+  unsafeRenderPrimitive Points $ do
+     vertex (Vertex3 a1 b1 c1)
+     vertex (Vertex3 a2 b2 c2)
+     vertex (Vertex3 a3 b3 c3)
+     vertex (Vertex3 a4 b4 c4)
+-}
+
+-------------------------------------------------------------------------------
+--  check for collisions with brushes
+
+
+checkBrushes:: CollisionType -> (Bool, Bool, Bool, Double,Vec3)  ->
+   Tree -> Vec3 -> Vec3 -> Maybe (Bool, Bool, Bool, Double, Vec3)
+checkBrushes cType _ (Leaf leaf) start end =
+   checkBrush start end cType (leafBrushes leaf)
+
+
+checkBrush :: Vec3-> Vec3 -> CollisionType ->
+   [BSPBrush] -> Maybe (Bool,Bool,Bool,Double,Vec3)
+checkBrush _ _ _ [] = Just (False,False,False,0,(0,0,0))
+checkBrush start end cType (brush:brushes) =
+     let res = checkBrush'  start end cType brush
+     in case (res) of
+         Just (True,_,_,_,_) -> res
+         _ -> checkBrush start end cType brushes
+
+
+checkBrush' :: Vec3-> Vec3 -> CollisionType ->
+   BSPBrush -> Maybe (Bool,Bool,Bool,Double,Vec3)
+checkBrush'  start end cType brush
+     |((numOfBrushSides brush) > 0) && ((textureType brush)==1) =
+       let colout =
+             checkBrushSides start end
+                cType False False False False (-1.0)
+                   (1.0) (0,0,0) (brushSides brush)
+       in case colout of
+          Just (out,collided,step,grounded,startR,endR,newNorm) ->
+              case (startR < endR && startR > -1  && out) of
+                 True -> Just (collided,step,grounded,fixRatio startR,newNorm)
+                 _    -> Nothing
+          _ -> Nothing
+     |otherwise = Nothing
+     where
+        fixRatio x
+           | x < 0.0 = 0.0
+           | otherwise = x
+
+
+checkBrushSides ::  Vec3 -> Vec3 -> CollisionType-> Bool -> Bool ->
+   Bool -> Bool -> Double -> Double -> Vec3 -> [BSPBrushSide] ->
+     (Maybe (Bool,Bool,Bool,Bool,Double,Double,Vec3))
+checkBrushSides  (_,_,_) (_,_,_) _
+  out collided step ground startR endR cNorm [] =
+     Just (out,collided,step,ground,startR,endR,cNorm)
+checkBrushSides  start@(x,_,z) end@(x1,_,z1) cType
+  out collided step ground startR endR cNorm (b:bs)
+     | startDist >  0 && endDist >  0 = Nothing
+     | startDist <= 0 && endDist <= 0 = continue
+     | startDist > endDist =
+           case (ratio1 > startR) of
+              True -> (checkBrushSides start end cType
+                          checkout True mayStep grounded
+                              ratio1 endR (bsPlaneNorm b) bs)
+              _    -> continue
+     | otherwise =
+           case (ratio2 < endR) of
+              True -> (checkBrushSides start end cType
+                          checkout collided step ground
+                              startR ratio2 cNorm bs)
+              _    -> continue
+     where
+        checkout
+            | startDist > 0 = True
+            | otherwise = out
+        mayStep
+            | ((x /= x1 || z /= z1) && planey /= 1) = True
+            | otherwise = step
+        grounded
+            | planey >= 0.2 = True
+            | otherwise = ground
+        planey = get2nd3 (bsPlaneNorm b)
+        ratio1     = (startDist - epsilon) / (startDist - endDist)
+        ratio2     = (startDist + epsilon) / (startDist - endDist)
+        continue  = checkBrushSides start end cType
+                       checkout collided step ground
+                           startR endR cNorm bs
+        startDist = vDist start cType (bsPlaneNorm b) (bsPlaneDist b)
+        endDist = vDist end cType  (bsPlaneNorm b) (bsPlaneDist b)
+        get2nd3 (_,a,_) = a
+
+
+vDist :: Vec3 -> CollisionType -> Vec3 -> Double  ->  Double
+vDist vec box@(Box _ _ _) pnorm pdist =
+   (dotProd (vectorAdd vec (getVOffs pnorm box)) pnorm) - pdist
+vDist vec (SphereT rad) pnorm pdist =
+   (dotProd vec pnorm) - (pdist + rad)
+
+
+getVOffs:: Vec3 -> CollisionType  -> Vec3
+getVOffs (p1,p2,p3) (Box (x,y,z) (x1,y1,z1) _) =
+   (chooseMin' p1 x x1,chooseMin' p2 y y1, chooseMin' p3 z z1)
+   where
+      chooseMin' p mn mx
+        | p < 0 = mx
+        | otherwise = mn
+
+
+
+
+-------------------------------------------------------------------------------
+
+
+-- recurse down a nodes
+checkNode :: CollisionType -> (Bool,Bool,Bool,Double,Vec3) ->
+   Tree -> Double-> Double -> Vec3 -> Vec3 -> Maybe (Bool,Bool,Bool,Double,Vec3)
+checkNode cType cState (Leaf leaf) _ _ start end =
+   checkBrushes cType cState (Leaf leaf)  start end
+checkNode cType cState (Branch node left right) startRatio endRatio start end =
+   let sDist = (dotProd (planeNormal node) start) - (dist node)
+       eDist = (dotProd (planeNormal node) end)   - (dist node)
+   in recurse sDist eDist
+   where
+      boffset = getOffset cType (planeNormal node)
+      recurse sDist eDist
+         | (sDist >= boffset && eDist >= boffset)             =
+            checkNode cType cState left  sDist eDist start end
+         | (sDist < ((-1)*boffset) && eDist < ((-1)*boffset)) =
+            checkNode cType cState right sDist eDist start end
+         | otherwise =
+            split cType cState sDist eDist
+               startRatio endRatio start end
+                  (Branch node left right)
+
+
+-- splits a vector if it lies on both side of
+-- the splitting plane
+split :: CollisionType -> (Bool,Bool,Bool,Double,Vec3) ->
+   Double -> Double -> Double -> Double -> Vec3 -> Vec3 ->
+      Tree -> Maybe (Bool,Bool,Bool,Double,Vec3)
+split cType cState startDist endDist startRatio
+   endRatio start end (Branch node left right)
+       |startDist < endDist =
+         let result1 = checkNode cType cState
+                          right startRatio (middleR r1) start (middleV r1)
+         in case (result1) of
+             Just (True,_,_,_,_) -> result1
+             _ -> let result2 =
+                        checkNode  cType cState left
+                         (middleR r2) endRatio (middleV r2) end
+                  in case (result2) of
+                       Just (True,_,_,_,_) -> result2
+                       _                   -> Nothing
+       |startDist > endDist =
+         let result1 = checkNode  cType cState
+                          left  startRatio (middleR r2) start (middleV r2)
+         in case (result1) of
+             Just (True,_,_,_,_) -> result1
+             _ -> let result2 =
+                        checkNode  cType cState right
+                         (middleR r1) endRatio   (middleV r1) end
+                  in case (result2) of
+                       Just (True,_,_,_,_) -> result2
+                       _                   -> Nothing
+       |otherwise =
+         let result1 = checkNode  cType cState
+                          left  startRatio (middleR 1.0) start (middleV 1.0)
+         in case (result1) of
+             Just (True,_,_,_,_) -> result1
+             _ -> let result2 =
+                        checkNode  cType cState right
+                         (middleR 0.0) endRatio   (middleV 0.0) end
+                  in case (result2) of
+                       Just (True,_,_,_,_) -> result2
+                       _                   -> Nothing
+       where
+          inverseDist = 1.0/(startDist - endDist)
+          boffset     = getOffset cType (planeNormal node)
+          r1          = fixDouble $ (startDist - boffset - epsilon)*inverseDist
+          r2          = fixDouble $ (startDist + boffset + epsilon)*inverseDist
+          middleR     = getMiddleRatio startRatio endRatio
+          middleV     = getHalfVec start end
+          fixDouble x
+             | x < 0.0 = 0.0
+             | x > 1.0 = 1.0
+             | otherwise = x
+
+
+-- gets the middle of 2 ratios
+getMiddleRatio :: Double -> Double -> Double -> Double
+getMiddleRatio startRatio endRatio ratio =
+       startRatio + (ratio * (endRatio - startRatio))
+
+
+-- gets half a vector
+getHalfVec :: Vec3 -> Vec3 -> Double -> Vec3
+getHalfVec start end ratio =
+       vectorAdd start (mapTup (ratio*) (vectorSub end start))
+
+ tga/0.tga view

binary file changed (absent → 4140 bytes)

+ tga/1.tga view

binary file changed (absent → 4140 bytes)

+ tga/2.tga view

binary file changed (absent → 4140 bytes)

+ tga/3.tga view

binary file changed (absent → 4140 bytes)

+ tga/4.tga view

binary file changed (absent → 4140 bytes)

+ tga/5.tga view

binary file changed (absent → 4140 bytes)

+ tga/6.tga view

binary file changed (absent → 4140 bytes)

+ tga/7.tga view

binary file changed (absent → 4140 bytes)

+ tga/8.tga view

binary file changed (absent → 4140 bytes)

+ tga/9.tga view

binary file changed (absent → 4140 bytes)

+ tga/crosshaira.tga view

binary file changed (absent → 4140 bytes)

+ tga/font.tga view

binary file changed (absent → 262188 bytes)

+ tga/hyphen.tga view

binary file changed (absent → 4140 bytes)

+ tga/models/players/klesk/animation.cfg view
@@ -0,0 +1,43 @@+// animation config file
+
+sex	n
+
+headoffset	0 0 0
+footsteps	boots
+
+// first frame, num frames, looping frames, frames per second
+
+0	30	0	30		// BOTH_DEATH1
+29	1	0	30		// BOTH_DEAD1
+30	30	0	30		// BOTH_DEATH2
+59	1	0	30		// BOTH_DEAD2
+60	25	0	17		// BOTH_DEATH3
+84	1	0	17		// BOTH_DEAD3
+
+85	40	0	20		// TORSO_GESTURE
+
+125	6	0	15		// TORSO_ATTACK		(MUST NOT CHANGE -- hand animation is synced to this)
+131	6	0	15		// TORSO_ATTACK2	(MUST NOT CHANGE -- hand animation is synced to this)
+
+137	5	0	20		// TORSO_DROP		(MUST NOT CHANGE -- hand animation is synced to this)
+142	4	0	20		// TORSO_RAISE		(MUST NOT CHANGE -- hand animation is synced to this)
+
+146	10	10	10		// TORSO_STAND
+157	5	5	5		// TORSO_STAND2
+
+162	12	12	17		// LEGS_WALKCR
+174	12	12	20		// LEGS_WALK
+186	10	10	16		// LEGS_RUN
+196	10	10	18		// LEGS_BACK
+206	8	8	15		// LEGS_SWIM
+
+214	8	0	16		// LEGS_JUMP
+223	1	0	10		// LEGS_LAND
+
+224	8	0	15		// LEGS_JUMPB
+232	1	0	15		// LEGS_LANDB
+
+233	10	10	10		// LEGS_IDLE
+243	11	11	10		// LEGS_IDLECR
+
+254	7	7	15		// LEGS_TURN
+ tga/models/players/klesk/h_red.tga view

binary file changed (absent → 98348 bytes)

+ tga/models/players/klesk/head.md3 view

binary file changed (absent → 4140 bytes)

+ tga/models/players/klesk/head_default.skin view
@@ -0,0 +1,2 @@+h_head,models/players/ironside/h_red.tga
+tag_head,
+ tga/models/players/klesk/l_red.tga view

binary file changed (absent → 196652 bytes)

+ tga/models/players/klesk/lower.md3 view

binary file changed (absent → 806404 bytes)

+ tga/models/players/klesk/lower_default.skin view
@@ -0,0 +1,2 @@+tag_torso,
+l_lower,models/players/ironside/l_red.tga
+ tga/models/players/klesk/u_red.tga view

binary file changed (absent → 196652 bytes)

+ tga/models/players/klesk/upper.md3 view

binary file changed (absent → 836876 bytes)

+ tga/models/players/klesk/upper_default.skin view
@@ -0,0 +1,6 @@+tag_weapon,
+tag_head,
+u_torso,models/players/ironside/u_red.tga
+u_rarm,models/players/ironside/u_red.tga
+u_larm,models/players/ironside/u_red.tga
+tag_torso,
+ tga/models/weapons/railgun.md3 view

binary file changed (absent → 11908 bytes)

+ tga/models/weapons/railgun.shader view
@@ -0,0 +1,4 @@+railgun.bmp
+railgun2.bmp
+railgun3.bmp
+railgun4.bmp
+ tga/textures/base_support/flat1_1.tga view

binary file changed (absent → 12306 bytes)

+ tga/textures/common/clip.tga view

binary file changed (absent → 3180 bytes)

+ tga/textures/common/trigger.tga view

binary file changed (absent → 3180 bytes)

+ tga/textures/e7/e7bmtrim.tga view

binary file changed (absent → 49170 bytes)

+ tga/textures/e7/e7brickfloor01.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/e7/e7bricks01.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/e7/e7panelwood.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/e7/e7panelwood2.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/e7/e7sbrickfloor.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/e7/e7swindow.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/evil8_floor/e8cretefloor01b.tga view

binary file changed (absent → 786450 bytes)

+ tga/textures/gothic_block/blocks11b.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/gothic_block/blocks15_blue.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/gothic_block/blocks18b.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/gothic_block/blocks18d.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/gothic_block/killblock.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/gothic_block/killblock_j2.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/gothic_floor/largerblock3b3.tga view

binary file changed (absent → 786450 bytes)

+ tga/textures/gothic_floor/largerblock3b3dim.tga view

binary file changed (absent → 786450 bytes)

+ tga/textures/gothic_floor/q1metal7_99.tga view

binary file changed (absent → 786450 bytes)

+ tga/textures/gothic_light/ironcrosslt2_10000.tga view

binary file changed (absent → 49170 bytes)

+ tga/textures/gothic_trim/border7.tga view

binary file changed (absent → 24594 bytes)

+ tga/textures/gothic_trim/km_arena1tower4.tga view

binary file changed (absent → 49170 bytes)

+ tga/textures/gothic_trim/metalsupport4i_bit.tga view

binary file changed (absent → 49170 bytes)

+ tga/textures/gothic_trim/pitted_rust3.tga view

binary file changed (absent → 786450 bytes)

+ tga/textures/gothic_trim/wood2.tga view

binary file changed (absent → 49170 bytes)

+ tga/textures/gothic_wall/oct20c.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/gothic_wall/proto_brik.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/gothic_wall/slateroofc.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/organics/dirt2.tga view

binary file changed (absent → 197147 bytes)

+ tga/textures/skies/nitesky.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/skin/pjwal2k.tga view

binary file changed (absent → 196626 bytes)

+ tga/textures/stone/pjrock6.tga view

binary file changed (absent → 196626 bytes)

+ tga/tga/models/weapons/railgun.tga view

binary file changed (absent → 196626 bytes)

+ tga/tga/models/weapons/railgun2.tga view

binary file changed (absent → 196626 bytes)

+ tga/tga/models/weapons/railgun3.tga view

binary file changed (absent → 98322 bytes)

+ tga/tga/models/weapons/railgun4.tga view

binary file changed (absent → 49170 bytes)