diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 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. + + , 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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 + + diff --git a/README-leveleg b/README-leveleg new file mode 100644 --- /dev/null +++ b/README-leveleg @@ -0,0 +1,26 @@ + +================================================================ + Monastery At Night + Level for Quake III Arena +================================================================ + + + +--- + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/frag.cabal b/frag.cabal new file mode 100644 --- /dev/null +++ b/frag.cabal @@ -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 diff --git a/leveleg.bsp b/leveleg.bsp new file mode 100644 # file too large to diff: leveleg.bsp diff --git a/leveleg.cfg b/leveleg.cfg new file mode 100644 --- /dev/null +++ b/leveleg.cfg @@ -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)}) diff --git a/leveleg.med b/leveleg.med new file mode 100644 --- /dev/null +++ b/leveleg.med @@ -0,0 +1,2 @@ +MMap "leveleg.bsp" +MPlayerModel "klesk" "railgun" diff --git a/src/AFRP.hs b/src/AFRP.hs new file mode 100644 --- /dev/null +++ b/src/AFRP.hs @@ -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 diff --git a/src/AFRPAffineSpace.hs b/src/AFRPAffineSpace.hs new file mode 100644 --- /dev/null +++ b/src/AFRPAffineSpace.hs @@ -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) diff --git a/src/AFRPDiagnostics.hs b/src/AFRPDiagnostics.hs new file mode 100644 --- /dev/null +++ b/src/AFRPDiagnostics.hs @@ -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) diff --git a/src/AFRPEvent.hs b/src/AFRPEvent.hs new file mode 100644 --- /dev/null +++ b/src/AFRPEvent.hs @@ -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 diff --git a/src/AFRPForceable.hs b/src/AFRPForceable.hs new file mode 100644 --- /dev/null +++ b/src/AFRPForceable.hs @@ -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 diff --git a/src/AFRPGeometry.hs b/src/AFRPGeometry.hs new file mode 100644 --- /dev/null +++ b/src/AFRPGeometry.hs @@ -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 + + diff --git a/src/AFRPInternals.hs b/src/AFRPInternals.hs new file mode 100644 --- /dev/null +++ b/src/AFRPInternals.hs @@ -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) + + diff --git a/src/AFRPMiscellany.hs b/src/AFRPMiscellany.hs new file mode 100644 --- /dev/null +++ b/src/AFRPMiscellany.hs @@ -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 diff --git a/src/AFRPPoint2.hs b/src/AFRPPoint2.hs new file mode 100644 --- /dev/null +++ b/src/AFRPPoint2.hs @@ -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 diff --git a/src/AFRPPoint3.hs b/src/AFRPPoint3.hs new file mode 100644 --- /dev/null +++ b/src/AFRPPoint3.hs @@ -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 diff --git a/src/AFRPTask.hs b/src/AFRPTask.hs new file mode 100644 --- /dev/null +++ b/src/AFRPTask.hs @@ -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??? diff --git a/src/AFRPUtilities.hs b/src/AFRPUtilities.hs new file mode 100644 --- /dev/null +++ b/src/AFRPUtilities.hs @@ -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 (^+^) diff --git a/src/AFRPVector2.hs b/src/AFRPVector2.hs new file mode 100644 --- /dev/null +++ b/src/AFRPVector2.hs @@ -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 diff --git a/src/AFRPVector3.hs b/src/AFRPVector3.hs new file mode 100644 --- /dev/null +++ b/src/AFRPVector3.hs @@ -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 diff --git a/src/AFRPVectorSpace.hs b/src/AFRPVectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/AFRPVectorSpace.hs @@ -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 + + + diff --git a/src/BSP.hs b/src/BSP.hs new file mode 100644 --- /dev/null +++ b/src/BSP.hs @@ -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)] + + diff --git a/src/BitSet.hs b/src/BitSet.hs new file mode 100644 --- /dev/null +++ b/src/BitSet.hs @@ -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 + diff --git a/src/Camera.hs b/src/Camera.hs new file mode 100644 --- /dev/null +++ b/src/Camera.hs @@ -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)} + + diff --git a/src/Collision.hs b/src/Collision.hs new file mode 100644 --- /dev/null +++ b/src/Collision.hs @@ -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)) + + diff --git a/src/Command.hs b/src/Command.hs new file mode 100644 --- /dev/null +++ b/src/Command.hs @@ -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. diff --git a/src/Curves.hs b/src/Curves.hs new file mode 100644 --- /dev/null +++ b/src/Curves.hs @@ -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 diff --git a/src/Diagnostics.hs b/src/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/Diagnostics.hs @@ -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) diff --git a/src/Frustum.hs b/src/Frustum.hs new file mode 100644 --- /dev/null +++ b/src/Frustum.hs @@ -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 + diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 --- /dev/null +++ b/src/Game.hs @@ -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) diff --git a/src/HGL.hs b/src/HGL.hs new file mode 100644 --- /dev/null +++ b/src/HGL.hs @@ -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 diff --git a/src/IdentityList.hs b/src/IdentityList.hs new file mode 100644 --- /dev/null +++ b/src/IdentityList.hs @@ -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] ] diff --git a/src/MD3.hs b/src/MD3.hs new file mode 100644 --- /dev/null +++ b/src/MD3.hs @@ -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)] + + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 ++ " " + 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 + + diff --git a/src/MapCfg.hs b/src/MapCfg.hs new file mode 100644 --- /dev/null +++ b/src/MapCfg.hs @@ -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 + + + diff --git a/src/Matrix.hs b/src/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Matrix.hs @@ -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 diff --git a/src/Object.hs b/src/Object.hs new file mode 100644 --- /dev/null +++ b/src/Object.hs @@ -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 + diff --git a/src/ObjectBehavior.hs b/src/ObjectBehavior.hs new file mode 100644 --- /dev/null +++ b/src/ObjectBehavior.hs @@ -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 diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -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 = [] diff --git a/src/PhysicalDimensions.hs b/src/PhysicalDimensions.hs new file mode 100644 --- /dev/null +++ b/src/PhysicalDimensions.hs @@ -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 diff --git a/src/Quaternion.hs b/src/Quaternion.hs new file mode 100644 --- /dev/null +++ b/src/Quaternion.hs @@ -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 + + + + diff --git a/src/Raybox.hs b/src/Raybox.hs new file mode 100644 --- /dev/null +++ b/src/Raybox.hs @@ -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 diff --git a/src/ReadImage.hs b/src/ReadImage.hs new file mode 100644 --- /dev/null +++ b/src/ReadImage.hs @@ -0,0 +1,68 @@ +{- + ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2004 + 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. diff --git a/src/Render.hs b/src/Render.hs new file mode 100644 --- /dev/null +++ b/src/Render.hs @@ -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 () diff --git a/src/RenderObject.hs b/src/RenderObject.hs new file mode 100644 --- /dev/null +++ b/src/RenderObject.hs @@ -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() + + + diff --git a/src/TGA.hs b/src/TGA.hs new file mode 100644 --- /dev/null +++ b/src/TGA.hs @@ -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 + + + + + + diff --git a/src/TextureFonts.hs b/src/TextureFonts.hs new file mode 100644 --- /dev/null +++ b/src/TextureFonts.hs @@ -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) + + + diff --git a/src/Textures.hs b/src/Textures.hs new file mode 100644 --- /dev/null +++ b/src/Textures.hs @@ -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 + diff --git a/src/Visibility.hs b/src/Visibility.hs new file mode 100644 --- /dev/null +++ b/src/Visibility.hs @@ -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)) + diff --git a/tga/0.tga b/tga/0.tga new file mode 100644 Binary files /dev/null and b/tga/0.tga differ diff --git a/tga/1.tga b/tga/1.tga new file mode 100644 Binary files /dev/null and b/tga/1.tga differ diff --git a/tga/2.tga b/tga/2.tga new file mode 100644 Binary files /dev/null and b/tga/2.tga differ diff --git a/tga/3.tga b/tga/3.tga new file mode 100644 Binary files /dev/null and b/tga/3.tga differ diff --git a/tga/4.tga b/tga/4.tga new file mode 100644 Binary files /dev/null and b/tga/4.tga differ diff --git a/tga/5.tga b/tga/5.tga new file mode 100644 Binary files /dev/null and b/tga/5.tga differ diff --git a/tga/6.tga b/tga/6.tga new file mode 100644 Binary files /dev/null and b/tga/6.tga differ diff --git a/tga/7.tga b/tga/7.tga new file mode 100644 Binary files /dev/null and b/tga/7.tga differ diff --git a/tga/8.tga b/tga/8.tga new file mode 100644 Binary files /dev/null and b/tga/8.tga differ diff --git a/tga/9.tga b/tga/9.tga new file mode 100644 Binary files /dev/null and b/tga/9.tga differ diff --git a/tga/crosshaira.tga b/tga/crosshaira.tga new file mode 100644 Binary files /dev/null and b/tga/crosshaira.tga differ diff --git a/tga/font.tga b/tga/font.tga new file mode 100644 Binary files /dev/null and b/tga/font.tga differ diff --git a/tga/hyphen.tga b/tga/hyphen.tga new file mode 100644 Binary files /dev/null and b/tga/hyphen.tga differ diff --git a/tga/models/players/klesk/animation.cfg b/tga/models/players/klesk/animation.cfg new file mode 100644 --- /dev/null +++ b/tga/models/players/klesk/animation.cfg @@ -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 diff --git a/tga/models/players/klesk/h_red.tga b/tga/models/players/klesk/h_red.tga new file mode 100644 Binary files /dev/null and b/tga/models/players/klesk/h_red.tga differ diff --git a/tga/models/players/klesk/head.md3 b/tga/models/players/klesk/head.md3 new file mode 100644 Binary files /dev/null and b/tga/models/players/klesk/head.md3 differ diff --git a/tga/models/players/klesk/head_default.skin b/tga/models/players/klesk/head_default.skin new file mode 100644 --- /dev/null +++ b/tga/models/players/klesk/head_default.skin @@ -0,0 +1,2 @@ +h_head,models/players/ironside/h_red.tga +tag_head, diff --git a/tga/models/players/klesk/l_red.tga b/tga/models/players/klesk/l_red.tga new file mode 100644 Binary files /dev/null and b/tga/models/players/klesk/l_red.tga differ diff --git a/tga/models/players/klesk/lower.md3 b/tga/models/players/klesk/lower.md3 new file mode 100644 Binary files /dev/null and b/tga/models/players/klesk/lower.md3 differ diff --git a/tga/models/players/klesk/lower_default.skin b/tga/models/players/klesk/lower_default.skin new file mode 100644 --- /dev/null +++ b/tga/models/players/klesk/lower_default.skin @@ -0,0 +1,2 @@ +tag_torso, +l_lower,models/players/ironside/l_red.tga diff --git a/tga/models/players/klesk/u_red.tga b/tga/models/players/klesk/u_red.tga new file mode 100644 Binary files /dev/null and b/tga/models/players/klesk/u_red.tga differ diff --git a/tga/models/players/klesk/upper.md3 b/tga/models/players/klesk/upper.md3 new file mode 100644 Binary files /dev/null and b/tga/models/players/klesk/upper.md3 differ diff --git a/tga/models/players/klesk/upper_default.skin b/tga/models/players/klesk/upper_default.skin new file mode 100644 --- /dev/null +++ b/tga/models/players/klesk/upper_default.skin @@ -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, diff --git a/tga/models/weapons/railgun.md3 b/tga/models/weapons/railgun.md3 new file mode 100644 Binary files /dev/null and b/tga/models/weapons/railgun.md3 differ diff --git a/tga/models/weapons/railgun.shader b/tga/models/weapons/railgun.shader new file mode 100644 --- /dev/null +++ b/tga/models/weapons/railgun.shader @@ -0,0 +1,4 @@ +railgun.bmp +railgun2.bmp +railgun3.bmp +railgun4.bmp diff --git a/tga/textures/base_support/flat1_1.tga b/tga/textures/base_support/flat1_1.tga new file mode 100644 Binary files /dev/null and b/tga/textures/base_support/flat1_1.tga differ diff --git a/tga/textures/common/clip.tga b/tga/textures/common/clip.tga new file mode 100644 Binary files /dev/null and b/tga/textures/common/clip.tga differ diff --git a/tga/textures/common/trigger.tga b/tga/textures/common/trigger.tga new file mode 100644 Binary files /dev/null and b/tga/textures/common/trigger.tga differ diff --git a/tga/textures/e7/e7bmtrim.tga b/tga/textures/e7/e7bmtrim.tga new file mode 100644 Binary files /dev/null and b/tga/textures/e7/e7bmtrim.tga differ diff --git a/tga/textures/e7/e7brickfloor01.tga b/tga/textures/e7/e7brickfloor01.tga new file mode 100644 Binary files /dev/null and b/tga/textures/e7/e7brickfloor01.tga differ diff --git a/tga/textures/e7/e7bricks01.tga b/tga/textures/e7/e7bricks01.tga new file mode 100644 Binary files /dev/null and b/tga/textures/e7/e7bricks01.tga differ diff --git a/tga/textures/e7/e7panelwood.tga b/tga/textures/e7/e7panelwood.tga new file mode 100644 Binary files /dev/null and b/tga/textures/e7/e7panelwood.tga differ diff --git a/tga/textures/e7/e7panelwood2.tga b/tga/textures/e7/e7panelwood2.tga new file mode 100644 Binary files /dev/null and b/tga/textures/e7/e7panelwood2.tga differ diff --git a/tga/textures/e7/e7sbrickfloor.tga b/tga/textures/e7/e7sbrickfloor.tga new file mode 100644 Binary files /dev/null and b/tga/textures/e7/e7sbrickfloor.tga differ diff --git a/tga/textures/e7/e7swindow.tga b/tga/textures/e7/e7swindow.tga new file mode 100644 Binary files /dev/null and b/tga/textures/e7/e7swindow.tga differ diff --git a/tga/textures/evil8_floor/e8cretefloor01b.tga b/tga/textures/evil8_floor/e8cretefloor01b.tga new file mode 100644 Binary files /dev/null and b/tga/textures/evil8_floor/e8cretefloor01b.tga differ diff --git a/tga/textures/gothic_block/blocks11b.tga b/tga/textures/gothic_block/blocks11b.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_block/blocks11b.tga differ diff --git a/tga/textures/gothic_block/blocks15_blue.tga b/tga/textures/gothic_block/blocks15_blue.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_block/blocks15_blue.tga differ diff --git a/tga/textures/gothic_block/blocks18b.tga b/tga/textures/gothic_block/blocks18b.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_block/blocks18b.tga differ diff --git a/tga/textures/gothic_block/blocks18d.tga b/tga/textures/gothic_block/blocks18d.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_block/blocks18d.tga differ diff --git a/tga/textures/gothic_block/killblock.tga b/tga/textures/gothic_block/killblock.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_block/killblock.tga differ diff --git a/tga/textures/gothic_block/killblock_j2.tga b/tga/textures/gothic_block/killblock_j2.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_block/killblock_j2.tga differ diff --git a/tga/textures/gothic_floor/largerblock3b3.tga b/tga/textures/gothic_floor/largerblock3b3.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_floor/largerblock3b3.tga differ diff --git a/tga/textures/gothic_floor/largerblock3b3dim.tga b/tga/textures/gothic_floor/largerblock3b3dim.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_floor/largerblock3b3dim.tga differ diff --git a/tga/textures/gothic_floor/q1metal7_99.tga b/tga/textures/gothic_floor/q1metal7_99.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_floor/q1metal7_99.tga differ diff --git a/tga/textures/gothic_light/ironcrosslt2_10000.tga b/tga/textures/gothic_light/ironcrosslt2_10000.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_light/ironcrosslt2_10000.tga differ diff --git a/tga/textures/gothic_trim/border7.tga b/tga/textures/gothic_trim/border7.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_trim/border7.tga differ diff --git a/tga/textures/gothic_trim/km_arena1tower4.tga b/tga/textures/gothic_trim/km_arena1tower4.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_trim/km_arena1tower4.tga differ diff --git a/tga/textures/gothic_trim/metalsupport4i_bit.tga b/tga/textures/gothic_trim/metalsupport4i_bit.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_trim/metalsupport4i_bit.tga differ diff --git a/tga/textures/gothic_trim/pitted_rust3.tga b/tga/textures/gothic_trim/pitted_rust3.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_trim/pitted_rust3.tga differ diff --git a/tga/textures/gothic_trim/wood2.tga b/tga/textures/gothic_trim/wood2.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_trim/wood2.tga differ diff --git a/tga/textures/gothic_wall/oct20c.tga b/tga/textures/gothic_wall/oct20c.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_wall/oct20c.tga differ diff --git a/tga/textures/gothic_wall/proto_brik.tga b/tga/textures/gothic_wall/proto_brik.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_wall/proto_brik.tga differ diff --git a/tga/textures/gothic_wall/slateroofc.tga b/tga/textures/gothic_wall/slateroofc.tga new file mode 100644 Binary files /dev/null and b/tga/textures/gothic_wall/slateroofc.tga differ diff --git a/tga/textures/organics/dirt2.tga b/tga/textures/organics/dirt2.tga new file mode 100644 Binary files /dev/null and b/tga/textures/organics/dirt2.tga differ diff --git a/tga/textures/skies/nitesky.tga b/tga/textures/skies/nitesky.tga new file mode 100644 Binary files /dev/null and b/tga/textures/skies/nitesky.tga differ diff --git a/tga/textures/skin/pjwal2k.tga b/tga/textures/skin/pjwal2k.tga new file mode 100644 Binary files /dev/null and b/tga/textures/skin/pjwal2k.tga differ diff --git a/tga/textures/stone/pjrock6.tga b/tga/textures/stone/pjrock6.tga new file mode 100644 Binary files /dev/null and b/tga/textures/stone/pjrock6.tga differ diff --git a/tga/tga/models/weapons/railgun.tga b/tga/tga/models/weapons/railgun.tga new file mode 100644 Binary files /dev/null and b/tga/tga/models/weapons/railgun.tga differ diff --git a/tga/tga/models/weapons/railgun2.tga b/tga/tga/models/weapons/railgun2.tga new file mode 100644 Binary files /dev/null and b/tga/tga/models/weapons/railgun2.tga differ diff --git a/tga/tga/models/weapons/railgun3.tga b/tga/tga/models/weapons/railgun3.tga new file mode 100644 Binary files /dev/null and b/tga/tga/models/weapons/railgun3.tga differ diff --git a/tga/tga/models/weapons/railgun4.tga b/tga/tga/models/weapons/railgun4.tga new file mode 100644 Binary files /dev/null and b/tga/tga/models/weapons/railgun4.tga differ