├── LICENSE ├── README.md ├── camera.lisp ├── clrt.asd ├── cube.lisp ├── lights.lisp ├── linalg-tests.lisp ├── linalg.lisp ├── material.lisp ├── objects.lisp ├── ray.lisp ├── scene.lisp ├── simple-scene.lisp └── sphere.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | DISCLAIMER 2 | ========== 3 | 4 | The source-code corresponds to [this series of screencasts](http://rudairandamacha.blogspot.de/2012/09/writing-simple-raytracer-in-common-lisp.html). As both the screencasts and the source-code were made in 2009, _all of this is only provided for convenience and totally unmaintained_. 5 | 6 | LICENSE 7 | ======= 8 | 9 | Copyright 2009 by Alexander Lehmann 10 | 11 | Licensed under the Apache License, Version 2.0 (the "License"); 12 | you may not use this file except in compliance with the License. 13 | You may obtain a copy of the License at 14 | 15 | http://www.apache.org/licenses/LICENSE-2.0 16 | 17 | Unless required by applicable law or agreed to in writing, software 18 | distributed under the License is distributed on an "AS IS" BASIS, 19 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 20 | See the License for the specific language governing permissions and 21 | limitations under the License. 22 | 23 | DEPENDENCIES 24 | ============ 25 | 26 | The only dependency is [zpng](http://www.xach.com/lisp/zpng/). 27 | 28 | In order to install and manage dependencies, this project makes use of both [asdf-install](http://www.cliki.net/ASDF-Install) and [asdf](http://common-lisp.net/project/asdf/). Please note that the former has been deprecated for quite some time now (keep in mind that this source-code and the corresponding tutorial were made in 2009), however it still works ok in this case. Also note that both probably come pre-installed with your current Lisp implementation, e.g. [sbcl](http://www.sbcl.org/). 29 | 30 | Using `asdf-install` makes installing the necessary dependencies fairly easy: 31 | 32 | ```lisp 33 | (require 'asdf-install) 34 | (asdf-install:install 'zpng) 35 | ``` 36 | 37 | In case you haven't used `asdf-install` before, don't get anxious when you see something like the following warning about a missing GPG key. Just skip the GPG check and go on with the installation process: 38 | 39 | No key found for key id 0x71CA4AFEE03213D2. Try some command like 40 | gpg --recv-keys 0x71CA4AFEE03213D2 41 | 42 | Type HELP for debugger help, or (SB-EXT:QUIT) to exit from SBCL. 43 | 44 | restarts (invokable by number or by possibly-abbreviated name): 45 | 0: [SKIP-GPG-CHECK] Don't check GPG signature for this package 46 | 1: [ABORT ] Exit debugger, returning to top level. 47 | 48 | Another thing that might show up during installation is a warning about a missing component (most likely `zpng` or `salza2`). If you run into this, simply choose to retry finding the missing module after reinitializing the source-registry: 49 | 50 | Component "zpng" not found 51 | 52 | Type HELP for debugger help, or (SB-EXT:QUIT) to exit from SBCL. 53 | 54 | restarts (invokable by number or by possibly-abbreviated name): 55 | 0: [REINITIALIZE-SOURCE-REGISTRY-AND-RETRY] Retry finding system zpng after 56 | reinitializing the 57 | source-registry. 58 | 1: [RETRY ] Retry installation 59 | 2: [ABORT ] Exit debugger, returning to top 60 | level. 61 | 62 | Now you're ready to run. 63 | 64 | RUNNING THE EXAMPLE 65 | =================== 66 | 67 | You can find the setup for a simple example scene in `simple-scene.lisp`. Running the example is easy once you've installed the necessary dependencies. 68 | 69 | First change to the directory that contains the sources, then start you're favorite Lisp interpreter and off you go: 70 | 71 | ```lisp 72 | (require 'asdf) 73 | (asdf:load-system 'clrt) 74 | (load "simple-scene") 75 | (simple-scene:render) 76 | ``` 77 | 78 | The resulting image will then be saved as `test.png`. 79 | -------------------------------------------------------------------------------- /camera.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; camera.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage #:clrt-camera 20 | (:use :cl :linalg) 21 | (:export #:camera 22 | #:camera-pos 23 | #:camera-direction 24 | #:camera-fov 25 | #:world->view)) 26 | 27 | 28 | (in-package #:clrt-camera) 29 | 30 | 31 | 32 | (defclass camera () 33 | ((pos 34 | :initarg :pos 35 | :initform (error ":pos must be specified.") 36 | :type matrix 37 | :reader camera-pos) 38 | (dir 39 | :type matrix 40 | :reader camera-direction) 41 | (up 42 | :initarg :up 43 | :initform (error ":up must be specified.") 44 | :type matrix 45 | :reader camera-up) 46 | (fov 47 | :initarg :fov 48 | :initform 110.0 49 | :type (real 70.0 130.0) 50 | :reader camera-fov) 51 | (w2v-matrix 52 | :type matrix 53 | :reader w2v-matrix))) 54 | 55 | 56 | (defmethod initialize-instance :after ((cam camera) &key look-at) 57 | (setf (slot-value cam 'dir) 58 | (normalized (m- look-at (camera-pos cam))))) 59 | 60 | 61 | (defmethod w2v-matrix :before ((cam camera)) 62 | (unless (slot-boundp cam 'w2v-matrix) 63 | (let* ((right (normalized (cross (camera-up cam) (camera-direction cam)))) 64 | (up (normalized (cross (camera-direction cam) right))) 65 | (dir (camera-direction cam))) 66 | (setf (slot-value cam 'w2v-matrix) 67 | (make-instance 'matrix 68 | :rows 3 69 | :cols 3 70 | :data (make-array 9 71 | :element-type 'single-float 72 | :initial-contents (vector (vec-x right) 73 | (vec-y right) 74 | (vec-z right) 75 | (vec-x up) 76 | (vec-y up) 77 | (vec-z up) 78 | (vec-x dir) 79 | (vec-y dir) 80 | (vec-z dir)))))))) 81 | 82 | 83 | (defun world->view (cam vec) 84 | (m* (w2v-matrix cam) (m- vec (camera-pos cam)))) 85 | -------------------------------------------------------------------------------- /clrt.asd: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; clrt.asd 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (require 'asdf) 20 | 21 | 22 | (asdf:defsystem #:clrt 23 | :description "clrt: a simple common lisp raytracer" 24 | :author "Alexander Lehmann " 25 | :license "Apache License 2.0" 26 | :depends-on (#:zpng) 27 | :components 28 | ((:file "linalg") 29 | (:file "camera" :depends-on ("linalg")) 30 | (:file "objects" :depends-on ("linalg" "camera" "ray" "material")) 31 | (:file "scene" :depends-on ("linalg" "camera" "objects" "lights" "material")) 32 | (:file "sphere" :depends-on ("linalg" "objects")) 33 | (:file "ray" :depends-on ("linalg")) 34 | (:file "cube" :depends-on ("linalg" "objects")) 35 | (:file "lights" :depends-on ("linalg")) 36 | (:file "material" :depends-on ("linalg")))) 37 | 38 | 39 | -------------------------------------------------------------------------------- /cube.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; cube.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (in-package #:clrt-objects) 20 | 21 | 22 | (defclass cube (object) 23 | (fll 24 | flr 25 | fur 26 | ful 27 | bll 28 | blr 29 | bur 30 | bul 31 | ;;; The following slots will resemble a list consisting of 32 | ;;; the face's origin, it's up- and right-vector as well as 33 | ;;; the face's surface normal. 34 | front 35 | back 36 | left 37 | right 38 | top 39 | bottom)) 40 | 41 | 42 | (defmethod initialize-instance :after ((cube cube) &key width height depth) 43 | (assert (< 0 width) 44 | nil 45 | ":width must be > 0.") 46 | (assert (< 0 height) 47 | nil 48 | ":height must be > 0.") 49 | (assert (< 0 depth) 50 | nil 51 | ":depth must be > 0.") 52 | (let ((cx (vec-x (object-center cube))) 53 | (cy (vec-y (object-center cube))) 54 | (cz (vec-z (object-center cube))) 55 | (w/2 (/ width 2.0)) 56 | (h/2 (/ height 2.0)) 57 | (d/2 (/ depth 2.0))) 58 | (macrolet ((prep-edge (edge-name opx opy opz) 59 | `(setf (slot-value cube ,edge-name) 60 | (make-vector 3 61 | :data (make-array 3 62 | :element-type 'single-float 63 | :initial-contents (vector (,opx cx w/2) 64 | (,opy cy h/2) 65 | (,opz cz d/2))))))) 66 | (prep-edge 'fll - - -) 67 | (prep-edge 'flr + - -) 68 | (prep-edge 'fur + + -) 69 | (prep-edge 'ful - + -) 70 | (prep-edge 'bll - - +) 71 | (prep-edge 'blr + - +) 72 | (prep-edge 'bur + + +) 73 | (prep-edge 'bul - + +)))) 74 | 75 | 76 | (defmethod finalize ((cube cube) (cam camera)) 77 | (dolist (edge '(fll flr fur ful bll blr bur bul)) 78 | (setf (slot-value cube edge) 79 | (world->view cam (slot-value cube edge)))) 80 | (macrolet ((prep-face (face-name lower-left upper-left lower-right) 81 | (let ((up (gensym)) 82 | (right (gensym)) 83 | (normal (gensym))) 84 | `(let* ((,up (m- (slot-value cube ,upper-left) (slot-value cube ,lower-left))) 85 | (,right (m- (slot-value cube ,lower-right) (slot-value cube ,lower-left))) 86 | (,normal (normalized (cross ,up ,right)))) 87 | (setf (slot-value cube ,face-name) 88 | (list (slot-value cube ,lower-left) ,up ,right ,normal)))))) 89 | (prep-face 'front 'fll 'ful 'flr) 90 | (prep-face 'back 'blr 'bur 'bll) 91 | (prep-face 'left 'bll 'bul 'fll) 92 | (prep-face 'right 'flr 'fur 'blr) 93 | (prep-face 'top 'ful 'bul 'fur) 94 | (prep-face 'bottom 'blr 'flr 'bll)) 95 | T) 96 | 97 | 98 | (defmethod intersects ((cube cube) (ray ray) &key (lower-bound 0.0) shadow-feeler) 99 | (let ((intersection-points 100 | (loop for side in '(front back left right top bottom) 101 | for ip = (destructuring-bind (origin up right normal) 102 | (slot-value cube side) 103 | (multiple-value-bind (dist u v) 104 | (intersects-face origin up right ray #'(lambda (u v) (and (<= 0 u 1) 105 | (<= 0 v 1)))) 106 | (when dist 107 | (list dist cube (point-on-ray ray dist) u v normal)))) 108 | unless (null ip) collect ip))) 109 | (min-in-range intersection-points 110 | :lower-bound lower-bound 111 | :upper-bound shadow-feeler 112 | :key #'car))) 113 | -------------------------------------------------------------------------------- /lights.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; lights.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage #:clrt-lights 20 | (:use :cl :linalg) 21 | (:export #:light 22 | #:light-pos 23 | #:light-color)) 24 | 25 | 26 | (in-package #:clrt-lights) 27 | 28 | 29 | (defclass light () 30 | ((pos 31 | :initarg :pos 32 | :initform (error ":pos must be specified.") 33 | :type matrix 34 | :reader light-pos) 35 | (color 36 | :initarg :color 37 | :initform (make-vector 3 :data #(1.0 1.0 1.0)) 38 | :type matrix 39 | :reader light-color))) 40 | -------------------------------------------------------------------------------- /linalg-tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; linalg-tests.lsp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage :linalg-tests 20 | (:use :cl :linalg :lisp-unit)) 21 | 22 | 23 | ;;; Force the export of the symbols matrix-(rows|cols|data) which are neccessary 24 | ;;; for the execution of the tests. 25 | (in-package :linalg) 26 | 27 | (export '(matrix-rows matrix-cols matrix-data)) 28 | 29 | 30 | (in-package :linalg-tests) 31 | 32 | 33 | (defun matrix= (a b) 34 | (and (= (matrix-rows a) (matrix-rows b)) 35 | (= (matrix-cols a) (matrix-cols b)) 36 | (equalp (matrix-data a) (matrix-data b)))) 37 | 38 | 39 | ;;; Some constant matrices that will be used throughout the tests 40 | (defparameter *A* 41 | (make-instance 'matrix 42 | :rows 2 43 | :cols 4 44 | :data #(1.0 2.0 3.0 4.0 45 | 5.0 6.0 7.0 8.0))) 46 | 47 | (defparameter *B* 48 | (make-instance 'matrix 49 | :rows 4 50 | :cols 4 51 | :data #(-2.0 -4.0 -0.5 9.0 52 | -1.0 -3.0 2.0 4.0 53 | 5.0 7.0 0.0 1.0 54 | 2.0 3.0 4.0 5.0))) 55 | 56 | (defparameter *rv* 57 | (make-vector 4 :data #(42.0 23.0 -23.0 -42.0) :orientation :row)) 58 | 59 | (defparameter *cv* 60 | (make-vector 4 :data #(7.0 8.0 -71.0 0.1))) 61 | 62 | 63 | ;;; Conversion of an array into a column vector 64 | (define-test column-vector-from-array 65 | (assert-true 66 | (let ((cv (make-vector 4 :data #(1 2 3 4)))) 67 | (and (= (matrix-at cv 0 0) 1) 68 | (= (matrix-at cv 1 0) 2) 69 | (= (matrix-at cv 2 0) 3) 70 | (= (matrix-at cv 3 0) 4))))) 71 | 72 | 73 | ;;; Conversion of an array into a row vector 74 | (define-test row-vector-from-array 75 | (assert-true 76 | (let ((rv (make-vector 4 :data #(1 2 3 4) :orientation :row))) 77 | (and (= (matrix-at rv 0 0) 1) 78 | (= (matrix-at rv 0 1) 2) 79 | (= (matrix-at rv 0 2) 3) 80 | (= (matrix-at rv 0 3) 4))))) 81 | 82 | 83 | ;;; Matrix addition 84 | (define-test matrix+ 85 | (assert-equality #'matrix= 86 | (m+ *A* *A* *A*) 87 | (make-instance 'matrix 88 | :rows 2 89 | :cols 4 90 | :data #( 3.0 6.0 9.0 12.0 91 | 15.0 18.0 21.0 24.0)))) 92 | 93 | 94 | ;;; Matrix subtraction 95 | (define-test matrix- 96 | (assert-equality #'matrix= 97 | (m- *A* *A* *A*) 98 | (make-instance 'matrix 99 | :rows 2 100 | :cols 4 101 | :data #(-1.0 -2.0 -3.0 -4.0 102 | -5.0 -6.0 -7.0 -8.0)))) 103 | 104 | 105 | ;;; Matrix multiplication 106 | (define-test m* 107 | (assert-equality #'matrix= 108 | (m* *A* *B*) 109 | (make-instance 'matrix 110 | :rows 2 111 | :cols 4 112 | :data #(19.0 23.0 19.5 40.0 113 | 35.0 35.0 41.5 116.0)))) 114 | 115 | 116 | ;;; Multiplication of a matrix and a scalar value 117 | (define-test matrix-scalar-multiplication 118 | (assert-equality #'matrix= 119 | (m* *A* 0.5) 120 | (make-instance 'matrix 121 | :rows 2 122 | :cols 4 123 | :data #(0.5 1.0 1.5 2.0 124 | 2.5 3.0 3.5 4.0)))) 125 | 126 | 127 | ;;; Multiplication of a scalar value and a matrix 128 | (define-test scalar-matrix-multiplication 129 | (assert-equality #'matrix= 130 | (m* 0.5 *A*) 131 | (make-instance 'matrix 132 | :rows 2 133 | :cols 4 134 | :data #(0.5 1.0 1.5 2.0 135 | 2.5 3.0 3.5 4.0)))) 136 | 137 | 138 | ;;; Multiplication of two scalar values 139 | (define-test scalar-scalar-multiplication 140 | (assert-equal (m* 1.5 2.0) 3.0)) 141 | 142 | 143 | ;;; Transpose of a matrix 144 | (define-test matrix-transpose 145 | (assert-equality #'matrix= 146 | (transposed *A*) 147 | (make-instance 'matrix 148 | :rows 4 149 | :cols 2 150 | :data #(1.0 5.0 2.0 6.0 151 | 3.0 7.0 4.0 8.0)))) 152 | 153 | 154 | ;;; Multiplication of a matrix and a column vector 155 | (define-test matrix-column-vector-multiplication 156 | (assert-equality #'matrix= 157 | (m* *B* *cv*) 158 | (make-vector 4 :data #(-9.6 -172.6 91.1 -245.5)))) 159 | 160 | 161 | ;;; Multiplication of a row vector and a matrix 162 | (define-test row-vector-matrix-multiplication 163 | (assert-equality #'matrix= 164 | (m* *rv* *B*) 165 | (make-vector 4 :data #(-306.0 -524.0 -143.0 237.0) :orientation :row))) 166 | 167 | 168 | ;;; Multiplication of row and column vector 169 | (define-test row-column-vector-multiplication 170 | (assert-equal 2106.8 (m* *rv* *cv*))) 171 | 172 | 173 | ;;; Length of a vector 174 | (define-test length-of-vector 175 | (assert-equal 71.791434 (vec-length *cv*))) 176 | 177 | 178 | ;;; Multiplication with arbitrary addends 179 | (define-test mult 180 | (assert-equal 406781.4 (mult *rv* *B* (transposed *B*) *cv*))) 181 | 182 | 183 | ;;; Copying a matrix 184 | (define-test copy-matrix 185 | (assert-equality #'matrix= *A* (copy-matrix *A*))) 186 | 187 | 188 | ;;; Normalization 189 | (define-test normalized-vector 190 | (assert-equal 1.0 191 | (fround 192 | (vec-length 193 | (normalized 194 | (make-vector 10 195 | :generator #'(lambda (k) (random 100.0)))))))) 196 | 197 | 198 | ;;; Dot-product 199 | (define-test dot-product 200 | (assert-equal 14.0 201 | (dot (make-vector 3 :data #(1.0 2.0 3.0)) 202 | (make-vector 3 :data #(1.0 2.0 3.0))))) 203 | -------------------------------------------------------------------------------- /linalg.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; linalg.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage #:linalg 20 | (:use :cl) 21 | (:export #:matrix 22 | #:matrix-at 23 | #:|setf matrix-at| 24 | #:copy-matrix 25 | #:transposed 26 | #:matrix-print 27 | #:m* 28 | #:mult 29 | #:m+ 30 | #:m- 31 | #:m. 32 | #:make-vector 33 | #:vec-x 34 | #:vec-y 35 | #:vec-z 36 | #:vec-length 37 | #:normalized 38 | #:cross 39 | #:dot)) 40 | 41 | 42 | (in-package #:linalg) 43 | 44 | 45 | 46 | (defclass matrix () 47 | ((rows 48 | :initarg :rows 49 | :initform (error ":rows must be specified.") 50 | :reader matrix-rows) 51 | (cols 52 | :initarg :cols 53 | :initform (error ":cols must be specified.") 54 | :reader matrix-cols) 55 | (data 56 | :initarg :data 57 | :accessor matrix-data))) 58 | 59 | 60 | (defmethod initialize-instance :after ((m matrix) &key generator) 61 | (assert (< 0 (matrix-rows m)) 62 | nil 63 | ":rows must be > 0.") 64 | (assert (< 0 (matrix-cols m)) 65 | nil 66 | ":cols must be > 0.") 67 | (if (slot-boundp m 'data) 68 | (progn 69 | (assert (= (length (matrix-data m)) (* (matrix-rows m) (matrix-cols m))) 70 | nil 71 | ":data dimension should be ~d." 72 | (* (matrix-rows m) (matrix-cols m))) 73 | (assert (not generator) 74 | nil 75 | ":data and :generator may not be specified at the same time.")) 76 | (if (functionp generator) 77 | (progn 78 | (setf (matrix-data m) 79 | (make-array (* (matrix-rows m) (matrix-cols m)) :element-type 'single-float)) 80 | (dotimes (i (matrix-rows m) m) 81 | (dotimes (j (matrix-cols m)) 82 | (setf (matrix-at m i j) 83 | (funcall generator i j))))) 84 | (progn 85 | (setf (matrix-data m) 86 | (make-array (* (matrix-rows m) (matrix-cols m)) 87 | :element-type 'single-float 88 | :initial-element 0.0)) 89 | m)))) 90 | 91 | 92 | (defun matrix-at (m i j) 93 | (aref (matrix-data m) (+ (* i (matrix-cols m)) j))) 94 | 95 | 96 | (defun (setf matrix-at) (value m i j) 97 | (setf (aref (matrix-data m) (+ (* i (matrix-cols m)) j)) value)) 98 | 99 | 100 | (defun copy-matrix (m) 101 | (make-instance 'matrix 102 | :rows (matrix-rows m) 103 | :cols (matrix-cols m) 104 | :data (copy-seq (matrix-data m)))) 105 | 106 | 107 | (defun transposed (m) 108 | (make-instance 'matrix 109 | :rows (matrix-cols m) 110 | :cols (matrix-rows m) 111 | :generator #'(lambda (i j) (matrix-at m j i)))) 112 | 113 | 114 | (defun matrix-print (m) 115 | (dotimes (i (matrix-rows m) nil) 116 | (dotimes (j (matrix-cols m)) 117 | (format t "~7,2f " (matrix-at m i j))) 118 | (terpri))) 119 | 120 | 121 | (defmacro do-matrix ((m i j &optional elt) &body body) 122 | `(dotimes (,i (matrix-rows ,m) ,m) 123 | (dotimes (,j (matrix-cols ,m)) 124 | ,@(if elt 125 | `((symbol-macrolet ((,elt (matrix-at ,m ,i ,j))) 126 | ,@body)) 127 | body)))) 128 | 129 | 130 | (defgeneric m* (op1 op2)) 131 | 132 | (defmethod m* ((a matrix) (b matrix)) 133 | (assert (= (matrix-cols a) (matrix-rows b))) 134 | (let ((result (make-instance 'matrix 135 | :rows (matrix-rows a) 136 | :cols (matrix-cols b)))) 137 | (do-matrix (result i j elt) 138 | (dotimes (k (matrix-cols a)) 139 | (incf elt 140 | (* (matrix-at a i k) (matrix-at b k j))))) 141 | (if (= 1 (matrix-cols result) (matrix-rows result)) 142 | (aref (matrix-data result) 0) 143 | result))) 144 | 145 | 146 | (defmethod m* ((m matrix) (s single-float)) 147 | (make-instance 'matrix 148 | :rows (matrix-rows m) 149 | :cols (matrix-cols m) 150 | :data (map '(simple-array single-float 1) #'(lambda (i) (* i s)) (matrix-data m)))) 151 | 152 | 153 | (defmethod m* ((s single-float) (m matrix)) 154 | (m* m s)) 155 | 156 | 157 | (defmethod m* ((a single-float) (b single-float)) 158 | (* a b)) 159 | 160 | 161 | (defun mult (&rest operands) 162 | (when (consp operands) 163 | (let ((acc (car operands))) 164 | (dolist (operand (cdr operands) acc) 165 | (setf acc (m* acc operand)))))) 166 | 167 | 168 | (defmacro assert-same-dimensions (a b) 169 | `(assert (and (= (matrix-rows ,a) (matrix-rows ,b)) 170 | (= (matrix-cols ,a) (matrix-cols ,b))) 171 | nil 172 | "The matrices ~A and ~A must have the same dimensions." 173 | ,a ,b)) 174 | 175 | 176 | (defmacro def-elementwise-op-fun (name op) 177 | `(defun ,name (&rest operands) 178 | (when (consp operands) 179 | (let ((acc (copy-matrix (car operands)))) 180 | (dolist (operand (cdr operands) acc) 181 | (assert-same-dimensions acc operand) 182 | (map-into (matrix-data acc) ,op (matrix-data acc) (matrix-data operand))))))) 183 | 184 | (def-elementwise-op-fun m+ #'+) 185 | (def-elementwise-op-fun m- #'-) 186 | (def-elementwise-op-fun m. #'*) 187 | 188 | 189 | (defmacro make-vector (dim &key (orientation :column) data generator) 190 | (let ((i (gensym)) 191 | (j (gensym))) 192 | (case orientation 193 | (:column 194 | `(make-instance 'matrix 195 | :rows ,dim 196 | :cols 1 197 | ,@(if data 198 | `(:data ,data) 199 | (when generator 200 | `(:generator #'(lambda (,i ,j) (funcall ,generator ,i))))))) 201 | (:row 202 | `(make-instance 'matrix 203 | :rows 1 204 | :cols ,dim 205 | ,@(if data 206 | `(:data ,data) 207 | (when generator 208 | `(:generator #'(lambda (,i ,j) (funcall ,generator ,j))))))) 209 | (t (error "Unknown :orientation '~A'" orientation))))) 210 | 211 | 212 | (defmacro vec-x (v) 213 | `(aref (matrix-data ,v) 0)) 214 | 215 | 216 | (defmacro vec-y (v) 217 | `(aref (matrix-data ,v) 1)) 218 | 219 | 220 | (defmacro vec-z (v) 221 | `(aref (matrix-data ,v) 2)) 222 | 223 | 224 | (defun vec-length (v) 225 | (sqrt (reduce #'(lambda (i j) (+ i (* j j))) (matrix-data v) :initial-value 0.0))) 226 | 227 | 228 | (defun normalized (v) 229 | (let ((s (vec-length v))) 230 | (if (/= s 0) 231 | (make-instance 'matrix 232 | :rows (matrix-rows v) 233 | :cols (matrix-cols v) 234 | :data (map '(simple-array single-float 1) #'(lambda (i) (/ i s)) (matrix-data v))) 235 | (copy-matrix v)))) 236 | 237 | 238 | (defun is-threedimensional-vector? (v) 239 | (or (and (= (matrix-rows v) 3) 240 | (= (matrix-cols v) 1)) 241 | (and (= (matrix-rows v) 1) 242 | (= (matrix-cols v) 3)))) 243 | 244 | 245 | (defun cross (a b) 246 | (assert (is-threedimensional-vector? a)) 247 | (assert (is-threedimensional-vector? b)) 248 | (make-instance 'matrix 249 | :rows 3 250 | :cols 1 251 | :data (make-array 3 252 | :element-type 'single-float 253 | :initial-contents (vector (- (* (vec-y a) (vec-z b)) 254 | (* (vec-y b) (vec-z a))) 255 | (- (* (vec-z a) (vec-x b)) 256 | (* (vec-z b) (vec-x a))) 257 | (- (* (vec-x a) (vec-y b)) 258 | (* (vec-x b) (vec-y a))))))) 259 | 260 | 261 | (defun is-vector? (v) 262 | (or (= (matrix-cols v) 1) 263 | (= (matrix-rows v) 1))) 264 | 265 | 266 | (defun dot (a b) 267 | (assert (is-vector? a)) 268 | (assert (is-vector? b)) 269 | (reduce #'+ (map 'vector #'* (matrix-data a) (matrix-data b)))) 270 | -------------------------------------------------------------------------------- /material.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; material.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage #:clrt-material 20 | (:use :cl :linalg) 21 | (:export #:material 22 | #:ambient-color 23 | #:diffuse-color 24 | #:specular-color 25 | #:ambient-coeff 26 | #:diffuse-coeff 27 | #:specular-coeff 28 | #:roughness)) 29 | 30 | 31 | (in-package #:clrt-material) 32 | 33 | 34 | 35 | (defclass material () 36 | ((ambient-color 37 | :initarg :ambient-color 38 | :initform (make-vector 3) 39 | :type matrix 40 | :reader ambient-color) 41 | (diffuse-color 42 | :initarg :diffuse-color 43 | :initform (make-vector 3 :data (make-array 3 44 | :element-type 'single-float 45 | :initial-element 1.0)) 46 | :type matrix 47 | :reader diffuse-color) 48 | (specular-color 49 | :initarg :specular-color 50 | :initform (make-vector 3) 51 | :type matrix 52 | :reader specular-color) 53 | (ambient-coeff 54 | :initarg :ambient-coeff 55 | :initform 0.0 56 | :type (real 0.0 1.0) 57 | :reader ambient-coeff) 58 | (diffuse-coeff 59 | :initarg :diffuse-coeff 60 | :initform 1.0 61 | :type (real 0.0 1.0) 62 | :reader diffuse-coeff) 63 | (specular-coeff 64 | :initarg :specular-coeff 65 | :initform 0.0 66 | :type (real 0.0 1.0) 67 | :reader specular-coeff) 68 | (roughness 69 | :initarg :roughness 70 | :initform 50 71 | :type (integer 0) 72 | :reader roughness))) 73 | 74 | 75 | (defmethod initialize-instance :after ((mat material) &key) 76 | (assert (= (+ (ambient-coeff mat) (diffuse-coeff mat) (specular-coeff mat)) 77 | 1.0) 78 | nil 79 | ":ambient-coeff, :diffuse-coeff and :specular-coeff must sum up to 1.0.")) 80 | -------------------------------------------------------------------------------- /objects.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; objects.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage #:clrt-objects 20 | (:use #:cl #:linalg #:clrt-camera #:clrt-ray #:clrt-material) 21 | (:export #:object 22 | #:object-material 23 | #:intersects 24 | #:finalize 25 | #:sphere 26 | #:cube)) 27 | 28 | (in-package #:clrt-objects) 29 | 30 | 31 | 32 | (defclass object () 33 | ((center 34 | :initarg :center 35 | :initform (error ":center must be specified.") 36 | :type matrix 37 | :reader object-center) 38 | (material 39 | :initarg :material 40 | :initform (error ":material must be specified.") 41 | :type material 42 | :reader object-material))) 43 | 44 | 45 | (defgeneric intersects (obj ray &key lower-bound shadow-feeler)) 46 | 47 | 48 | (defgeneric finalize (obj cam)) 49 | 50 | (defmethod finalize ((obj object) (cam camera)) 51 | (setf (slot-value obj 'center) 52 | (world->view cam (slot-value obj 'center)))) 53 | 54 | 55 | (defun min-in-range (elements &key (lower-bound 0.0) upper-bound (key #'identity)) 56 | (let ((elts (remove-if-not #'(lambda (i) 57 | (if upper-bound 58 | (<= lower-bound i upper-bound) 59 | (<= lower-bound i))) 60 | elements :key key))) 61 | (when elts 62 | (reduce #'(lambda (a b) (if (<= (funcall key a) (funcall key b)) 63 | a 64 | b)) 65 | elts)))) 66 | 67 | 68 | (defun intersects-face (origin up right ray test-fn) 69 | (let* ((a (vec-x right)) 70 | (b (vec-x up)) 71 | (c (- (vec-x (ray-direction ray)))) 72 | (d (vec-y right)) 73 | (e (vec-y up)) 74 | (f (- (vec-y (ray-direction ray)))) 75 | (g (vec-z right)) 76 | (h (vec-z up)) 77 | (i (- (vec-z (ray-direction ray)))) 78 | (det (- (+ (* a e i) (* b f g) (* c d h)) 79 | (+ (* c e g) (* b d i) (* a f h))))) 80 | (when (/= det 0) 81 | (let* ((rhs (m- (ray-origin ray) origin)) 82 | (u (/ (+ (* (- (* e i) (* f h)) (vec-x rhs)) 83 | (* (- (* c h) (* b i)) (vec-y rhs)) 84 | (* (- (* b f) (* c e)) (vec-z rhs))) 85 | det)) 86 | (v (/ (+ (* (- (* f g) (* d i)) (vec-x rhs)) 87 | (* (- (* a i) (* c g)) (vec-y rhs)) 88 | (* (- (* c d) (* a f)) (vec-z rhs))) 89 | det)) 90 | (dist (/ (+ (* (- (* d h) (* e g)) (vec-x rhs)) 91 | (* (- (* b g) (* a h)) (vec-y rhs)) 92 | (* (- (* a e) (* b d)) (vec-z rhs))) 93 | det))) 94 | (when (funcall test-fn u v) 95 | (values dist u v)))))) 96 | 97 | 98 | -------------------------------------------------------------------------------- /ray.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; ray.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage #:clrt-ray 20 | (:use #:cl #:linalg) 21 | (:export #:ray 22 | #:point-on-ray 23 | #:ray-origin 24 | #:ray-direction)) 25 | 26 | (in-package #:clrt-ray) 27 | 28 | 29 | (defclass ray () 30 | ((origin 31 | :initarg :origin 32 | :initform (error ":origin must be specified.") 33 | :type matrix 34 | :reader ray-origin) 35 | (direction 36 | :initarg :direction 37 | :initform (error ":direction must be specified.") 38 | :type matrix 39 | :reader ray-direction))) 40 | 41 | 42 | (defmethod initialize-instance :after ((ray ray) &key) 43 | (assert (<= 0.9999 44 | (dot (ray-direction ray) (ray-direction ray)) 45 | 1.0001) 46 | nil 47 | ":direction must be a unit-length vector.")) 48 | 49 | 50 | (defun point-on-ray (ray dist) 51 | (m+ (ray-origin ray) (m* dist (ray-direction ray)))) 52 | -------------------------------------------------------------------------------- /scene.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; scene.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage #:clrt-scene 20 | (:use :cl :clrt-camera :clrt-objects :linalg 21 | :clrt-material :clrt-lights :clrt-ray) 22 | (:export #:scene 23 | #:add-object 24 | #:add-light 25 | #:render)) 26 | 27 | (in-package #:clrt-scene) 28 | 29 | 30 | (defclass scene () 31 | ((camera 32 | :initarg :camera 33 | :initform (error ":camera must be specified.") 34 | :type camera 35 | :reader scene-camera) 36 | (objects 37 | :initform '() 38 | :reader scene-objects) 39 | (lights 40 | :initform '() 41 | :reader scene-lights) 42 | already-finalized)) 43 | 44 | 45 | (defun add-object (scene object) 46 | (push object (slot-value scene 'objects))) 47 | 48 | 49 | (defun add-light (scene light) 50 | (push light (slot-value scene 'lights))) 51 | 52 | 53 | (defun render (scene width height filename) 54 | (assert (consp (slot-value scene 'objects)) 55 | nil 56 | "There are no objects in the scene.") 57 | (assert (consp (slot-value scene 'lights)) 58 | nil 59 | "There are no lights in the scene.") 60 | (unless (slot-boundp scene 'already-finalized) 61 | (progn 62 | (dolist (obj (scene-objects scene)) 63 | (finalize obj (scene-camera scene))) 64 | (setf (slot-value scene 'already-finalized) T))) 65 | (let* ((image (make-instance 'zpng:png 66 | :width width 67 | :height height)) 68 | (image-data (zpng:data-array image)) 69 | (delta (* pi (/ (camera-fov (scene-camera scene)) 360.0))) 70 | (maxx (coerce (tan delta) 'single-float)) 71 | (minx (- maxx)) 72 | (maxy (* maxx (/ (coerce height 'single-float) (coerce width 'single-float)))) 73 | (stepx (/ (* 2.0 maxx) (coerce width 'single-float))) 74 | (stepy (/ (* 2.0 maxy) (coerce height 'single-float))) 75 | (zero-vector (make-vector 3 :data (make-array 3 76 | :element-type 'single-float 77 | :initial-element 0.0)))) 78 | (do ((y 0 (1+ y)) 79 | (y-coord maxy (- y-coord stepy))) 80 | ((>= y height)) 81 | (do* ((x 0 (1+ x)) 82 | (x-coord minx (+ x-coord stepx)) 83 | (image-plane-pos (make-vector 3 :data (make-array 3 84 | :element-type 'single-float 85 | :initial-contents (vector x-coord y-coord 1.0))) 86 | (make-vector 3 :data (make-array 3 87 | :element-type 'single-float 88 | :initial-contents (vector x-coord y-coord 1.0))))) 89 | ((>= x width)) 90 | (let ((color (trace-ray scene 91 | (make-instance 'ray 92 | :origin image-plane-pos 93 | :direction (normalized 94 | (m- image-plane-pos zero-vector)))))) 95 | (setf (aref image-data y x 0) (min 255 (truncate (* 255 (vec-x color)))) 96 | (aref image-data y x 1) (min 255 (truncate (* 255 (vec-y color)))) 97 | (aref image-data y x 2) (min 255 (truncate (* 255 (vec-z color))))))) 98 | (when (zerop (mod y 40)) 99 | (format t "Rendering... ~,2f%~%" (/ (* y 100.0) height)))) 100 | (zpng:write-png image filename :if-exists :supersede))) 101 | 102 | 103 | (defun find-closest-intersection (scene ray lower-bound shadow-feeler) 104 | (let ((closest-match)) 105 | (dolist (obj (scene-objects scene) closest-match) 106 | (let ((intersection-point (intersects obj ray 107 | :lower-bound lower-bound 108 | :shadow-feeler shadow-feeler))) 109 | (if closest-match 110 | (setf closest-match 111 | (if (<= (car intersection-point) (car closest-match)) 112 | intersection-point 113 | closest-match)) 114 | (setf closest-match intersection-point)))))) 115 | 116 | 117 | (defun trace-ray (scene ray &optional (lower-bound 0.0) shadow-feeler) 118 | (let ((closest-match (find-closest-intersection scene ray lower-bound shadow-feeler))) 119 | (if closest-match 120 | (destructuring-bind (dist obj ip u v normal) closest-match 121 | (declare (ignore dist u v)) 122 | (let* ((mat (object-material obj)) 123 | (color (m* (ambient-coeff mat) (ambient-color mat)))) 124 | (dolist (light (slot-value scene 'lights) color) 125 | (let* ((aux-dir-to-light (m- (light-pos light) ip)) 126 | (dist-to-light (vec-length aux-dir-to-light)) 127 | (dir-to-light (normalized aux-dir-to-light))) 128 | (unless (find-closest-intersection scene 129 | (make-instance 'ray 130 | :origin ip 131 | :direction dir-to-light) 132 | 1e-3 133 | dist-to-light) 134 | (let* ((inv-ray-direction (m* -1.0 (ray-direction ray))) 135 | (alpha (dot normal dir-to-light)) 136 | (halfway-vec (normalized (m+ inv-ray-direction dir-to-light))) 137 | (beta (dot normal halfway-vec))) 138 | (when (< 0 alpha) 139 | (setf color 140 | (m+ color (mult alpha 141 | (diffuse-coeff mat) 142 | (m. (light-color light) (diffuse-color mat)))))) 143 | (when (< 0 beta) 144 | (setf color 145 | (m+ color (mult (expt beta (roughness mat)) 146 | (specular-coeff mat) 147 | (m. (light-color light) (specular-color mat)))))))))))) 148 | (make-vector 3)))) 149 | 150 | 151 | -------------------------------------------------------------------------------- /simple-scene.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; simple-scene.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (defpackage #:simple-scene 20 | (:use :cl :linalg) 21 | (:export #:render)) 22 | 23 | 24 | (in-package #:simple-scene) 25 | 26 | 27 | (defparameter *cam* (make-instance 'clrt-camera:camera 28 | :pos (make-vector 3 :data #(50.0 50.0 0.0)) 29 | :up (make-vector 3 :data #(0.0 1.0 0.0)) 30 | :look-at (make-vector 3 :data #(0.0 0.0 100.0)))) 31 | 32 | 33 | (defparameter *scene* (make-instance 'clrt-scene:scene 34 | :camera *cam*)) 35 | 36 | 37 | (defparameter *blue-material* (make-instance 'clrt-material:material 38 | :ambient-color (make-vector 3 :data #(0.0 0.0 0.2)) 39 | :ambient-coeff 0.1 40 | :diffuse-color (make-vector 3 :data #(0.0 0.0 0.8)) 41 | :diffuse-coeff 0.6 42 | :specular-color (make-vector 3 :data #(1.0 1.0 1.0)) 43 | :specular-coeff 0.3 44 | :roughness 50)) 45 | 46 | 47 | (defparameter *cube* (make-instance 'clrt-objects:cube 48 | :center (make-vector 3 :data #(0.0 0.0 100.0)) 49 | :width 40.0 50 | :height 40.0 51 | :depth 40.0 52 | :material *blue-material*)) 53 | 54 | 55 | ;(clrt-scene:add-object *scene* *cube*) 56 | (clrt-scene:add-object *scene* (make-instance 'clrt-objects:sphere 57 | :center (make-vector 3 :data #(0.0 0.0 100.0)) 58 | :radius 40.0 59 | :material *blue-material*)) 60 | 61 | 62 | (defparameter *light* (make-instance 'clrt-lights:light 63 | :pos (make-vector 3 :data #(-100.0 100.0 0.0)))) 64 | 65 | 66 | (clrt-scene:add-light *scene* *light*) 67 | 68 | 69 | (defun render () 70 | (clrt-scene:render *scene* 640 480 "test.png")) 71 | -------------------------------------------------------------------------------- /sphere.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; sphere.lisp 3 | ;;;; 4 | ;;;; Copyright 2009 Alexander Lehmann 5 | ;;;; 6 | ;;;; Licensed under the Apache License, Version 2.0 (the "License"); 7 | ;;;; you may not use this file except in compliance with the License. 8 | ;;;; You may obtain a copy of the License at 9 | ;;;; 10 | ;;;; http://www.apache.org/licenses/LICENSE-2.0 11 | ;;;; 12 | ;;;; Unless required by applicable law or agreed to in writing, software 13 | ;;;; distributed under the License is distributed on an "AS IS" BASIS, 14 | ;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | ;;;; See the License for the specific language governing permissions and 16 | ;;;; limitations under the License. 17 | 18 | 19 | (in-package #:clrt-objects) 20 | 21 | 22 | (defclass sphere (object) 23 | ((radius 24 | :initarg :radius 25 | :initform (error ":radius must be specified.") 26 | :type single-float 27 | :reader sphere-radius))) 28 | 29 | 30 | (defmethod intersects ((sphere sphere) (ray ray) &key (lower-bound 0.0) shadow-feeler) 31 | (let* ((ro (ray-origin ray)) 32 | (rd (ray-direction ray)) 33 | (c (object-center sphere)) 34 | (r (sphere-radius sphere)) 35 | (ro*rd (dot ro rd)) 36 | (rd*rd (dot rd rd)) 37 | (c*rd (dot c rd)) 38 | (discr (- (* 4 (expt (- ro*rd c*rd) 2)) 39 | (* 4 rd*rd (- (dot ro ro) (* 2 (dot ro c)) (- (dot c c)) (* r r))))) 40 | (tmin (min-in-range (cond 41 | ((< discr 0) nil) 42 | ((= discr 0) (list (/ (* -2 (- ro*rd c*rd)) (* 2 rd*rd)))) 43 | (t (let ((root (sqrt discr))) 44 | (list (/ (+ (* -2 (- ro*rd c*rd)) root) (* 2 rd*rd)) 45 | (/ (- (* -2 (- ro*rd c*rd)) root) (* 2 rd*rd)))))) 46 | :lower-bound lower-bound 47 | :upper-bound shadow-feeler))) 48 | (when tmin 49 | (let ((ip (point-on-ray ray tmin))) 50 | (list tmin sphere ip 51 | nil nil ;; TODO 52 | (normalized (m- ip c))))))) 53 | --------------------------------------------------------------------------------