├── .gitignore ├── Crocodile.cabal ├── Gallery ├── path-tracer-bugs-22-9-2011.jpg ├── path-tracer-bugs-23-9-2011.jpg ├── path-tracer-bugs-24-9-2011.jpg ├── photon-map-14-9-2011.jpg ├── photon-map-16-9-2011.jpg ├── photon-map-wip-1-6-2011.jpg ├── photon-map-wip-14-5-2011.jpg └── photon-map-wip-20-5-2011.jpg ├── LICENSE ├── README ├── Setup.hs ├── app └── src │ ├── BoundingBox.hs │ ├── Camera.hs │ ├── Colour.hs │ ├── CornellBox.hs │ ├── Distribution.hs │ ├── IrradianceCache.hs │ ├── KDTree.hs │ ├── Light.hs │ ├── Light.hs-boot │ ├── Main.hs │ ├── Material.hs │ ├── Matrix.hs │ ├── Misc.hs │ ├── Octree.hs │ ├── PhotonMap.hs │ ├── PhotonMap.hs-boot │ ├── PolymorphicNum.hs │ ├── Primitive.hs │ ├── Primitive.hs-boot │ ├── Ray.hs │ ├── RayTrace.hs │ ├── RayTrace.hs-boot │ ├── RenderContext.hs │ ├── RenderContext.hs-boot │ ├── RussianRoulette.hs │ ├── SceneGraph.hs │ ├── Shader.hs │ ├── ShadowCache.hs │ ├── ShadowCache.hs-boot │ ├── SparseVoxelOctree.hs │ ├── SparseVoxelOctree.hs-boot │ ├── TestScenes.hs │ ├── Tests │ ├── BoundingBoxTest.hs │ ├── ColourTest.hs │ ├── OctreeTest.hs │ ├── PrimitiveTest.hs │ ├── RandomUVTest │ │ └── RandomUVTest.hs │ ├── UnitTests.hs │ └── VectorTest.hs │ ├── ToneMap.hs │ ├── Vector.hs │ ├── scripts │ ├── build │ ├── build-caf-debug │ ├── build-profile │ ├── build-single-hs-file │ ├── clean │ ├── run-hlint │ └── unit_test │ └── temp.txt └── dist └── setup-config /.gitignore: -------------------------------------------------------------------------------- 1 | app/src/Tests/HemisphereTest 2 | app/src/Tests/RandomUVTest/RandomUVTest 3 | *.hi 4 | *.o-boot 5 | *.hi-boot 6 | *.o 7 | *.bmp 8 | *.prof 9 | *.hp 10 | *.DS_store 11 | *.lkshw 12 | .gitignore 13 | *.ps 14 | *.aux 15 | *.hcr 16 | *.s 17 | crocodile 18 | dist/* 19 | dist/setup-config 20 | hlint-output.txt 21 | *~ 22 | #* 23 | *.jpg 24 | -------------------------------------------------------------------------------- /Crocodile.cabal: -------------------------------------------------------------------------------- 1 | 2 | -- Crocodile.cabal auto-generated by cabal init. For additional 3 | -- options, see 4 | -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. 5 | -- The name of the package. 6 | Name: crocodile 7 | 8 | -- The package version. See the Haskell package versioning policy 9 | -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for 10 | -- standards guiding when and how versions should be incremented. 11 | Version: 0.1.3 12 | 13 | stability: Experimental 14 | 15 | -- A short (one-line) description of the package. 16 | Synopsis: An offline renderer supporting ray tracing and photon mapping 17 | 18 | -- A longer description of the package. 19 | Description: This is an offline renderer written purely in Haskell, supporting ray tracing, path tracing and photon mapping with an irradiance cache 20 | 21 | -- URL for the project homepage or repository. 22 | Homepage: https://github.com/TomHammersley/HaskellRenderer/ 23 | 24 | -- The license under which the package is released. 25 | License: GPL-2 26 | 27 | -- The file containing the license text. 28 | License-file: LICENSE 29 | 30 | -- The package author(s). 31 | Author: Tom Hammersley 32 | 33 | -- An email address to which users can send suggestions, bug reports, 34 | -- and patches. 35 | Maintainer: tomhammersley@gmail.com 36 | 37 | -- A copyright notice. 38 | -- Copyright: 39 | 40 | Category: Graphics 41 | 42 | Build-type: Simple 43 | 44 | -- Extra files to be distributed with the package, such as examples or 45 | -- a README. 46 | Extra-source-files: README LICENSE Setup.hs app/src/*.hs app/src/*.hs-boot app/src/Tests/*.hs app/src/scripts/build app/src/scripts/clean app/src/scripts/run-hlint app/src/scripts/unit_test 47 | 48 | -- Constraint on the version of Cabal needed to build this package. 49 | Cabal-version: >=1.6 50 | 51 | Executable crocodile 52 | -- Packages needed in order to build this package. 53 | Build-depends: base >= 4 && < 5, HUnit, heap, bmp, mtl, mersenne-random-pure64, ghc-prim, parallel, bytestring, deepseq 54 | 55 | -- .hs or .lhs file containing the Main module. 56 | Main-is: Main.hs 57 | 58 | Hs-Source-Dirs: app/src 59 | 60 | ghc-options: -O2 -fexcess-precision -funbox-strict-fields -threaded -rtsopts -fwarn-missing-signatures -Wall -O2 -fspec-constr -fliberate-case -fstatic-argument-transformation -fspec-constr-count=10 61 | 62 | source-repository head 63 | type: git 64 | location: git://github.com/TomHammersey/HaskellRenderer.git 65 | -------------------------------------------------------------------------------- /Gallery/path-tracer-bugs-22-9-2011.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TomHammersley/HaskellRenderer/7ff7ff6c6cd6aa4b492e6cc904f98882fae4cd1b/Gallery/path-tracer-bugs-22-9-2011.jpg -------------------------------------------------------------------------------- /Gallery/path-tracer-bugs-23-9-2011.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TomHammersley/HaskellRenderer/7ff7ff6c6cd6aa4b492e6cc904f98882fae4cd1b/Gallery/path-tracer-bugs-23-9-2011.jpg -------------------------------------------------------------------------------- /Gallery/path-tracer-bugs-24-9-2011.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TomHammersley/HaskellRenderer/7ff7ff6c6cd6aa4b492e6cc904f98882fae4cd1b/Gallery/path-tracer-bugs-24-9-2011.jpg -------------------------------------------------------------------------------- /Gallery/photon-map-14-9-2011.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TomHammersley/HaskellRenderer/7ff7ff6c6cd6aa4b492e6cc904f98882fae4cd1b/Gallery/photon-map-14-9-2011.jpg -------------------------------------------------------------------------------- /Gallery/photon-map-16-9-2011.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TomHammersley/HaskellRenderer/7ff7ff6c6cd6aa4b492e6cc904f98882fae4cd1b/Gallery/photon-map-16-9-2011.jpg -------------------------------------------------------------------------------- /Gallery/photon-map-wip-1-6-2011.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TomHammersley/HaskellRenderer/7ff7ff6c6cd6aa4b492e6cc904f98882fae4cd1b/Gallery/photon-map-wip-1-6-2011.jpg -------------------------------------------------------------------------------- /Gallery/photon-map-wip-14-5-2011.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TomHammersley/HaskellRenderer/7ff7ff6c6cd6aa4b492e6cc904f98882fae4cd1b/Gallery/photon-map-wip-14-5-2011.jpg -------------------------------------------------------------------------------- /Gallery/photon-map-wip-20-5-2011.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TomHammersley/HaskellRenderer/7ff7ff6c6cd6aa4b492e6cc904f98882fae4cd1b/Gallery/photon-map-wip-20-5-2011.jpg -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | , 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Haskell Ray Tracer and Photon Mapper v0.0 2 | ----------------------------------------- 3 | 4 | This is a parallel ray tracer and partially parallel photon mapper written in Haskell. 5 | 6 | Features: 7 | 8 | Fully recursive raytracer with reflection and refraction 9 | * Sphere primitive 10 | * Plane primitive 11 | * Triangle mesh primitive 12 | * Parallelised ray tracing 13 | * Distributed ray tracing giving depth of field and anti-aliasing 14 | * Photon mapping 15 | * Irradiance caching 16 | * Gamma correction 17 | * Tone mapping 18 | * Path tracing (work-in-progress, as a reference renderer) 19 | 20 | Disclaimer 21 | ---------- 22 | 23 | I am a novice Haskell programmer. This code is not intended to be representative of best-practice Haskell programming. 24 | 25 | If you see code that could be improved in terms of style, correctness, clarity, flexibility or efficiency, please, let me know! I'm eager to learn and I'd love to hear the opinion of those far more capable than me. 26 | 27 | Why call it "crocodile"? 28 | ------------------------ 29 | 30 | My two-year old son currently has quite a penchant for crocodiles. 31 | 32 | Usage 33 | ----- 34 | 35 | Currently there is a default hard-coded scene of the Cornell Box. I build the program with: 36 | 37 | scripts/build 38 | 39 | and execute it with: 40 | 41 | time ./crocodile -p -i +RTS -N -RTS 42 | 43 | Cabal also works, of course 44 | 45 | This will output a file called test.bmp containing the resulting image. Depending on the number of photons emitted, the photon gathering radius and the maximum number of photons gathered, this could take quite some time. You can tune the parameters in Main.hs. 46 | 47 | Options 48 | ------- 49 | 50 | -i outputs intermediate renderings for fast debug feedback (recommended) 51 | -p enables the photon mapping pass 52 | -v directly visualises the photon map 53 | -c enable the irradiance cache 54 | -P invokes the path tracer codepath 55 | -d enable ray distribution for depth of field and anti-aliasing 56 | 57 | Bugs 58 | ---- 59 | 60 | The Photon Mapping is largely functional though it currently has some minor artefacts. Work is ongoing to fix them. 61 | There are numerous TODO issues noted in the code. 62 | 63 | Future planned work 64 | ------------------- 65 | 66 | * Gradients for the irradiance cache 67 | * Parsing of scene data files 68 | * Optimisation! Particularly of photon mapping 69 | * Parallelisation of photon gathering 70 | * Extended shader model 71 | * Alternative GI code paths - e.g. path tracing 72 | * Caustic photon mapping 73 | 74 | Tom Hammersley 12/5/2011 75 | tomhammersley@gmail.com 76 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/src/BoundingBox.hs: -------------------------------------------------------------------------------- 1 | -- Bounding box code 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | module BoundingBox where 5 | 6 | import PolymorphicNum 7 | import Vector 8 | import Ray 9 | 10 | type AABB = (Vector, Vector) 11 | 12 | boundingBoxTangentSpace :: AABB -> Position -> TangentSpace 13 | boundingBoxTangentSpace (boxMin, boxMax) p 14 | | dx > dy && dx > dz = (Vector 0 sx 0 0, Vector 0 0 sx 0, Vector sx 0 0 0) 15 | | dy > dx && dy > dz = (Vector sy 0 0 0, Vector 0 0 sy 0, Vector 0 sy 0 0) 16 | | otherwise = (Vector sz 0 0 0, Vector 0 sz 0 0, Vector 0 0 sz 0) 17 | where 18 | centre = (boxMin <+> boxMax) <*> (0.5 :: Double) 19 | delta = normalise (p <-> centre) 20 | dx = (abs . vecX) delta 21 | dy = (abs . vecY) delta 22 | dz = (abs . vecZ) delta 23 | sx = (signum . vecX) delta 24 | sy = (signum . vecY) delta 25 | sz = (signum . vecZ) delta 26 | 27 | boundingBoxRadius :: AABB -> Double 28 | boundingBoxRadius (boxMin, boxMax) = boxMin `distance` boxMax 29 | 30 | boundingBoxCentre :: AABB -> Position 31 | boundingBoxCentre (boxMin, boxMax) = (boxMin <+> boxMax) <*> (0.5 :: Double) 32 | 33 | boundingBoxUnion :: AABB -> AABB -> AABB 34 | boundingBoxUnion (min1, max1) (min2, max2) = (Vector.min min1 min2, Vector.max max1 max2) 35 | 36 | boundingBoxValid :: AABB -> Bool 37 | boundingBoxValid (boxMin, boxMax) = vecX boxMin <= vecX boxMax && 38 | vecY boxMin <= vecY boxMax && 39 | vecZ boxMin <= vecZ boxMax 40 | 41 | boundingBoxOverlaps :: AABB -> AABB -> Bool 42 | boundingBoxOverlaps box1 box2 = overlaps box1 box2 || overlaps box2 box1 43 | where 44 | overlaps (min1, max1) (min2, max2) = vecX min1 <= vecX max2 && (vecX max1 >= vecX min2) && 45 | vecY min1 <= vecY max2 && (vecY max1 >= vecY min2) && 46 | vecZ min1 <= vecZ max2 && (vecZ max1 >= vecZ min2) 47 | 48 | -- Enlarge a bounding box to include a point 49 | boundingBoxEnlarge :: Position -> AABB -> AABB 50 | boundingBoxEnlarge pos(boxMin, boxMax) = (Vector.min boxMin pos, Vector.max boxMax pos) 51 | 52 | -- Linearly scale a box 53 | boundingBoxScale :: AABB -> Double -> AABB 54 | boundingBoxScale (boxMin, boxMax) k = (setWTo1 $ boxMin <*> k, setWTo1 $ boxMax <*> k) 55 | 56 | -- Give a bounding box a buffer of a certain distance all the way around 57 | boundingBoxGrow :: AABB -> Double -> AABB 58 | boundingBoxGrow (Vector x1 y1 z1 _, Vector x2 y2 z2 _) k = (Vector (x1 - k) (y1 - k) (z1 - k) 1, Vector (x2 + k) (y2 + k) (z2 + k) 1) 59 | 60 | -- This is a dummy box that is used initially. If anything is intersected with it, it becomes valid. Else it is an invalid box that can be tested for 61 | initialInvalidBox :: AABB 62 | initialInvalidBox = (Vector bigNumber bigNumber bigNumber 1, Vector smallNumber smallNumber smallNumber 1) 63 | where 64 | bigNumber = 10000000 65 | smallNumber = -10000000 66 | 67 | -- These functions are useful for finding the greatest or smallest part of a box relative to a normal 68 | boundingBoxMinComponent :: (Vector -> Double) -> Vector -> AABB -> Double 69 | boundingBoxMinComponent f norm (boxMin, boxMax) = if f norm > 0 then f boxMin else f boxMax 70 | 71 | boundingBoxMaxComponent :: (Vector -> Double) -> Vector -> AABB -> Double 72 | boundingBoxMaxComponent f norm (boxMin, boxMax) = if f norm > 0 then f boxMax else f boxMin 73 | 74 | -- Does a box contain a point? 75 | contains :: AABB -> Position -> Bool 76 | {-# SPECIALIZE INLINE contains :: AABB -> Position -> Bool #-} 77 | contains (Vector !minX !minY !minZ _, Vector !maxX !maxY !maxZ _) (Vector !x !y !z _) = 78 | x >= minX && x <= maxX && 79 | y >= minY && y <= maxY && 80 | z >= minZ && z <= maxZ 81 | 82 | -- Does a sphere (conservatively) overlap with a bounding box? (Arvo's method) 83 | overlapsSphere :: AABB -> Position -> Double -> Bool 84 | overlapsSphere (boxMin, boxMax) p r = sum [closestDistance vecX, closestDistance vecY, closestDistance vecZ] < (r * r) 85 | where 86 | closestDistance f | f p < f boxMin = (f p - f boxMin) ** (2.0 :: Double) 87 | | f p > f boxMax = (f p - f boxMax) ** (2.0 :: Double) 88 | | otherwise = 0 89 | 90 | boundingBoxIntersectRay :: AABB -> Ray -> Maybe (Double, Double) 91 | boundingBoxIntersectRay (bounds0, bounds1) (Ray rayOrg _ invRayDir rayLen) 92 | | tmax < tmin = Nothing 93 | | tmin > 0 && tmin < rayLen = Just (tmin, tmax `Prelude.min` rayLen) 94 | | tmax > 0 && tmax < rayLen = Just (tmax, tmax) 95 | | otherwise = Nothing 96 | where 97 | (tmin, tmax) = foldr1 (\(a0, b0) (a1, b1) -> (a0 `Prelude.max` a1, b0 `Prelude.min` b1)) (map intercepts [vecX, vecY, vecZ]) 98 | 99 | intercepts f = let x0 = (f bounds0 - f rayOrg) * f invRayDir 100 | x1 = (f bounds1 - f rayOrg) * f invRayDir 101 | in (x0 `Prelude.min` x1, x0 `Prelude.max` x1) 102 | 103 | boundingBoxVertices :: AABB -> [Position] 104 | boundingBoxVertices (Vector x0 y0 z0 _, Vector x1 y1 z1 _) = 105 | [ 106 | Vector x0 y0 z0 1, 107 | Vector x1 y0 z0 1, 108 | Vector x0 y1 z0 1, 109 | Vector x1 y1 z0 1, 110 | Vector x0 y0 z1 1, 111 | Vector x1 y0 z1 1, 112 | Vector x0 y1 z1 1, 113 | Vector x1 y1 z1 1 114 | ] 115 | -------------------------------------------------------------------------------- /app/src/Camera.hs: -------------------------------------------------------------------------------- 1 | -- Camera module 2 | 3 | module Camera where 4 | 5 | import PolymorphicNum 6 | import Vector 7 | import Matrix 8 | 9 | data Camera = Camera { worldToCamera :: Matrix, fieldOfView :: !Double, position :: Vector, farClip :: !Double } deriving (Show) 10 | 11 | lookAt :: Position -> Position -> Direction -> Double -> Double -> Camera 12 | lookAt pos target up fov = 13 | Camera matrix fov pos 14 | where 15 | forward = normalise $ target <-> pos 16 | right = normalise $ up `cross` forward 17 | up' = right `cross` forward 18 | matrix = buildMatrix right up' forward pos 19 | 20 | withVectors :: Position -> Direction -> Direction -> Direction -> Double -> Double -> Camera 21 | withVectors pos basisX basisY basisZ fov = Camera matrix fov pos 22 | where 23 | matrix = buildMatrix basisX basisY basisZ (Vector.negate pos) 24 | -------------------------------------------------------------------------------- /app/src/Colour.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Colour where 5 | import Vector hiding (min, max) 6 | import Misc 7 | import Data.Word 8 | import Control.DeepSeq 9 | import PolymorphicNum 10 | import Data.List 11 | 12 | -- Normalised RGBA colour 13 | data Colour = Colour { red :: {-# UNPACK #-} !Double, 14 | green :: {-# UNPACK #-} !Double, 15 | blue :: {-# UNPACK #-} !Double, 16 | alpha :: {-# UNPACK #-} !Double } deriving (Show, Read, Ord, Eq) 17 | 18 | instance NFData Colour where 19 | rnf (Colour r g b a) = rnf r `seq` rnf g `seq` rnf b `seq` rnf a 20 | 21 | instance PolymorphicNum Colour Colour Colour where 22 | (Colour !r !g !b !a) <*> (Colour !r' !g' !b' !a') = Colour (r * r') (g * g') (b * b') (a * a') 23 | (Colour !r !g !b !a) (Colour !r' !g' !b' !a') = Colour (r / r') (g / g') (b / b') (a / a') 24 | (Colour !r !g !b !a) <-> (Colour !r' !g' !b' !a') = Colour (r - r') (g - g') (b - b') (a - a') 25 | (Colour !r !g !b !a) <+> (Colour !r' !g' !b' !a') = Colour (r + r') (g + g') (b + b') (a + a') 26 | 27 | instance PolymorphicNum Colour Double Colour where 28 | (Colour !r !g !b !a) <*> k = Colour (r * k) (g * k) (b * k) (a * k) 29 | (Colour !r !g !b !a) k = Colour (r / k) (g / k) (b / k) (a / k) 30 | (Colour !r !g !b !a) <-> k = Colour (r - k) (g - k) (b - k) (a - k) 31 | (Colour !r !g !b !a) <+> k = Colour (r + k) (g + k) (b + k) (a + k) 32 | 33 | instance PolymorphicNum Double Colour Colour where 34 | k <*> (Colour !r !g !b !a) = Colour (k * r) (k * g) (k * b) (k * a) 35 | k (Colour !r !g !b !a) = Colour (k / r) (k / g) (k / b) (k / a) 36 | k <-> (Colour !r !g !b !a) = Colour (k - r) (k - g) (k - b) (k - a) 37 | k <+> (Colour !r !g !b !a) = Colour (k + r) (k + g) (k + b) (k + a) 38 | 39 | clamp :: Colour -> Colour 40 | clamp (Colour !r !g !b !a) = Colour (max 0 (min r 1)) (max 0 (min g 1)) (max 0 (min b 1)) (max 0 (min a 1)) 41 | 42 | fold :: (Double -> Double -> Double) -> Colour -> Double -> Colour 43 | fold f (Colour !r !g !b !a) k = Colour (f r k) (f g k) (f b k) (f a k) 44 | 45 | -- Basic colours 46 | colRed :: Colour 47 | colRed = Colour 1 0 0 1 48 | 49 | colGreen :: Colour 50 | colGreen = Colour 0 1 0 1 51 | 52 | colBlue :: Colour 53 | colBlue = Colour 0 0 1 1 54 | 55 | colWhite :: Colour 56 | colWhite = Colour 1 1 1 1 57 | 58 | colBlack :: Colour 59 | colBlack = Colour 0 0 0 1 60 | 61 | colZero :: Colour 62 | colZero = Colour 0 0 0 0 63 | 64 | colGrey :: Colour 65 | colGrey = Colour 0.5 0.5 0.5 1 66 | 67 | colYellow :: Colour 68 | colYellow = Colour 1 1 0 1 69 | 70 | gamma :: Double 71 | gamma = 2.2 72 | 73 | invGamma :: Double 74 | invGamma = 1.0 / gamma 75 | 76 | -- Gamma correct a colour 77 | gammaCorrect :: Colour -> Colour 78 | gammaCorrect (Colour !r !g !b !a) = Colour (r ** gamma) (g ** gamma) (b ** gamma) (a ** gamma) 79 | 80 | invGammaCorrect ::Colour -> Colour 81 | invGammaCorrect (Colour !r !g !b !a) = Colour (r ** invGamma) (g ** invGamma) (b ** invGamma) (a ** invGamma) 82 | 83 | -- Colour encode a normal 84 | encodeNormal :: Vector -> Colour 85 | encodeNormal (Vector !x !y !z _) = gammaCorrect $ Colour (saturate $ x * 0.5 + 0.5) (saturate $ y * 0.5 + 0.5) (saturate $ z * 0.5 + 0.5) 1 86 | 87 | -- Convert a list of colours to a list of Word8s 88 | convertColoursToPixels :: [Colour] -> [Word8] 89 | convertColoursToPixels (col:cols) = r : g : b : 255 : convertColoursToPixels cols 90 | where 91 | r = truncate (red col * 255.0) 92 | g = truncate (green col * 255.0) 93 | b = truncate (blue col * 255.0) 94 | convertColoursToPixels [] = [] 95 | 96 | -- Measure overall magnitude of a colour 97 | magnitude :: Colour -> Double 98 | magnitude (Colour r g b _) = r * 0.3 + g * 0.6 + b * 0.1 99 | 100 | -- Convert to a list 101 | toListRGBA :: Colour -> [Double] 102 | toListRGBA (Colour r g b a) = [r, g, b, a] 103 | 104 | toListRGB :: Colour -> [Double] 105 | toListRGB (Colour r g b _) = [r, g, b] 106 | 107 | luminance :: Colour -> Double 108 | luminance (Colour !r !g !b _) = r * 0.3 + g * 0.6 + b * 0.1 109 | 110 | logLuminance :: Colour -> Double 111 | logLuminance = log . max 1e-5 . luminance 112 | 113 | -- Average together a list of colours 114 | averageColour :: [Colour] -> Colour 115 | averageColour xs = foldl' (\x y -> x <*> weight <+> y) colBlack xs 116 | where 117 | weight = (1 :: Double) / fromIntegral (length xs) 118 | 119 | maxChannel :: Colour -> Double 120 | maxChannel (Colour r g b _) = r `max` g `max` b 121 | -------------------------------------------------------------------------------- /app/src/CornellBox.hs: -------------------------------------------------------------------------------- 1 | -- Cornell box reference data 2 | 3 | module CornellBox(cornellBox, cornellBoxCamera, cornellBoxLights) where 4 | 5 | import Vector 6 | import Primitive 7 | import Camera 8 | import Material 9 | import Colour 10 | import Shader 11 | import Matrix 12 | import Light 13 | import TestScenes 14 | 15 | cornellBoxLights :: [Light] 16 | 17 | cornellBoxCamera :: Camera 18 | 19 | cameraPosition :: Vector 20 | 21 | floorObject :: Object 22 | leftWallObject :: Object 23 | rightWallObject :: Object 24 | frontWallObject :: Object 25 | ceilingObject :: Object 26 | backWallObject :: Object 27 | tallBlockObject :: Object 28 | shortBlockObject :: Object 29 | --lightObject :: Object 30 | 31 | leftWallVertices :: [Vector] 32 | rightWallVertices :: [Vector] 33 | backWallVertices :: [Vector] 34 | frontWallVertices :: [Vector] 35 | ceilingVertices :: [Vector] 36 | --lightVertices :: [Vector] 37 | floorVertices :: [Vector] 38 | tallBlockVertices :: [Vector] 39 | shortBlockVertices :: [Vector] 40 | 41 | whiteMaterial :: Material 42 | redMaterial :: Material 43 | greenMaterial :: Material 44 | --lightMaterial :: Material 45 | 46 | cornellBoxLights = [ 47 | QuadLight (CommonLightData (Colour 500 500 500 0) True) (Vector 213.0 548.0 227.0 1.0) 600 (Vector 130.0 0.0 0.0 0.0) (Vector 0.0 0.0 105.0 0.0) 48 | ] 49 | 50 | cameraPosition = Vector 278.0 273.0 (-800.0) 1.0 51 | cornellBoxCamera = withVectors cameraPosition xaxis yaxis zaxis 45.0 10000 52 | 53 | whiteMaterial = Material (Colour 0.5 0.5 0.5 1) (Colour 0.5 0.5 0.5 1) colBlack colBlack 0 0 0 iorAir NullShader 54 | redMaterial = Material (Colour 0.5 0.0 0.0 1) (Colour 0.5 0.0 0.0 1) colBlack colBlack 0 0 0 iorAir NullShader 55 | greenMaterial = Material (Colour 0.0 0.5 0.0 1) (Colour 0.0 0.5 0.0 1) colBlack colBlack 0 0 0 iorAir NullShader 56 | --lightMaterial = Material colBlack colBlack colBlack (Colour 1000 1000 1000 1) 0 0 0 iorAir NullShader 57 | 58 | --lightVertices = [ 59 | -- Vector 343.0 548.0 227.0 1.0, 60 | -- Vector 343.0 548.0 342.2 1.0, 61 | -- Vector 213.0 548.0 342.0 1.0, 62 | -- Vector 213.0 548.0 227.2 1.0 63 | -- ] 64 | 65 | floorVertices = [ 66 | Vector 556.0 0.0 0.0 1.0, 67 | Vector 0.0 0.0 0.0 1.0, 68 | Vector 0.0 0.0 559.2 1.0, 69 | Vector 556.0 0.0 559.2 1.0 70 | ] 71 | 72 | ceilingVertices = [ 73 | Vector 556.0 548.8 0.0 1.0, 74 | Vector 556.0 548.8 559.2 1.0, 75 | Vector 0.0 548.8 559.2 1.0, 76 | Vector 0.0 548.8 0.0 1.0 77 | ] 78 | 79 | backWallVertices = [ 80 | Vector 556.0 0.0 559.2 1.0, 81 | Vector 0.0 0.0 559.2 1.0, 82 | Vector 0.0 548.8 559.2 1.0, 83 | Vector 556.0 548.8 559.2 1.0 84 | ] 85 | 86 | frontWallVertices = [ 87 | Vector 556.0 548.8 0.0 1.0, 88 | Vector 0.0 548.8 0.0 1.0, 89 | Vector 0.0 0.0 0.0 1.0, 90 | Vector 556.0 0.0 0.0 1.0 91 | ] 92 | 93 | leftWallVertices = [ 94 | Vector 0.0 0.0 559.2 1.0, 95 | Vector 0.0 0.0 0.0 1.0, 96 | Vector 0.0 548.8 0.0 1.0, 97 | Vector 0.0 548.8 559.2 1.0 98 | ] 99 | 100 | rightWallVertices = [ 101 | Vector 556.0 0.0 0.0 1.0, 102 | Vector 556.0 0.0 559.2 1.0, 103 | Vector 556.0 548.8 559.2 1.0, 104 | Vector 556.0 548.8 0.0 1.0 105 | ] 106 | 107 | shortBlockVertices = [ 108 | Vector 130.0 165.0 65.0 1.0, 109 | Vector 82.0 165.0 225.0 1.0, 110 | Vector 240.0 165.0 272.0 1.0, 111 | Vector 290.0 165.0 114.0 1.0, 112 | 113 | Vector 290.0 0.0 114.0 1.0, 114 | Vector 290.0 165.0 114.0 1.0, 115 | Vector 240.0 165.0 272.0 1.0, 116 | Vector 240.0 0.0 272.0 1.0, 117 | 118 | Vector 130.0 0.0 65.0 1.0, 119 | Vector 130.0 165.0 65.0 1.0, 120 | Vector 290.0 165.0 114.0 1.0, 121 | Vector 290.0 0.0 114.0 1.0, 122 | 123 | Vector 82.0 0.0 225.0 1.0, 124 | Vector 82.0 165.0 225.0 1.0, 125 | Vector 130.0 165.0 65.0 1.0, 126 | Vector 130.0 0.0 65.0 1.0, 127 | 128 | Vector 240.0 0.0 272.0 1.0, 129 | Vector 240.0 165.0 272.0 1.0, 130 | Vector 82.0 165.0 225.0 1.0, 131 | Vector 82.0 0.0 225.0 1.0 132 | ] 133 | 134 | tallBlockVertices = [ 135 | Vector 423.0 330.0 247.0 1.0, 136 | Vector 265.0 330.0 296.0 1.0, 137 | Vector 314.0 330.0 456.0 1.0, 138 | Vector 472.0 330.0 406.0 1.0, 139 | 140 | Vector 423.0 0.0 247.0 1.0, 141 | Vector 423.0 330.0 247.0 1.0, 142 | Vector 472.0 330.0 406.0 1.0, 143 | Vector 472.0 0.0 406.0 1.0, 144 | 145 | Vector 472.0 0.0 406.0 1.0, 146 | Vector 472.0 330.0 406.0 1.0, 147 | Vector 314.0 330.0 456.0 1.0, 148 | Vector 314.0 0.0 456.0 1.0, 149 | 150 | Vector 314.0 0.0 456.0 1.0, 151 | Vector 314.0 330.0 456.0 1.0, 152 | Vector 265.0 330.0 296.0 1.0, 153 | Vector 265.0 0.0 296.0 1.0, 154 | 155 | Vector 265.0 0.0 296.0 1.0, 156 | Vector 265.0 330.0 296.0 1.0, 157 | Vector 423.0 330.0 247.0 1.0, 158 | Vector 423.0 0.0 247.0 1.0 159 | ] 160 | 161 | floorObject = Object (TriangleMesh (quadsToTriangles floorVertices)) whiteMaterial identity 162 | frontWallObject = Object (TriangleMesh (quadsToTriangles frontWallVertices)) whiteMaterial identity 163 | leftWallObject = Object (TriangleMesh (quadsToTriangles leftWallVertices)) redMaterial identity 164 | rightWallObject = Object (TriangleMesh (quadsToTriangles rightWallVertices)) greenMaterial identity 165 | ceilingObject = Object (TriangleMesh (quadsToTriangles ceilingVertices)) whiteMaterial identity 166 | backWallObject = Object (TriangleMesh (quadsToTriangles backWallVertices)) whiteMaterial identity 167 | shortBlockObject = Object (TriangleMesh (quadsToTriangles shortBlockVertices)) whiteMaterial identity 168 | tallBlockObject = Object (TriangleMesh (quadsToTriangles tallBlockVertices)) whiteMaterial identity 169 | --lightObject = Object (TriangleMesh (quadsToTriangles lightVertices)) lightMaterial identity 170 | 171 | cornellBox :: [Object] 172 | cornellBox = [ceilingObject, floorObject, leftWallObject, rightWallObject, backWallObject, frontWallObject, tallBlockObject, shortBlockObject, Object (SparseOctreeModel testSvo) defaultMaterial identity] 173 | --cornellBox = [leftWallObject, rightWallObject] 174 | -------------------------------------------------------------------------------- /app/src/Distribution.hs: -------------------------------------------------------------------------------- 1 | -- Module for generating sample patterns for distributed ray tracing 2 | 3 | module Distribution (generatePointsOnSphere, 4 | generatePointsOnQuad, 5 | generatePointsOnHemisphere, 6 | generatePointOnHemisphere, 7 | generateRandomUVs, 8 | generateDirectionsOnSphere, 9 | generateStratifiedDirectionOnHemisphere, 10 | generateUnstratifiedDirectionOnHemisphere, 11 | generateStratifiedDirectionsOnHemisphere, 12 | generateUnstratifiedDirectionsOnHemisphere, 13 | randomUV, 14 | stratify, 15 | uvToHemisphere) where 16 | 17 | import PolymorphicNum 18 | import Vector 19 | import System.Random 20 | import Control.Monad.State 21 | import Misc 22 | 23 | -- Generate a pair of random normalised floats 24 | randomUV :: (RandomGen g) => State g (Double, Double) 25 | randomUV = do u <- randDouble 26 | v <- randDouble 27 | return (saturate u, saturate v) 28 | 29 | -- Generate a list of N random UVs 30 | generateRandomUVs :: (RandomGen g) => Int -> State g [(Double, Double)] 31 | generateRandomUVs n = replicateM n randomUV 32 | 33 | uvToSphere :: Double -> (Double, Double) -> Position 34 | uvToSphere r (u, v) = Vector (r * x) (r * y) (r * z) 1 35 | where 36 | z = 2 * u - 1 37 | t = 2 * pi * v 38 | w = sqrt (1 - z * z) 39 | x = w * cos t 40 | y = w * sin t 41 | 42 | -- Proportional to cosine-weighted solid angle 43 | uvToHemisphere :: Double -> Double -> (Double, Double) -> Position 44 | {-# SPECIALIZE INLINE uvToHemisphere :: Double -> Double -> (Double, Double) -> Position #-} 45 | uvToHemisphere r w (u, v) = Vector (r * x) (r * y) (r * z) w 46 | where 47 | k = sqrt u 48 | theta = 2.0 * pi * v 49 | x = k * cos theta 50 | y = k * sin theta 51 | z = sqrt (1.0 - u) 52 | 53 | -- Generate a list of random points on a sphere 54 | generatePointsOnSphere :: (RandomGen g) => Int -> Double -> g -> ([Position], g) 55 | generatePointsOnSphere numPoints r gen 56 | | numPoints <= 1 = ([Vector 0 0 0 1], gen) 57 | | otherwise = (map (uvToSphere r) randomUVs, gen') 58 | where 59 | (randomUVs, gen') = runState (generateRandomUVs numPoints) gen 60 | 61 | -- Generate a list of random points on a hemisphere (z > 0) 62 | generatePointsOnHemisphere :: (RandomGen g) => Int -> Double -> g -> ([Position], g) 63 | generatePointsOnHemisphere numPoints r gen 64 | | numPoints <= 1 = ([Vector 0 0 0 1], gen) 65 | | otherwise = (map (uvToHemisphere r 1) randomUVs, gen') 66 | where 67 | (randomUVs, gen') = runState (generateRandomUVs numPoints) gen 68 | 69 | generatePointsOnQuad :: (RandomGen g) => Position -> Direction -> Direction -> Int -> g -> ([Position], g) 70 | generatePointsOnQuad pos deltaU deltaV numPoints gen 71 | | numPoints <= 1 = ([Vector 0 0 0 1], gen) 72 | | otherwise = (map (\(u, v) -> pos <+> deltaU <*> u <+> deltaV <*> v) randomUVs, gen') 73 | where 74 | (randomUVs, gen') = runState (generateRandomUVs numPoints) gen 75 | 76 | -- Generate a single random point on a hemisphere 77 | generatePointOnHemisphere :: (RandomGen g) => g -> Double -> (Position, g) 78 | generatePointOnHemisphere gen r = (uvToHemisphere r 1 uv, gen') 79 | where 80 | (uv, gen') = runState randomUV gen 81 | 82 | -- Stratify over an 8x8 grid 83 | stratify :: (Double, Double) -> Int -> (Double, Double) 84 | stratify (u, v) index = ((col + u) * recipGridX, (row + v) * recipGridY) 85 | where 86 | gridX = 8 87 | gridY = 8 88 | recipGridX = (1.0 :: Double) / gridX 89 | recipGridY = (1.0 :: Double) / gridY 90 | wrappedIndex = index `mod` floor (gridX * gridY) 91 | row = fromIntegral (wrappedIndex `div` floor gridX) 92 | col = fromIntegral (wrappedIndex `mod` floor gridX) 93 | 94 | generateDirectionsOnSphere :: (RandomGen g) => Int -> Double -> g -> ([Direction], g) 95 | generateDirectionsOnSphere numPoints r gen 96 | | numPoints <= 1 = ([Vector 0 0 0 1], gen) 97 | | otherwise = (map (setWTo0 . uvToSphere r) randomUVs, gen') 98 | where 99 | (randomUVs, gen') = runState (generateRandomUVs numPoints) gen 100 | 101 | generateUnstratifiedDirectionOnHemisphere :: (RandomGen g) => Double -> State g Direction 102 | generateUnstratifiedDirectionOnHemisphere r = do 103 | u <- randDouble 104 | v <- randDouble 105 | return (uvToHemisphere r 0 (u, v)) 106 | 107 | generateStratifiedDirectionOnHemisphere :: (RandomGen g) => g -> Double -> Int -> (Direction, g) 108 | generateStratifiedDirectionOnHemisphere gen r index = (uvToHemisphere r 0 (stratify uv index), gen') 109 | where 110 | (uv, gen') = runState randomUV gen 111 | 112 | generateStratifiedDirectionsOnHemisphere :: (RandomGen g) => Int -> Double -> g -> ([Direction], g) 113 | generateStratifiedDirectionsOnHemisphere numPoints r gen 114 | | numPoints <= 1 = ([Vector 0 0 0 1], gen) 115 | | numPoints `mod` 64 /= 0 = error "Error, must specify point count in multiples of 64 (8x8 grid stratification)" 116 | | otherwise = (map (uvToHemisphere r 0) stratifiedUVs, gen') 117 | where 118 | (randomUVs, gen') = runState (generateRandomUVs numPoints) gen 119 | stratifiedUVs = zipWith stratify randomUVs [0..] 120 | 121 | generateUnstratifiedDirectionsOnHemisphere :: (RandomGen g) => Int -> Double -> g -> ([Direction], g) 122 | generateUnstratifiedDirectionsOnHemisphere numPoints r gen 123 | | numPoints <= 1 = ([Vector 0 0 0 1], gen) 124 | | otherwise = (map (uvToHemisphere r 0) randomUVs, gen') 125 | where 126 | (randomUVs, gen') = runState (generateRandomUVs numPoints) gen 127 | -------------------------------------------------------------------------------- /app/src/IrradianceCache.hs: -------------------------------------------------------------------------------- 1 | -- The irradiance cache 2 | 3 | module IrradianceCache (IrradianceCache, query, initialiseCache) where 4 | 5 | import PolymorphicNum 6 | import Vector 7 | import Colour 8 | import BoundingBox 9 | import Octree 10 | import SceneGraph 11 | 12 | -- Irradiance gradient using a central-differencing approach 13 | data IrradianceGradient = CentralDifferenceGradient {-# UNPACK #-} !(Colour, Colour, Colour) 14 | 15 | -- Direction of normal, colour, radius 16 | data CacheSample = CacheSample {-# UNPACK #-} !(Normal, Colour, Double) 17 | 18 | type IrradianceCache = Octree CacheSample 19 | 20 | -- Pretty printer for cache samples 21 | instance Show CacheSample where 22 | show (CacheSample (dir, col, r)) = "\tDirection: " ++ show dir ++ "\n\tColour: " ++ show col ++ "\n\tRadius: " ++ show r ++ "\n" 23 | 24 | -- This gives an initial empty cache that will later be populated 25 | initialiseCache :: SceneGraph -> IrradianceCache 26 | initialiseCache sceneGraph = OctreeNode slightlyEnlargedBox $ map OctreeDummy (splitBoxIntoOctreeChildren slightlyEnlargedBox) 27 | where 28 | -- Create the initial irradiance cache tree. This is a box a little larger than the world so that we fit any points offset along the normal etc 29 | slightlyEnlargedBox = boundingBoxGrow (finiteBox sceneGraph) 10 30 | 31 | -- Quantify the error if we use a given sample to shade a point 32 | -- The bigger the number, the better the estimate 33 | errorWeight :: (Position, Direction) -> (Position, CacheSample) -> Double 34 | {-# SPECIALIZE INLINE errorWeight :: (Position, Direction) -> (Position, CacheSample) -> Double #-} 35 | errorWeight (pos', dir') (pos, CacheSample (dir, _, r)) 36 | | dot <= 0 = 0 37 | | otherwise = 1 / ((pos `distance` pos') / r + sqrt (1 + dot)) 38 | where 39 | dot = dir `dot3` dir' 40 | 41 | -- This slightly convoluted version is written to be tail recursive. I effectively have to maintain a software stack of the 42 | -- nodes remaining to be traversed 43 | findSamples :: (Position, Direction) -> [IrradianceCache] -> [(Vector, CacheSample, Double)] -> [(Vector, CacheSample, Double)] 44 | findSamples posDir@(pos, _) (OctreeNode box nodeChildren : xs) acc 45 | | box `contains` pos = findSamples posDir (nodeChildren ++ xs) acc 46 | | otherwise = findSamples posDir xs acc 47 | findSamples posDir@(pos, _) (OctreeLeaf _ (samplePos, sample) : xs) acc 48 | | (pos `distanceSq` samplePos) <= sampleR * sampleR && weight > minimumWeight = findSamples posDir xs ((samplePos, sample, weight) : acc) 49 | | otherwise = findSamples posDir xs acc 50 | where 51 | weight = errorWeight posDir (samplePos, sample) 52 | (CacheSample (_, _, sampleR)) = sample 53 | minimumWeight = 1.5 -- The bigger this weight, the less it will reuse samples and the higher the quality 54 | findSamples posDir (OctreeDummy _ : xs) acc = findSamples posDir xs acc 55 | findSamples _ [] acc = acc 56 | 57 | -- Sum together a list of samples and error weights 58 | sumSamples :: [(Vector, CacheSample, Double)] -> Colour 59 | sumSamples samples = colourSum weightSum 60 | where 61 | sumSamples' (colAcc, weightAcc) ((_, CacheSample (_, col, _), weight):xs) = sumSamples' (colAcc <+> col <*> weight, weightAcc + weight) xs 62 | sumSamples' (colAcc, weightAcc) [] = (colAcc, weightAcc) 63 | (colourSum, weightSum) = sumSamples' (colBlack, 0) samples 64 | 65 | -- Query the irradiance given a point 66 | -- Supplied function supplies the irradiance colour at a surface location along with the radius it is valid for 67 | query :: IrradianceCache -> SurfaceLocation -> (SurfaceLocation -> (Colour, Double)) -> (Colour, IrradianceCache) 68 | query irrCache posTanSpace f = case findSamples (position, normal) [irrCache] [] of 69 | -- Insert a new cache sample 70 | [] -> let (colour, r) = f posTanSpace 71 | sample = CacheSample (normal, colour, r) 72 | in (colour, Octree.insert (fst posTanSpace) sample irrCache) 73 | -- Re-use existing cache samples 74 | list -> (sumSamples list, irrCache) 75 | where 76 | position = fst posTanSpace 77 | tanSpace = snd posTanSpace 78 | normal = tsNormal tanSpace 79 | -------------------------------------------------------------------------------- /app/src/KDTree.hs: -------------------------------------------------------------------------------- 1 | -- This is a module for constructing bounding volume hierarchies using a kdtree 2 | 3 | module KDTree(generateSceneGraphUsingKDTree, makeSplittingPlane, degenerateSplitList, findSplittingPlane) where 4 | 5 | import PolymorphicNum 6 | import Vector 7 | import Primitive 8 | import Data.List 9 | import BoundingBox 10 | 11 | -- This stuff is object specific 12 | 13 | -- What side of a plane is an object on? 14 | onPositiveSide :: (Vector, Double) -> Object -> Bool 15 | onPositiveSide (planeNormal, planeDist) obj = planeDist + (planeNormal `dot3` objBoxCentre) > 0.01 16 | where 17 | Just (boxMin, boxMax) = primitiveBoundingBox (primitive obj) obj 18 | objBoxCentre = (boxMin <+> boxMax) <*> (0.5 :: Double) 19 | 20 | -- This stuff is generic 21 | 22 | -- Generate a plane to split the objects along 23 | makeSplittingPlane :: AABB -> Int -> (Vector, Double) 24 | makeSplittingPlane (boxMin, boxMax) buildCycle = case nthLargestAxis (boxMax <-> boxMin) buildCycle of 25 | 0 -> (xaxis, -(vecX midPoint)) 26 | 1 -> (yaxis, -(vecY midPoint)) 27 | 2 -> (zaxis, -(vecZ midPoint)) 28 | _ -> error "Undefined value" 29 | where 30 | midPoint = (boxMin <+> boxMax) <*> (0.5 :: Double) 31 | 32 | -- Find a working splitting plane 33 | findSplittingPlane :: AABB -> Int -> [t] -> ((Vector, Double) -> t -> Bool) -> Maybe (Vector, Double) 34 | findSplittingPlane box buildCycle objs partitionFunc 35 | | buildCycle > 2 = Nothing 36 | | otherwise = if length leftObjects > 0 && length rightObjects > 0 37 | then Just candidateSplittingPlane 38 | else findSplittingPlane box (buildCycle + 1) objs partitionFunc 39 | where 40 | candidateSplittingPlane = makeSplittingPlane box buildCycle 41 | (leftObjects, rightObjects) = partition (partitionFunc candidateSplittingPlane) objs 42 | 43 | -- We use this dysfunctional strategy where all our smarter ideas run out 44 | degenerateSplitList :: (Eq t) => [t] -> ([t], [t]) 45 | degenerateSplitList objs = ([x | x <- objs, case x `elemIndex` objs of 46 | Just index -> odd index 47 | Nothing -> False], 48 | [x | x <- objs, case x `elemIndex` objs of 49 | Just index -> even index 50 | Nothing -> False]) 51 | 52 | -- Make children using a kd tree 53 | generateSceneGraphUsingKDTree :: [Object] -> [[Object]] 54 | generateSceneGraphUsingKDTree objs = [leftObjects, rightObjects] 55 | where 56 | objBox = objectListBoundingBox objs 57 | (leftObjects, rightObjects) = case findSplittingPlane objBox 0 objs onPositiveSide of 58 | Nothing -> degenerateSplitList objs 59 | Just splittingPlane -> partition (onPositiveSide splittingPlane) objs 60 | -------------------------------------------------------------------------------- /app/src/Light.hs: -------------------------------------------------------------------------------- 1 | -- Module for lights 2 | 3 | module Light (applyLight, 4 | surfaceEpsilon, 5 | Light(PointLight, AmbientLight, QuadLight), 6 | CommonLightData(CommonLightData), 7 | LightingResult, 8 | position, 9 | colour, 10 | range, 11 | deltaU, 12 | deltaV, 13 | addToPhotonMap, 14 | common) where 15 | 16 | import PolymorphicNum 17 | import Vector 18 | import Colour 19 | import Ray 20 | import Material 21 | import Shader 22 | import SceneGraph 23 | import Misc 24 | import Control.Monad.State 25 | import ShadowCache 26 | 27 | data CommonLightData = CommonLightData { colour :: !Colour, 28 | addToPhotonMap :: !Bool } deriving (Show) 29 | 30 | data Light = PointLight { common :: CommonLightData, position :: !Position, range :: !Double } 31 | | AmbientLight { common :: CommonLightData } 32 | | QuadLight { common :: CommonLightData, position :: !Position, range :: !Double, deltaU :: !Direction, deltaV :: !Direction } deriving (Show) 33 | 34 | type LightingResult = (Colour, Colour, Colour) -- Ambient, diffuse, specular 35 | 36 | -- Value for the surface epsilon 37 | surfaceEpsilon :: Double 38 | surfaceEpsilon = 0.1 39 | 40 | -- Find the attenuation for a light source 41 | lightAttenuation :: Vector -> Vector -> Double -> Double 42 | lightAttenuation lightPos shadePos lightRange = 43 | let dist = lightPos `Vector.distance` shadePos 44 | in if dist < lightRange then 1 - dist / lightRange else 0 45 | 46 | -- Apply phong lighting to an object 47 | phongLighting :: SurfaceLocation -> Light -> Material -> SceneGraph -> Direction -> State ShadowCache Colour 48 | phongLighting (shadePos, tanSpace) (PointLight (CommonLightData lightColour inPhotonMap') lightPos lightRange) objMaterial sceneGraph viewDirection 49 | | (lightPos `distanceSq` shadePos) < (lightRange * lightRange) && dotProd > 0 = 50 | do 51 | shadowCache <- get 52 | let (intersection, shadowCache') = testShadowCache shadowCache sceneGraph (rayWithPoints intersectionPlusEpsilon lightPos) 53 | let result = case intersection of 54 | Just _ -> colBlack -- An object is closer to our point of consideration than the light, so occluded 55 | Nothing -> (lightColour <*> lightingSum) <*> attenuation 56 | where 57 | lightingSum = diffuseLighting <+> specularLighting 58 | attenuation = lightAttenuation lightPos shadePos lightRange 59 | specularCorrection = (specularPower objMaterial + 2) / (2 * pi) 60 | specularLighting = specular objMaterial <*> (specularCorrection * saturate (reflection `dot3` Vector.negate viewDirection) ** specularPower objMaterial) 61 | reflection = reflect incoming normal 62 | diffuseLighting = if inPhotonMap' 63 | then colBlack 64 | else shaderDiffuse <*> diffuse objMaterial <*> saturate dotProd 65 | shaderDiffuse = evaluateDiffuse (shader objMaterial) shadePos tanSpace 66 | put shadowCache' 67 | return result 68 | | otherwise = return colBlack 69 | where 70 | intersectionPlusEpsilon = shadePos <+> normal <*> surfaceEpsilon 71 | incoming = normalise (lightPos <-> shadePos) 72 | dotProd = normal `dot3` incoming 73 | normal = thr tanSpace 74 | phongLighting _ (AmbientLight (CommonLightData _ _)) _ _ _ = error "phongLighting: Do not know how to handle AmbientLight" 75 | phongLighting (shadePos, tanSpace) (QuadLight (CommonLightData lightColour inPhotonMap') lightPos lightRange du dv) objMaterial sceneGraph viewDirection 76 | | (lightCentre `distanceSq` shadePos) < (lightRange * lightRange) && dotProd > 0 = 77 | do 78 | shadowCache <- get 79 | let (intersection, shadowCache') = testShadowCache shadowCache sceneGraph (rayWithPoints intersectionPlusEpsilon lightCentre) 80 | let result = case intersection of 81 | Just _ -> colBlack -- An object is closer to our point of consideration than the light, so occluded 82 | Nothing -> let lightingSum = diffuseLighting <+> specularLighting 83 | attenuation = lightAttenuation lightCentre shadePos lightRange 84 | specularCorrection = (specularPower objMaterial + 2) / (2 * pi) 85 | specularLighting = specular objMaterial <*> (specularCorrection * saturate (reflection `dot3` Vector.negate viewDirection) ** specularPower objMaterial) 86 | reflection = reflect incoming normal 87 | 88 | diffuseLighting = if inPhotonMap' 89 | then colBlack 90 | else shaderDiffuse <*> diffuse objMaterial <*> saturate dotProd 91 | shaderDiffuse = evaluateDiffuse (shader objMaterial) shadePos tanSpace 92 | in lightColour <*> lightingSum <*> attenuation 93 | put shadowCache' 94 | return result 95 | | otherwise = return colBlack 96 | where 97 | lightCentre = lightPos <+> du <*> (0.5 :: Double) <+> dv <*> (0.5 :: Double) 98 | intersectionPlusEpsilon = shadePos <+> normal <*> surfaceEpsilon 99 | incoming = normalise (lightCentre <-> shadePos) 100 | dotProd = normal `dot3` incoming 101 | normal = thr tanSpace 102 | 103 | -- For a given surface point, work out the lighting, including occlusion 104 | applyLight :: SceneGraph -> SurfaceLocation -> Material -> Direction -> Light -> State ShadowCache Colour 105 | applyLight sceneGraph intersectionPointNormal objMaterial viewDirection light@(PointLight (CommonLightData _ _) _ _) 106 | = phongLighting 107 | intersectionPointNormal 108 | light 109 | objMaterial 110 | sceneGraph 111 | viewDirection 112 | applyLight _ (intersectionPoint, intersectionTanSpace) objMaterial _ (AmbientLight (CommonLightData ambientColour _)) = 113 | let shaderAmbient = evaluateAmbient (shader objMaterial) intersectionPoint intersectionTanSpace 114 | materialAmbient = ambient objMaterial 115 | in return $! ambientColour <*> shaderAmbient <*> materialAmbient 116 | applyLight sceneGraph intersectionPointNormal objMaterial viewDirection light@(QuadLight (CommonLightData _ _) _ _ _ _) 117 | = phongLighting 118 | intersectionPointNormal 119 | light 120 | objMaterial 121 | sceneGraph 122 | viewDirection 123 | -------------------------------------------------------------------------------- /app/src/Light.hs-boot: -------------------------------------------------------------------------------- 1 | module Light (applyLight, 2 | surfaceEpsilon, 3 | Light(PointLight, AmbientLight, QuadLight), 4 | CommonLightData(CommonLightData), 5 | LightingResult, 6 | position, 7 | colour, 8 | range, 9 | deltaU, 10 | deltaV, 11 | addToPhotonMap, 12 | common) where 13 | 14 | import Vector 15 | import Colour 16 | import Material 17 | import SceneGraph 18 | import Control.Monad.State 19 | import {-# SOURCE #-} ShadowCache 20 | 21 | data CommonLightData = CommonLightData { colour :: !Colour, 22 | addToPhotonMap :: !Bool } 23 | 24 | data Light = PointLight { common :: CommonLightData, position :: !Position, range :: !Double } 25 | | AmbientLight { common :: CommonLightData } 26 | | QuadLight { common :: CommonLightData, position :: !Position, range :: !Double, deltaU :: !Direction, deltaV :: !Direction } 27 | 28 | type LightingResult = (Colour, Colour, Colour) -- Ambient, diffuse, specular 29 | 30 | applyLight :: SceneGraph -> (Position, TangentSpace) -> Material -> Direction -> Light -> State ShadowCache Colour 31 | surfaceEpsilon :: Double 32 | -------------------------------------------------------------------------------- /app/src/Main.hs: -------------------------------------------------------------------------------- 1 | -- Main module of raytracer 2 | 3 | import Data.Bits 4 | import Data.ByteString hiding (map) 5 | import System.Console.GetOpt 6 | import System.Environment 7 | import RayTrace 8 | import Colour 9 | import SceneGraph 10 | import KDTree 11 | import CornellBox 12 | import GHC.Conc (numCapabilities) 13 | import Codec.BMP 14 | import PhotonMap 15 | import RenderContext 16 | import Light 17 | import ToneMap 18 | import Control.Arrow 19 | import Primitive 20 | import Camera 21 | 22 | -- Command line option support 23 | data Option 24 | = ShowIntermediate -- -i 25 | | PhotonMap -- -p 26 | | DirectPhotonMapVisualisation -- -v 27 | | DistributedRayTracing -- d 28 | | IrradianceCaching -- c 29 | | PathTrace -- P 30 | deriving (Eq, Ord, Enum, Show, Bounded) 31 | 32 | options :: [OptDescr Option] 33 | options = [ 34 | Option "i" [] (NoArg ShowIntermediate) "Show intermediates", 35 | Option "p" [] (NoArg PhotonMap) "Photon map", 36 | Option "v" [] (NoArg DirectPhotonMapVisualisation) "Direct photon map visualisation", 37 | Option "d" [] (NoArg DistributedRayTracing) "Distributed ray tracing", 38 | Option "c" [] (NoArg IrradianceCaching) "Irradiance caching", 39 | Option "P" [] (NoArg PathTrace) "Path tracing" 40 | ] 41 | 42 | parsedOptions :: [String] -> [Option] 43 | parsedOptions argv = case getOpt Permute options argv of 44 | (args,_,[]) -> args 45 | (_,_,_) -> [] 46 | 47 | -- Some hardcoded values, at present 48 | renderWidth :: Int -> Int 49 | renderWidth mipLevel = 1280 `shiftR` mipLevel 50 | 51 | renderHeight :: Int -> Int 52 | renderHeight mipLevel = 720 `shiftR` mipLevel 53 | 54 | -- This returns a list of colours of pixels 55 | renderScaledImage :: Int -> RenderContext -> Maybe PhotonMap -> [Colour] 56 | renderScaledImage mipLevel renderSettings photonMap = finalImage 57 | where 58 | rawImageOutput = renderScene photonMap renderSettings camera (renderWidth mipLevel) (renderHeight mipLevel) 59 | exposedImage = exposeImage imageAverageLuminance rawImageOutput 4 60 | toneMappedImage = toneMapImage toneMapHejlBurgessDawson exposedImage 61 | finalImage = map (clamp . invGammaCorrect) toneMappedImage 62 | 63 | -- In the interest of rapid developer feedback, this functions writes a progressively-increasing image 64 | -- So, we get quick feedback on the intermediate results, but will still ultimately get the final image 65 | -- Note this does no re-use, so it'll be slower overall 66 | writeImageMipMapChain :: String -> [Int] -> Maybe PhotonMap -> RenderContext -> IO () 67 | writeImageMipMapChain baseFilename [] photonMap renderSettings = do 68 | let imageData = renderScaledImage 0 renderSettings photonMap 69 | let rgba = Data.ByteString.pack (convertColoursToPixels imageData) 70 | let bmp = packRGBA32ToBMP (renderWidth 0) (renderHeight 0) rgba 71 | Prelude.putStrLn "Performing final render" 72 | writeBMP (baseFilename ++ ".bmp") bmp 73 | writeImageMipMapChain baseFilename (mipLevel:mipLevels) photonMap renderSettings = do 74 | let imageData = renderScaledImage mipLevel renderSettings photonMap 75 | let rgba = Data.ByteString.pack (convertColoursToPixels imageData) 76 | let bmp = packRGBA32ToBMP (renderWidth mipLevel) (renderHeight mipLevel) rgba 77 | let filename = baseFilename ++ "-" ++ show mipLevel ++ ".bmp" 78 | Prelude.putStrLn filename 79 | writeBMP filename bmp 80 | writeImageMipMapChain baseFilename mipLevels photonMap renderSettings 81 | 82 | -- Strip off the photon map flag from a light 83 | notInPhotonMap :: Light -> Light 84 | notInPhotonMap (PointLight (CommonLightData colour' _) position' range') = PointLight (CommonLightData colour' False) position' range' 85 | notInPhotonMap (AmbientLight (CommonLightData colour' _)) = AmbientLight (CommonLightData colour' False) 86 | notInPhotonMap (QuadLight (CommonLightData colour' _) position' range' deltaU' deltaV') = QuadLight (CommonLightData colour' False) position' range' deltaU' deltaV' 87 | 88 | scene :: [Object] 89 | scene = cornellBox 90 | 91 | lights :: [Light] 92 | lights = cornellBoxLights 93 | 94 | camera :: Camera 95 | camera = cornellBoxCamera 96 | 97 | -- Main function 98 | main :: IO () 99 | main = do 100 | args <- getArgs 101 | let opts = parsedOptions args 102 | 103 | let renderSettings = RenderContext 104 | numDistributedSamples 105 | (buildSceneGraph scene generateSceneGraphUsingKDTree) 106 | Main.lights 107 | maxRayDepth 108 | reflectionDistance 109 | refractionDistance 110 | (PhotonMapContext photonGatherDistance maxGatherPhotons coneFilterConstant directPhotonMapVisualisation) 111 | rayOriginDistribution' 112 | depthOfFieldFocalDistance' 113 | renderMode' 114 | enableIrradianceCache 115 | where 116 | -- Ray trace constants 117 | numDistributedSamples = if DistributedRayTracing `Prelude.elem` opts 118 | then 64 119 | else 1 120 | maxRayDepth = 5 121 | reflectionDistance = 1000 122 | refractionDistance = 1000 123 | -- Photon constants 124 | photonGatherDistance = 100 125 | maxGatherPhotons = 200 126 | coneFilterConstant = 2 127 | -- Depth of field constants 128 | rayOriginDistribution' = 0.5 129 | depthOfFieldFocalDistance' = 400 130 | renderMode' 131 | | PhotonMap `Prelude.elem` opts = PhotonMapper 132 | | PathTrace `Prelude.elem` opts = PathTracer 133 | | otherwise = RayTrace 134 | directPhotonMapVisualisation = DirectPhotonMapVisualisation `Prelude.elem` opts 135 | enableIrradianceCache = IrradianceCaching `Prelude.elem` opts 136 | 137 | -- Display hardware capabilities 138 | Prelude.putStrLn $ "Running on " ++ show numCapabilities ++ " cores" 139 | 140 | -- Create a photon map, if necessary 141 | let doPhotonMapping = PhotonMap `Prelude.elem` opts 142 | let photonMapMessage = if doPhotonMapping 143 | then if DirectPhotonMapVisualisation `Prelude.elem` opts 144 | then "Directly visualising photon map" 145 | else "Creating photon map..." 146 | else "Photon mapping disabled" 147 | Prelude.putStrLn photonMapMessage 148 | let thousand = 1000 149 | let numPhotons = 200 * thousand 150 | let (photonMap, lights') 151 | | doPhotonMapping = Control.Arrow.first Just $ 152 | buildPhotonMap (sceneGraph renderSettings) cornellBoxLights numPhotons 153 | | otherwise = (Nothing, map notInPhotonMap (RenderContext.lights renderSettings)) 154 | 155 | -- Display message about irradiance cache 156 | Prelude.putStrLn (if useIrradianceCache renderSettings then "Irradiance caching enabled" else "Irrradiance caching disabled") 157 | 158 | -- Display message about path tracing 159 | Prelude.putStrLn (if PathTrace `Prelude.elem` opts then "Path tracer enabled" else "Path tracer disabled") 160 | 161 | -- Render the image 162 | let renderSettings' = renderSettings { RenderContext.lights = lights' } 163 | let maxMipLevel = 8 164 | let intermediateMipLevels = if ShowIntermediate `Prelude.elem` opts 165 | then Prelude.reverse [1..maxMipLevel] 166 | else [] 167 | Prelude.putStrLn "Rendering image..." 168 | writeImageMipMapChain "render-output" intermediateMipLevels photonMap renderSettings' 169 | -------------------------------------------------------------------------------- /app/src/Material.hs: -------------------------------------------------------------------------------- 1 | -- Materials of an object 2 | 3 | module Material where 4 | 5 | import Colour 6 | import Shader 7 | 8 | data Material = Material { ambient :: {-# UNPACK #-} !Colour, 9 | diffuse :: {-# UNPACK #-} !Colour, 10 | specular :: {-# UNPACK #-} !Colour, 11 | emission :: {-# UNPACK #-} !Colour, 12 | specularPower :: {-# UNPACK #-} !Double, 13 | reflectivity :: {-# UNPACK #-} !Double, 14 | transmit :: {-# UNPACK #-} !Double, 15 | indexOfRefraction :: {-# UNPACK #-} !Double, 16 | shader :: Shader } deriving (Show, Eq) 17 | 18 | iorAir :: Double 19 | iorAir = 1.000293 20 | 21 | iorWater :: Double 22 | iorWater = 1.3330 23 | 24 | defaultMaterial :: Material 25 | defaultMaterial = Material 26 | (Colour 0.5 0.5 0.5 0.5) 27 | (Colour 0.5 0.5 0.5 0.5) 28 | (Colour 0.5 0.5 0.5 0.5) 29 | (Colour 0.0 0.0 0.0 0.0) 30 | 25 31 | 0 32 | 0 33 | iorAir 34 | NullShader 35 | -------------------------------------------------------------------------------- /app/src/Matrix.hs: -------------------------------------------------------------------------------- 1 | -- 4D Matrix Library 2 | -- TODO - Rewrite all this to be a lot more efficient. Very early code...2/ 3 | {-# LANGUAGE BangPatterns #-} 4 | 5 | module Matrix where 6 | 7 | import Vector 8 | 9 | data Matrix = Matrix ![Double] deriving (Show, Read, Eq) 10 | 11 | -- Just pass back the identity matrix 12 | identity :: Matrix 13 | identity = Matrix [1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1] 14 | 15 | -- Multiply together two matrices 16 | mul :: Matrix -> Matrix -> Matrix 17 | mul (Matrix a) (Matrix b) = Matrix [sum [(a !! (i * 4 + k)) * (b !! (k * 4 + j)) | k <- [0..3]] | j <- [0..3], i <- [0..3]] 18 | 19 | -- Need matrix inversion code 20 | 21 | -- Vector * Matrix 22 | transformVector :: Matrix -> Vector -> Vector 23 | transformVector (Matrix mat) (Vector !x !y !z !w) = Vector x' y' z' w' 24 | where 25 | !vec = [x, y, z, w] 26 | !xvector = take 4 mat 27 | !yvector = take 4 (drop 4 mat) 28 | !zvector = take 4 (drop 8 mat) 29 | !wvector = take 4 (drop 12 mat) 30 | !x' = sum $ zipWith (*) vec xvector 31 | !y' = sum $ zipWith (*) vec yvector 32 | !z' = sum $ zipWith (*) vec zvector 33 | !w' = sum $ zipWith (*) vec wvector 34 | 35 | -- Build a matrix from 4 vectors 36 | buildMatrix :: Vector -> Vector -> Vector -> Vector -> Matrix 37 | buildMatrix (Vector xx xy xz _) (Vector yx yy yz _) (Vector zx zy zz _) (Vector px py pz _) = Matrix ([xx, xy, xz] ++ [px] ++ 38 | [yx, yy, yz] ++ [py] ++ 39 | [zx, zy, zz] ++ [pz] ++ 40 | [0, 0, 0, 1]) 41 | getTranslation :: Matrix -> Vector 42 | {-# SPECIALIZE INLINE getTranslation :: Matrix -> Vector #-} 43 | getTranslation (Matrix a) = Vector x y z 1 44 | where 45 | [!x, !y, !z, _] = drop 12 a 46 | 47 | translationMatrix :: Double -> Double -> Double -> Matrix 48 | translationMatrix !x !y !z = Matrix [1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, x, y, z, 1] 49 | translationMatrix' :: Vector -> Matrix 50 | translationMatrix' (Vector !x !y !z _) = Matrix [1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, x, y, z, 1] 51 | -------------------------------------------------------------------------------- /app/src/Misc.hs: -------------------------------------------------------------------------------- 1 | -- Various assorted bits and pieces 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | module Misc where 5 | 6 | import Data.List 7 | import Control.Parallel.Strategies 8 | import Control.Monad.State 9 | import System.Random 10 | 11 | degreesToRadians :: Double -> Double 12 | degreesToRadians x = x * pi / 180 13 | 14 | xor :: Bool -> Bool -> Bool 15 | xor True a = not a 16 | xor False a = a 17 | 18 | thr :: (x, y, z) -> z 19 | thr (_, _, c) = c 20 | 21 | -- Little helper for saturation 22 | saturate :: (Num t, Ord t) => t -> t 23 | saturate x = Prelude.max 0 (Prelude.min x 1) 24 | 25 | harmonicMean :: (Num t, Fractional t) => [t] -> t 26 | harmonicMean array@(_:_) = fromIntegral (length array) / foldl' (\a b -> b + 1 / a) 0 array 27 | harmonicMean [] = 0 28 | 29 | -- This performs a map, and passes through the state of the completed operation to the next recursion 30 | -- Couldn't work out the equivalent using the state monad etc 31 | mapS :: (a -> s -> (b, s)) -> [a] -> s -> ([b], s) 32 | mapS f z s = mapS' z s [] 33 | where 34 | mapS' !(x:xs) !st !acc = seq (result, st') $ mapS' xs st' (result : acc) 35 | where (!result, !st') = f x st `using` rseq 36 | mapS' [] !st !acc = (acc, st) 37 | 38 | -- Map over a list, passing state from one to the next with the state monad and returning state 39 | mapWithState :: [a] -> s -> (a -> State s b) -> ([b], s) 40 | mapWithState arr s f = mapWithState' arr s [] 41 | where 42 | mapWithState' (x:xs) !st !acc = result `seq` mapWithState' xs st' (result : acc) 43 | where 44 | (!result, !st') = runState (f x) st 45 | mapWithState' [] !st !acc = (acc, st) 46 | 47 | -- As above, but discard state 48 | mapWithStateDiscard :: [a] -> s -> (a -> State s b) -> [b] 49 | mapWithStateDiscard arr s f = mapWithState' arr s [] 50 | where 51 | mapWithState' (x:xs) !st !acc = result `seq` mapWithState' xs st' (result : acc) 52 | where 53 | (!result, !st') = runState (f x) st `using` rseq 54 | mapWithState' [] _ !acc = acc 55 | 56 | -- Zip over two lists, passing state from one to the next with the state monad 57 | zipWithState :: (a -> b -> State s c) -> [a] -> [b] -> s -> ([c], s) 58 | zipWithState f arr1 arr2 s = zipWithState' arr1 arr2 s [] 59 | where 60 | zipWithState' (x:xs) (y:ys) st acc = zipWithState' xs ys st' (result : acc) 61 | where 62 | (!result, !st') = runState (f x y) st 63 | zipWithState' (_:_) [] _ _ = error "Lists are of a different size - unhandled case!" 64 | zipWithState' [] (_:_) _ _ = error "Lists are of a different size - unhandled case!" 65 | zipWithState' [] [] st acc = (acc, st) 66 | 67 | zipWithState3 :: (a -> b -> c -> State s d) -> [a] -> [b] -> [c] -> s -> ([d], s) 68 | zipWithState3 f arr1 arr2 arr3 s = zipWithState3' arr1 arr2 arr3 s [] 69 | where 70 | zipWithState3' (x:xs) (y:ys) (z:zs) st acc = zipWithState3' xs ys zs st' (result : acc) 71 | where 72 | (!result, !st') = runState (f x y z) st 73 | zipWithState3' (_:_) [] _ st acc = (acc, st) 74 | zipWithState3' (_:_) (_:_) [] st acc = (acc, st) 75 | zipWithState3' [] (_:_) _ st acc = (acc, st) 76 | zipWithState3' [] [] (_:_) st acc = (acc, st) 77 | zipWithState3' [] [] [] st acc = (acc, st) 78 | 79 | zipWith' :: (a -> b -> t) -> [a] -> [b] -> [t] 80 | zipWith' f l1 l2 = [ f e1 e2 | (e1, e2) <- zipWith k l1 l2 ] 81 | where 82 | k x y = x `seq` y `seq` (x,y) 83 | 84 | -- Repeatedly call a function and pass state (eg, random numbers) 85 | replicateWithState :: Int -> s -> State s b -> ([b], s) 86 | replicateWithState count s f = replicateWithState' count s [] 87 | where 88 | replicateWithState' 0 st acc = (acc, st) 89 | replicateWithState' ct st acc = replicateWithState' (ct - 1) st' (result : acc) 90 | where 91 | (!result, !st') = runState f st 92 | 93 | randDouble :: (RandomGen g) => State g Double 94 | randDouble = do 95 | gen <- get 96 | let (r, gen') = randomR (0, 1) gen 97 | put gen' 98 | return r 99 | 100 | -- Handy little thing to apply a different function to each of the two elements in a Maybe (a, a) pair. Useful in various ray tracing bits of code 101 | maybePairFunctor :: (Ord a) => (a -> a -> a) -> (a -> a -> a) -> Maybe (a, a) -> Maybe (a, a) -> Maybe (a, a) 102 | maybePairFunctor _ _ Nothing Nothing = Nothing 103 | maybePairFunctor _ _ Nothing x@(Just (_, _)) = x 104 | maybePairFunctor _ _ x@(Just (_, _)) Nothing = x 105 | maybePairFunctor f1 f2 (Just (a1, a2)) (Just (b1, b2)) = Just (a1 `f1` b1, a2 `f2` b2) 106 | -------------------------------------------------------------------------------- /app/src/Octree.hs: -------------------------------------------------------------------------------- 1 | -- This is a module for constructing bounding volume hierarchies using an octree approach 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | module Octree(generateSceneGraphUsingOctree, splitBoxIntoOctreeChildren, octreeChildBox, Octree(OctreeNode, OctreeLeaf, OctreeDummy), create, Octree.insert, gather) where 5 | 6 | import Vector 7 | import {-# SOURCE #-} Primitive 8 | import BoundingBox 9 | import Misc 10 | 11 | data Octree a = OctreeDummy !AABB 12 | | OctreeNode !AABB [Octree a] 13 | | OctreeLeaf !AABB !(Vector, a) deriving (Eq) 14 | 15 | instance Show a => Show (Octree a) where 16 | show = display 0 17 | 18 | tabs :: String 19 | tabs = '\t' : tabs 20 | 21 | display :: (Show a) => Int -> Octree a -> String 22 | display level (OctreeDummy box) = take level tabs ++ "[Dummy] box=" ++ show box ++ "\n" 23 | display level (OctreeNode box children) = take level tabs ++ "[Node] box=" ++ show box ++ "\n" ++ concatMap (display (level + 1)) children ++ "\n" 24 | display level (OctreeLeaf box (pos, value)) = take level tabs ++ "[Leaf] box=" ++ show box ++ " pos=" ++ show pos ++ " value=" ++ show value ++ "\n" 25 | 26 | create :: AABB -> Octree a 27 | create box = OctreeNode box $ map OctreeDummy (splitBoxIntoOctreeChildren box) 28 | 29 | -- Insert into an octree 30 | insert :: Vector -> a -> Octree a -> Octree a 31 | insert pos a oct = fst $ insert' pos oct (Just a) 32 | 33 | insert' :: Vector -> Octree a -> Maybe a -> (Octree a, Maybe a) 34 | insert' pos oct@(OctreeDummy box) state = case state of 35 | -- If we have been passed some state then attempt to consume it 36 | Just value -> if box `contains` pos 37 | then (OctreeLeaf box (pos, value), Nothing) 38 | else (oct, state) 39 | _ -> (oct, state) 40 | 41 | insert' pos oct@(OctreeNode box nodeChildren) state = if box `contains` pos 42 | then let (nodeChildren', state') = mapS (insert' pos) nodeChildren state 43 | in (OctreeNode box nodeChildren', state') 44 | else (oct, state) 45 | 46 | insert' pos oct@(OctreeLeaf box (pos', a')) state = if box `contains` pos 47 | then 48 | -- First up, we turn this leaf into a node with 8 children 49 | -- Discard result of mapS - we assume it returns Nothing 50 | -- Then, re-insert the original value into our nascent octree 51 | let (!newChildren, _) = mapS (insert' pos) (map OctreeDummy (splitBoxIntoOctreeChildren box)) state 52 | (!octTree', !state') = insert' pos' (OctreeNode box newChildren) (Just a') 53 | in (octTree', state') 54 | else (oct, state) 55 | 56 | -- Gather data within a sphere from an octree 57 | gather :: Position -> Double -> Octree a -> [(a, Double)] 58 | gather pos r (OctreeNode box nodeChildren) = if overlapsSphere box pos r 59 | then concatMap (gather pos r) nodeChildren 60 | else [] 61 | gather pos r (OctreeLeaf _ (pos', a)) 62 | | dSq <= r * r = [(a, dSq)] 63 | | otherwise = [] 64 | where dSq = pos `distanceSq` pos' 65 | gather _ _ (OctreeDummy _) = [] 66 | 67 | -- Generate a scene graph using an octree. Refactor this to just be an octree later 68 | splitBoxIntoOctreeChildren :: AABB -> [AABB] 69 | splitBoxIntoOctreeChildren (Vector xmin ymin zmin _, Vector xmax ymax zmax _) = 70 | [ 71 | (Vector xmin ymin zmin 1, Vector centreX centreY centreZ 1), 72 | (Vector centreX ymin zmin 1, Vector xmax centreY centreZ 1), 73 | (Vector xmin centreY zmin 1, Vector centreX ymax centreZ 1), 74 | (Vector centreX centreY zmin 1, Vector xmax ymax centreZ 1), 75 | 76 | (Vector xmin ymin centreZ 1, Vector centreX centreY zmax 1), 77 | (Vector centreX ymin centreZ 1, Vector xmax centreY zmax 1), 78 | (Vector xmin centreY centreZ 1, Vector centreX ymax zmax 1), 79 | (Vector centreX centreY centreZ 1, Vector xmax ymax zmax 1) 80 | ] 81 | where 82 | centreX = (xmin + xmax) * 0.5 83 | centreY = (ymin + ymax) * 0.5 84 | centreZ = (zmin + zmax) * 0.5 85 | 86 | octreeChildBox :: AABB -> Int -> AABB 87 | octreeChildBox (Vector !xmin !ymin !zmin _, Vector !xmax !ymax ! zmax _) index 88 | = case index of 89 | 0 -> (Vector xmin ymin zmin 1, Vector centreX centreY centreZ 1) 90 | 1 -> (Vector centreX ymin zmin 1, Vector xmax centreY centreZ 1) 91 | 2 -> (Vector xmin centreY zmin 1, Vector centreX ymax centreZ 1) 92 | 3 -> (Vector centreX centreY zmin 1, Vector xmax ymax centreZ 1) 93 | 94 | 4 -> (Vector xmin ymin centreZ 1, Vector centreX centreY zmax 1) 95 | 5 -> (Vector centreX ymin centreZ 1, Vector xmax centreY zmax 1) 96 | 6 -> (Vector xmin centreY centreZ 1, Vector centreX ymax zmax 1) 97 | 7 -> (Vector centreX centreY centreZ 1, Vector xmax ymax zmax 1) 98 | _ -> error "Invalid index" 99 | where 100 | !centreX = (xmin + xmax) * 0.5 101 | !centreY = (ymin + ymax) * 0.5 102 | !centreZ = (zmin + zmax) * 0.5 103 | 104 | -- Octree code that's spilt out from other modules... this is scene graph specific helper code rather than self-contained octree stuff 105 | 106 | -- Take a list of objects and split it into a list of objects that intersect a box, and those that don't 107 | objectsIntersectingBox :: [Object] -> AABB -> ([Object], [Object]) 108 | objectsIntersectingBox objects box = objectsIntersectingBox' objects box ([], []) 109 | 110 | objectsIntersectingBox' :: [Object] -> AABB -> ([Object], [Object]) -> ([Object], [Object]) 111 | objectsIntersectingBox' (obj:objs) box (currentHit, currentMiss) = if intersectsBox (primitive obj) (transform obj) box 112 | then objectsIntersectingBox' objs box (obj : currentHit, currentMiss) 113 | else objectsIntersectingBox' objs box (currentHit, obj : currentMiss) 114 | objectsIntersectingBox' [] _ (currentHit, currentMiss) = (currentHit, currentMiss) 115 | 116 | -- Iterator function. Match up objects to this box, and then iterate with the remainder 117 | assignObjectsToOctreeBoxes' :: [Object] -> [AABB] -> [[Object]] -> [[Object]] 118 | assignObjectsToOctreeBoxes' objs (box:boxes) (x:xs) = assignObjectsToOctreeBoxes' remainingObjects boxes (matchedObjects : x : xs) 119 | where 120 | (matchedObjects, remainingObjects) = objectsIntersectingBox objs box 121 | assignObjectsToOctreeBoxes' _ [] currentList = currentList 122 | assignObjectsToOctreeBoxes' objs (box:boxes) [] = assignObjectsToOctreeBoxes' remainingObjects boxes [matchedObjects] 123 | where 124 | (matchedObjects, remainingObjects) = objectsIntersectingBox objs box 125 | 126 | -- Generate the list of objects for each bounding box 127 | assignObjectsToOctreeBoxes :: [Object] -> [AABB] -> [[Object]] 128 | assignObjectsToOctreeBoxes objects boxes = assignObjectsToOctreeBoxes' objects boxes [] 129 | 130 | -- Make children using an octree algorithm 131 | generateSceneGraphUsingOctree :: [Object] -> [[Object]] 132 | generateSceneGraphUsingOctree (obj:objs) 133 | | not (boundingBoxValid nodeBox) = error "Invalid bounding box" 134 | | otherwise = onlyPopulatedBoxes 135 | where 136 | nodeBox = objectListBoundingBox (obj:objs) 137 | octreeBoxes = splitBoxIntoOctreeChildren nodeBox 138 | objsPerOctreeBox = assignObjectsToOctreeBoxes (obj:objs) octreeBoxes 139 | onlyPopulatedBoxes = filter (\x -> length x > 0) objsPerOctreeBox 140 | generateSceneGraphUsingOctree [] = [] 141 | -------------------------------------------------------------------------------- /app/src/PhotonMap.hs: -------------------------------------------------------------------------------- 1 | -- Photon mapping 2 | 3 | module PhotonMap(buildPhotonMap, PhotonMap(photonList), irradiance, PhotonMapContext(PhotonMapContext)) where 4 | 5 | import PolymorphicNum 6 | import {-# SOURCE #-} Light hiding (position) 7 | import Vector 8 | import Distribution 9 | import Material 10 | import Colour 11 | import SceneGraph 12 | import {-# SOURCE #-} RayTrace 13 | import Ray hiding (direction) 14 | import Control.Monad.State 15 | import BoundingBox 16 | import KDTree 17 | import Debug.Trace 18 | import Misc 19 | import Control.Parallel.Strategies 20 | import Control.DeepSeq 21 | import Data.Heap hiding (partition) 22 | import System.Random 23 | import Data.List hiding (union, insert) 24 | import Primitive 25 | import RussianRoulette 26 | 27 | data PhotonMapContext = PhotonMapContext { 28 | photonGatherDistance :: Double, 29 | maxGatherPhotons :: Int, 30 | coneFilterK :: Double, 31 | directVisualisation :: Bool } 32 | 33 | data Photon = Photon { power :: {-# UNPACK #-} !Colour, posDir :: {-# UNPACK #-} !(Position, Direction) } deriving (Show, Eq, Ord) 34 | 35 | data PhotonMapTree = PhotonMapNode {-# UNPACK #-} !Int {-# UNPACK #-} !Double PhotonMapTree PhotonMapTree 36 | | PhotonMapLeaf {-# UNPACK #-} !Photon deriving (Show, Eq) 37 | 38 | data PhotonMap = PhotonMap { photonList :: [Photon], 39 | photonMapTree :: PhotonMapTree } deriving(Show, Eq) 40 | 41 | instance NFData Photon where 42 | rnf (Photon power' posDir') = rnf power' `seq` rnf posDir' 43 | 44 | -- TODO - I would ideally like to eliminate this... but it's really not that big of a deal 45 | randomNumberGenerator :: StdGen 46 | randomNumberGenerator = mkStdGen 12345 47 | 48 | -- Generate a list of photon position and direction tuples to emit 49 | -- I zip up each pos,dir tuple with a random number generator to give each photon a different sequence of random values 50 | -- Helps parallelisation... 51 | -- TODO Eliminate magic number seeds from here 52 | emitPhotons :: Light -> Int -> [(Position, Direction, StdGen, Colour)] 53 | emitPhotons (PointLight (CommonLightData lightPower True) pos _) numPhotons = zipWith (\dir num -> (pos, dir, mkStdGen num, flux)) (fst $ generatePointsOnSphere numPhotons 1 randomNumberGenerator) [1..numPhotons] 54 | where 55 | flux = lightPower <*> ((1.0 / fromIntegral numPhotons) :: Double) 56 | emitPhotons (QuadLight (CommonLightData lightPower True) corner _ du dv) numPhotons = zipWith3 (\pos dir num -> (pos, transformDir dir tanSpace, mkStdGen num, flux)) randomPoints randomDirs [1..numPhotons] 57 | where 58 | randomPoints = fst $ generatePointsOnQuad corner du dv numPhotons randomNumberGenerator 59 | randomDirs = fst $ generatePointsOnHemisphere numPhotons 1 randomNumberGenerator 60 | area = Vector.magnitude (du `cross` dv) 61 | flux = lightPower <*> (area / fromIntegral numPhotons) 62 | tanSpace = (normalise du, normalise dv, normalise (du `cross` dv)) 63 | emitPhotons _ _ = [] 64 | 65 | -- Decide what to do with a photon 66 | choosePhotonFate :: (RandomGen g) => (Double, Double) -> State g RussianRouletteChoice 67 | choosePhotonFate (diffuseP, specularP) = do 68 | p <- randDouble 69 | let result | p < diffuseP = DiffuseReflect 70 | | p < (diffuseP + specularP) = SpecularReflect 71 | | otherwise = Absorb 72 | return $! result 73 | 74 | -- Compute new power for a photon 75 | computeNewPhotonPower :: RussianRouletteChoice -> (Double, Double) -> Colour -> Material -> Colour 76 | computeNewPhotonPower fate (diffuseP, specularP) photonPower mat = case fate of 77 | DiffuseReflect -> photonPower <*> diffuse mat diffuseP 78 | SpecularReflect -> photonPower <*> specular mat specularP 79 | Absorb -> colBlack 80 | 81 | -- Find a diffuse reflection direction in the hemisphere of the normal 82 | -- Realistic Image Synthesis Using Photon Mapping - Eq 2.24 83 | diffuseReflectionDirection :: (RandomGen g) => g -> TangentSpace -> (Direction, g) 84 | diffuseReflectionDirection stdGen tanSpace = (transformDir dir tanSpace, stdGen') 85 | where 86 | (uv, stdGen') = runState randomUV stdGen 87 | dir = uvToHemisphere 1 0 uv 88 | 89 | -- Main working photon tracing function 90 | -- Realistic Image Synthesis Using Photon Mapping p60 91 | tracePhoton :: (RandomGen g) => [Photon] -> Photon -> SceneGraph -> g -> (Int, Int) -> [Photon] 92 | tracePhoton currentPhotons (Photon photonPower photonPosDir) sceneGraph rndState (bounce, maxBounces) = 93 | -- See if the photon intersects a surfaces 94 | case findNearestIntersection sceneGraph ray of 95 | Nothing -> currentPhotons 96 | Just (obj, t, tanSpace) -> case photonFate of 97 | -- Diffuse reflection. Here, we store the photon that got reflected, and trace a new photon - but only if it's bright enough to be worthwhile 98 | DiffuseReflect -> if Colour.magnitude newPhotonPower > brightnessEpsilon && (bounce + 1) <= maxBounces 99 | then tracePhoton (storedPhoton : currentPhotons) reflectedPhoton sceneGraph rndState'' (bounce + 1, maxBounces) 100 | else storedPhoton : currentPhotons 101 | where 102 | reflectedPhoton = Photon newPhotonPower (surfacePos, reflectedDir) 103 | (reflectedDir, rndState'') = diffuseReflectionDirection rndState' tanSpace 104 | 105 | -- Specular reflection. Here, we reflect the photon in the fashion that the surface would reflect towards the viewer and 106 | -- aim to absorb it somewhere else in the photon map 107 | SpecularReflect -> if Colour.magnitude newPhotonPower > brightnessEpsilon && (bounce + 1) <= maxBounces 108 | then tracePhoton currentPhotons reflectedPhoton sceneGraph rndState' (bounce + 1, maxBounces) 109 | else currentPhotons 110 | where 111 | reflectedPhoton = Photon newPhotonPower (surfacePos, reflectedDir) 112 | reflectedDir = Vector.negate (snd photonPosDir) `reflect` normal 113 | 114 | -- Absorb. The photon simply gets absorbed into the map 115 | Absorb -> storedPhoton : currentPhotons 116 | where 117 | (photonFate, rndState') = runState (choosePhotonFate coefficients) rndState 118 | coefficients = russianRouletteCoefficients (material obj) 119 | newPhotonPower = computeNewPhotonPower photonFate coefficients photonPower (material obj) 120 | normal = thr tanSpace 121 | hitPosition = pointAlongRay ray t 122 | surfacePos = hitPosition <+> normal <*> surfaceEpsilon 123 | brightnessEpsilon = 0.1 124 | storedPhoton = Photon photonPower (surfacePos, snd photonPosDir) 125 | where 126 | ray = rayWithPosDir photonPosDir 10000 127 | 128 | -- Build a list of photons for a light source 129 | tracePhotonsForLight :: Int -> SceneGraph -> Light -> [Photon] 130 | tracePhotonsForLight numPhotons sceneGraph light = concat (map (\(pos, dir, rndState, flux) -> tracePhoton [] (Photon flux (pos, dir)) sceneGraph rndState (0, maxBounces)) posDirGens `using` parListChunk photonsPerChunk rdeepseq) 131 | where 132 | posDirGens = emitPhotons light numPhotons -- Positions, directions, random number generators 133 | maxBounces = 500 134 | photonsPerChunk = 256 135 | 136 | -- High-level function to build a photon map 137 | buildPhotonMap :: SceneGraph -> [Light] -> Int -> (PhotonMap, [Light]) 138 | buildPhotonMap sceneGraph lights numPhotonsPerLight = photons `seq` kdTree `seq` (PhotonMap photons kdTree, lightsNotForPhotonMap) 139 | where 140 | (lightsForPhotonMap, lightsNotForPhotonMap) = partition (addToPhotonMap . common) lights 141 | photons = concatMap (tracePhotonsForLight numPhotonsPerLight sceneGraph) lightsForPhotonMap 142 | kdTree = buildKDTree photons 143 | 144 | -- Make a bounding box of a list of photons 145 | photonsBoundingBox :: [Photon] -> AABB 146 | photonsBoundingBox = foldl' (\box photon -> boundingBoxEnlarge (fst . posDir $ photon) box) initialInvalidBox 147 | 148 | -- Construct a balanced kd tree of photons 149 | -- Realistic Image Synthesis Using Photon Mapping p72 150 | buildKDTree :: [Photon] -> PhotonMapTree 151 | buildKDTree (x:[]) = PhotonMapLeaf x 152 | buildKDTree [] = error "buildKDTree [] should never get called" 153 | buildKDTree photons = let (boxMin, boxMax) = photonsBoundingBox photons 154 | axis = largestAxis (boxMax <-> boxMin) 155 | numPhotons = fromIntegral (length photons) :: Double 156 | photonsMedian = foldl' (\box photon -> box <+> (fst . posDir $ photon)) zeroVector photons numPhotons 157 | value = component photonsMedian axis 158 | photonsGT = Prelude.filter (\p -> component ((fst . posDir) p) axis > value) photons 159 | photonsLE = Prelude.filter (\p -> component ((fst . posDir) p) axis <= value) photons 160 | in if length photonsGT > 0 && length photonsLE > 0 161 | then let gtTree = buildKDTree photonsGT 162 | leTree = buildKDTree photonsLE 163 | in gtTree `seq` leTree `seq` PhotonMapNode axis value gtTree leTree 164 | else let (photons0', photons1') = trace "Using degenerate case" $ degenerateSplitList photons in PhotonMapNode axis value (buildKDTree photons0') (buildKDTree photons1') 165 | 166 | -- Use a max heap to make it easy to eliminate distant photons 167 | data GatheredPhoton = GatheredPhoton Double Photon deriving (Show) 168 | type PhotonHeap = MaxHeap GatheredPhoton 169 | 170 | instance Ord GatheredPhoton where 171 | compare (GatheredPhoton dist1 _) (GatheredPhoton dist2 _) = dist1 `compare` dist2 172 | 173 | instance Eq GatheredPhoton where 174 | (GatheredPhoton dist1 _) == (GatheredPhoton dist2 _) = dist1 == dist2 175 | 176 | instance NFData GatheredPhoton where 177 | rnf (GatheredPhoton dist photon) = rnf dist `seq` rnf photon 178 | 179 | -- Return the minimum squared search radius from that specified, versus the furthest photon in the heap 180 | -- We don't want to locate any photons further away than our current furthest - we're looking for the closest ones, after all 181 | minimalSearchRadius :: Double -> PhotonHeap -> Double 182 | minimalSearchRadius rSq photonHeap = case viewHead photonHeap of 183 | Nothing -> rSq 184 | Just (GatheredPhoton dSq _) -> Prelude.min rSq dSq 185 | 186 | -- Gather photons for irradiance computations 187 | -- Algorithm adapted from Realistic Image Synthesis Using Photon Mapping p73 188 | gatherPhotons :: PhotonMapTree -> Position -> Double -> PhotonHeap -> Int -> PhotonHeap 189 | gatherPhotons (PhotonMapNode axis value gtChild leChild) pos rSq photonHeap maxPhotons 190 | -- In this case, the split plane bisects the search sphere - search both halves of tree 191 | | (value - posComponent) ** 2 <= rSq = let heap1 = gatherPhotons gtChild pos rSq' photonHeap maxPhotons 192 | rSq'' = minimalSearchRadius rSq' heap1 193 | heap2 = gatherPhotons leChild pos rSq'' photonHeap maxPhotons 194 | newHeap = union heap1 heap2 195 | in heap1 `seq` heap2 `seq` newHeap `seq` Data.Heap.drop (size newHeap - maxPhotons) newHeap 196 | 197 | -- One side of the tree... 198 | | posComponent > value = gatherPhotons gtChild pos rSq' photonHeap maxPhotons 199 | 200 | -- ... or the other 201 | | posComponent <= value = gatherPhotons leChild pos rSq' photonHeap maxPhotons 202 | 203 | -- Prolapse 204 | | otherwise = error "gatherPhotons: unexplained/unexpected case here" 205 | where 206 | posComponent = component pos axis 207 | rSq' = minimalSearchRadius rSq photonHeap -- Refine search radius as we go down tree to search no further than closest allowed photon 208 | gatherPhotons (PhotonMapLeaf p) pos rSq photonHeap maxPhotons 209 | | distSq < rSq = let newHeap = insert (GatheredPhoton distSq p) photonHeap 210 | in Data.Heap.drop (size newHeap - maxPhotons) newHeap -- Discard any excess photons - we get rid of the furthest ones 211 | | otherwise = photonHeap 212 | where distSq = pos `distanceSq` (fst . posDir) p 213 | 214 | -- Return the contribution of a given photon, including a simple cos term to emulate BRDF plus the cone filter 215 | -- Cone filter is from Realistic Image Synthesis Using Photon Mapping p81 216 | photonContribution :: Double -> SurfaceLocation -> Photon -> Colour 217 | photonContribution kr (pos, (_, _, normal)) photon = power photon <*> ((Vector.negate normal `sdot3` (snd . posDir) photon) * weight) 218 | where 219 | weight = 1 - (pos `distance` (fst . posDir) photon) / (kr + 0.000000001) -- Add on an epsilon to prevent div0 in cone filter 220 | 221 | -- Find the overall contribution of a list of photons 222 | -- Radiance estimate algorithm from Realistic Image Synthesis Using Photon Mapping p81 223 | sumPhotonContribution :: Double -> Double -> SurfaceLocation -> [Photon] -> Colour 224 | sumPhotonContribution r k posTanSpace photons = foldl' (\y x -> y <+> photonContribution (k * r) posTanSpace x) colBlack photons <*> (1.0 / ((1.0 - 2.0 / (3.0 * k)) * pi * r * r)) 225 | 226 | -- Look up the resulting irradiance from the photon map at a given point 227 | -- Realistic Image Synthesis Using Photon Mapping, e7.6 228 | irradiance :: PhotonMap -> PhotonMapContext -> Material -> SurfaceLocation -> (Colour, Double) 229 | irradiance photonMap photonMapContext mat posTanSpace = (sumPhotonContribution r k posTanSpace gatheredPhotons <*> diffuse mat, harmonicMean $ map (\(GatheredPhoton dist _) -> sqrt dist) nearestPhotons) 230 | where 231 | r = photonGatherDistance photonMapContext 232 | maxPhotons 233 | | directVisualisation photonMapContext = 1 234 | | otherwise = maxGatherPhotons photonMapContext 235 | k = coneFilterK photonMapContext 236 | photonHeap = gatherPhotons (photonMapTree photonMap) (fst posTanSpace) (r * r) Data.Heap.empty maxPhotons 237 | nearestPhotons = Data.Heap.take maxPhotons photonHeap 238 | gatheredPhotons = map (\(GatheredPhoton _ photon) -> photon) nearestPhotons 239 | -------------------------------------------------------------------------------- /app/src/PhotonMap.hs-boot: -------------------------------------------------------------------------------- 1 | -- Photon mapping 2 | 3 | module PhotonMap(buildPhotonMap, PhotonMap(photonList), irradiance, PhotonMapContext(PhotonMapContext)) where 4 | 5 | --import PolymorphicNum 6 | import {-# SOURCE #-} Light hiding (position) 7 | import Vector 8 | --import Distribution 9 | import Material 10 | import Colour 11 | import SceneGraph 12 | --import Ray hiding (direction) 13 | --import Control.Monad.State 14 | --import BoundingBox 15 | --import KDTree 16 | --import Debug.Trace 17 | --import Misc 18 | --import Control.Parallel.Strategies 19 | --import Control.DeepSeq 20 | --import Data.Heap hiding (partition) 21 | --import System.Random 22 | --import Data.List hiding (union, insert) 23 | --import Primitive 24 | --import RussianRoulette 25 | 26 | data PhotonMapContext = PhotonMapContext { 27 | photonGatherDistance :: Double, 28 | maxGatherPhotons :: Int, 29 | coneFilterK :: Double, 30 | directVisualisation :: Bool } 31 | 32 | data Photon = Photon { power :: {-# UNPACK #-} !Colour, posDir :: {-# UNPACK #-} !(Position, Direction) } 33 | 34 | data PhotonMapTree = PhotonMapNode {-# UNPACK #-} !Int {-# UNPACK #-} !Double PhotonMapTree PhotonMapTree 35 | | PhotonMapLeaf {-# UNPACK #-} !Photon 36 | 37 | data PhotonMap = PhotonMap { photonList :: [Photon], 38 | photonMapTree :: PhotonMapTree } 39 | 40 | buildPhotonMap :: SceneGraph -> [Light] -> Int -> (PhotonMap, [Light]) 41 | irradiance :: PhotonMap -> PhotonMapContext -> Material -> SurfaceLocation -> (Colour, Double) 42 | -------------------------------------------------------------------------------- /app/src/PolymorphicNum.hs: -------------------------------------------------------------------------------- 1 | -- Module for a generic typeclass to bind together my linear algebra maths - vectors, matrices - rather than instancing off Num 2 | 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | 6 | module PolymorphicNum where 7 | 8 | class PolymorphicNum a b c | a b -> c where 9 | (<*>) :: a -> b -> c 10 | () :: a -> b -> c 11 | (<->) :: a -> b -> c 12 | (<+>) :: a -> b -> c 13 | infixl 7 <*> 14 | infixl 7 15 | infixl 6 <+> 16 | infixl 6 <-> 17 | -------------------------------------------------------------------------------- /app/src/Primitive.hs: -------------------------------------------------------------------------------- 1 | -- Module for general primitives and intersections 2 | 3 | module Primitive (primitiveBoundingRadius, 4 | primitiveClosestIntersect, 5 | primitiveAnyIntersect, 6 | Object(Object), 7 | Primitive(Sphere, Plane, TriangleMesh, Box, SparseOctreeModel), 8 | primitive, 9 | material, 10 | makeQuad, 11 | makeTriangleWithTangents, 12 | makeTriangle, 13 | quadsToTriangles, 14 | vertPosition, 15 | vertUV, 16 | vertTangentSpace, 17 | transform, 18 | radius, 19 | triangles, 20 | getCentre, 21 | planeDistance, 22 | primitiveBoundingBox, 23 | objectListBoundingBox, 24 | intersectsBox, 25 | infinite, 26 | boundingBoxValid, 27 | sphereIntersect, 28 | makePlane, 29 | intersectRayTriangle, 30 | TangentSpace, 31 | Vertex, 32 | bounds, 33 | svo) where 34 | 35 | import PolymorphicNum 36 | import Ray 37 | import Vector 38 | import Material 39 | import Matrix 40 | import BoundingBox 41 | import Data.Maybe 42 | import Data.List 43 | import {-# SOURCE #-} SparseVoxelOctree 44 | 45 | -- Triangle object used for triangle meshes 46 | data Vertex = Vertex { vertPosition :: {-# UNPACK #-} !Position, 47 | vertUV :: {-# UNPACK #-} !Position, 48 | vertTangentSpace :: {-# UNPACK #-} !TangentSpace } deriving (Show, Eq) 49 | data Triangle = Triangle { vertices :: ![Vertex], plane :: !Primitive, halfPlanes :: ![Primitive] } deriving (Show, Eq) 50 | 51 | -- General object definition 52 | data Object = Object { primitive :: Primitive, 53 | material :: Material, 54 | transform :: !Matrix} deriving (Show, Eq) 55 | 56 | -- Different kinds of primitives that an object can have 57 | data Primitive = Sphere { radius :: {-# UNPACK #-} !Double } 58 | | Plane { planeTangentSpace :: {-# UNPACK #-} !TangentSpace, planeDistance :: {-# UNPACK #-} !Double } 59 | | TriangleMesh { triangles :: [Triangle] } 60 | | Box { bounds :: {-# UNPACK #-} !AABB } 61 | | SparseOctreeModel { svo :: SparseOctree } deriving (Show, Eq) 62 | 63 | -- Get the centre of an object 64 | getCentre :: Object -> Vector 65 | getCentre object = getTranslation $ transform object 66 | 67 | -- Surface normal for 3 points 68 | surfaceNormal :: Position -> Position -> Position -> Direction 69 | surfaceNormal v1 v2 v3 = (v2 <-> v1) `cross` (v3 <-> v1) 70 | 71 | -- Make a tangent spac 72 | triangleTangentSpace :: Position -> Position -> Position -> TangentSpace 73 | triangleTangentSpace v1 v2 v3 = (tangent, binormal, normal) 74 | where 75 | normal = normalise (surfaceNormal v1 v2 v3) 76 | tangent = normalise (v2 <-> v1) 77 | binormal = normalise (normal `cross` tangent) 78 | 79 | -- Make a plane 80 | makePlane :: Position -> Position -> Position -> Primitive 81 | makePlane v1 v2 v3 = Plane tanSpace (-(v1 `dot3` normal)) 82 | where 83 | tanSpace@(_, _, normal) = triangleTangentSpace v1 v2 v3 84 | 85 | makePlaneWithTangents :: Position -> Position -> Position -> Direction -> Direction -> Primitive 86 | makePlaneWithTangents v1 v2 v3 tangent binormal = Plane (tangent, binormal, normal) (-(v1 `dot3` normal)) 87 | where 88 | normal = normalise (surfaceNormal v1 v2 v3) 89 | 90 | -- ------------------------------------------------------------------------------------------------------------------------------------------------------------------- 91 | -- Triangle base functionality 92 | 93 | -- Make a triangle 94 | makeTriangle :: Position -> Position -> Position -> Triangle 95 | makeTriangle v1 v2 v3 = makeTriangleWithTangents v1 v2 v3 tangent binormal 96 | where 97 | (tangent, binormal, _) = triangleTangentSpace v1 v2 v3 98 | 99 | makeTriangleWithTangents :: Position -> Position -> Position -> Direction -> Direction -> Triangle 100 | makeTriangleWithTangents v1 v2 v3 tangent binormal = Triangle verts newPlane newHalfPlanes 101 | where newPlane = makePlaneWithTangents v1 v2 v3 tangent binormal 102 | newTanSpace = planeTangentSpace newPlane 103 | verts = map (\v -> Vertex v zeroVector newTanSpace) [v1, v2, v3] 104 | edgeVertices = [v1, v2, v3] 105 | edges = map normalise [v2 <-> v1, v3 <-> v2, v1 <-> v3] 106 | edgeNormals = map (\edge -> normalise (tsNormal newTanSpace `cross` edge)) edges 107 | newHalfPlanes = zipWith3 (\edgeNormal edgeVertex edgeDir -> Plane (edgeDir, tsNormal newTanSpace, edgeNormal) (-(edgeNormal `dot3` edgeVertex))) edgeNormals edgeVertices edges 108 | 109 | makeQuad :: [Position] -> [Triangle] 110 | makeQuad [vert1, vert2, vert3, vert4] = [makeTriangleWithTangents vert1 vert2 vert3 tangent binormal, 111 | makeTriangleWithTangents vert1 vert3 vert4 tangent binormal] 112 | where 113 | tangent = normalise (vert2 <-> vert1) 114 | binormal = normalise (vert3 <-> vert1) 115 | makeQuad _ = error "makeQuad: List was invalid size" 116 | 117 | -- Turn a list of quad vertices into a triangle list 118 | quadsToTriangles :: [Position] -> [Triangle] 119 | quadsToTriangles positions = quadsToTriangles' positions [] 120 | where 121 | quadsToTriangles' verts currentList 122 | | length verts >= 4 = quadsToTriangles' (drop 4 verts) (currentList ++ makeQuad (take 4 verts)) 123 | | otherwise = currentList 124 | 125 | -- Area of a triangle 126 | triangleArea :: Position -> Position -> Position -> Double 127 | triangleArea v1 v2 v3 = 0.5 * magnitude (surfaceNormal v1 v2 v3) 128 | 129 | -- Calculate the barycentric co-ordinates of a point on a triangle 130 | calculateBarycentricCoordinates :: Position -> Triangle -> (Double, Double, Double) 131 | calculateBarycentricCoordinates pos triangle = (alpha, beta, gamma) 132 | where alpha = triangleArea pos v2 v3 / area 133 | beta = triangleArea pos v1 v3 / area 134 | gamma = 1 - alpha - beta 135 | area = triangleArea v1 v2 v3 136 | [v1, v2, v3] = map vertPosition (vertices triangle) 137 | 138 | -- Distance to a plane 139 | distanceToPlane :: Primitive -> Vector -> Double 140 | distanceToPlane (Plane (_, _, norm) dist) pos = (pos `dot3` norm) + dist 141 | distanceToPlane _ _ = error "distanceToPlane: Unsupported primitive for this function" 142 | 143 | -- Use halfplanes to test if a point is inside a triangle 144 | pointInsideTriangle :: Triangle -> Position -> Bool 145 | pointInsideTriangle tri point = all (\pln -> distanceToPlane pln point >= 0) (halfPlanes tri) 146 | 147 | {- 148 | pointInsideTriangleBary :: Triangle -> Position -> Bool 149 | pointInsideTriangleBary tri point = u >= 0 && v >= 0 && (u + v) < 1 150 | where 151 | [a, b, c] = map vertPosition (vertices tri) 152 | v0 = c <-> a 153 | v1 = b <-> a 154 | v2 = point <-> a 155 | 156 | dot00 = v0 `dot3` v0 157 | dot01 = v0 `dot3` v1 158 | dot02 = v0 `dot3` v2 159 | 160 | dot11 = v1 `dot3` v1 161 | dot12 = v1 `dot3` v2 162 | 163 | invDenom = 1 / (dot00 * dot11 - dot01 * dot01) 164 | u = (dot11 * dot02 - dot01 * dot12) * invDenom 165 | v = (dot00 * dot12 - dot01 * dot02) * invDenom 166 | -} 167 | 168 | -- Intersect a ray with a triangle 169 | intersectRayTriangle :: Ray -> Triangle -> Bool -> (Bool, Double, Triangle) 170 | intersectRayTriangle ray triangle doubleSided 171 | | not doubleSided && direction ray `dot3` (tsNormal . planeTangentSpace . plane) triangle >= 0 = (False, 0, triangle) 172 | | otherwise = case planeIntersect (plane triangle) ray of 173 | Nothing -> (False, 0, triangle) 174 | Just (dist', _) -> if pointInsideTriangle triangle (pointAlongRay ray dist') 175 | then (True, dist', triangle) 176 | else (False, 0, triangle) 177 | 178 | -- Intersect against a list of triangles 179 | intersectRayTriangleList :: [Triangle] -> Int -> Maybe (Double, TangentSpace) -> Ray -> Object -> Maybe (Double, TangentSpace) 180 | intersectRayTriangleList (x:xs) index acc ray obj = intersectRayTriangleList xs (index + 1) acc' ray' obj 181 | where 182 | (ray', acc') = case intersectRayTriangle ray x False of 183 | (False, _, _) -> (ray, acc) 184 | (True, dist, _) -> let intersectionPoint = pointAlongRay ray dist 185 | (triAlpha, triBeta, triGamma) = calculateBarycentricCoordinates intersectionPoint x 186 | in (shortenRay ray dist, Just (dist, interpolatedTangentSpace x triAlpha triBeta triGamma)) 187 | intersectRayTriangleList [] _ acc _ _ = acc 188 | 189 | -- Intersect against any triangle 190 | intersectRayAnyTriangleList :: [Triangle] -> Int -> Ray -> Object -> Maybe (Double, TangentSpace) 191 | intersectRayAnyTriangleList (x:xs) index ray obj = case intersectRayTriangle ray x False of 192 | (False, _, _) -> intersectRayAnyTriangleList xs (index + 1) ray obj 193 | (True, dist, _) -> let intersectionPoint = pointAlongRay ray dist 194 | (triAlpha, triBeta, triGamma) = calculateBarycentricCoordinates intersectionPoint x 195 | in Just (dist, interpolatedTangentSpace x triAlpha triBeta triGamma) 196 | intersectRayAnyTriangleList [] _ _ _ = Nothing 197 | 198 | -- Get the interpolated vertex normal 199 | interpolatedTangentSpace :: Triangle -> Double -> Double -> Double -> TangentSpace 200 | interpolatedTangentSpace triangle triAlpha triBeta triGamma = (tangent, binormal, normal) 201 | where [(tan1, bi1, norm1), (tan2, bi2, norm2), (tan3, bi3, norm3)] = map vertTangentSpace (vertices triangle) 202 | tangent = normalise $ tan1 <*> triAlpha <+> tan2 <*> triBeta <+> tan3 <*> triGamma 203 | binormal = normalise $ bi1 <*> triAlpha <+> bi2 <*> triBeta <+> bi3 <*> triGamma 204 | normal = normalise $ norm1 <*> triAlpha <+> norm2 <*> triBeta <+> norm3 <*> triGamma 205 | 206 | planeIntersect :: Primitive -> Ray -> Maybe (Double, TangentSpace) 207 | planeIntersect (Plane planeTanSpace@(_, _, planeNormal) planeD) (Ray rayOrg rayDir _ rayLen) 208 | | dirDotNormal == 0 = Nothing 209 | | intercept >= 0 && intercept <= rayLen = Just (intercept, planeTanSpace) 210 | | otherwise = Nothing 211 | where dirDotNormal = rayDir `dot3` planeNormal 212 | intercept = ((-planeD) - (rayOrg `dot3` planeNormal)) / dirDotNormal 213 | planeIntersect _ _ = error "planeIntersect was called for an inappropriate primitive type" -- only available for this case 214 | 215 | -- ------------------------------------------------------------------------------------------------------------------------------------------------------------------- 216 | -- Family of intersection functions 217 | primitiveClosestIntersect :: Primitive -> Ray -> Object -> Maybe (Double, TangentSpace) 218 | 219 | -- This function intersects a ray with a sphere, and returns the closest intercept 220 | primitiveClosestIntersect (Sphere sphereRadius) ray@(Ray rayOrg rayDir _ rayLen) obj 221 | | discriminant < 0 = Nothing 222 | | discriminant == 0 = Just ((-b) ** (0.5 :: Double), tanSpace $ (-b) ** (0.5 :: Double)) 223 | | root1 >= 0 && root1 <= rayLen = Just (root1, tanSpace root1) 224 | | root2 >= 0 && root2 <= rayLen = Just (root2, tanSpace root2) 225 | | otherwise = Nothing 226 | where 227 | delta = rayOrg <-> getCentre obj 228 | b = 2 * (delta `dot3` rayDir) 229 | c = (delta `dot3` delta) - sphereRadius ** 2 230 | discriminant = b ** 2 - 4 * c -- A is 1 because the ray direction is normalised 231 | root1 = ((-b) - sqrt discriminant) * 0.5 232 | root2 = ((-b) + sqrt discriminant) * 0.5 233 | tanSpace d = let tangent = Vector 1 0 0 0 -- TODO - This is clearly incorrect - fix this later! 234 | binormal = Vector 0 1 0 0 235 | normal = (pointAlongRay ray d <-> getCentre obj) <*> (1 / sphereRadius) 236 | in (tangent, binormal, normal) 237 | 238 | -- This function intersects a ray with a plane and returns the closest intercept 239 | primitiveClosestIntersect pln@(Plane (_, _, _) _) ray _ = planeIntersect pln ray 240 | 241 | -- Find intersection with a triangle mesh 242 | primitiveClosestIntersect (TriangleMesh tris) ray obj = intersectRayTriangleList tris 0 Nothing ray obj 243 | 244 | -- TODO Need to transform ray by inverse object matrix 245 | primitiveClosestIntersect (Box aabb) ray _ = case boundingBoxIntersectRay aabb ray of Nothing -> Nothing 246 | Just (d, _) -> Just (d, boundingBoxTangentSpace aabb (pointAlongRay ray d)) 247 | 248 | -- TODO Need to transform ray by inverse object matrix 249 | primitiveClosestIntersect (SparseOctreeModel svo') ray _ = SparseVoxelOctree.closestIntersect ray 0 50 lodScaler svo' 250 | where 251 | lodScaler = 500 -- resolution * fov * k 252 | 253 | primitiveAnyIntersect :: Primitive -> Ray -> Object -> Maybe (Double, TangentSpace) 254 | primitiveAnyIntersect (TriangleMesh tris) ray obj = intersectRayAnyTriangleList tris 0 ray obj 255 | primitiveAnyIntersect (SparseOctreeModel svo') ray _ = SparseVoxelOctree.anyIntersect ray 0 50 lodScaler svo' -- TODO Need to transform ray by inverse object matrix 256 | where 257 | lodScaler = 500 -- resolution * fov * k 258 | primitiveAnyIntersect primitive' ray obj = primitiveClosestIntersect primitive' ray obj 259 | 260 | -- ------------------------------------------------------------------------------------------------------------------------------------------------------------------- 261 | -- Family of bounding radius functions (post-xfrom by localToWorld matrix) 262 | primitiveBoundingRadius :: Primitive -> Matrix -> Vector -> Double 263 | 264 | primitiveBoundingRadius (Sphere sphereRadius) xform pos = sphereRadius + (pos `distance` getTranslation xform) 265 | primitiveBoundingRadius (Plane _ _) _ _ = 0 266 | primitiveBoundingRadius (TriangleMesh tris) xform centre = maximum (map triangleRadius tris) 267 | where 268 | triangleRadius tri = maximum (map (\v -> centre `distance` (xform `transformVector` vertPosition v)) (vertices tri)) 269 | 270 | primitiveBoundingRadius (Box (boxMin, boxMax)) xform pos = (boxMin `distance` boxMax) + (pos `distance` getTranslation xform) -- TODO - need to factor in world matrix 271 | primitiveBoundingRadius (SparseOctreeModel svo_) xform pos = boundingRadius svo_ + (pos `distance` getTranslation xform) 272 | 273 | 274 | -- ------------------------------------------------------------------------------------------------------------------------------------------------------------------- 275 | -- Family of bounding box functions 276 | 277 | -- Find the bounding box of a primitive in world space 278 | primitiveBoundingBox :: Primitive -> Object -> Maybe AABB 279 | primitiveBoundingBox (Sphere sphereRadius) obj = Just (boxMin, boxMax) 280 | where 281 | boxMin = getCentre obj <-> Vector sphereRadius sphereRadius sphereRadius 0 282 | boxMax = getCentre obj <+> Vector sphereRadius sphereRadius sphereRadius 0 283 | primitiveBoundingBox (Plane _ _) _ = Nothing 284 | primitiveBoundingBox (TriangleMesh tris) obj = Just $ triangleListBoundingBox initialInvalidBox (transform obj) tris 285 | primitiveBoundingBox (Box box) _ = Just box -- TODO Need to transform this by object's matrix 286 | primitiveBoundingBox (SparseOctreeModel svo_) _ = Just $ boundingBox svo_ -- TODO need to transform by this object's matrix 287 | 288 | -- Bounding box of a list of something 289 | triangleListBoundingBox :: AABB -> Matrix -> [Triangle] -> AABB 290 | triangleListBoundingBox currentBox transformMatrix (tri:tris) = triangleListBoundingBox (boundingBoxUnion currentBox thisTriangleBox) transformMatrix tris 291 | where 292 | worldSpaceVertices = map (transformVector transformMatrix . vertPosition) (vertices tri) 293 | (invalidMin, invalidMax) = initialInvalidBox 294 | thisTriangleBox = (foldl' Vector.min invalidMin worldSpaceVertices, foldl' Vector.max invalidMax worldSpaceVertices) 295 | triangleListBoundingBox currentBox _ [] = currentBox 296 | 297 | objectListBoundingBox :: [Object] -> AABB 298 | objectListBoundingBox = foldr (boundingBoxUnion . (\obj -> fromMaybe initialInvalidBox (primitiveBoundingBox (primitive obj) obj))) initialInvalidBox 299 | 300 | -- Does a primitive intersect a box? 301 | -- Could maybe generalise the primitiveClosestIntersect function above via further pattern matching? 302 | intersectsBox :: Primitive -> Matrix -> AABB -> Bool 303 | intersectsBox (Sphere sphereRadius) matrix (boxMin, boxMax) = (centreX + sphereRadius) >= vecX boxMin && (centreX - sphereRadius) <= vecX boxMax && 304 | (centreY + sphereRadius) >= vecY boxMin && (centreY - sphereRadius) <= vecY boxMax && 305 | (centreZ + sphereRadius) >= vecZ boxMin && (centreZ - sphereRadius) <= vecZ boxMax 306 | where 307 | centre = getTranslation matrix 308 | centreX = vecX centre 309 | centreY = vecY centre 310 | centreZ = vecZ centre 311 | 312 | intersectsBox (Plane (_, _, planeNormal) planeD) _ box = signum minDistance /= signum maxDistance 313 | where 314 | minX = boundingBoxMinComponent vecX planeNormal box 315 | minY = boundingBoxMinComponent vecY planeNormal box 316 | minZ = boundingBoxMinComponent vecZ planeNormal box 317 | maxX = boundingBoxMaxComponent vecX planeNormal box 318 | maxY = boundingBoxMaxComponent vecY planeNormal box 319 | maxZ = boundingBoxMaxComponent vecZ planeNormal box 320 | minAgainstPlane = Vector minX minY minZ 1 321 | maxAgainstPlane = Vector maxX maxY maxZ 1 322 | minDistance = (planeNormal `dot3` minAgainstPlane) + planeD 323 | maxDistance = (planeNormal `dot3` maxAgainstPlane) + planeD 324 | 325 | intersectsBox (TriangleMesh tris) matrix box = boundingBoxOverlaps box triListBox 326 | where 327 | triListBox = triangleListBoundingBox initialInvalidBox matrix tris 328 | 329 | intersectsBox (Box primBox) _ box = boundingBoxOverlaps box primBox 330 | 331 | intersectsBox (SparseOctreeModel svo_) _ box = boundingBoxOverlaps box (boundingBox svo_) 332 | 333 | -- ------------------------------------------------------------------------------------------------------------------------------------------------------------------- 334 | -- Aspect querying of objects 335 | infinite :: Primitive -> Bool 336 | infinite (Plane _ _) = True 337 | infinite _ = False 338 | 339 | -- ------------------------------------------------------------------------------------------------------------------------------------------------------------------- 340 | -- Specialised intersection code for bounding volume hierarchies 341 | sphereIntersect :: Double -> Vector -> Ray -> Maybe Double 342 | sphereIntersect rad centre (Ray rayOrg rayDir _ rayLen) 343 | | (centre `distanceSq` rayOrg) < (rad * rad) = Just 0 -- Inside the sphere! 344 | | discriminant < 0 = Nothing 345 | | discriminant == 0 = Just ((-b) / 2) 346 | | root1 >= 0 && root1 <= rayLen = Just root1 347 | | root2 >= 0 && root2 <= rayLen = Just root2 348 | | otherwise = Nothing 349 | where 350 | delta = rayOrg <-> centre 351 | b = 2.0 * (delta `dot3` rayDir) 352 | c = (delta `dot3` delta) - rad**2 353 | discriminant = b**2 - 4 * c -- A is 1 because the ray direction is normalised 354 | root1 = (-b - sqrt discriminant) / 2 355 | root2 = (-b + sqrt discriminant) / 2 356 | -------------------------------------------------------------------------------- /app/src/Primitive.hs-boot: -------------------------------------------------------------------------------- 1 | -- Module for general primitives and intersections 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE UnboxedTuples #-} 5 | 6 | module Primitive (primitiveBoundingRadius, 7 | primitiveClosestIntersect, 8 | primitiveAnyIntersect, 9 | Object(Object), 10 | Primitive(Sphere, Plane, TriangleMesh, Box, SparseOctreeModel), 11 | primitive, 12 | material, 13 | makeQuad, 14 | makeTriangle, 15 | makeTriangleWithTangents, 16 | quadsToTriangles, 17 | vertPosition, 18 | vertUV, 19 | vertTangentSpace, 20 | transform, 21 | radius, 22 | triangles, 23 | getCentre, 24 | planeDistance, 25 | primitiveBoundingBox, 26 | objectListBoundingBox, 27 | intersectsBox, 28 | infinite, 29 | boundingBoxValid, 30 | sphereIntersect, 31 | TangentSpace) where 32 | 33 | import Ray 34 | import Vector 35 | import Material 36 | import Matrix 37 | import BoundingBox 38 | import {-# SOURCE #-} SparseVoxelOctree 39 | 40 | -- Triangle object used for triangle meshes 41 | data Vertex = Vertex { vertPosition :: {-# UNPACK #-} !Position, 42 | vertUV :: {-# UNPACK #-} !Position, 43 | vertTangentSpace :: {-# UNPACK #-} !TangentSpace } 44 | data Triangle = Triangle { vertices :: ![Vertex], plane :: !Primitive, halfPlanes :: ![Primitive] } 45 | 46 | -- General object definition 47 | data Object = Object { primitive :: Primitive, 48 | material :: Material, 49 | transform :: !Matrix} 50 | 51 | -- Different kinds of primitives that an object can have 52 | data Primitive = Sphere { radius :: {-# UNPACK #-} !Double } 53 | | Plane { planeTangentSpace :: {-# UNPACK #-} !TangentSpace, planeDistance :: {-# UNPACK #-} !Double } 54 | | TriangleMesh { triangles :: [Triangle] } 55 | | Box { bounds :: {-# UNPACK #-} !AABB } 56 | | SparseOctreeModel { svo :: SparseOctree } 57 | 58 | primitiveBoundingRadius :: Primitive -> Matrix -> Vector -> Double 59 | primitiveBoundingBox :: Primitive -> Object -> Maybe AABB 60 | 61 | primitiveClosestIntersect :: Primitive -> Ray -> Object -> Maybe (Double, TangentSpace) 62 | primitiveAnyIntersect :: Primitive -> Ray -> Object -> Maybe (Double, TangentSpace) 63 | 64 | makeQuad :: [Position] -> [Triangle] 65 | makeTriangle :: Position -> Position -> Position -> Triangle 66 | makeTriangleWithTangents :: Position -> Position -> Position -> Direction -> Direction -> Triangle 67 | quadsToTriangles :: [Position] -> [Triangle] 68 | getCentre :: Object -> Vector 69 | objectListBoundingBox :: [Object] -> AABB 70 | intersectsBox :: Primitive -> Matrix -> AABB -> Bool 71 | infinite :: Primitive -> Bool 72 | sphereIntersect :: Double -> Vector -> Ray -> Maybe Double 73 | -------------------------------------------------------------------------------- /app/src/Ray.hs: -------------------------------------------------------------------------------- 1 | -- Module for handling rays in a raytracer 2 | 3 | module Ray where 4 | 5 | import PolymorphicNum 6 | import Vector 7 | 8 | -- For now, we're sticking to Doubles 9 | data Ray = Ray { origin :: {-# UNPACK #-} !Position, direction :: {-# UNPACK #-} !Direction, invDirection :: {-# UNPACK #-} !Direction, rayLength :: {-# UNPACK #-} !Double } deriving (Show) 10 | 11 | -- Make a ray given the start and end position 12 | rayWithPoints :: Position -> Position -> Ray 13 | rayWithPoints start end = Ray start dir (recipPerElem dir) d 14 | where 15 | d = end `distance` start 16 | dir = (end <-> start) d 17 | 18 | rayWithDirection :: Position -> Direction -> Double -> Ray 19 | rayWithDirection p d = Ray p d (recipPerElem d) 20 | 21 | rayWithPosDir :: (Position, Direction) -> Double -> Ray 22 | rayWithPosDir (start, dir) = Ray start dir (recipPerElem dir) -- ray length done via eta reduction 23 | 24 | -- Given a ray and a distance, produce the point along the ray 25 | pointAlongRay :: Ray -> Double -> Position 26 | pointAlongRay (Ray org dir _ _) dist = setWTo1 (madd org dir dist) 27 | 28 | -- Given some intercept, work out if it is valid, for this ray 29 | validIntercept :: Ray -> Double -> Bool 30 | validIntercept (Ray _ _ _ rayLen) t = t >= 0 && t <= rayLen 31 | 32 | -- Make a shorter version of the same ray 33 | shortenRay :: Ray -> Double -> Ray 34 | shortenRay (Ray org dir invDir _) = Ray org dir invDir 35 | -------------------------------------------------------------------------------- /app/src/RayTrace.hs-boot: -------------------------------------------------------------------------------- 1 | module RayTrace (renderScene, findNearestIntersection, findAnyIntersection) where 2 | 3 | import Vector 4 | --import {-# SOURCE #-} Light 5 | import {-# SOURCE #-} PhotonMap 6 | import Primitive 7 | import Colour 8 | import Ray 9 | --import Material 10 | --import Matrix 11 | import Camera 12 | import SceneGraph 13 | import RenderContext 14 | 15 | --rayTraceImage :: RenderContext -> Camera -> Int -> Int -> PhotonMap -> [Colour] 16 | findNearestIntersection :: SceneGraph -> Ray -> Maybe (Object, Double, TangentSpace) 17 | findAnyIntersection :: SceneGraph -> Ray -> Maybe (Object, Double, TangentSpace) 18 | renderScene :: Maybe PhotonMap -> RenderContext -> Camera -> Int -> Int -> [Colour] 19 | -------------------------------------------------------------------------------- /app/src/RenderContext.hs: -------------------------------------------------------------------------------- 1 | -- This is a render context, something that describes the general shared variables for rendering 2 | 3 | module RenderContext where 4 | 5 | import SceneGraph 6 | import {-# SOURCE #-} Light 7 | import {-# SOURCE #-} PhotonMap (PhotonMapContext) 8 | 9 | data RenderMode = RayTrace | PhotonMapper | PathTracer deriving (Show) 10 | 11 | data RenderMethodConfiguration = RenderMethodRayTrace 12 | | RenderMethodPhotonMap 13 | | RenderMethodPathTracer deriving (Show) 14 | 15 | data RenderContext = RenderContext { 16 | numDistribSamples :: Int, 17 | sceneGraph :: SceneGraph, 18 | lights :: [Light], 19 | maximumRayDepth :: Int, 20 | reflectionRayLength :: Double, 21 | refractionRayLength :: Double, 22 | photonMapContext :: PhotonMapContext, 23 | rayOriginDistribution :: Double, 24 | depthOfFieldFocalDistance :: Double, 25 | renderMode :: RenderMode, 26 | useIrradianceCache :: Bool } 27 | 28 | -------------------------------------------------------------------------------- /app/src/RenderContext.hs-boot: -------------------------------------------------------------------------------- 1 | -- This is a render context, something that describes the general shared variables for rendering 2 | 3 | module RenderContext where 4 | 5 | import SceneGraph 6 | 7 | data RenderMode = RayTrace | PhotonMapper | PathTracer 8 | 9 | data RenderContext = RenderContext { 10 | numDistribSamples :: Int, 11 | sceneGraph :: SceneGraph, 12 | lights :: [Light], 13 | maximumRayDepth :: Int, 14 | reflectionRayLength :: Double, 15 | refractionRayLength :: Double, 16 | photonMapContext :: PhotonMapContext, 17 | rayOriginDistribution :: Double, 18 | depthOfFieldFocalDistance :: Double, 19 | renderMode :: RenderMode, 20 | useIrradianceCache :: Bool } 21 | -------------------------------------------------------------------------------- /app/src/RussianRoulette.hs: -------------------------------------------------------------------------------- 1 | -- Shared module for russian roulette across path tracer and photon mapper 2 | 3 | module RussianRoulette where 4 | 5 | import Material 6 | import Colour 7 | 8 | data RussianRouletteChoice = DiffuseReflect | SpecularReflect | Absorb deriving (Show, Eq) 9 | 10 | -- Compute russian roulette coefficients 11 | russianRouletteCoefficients :: Material -> (Double, Double) 12 | russianRouletteCoefficients mat = (diffuseP, specularP) 13 | where 14 | diffuseP = (magnitude . Material.diffuse) mat 15 | specularP = (magnitude . Material.specular) mat 16 | 17 | russianRouletteCoefficients2 :: Material -> (Double, Double) 18 | russianRouletteCoefficients2 mat = (diffuseP, 1 - diffuseP) 19 | where 20 | (Colour dr dg db _) = diffuse mat 21 | (Colour sr sg sb _) = specular mat 22 | diffuseP = (dr + dg + db) / (dr + dg + db + sr + sg + sb) 23 | 24 | -------------------------------------------------------------------------------- /app/src/SceneGraph.hs: -------------------------------------------------------------------------------- 1 | -- The graph structure holding the scene 2 | 3 | module SceneGraph (buildSceneGraph, SphereTreeNode(boundingRadius, boundingCentre, object, children), SceneGraph(root, infiniteObjects, finiteBox)) where 4 | 5 | import PolymorphicNum 6 | import Primitive 7 | import Vector 8 | import BoundingBox 9 | import Data.List 10 | 11 | data SphereTreeNode = SphereTreeNode { object :: Maybe Object, children :: [SphereTreeNode], boundingRadius :: !Double, boundingCentre :: !Vector } deriving (Show) 12 | data SceneGraph = SceneGraph { root :: SphereTreeNode, infiniteObjects :: [Object], finiteBox :: AABB } deriving (Show) 13 | 14 | -- Find the mean of a collection of objects 15 | 16 | calculateMeanPosition :: [Object] -> Vector 17 | calculateMeanPosition objects = setWTo1 (calculateMeanPosition' objects zeroVector len') 18 | where 19 | len' = fromIntegral (length objects) :: Double 20 | calculateMeanPosition' (obj : objs) acc = calculateMeanPosition' objs acc <+> getCentre obj 21 | calculateMeanPosition' [] acc = acc 22 | 23 | -- Find the overall bounding radius of a list of objects 24 | calculateBoundingRadius :: [Object] -> Vector -> Double 25 | calculateBoundingRadius objs centre = foldr (Prelude.max . (\obj -> primitiveBoundingRadius (primitive obj) (transform obj) centre)) 0 objs 26 | 27 | -- Build up a sphere tree 28 | buildSphereTree :: ([Object] -> [[Object]]) -> [Object] -> SphereTreeNode 29 | buildSphereTree _ (obj : []) = SphereTreeNode (Just obj) [] nodeRadius nodeCentre 30 | where 31 | nodeCentre = calculateMeanPosition [obj] 32 | nodeRadius = calculateBoundingRadius [obj] nodeCentre 33 | buildSphereTree builder (obj:objs) 34 | | length (obj:objs) == 1 = error "Should have been handled by a different pattern" 35 | | null (obj:objs) = error "Should not have zero objects" 36 | | otherwise = SphereTreeNode Nothing nodeChildren nodeRadius nodeCentre 37 | where 38 | nodeCentre = calculateMeanPosition (obj:objs) 39 | nodeRadius = calculateBoundingRadius (obj:objs) nodeCentre 40 | nodeChildren = map (buildSphereTree builder) (builder (obj:objs)) 41 | buildSphereTree _ [] = SphereTreeNode Nothing [] 0 zeroVector -- error "Should not hit this pattern for buildSphereTree" 42 | 43 | -- Build a scene graph 44 | buildSceneGraph :: [Object] -> ([Object] -> [[Object]]) -> SceneGraph 45 | buildSceneGraph objs buildFunction = SceneGraph (buildSphereTree buildFunction nonInfiniteObjs) infiniteObjs (objectListBoundingBox nonInfiniteObjs) 46 | where 47 | (infiniteObjs, nonInfiniteObjs) = partition (infinite . primitive) objs 48 | -------------------------------------------------------------------------------- /app/src/Shader.hs: -------------------------------------------------------------------------------- 1 | -- Generic shaders to return colour and texture information 2 | 3 | module Shader where 4 | 5 | import PolymorphicNum 6 | import Vector 7 | import Colour 8 | import Misc 9 | 10 | data Shader = CheckedShader { scale :: {-# UNPACK #-} !Vector, colour1 :: {-# UNPACK #-} !Colour, colour2 :: {-# UNPACK #-} !Colour } 11 | | ShowNormalShader 12 | | NullShader deriving (Show, Eq) 13 | 14 | -- Functions available for each shader 15 | evaluateAmbient :: Shader -> Position -> TangentSpace -> Colour 16 | evaluateDiffuse :: Shader -> Position -> TangentSpace -> Colour 17 | evaluateSpecular :: Shader -> Position -> TangentSpace -> Colour 18 | shadePoint :: Shader -> (Position, Direction) -> (Colour, Colour, Colour) -> Colour 19 | 20 | -- Checked shaders 21 | evaluateDiffuse (CheckedShader checkScale checkColour1 checkColour2) position _ = 22 | let scaledPosition = checkScale <*> position 23 | scaledX = round (vecX scaledPosition) :: Int 24 | scaledY = round (vecY scaledPosition) :: Int 25 | scaledZ = round (vecZ scaledPosition) :: Int 26 | in if odd scaledX `xor` odd scaledY `xor` odd scaledZ then checkColour1 else checkColour2 27 | 28 | -- Normal display 29 | evaluateDiffuse ShowNormalShader _ (_, _, normal) = encodeNormal normal 30 | 31 | -- Null shader 32 | evaluateDiffuse NullShader _ _ = colWhite 33 | 34 | -- Defaults 35 | evaluateSpecular = evaluateDiffuse 36 | evaluateAmbient = evaluateDiffuse 37 | 38 | -- New style shader interface 39 | shadePoint (CheckedShader checkScale checkColour1 checkColour2) (position, _) (ambient, diffuse, specular) = (ambient <+> diffuse <+> specular) <*> checkColour 40 | where 41 | scaledPosition = checkScale <*> position 42 | scaledX = round (vecX scaledPosition) :: Int 43 | scaledY = round (vecY scaledPosition) :: Int 44 | scaledZ = round (vecZ scaledPosition) :: Int 45 | checkColour = if odd scaledX `xor` odd scaledY `xor` odd scaledZ then checkColour1 else checkColour2 46 | 47 | shadePoint ShowNormalShader (_, norm) (_, _, _) = encodeNormal norm 48 | 49 | -- Default fallback 50 | shadePoint _ (_, _) (ambient, diffuse, specular) = ambient <+> diffuse <+> specular 51 | -------------------------------------------------------------------------------- /app/src/ShadowCache.hs: -------------------------------------------------------------------------------- 1 | -- A simple shadow cache system to re-test the last shadowing object 2 | 3 | module ShadowCache(ShadowCache, initShadowCache, testShadowCache) where 4 | 5 | import Ray 6 | import Vector 7 | import SceneGraph 8 | import {-# SOURCE #-} RayTrace 9 | import Primitive 10 | 11 | data ShadowCache = ShadowCache (Maybe Object) (Maybe Object) (Maybe Object) (Maybe Object) (Maybe Object) (Maybe Object) 12 | 13 | initShadowCache :: ShadowCache 14 | initShadowCache = ShadowCache Nothing Nothing Nothing Nothing Nothing Nothing 15 | 16 | rayFaceIndex :: Ray -> Int 17 | rayFaceIndex (Ray _ (Vector dx dy dz _) _ _) 18 | | dx > dy && dx > dz = if dx < 0 then 0 else 1 19 | | dy > dx && dy > dz = if dx < 2 then 3 else 1 20 | | otherwise = if dx < 0 then 4 else 5 21 | 22 | queryCache :: ShadowCache -> Int -> Maybe Object 23 | queryCache (ShadowCache value _ _ _ _ _) 0 = value 24 | queryCache (ShadowCache _ value _ _ _ _) 1 = value 25 | queryCache (ShadowCache _ _ value _ _ _) 2 = value 26 | queryCache (ShadowCache _ _ _ value _ _) 3 = value 27 | queryCache (ShadowCache _ _ _ _ value _) 4 = value 28 | queryCache (ShadowCache _ _ _ _ _ value) 5 = value 29 | queryCache _ _ = error "Invalid cache index" 30 | 31 | setCache :: ShadowCache -> Int -> Maybe Object -> ShadowCache 32 | setCache (ShadowCache _ value1 value2 value3 value4 value5) 0 value = ShadowCache value value1 value2 value3 value4 value5 33 | setCache (ShadowCache value0 _ value2 value3 value4 value5) 1 value = ShadowCache value0 value value2 value3 value4 value5 34 | setCache (ShadowCache value0 value1 _ value3 value4 value5) 2 value = ShadowCache value0 value1 value value3 value4 value5 35 | setCache (ShadowCache value0 value1 value2 _ value4 value5) 3 value = ShadowCache value0 value1 value2 value value4 value5 36 | setCache (ShadowCache value0 value1 value2 value3 _ value5) 4 value = ShadowCache value0 value1 value2 value3 value value5 37 | setCache (ShadowCache value0 value1 value2 value3 value4 _) 5 value = ShadowCache value0 value1 value2 value3 value4 value 38 | setCache _ _ _ = error "Invalid cache index" 39 | 40 | -- TODO - Potentially move this into state monad to make it clearer? 41 | testShadowCache :: ShadowCache -> SceneGraph -> Ray -> (Maybe (Double, TangentSpace), ShadowCache) 42 | testShadowCache cache sceneGraph ray = case cacheValue of Nothing -> 43 | -- No object in cache so try against whole scene first 44 | case findAnyIntersection sceneGraph ray of 45 | -- No cached result, no intersection, same old cache 46 | Nothing -> (Nothing, cache) 47 | 48 | -- Hit an object, found a new value for the cache 49 | Just (obj, dist, ts) -> (Just (dist, ts), setCache cache cacheIndex (Just obj)) 50 | 51 | Just obj -> 52 | -- We have an object in the cache so try that first 53 | case primitiveAnyIntersect (primitive obj) ray obj of 54 | -- Did not hit cached object. If we hit a new object, then replace cache 55 | Nothing -> 56 | case findAnyIntersection sceneGraph ray of 57 | -- Cache failed, scene intersection failed, just return cache as-is 58 | Nothing -> (Nothing, cache) 59 | 60 | -- Cached object failed but found new object - put that in cache instead 61 | Just (obj', dist, ts) -> (Just (dist, ts), setCache cache cacheIndex (Just obj')) 62 | -- Hit the same cached object again - keep cache as it is 63 | Just (dist, ts) -> (Just (dist, ts), cache) 64 | where 65 | cacheIndex = rayFaceIndex ray 66 | cacheValue = queryCache cache cacheIndex 67 | -------------------------------------------------------------------------------- /app/src/ShadowCache.hs-boot: -------------------------------------------------------------------------------- 1 | -- A simple shadow cache system to re-test the last shadowing object 2 | 3 | module ShadowCache(ShadowCache, initShadowCache, testShadowCache) where 4 | 5 | import Ray 6 | import Vector 7 | import SceneGraph 8 | import Primitive 9 | 10 | data ShadowCache = ShadowCache (Maybe Object) (Maybe Object) (Maybe Object) (Maybe Object) (Maybe Object) (Maybe Object) 11 | 12 | initShadowCache :: ShadowCache 13 | testShadowCache :: ShadowCache -> SceneGraph -> Ray -> (Maybe (Double, TangentSpace), ShadowCache) 14 | -------------------------------------------------------------------------------- /app/src/SparseVoxelOctree.hs: -------------------------------------------------------------------------------- 1 | 2 | -- The sparse voxel octree data structure 3 | {-# LANGUAGE BangPatterns #-} 4 | 5 | module SparseVoxelOctree(build, 6 | SparseOctree, 7 | closestIntersect, 8 | anyIntersect, 9 | boundingRadius, 10 | boundingBox, 11 | enumerateLeafBoxes) where 12 | 13 | import Octree 14 | import BoundingBox 15 | import Ray 16 | import Vector 17 | import PolymorphicNum 18 | 19 | -- Boxes are strict to prevent accumulation of large amounts of thunks. Children and other bits are lazy to save space 20 | data SparseOctree = SparseOctreeDummy 21 | | SparseOctreeNode !AABB [SparseOctree] 22 | | SparseOctreeLeaf !AABB Double TangentSpace deriving (Eq) 23 | 24 | instance Show SparseOctree where 25 | show = display 0 26 | 27 | tabs :: String 28 | tabs = '\t' : tabs 29 | 30 | display :: Int -> SparseOctree -> String 31 | display level (SparseOctreeDummy) = take level tabs ++ show level ++ " [Dummy]\n" 32 | display level (SparseOctreeNode box children) = take level tabs ++ show level ++ " [Node] box=" ++ show box ++ "\n" ++ concatMap (display (level + 1)) children ++ "\n" 33 | display level (SparseOctreeLeaf box value tanSpace) = take level tabs ++ show level ++ " [Leaf] box=" ++ show box ++ " value=" ++ show value ++ " tanSpace=" ++ show tanSpace ++ "\n" 34 | 35 | -- Work out a tangent space for an SVO leaf box 36 | calculateTangentSpace :: (Position -> Double) -> AABB -> TangentSpace 37 | calculateTangentSpace f box = constructTangentSpace finalNormal 38 | where 39 | !centre = boundingBoxCentre box 40 | !normals = accumulateNormal (boundingBoxVertices box) 41 | finalNormal | null normals = error "Error - we should not be trying to form a tangent space for an empty leaf!" 42 | | otherwise = normalise $ foldr1 (<+>) normals ((fromIntegral $ length normals) :: Double) 43 | -- This little function makes a list of "solid matter to point away from". Ie, if there is some solid matter on our right, the normal should point away from it 44 | -- Empty spaces are simply omitted or not added to the list. We should end up with a non-empty list of normals to average out 45 | accumulateNormal (x:xs) | f x > 0 = normalise (centre <-> x) : accumulateNormal xs 46 | | otherwise = accumulateNormal xs 47 | accumulateNormal [] = [] 48 | 49 | -- Build a sparse voxel octree for a data set 50 | build :: (AABB -> Double) -> (Position -> Double) -> AABB -> Int -> Double -> SparseOctree 51 | build = build' 0 52 | where 53 | build' !depth !func !func2 !box !maxDepth !minDimension 54 | | func box <= 0 = SparseOctreeDummy -- Really this is a soft error. But, the user might specify an invalid input... 55 | | depth == maxDepth || boundingBoxRadius box <= minDimension = SparseOctreeLeaf box (func box) (calculateTangentSpace func2 box) 56 | | otherwise = SparseOctreeNode box (concatMap (buildNonEmptyNodes . octreeChildBox box) [0..7]) 57 | where 58 | -- subBoxList = splitBoxIntoOctreeChildren box 59 | buildNonEmptyNodes childBox 60 | | func childBox > 0 = [build' (depth + 1) func func2 childBox maxDepth minDimension] 61 | | otherwise = [] 62 | 63 | -- Find the closest Maybe intersection 64 | nearestIntersection :: Maybe (Double, TangentSpace) -> Maybe (Double, TangentSpace) -> Maybe (Double, TangentSpace) 65 | nearestIntersection Nothing Nothing = Nothing 66 | nearestIntersection Nothing x@(Just _) = x 67 | nearestIntersection y@(Just _) Nothing = y 68 | nearestIntersection x@(Just (d1, _)) y@(Just (d2, _)) | d1 < d2 = x 69 | | otherwise = y 70 | 71 | -- Work out if a further refinement of given intersection is likely to result in a feature hardly visible in the image 72 | -- TODO: Make this work on distance to eye, not distance along ray 73 | intersectionWorthSubdivision :: Double -> Double -> Double -> Bool 74 | intersectionWorthSubdivision d scaler radius = radius * scaler / d >= 2 75 | 76 | -- Intersect with a ray 77 | closestIntersect :: Ray -> Int -> Int -> Double -> SparseOctree -> Maybe (Double, TangentSpace) 78 | closestIntersect _ _ _ _ SparseOctreeDummy = Nothing 79 | closestIntersect ray depth maxDepth lodScale !(SparseOctreeNode box children) = 80 | case boundingBoxIntersectRay box ray of Nothing -> Nothing 81 | Just (dist, dist2) -> if depth >= maxDepth || not (intersectionWorthSubdivision dist lodScale (boundingBoxRadius box)) 82 | then Just (dist, boundingBoxTangentSpace box (pointAlongRay ray dist)) 83 | else foldr1 nearestIntersection (map (closestIntersect (shortenRay ray dist2) (depth + 1) maxDepth lodScale) children) 84 | closestIntersect ray _ _ _ !(SparseOctreeLeaf box _ tanSpace) = 85 | case boundingBoxIntersectRay box ray of Nothing -> Nothing 86 | Just (dist, _) -> Just (dist, tanSpace) 87 | 88 | anyIntersect :: Ray -> Int -> Int -> Double -> SparseOctree -> Maybe (Double, TangentSpace) 89 | anyIntersect _ _ _ _ SparseOctreeDummy = Nothing 90 | anyIntersect ray depth maxDepth lodScale (SparseOctreeNode box children) = 91 | case boundingBoxIntersectRay box ray of Nothing -> Nothing 92 | Just (dist, dist2) -> if depth >= maxDepth || not (intersectionWorthSubdivision dist lodScale (boundingBoxRadius box)) 93 | then Just (dist, boundingBoxTangentSpace box (pointAlongRay ray dist)) 94 | else traverseChildren children 95 | where 96 | traverseChildren [] = Nothing 97 | traverseChildren (x:xs) = case anyIntersect (shortenRay ray dist2) (depth + 1) maxDepth lodScale x of 98 | Nothing -> traverseChildren xs 99 | Just z -> Just z 100 | anyIntersect ray _ _ _ (SparseOctreeLeaf box _ tanSpace) = case boundingBoxIntersectRay box ray of Nothing -> Nothing 101 | Just (dist, _) -> Just (dist, tanSpace) 102 | 103 | boundingRadius :: SparseOctree -> Double 104 | boundingRadius SparseOctreeDummy = 0 105 | boundingRadius (SparseOctreeNode box _) = boundingBoxRadius box 106 | boundingRadius (SparseOctreeLeaf box _ _) = boundingBoxRadius box 107 | 108 | boundingBox :: SparseOctree -> AABB 109 | boundingBox SparseOctreeDummy = error "Invalid SVO" 110 | boundingBox (SparseOctreeNode box _) = box 111 | boundingBox (SparseOctreeLeaf box _ _) = box 112 | 113 | -- Traverse the whole tree and make a list of bounding boxes for each leaf 114 | enumerateLeafBoxes :: SparseOctree -> [AABB] 115 | enumerateLeafBoxes = enumerateLeafBoxes' [] 116 | where 117 | enumerateLeafBoxes' acc SparseOctreeDummy = acc 118 | enumerateLeafBoxes' acc (SparseOctreeNode _ children) = acc ++ concatMap (enumerateLeafBoxes' []) children 119 | enumerateLeafBoxes' acc (SparseOctreeLeaf box _ _) = box : acc 120 | -------------------------------------------------------------------------------- /app/src/SparseVoxelOctree.hs-boot: -------------------------------------------------------------------------------- 1 | -- The sparse voxel octree data structure 2 | 3 | module SparseVoxelOctree(build, 4 | SparseOctree, 5 | closestIntersect, 6 | anyIntersect, 7 | boundingRadius, 8 | boundingBox, 9 | enumerateLeafBoxes) where 10 | 11 | import BoundingBox 12 | import Ray 13 | import Vector 14 | 15 | data SparseOctree = SparseOctreeDummy 16 | | SparseOctreeNode !AABB [SparseOctree] 17 | | SparseOctreeLeaf !AABB Double 18 | 19 | instance Show SparseOctree 20 | instance Eq SparseOctree 21 | 22 | -- Build a sparse voxel octree for a data set 23 | build :: (AABB -> Double) -> (Position -> Double) -> AABB -> Int -> Double -> SparseOctree 24 | 25 | -- Intersect with a ray 26 | closestIntersect :: Ray -> Int -> Int -> Double -> SparseOctree -> Maybe (Double, TangentSpace) 27 | anyIntersect :: Ray -> Int -> Int -> Double -> SparseOctree -> Maybe (Double, TangentSpace) 28 | 29 | -- The bounding radius 30 | boundingRadius :: SparseOctree -> Double 31 | 32 | -- The bounding box 33 | boundingBox :: SparseOctree -> AABB 34 | 35 | enumerateLeafBoxes :: SparseOctree -> [AABB] 36 | -------------------------------------------------------------------------------- /app/src/TestScenes.hs: -------------------------------------------------------------------------------- 1 | -- Just some built-in test scenes for debugging purposes 2 | 3 | module TestScenes where 4 | 5 | import Colour 6 | import Light 7 | import SparseVoxelOctree 8 | import Vector 9 | import BoundingBox 10 | import Primitive 11 | import Matrix 12 | import Material 13 | import Camera 14 | 15 | testSvo :: SparseOctree 16 | testSvo = build (sphereOverlapsBox spherePos sphereRadius) (sphereContainsPoint spherePos sphereRadius) (Vector 140 140 190 1, Vector 360 360 410 1) maxRecursion minDimension 17 | where 18 | spherePos = Vector 250 250 300 1 19 | sphereRadius = 100 20 | maxRecursion = 100 21 | minDimension = 5 22 | sphereOverlapsBox pos r box 23 | | overlapsSphere box pos r = 1 24 | | otherwise = 0 25 | sphereContainsPoint pos r p | p `distance` pos <= r = 1 26 | | otherwise = 0 27 | 28 | svoTestScene :: [Object] 29 | svoTestScene = [Object (SparseOctreeModel testSvo) defaultMaterial identity] 30 | 31 | svoLeafBoxes :: [Object] 32 | svoLeafBoxes = map (\x -> Object (Box x) defaultMaterial identity) (enumerateLeafBoxes testSvo) 33 | 34 | boxTestScene :: [Object] 35 | boxTestScene = [Object (Box (Vector (-50) (-50) (-50) 0, Vector 50 50 50 0)) defaultMaterial identity] 36 | 37 | testSceneCamera :: Camera 38 | testSceneCamera = withVectors (Vector 0 0 (-400.0) 1.0) xaxis yaxis zaxis 45.0 10000 39 | 40 | testSceneLights :: [Light] 41 | testSceneLights = [ 42 | QuadLight (CommonLightData (Colour 500 500 500 0) True) (Vector 0.0 200.0 (-300.0) 1.0) 1000 (Vector 1000.0 0.0 0.0 0.0) (Vector 0.0 0.0 1000.0 0.0) 43 | ] 44 | -------------------------------------------------------------------------------- /app/src/Tests/BoundingBoxTest.hs: -------------------------------------------------------------------------------- 1 | module Tests.BoundingBoxTest where 2 | 3 | import Test.HUnit 4 | import Vector 5 | import BoundingBox 6 | import GHC.Prim 7 | import GHC.Types 8 | 9 | test_InsideBox = TestCase (assertEqual "Inside box" (box `contains` pos) True) 10 | where 11 | box = (Vector (-5) (-5) (-5) 1, Vector 5 5 5 1) 12 | pos = Vector 0 0 0 1 13 | 14 | test_OutsideBoxMinX = TestCase (assertEqual "Inside box" (box `contains` pos) False) 15 | where 16 | box = (Vector (-5) (-5) (-5) 1, Vector 5 5 5 1) 17 | pos = Vector (-10) 0 0 1 18 | 19 | tests_BoundingBox = TestList [ 20 | TestLabel "InsideBox" test_InsideBox, 21 | TestLabel "OutsideBoxMinX" test_OutsideBoxMinX 22 | ] 23 | -------------------------------------------------------------------------------- /app/src/Tests/ColourTest.hs: -------------------------------------------------------------------------------- 1 | module Tests.ColourTest where 2 | 3 | import PolymorphicNum 4 | import Colour 5 | import Test.HUnit 6 | 7 | test_Add = TestCase (assertEqual "Colour addition" expected (v1 <+> v2)) 8 | where 9 | v1 = Colour 1 2 3 4 10 | v2 = Colour 10 20 30 40 11 | expected = Colour 11 22 33 44 12 | 13 | test_Sub = TestCase (assertEqual "Colour subtraction" expected (v1 <-> v2)) 14 | where 15 | v1 = Colour 10 20 30 40 16 | v2 = Colour 5 10 15 20 17 | expected = Colour 5 10 15 20 18 | 19 | test_Mul = TestCase (assertEqual "Colour multiplication" expected (v1 <*> v2)) 20 | where 21 | v1 = Colour 10 20 30 40 22 | v2 = Colour 5 10 15 20 23 | expected = Colour 50 200 450 800 24 | 25 | test_Div = TestCase (assertEqual "Colour division" expected (v1 v2)) 26 | where 27 | v1 = Colour 10 20 30 40 28 | v2 = Colour 5 10 15 20 29 | expected = Colour 2 2 2 2 30 | 31 | test_AddScalar = TestCase (assertEqual "Colour add scalar" expected (v1 <+> k)) 32 | where 33 | v1 = Colour 10 20 30 40 34 | k = 1 :: Double 35 | expected = Colour 11 21 31 41 36 | 37 | test_SubScalar = TestCase (assertEqual "Colour sub scalar" expected (v1 <-> k)) 38 | where 39 | v1 = Colour 10 20 30 40 40 | k = 1 :: Double 41 | expected = Colour 9 19 29 39 42 | 43 | test_Clamp = TestCase (assertEqual "Colour clamp" expected (clamp v1)) 44 | where 45 | v1 = Colour 2 0 (-5) 0.5 46 | expected = Colour 1 0 0 0.5 47 | 48 | test_Luminance0 = TestCase (assertEqual "Luminance = 0" expected (luminance v1)) 49 | where 50 | v1 = Colour 0 0 0 0 51 | expected = 0 52 | 53 | test_Luminance1 = TestCase (assertEqual "Luminance = 1" expected (luminance v1)) 54 | where 55 | v1 = Colour 1 1 1 1 56 | expected = 0.9999999999999999 57 | 58 | tests_Colour = TestList [ 59 | TestLabel "Addition" test_Add, 60 | TestLabel "Subtraction" test_Sub, 61 | TestLabel "Multiplication" test_Mul, 62 | TestLabel "Div" test_Div, 63 | TestLabel "Add scalar" test_AddScalar, 64 | TestLabel "Sub scalar" test_SubScalar, 65 | TestLabel "Clamp" test_Clamp, 66 | TestLabel "Luminance = 0" test_Luminance0, 67 | TestLabel "Luminance = 1" test_Luminance1 68 | ] -------------------------------------------------------------------------------- /app/src/Tests/OctreeTest.hs: -------------------------------------------------------------------------------- 1 | module Tests.OctreeTest where 2 | 3 | import Test.HUnit 4 | import Vector 5 | import Octree 6 | 7 | test_create = TestCase (assertEqual "create" expectedResult ((create box) :: Octree Int)) 8 | where 9 | box = (Vector (-10) (-10) (-10) 1, Vector 10 10 10 1) 10 | octChildren = [ 11 | (OctreeDummy (Vector (-10) (-10) (-10) 1, Vector 0 0 0 1)) :: Octree Int, 12 | (OctreeDummy (Vector 0 (-10) (-10) 1, Vector 10 0 0 1)) :: Octree Int, 13 | (OctreeDummy (Vector (-10) 0 (-10) 1, Vector 0 10 0 1)) :: Octree Int, 14 | (OctreeDummy (Vector 0 0 (-10) 1, Vector 10 10 0 1)) :: Octree Int, 15 | (OctreeDummy (Vector (-10) (-10) 0 1, Vector 0 0 10 1)) :: Octree Int, 16 | (OctreeDummy (Vector 0 (-10) 0 1, Vector 10 0 10 1)) :: Octree Int, 17 | (OctreeDummy (Vector (-10) 0 0 1, Vector 0 10 10 1)) :: Octree Int, 18 | (OctreeDummy (Vector 0 0 0 1, Vector 10 10 10 1)) :: Octree Int 19 | ] 20 | expectedResult = (OctreeNode (Vector (-10) (-10) (-10) 1, Vector 10 10 10 1) octChildren) :: Octree Int 21 | 22 | tests_Octree = TestList [ 23 | TestLabel "Creation" test_create 24 | ] 25 | -------------------------------------------------------------------------------- /app/src/Tests/PrimitiveTest.hs: -------------------------------------------------------------------------------- 1 | module Tests.PrimitiveTest where 2 | 3 | import PolymorphicNum 4 | import Vector 5 | import Test.HUnit 6 | import Primitive 7 | import Ray 8 | import Matrix 9 | import Material 10 | 11 | test_triIntersect1 = TestCase (assertEqual "Triangle intersection 1" expectedResult actualResult) 12 | where 13 | v1 = Vector 0 0 0 1 14 | v2 = Vector 10 10 0 1 15 | v3 = Vector 20 0 0 1 16 | tri = makeTriangle v1 v2 v3 17 | ray = rayWithDirection (Vector 10 5 (-10) 1) (Vector 0 0 1 0) 1000 18 | expectedResult = True 19 | (actualResult, _, _) = (intersectRayTriangle ray tri True) 20 | 21 | test_triIntersect2 = TestCase (assertEqual "Triangle intersection 2" expectedResult actualResult) 22 | where 23 | v1 = Vector 0 0 0 1 24 | v2 = Vector 10 10 0 1 25 | v3 = Vector 20 0 0 1 26 | tri = makeTriangle v1 v2 v3 27 | ray = rayWithDirection (Vector (-100) 5 (-10) 1) (Vector 0 0 1 0) 1000 28 | expectedResult = False 29 | (actualResult, _, _) = (intersectRayTriangle ray tri True) 30 | 31 | test_triIntersect3 = TestCase (assertEqual "Triangle intersection 3" expectedResult actualResult) 32 | where 33 | v1 = Vector 0 0 0 1 34 | v2 = Vector 10 10 0 1 35 | v3 = Vector 20 0 0 1 36 | tri = makeTriangle v1 v2 v3 37 | ray = rayWithDirection (Vector 100 5 (-10) 1) (Vector 0 0 1 0) 1000 38 | expectedResult = False 39 | (actualResult, _, _) = (intersectRayTriangle ray tri True) 40 | 41 | test_triIntersect4 = TestCase (assertEqual "Triangle intersection 4" expectedResult actualResult) 42 | where 43 | v1 = Vector 0 0 0 1 44 | v2 = Vector 10 10 0 1 45 | v3 = Vector 20 0 0 1 46 | tri = makeTriangle v1 v2 v3 47 | ray = rayWithDirection (Vector 10 500 (-10) 1) (Vector 0 0 1 0) 1000 48 | expectedResult = False 49 | (actualResult, _, _) = (intersectRayTriangle ray tri True) 50 | 51 | test_triIntersect5 = TestCase (assertEqual "Triangle intersection 5" expectedResult actualResult) 52 | where 53 | v1 = Vector 0 0 0 1 54 | v2 = Vector 10 10 0 1 55 | v3 = Vector 20 0 0 1 56 | tri = makeTriangle v1 v2 v3 57 | ray = rayWithDirection (Vector 10 (-500) (-10) 1) (Vector 0 0 1 0) 1000 58 | expectedResult = False 59 | (actualResult, _, _) = (intersectRayTriangle ray tri True) 60 | 61 | test_boxIntersect1 = TestCase (assertEqual "Box intersection 1" expectedResult actualResult) 62 | where 63 | box = Box (Vector (-5) (-5) (-5) 0, Vector 5 5 5 0) 64 | ray = rayWithDirection (Vector 0 0 (-100) 1) (Vector 0 0 1 0) 1000 65 | expectedResult = True 66 | obj = Object box defaultMaterial identity 67 | hitResult = primitiveClosestIntersect box ray obj 68 | actualResult = case hitResult of Nothing -> False 69 | _ -> True 70 | 71 | test_boxIntersect2 = TestCase (assertEqual "Box intersection 2" expectedResult actualResult) 72 | where 73 | box = Box (Vector (-5) (-5) (-5) 0, Vector 5 5 5 0) 74 | ray = rayWithDirection (Vector (-1000) 0 (-100) 1) (Vector 0 0 1 0) 1000 75 | expectedResult = Nothing 76 | obj = Object box defaultMaterial identity 77 | actualResult = primitiveClosestIntersect box ray obj 78 | 79 | tests_Primitive = TestList [ 80 | TestLabel "Triangle intersection 1" test_triIntersect1, 81 | TestLabel "Triangle intersection 2" test_triIntersect2, 82 | TestLabel "Triangle intersection 3" test_triIntersect3, 83 | TestLabel "Triangle intersection 4" test_triIntersect4, 84 | TestLabel "Triangle intersection 5" test_triIntersect5, 85 | TestLabel "Box intersection 1" test_boxIntersect1, 86 | TestLabel "Box intersection 2" test_boxIntersect2 87 | ] 88 | -------------------------------------------------------------------------------- /app/src/Tests/RandomUVTest/RandomUVTest.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from a NeHe OpenGL tutorial 2 | -- 3 | -- This code was created by Jeff Molofee '99 (ported to Haskell GHC 2005) 4 | -- 5 | 6 | module Main where 7 | 8 | import qualified Graphics.UI.GLFW as GLFW 9 | -- everything from here starts with gl or GL 10 | import Graphics.Rendering.OpenGL.Raw 11 | import Graphics.Rendering.GLU.Raw ( gluPerspective ) 12 | import Data.Bits ( (.|.) ) 13 | import System.Exit ( exitWith, ExitCode(..) ) 14 | import Distribution 15 | import System.Random.Mersenne.Pure64 16 | import Control.Monad.State 17 | 18 | initGL :: IO () 19 | initGL = do 20 | glShadeModel gl_SMOOTH -- enables smooth color shading 21 | glClearColor 0 0 0 0 -- Clear the background color to black 22 | glClearDepth 1 -- enables clearing of the depth buffer 23 | glEnable gl_DEPTH_TEST 24 | glDepthFunc gl_LEQUAL -- type of depth test 25 | glHint gl_PERSPECTIVE_CORRECTION_HINT gl_NICEST 26 | 27 | resizeScene :: GLFW.WindowSizeCallback 28 | resizeScene w 0 = resizeScene w 1 -- prevent divide by zero 29 | resizeScene width height = do 30 | glViewport 0 0 (fromIntegral width) (fromIntegral height) 31 | glMatrixMode gl_PROJECTION 32 | glLoadIdentity 33 | gluPerspective 45 (fromIntegral width/fromIntegral height) 0.1 100 34 | glMatrixMode gl_MODELVIEW 35 | glLoadIdentity 36 | glFlush 37 | 38 | renderCross :: (Double, Double) -> IO () 39 | renderCross (x, y) = do 40 | glVertex3f ((realToFrac x) - size) (realToFrac y) 0 41 | glVertex3f ((realToFrac x) + size) (realToFrac y) 0 42 | glVertex3f (realToFrac x) ((realToFrac y) - size) 0 43 | glVertex3f (realToFrac x) ((realToFrac y) + size) 0 44 | where 45 | size = 0.01 46 | 47 | randomUVList :: [(Double, Double)] 48 | randomUVList = zipWith stratify (evalState (generateRandomUVs 1024) (pureMT 12345)) [0..] 49 | 50 | drawScene :: IO () 51 | drawScene = do 52 | -- clear the screen and the depth bufer 53 | glClear $ fromIntegral $ gl_COLOR_BUFFER_BIT 54 | .|. gl_DEPTH_BUFFER_BIT 55 | glLoadIdentity -- reset view 56 | 57 | glTranslatef (-0.5) (-0.5) (-1.5) 58 | 59 | -- Render my test data 60 | glBegin gl_LINES 61 | _ <- mapM renderCross randomUVList 62 | glEnd 63 | 64 | glFlush 65 | 66 | shutdown :: GLFW.WindowCloseCallback 67 | shutdown = do 68 | GLFW.closeWindow 69 | GLFW.terminate 70 | _ <- exitWith ExitSuccess 71 | return True 72 | 73 | keyPressed :: GLFW.KeyCallback 74 | keyPressed GLFW.KeyEsc True = shutdown >> return () 75 | keyPressed _ _ = return () 76 | 77 | main :: IO () 78 | main = do 79 | True <- GLFW.initialize 80 | -- select type of display mode: 81 | -- Double buffer 82 | -- RGBA color 83 | -- Alpha components supported 84 | -- Depth buffer 85 | let dspOpts = GLFW.defaultDisplayOptions 86 | -- get a 800 x 600 window 87 | { GLFW.displayOptions_width = 640 88 | , GLFW.displayOptions_height = 480 89 | -- Set depth buffering and RGBA colors 90 | , GLFW.displayOptions_numRedBits = 8 91 | , GLFW.displayOptions_numGreenBits = 8 92 | , GLFW.displayOptions_numBlueBits = 8 93 | , GLFW.displayOptions_numAlphaBits = 8 94 | , GLFW.displayOptions_numDepthBits = 1 95 | -- , GLFW.displayOptions_displayMode = GLFW.Fullscreen 96 | } 97 | -- open a window 98 | True <- GLFW.openWindow dspOpts 99 | -- window starts at upper left corner of the screen 100 | GLFW.setWindowPosition 0 0 101 | GLFW.setWindowTitle "Random UV generation test" 102 | -- register the function to do all our OpenGL drawing 103 | GLFW.setWindowRefreshCallback drawScene 104 | -- register the funciton called when our window is resized 105 | GLFW.setWindowSizeCallback resizeScene 106 | -- register the function called when the keyboard is pressed. 107 | GLFW.setKeyCallback keyPressed 108 | GLFW.setWindowCloseCallback shutdown 109 | -- initialize our window. 110 | initGL 111 | -- start event processing engine 112 | forever $ do 113 | drawScene 114 | GLFW.swapBuffers 115 | -------------------------------------------------------------------------------- /app/src/Tests/UnitTests.hs: -------------------------------------------------------------------------------- 1 | -- This defines all unit tests to be executed for this project 2 | 3 | import Tests.VectorTest 4 | import Tests.BoundingBoxTest 5 | import Tests.ColourTest 6 | import Tests.OctreeTest 7 | import Tests.PrimitiveTest 8 | import Test.HUnit 9 | 10 | unitTests = [tests_Vector, tests_BoundingBox, tests_Colour, tests_Octree, tests_Primitive] 11 | 12 | main = mapM runTestTT unitTests 13 | -------------------------------------------------------------------------------- /app/src/Tests/VectorTest.hs: -------------------------------------------------------------------------------- 1 | module Tests.VectorTest where 2 | 3 | import PolymorphicNum 4 | import Vector 5 | import Test.HUnit 6 | 7 | test_Add = TestCase (assertEqual "Vector addition" expectedResult (v1 <+> v2)) 8 | where 9 | v1 = Vector 1 2 3 4 10 | v2 = Vector 10 20 30 40 11 | expectedResult = Vector 11 22 33 44 12 | 13 | test_Sub = TestCase (assertEqual "Vector subtraction" expectedResult (v1 <-> v2)) 14 | where 15 | v1 = Vector 10 20 30 40 16 | v2 = Vector 1 2 3 4 17 | expectedResult = Vector 9 18 27 36 18 | 19 | test_Mul = TestCase (assertEqual "Vector multiplication" expectedResult (v1 <*> v2)) 20 | where 21 | v1 = Vector 1 0 2 3 22 | v2 = Vector 1 10 (-2) 3 23 | expectedResult = Vector 1 0 (-4) 9 24 | 25 | test_Madd = TestCase (assertEqual "Vector madd" expectedResult (madd pos dir k)) 26 | where 27 | pos = Vector 1 2 3 1 28 | dir = Vector 0.5 0 1 0 29 | k = 10 30 | expectedResult = Vector 6 2 13 1 31 | 32 | test_ScalarMul = TestCase (assertEqual "Vector-scalar mul" expectedResult (vec <*> k)) 33 | where 34 | vec = Vector 1 2 (-3) 1 35 | k = 2 :: Double 36 | expectedResult = Vector 2 4 (-6) 2 37 | 38 | test_ScalarDiv = TestCase (assertEqual "Vector-scalar div" expectedResult (vec k)) 39 | where 40 | vec = Vector 10 20 (-30) 40 41 | k = 2 :: Double 42 | expectedResult = Vector 5 10 (-15) 20 43 | 44 | test_ScalarDot3 = TestCase (assertEqual "dot3" expectedResult (v1 `dot3` v2)) 45 | where 46 | v1 = Vector 1 2 0 1 47 | v2 = Vector (-2) 4 (-5) 1 48 | expectedResult = 6 49 | 50 | test_ScalarDot4 = TestCase (assertEqual "dot4" expectedResult (v1 `dot4` v2)) 51 | where 52 | v1 = Vector 1 2 0 1 53 | v2 = Vector (-2) 4 (-5) 1 54 | expectedResult = 7 55 | 56 | test_SatScalarDot3 = TestCase (assertEqual "sdot3" expectedResult (v1 `sdot3` v2)) 57 | where 58 | v1 = Vector 1 2 0 1 59 | v2 = Vector (-2) 4 (-5) 1 60 | expectedResult = 1 61 | 62 | test_SatScalarDot4 = TestCase (assertEqual "sdot4" expectedResult (v1 `sdot4` v2) ) 63 | where 64 | v1 = Vector 1 2 0 1 65 | v2 = Vector (-2) (-4) (-5) 1 66 | expectedResult = 0 67 | 68 | test_Cross = TestCase (assertEqual "cross" expectedResult (v1 `cross` v2)) 69 | where 70 | v1 = Vector 1 0 0 0 71 | v2 = Vector 0 1 0 0 72 | expectedResult = Vector 0 0 1 0 73 | 74 | test_Magnitude = TestCase (assertEqual "magnitude" expectedResult (magnitude v1)) 75 | where 76 | v1 = Vector 3 4 0 0 77 | expectedResult = 5 78 | 79 | test_MagnitudeSq = TestCase (assertEqual "magnitudeSq" expectedResult (magnitudeSq v1)) 80 | where 81 | v1 = Vector 3 4 0 0 82 | expectedResult = 25 83 | 84 | test_Normalise = TestCase (assertEqual "normalise" expectedResult (normalise v1)) 85 | where 86 | v1 = Vector 1 (-1) 1 0 87 | expectedResult = Vector 0.5773502691896258 (-0.5773502691896258) 0.5773502691896258 0 88 | 89 | test_Reflect = undefined 90 | test_Refract = undefined 91 | 92 | test_LargestAxis = TestCase (assertEqual "largestAxis" expectedResult (largestAxis v1)) 93 | where 94 | v1 = Vector (-1) 2 (-3) 0 95 | expectedResult = 2 96 | 97 | test_Min = TestCase (assertEqual "min" expectedResult (v1 `Vector.min` v2)) 98 | where 99 | v1 = Vector (-1) 2 (-3) 8 100 | v2 = Vector 10 (-20) 50 2 101 | expectedResult = Vector (-1) (-20) (-3) 2 102 | 103 | test_Max = TestCase (assertEqual "max" expectedResult (v1 `Vector.max` v2)) 104 | where 105 | v1 = Vector (-1) 2 (-3) 8 106 | v2 = Vector 10 (-20) 50 2 107 | expectedResult = Vector 10 2 50 8 108 | 109 | test_TransformDir = TestCase (assertEqual "TransformDir" expectedResult (transformDir normal tangentSpace)) 110 | where 111 | normal = Vector 0 0.7 0.7 0 112 | tangentSpace = (yaxis, zaxis, xaxis) 113 | expectedResult = Vector 0.7071067811865476 0 0.7071067811865476 0 114 | 115 | tests_Vector = TestList [ 116 | TestLabel "Addition" test_Add, 117 | TestLabel "Subtraction" test_Sub, 118 | TestLabel "Multiplication" test_Mul, 119 | TestLabel "Madd" test_Madd, 120 | TestLabel "Vector * scalar" test_ScalarMul, 121 | TestLabel "Vector / scalar" test_ScalarDiv, 122 | TestLabel "Dot3" test_ScalarDot3, 123 | TestLabel "Dot4" test_ScalarDot4, 124 | TestLabel "Sdot3" test_SatScalarDot3, 125 | TestLabel "Sdot4" test_SatScalarDot4, 126 | TestLabel "Cross" test_Cross, 127 | TestLabel "Magnitude" test_Magnitude, 128 | TestLabel "MagnitudeSq" test_MagnitudeSq, 129 | TestLabel "Normalise" test_Normalise, 130 | TestLabel "LargestAxis" test_LargestAxis, 131 | TestLabel "Min" test_Min, 132 | TestLabel "Max" test_Max, 133 | TestLabel "TransformDir" test_TransformDir 134 | ] 135 | -------------------------------------------------------------------------------- /app/src/ToneMap.hs: -------------------------------------------------------------------------------- 1 | -- Tone map an image 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | module ToneMap(toneMapImage, 5 | toneMapIdentity, 6 | toneMapAverageLuminance, 7 | toneMapReinhard, 8 | toneMapHejlBurgessDawson, 9 | exposeImage, 10 | imageAverageLogLuminance, 11 | imageAverageLuminance) where 12 | 13 | import PolymorphicNum 14 | import Colour 15 | import Data.List 16 | 17 | -- x = x 18 | toneMapIdentity :: [Colour] -> [Colour] 19 | toneMapIdentity = map id 20 | 21 | -- x = x / avg xs 22 | toneMapAverageLuminance :: [Colour] -> [Colour] 23 | toneMapAverageLuminance xs = map (<*> invAverageBrightness) xs 24 | where 25 | invAverageBrightness = 1 / imageAverageLuminance xs 26 | 27 | -- Reinhard tone map operator http://filmicgames.com/archives/75 28 | toneMapReinhard :: [Colour] -> [Colour] 29 | toneMapReinhard = map (\(Colour r g b _) -> Colour (r / (r + 1)) (g / (g + 1)) (b / (b + 1)) 1) 30 | 31 | -- Hejl-Burgess-Dawson http://filmicgames.com/archives/75 32 | toneMapHejlBurgessDawson :: [Colour] -> [Colour] 33 | toneMapHejlBurgessDawson = map f 34 | where 35 | f colour = (x <*> (x <*> (6.2 :: Double) <+> (0.5 :: Double))) (x <*> (x <*> (6.2 :: Double) <+> (1.7 :: Double)) <+> (0.06:: Double)) 36 | where 37 | x = (\x' -> fold max x' 0) (colour <-> (0.004 :: Double)) 38 | 39 | -- Apply a tone map operator 40 | toneMapImage :: ([Colour] -> [Colour]) -> [Colour] -> [Colour] 41 | toneMapImage f = f 42 | 43 | -- Normal averaging 44 | imageAverageLuminance :: [Colour] -> Double 45 | imageAverageLuminance xs = s / fromIntegral l 46 | where 47 | (s, l) = foldl' step (0, 0 :: Integer) xs 48 | step (!s', !l') a = (s' + luminance a, l' + 1) 49 | 50 | -- Get the average luminance of a scene, using Reinhard style log-lum averaging to damp down the effect of outlier pixels 51 | imageAverageLogLuminance :: [Colour] -> Double 52 | imageAverageLogLuminance xs = exp (s / fromIntegral l) 53 | where 54 | (s, l) = foldl' step (0, 0 :: Integer) xs 55 | step (!s', !l') a = (s' + logLuminance a, l' + 1) 56 | 57 | -- Adjust the exposure of an image 58 | exposeImage :: ([Colour] -> Double) -> [Colour] -> Double -> [Colour] 59 | exposeImage f xs exposureScale = map ( (exposure * exposureScale)) xs 60 | where 61 | exposure = f xs 62 | -------------------------------------------------------------------------------- /app/src/Vector.hs: -------------------------------------------------------------------------------- 1 | -- Vector library for 3d graphics 2 | 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | module Vector where 7 | 8 | import Prelude 9 | import PolymorphicNum as L 10 | import Data.List 11 | import Misc 12 | import Control.DeepSeq 13 | 14 | {-# SPECIALIZE INLINE vecX :: Vector -> Double #-} 15 | {-# SPECIALIZE INLINE vecY :: Vector -> Double #-} 16 | {-# SPECIALIZE INLINE vecZ :: Vector -> Double #-} 17 | 18 | data Vector = Vector { vecX :: {-# UNPACK #-} !Double, 19 | vecY :: {-# UNPACK #-} !Double, 20 | vecZ :: {-# UNPACK #-} !Double, 21 | vecW :: {-# UNPACK #-} !Double } deriving (Ord, Eq) 22 | type Position = Vector 23 | type Direction = Vector 24 | type Normal = Vector 25 | type TangentSpace = (Vector, Vector, Vector) 26 | type SurfaceLocation = (Position, TangentSpace) 27 | 28 | instance PolymorphicNum Vector Vector Vector where 29 | {-# SPECIALIZE INLINE (<+>) :: Vector -> Vector -> Vector #-} 30 | (Vector !x !y !z !w) <+> (Vector !x' !y' !z' !w') = Vector (x + x') (y + y') (z + z') (w + w') 31 | {-# SPECIALIZE INLINE (<->) :: Vector -> Vector -> Vector #-} 32 | (Vector !x !y !z !w) <-> (Vector !x' !y' !z' !w') = Vector (x - x') (y - y') (z - z') (w - w') 33 | {-# SPECIALIZE INLINE (<*>) :: Vector -> Vector -> Vector #-} 34 | (Vector !x !y !z !w) <*> (Vector !x' !y' !z' !w') = Vector (x * x') (y * y') (z * z') (w * w') 35 | {-# SPECIALIZE INLINE () :: Vector -> Vector -> Vector #-} 36 | (Vector !x !y !z !w) (Vector !x' !y' !z' !w') = Vector (x / x') (y / y') (z / z') (w / w') 37 | 38 | instance PolymorphicNum Vector Double Vector where 39 | {-# SPECIALIZE INLINE (<+>) :: Vector -> Double -> Vector #-} 40 | (Vector !x !y !z !w) <+> (!k) = Vector (x + k) (y + k) (z + k) (w + k) 41 | {-# SPECIALIZE INLINE (<->) :: Vector -> Double -> Vector #-} 42 | (Vector !x !y !z !w) <-> (!k) = Vector (x - k) (y - k) (z - k) (w - k) 43 | {-# SPECIALIZE INLINE (<*>) :: Vector -> Double -> Vector #-} 44 | (Vector !x !y !z !w) <*> (!k) = Vector (x * k) (y * k) (z * k) (w * k) 45 | {-# SPECIALIZE INLINE () :: Vector -> Double -> Vector #-} 46 | (Vector !x !y !z !w) (!k) = Vector (x / k) (y / k) (z / k) (w / k) 47 | 48 | instance PolymorphicNum Double Vector Vector where 49 | {-# SPECIALIZE INLINE (<+>) :: Double -> Vector -> Vector #-} 50 | (!k) <+> (Vector !x !y !z !w) = Vector (k + x) (k + y) (k + z) (k + w) 51 | {-# SPECIALIZE INLINE (<->) :: Double -> Vector -> Vector #-} 52 | (!k) <-> (Vector !x !y !z !w) = Vector (k - x) (k - y) (k - z) (k - w) 53 | {-# SPECIALIZE INLINE (<*>) :: Double -> Vector -> Vector #-} 54 | (!k) <*> (Vector !x !y !z !w) = Vector (k * x) (k * y) (k * z) (k * w) 55 | {-# SPECIALIZE INLINE () :: Double -> Vector -> Vector #-} 56 | (!k) (Vector !x !y !z !w) = Vector (k / x) (k / y) (k / z) (k / w) 57 | 58 | {- 59 | instance PolymorphicNum Vector (Num a) Vector where 60 | (Vector x y z w) <+> k = Vector (x + k) (y + k) (z + k) (w + k) 61 | (Vector x y z w) <-> k = Vector (x - k) (y - k) (z - k) (w - k) 62 | (Vector x y z w) <*> k = Vector (x * k) (y * k) (z * k) (w * k) 63 | (Vector x y z w) k = Vector (x / k) (y / k) (z / k) (w / k) 64 | 65 | instance PolymorphicNum (Num a) Vector Vector where 66 | k <+> (Vector x y z w) = Vector (k + x) (k + y) (k + z) (k + w) 67 | k <-> (Vector x y z w) = Vector (k - x) (k - y) (k - z) (k - w) 68 | k <*> (Vector x y z w) = Vector (k * x) (k * y) (k * z) (k * w) 69 | k (Vector x y z w) = Vector (k / x) (k / y) (k / z) (k / w) 70 | -} 71 | 72 | instance Show Vector where 73 | show (Vector !x !y !z !w) = "(" ++ show x ++ ", " ++ show y ++ ", " ++ show z ++ ", " ++ show w ++ ")" 74 | 75 | instance NFData Vector where 76 | rnf (Vector x y z w) = rnf x `seq` rnf y `seq` rnf z `seq` rnf w 77 | 78 | tsTangent :: TangentSpace -> Normal 79 | tsTangent (t, _, _) = t 80 | 81 | tsBinormal :: TangentSpace -> Normal 82 | tsBinormal (_, b, _) = b 83 | 84 | tsNormal :: TangentSpace -> Normal 85 | tsNormal = thr 86 | 87 | xaxis :: Vector 88 | xaxis = Vector 1 0 0 0 89 | 90 | yaxis :: Vector 91 | yaxis = Vector 0 1 0 0 92 | 93 | zaxis :: Vector 94 | zaxis = Vector 0 0 1 0 95 | 96 | waxis :: Vector 97 | waxis = Vector 0 0 0 1 98 | 99 | zeroVector :: Vector 100 | zeroVector = Vector 0 0 0 0 101 | 102 | setWTo1 :: Vector -> Vector 103 | {-# SPECIALIZE INLINE setWTo1 :: Vector -> Vector #-} 104 | setWTo1 v = v { vecW = 1 } 105 | 106 | setWTo0 :: Vector -> Vector 107 | {-# SPECIALIZE INLINE setWTo0 :: Vector -> Vector #-} 108 | setWTo0 v = v { vecW = 0 } 109 | 110 | restoreOriginalW :: Vector -> Vector -> Vector 111 | {-# SPECIALIZE INLINE restoreOriginalW :: Vector -> Vector -> Vector #-} 112 | restoreOriginalW (Vector _ _ _ !w') (Vector !x !y !z _) = Vector x y z w' 113 | 114 | madd :: Position -> Direction -> Double -> Vector 115 | {-# SPECIALIZE INLINE madd :: Vector -> Vector -> Double -> Vector #-} 116 | madd (Vector !x !y !z !w) (Vector !x' !y' !z' !w') !scalar = Vector x'' y'' z'' w'' 117 | where 118 | x'' = x + x' * scalar 119 | y'' = y + y' * scalar 120 | z'' = z + z' * scalar 121 | w'' = w + w' * scalar 122 | 123 | negate :: Direction -> Direction 124 | {-# SPECIALIZE INLINE Vector.negate :: Vector -> Vector #-} 125 | negate (Vector !x !y !z !w) = Vector (-x) (-y) (-z) (-w) 126 | 127 | dot3 :: Vector -> Vector -> Double 128 | {-# SPECIALIZE INLINE dot3 :: Vector -> Vector -> Double #-} 129 | (Vector !x !y !z _) `dot3` (Vector !x' !y' !z' _) = x * x' + y * y' + z * z' 130 | 131 | dot4 :: Vector -> Vector -> Double 132 | {-# SPECIALIZE INLINE dot4 :: Vector -> Vector -> Double #-} 133 | (Vector !x !y !z !w) `dot4` (Vector !x' !y' !z' !w') = x * x' + y * y' + z * z' + w * w' 134 | 135 | sdot3 :: Vector -> Vector -> Double 136 | {-# SPECIALIZE INLINE dot3 :: Vector -> Vector -> Double #-} 137 | (Vector !x !y !z _) `sdot3` (Vector !x' !y' !z' _) = saturate (x * x' + y * y' + z * z') 138 | 139 | sdot4 :: Vector -> Vector -> Double 140 | {-# SPECIALIZE INLINE sdot4 :: Vector -> Vector -> Double #-} 141 | (Vector !x !y !z !w) `sdot4` (Vector !x' !y' !z' !w') = saturate (x * x' + y * y' + z * z' + w * w') 142 | 143 | cross :: Direction -> Direction -> Direction 144 | {-# SPECIALIZE INLINE cross :: Vector -> Vector -> Vector #-} 145 | (Vector !x1 !y1 !z1 _) `cross` (Vector !x2 !y2 !z2 _) = Vector x y z 0 146 | where 147 | !x = y1 * z2 - y2 * z1 148 | !y = z1 * x2 - z2 * x1 149 | !z = x1 * y2 - x2 * y1 150 | 151 | magnitude :: Vector -> Double 152 | {-# SPECIALIZE INLINE magnitude :: Vector -> Double #-} 153 | magnitude !vec = sqrt (magnitudeSq vec) 154 | 155 | magnitudeSq :: Vector -> Double 156 | {-# SPECIALIZE INLINE magnitudeSq :: Vector -> Double #-} 157 | magnitudeSq (Vector !x !y !z _) = x * x + y * y + z * z 158 | 159 | normalise :: Direction -> Direction 160 | {-# SPECIALIZE INLINE normalise :: Direction -> Direction #-} 161 | normalise !a = setWTo0 (a magnitude a) 162 | 163 | distance :: Position -> Position -> Double 164 | {-# SPECIALIZE INLINE distance :: Position -> Position -> Double #-} 165 | distance !a !b = magnitude (a <-> b) 166 | 167 | distanceSq :: Position -> Position -> Double 168 | {-# SPECIALIZE INLINE distanceSq :: Position -> Position -> Double #-} 169 | distanceSq !a !b = magnitudeSq (a <-> b) 170 | 171 | reflect :: Direction -> Direction -> Direction 172 | {-# SPECIALIZE INLINE reflect :: Direction -> Direction -> Direction #-} 173 | reflect !incoming !normal = setWTo0 $ (normal <*> (2 * (normal `dot3` incoming))) <-> incoming 174 | 175 | refract :: Direction -> Direction -> Double -> Direction 176 | {-# SPECIALIZE INLINE refract :: Vector -> Vector -> Double -> Vector #-} 177 | refract !incoming !normal !eta 178 | | cosTheta1 > 0.0 = setWTo0 $ (l <*> eta) <+> (normal <*> (eta * cosTheta1 - cosTheta2)) 179 | | otherwise = setWTo0 $ (l <*> eta) <+> (normal <*> (eta * cosTheta1 + cosTheta2)) 180 | where !cosTheta1 = normal `dot3` incoming 181 | !cosTheta2 = sqrt (1.0 - eta ** 2.0 * (1.0 - cosTheta1 ** 2.0)) 182 | !l = Vector.negate incoming 183 | 184 | largestAxis :: Vector -> Int 185 | largestAxis (Vector !x !y !z _) 186 | | abs x >= abs y && abs x >= abs z = 0 187 | | abs y >= abs x && abs y >= abs z = 1 188 | | abs z >= abs x && abs z >= abs y = 2 189 | | otherwise = error "largestAxis: Undefined case" 190 | 191 | nthLargestAxis :: Vector -> Int -> Int 192 | nthLargestAxis (Vector !x !y !z _) order 193 | | order < 3 = snd (sort [(abs x, 0), (abs y, 1), (abs z, 2)] !! order) 194 | | otherwise = error "nthLargestAXis: Undefined case" 195 | 196 | min :: Vector -> Vector -> Vector 197 | {-# SPECIALIZE INLINE Vector.min :: Vector -> Vector -> Vector #-} 198 | min (Vector !x1 !y1 !z1 !w1) (Vector !x2 !y2 !z2 !w2) = Vector x y z w 199 | where 200 | !x = Prelude.min x1 x2 201 | !y = Prelude.min y1 y2 202 | !z = Prelude.min z1 z2 203 | !w = Prelude.min w1 w2 204 | 205 | max :: Vector -> Vector -> Vector 206 | {-# SPECIALIZE INLINE Vector.max :: Vector -> Vector -> Vector #-} 207 | max (Vector !x1 !y1 !z1 !w1) (Vector !x2 !y2 !z2 !w2) = Vector x y z w 208 | where 209 | !x = Prelude.max x1 x2 210 | !y = Prelude.max y1 y2 211 | !z = Prelude.max z1 z2 212 | !w = Prelude.max w1 w2 213 | 214 | directionToSpherical :: Direction -> (Double, Double) 215 | directionToSpherical (Vector !x !y !z _) = (theta, phi) 216 | where 217 | theta = acos z / pi 218 | phi = (atan2 y x + pi) / (2.0 * pi) 219 | 220 | sphericalToDirection :: Double -> Double -> Direction 221 | sphericalToDirection !theta !phi = Vector (sin theta * cos phi) (sin theta * sin phi) (cos theta) 1 222 | 223 | component :: Vector -> Int -> Double 224 | {-# SPECIALIZE INLINE component :: Vector -> Int -> Double #-} 225 | component (Vector !x _ _ _) 0 = x 226 | component (Vector _ !y _ _) 1 = y 227 | component (Vector _ _ !z _) 2 = z 228 | component (Vector _ _ _ !w) 3 = w 229 | component _ _ = error "Invalid component index" 230 | 231 | transformDir :: Direction -> TangentSpace -> Direction 232 | {-# SPECIALIZE INLINE transformDir :: Direction -> TangentSpace -> Direction #-} 233 | transformDir (Vector !x !y !z _) !(tangent, binormal, normal) = (setWTo0 . normalise) (tangent <*> x <+> binormal <*> y <+> normal <*> z) 234 | 235 | recipPerElem :: Vector -> Vector 236 | recipPerElem (Vector !x !y !z !w) = Vector (f x) (f y) (f z) (f w) 237 | where 238 | f a | a == 0 = 10000000 -- What is Haskell for infinity? 239 | | otherwise = 1 / a 240 | 241 | -- This function constructs a tangent space for a given normal. It gives no guarantees about how that space is rotated... just that it works 242 | -- So, be careful if you use this to do anything anisotropic! 243 | constructTangentSpace :: Direction -> TangentSpace 244 | constructTangentSpace givenNormal@(Vector nx ny nz _) = (setWTo0 tangent, setWTo0 binormal, setWTo0 givenNormal) 245 | where 246 | tangent' | nx /= 0 = Vector ny nx nz 0 247 | | ny /= 0 = Vector nx nz ny 0 248 | | otherwise = Vector nz ny nx 0 249 | tangent = tangent' <-> givenNormal <*> (givenNormal `dot3` tangent') 250 | binormal = normalise (tangent `cross` givenNormal) -------------------------------------------------------------------------------- /app/src/scripts/build: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Build main code 4 | ghc -optl"-Wl,-read_only_relocs,suppress" -tmpdir tmp -hidir hi -odir obj -fext-core -fexcess-precision -funbox-strict-fields -threaded -rtsopts -fwarn-missing-signatures -Wall -O2 -fspec-constr -fliberate-case -fstatic-argument-transformation -fspec-constr-count=10 Main.hs -o ../crocodile $1 $2 $3 $4 $5 $6 $7 $8 $9 5 | 6 | # Tidy up 7 | mv *.hcr core/ 8 | 9 | # Unit test 10 | scripts/unit_test 11 | 12 | rm obj/Main.o 13 | 14 | # Build test suite 15 | ghc -optl"-Wl,-read_only_relocs,suppress" -tmpdir tmp -hidir hi -odir obj -fext-core -fexcess-precision -funbox-strict-fields -threaded -rtsopts -fwarn-missing-signatures -Wall -O2 -fspec-constr -fliberate-case -fstatic-argument-transformation Tests/HemisphereTest/HemisphereTest.hs -o Tests/HemisphereTest/HemisphereTest $1 $2 $3 $4 $5 $6 $7 $8 $9 16 | 17 | rm obj/Main.o 18 | 19 | ghc -optl"-Wl,-read_only_relocs,suppress" -tmpdir tmp -hidir hi -odir obj -fext-core -fexcess-precision -funbox-strict-fields -threaded -rtsopts -fwarn-missing-signatures -Wall -O2 -fspec-constr -fliberate-case -fstatic-argument-transformation Tests/RandomUVTest/RandomUVTest.hs -o Tests/RandomUVTest/RandomUVTest $1 $2 $3 $4 $5 $6 $7 $8 $9 20 | 21 | -------------------------------------------------------------------------------- /app/src/scripts/build-caf-debug: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ghc -tmpdir tmp -hidir hi -odir obj --make -fext-core Main.hs -o ../crocodile -fwarn-missing-signatures -Wall -prof -auto-all -caf-all -rtsopts $1 $2 $3 $4 $5 $6 $7 $8 $9 3 | mv *.hcr core/ 4 | -------------------------------------------------------------------------------- /app/src/scripts/build-profile: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ghc -tmpdir tmp -hidir hi -odir obj --make -O2 -fext-core -fexcess-precision -funfolding-use-threshold=16 -funbox-strict-fields Main.hs -o ../crocodile -funfolding-keeness-factor=10 -fwarn-missing-signatures -Wall -feager-blackholing -prof -auto-all -caf-all -rtsopts $1 $2 $3 $4 $5 $6 $7 $8 $9 3 | mv *.hcr core/ 4 | -------------------------------------------------------------------------------- /app/src/scripts/build-single-hs-file: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ghc -tmpdir tmp -hidir hi -odir obj -fext-core -fexcess-precision -funbox-strict-fields -threaded -rtsopts -fwarn-missing-signatures -Wall -O2 -fspec-constr -fliberate-case -fstatic-argument-transformation $1 $2 $3 $4 $5 $6 $7 $8 $9 3 | -------------------------------------------------------------------------------- /app/src/scripts/clean: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | rm obj/*.o 3 | -------------------------------------------------------------------------------- /app/src/scripts/run-hlint: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ~/.cabal/bin/hlint *.hs > hlint-output.txt 3 | less hlint-output.txt 4 | -------------------------------------------------------------------------------- /app/src/scripts/unit_test: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | runhaskell -- -fobject-code Tests/UnitTests.hs 3 | -------------------------------------------------------------------------------- /app/src/temp.txt: -------------------------------------------------------------------------------- 1 | [ 3 of 26] Compiling Vector ( Vector.hs, obj/Vector.o ) 2 | 3 | Vector.hs:189:65: 4 | No instance for (LinearAlgebra Direction b0 a0) 5 | arising from a use of `<*>' 6 | Possible fix: 7 | add an instance declaration for (LinearAlgebra Direction b0 a0) 8 | In the first argument of `(<->)', namely 9 | `(normal <*> (2.0 <*> (normal `dot3` incoming)))' 10 | In the second argument of `($)', namely 11 | `(normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming' 12 | In the expression: 13 | restoreOriginalW incoming 14 | $ (normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming 15 | 16 | Vector.hs:189:74: 17 | No instance for (LinearAlgebra a1 Double b0) 18 | arising from a use of `<*>' 19 | Possible fix: 20 | add an instance declaration for (LinearAlgebra a1 Double b0) 21 | In the second argument of `(<*>)', namely 22 | `(2.0 <*> (normal `dot3` incoming))' 23 | In the first argument of `(<->)', namely 24 | `(normal <*> (2.0 <*> (normal `dot3` incoming)))' 25 | In the second argument of `($)', namely 26 | `(normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming' 27 | 28 | Vector.hs:189:105: 29 | No instance for (LinearAlgebra a0 Direction Vector) 30 | arising from a use of `<->' 31 | Possible fix: 32 | add an instance declaration for (LinearAlgebra a0 Direction Vector) 33 | In the second argument of `($)', namely 34 | `(normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming' 35 | In the expression: 36 | restoreOriginalW incoming 37 | $ (normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming 38 | In an equation for `reflect': 39 | reflect !incoming !normal 40 | = restoreOriginalW incoming 41 | $ (normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming 42 | 43 | Vector.hs:194:42: 44 | No instance for (LinearAlgebra Direction Double a2) 45 | arising from a use of `<*>' 46 | Possible fix: 47 | add an instance declaration for (LinearAlgebra Direction Double a2) 48 | In the first argument of `(<+>)', namely `(l <*> eta)' 49 | In the second argument of `($)', namely 50 | `(l <*> eta) 51 | <+> 52 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2))' 53 | In the expression: 54 | setWTo0 55 | $ (l <*> eta) 56 | <+> 57 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 58 | 59 | Vector.hs:194:51: 60 | No instance for (LinearAlgebra a2 b1 Vector) 61 | arising from a use of `<+>' 62 | Possible fix: 63 | add an instance declaration for (LinearAlgebra a2 b1 Vector) 64 | In the second argument of `($)', namely 65 | `(l <*> eta) 66 | <+> 67 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2))' 68 | In the expression: 69 | setWTo0 70 | $ (l <*> eta) 71 | <+> 72 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 73 | In an equation for `refract': 74 | refract !incoming !normal !eta 75 | | cosTheta1 >## 0.0## 76 | = setWTo0 77 | $ (l <*> eta) 78 | <+> 79 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 80 | | otherwise 81 | = setWTo0 82 | $ (l <*> eta) 83 | <+> 84 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 85 | where 86 | !(D# cosTheta1) = normal `dot3` incoming 87 | !cosTheta2 88 | = sqrtDouble# 89 | (1.0## -## eta# **## 2.0## *## (1.0## -## cosTheta1 **## 2.0##)) 90 | !l = Vector.negate incoming 91 | !(D# eta#) = eta 92 | 93 | Vector.hs:194:63: 94 | No instance for (LinearAlgebra Direction Double b1) 95 | arising from a use of `<*>' 96 | Possible fix: 97 | add an instance declaration for (LinearAlgebra Direction Double b1) 98 | In the second argument of `(<+>)', namely 99 | `(normal <*> D# (eta# *## cosTheta1 -## cosTheta2))' 100 | In the second argument of `($)', namely 101 | `(l <*> eta) 102 | <+> 103 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2))' 104 | In the expression: 105 | setWTo0 106 | $ (l <*> eta) 107 | <+> 108 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 109 | 110 | Vector.hs:195:32: 111 | No instance for (LinearAlgebra Direction Double a3) 112 | arising from a use of `<*>' 113 | Possible fix: 114 | add an instance declaration for (LinearAlgebra Direction Double a3) 115 | In the first argument of `(<+>)', namely `(l <*> eta)' 116 | In the second argument of `($)', namely 117 | `(l <*> eta) 118 | <+> 119 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2))' 120 | In the expression: 121 | setWTo0 122 | $ (l <*> eta) 123 | <+> 124 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 125 | 126 | Vector.hs:195:41: 127 | No instance for (LinearAlgebra a3 b2 Vector) 128 | arising from a use of `<+>' 129 | Possible fix: 130 | add an instance declaration for (LinearAlgebra a3 b2 Vector) 131 | In the second argument of `($)', namely 132 | `(l <*> eta) 133 | <+> 134 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2))' 135 | In the expression: 136 | setWTo0 137 | $ (l <*> eta) 138 | <+> 139 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 140 | In an equation for `refract': 141 | refract !incoming !normal !eta 142 | | cosTheta1 >## 0.0## 143 | = setWTo0 144 | $ (l <*> eta) 145 | <+> 146 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 147 | | otherwise 148 | = setWTo0 149 | $ (l <*> eta) 150 | <+> 151 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 152 | where 153 | !(D# cosTheta1) = normal `dot3` incoming 154 | !cosTheta2 155 | = sqrtDouble# 156 | (1.0## -## eta# **## 2.0## *## (1.0## -## cosTheta1 **## 2.0##)) 157 | !l = Vector.negate incoming 158 | !(D# eta#) = eta 159 | 160 | Vector.hs:195:53: 161 | No instance for (LinearAlgebra Direction Double b2) 162 | arising from a use of `<*>' 163 | Possible fix: 164 | add an instance declaration for (LinearAlgebra Direction Double b2) 165 | In the second argument of `(<+>)', namely 166 | `(normal <*> D# (eta# *## cosTheta1 +## cosTheta2))' 167 | In the second argument of `($)', namely 168 | `(l <*> eta) 169 | <+> 170 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2))' 171 | In the expression: 172 | setWTo0 173 | $ (l <*> eta) 174 | <+> 175 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 176 | 177 | Vector.hs:250:83: 178 | No instance for (LinearAlgebra Vector Double a5) 179 | arising from a use of `<*>' 180 | Possible fix: 181 | add an instance declaration for (LinearAlgebra Vector Double a5) 182 | In the first argument of `(<+>)', namely `tangent <*> x' 183 | In the first argument of `(<+>)', namely 184 | `tangent <*> x <+> binormal <*> y' 185 | In the second argument of `($)', namely 186 | `tangent <*> x <+> binormal <*> y <+> normal <*> z' 187 | 188 | Vector.hs:250:102: 189 | No instance for (LinearAlgebra Vector Double b4) 190 | arising from a use of `<*>' 191 | Possible fix: 192 | add an instance declaration for (LinearAlgebra Vector Double b4) 193 | In the second argument of `(<+>)', namely `binormal <*> y' 194 | In the first argument of `(<+>)', namely 195 | `tangent <*> x <+> binormal <*> y' 196 | In the second argument of `($)', namely 197 | `tangent <*> x <+> binormal <*> y <+> normal <*> z' 198 | 199 | Vector.hs:250:108: 200 | No instance for (LinearAlgebra a4 b3 Vector) 201 | arising from a use of `<+>' 202 | Possible fix: 203 | add an instance declaration for (LinearAlgebra a4 b3 Vector) 204 | In the second argument of `($)', namely 205 | `tangent <*> x <+> binormal <*> y <+> normal <*> z' 206 | In the expression: 207 | setWTo0 $ tangent <*> x <+> binormal <*> y <+> normal <*> z 208 | In an equation for `transformDir': 209 | transformDir (Vector !x !y !z _) !(tangent, binormal, normal) 210 | = setWTo0 $ tangent <*> x <+> binormal <*> y <+> normal <*> z 211 | 212 | Vector.hs:250:119: 213 | No instance for (LinearAlgebra Vector Double b3) 214 | arising from a use of `<*>' 215 | Possible fix: 216 | add an instance declaration for (LinearAlgebra Vector Double b3) 217 | In the second argument of `(<+>)', namely `normal <*> z' 218 | In the second argument of `($)', namely 219 | `tangent <*> x <+> binormal <*> y <+> normal <*> z' 220 | In the expression: 221 | setWTo0 $ tangent <*> x <+> binormal <*> y <+> normal <*> z 222 | mv: rename *.hcr to core/*.hcr: No such file or directory 223 | 224 | Vector.hs:189:65: 225 | No instance for (LinearAlgebra Direction b0 a0) 226 | arising from a use of `<*>' 227 | Possible fix: 228 | add an instance declaration for (LinearAlgebra Direction b0 a0) 229 | In the first argument of `(<->)', namely 230 | `(normal <*> (2.0 <*> (normal `dot3` incoming)))' 231 | In the second argument of `($)', namely 232 | `(normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming' 233 | In the expression: 234 | restoreOriginalW incoming 235 | $ (normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming 236 | 237 | Vector.hs:189:74: 238 | No instance for (LinearAlgebra a1 Double b0) 239 | arising from a use of `<*>' 240 | Possible fix: 241 | add an instance declaration for (LinearAlgebra a1 Double b0) 242 | In the second argument of `(<*>)', namely 243 | `(2.0 <*> (normal `dot3` incoming))' 244 | In the first argument of `(<->)', namely 245 | `(normal <*> (2.0 <*> (normal `dot3` incoming)))' 246 | In the second argument of `($)', namely 247 | `(normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming' 248 | 249 | Vector.hs:189:105: 250 | No instance for (LinearAlgebra a0 Direction Vector) 251 | arising from a use of `<->' 252 | Possible fix: 253 | add an instance declaration for (LinearAlgebra a0 Direction Vector) 254 | In the second argument of `($)', namely 255 | `(normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming' 256 | In the expression: 257 | restoreOriginalW incoming 258 | $ (normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming 259 | In an equation for `reflect': 260 | reflect !incoming !normal 261 | = restoreOriginalW incoming 262 | $ (normal <*> (2.0 <*> (normal `dot3` incoming))) <-> incoming 263 | 264 | Vector.hs:194:42: 265 | No instance for (LinearAlgebra Direction Double a2) 266 | arising from a use of `<*>' 267 | Possible fix: 268 | add an instance declaration for (LinearAlgebra Direction Double a2) 269 | In the first argument of `(<+>)', namely `(l <*> eta)' 270 | In the second argument of `($)', namely 271 | `(l <*> eta) 272 | <+> 273 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2))' 274 | In the expression: 275 | setWTo0 276 | $ (l <*> eta) 277 | <+> 278 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 279 | 280 | Vector.hs:194:51: 281 | No instance for (LinearAlgebra a2 b1 Vector) 282 | arising from a use of `<+>' 283 | Possible fix: 284 | add an instance declaration for (LinearAlgebra a2 b1 Vector) 285 | In the second argument of `($)', namely 286 | `(l <*> eta) 287 | <+> 288 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2))' 289 | In the expression: 290 | setWTo0 291 | $ (l <*> eta) 292 | <+> 293 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 294 | In an equation for `refract': 295 | refract !incoming !normal !eta 296 | | cosTheta1 >## 0.0## 297 | = setWTo0 298 | $ (l <*> eta) 299 | <+> 300 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 301 | | otherwise 302 | = setWTo0 303 | $ (l <*> eta) 304 | <+> 305 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 306 | where 307 | !(D# cosTheta1) = normal `dot3` incoming 308 | !cosTheta2 309 | = sqrtDouble# 310 | (1.0## -## eta# **## 2.0## *## (1.0## -## cosTheta1 **## 2.0##)) 311 | !l = Vector.negate incoming 312 | !(D# eta#) = eta 313 | 314 | Vector.hs:194:63: 315 | No instance for (LinearAlgebra Direction Double b1) 316 | arising from a use of `<*>' 317 | Possible fix: 318 | add an instance declaration for (LinearAlgebra Direction Double b1) 319 | In the second argument of `(<+>)', namely 320 | `(normal <*> D# (eta# *## cosTheta1 -## cosTheta2))' 321 | In the second argument of `($)', namely 322 | `(l <*> eta) 323 | <+> 324 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2))' 325 | In the expression: 326 | setWTo0 327 | $ (l <*> eta) 328 | <+> 329 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 330 | 331 | Vector.hs:195:32: 332 | No instance for (LinearAlgebra Direction Double a3) 333 | arising from a use of `<*>' 334 | Possible fix: 335 | add an instance declaration for (LinearAlgebra Direction Double a3) 336 | In the first argument of `(<+>)', namely `(l <*> eta)' 337 | In the second argument of `($)', namely 338 | `(l <*> eta) 339 | <+> 340 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2))' 341 | In the expression: 342 | setWTo0 343 | $ (l <*> eta) 344 | <+> 345 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 346 | 347 | Vector.hs:195:41: 348 | No instance for (LinearAlgebra a3 b2 Vector) 349 | arising from a use of `<+>' 350 | Possible fix: 351 | add an instance declaration for (LinearAlgebra a3 b2 Vector) 352 | In the second argument of `($)', namely 353 | `(l <*> eta) 354 | <+> 355 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2))' 356 | In the expression: 357 | setWTo0 358 | $ (l <*> eta) 359 | <+> 360 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 361 | In an equation for `refract': 362 | refract !incoming !normal !eta 363 | | cosTheta1 >## 0.0## 364 | = setWTo0 365 | $ (l <*> eta) 366 | <+> 367 | (normal <*> D# (eta# *## cosTheta1 -## cosTheta2)) 368 | | otherwise 369 | = setWTo0 370 | $ (l <*> eta) 371 | <+> 372 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 373 | where 374 | !(D# cosTheta1) = normal `dot3` incoming 375 | !cosTheta2 376 | = sqrtDouble# 377 | (1.0## -## eta# **## 2.0## *## (1.0## -## cosTheta1 **## 2.0##)) 378 | !l = Vector.negate incoming 379 | !(D# eta#) = eta 380 | 381 | Vector.hs:195:53: 382 | No instance for (LinearAlgebra Direction Double b2) 383 | arising from a use of `<*>' 384 | Possible fix: 385 | add an instance declaration for (LinearAlgebra Direction Double b2) 386 | In the second argument of `(<+>)', namely 387 | `(normal <*> D# (eta# *## cosTheta1 +## cosTheta2))' 388 | In the second argument of `($)', namely 389 | `(l <*> eta) 390 | <+> 391 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2))' 392 | In the expression: 393 | setWTo0 394 | $ (l <*> eta) 395 | <+> 396 | (normal <*> D# (eta# *## cosTheta1 +## cosTheta2)) 397 | 398 | Vector.hs:250:83: 399 | No instance for (LinearAlgebra Vector Double a5) 400 | arising from a use of `<*>' 401 | Possible fix: 402 | add an instance declaration for (LinearAlgebra Vector Double a5) 403 | In the first argument of `(<+>)', namely `tangent <*> x' 404 | In the first argument of `(<+>)', namely 405 | `tangent <*> x <+> binormal <*> y' 406 | In the second argument of `($)', namely 407 | `tangent <*> x <+> binormal <*> y <+> normal <*> z' 408 | 409 | Vector.hs:250:102: 410 | No instance for (LinearAlgebra Vector Double b4) 411 | arising from a use of `<*>' 412 | Possible fix: 413 | add an instance declaration for (LinearAlgebra Vector Double b4) 414 | In the second argument of `(<+>)', namely `binormal <*> y' 415 | In the first argument of `(<+>)', namely 416 | `tangent <*> x <+> binormal <*> y' 417 | In the second argument of `($)', namely 418 | `tangent <*> x <+> binormal <*> y <+> normal <*> z' 419 | 420 | Vector.hs:250:108: 421 | No instance for (LinearAlgebra a4 b3 Vector) 422 | arising from a use of `<+>' 423 | Possible fix: 424 | add an instance declaration for (LinearAlgebra a4 b3 Vector) 425 | In the second argument of `($)', namely 426 | `tangent <*> x <+> binormal <*> y <+> normal <*> z' 427 | In the expression: 428 | setWTo0 $ tangent <*> x <+> binormal <*> y <+> normal <*> z 429 | In an equation for `transformDir': 430 | transformDir (Vector !x !y !z _) !(tangent, binormal, normal) 431 | = setWTo0 $ tangent <*> x <+> binormal <*> y <+> normal <*> z 432 | 433 | Vector.hs:250:119: 434 | No instance for (LinearAlgebra Vector Double b3) 435 | arising from a use of `<*>' 436 | Possible fix: 437 | add an instance declaration for (LinearAlgebra Vector Double b3) 438 | In the second argument of `(<+>)', namely `normal <*> z' 439 | In the second argument of `($)', namely 440 | `tangent <*> x <+> binormal <*> y <+> normal <*> z' 441 | In the expression: 442 | setWTo0 $ tangent <*> x <+> binormal <*> y <+> normal <*> z 443 | --------------------------------------------------------------------------------