Browse code
chore(raytracer): split up the system a bit
Edward authored on 23/03/2021 06:11:43Showing 7 changed files
- raytracing_in_one_weekend/1.lisp
- raytracing_in_one_weekend/canvas-server.lisp
- raytracing_in_one_weekend/material.lisp
- raytracing_in_one_weekend/package.lisp
- raytracing_in_one_weekend/raytracing.asd
- raytracing_in_one_weekend/scenes.lisp
- raytracing_in_one_weekend/vector-utils.lisp
| ... | ... |
@@ -1,147 +1,43 @@ |
| 1 |
-(defpackage :fwoar.lisp-sandbox.1 |
|
| 2 |
- (:use :cl |
|
| 3 |
- ) |
|
| 4 |
- (:export )) |
|
| 5 | 1 |
(in-package :fwoar.lisp-sandbox.1) |
| 6 | 2 |
|
| 7 |
-(define-symbol-macro infinity |
|
| 8 |
- #.sb-ext:double-float-positive-infinity) |
|
| 9 |
-(defun deg2rad (deg) |
|
| 10 |
- (/ (* deg pi) |
|
| 11 |
- 180.0d0)) |
|
| 3 |
+(defclass hittable () |
|
| 4 |
+ ()) |
|
| 12 | 5 |
|
| 13 |
-(defun rand-min-max (min max) |
|
| 14 |
- (+ min |
|
| 15 |
- (* (- max min) |
|
| 16 |
- (random 1.0d0)))) |
|
| 6 |
+(fw.lu:defclass+ sphere (hittable) |
|
| 7 |
+ ((center :initarg :center) |
|
| 8 |
+ (radius :initarg :radius) |
|
| 9 |
+ (material-color :initarg :color |
|
| 10 |
+ :reader material-color |
|
| 11 |
+ :initform (vec3 (random 1.0d0) |
|
| 12 |
+ (random 1.0d0) |
|
| 13 |
+ (random 1.0d0))) |
|
| 14 |
+ (material :initarg :material |
|
| 15 |
+ :reader .material |
|
| 16 |
+ :initform (lambertian-material (random 0.8))))) |
|
| 17 |
+ |
|
| 18 |
+(fw.lu:defclass+ ray () |
|
| 19 |
+ ((origin :initarg :origin) |
|
| 20 |
+ (direction :initarg :direction))) |
|
| 21 |
+ |
|
| 22 |
+(fw.lu:defclass+ hit-record () |
|
| 23 |
+ ((p :initarg :p :reader .p) |
|
| 24 |
+ (time :initarg :time :reader .time) |
|
| 25 |
+ (thing :initarg :thing :accessor .thing) |
|
| 26 |
+ (material :initarg :material :accessor .material) |
|
| 27 |
+ (normal :initarg :normal :accessor .normal :initform ()) |
|
| 28 |
+ (front-face :initarg :front-face :accessor .front-face :initform ()))) |
|
| 17 | 29 |
|
| 30 |
+(defclass camera () |
|
| 31 |
+ ((origin :initarg :origin :reader origin) |
|
| 32 |
+ (lower-left-corner :initarg :lower-left-corner :reader lower-left-corner) |
|
| 33 |
+ (horizontal :initarg :horizontal :reader horizontal) |
|
| 34 |
+ (vertical :initarg :vertical :reader vertical))) |
|
| 18 | 35 |
|
| 19 |
-(defstruct (size (:type vector)) |
|
| 20 |
- width height) |
|
| 21 |
-(defstruct (color (:type vector)) |
|
| 22 |
- r g b) |
|
| 23 | 36 |
(defstruct (vec3 (:type vector) |
| 24 | 37 |
(:constructor vec3 (x y z)) |
| 25 | 38 |
(:conc-name v3-)) |
| 26 | 39 |
x y z) |
| 27 | 40 |
|
| 28 |
-(defun rand-vec3 () |
|
| 29 |
- (vec3 (random 1.0d0) |
|
| 30 |
- (random 1.0d0) |
|
| 31 |
- (random 1.0d0))) |
|
| 32 |
- |
|
| 33 |
-(defun rand-vec3-min-max (min max) |
|
| 34 |
- (vec3 (rand-min-max min max) |
|
| 35 |
- (rand-min-max min max) |
|
| 36 |
- (rand-min-max min max))) |
|
| 37 |
- |
|
| 38 |
-(declaim (inline vec+ vec* vec- vec/ random-in-unit-sphere negate)) |
|
| 39 |
-(defun random-in-unit-sphere () |
|
| 40 |
- (loop for p = (rand-vec3-min-max -1.0d0 1.0d0) |
|
| 41 |
- while (>= (length-squared p) |
|
| 42 |
- 1) |
|
| 43 |
- finally (return p))) |
|
| 44 |
-(defun random-unit-vector () |
|
| 45 |
- (unit-vector (random-in-unit-sphere))) |
|
| 46 |
- |
|
| 47 |
-(defun vec+ (vec1 vec2) |
|
| 48 |
- (declare (optimize (speed 3))) |
|
| 49 |
- (fw.lu:vector-destructuring-bind (a b c) vec1 |
|
| 50 |
- (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 51 |
- (vec3 (+ a a1) |
|
| 52 |
- (+ b b1) |
|
| 53 |
- (+ c c1))))) |
|
| 54 |
-(define-compiler-macro vec+ (&whole whole vec1 vec2) |
|
| 55 |
- (cond ((and (vectorp vec1) |
|
| 56 |
- (vectorp vec2)) |
|
| 57 |
- (vec+ vec1 vec2)) |
|
| 58 |
- ((vectorp vec1) |
|
| 59 |
- (alexandria:once-only (vec2) |
|
| 60 |
- `(fw.lu:vector-destructuring-bind (a b c) ,vec1 |
|
| 61 |
- (vec3 |
|
| 62 |
- (+ a (aref ,vec2 0)) |
|
| 63 |
- (+ b (aref ,vec2 1)) |
|
| 64 |
- (+ c (aref ,vec2 2)))))) |
|
| 65 |
- ((vectorp vec2) |
|
| 66 |
- (alexandria:once-only (vec1) |
|
| 67 |
- `(fw.lu:vector-destructuring-bind (a b c) ,vec2 |
|
| 68 |
- (vec3 |
|
| 69 |
- (+ a (aref ,vec1 0)) |
|
| 70 |
- (+ b (aref ,vec1 1)) |
|
| 71 |
- (+ c (aref ,vec1 2)))))) |
|
| 72 |
- (t whole))) |
|
| 73 |
-(defun vec- (vec1 vec2) |
|
| 74 |
- (declare (optimize (speed 3))) |
|
| 75 |
- (fw.lu:vector-destructuring-bind (a b c) vec1 |
|
| 76 |
- (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 77 |
- (vec3 (- a a1) |
|
| 78 |
- (- b b1) |
|
| 79 |
- (- c c1))))) |
|
| 80 |
-(defun vec* (vec1 vec2) |
|
| 81 |
- (declare (optimize (speed 3))) |
|
| 82 |
- (etypecase vec1 |
|
| 83 |
- ((array * (3)) (fw.lu:vector-destructuring-bind (a b c) vec1 |
|
| 84 |
- (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 85 |
- (vec3 (* a a1) |
|
| 86 |
- (* b b1) |
|
| 87 |
- (* c c1))))) |
|
| 88 |
- (double-float (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 89 |
- (vec3 (* vec1 a1) |
|
| 90 |
- (* vec1 b1) |
|
| 91 |
- (* vec1 c1)))) |
|
| 92 |
- (single-float (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 93 |
- (vec3 (* vec1 a1) |
|
| 94 |
- (* vec1 b1) |
|
| 95 |
- (* vec1 c1)))) |
|
| 96 |
- (number (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 97 |
- (vec3 (* vec1 a1) |
|
| 98 |
- (* vec1 b1) |
|
| 99 |
- (* vec1 c1)))))) |
|
| 100 |
-(defun negate (vec) |
|
| 101 |
- (fw.lu:vector-destructuring-bind (x y z) vec |
|
| 102 |
- (vec3 (- x) |
|
| 103 |
- (- y) |
|
| 104 |
- (- z)))) |
|
| 105 |
- |
|
| 106 |
-(defun vec/ (vec it) |
|
| 107 |
- (declare (optimize (speed 3))) |
|
| 108 |
- (vec* (/ 1.0 it) |
|
| 109 |
- vec)) |
|
| 110 |
-(defun dot (u v) |
|
| 111 |
- (fw.lu:vector-destructuring-bind (a1 b1 c1) u |
|
| 112 |
- (fw.lu:vector-destructuring-bind (a2 b2 c2) v |
|
| 113 |
- (+ (* a1 a2) |
|
| 114 |
- (* b1 b2) |
|
| 115 |
- (* c1 c2))))) |
|
| 116 |
-(defun cross (u v) |
|
| 117 |
- (fw.lu:vector-destructuring-bind (a1 b1 c1) u |
|
| 118 |
- (fw.lu:vector-destructuring-bind (a2 b2 c2) v |
|
| 119 |
- (vec3 (- (* b1 c2) |
|
| 120 |
- (* c1 b2)) |
|
| 121 |
- (- (* c1 a2) |
|
| 122 |
- (* a1 c2)) |
|
| 123 |
- (- (* a1 b2) |
|
| 124 |
- (* b1 a2)))))) |
|
| 125 |
- |
|
| 126 |
-(defun length-squared (v) |
|
| 127 |
- (fw.lu:vector-destructuring-bind (x y z) v |
|
| 128 |
- (+ (* x x) |
|
| 129 |
- (* y y) |
|
| 130 |
- (* z z)))) |
|
| 131 |
-(defun vec-length (v) |
|
| 132 |
- (sqrt (length-squared v))) |
|
| 133 |
-(defun unit-vector (v) |
|
| 134 |
- (vec/ v |
|
| 135 |
- (vec-length v))) |
|
| 136 |
- |
|
| 137 |
-(declaim (inline near-zero)) |
|
| 138 |
-(defun near-zero (vec) |
|
| 139 |
- (fw.lu:vector-destructuring-bind (x y z) vec |
|
| 140 |
- (let* ((s 1.0d-8)) |
|
| 141 |
- (and (< (abs x) s) |
|
| 142 |
- (< (abs y) s) |
|
| 143 |
- (< (abs z) s))))) |
|
| 144 |
- |
|
| 145 | 41 |
(defun call-with-ppm-header (stream size callback &optional (colors 255)) |
| 146 | 42 |
(format stream "P3~%~d ~d~%~d~%" |
| 147 | 43 |
(size-width size) |
| ... | ... |
@@ -152,27 +48,6 @@ |
| 152 | 48 |
#.(progn (defmacro ig (&rest syms) `'(declare (ignore ,@syms))) |
| 153 | 49 |
nil) |
| 154 | 50 |
|
| 155 |
-(defvar *color-depth* 255) |
|
| 156 |
- |
|
| 157 |
-(defun clamp (x min max) |
|
| 158 |
- (cond ((< x min) min) |
|
| 159 |
- ((> x max) max) |
|
| 160 |
- (t x))) |
|
| 161 |
- |
|
| 162 |
-(defvar *samples-per-pixel* 1) |
|
| 163 |
-(defun scale-to-8bit (color) |
|
| 164 |
- (let ((scale (/ *samples-per-pixel*))) |
|
| 165 |
- (flet ((scale-to-depth (c) |
|
| 166 |
- (floor |
|
| 167 |
- (* *color-depth* |
|
| 168 |
- (clamp (sqrt (* c scale)) |
|
| 169 |
- 0.0d0 0.999d0))))) |
|
| 170 |
- (fwoar.lisputils:vector-destructuring-bind (r g b) color |
|
| 171 |
- (let ((r (scale-to-depth r)) |
|
| 172 |
- (g (scale-to-depth g)) |
|
| 173 |
- (b (scale-to-depth b))) |
|
| 174 |
- (vec3 r g b)))))) |
|
| 175 |
- |
|
| 176 | 51 |
(defun format-color (s v _ __) |
| 177 | 52 |
#.(ig _ __) |
| 178 | 53 |
(fw.lu:vector-destructuring-bind (r g b) (scale-to-8bit v) |
| ... | ... |
@@ -197,23 +72,11 @@ |
| 197 | 72 |
(when intermediate |
| 198 | 73 |
(format stream "~{~/fwoar.lisp-sandbox.1::format-color/~^ ~}~&" intermediate))))
|
| 199 | 74 |
|
| 200 |
-(fw.lu:defclass+ ray () |
|
| 201 |
- ((origin :initarg :origin) |
|
| 202 |
- (direction :initarg :direction))) |
|
| 203 |
- |
|
| 204 | 75 |
(defgeneric at (self it) |
| 205 | 76 |
(:method ((ray ray) (it number)) |
| 206 | 77 |
(with-slots (origin direction) ray |
| 207 | 78 |
(vec+ origin |
| 208 | 79 |
(vec* it direction))))) |
| 209 |
- |
|
| 210 |
-(fw.lu:defclass+ hit-record () |
|
| 211 |
- ((p :initarg :p :reader .p) |
|
| 212 |
- (time :initarg :time :reader .time) |
|
| 213 |
- (thing :initarg :thing :accessor .thing) |
|
| 214 |
- (material :initarg :material :accessor .material) |
|
| 215 |
- (normal :initarg :normal :accessor .normal :initform ()) |
|
| 216 |
- (front-face :initarg :front-face :accessor .front-face :initform ()))) |
|
| 217 | 80 |
(defun set-face-normal (hit-record r outward-normal) |
| 218 | 81 |
(prog1 hit-record |
| 219 | 82 |
(with-slots (direction) r |
| ... | ... |
@@ -224,20 +87,6 @@ |
| 224 | 87 |
outward-normal |
| 225 | 88 |
(vec* -1 outward-normal))))))) |
| 226 | 89 |
|
| 227 |
-(defclass hittable () |
|
| 228 |
- ()) |
|
| 229 |
-(fw.lu:defclass+ sphere (hittable) |
|
| 230 |
- ((center :initarg :center) |
|
| 231 |
- (radius :initarg :radius) |
|
| 232 |
- (material-color :initarg :color |
|
| 233 |
- :reader material-color |
|
| 234 |
- :initform (vec3 (random 1.0d0) |
|
| 235 |
- (random 1.0d0) |
|
| 236 |
- (random 1.0d0))) |
|
| 237 |
- (material :initarg :material |
|
| 238 |
- :reader .material |
|
| 239 |
- :initform (lambertian-material (random 0.8))))) |
|
| 240 |
- |
|
| 241 | 90 |
(defgeneric hit (thing ray t-min t-max) |
| 242 | 91 |
(:method ((things list) (r ray) (t-min real) (t-max real)) |
| 243 | 92 |
(let (temp-rec |
| ... | ... |
@@ -304,26 +153,6 @@ |
| 304 | 153 |
|
| 305 | 154 |
(defgeneric scatter (material ray-in rec)) |
| 306 | 155 |
|
| 307 |
-(defun original-material (rec ray world depth) |
|
| 308 |
- (declare (ignore ray world depth)) |
|
| 309 |
- (vec* 0.5 |
|
| 310 |
- (vec+ #(1 1 1) |
|
| 311 |
- (.normal rec)))) |
|
| 312 |
- |
|
| 313 |
-(defun lambertian-material (albedo) |
|
| 314 |
- (lambda (rec ray world depth) |
|
| 315 |
- (declare (ignore ray)) |
|
| 316 |
- (let ((scatter-direction (vec+ (.normal rec) |
|
| 317 |
- (random-unit-vector)))) |
|
| 318 |
- (when (near-zero scatter-direction) |
|
| 319 |
- (setf scatter-direction (.normal rec))) |
|
| 320 |
- |
|
| 321 |
- (vec* albedo |
|
| 322 |
- (ray-color (ray (.p rec) |
|
| 323 |
- scatter-direction) |
|
| 324 |
- world |
|
| 325 |
- (1- depth)))))) |
|
| 326 |
- |
|
| 327 | 156 |
(defun reflect (v n) |
| 328 | 157 |
(vec- v |
| 329 | 158 |
(vec* 2.0d0 |
| ... | ... |
@@ -343,31 +172,6 @@ |
| 343 | 172 |
n))) |
| 344 | 173 |
(vec+ out-perp out-parallel))) |
| 345 | 174 |
|
| 346 |
-(defun metal-material (albedo) |
|
| 347 |
- (lambda (rec ray world depth) |
|
| 348 |
- (with-slots (direction) ray |
|
| 349 |
- (let* ((reflected (reflect (unit-vector direction) |
|
| 350 |
- (.normal rec))) |
|
| 351 |
- (scattered (ray (.p rec) reflected))) |
|
| 352 |
- (vec* albedo |
|
| 353 |
- (ray-color scattered |
|
| 354 |
- world |
|
| 355 |
- (1- depth))))))) |
|
| 356 |
- |
|
| 357 |
-(defun fuzzy-metal-material (albedo fuzz) |
|
| 358 |
- (lambda (rec ray world depth) |
|
| 359 |
- (with-slots (direction) ray |
|
| 360 |
- (let* ((reflected (reflect (unit-vector direction) |
|
| 361 |
- (.normal rec))) |
|
| 362 |
- (scattered (ray (.p rec) |
|
| 363 |
- (vec+ reflected |
|
| 364 |
- (vec* fuzz |
|
| 365 |
- (random-in-unit-sphere)))))) |
|
| 366 |
- (vec* albedo |
|
| 367 |
- (ray-color scattered |
|
| 368 |
- world |
|
| 369 |
- (1- depth))))))) |
|
| 370 |
- |
|
| 371 | 175 |
(defun reflectance (cosine ref-idx) |
| 372 | 176 |
(let* ((r0 (/ (- 1 ref-idx) |
| 373 | 177 |
(+ 1 ref-idx))) |
| ... | ... |
@@ -377,41 +181,8 @@ |
| 377 | 181 |
(expt (- 1 cosine) |
| 378 | 182 |
5))))) |
| 379 | 183 |
|
| 380 |
-(defun dielectric-material (ir &optional (fuzz 0)) |
|
| 381 |
- (lambda (rec ray world depth) |
|
| 382 |
- (with-slots (direction) ray |
|
| 383 |
- (let* ((attenuation (vec3 1.0d0 1.0d0 1.0d0)) |
|
| 384 |
- (refraction-ratio (if (.front-face rec) |
|
| 385 |
- (/ 1.0d0 ir) |
|
| 386 |
- ir)) |
|
| 387 |
- (unit-direction (unit-vector direction)) |
|
| 388 |
- (normal (.normal rec)) |
|
| 389 |
- (cos-theta (min 1.0d0 |
|
| 390 |
- (dot (negate unit-direction) |
|
| 391 |
- normal))) |
|
| 392 |
- (sin-theta (sqrt (- 1 |
|
| 393 |
- (* cos-theta cos-theta)))) |
|
| 394 |
- (cannot-refract (> (* refraction-ratio |
|
| 395 |
- sin-theta) |
|
| 396 |
- 1.0d0)) |
|
| 397 |
- (direction (if (or cannot-refract |
|
| 398 |
- (> (reflectance cos-theta |
|
| 399 |
- refraction-ratio) |
|
| 400 |
- (random 1.0d0))) |
|
| 401 |
- (reflect unit-direction |
|
| 402 |
- normal) |
|
| 403 |
- (refract unit-direction |
|
| 404 |
- normal |
|
| 405 |
- refraction-ratio))) |
|
| 406 |
- (scattered (ray (.p rec) |
|
| 407 |
- (vec+ direction |
|
| 408 |
- (vec* fuzz |
|
| 409 |
- (random-in-unit-sphere)))))) |
|
| 410 |
- (vec* attenuation |
|
| 411 |
- (ray-color scattered |
|
| 412 |
- world |
|
| 413 |
- (1- depth))))))) |
|
| 414 |
- |
|
| 184 |
+(define-symbol-macro infinity |
|
| 185 |
+ #.sb-ext:double-float-positive-infinity) |
|
| 415 | 186 |
(defgeneric ray-color (ray world depth) |
| 416 | 187 |
(:method :around (r w (depth integer)) |
| 417 | 188 |
(if (<= depth 0) |
| ... | ... |
@@ -432,13 +203,6 @@ |
| 432 | 203 |
(vec* it |
| 433 | 204 |
#(0.5d0 0.7d0 1.0d0)))))))) |
| 434 | 205 |
|
| 435 |
- |
|
| 436 |
-(defclass camera () |
|
| 437 |
- ((origin :initarg :origin :reader origin) |
|
| 438 |
- (lower-left-corner :initarg :lower-left-corner :reader lower-left-corner) |
|
| 439 |
- (horizontal :initarg :horizontal :reader horizontal) |
|
| 440 |
- (vertical :initarg :vertical :reader vertical))) |
|
| 441 |
- |
|
| 442 | 206 |
(defun camera (&key |
| 443 | 207 |
(aspect-ratio 16/9) |
| 444 | 208 |
(viewport-height 2.0d0) |
| ... | ... |
@@ -523,220 +287,3 @@ |
| 523 | 287 |
do (rotatef (aref arr i) |
| 524 | 288 |
(aref arr j)) |
| 525 | 289 |
finally (return (coerce arr (type-of seq)))))) |
| 526 |
- |
|
| 527 |
-(defun raytrace (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50)) |
|
| 528 |
- (let* ((world (append (list (sphere #(0 0 -1) .5 |
|
| 529 |
- #(0.5 0.5 0.0) |
|
| 530 |
- (dielectric-material 0.4) |
|
| 531 |
- #+(or) |
|
| 532 |
- (lambda (rec ray world depth) |
|
| 533 |
- (declare (ignore rec world depth)) |
|
| 534 |
- (with-slots (direction) ray |
|
| 535 |
- (fw.lu:vector-destructuring-bind |
|
| 536 |
- (x y z) (unit-vector direction) |
|
| 537 |
- (vector (abs x) |
|
| 538 |
- (abs y) |
|
| 539 |
- (abs z))))))) |
|
| 540 |
- (loop repeat 30 |
|
| 541 |
- collect (sphere (vector (rand-min-max -3 3) |
|
| 542 |
- (rand-min-max -0.5 2) |
|
| 543 |
- (rand-min-max -1.5d0 -0.5d0)) |
|
| 544 |
- (rand-min-max 0.2 0.5) |
|
| 545 |
- (vector (random 1.0d0) |
|
| 546 |
- (random 1.0d0) |
|
| 547 |
- (random 1.0d0)) |
|
| 548 |
- (case (random 5) |
|
| 549 |
- (0 (lambertian-material |
|
| 550 |
- (rand-min-max 0.25 0.75))) |
|
| 551 |
- (1 (metal-material |
|
| 552 |
- (rand-min-max 0.25 0.75))) |
|
| 553 |
- (2 (fuzzy-metal-material |
|
| 554 |
- (rand-min-max 0.25 0.75) |
|
| 555 |
- (rand-min-max 0.01 0.75))) |
|
| 556 |
- (3 (dielectric-material |
|
| 557 |
- (rand-min-max 0.1 2.4))) |
|
| 558 |
- (4 #'original-material) |
|
| 559 |
- (5 |
|
| 560 |
- (lambda (rec ray world depth) |
|
| 561 |
- (declare (ignore rec world depth)) |
|
| 562 |
- (vector 1d0 1d0 1d0) |
|
| 563 |
- #+(or) |
|
| 564 |
- (with-slots (direction) ray |
|
| 565 |
- (fw.lu:vector-destructuring-bind |
|
| 566 |
- (x y z) (unit-vector direction) |
|
| 567 |
- (vector (abs x) |
|
| 568 |
- (abs y) |
|
| 569 |
- (abs z))))))))) |
|
| 570 |
- ;; #+(or) |
|
| 571 |
- (list (sphere #(0 -100.5 -1) 100 |
|
| 572 |
- #(0.5 0.5 0.5) |
|
| 573 |
- (lambertian-material 0.2))))) |
|
| 574 |
- (aspect-ratio 4/3) |
|
| 575 |
- (image-height (* (floor (/ image-width aspect-ratio)))) |
|
| 576 |
- |
|
| 577 |
- (camera (camera :focal-length 1.0d0))) |
|
| 578 |
- (let ((mailbox (sb-concurrency:make-mailbox))) |
|
| 579 |
- (loop for j in (shuffle (loop for x from 0 to image-height collect x)) |
|
| 580 |
- do |
|
| 581 |
- (sb-concurrency:send-message |
|
| 582 |
- (aref *thread-queues* |
|
| 583 |
- (mod j |
|
| 584 |
- (length *thread-queues*))) |
|
| 585 |
- (list *samples-per-pixel* |
|
| 586 |
- j image-width |
|
| 587 |
- image-height camera |
|
| 588 |
- world max-depth |
|
| 589 |
- (lambda (a b) |
|
| 590 |
- (sb-concurrency:send-message |
|
| 591 |
- mailbox |
|
| 592 |
- (list a b)))))) |
|
| 593 |
- (write-colors nil |
|
| 594 |
- (lambda (c) |
|
| 595 |
- (loop with messages = 0 |
|
| 596 |
- for it = (sb-concurrency:receive-message mailbox :timeout 2) |
|
| 597 |
- while it |
|
| 598 |
- do (destructuring-bind (color pos) it |
|
| 599 |
- (funcall c color pos)))) |
|
| 600 |
- image-width)))) |
|
| 601 |
- |
|
| 602 |
-(defun refraction-scene |
|
| 603 |
- (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50)) |
|
| 604 |
- (let* ((world (list (sphere #(0 0 -1) .5 |
|
| 605 |
- #(0.5 0.5 0.0) |
|
| 606 |
- (lambertian-material #(0.7 0.3 0.3))) |
|
| 607 |
- (sphere #(-1 0 -1) 0.5 |
|
| 608 |
- #(0 0 0) |
|
| 609 |
- (dielectric-material 1.5)) |
|
| 610 |
- (sphere #(-1 0 -1) -0.4 |
|
| 611 |
- #(0 0 0) |
|
| 612 |
- (dielectric-material 1.5)) |
|
| 613 |
- (sphere #(-1 0 -1) -0.2 |
|
| 614 |
- #(0 0 0) |
|
| 615 |
- (lambertian-material |
|
| 616 |
- #(0.8 0.6 0.2))) |
|
| 617 |
- #+(or) |
|
| 618 |
- (sphere #(1 0 -1) 0.5 |
|
| 619 |
- #(0 0 0) |
|
| 620 |
- (dielectric-material 2.4)) |
|
| 621 |
- #+(or) |
|
| 622 |
- (sphere #(-2 0 -1) 0.5 |
|
| 623 |
- #(0 0 0) |
|
| 624 |
- (metal-material #(0.8 0.8 0.8))) |
|
| 625 |
- (sphere #(1 0 -1) 0.5 |
|
| 626 |
- #(0 0 0) |
|
| 627 |
- (metal-material #(0.8 0.6 0.2))) |
|
| 628 |
- (sphere #(0 -100.5 -1) 100 |
|
| 629 |
- #(0.5 0.5 0.5) |
|
| 630 |
- (lambertian-material #(0.8 0.8 0.0))))) |
|
| 631 |
- (aspect-ratio 16/9) |
|
| 632 |
- (image-height (* (floor (/ image-width aspect-ratio)))) |
|
| 633 |
- |
|
| 634 |
- (camera (camera))) |
|
| 635 |
- (let ((mailbox (sb-concurrency:make-mailbox))) |
|
| 636 |
- (loop for j in (shuffle (loop for x from 0 to image-height collect x)) |
|
| 637 |
- do |
|
| 638 |
- (sb-concurrency:send-message |
|
| 639 |
- (aref *thread-queues* |
|
| 640 |
- (mod j |
|
| 641 |
- (length *thread-queues*))) |
|
| 642 |
- (list *samples-per-pixel* |
|
| 643 |
- j image-width |
|
| 644 |
- image-height camera |
|
| 645 |
- world max-depth |
|
| 646 |
- (lambda (a b) |
|
| 647 |
- (sb-concurrency:send-message |
|
| 648 |
- mailbox |
|
| 649 |
- (list a b)))))) |
|
| 650 |
- (write-colors nil |
|
| 651 |
- (lambda (c) |
|
| 652 |
- (loop with messages = 0 |
|
| 653 |
- for it = (sb-concurrency:receive-message mailbox :timeout 2) |
|
| 654 |
- while it |
|
| 655 |
- do (destructuring-bind (color pos) it |
|
| 656 |
- (funcall c color pos)))) |
|
| 657 |
- image-width)))) |
|
| 658 |
- |
|
| 659 |
-(defun refraction-scene1 |
|
| 660 |
- (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50)) |
|
| 661 |
- (let* ((world (list (sphere #(0 0 -1) 1 |
|
| 662 |
- #(0.5 0.5 0.0) |
|
| 663 |
- (dielectric-material 2.4)) |
|
| 664 |
- (sphere #(-0.5 0 -1) 0.5 |
|
| 665 |
- #(0 0 0) |
|
| 666 |
- (dielectric-material 1.5 0.2)) |
|
| 667 |
- (sphere #(-0.5 0 -1) -0.4 |
|
| 668 |
- #(0 0 0) |
|
| 669 |
- (dielectric-material 1.5 0.2)) |
|
| 670 |
- (sphere #(-0.5 0 -1) -0.2 |
|
| 671 |
- #(0 0 0) |
|
| 672 |
- (metal-material |
|
| 673 |
- #(0.8 0.6 0.2))) |
|
| 674 |
- #+(or) |
|
| 675 |
- (sphere #(1 0 -1) 0.5 |
|
| 676 |
- #(0 0 0) |
|
| 677 |
- (dielectric-material 2.4)) |
|
| 678 |
- #+(or) |
|
| 679 |
- (sphere #(-2 0 -1) 0.5 |
|
| 680 |
- #(0 0 0) |
|
| 681 |
- (metal-material #(0.8 0.8 0.8))) |
|
| 682 |
- (sphere #(0.5 0 -1) 0.5 |
|
| 683 |
- #(0 0 0) |
|
| 684 |
- (metal-material #(0.8 0.6 0.2))) |
|
| 685 |
- (sphere #(0 -100.5 -1) 100 |
|
| 686 |
- #(0.5 0.5 0.5) |
|
| 687 |
- (lambertian-material #(0.8 0.8 0.0))))) |
|
| 688 |
- (aspect-ratio 16/9) |
|
| 689 |
- (image-height (* (floor (/ image-width aspect-ratio)))) |
|
| 690 |
- |
|
| 691 |
- (camera (camera))) |
|
| 692 |
- (let ((mailbox (sb-concurrency:make-mailbox))) |
|
| 693 |
- (loop for j in (shuffle (loop for x from 0 to image-height collect x)) |
|
| 694 |
- do |
|
| 695 |
- (sb-concurrency:send-message |
|
| 696 |
- (aref *thread-queues* |
|
| 697 |
- (mod j |
|
| 698 |
- (length *thread-queues*))) |
|
| 699 |
- (list *samples-per-pixel* |
|
| 700 |
- j image-width |
|
| 701 |
- image-height camera |
|
| 702 |
- world max-depth |
|
| 703 |
- (lambda (a b) |
|
| 704 |
- (sb-concurrency:send-message |
|
| 705 |
- mailbox |
|
| 706 |
- (list a b)))))) |
|
| 707 |
- (write-colors nil |
|
| 708 |
- (lambda (c) |
|
| 709 |
- (loop with messages = 0 |
|
| 710 |
- for it = (sb-concurrency:receive-message mailbox :timeout 2) |
|
| 711 |
- while it |
|
| 712 |
- do (destructuring-bind (color pos) it |
|
| 713 |
- (funcall c color pos)))) |
|
| 714 |
- image-width)))) |
|
| 715 |
- |
|
| 716 |
-(defun sample-image (out) |
|
| 717 |
- (let ((image-width 256) |
|
| 718 |
- (image-height 256)) |
|
| 719 |
- (alexandria:with-output-to-file (s out :if-exists :supersede) |
|
| 720 |
- (call-with-ppm-header |
|
| 721 |
- s (make-size :width image-width :height image-height) |
|
| 722 |
- (lambda (s) |
|
| 723 |
- (write-colors |
|
| 724 |
- s (lambda (c) |
|
| 725 |
- (loop for j from (1- image-height) downto 0 |
|
| 726 |
- do (format *trace-output* |
|
| 727 |
- "~&Scanlines remaining: ~d ~s~%" |
|
| 728 |
- j |
|
| 729 |
- (local-time:now)) |
|
| 730 |
- do |
|
| 731 |
- (loop for i from 0 below image-width |
|
| 732 |
- collect |
|
| 733 |
- (let* ((r (/ (* i 1.0d0) |
|
| 734 |
- (1- image-width))) |
|
| 735 |
- (g (/ (* j 1.0d0) |
|
| 736 |
- (1- image-height))) |
|
| 737 |
- (b 0.15d0)) |
|
| 738 |
- (funcall c (make-color :r r |
|
| 739 |
- :g g |
|
| 740 |
- :b b)))))) |
|
| 741 |
- image-width)) |
|
| 742 |
- (1- #.(expt 2 8)))))) |
| 8 | 4 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,82 @@ |
| 1 |
+(in-package :fwoar.lisp-sandbox.material) |
|
| 2 |
+ |
|
| 3 |
+(defun original-material (rec ray world depth) |
|
| 4 |
+ (declare (ignore ray world depth)) |
|
| 5 |
+ (vec* 0.5 |
|
| 6 |
+ (vec+ #(1 1 1) |
|
| 7 |
+ (.normal rec)))) |
|
| 8 |
+ |
|
| 9 |
+(defun lambertian-material (albedo) |
|
| 10 |
+ (lambda (rec ray world depth) |
|
| 11 |
+ (declare (ignore ray)) |
|
| 12 |
+ (let ((scatter-direction (vec+ (.normal rec) |
|
| 13 |
+ (random-unit-vector)))) |
|
| 14 |
+ (when (near-zero scatter-direction) |
|
| 15 |
+ (setf scatter-direction (.normal rec))) |
|
| 16 |
+ |
|
| 17 |
+ (vec* albedo |
|
| 18 |
+ (ray-color (ray (.p rec) |
|
| 19 |
+ scatter-direction) |
|
| 20 |
+ world |
|
| 21 |
+ (1- depth)))))) |
|
| 22 |
+ |
|
| 23 |
+(defun metal-material (albedo) |
|
| 24 |
+ (lambda (rec ray world depth) |
|
| 25 |
+ (with-slots (direction) ray |
|
| 26 |
+ (let* ((reflected (reflect (unit-vector direction) |
|
| 27 |
+ (.normal rec))) |
|
| 28 |
+ (scattered (ray (.p rec) reflected))) |
|
| 29 |
+ (vec* albedo |
|
| 30 |
+ (ray-color scattered |
|
| 31 |
+ world |
|
| 32 |
+ (1- depth))))))) |
|
| 33 |
+ |
|
| 34 |
+(defun fuzzy-metal-material (albedo fuzz) |
|
| 35 |
+ (lambda (rec ray world depth) |
|
| 36 |
+ (with-slots (direction) ray |
|
| 37 |
+ (let* ((reflected (reflect (unit-vector direction) |
|
| 38 |
+ (.normal rec))) |
|
| 39 |
+ (scattered (ray (.p rec) |
|
| 40 |
+ (vec+ reflected |
|
| 41 |
+ (vec* fuzz |
|
| 42 |
+ (random-in-unit-sphere)))))) |
|
| 43 |
+ (vec* albedo |
|
| 44 |
+ (ray-color scattered |
|
| 45 |
+ world |
|
| 46 |
+ (1- depth))))))) |
|
| 47 |
+ |
|
| 48 |
+ |
|
| 49 |
+(defun dielectric-material (ir &optional (fuzz 0)) |
|
| 50 |
+ (lambda (rec ray world depth) |
|
| 51 |
+ (with-slots (direction) ray |
|
| 52 |
+ (let* ((attenuation (vec3 1.0d0 1.0d0 1.0d0)) |
|
| 53 |
+ (refraction-ratio (if (.front-face rec) |
|
| 54 |
+ (/ 1.0d0 ir) |
|
| 55 |
+ ir)) |
|
| 56 |
+ (unit-direction (unit-vector direction)) |
|
| 57 |
+ (normal (.normal rec)) |
|
| 58 |
+ (cos-theta (min 1.0d0 |
|
| 59 |
+ (dot (negate unit-direction) |
|
| 60 |
+ normal))) |
|
| 61 |
+ (sin-theta (sqrt (- 1 |
|
| 62 |
+ (* cos-theta cos-theta)))) |
|
| 63 |
+ (cannot-refract (> (* refraction-ratio |
|
| 64 |
+ sin-theta) |
|
| 65 |
+ 1.0d0)) |
|
| 66 |
+ (direction (if (or cannot-refract |
|
| 67 |
+ (> (reflectance cos-theta |
|
| 68 |
+ refraction-ratio) |
|
| 69 |
+ (random 1.0d0))) |
|
| 70 |
+ (reflect unit-direction |
|
| 71 |
+ normal) |
|
| 72 |
+ (refract unit-direction |
|
| 73 |
+ normal |
|
| 74 |
+ refraction-ratio))) |
|
| 75 |
+ (scattered (ray (.p rec) |
|
| 76 |
+ (vec+ direction |
|
| 77 |
+ (vec* fuzz |
|
| 78 |
+ (random-in-unit-sphere)))))) |
|
| 79 |
+ (vec* attenuation |
|
| 80 |
+ (ray-color scattered |
|
| 81 |
+ world |
|
| 82 |
+ (1- depth))))))) |
| 0 | 83 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,28 @@ |
| 1 |
+(defpackage :fwoar.lisp-sandbox.package |
|
| 2 |
+ (:use :cl ) |
|
| 3 |
+ (:export )) |
|
| 4 |
+ |
|
| 5 |
+(in-package :fwoar.lisp-sandbox.package) |
|
| 6 |
+ |
|
| 7 |
+(defpackage :fwoar.lisp-sandbox.canvas-server |
|
| 8 |
+ (:use :cl ) |
|
| 9 |
+ (:export |
|
| 10 |
+ #:send-update)) |
|
| 11 |
+ |
|
| 12 |
+(defpackage :fwoar.lisp-sandbox.material |
|
| 13 |
+ (:use :cl) |
|
| 14 |
+ (:export #:original-material |
|
| 15 |
+ #:lambertian-material |
|
| 16 |
+ #:metal-material |
|
| 17 |
+ #:fuzzy-metal-material |
|
| 18 |
+ #:dielectric-material)) |
|
| 19 |
+ |
|
| 20 |
+(defpackage :fwoar.lisp-sandbox.1 |
|
| 21 |
+ (:use :cl) |
|
| 22 |
+ (:import :fwoar.lisp-sandbox.material |
|
| 23 |
+ #:original-material |
|
| 24 |
+ #:lambertian-material |
|
| 25 |
+ #:metal-material |
|
| 26 |
+ #:fuzzy-metal-material |
|
| 27 |
+ #:dielectric-material) |
|
| 28 |
+ (:export )) |
| 23 | 26 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,218 @@ |
| 1 |
+(in-package :fwoar.lisp-sandbox.1) |
|
| 2 |
+ |
|
| 3 |
+(defun raytrace (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50)) |
|
| 4 |
+ (let* ((world (append (list (sphere #(0 0 -1) .5 |
|
| 5 |
+ #(0.5 0.5 0.0) |
|
| 6 |
+ (dielectric-material 0.4) |
|
| 7 |
+ #+(or) |
|
| 8 |
+ (lambda (rec ray world depth) |
|
| 9 |
+ (declare (ignore rec world depth)) |
|
| 10 |
+ (with-slots (direction) ray |
|
| 11 |
+ (fw.lu:vector-destructuring-bind |
|
| 12 |
+ (x y z) (unit-vector direction) |
|
| 13 |
+ (vector (abs x) |
|
| 14 |
+ (abs y) |
|
| 15 |
+ (abs z))))))) |
|
| 16 |
+ (loop repeat 30 |
|
| 17 |
+ collect (sphere (vector (rand-min-max -3 3) |
|
| 18 |
+ (rand-min-max -0.5 2) |
|
| 19 |
+ (rand-min-max -1.5d0 -0.5d0)) |
|
| 20 |
+ (rand-min-max 0.2 0.5) |
|
| 21 |
+ (vector (random 1.0d0) |
|
| 22 |
+ (random 1.0d0) |
|
| 23 |
+ (random 1.0d0)) |
|
| 24 |
+ (case (random 5) |
|
| 25 |
+ (0 (lambertian-material |
|
| 26 |
+ (rand-min-max 0.25 0.75))) |
|
| 27 |
+ (1 (metal-material |
|
| 28 |
+ (rand-min-max 0.25 0.75))) |
|
| 29 |
+ (2 (fuzzy-metal-material |
|
| 30 |
+ (rand-min-max 0.25 0.75) |
|
| 31 |
+ (rand-min-max 0.01 0.75))) |
|
| 32 |
+ (3 (dielectric-material |
|
| 33 |
+ (rand-min-max 0.1 2.4))) |
|
| 34 |
+ (4 #'original-material) |
|
| 35 |
+ (5 |
|
| 36 |
+ (lambda (rec ray world depth) |
|
| 37 |
+ (declare (ignore rec world depth)) |
|
| 38 |
+ (vector 1d0 1d0 1d0) |
|
| 39 |
+ #+(or) |
|
| 40 |
+ (with-slots (direction) ray |
|
| 41 |
+ (fw.lu:vector-destructuring-bind |
|
| 42 |
+ (x y z) (unit-vector direction) |
|
| 43 |
+ (vector (abs x) |
|
| 44 |
+ (abs y) |
|
| 45 |
+ (abs z))))))))) |
|
| 46 |
+ ;; #+(or) |
|
| 47 |
+ (list (sphere #(0 -100.5 -1) 100 |
|
| 48 |
+ #(0.5 0.5 0.5) |
|
| 49 |
+ (lambertian-material 0.2))))) |
|
| 50 |
+ (aspect-ratio 4/3) |
|
| 51 |
+ (image-height (* (floor (/ image-width aspect-ratio)))) |
|
| 52 |
+ |
|
| 53 |
+ (camera (camera :focal-length 1.0d0))) |
|
| 54 |
+ (let ((mailbox (sb-concurrency:make-mailbox))) |
|
| 55 |
+ (loop for j in (shuffle (loop for x from 0 to image-height collect x)) |
|
| 56 |
+ do |
|
| 57 |
+ (sb-concurrency:send-message |
|
| 58 |
+ (aref *thread-queues* |
|
| 59 |
+ (mod j |
|
| 60 |
+ (length *thread-queues*))) |
|
| 61 |
+ (list *samples-per-pixel* |
|
| 62 |
+ j image-width |
|
| 63 |
+ image-height camera |
|
| 64 |
+ world max-depth |
|
| 65 |
+ (lambda (a b) |
|
| 66 |
+ (sb-concurrency:send-message |
|
| 67 |
+ mailbox |
|
| 68 |
+ (list a b)))))) |
|
| 69 |
+ (write-colors nil |
|
| 70 |
+ (lambda (c) |
|
| 71 |
+ (loop with messages = 0 |
|
| 72 |
+ for it = (sb-concurrency:receive-message mailbox :timeout 2) |
|
| 73 |
+ while it |
|
| 74 |
+ do (destructuring-bind (color pos) it |
|
| 75 |
+ (funcall c color pos)))) |
|
| 76 |
+ image-width)))) |
|
| 77 |
+ |
|
| 78 |
+(defun refraction-scene |
|
| 79 |
+ (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50)) |
|
| 80 |
+ (let* ((world (list (sphere #(0 0 -1) .5 |
|
| 81 |
+ #(0.5 0.5 0.0) |
|
| 82 |
+ (lambertian-material #(0.7 0.3 0.3))) |
|
| 83 |
+ (sphere #(-1 0 -1) 0.5 |
|
| 84 |
+ #(0 0 0) |
|
| 85 |
+ (dielectric-material 1.5)) |
|
| 86 |
+ (sphere #(-1 0 -1) -0.4 |
|
| 87 |
+ #(0 0 0) |
|
| 88 |
+ (dielectric-material 1.5)) |
|
| 89 |
+ (sphere #(-1 0 -1) -0.2 |
|
| 90 |
+ #(0 0 0) |
|
| 91 |
+ (lambertian-material |
|
| 92 |
+ #(0.8 0.6 0.2))) |
|
| 93 |
+ #+(or) |
|
| 94 |
+ (sphere #(1 0 -1) 0.5 |
|
| 95 |
+ #(0 0 0) |
|
| 96 |
+ (dielectric-material 2.4)) |
|
| 97 |
+ #+(or) |
|
| 98 |
+ (sphere #(-2 0 -1) 0.5 |
|
| 99 |
+ #(0 0 0) |
|
| 100 |
+ (metal-material #(0.8 0.8 0.8))) |
|
| 101 |
+ (sphere #(1 0 -1) 0.5 |
|
| 102 |
+ #(0 0 0) |
|
| 103 |
+ (metal-material #(0.8 0.6 0.2))) |
|
| 104 |
+ (sphere #(0 -100.5 -1) 100 |
|
| 105 |
+ #(0.5 0.5 0.5) |
|
| 106 |
+ (lambertian-material #(0.8 0.8 0.0))))) |
|
| 107 |
+ (aspect-ratio 16/9) |
|
| 108 |
+ (image-height (* (floor (/ image-width aspect-ratio)))) |
|
| 109 |
+ |
|
| 110 |
+ (camera (camera))) |
|
| 111 |
+ (let ((mailbox (sb-concurrency:make-mailbox))) |
|
| 112 |
+ (loop for j in (shuffle (loop for x from 0 to image-height collect x)) |
|
| 113 |
+ do |
|
| 114 |
+ (sb-concurrency:send-message |
|
| 115 |
+ (aref *thread-queues* |
|
| 116 |
+ (mod j |
|
| 117 |
+ (length *thread-queues*))) |
|
| 118 |
+ (list *samples-per-pixel* |
|
| 119 |
+ j image-width |
|
| 120 |
+ image-height camera |
|
| 121 |
+ world max-depth |
|
| 122 |
+ (lambda (a b) |
|
| 123 |
+ (sb-concurrency:send-message |
|
| 124 |
+ mailbox |
|
| 125 |
+ (list a b)))))) |
|
| 126 |
+ (write-colors nil |
|
| 127 |
+ (lambda (c) |
|
| 128 |
+ (loop with messages = 0 |
|
| 129 |
+ for it = (sb-concurrency:receive-message mailbox :timeout 2) |
|
| 130 |
+ while it |
|
| 131 |
+ do (destructuring-bind (color pos) it |
|
| 132 |
+ (funcall c color pos)))) |
|
| 133 |
+ image-width)))) |
|
| 134 |
+ |
|
| 135 |
+(defun refraction-scene1 |
|
| 136 |
+ (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50)) |
|
| 137 |
+ (let* ((world (list (sphere #(0 0 -1) 1 |
|
| 138 |
+ #(0.5 0.5 0.0) |
|
| 139 |
+ (dielectric-material 2.4)) |
|
| 140 |
+ (sphere #(-0.5 0 -1) 0.5 |
|
| 141 |
+ #(0 0 0) |
|
| 142 |
+ (dielectric-material 1.5 0.2)) |
|
| 143 |
+ (sphere #(-0.5 0 -1) -0.4 |
|
| 144 |
+ #(0 0 0) |
|
| 145 |
+ (dielectric-material 1.5 0.2)) |
|
| 146 |
+ (sphere #(-0.5 0 -1) -0.2 |
|
| 147 |
+ #(0 0 0) |
|
| 148 |
+ (metal-material |
|
| 149 |
+ #(0.8 0.6 0.2))) |
|
| 150 |
+ #+(or) |
|
| 151 |
+ (sphere #(1 0 -1) 0.5 |
|
| 152 |
+ #(0 0 0) |
|
| 153 |
+ (dielectric-material 2.4)) |
|
| 154 |
+ #+(or) |
|
| 155 |
+ (sphere #(-2 0 -1) 0.5 |
|
| 156 |
+ #(0 0 0) |
|
| 157 |
+ (metal-material #(0.8 0.8 0.8))) |
|
| 158 |
+ (sphere #(0.5 0 -1) 0.5 |
|
| 159 |
+ #(0 0 0) |
|
| 160 |
+ (metal-material #(0.8 0.6 0.2))) |
|
| 161 |
+ (sphere #(0 -100.5 -1) 100 |
|
| 162 |
+ #(0.5 0.5 0.5) |
|
| 163 |
+ (lambertian-material #(0.8 0.8 0.0))))) |
|
| 164 |
+ (aspect-ratio 16/9) |
|
| 165 |
+ (image-height (* (floor (/ image-width aspect-ratio)))) |
|
| 166 |
+ |
|
| 167 |
+ (camera (camera))) |
|
| 168 |
+ (let ((mailbox (sb-concurrency:make-mailbox))) |
|
| 169 |
+ (loop for j in (shuffle (loop for x from 0 to image-height collect x)) |
|
| 170 |
+ do |
|
| 171 |
+ (sb-concurrency:send-message |
|
| 172 |
+ (aref *thread-queues* |
|
| 173 |
+ (mod j |
|
| 174 |
+ (length *thread-queues*))) |
|
| 175 |
+ (list *samples-per-pixel* |
|
| 176 |
+ j image-width |
|
| 177 |
+ image-height camera |
|
| 178 |
+ world max-depth |
|
| 179 |
+ (lambda (a b) |
|
| 180 |
+ (sb-concurrency:send-message |
|
| 181 |
+ mailbox |
|
| 182 |
+ (list a b)))))) |
|
| 183 |
+ (write-colors nil |
|
| 184 |
+ (lambda (c) |
|
| 185 |
+ (loop with messages = 0 |
|
| 186 |
+ for it = (sb-concurrency:receive-message mailbox :timeout 2) |
|
| 187 |
+ while it |
|
| 188 |
+ do (destructuring-bind (color pos) it |
|
| 189 |
+ (funcall c color pos)))) |
|
| 190 |
+ image-width)))) |
|
| 191 |
+ |
|
| 192 |
+(defun sample-image (out) |
|
| 193 |
+ (let ((image-width 256) |
|
| 194 |
+ (image-height 256)) |
|
| 195 |
+ (alexandria:with-output-to-file (s out :if-exists :supersede) |
|
| 196 |
+ (call-with-ppm-header |
|
| 197 |
+ s (make-size :width image-width :height image-height) |
|
| 198 |
+ (lambda (s) |
|
| 199 |
+ (write-colors |
|
| 200 |
+ s (lambda (c) |
|
| 201 |
+ (loop for j from (1- image-height) downto 0 |
|
| 202 |
+ do (format *trace-output* |
|
| 203 |
+ "~&Scanlines remaining: ~d ~s~%" |
|
| 204 |
+ j |
|
| 205 |
+ (local-time:now)) |
|
| 206 |
+ do |
|
| 207 |
+ (loop for i from 0 below image-width |
|
| 208 |
+ collect |
|
| 209 |
+ (let* ((r (/ (* i 1.0d0) |
|
| 210 |
+ (1- image-width))) |
|
| 211 |
+ (g (/ (* j 1.0d0) |
|
| 212 |
+ (1- image-height))) |
|
| 213 |
+ (b 0.15d0)) |
|
| 214 |
+ (funcall c (make-color :r r |
|
| 215 |
+ :g g |
|
| 216 |
+ :b b)))))) |
|
| 217 |
+ image-width)) |
|
| 218 |
+ (1- #.(expt 2 8)))))) |
| 0 | 219 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,149 @@ |
| 1 |
+(in-package :fwoar.lisp-sandbox.1) |
|
| 2 |
+ |
|
| 3 |
+(defun deg2rad (deg) |
|
| 4 |
+ (/ (* deg pi) |
|
| 5 |
+ 180.0d0)) |
|
| 6 |
+ |
|
| 7 |
+(defun rand-min-max (min max) |
|
| 8 |
+ (+ min |
|
| 9 |
+ (* (- max min) |
|
| 10 |
+ (random 1.0d0)))) |
|
| 11 |
+ |
|
| 12 |
+(defun rand-vec3 () |
|
| 13 |
+ (vec3 (random 1.0d0) |
|
| 14 |
+ (random 1.0d0) |
|
| 15 |
+ (random 1.0d0))) |
|
| 16 |
+ |
|
| 17 |
+(defun rand-vec3-min-max (min max) |
|
| 18 |
+ (vec3 (rand-min-max min max) |
|
| 19 |
+ (rand-min-max min max) |
|
| 20 |
+ (rand-min-max min max))) |
|
| 21 |
+ |
|
| 22 |
+(declaim (inline vec+ vec* vec- vec/ random-in-unit-sphere negate)) |
|
| 23 |
+(defun random-in-unit-sphere () |
|
| 24 |
+ (loop for p = (rand-vec3-min-max -1.0d0 1.0d0) |
|
| 25 |
+ while (>= (length-squared p) |
|
| 26 |
+ 1) |
|
| 27 |
+ finally (return p))) |
|
| 28 |
+ |
|
| 29 |
+(defun random-unit-vector () |
|
| 30 |
+ (unit-vector (random-in-unit-sphere))) |
|
| 31 |
+ |
|
| 32 |
+(defun vec+ (vec1 vec2) |
|
| 33 |
+ (declare (optimize (speed 3))) |
|
| 34 |
+ (fw.lu:vector-destructuring-bind (a b c) vec1 |
|
| 35 |
+ (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 36 |
+ (vec3 (+ a a1) |
|
| 37 |
+ (+ b b1) |
|
| 38 |
+ (+ c c1))))) |
|
| 39 |
+(define-compiler-macro vec+ (&whole whole vec1 vec2) |
|
| 40 |
+ (cond ((and (vectorp vec1) |
|
| 41 |
+ (vectorp vec2)) |
|
| 42 |
+ (vec+ vec1 vec2)) |
|
| 43 |
+ ((vectorp vec1) |
|
| 44 |
+ (alexandria:once-only (vec2) |
|
| 45 |
+ `(fw.lu:vector-destructuring-bind (a b c) ,vec1 |
|
| 46 |
+ (vec3 |
|
| 47 |
+ (+ a (aref ,vec2 0)) |
|
| 48 |
+ (+ b (aref ,vec2 1)) |
|
| 49 |
+ (+ c (aref ,vec2 2)))))) |
|
| 50 |
+ ((vectorp vec2) |
|
| 51 |
+ (alexandria:once-only (vec1) |
|
| 52 |
+ `(fw.lu:vector-destructuring-bind (a b c) ,vec2 |
|
| 53 |
+ (vec3 |
|
| 54 |
+ (+ a (aref ,vec1 0)) |
|
| 55 |
+ (+ b (aref ,vec1 1)) |
|
| 56 |
+ (+ c (aref ,vec1 2)))))) |
|
| 57 |
+ (t whole))) |
|
| 58 |
+(defun vec- (vec1 vec2) |
|
| 59 |
+ (declare (optimize (speed 3))) |
|
| 60 |
+ (fw.lu:vector-destructuring-bind (a b c) vec1 |
|
| 61 |
+ (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 62 |
+ (vec3 (- a a1) |
|
| 63 |
+ (- b b1) |
|
| 64 |
+ (- c c1))))) |
|
| 65 |
+(defun vec* (vec1 vec2) |
|
| 66 |
+ (declare (optimize (speed 3))) |
|
| 67 |
+ (etypecase vec1 |
|
| 68 |
+ ((array * (3)) (fw.lu:vector-destructuring-bind (a b c) vec1 |
|
| 69 |
+ (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 70 |
+ (vec3 (* a a1) |
|
| 71 |
+ (* b b1) |
|
| 72 |
+ (* c c1))))) |
|
| 73 |
+ (double-float (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 74 |
+ (vec3 (* vec1 a1) |
|
| 75 |
+ (* vec1 b1) |
|
| 76 |
+ (* vec1 c1)))) |
|
| 77 |
+ (single-float (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 78 |
+ (vec3 (* vec1 a1) |
|
| 79 |
+ (* vec1 b1) |
|
| 80 |
+ (* vec1 c1)))) |
|
| 81 |
+ (number (fw.lu:vector-destructuring-bind (a1 b1 c1) vec2 |
|
| 82 |
+ (vec3 (* vec1 a1) |
|
| 83 |
+ (* vec1 b1) |
|
| 84 |
+ (* vec1 c1)))))) |
|
| 85 |
+(defun negate (vec) |
|
| 86 |
+ (fw.lu:vector-destructuring-bind (x y z) vec |
|
| 87 |
+ (vec3 (- x) |
|
| 88 |
+ (- y) |
|
| 89 |
+ (- z)))) |
|
| 90 |
+ |
|
| 91 |
+(defun vec/ (vec it) |
|
| 92 |
+ (declare (optimize (speed 3))) |
|
| 93 |
+ (vec* (/ 1.0 it) |
|
| 94 |
+ vec)) |
|
| 95 |
+(defun dot (u v) |
|
| 96 |
+ (fw.lu:vector-destructuring-bind (a1 b1 c1) u |
|
| 97 |
+ (fw.lu:vector-destructuring-bind (a2 b2 c2) v |
|
| 98 |
+ (+ (* a1 a2) |
|
| 99 |
+ (* b1 b2) |
|
| 100 |
+ (* c1 c2))))) |
|
| 101 |
+(defun cross (u v) |
|
| 102 |
+ (fw.lu:vector-destructuring-bind (a1 b1 c1) u |
|
| 103 |
+ (fw.lu:vector-destructuring-bind (a2 b2 c2) v |
|
| 104 |
+ (vec3 (- (* b1 c2) |
|
| 105 |
+ (* c1 b2)) |
|
| 106 |
+ (- (* c1 a2) |
|
| 107 |
+ (* a1 c2)) |
|
| 108 |
+ (- (* a1 b2) |
|
| 109 |
+ (* b1 a2)))))) |
|
| 110 |
+ |
|
| 111 |
+(defun length-squared (v) |
|
| 112 |
+ (fw.lu:vector-destructuring-bind (x y z) v |
|
| 113 |
+ (+ (* x x) |
|
| 114 |
+ (* y y) |
|
| 115 |
+ (* z z)))) |
|
| 116 |
+(defun vec-length (v) |
|
| 117 |
+ (sqrt (length-squared v))) |
|
| 118 |
+(defun unit-vector (v) |
|
| 119 |
+ (vec/ v |
|
| 120 |
+ (vec-length v))) |
|
| 121 |
+ |
|
| 122 |
+(declaim (inline near-zero)) |
|
| 123 |
+(defun near-zero (vec) |
|
| 124 |
+ (fw.lu:vector-destructuring-bind (x y z) vec |
|
| 125 |
+ (let* ((s 1.0d-8)) |
|
| 126 |
+ (and (< (abs x) s) |
|
| 127 |
+ (< (abs y) s) |
|
| 128 |
+ (< (abs z) s))))) |
|
| 129 |
+ |
|
| 130 |
+(defvar *color-depth* 255) |
|
| 131 |
+ |
|
| 132 |
+(defun clamp (x min max) |
|
| 133 |
+ (cond ((< x min) min) |
|
| 134 |
+ ((> x max) max) |
|
| 135 |
+ (t x))) |
|
| 136 |
+ |
|
| 137 |
+(defvar *samples-per-pixel* 1) |
|
| 138 |
+(defun scale-to-8bit (color) |
|
| 139 |
+ (let ((scale (/ *samples-per-pixel*))) |
|
| 140 |
+ (flet ((scale-to-depth (c) |
|
| 141 |
+ (floor |
|
| 142 |
+ (* *color-depth* |
|
| 143 |
+ (clamp (sqrt (* c scale)) |
|
| 144 |
+ 0.0d0 0.999d0))))) |
|
| 145 |
+ (fwoar.lisputils:vector-destructuring-bind (r g b) color |
|
| 146 |
+ (let ((r (scale-to-depth r)) |
|
| 147 |
+ (g (scale-to-depth g)) |
|
| 148 |
+ (b (scale-to-depth b))) |
|
| 149 |
+ (vec3 r g b)))))) |