Browse code
feat: more formal raytracing system
Edward authored on 22/03/2021 07:54:54Showing 3 changed files
- raytracing_in_one_weekend/1.lisp
- raytracing_in_one_weekend/canvas-server.lisp
- raytracing_in_one_weekend/raytracing.asd
| ... | ... |
@@ -41,6 +41,8 @@ |
| 41 | 41 |
while (>= (length-squared p) |
| 42 | 42 |
1) |
| 43 | 43 |
finally (return p))) |
| 44 |
+(defun random-unit-vector () |
|
| 45 |
+ (unit-vector (random-in-unit-sphere))) |
|
| 44 | 46 |
|
| 45 | 47 |
(defun vec+ (vec1 vec2) |
| 46 | 48 |
(declare (optimize (speed 3))) |
| ... | ... |
@@ -144,21 +146,30 @@ |
| 144 | 146 |
(t x))) |
| 145 | 147 |
|
| 146 | 148 |
(defvar *samples-per-pixel* 1) |
| 147 |
-(defun format-color (s v _ __) |
|
| 148 |
- #.(ig _ __) |
|
| 149 |
+(defun scale-to-8bit (color) |
|
| 149 | 150 |
(let ((scale (/ *samples-per-pixel*))) |
| 150 | 151 |
(flet ((scale-to-depth (c) |
| 151 | 152 |
(floor |
| 152 | 153 |
(* *color-depth* |
| 153 | 154 |
(clamp (sqrt (* c scale)) |
| 154 | 155 |
0.0d0 0.999d0))))) |
| 155 |
- (fwoar.lisputils:vector-destructuring-bind (r g b) v |
|
| 156 |
+ (fwoar.lisputils:vector-destructuring-bind (r g b) color |
|
| 156 | 157 |
(let ((r (scale-to-depth r)) |
| 157 | 158 |
(g (scale-to-depth g)) |
| 158 | 159 |
(b (scale-to-depth b))) |
| 159 |
- (format s "~4d ~4d ~4d" r g b)))))) |
|
| 160 |
+ (vec3 r g b)))))) |
|
| 161 |
+ |
|
| 162 |
+(defun format-color (s v _ __) |
|
| 163 |
+ #.(ig _ __) |
|
| 164 |
+ (fw.lu:vector-destructuring-bind (r g b) (scale-to-8bit v) |
|
| 165 |
+ (format s "~4d ~4d ~4d" r g b))) |
|
| 160 | 166 |
|
| 161 | 167 |
(defun write-colors (stream colors columns) |
| 168 |
+ (funcall colors |
|
| 169 |
+ (lambda (color pos) |
|
| 170 |
+ (fwoar.lisp-sandbox.canvas-server:send-update |
|
| 171 |
+ (scale-to-8bit color) pos))) |
|
| 172 |
+ #+(or) |
|
| 162 | 173 |
(let ((intermediate ()) |
| 163 | 174 |
(idx 0)) |
| 164 | 175 |
(funcall colors |
| ... | ... |
@@ -186,6 +197,7 @@ |
| 186 | 197 |
((p :initarg :p :reader .p) |
| 187 | 198 |
(time :initarg :time :reader .time) |
| 188 | 199 |
(thing :initarg :thing :accessor .thing) |
| 200 |
+ (material :initarg :material :accessor .material) |
|
| 189 | 201 |
(normal :initarg :normal :accessor .normal :initform ()) |
| 190 | 202 |
(front-face :initarg :front-face :accessor .front-face :initform ()))) |
| 191 | 203 |
(defun set-face-normal (hit-record r outward-normal) |
| ... | ... |
@@ -207,7 +219,8 @@ |
| 207 | 219 |
:reader material-color |
| 208 | 220 |
:initform (vec3 (random 1.0d0) |
| 209 | 221 |
(random 1.0d0) |
| 210 |
- (random 1.0d0))))) |
|
| 222 |
+ (random 1.0d0))) |
|
| 223 |
+ (material :initarg :material :reader .material :initform (lambertian-material (random 0.8))))) |
|
| 211 | 224 |
|
| 212 | 225 |
(defgeneric hit (thing ray t-min t-max) |
| 213 | 226 |
(:method ((things list) (r ray) (t-min real) (t-max real)) |
| ... | ... |
@@ -225,6 +238,7 @@ |
| 225 | 238 |
(values hit-anything |
| 226 | 239 |
temp-rec)))) |
| 227 | 240 |
(:method ((sphere sphere) (r ray) (t-min real) (t-max real)) |
| 241 |
+ (declare (optimize (speed 3))) |
|
| 228 | 242 |
(uiop:nest (with-slots ((%center center) (%radius radius)) sphere) |
| 229 | 243 |
(let ((center %center) (radius %radius))) |
| 230 | 244 |
(with-slots ((%origin origin) (%direction direction)) r) |
| ... | ... |
@@ -254,7 +268,7 @@ |
| 254 | 268 |
radius))) |
| 255 | 269 |
|
| 256 | 270 |
(values t |
| 257 |
- (set-face-normal (hit-record p root sphere) |
|
| 271 |
+ (set-face-normal (hit-record p root sphere (.material sphere)) |
|
| 258 | 272 |
r |
| 259 | 273 |
outward-normal))))))))) |
| 260 | 274 |
|
| ... | ... |
@@ -272,6 +286,26 @@ |
| 272 | 286 |
(/ (- (- half-b) (sqrt discriminant)) |
| 273 | 287 |
a))))) |
| 274 | 288 |
|
| 289 |
+(defgeneric scatter (material ray-in rec)) |
|
| 290 |
+ |
|
| 291 |
+(defun original-material (rec world depth) |
|
| 292 |
+ (vec* 0.5 |
|
| 293 |
+ (vec+ #(1 1 1) |
|
| 294 |
+ (.normal rec)))) |
|
| 295 |
+ |
|
| 296 |
+(defun lambertian-material (albedo) |
|
| 297 |
+ (lambda (rec world depth) |
|
| 298 |
+ (let ((target (vec+ (vec+ (.p rec) |
|
| 299 |
+ (.normal rec)) |
|
| 300 |
+ (random-unit-vector)))) |
|
| 301 |
+ (vec* (material-color (.thing rec)) |
|
| 302 |
+ (vec* albedo |
|
| 303 |
+ (ray-color (ray (.p rec) |
|
| 304 |
+ (vec- target |
|
| 305 |
+ (.p rec))) |
|
| 306 |
+ world |
|
| 307 |
+ (1- depth))))))) |
|
| 308 |
+ |
|
| 275 | 309 |
(defgeneric ray-color (ray world depth) |
| 276 | 310 |
(:method :around (r w (depth integer)) |
| 277 | 311 |
(if (<= depth 0) |
| ... | ... |
@@ -281,18 +315,8 @@ |
| 281 | 315 |
(multiple-value-bind (hit-p rec) |
| 282 | 316 |
(hit world ray 0.001d0 infinity) |
| 283 | 317 |
(when hit-p |
| 284 |
- (let ((target (vec+ (vec+ (.p rec) |
|
| 285 |
- (.normal rec)) |
|
| 286 |
- (random-in-unit-sphere)))) |
|
| 287 |
- (return-from ray-color |
|
| 288 |
- #+(or) |
|
| 289 |
- (vec* (material-color (.thing rec))) |
|
| 290 |
- (vec* 0.75 |
|
| 291 |
- (ray-color (ray (.p rec) |
|
| 292 |
- (vec- target |
|
| 293 |
- (.p rec))) |
|
| 294 |
- world |
|
| 295 |
- (1- depth)))))) |
|
| 318 |
+ (return-from ray-color |
|
| 319 |
+ (funcall (.material rec) rec world depth))) |
|
| 296 | 320 |
(with-slots (direction) ray |
| 297 | 321 |
(let* ((unit-direction (unit-vector direction)) |
| 298 | 322 |
(it (+ (* 0.5 (v3-y unit-direction)) |
| ... | ... |
@@ -341,81 +365,130 @@ |
| 341 | 365 |
(vec+ (vec* v vertical)) |
| 342 | 366 |
(vec- origin))))))) |
| 343 | 367 |
|
| 368 |
+(declaim (notinline u-loop)) |
|
| 369 |
+(defun u-loop (j image-width image-height camera world max-depth c) |
|
| 370 |
+ (loop for i from 0 below image-width |
|
| 371 |
+ for u = (/ (* 1.0d0 i) |
|
| 372 |
+ (1- image-width)) |
|
| 373 |
+ for v = (/ (* 1.0d0 j) |
|
| 374 |
+ (1- image-height)) |
|
| 375 |
+ for r = (get-ray camera u v) |
|
| 376 |
+ for color = (loop for s below *samples-per-pixel* |
|
| 377 |
+ for u = (/ i |
|
| 378 |
+ (1- image-width)) |
|
| 379 |
+ then (/ (+ i (random 1.0d0)) |
|
| 380 |
+ (1- image-width)) |
|
| 381 |
+ for v = (/ j |
|
| 382 |
+ (1- image-height)) |
|
| 383 |
+ then (/ (+ j (random 1.0d0)) |
|
| 384 |
+ (1- image-height)) |
|
| 385 |
+ for r = (get-ray camera u v) |
|
| 386 |
+ for pixel-color = (ray-color r world max-depth) |
|
| 387 |
+ then (vec+ pixel-color |
|
| 388 |
+ (ray-color r world max-depth)) |
|
| 389 |
+ finally (return pixel-color)) |
|
| 390 |
+ do (funcall c color |
|
| 391 |
+ (list i |
|
| 392 |
+ (- image-height j))))) |
|
| 393 |
+ |
|
| 394 |
+(defvar *thread-queues* |
|
| 395 |
+ (make-array 8)) |
|
| 396 |
+ |
|
| 397 |
+(defun start-worker (id) |
|
| 398 |
+ (let ((mailbox (sb-concurrency:make-mailbox :name (format nil "mailbox-~d" id)))) |
|
| 399 |
+ (setf (aref *thread-queues* id) mailbox) |
|
| 400 |
+ (bt:make-thread |
|
| 401 |
+ (lambda () |
|
| 402 |
+ (loop |
|
| 403 |
+ (destructuring-bind (*samples-per-pixel* |
|
| 404 |
+ j image-width image-height camera world max-depth c) |
|
| 405 |
+ (sb-concurrency:receive-message mailbox) |
|
| 406 |
+ (u-loop j image-width image-height camera world max-depth c)))) |
|
| 407 |
+ :name (format nil "worker-~d" id)))) |
|
| 408 |
+ |
|
| 409 |
+(defun start-workers () |
|
| 410 |
+ (loop for x below 8 |
|
| 411 |
+ collect (start-worker x))) |
|
| 412 |
+ |
|
| 413 |
+(defun shuffle (seq) |
|
| 414 |
+ (let ((arr (map 'vector 'identity seq))) |
|
| 415 |
+ (loop for i from (1- (length arr)) downto 1 |
|
| 416 |
+ for j = (random i) |
|
| 417 |
+ do (rotatef (aref arr i) |
|
| 418 |
+ (aref arr j)) |
|
| 419 |
+ finally (return (coerce arr (type-of seq)))))) |
|
| 420 |
+ |
|
| 344 | 421 |
(defun raytrace (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50)) |
| 345 | 422 |
(let* ((world (append (list (sphere #(0 0 -1) 0.5 |
| 346 |
- #(0.5 0.5 0.0))) |
|
| 347 |
- #+(or) |
|
| 348 |
- (loop repeat 10 |
|
| 349 |
- collect (sphere (vector (rand-min-max -1 1) |
|
| 350 |
- (rand-min-max -1 1) |
|
| 351 |
- (rand-min-max -1.0d0 -.5d0)) |
|
| 352 |
- (rand-min-max 0.2 0.5))) |
|
| 423 |
+ #(0.5 0.5 0.0) |
|
| 424 |
+ #'original-material)) |
|
| 425 |
+ (loop repeat 30 |
|
| 426 |
+ collect (sphere (vector (rand-min-max -1.5 1.5) |
|
| 427 |
+ (rand-min-max -1.5 1.5) |
|
| 428 |
+ (rand-min-max -1.5d0 -1.0d0)) |
|
| 429 |
+ (rand-min-max 0.2 0.5) |
|
| 430 |
+ (vector (random 1.0d0) |
|
| 431 |
+ (random 1.0d0) |
|
| 432 |
+ (random 1.0d0)) |
|
| 433 |
+ (if (= 1 (random 2)) |
|
| 434 |
+ (lambertian-material |
|
| 435 |
+ (rand-min-max 0.25 0.75)) |
|
| 436 |
+ #'original-material))) |
|
| 353 | 437 |
(list (sphere #(0 -100.5 -1) 100 |
| 354 |
- #(0.5 0.5 0.5))))) |
|
| 438 |
+ #(0.5 0.5 0.5) |
|
| 439 |
+ (lambertian-material 0.2))))) |
|
| 355 | 440 |
(aspect-ratio 4/3) |
| 356 | 441 |
(image-height (* (floor (/ image-width aspect-ratio)))) |
| 357 | 442 |
|
| 358 | 443 |
(camera (camera))) |
| 359 |
- (alexandria:with-output-to-file (s out :if-exists :supersede) |
|
| 360 |
- (call-with-ppm-header s (make-size :width image-width :height image-height) |
|
| 361 |
- (lambda (s) |
|
| 362 |
- (write-colors s |
|
| 363 |
- (lambda (c) |
|
| 364 |
- (loop for j from (1- image-height) downto 0 |
|
| 365 |
- do (format *trace-output* |
|
| 366 |
- "~&Scanlines remaining: ~d ~s~%" |
|
| 367 |
- j |
|
| 368 |
- (local-time:now)) |
|
| 369 |
- (force-output s) |
|
| 370 |
- do |
|
| 371 |
- (loop for i from 0 below image-width |
|
| 372 |
- for u = (/ (* 1.0d0 i) |
|
| 373 |
- (1- image-width)) |
|
| 374 |
- for v = (/ (* 1.0d0 j) |
|
| 375 |
- (1- image-height)) |
|
| 376 |
- for r = (get-ray camera u v) |
|
| 377 |
- for color = (loop for s below *samples-per-pixel* |
|
| 378 |
- for u = (/ i |
|
| 379 |
- (1- image-width)) |
|
| 380 |
- then (/ (+ i (random 1.0d0)) |
|
| 381 |
- (1- image-width)) |
|
| 382 |
- for v = (/ j |
|
| 383 |
- (1- image-height)) |
|
| 384 |
- then (/ (+ j (random 1.0d0)) |
|
| 385 |
- (1- image-height)) |
|
| 386 |
- for r = (get-ray camera u v) |
|
| 387 |
- for pixel-color = (ray-color r world max-depth) |
|
| 388 |
- then (vec+ pixel-color |
|
| 389 |
- (ray-color r world max-depth)) |
|
| 390 |
- finally (return pixel-color)) |
|
| 391 |
- collect |
|
| 392 |
- (funcall c color)))) |
|
| 393 |
- image-width)) |
|
| 394 |
- (round *color-depth*))))) |
|
| 444 |
+ (let ((mailbox (sb-concurrency:make-mailbox))) |
|
| 445 |
+ (loop for j in (shuffle (loop for x from 0 to image-height collect x)) |
|
| 446 |
+ do |
|
| 447 |
+ (sb-concurrency:send-message |
|
| 448 |
+ (aref *thread-queues* |
|
| 449 |
+ (mod j |
|
| 450 |
+ (length *thread-queues*))) |
|
| 451 |
+ (list *samples-per-pixel* |
|
| 452 |
+ j image-width |
|
| 453 |
+ image-height camera |
|
| 454 |
+ world max-depth |
|
| 455 |
+ (lambda (a b) |
|
| 456 |
+ (sb-concurrency:send-message |
|
| 457 |
+ mailbox |
|
| 458 |
+ (list a b)))))) |
|
| 459 |
+ (write-colors nil |
|
| 460 |
+ (lambda (c) |
|
| 461 |
+ (loop with messages = 0 |
|
| 462 |
+ for it = (sb-concurrency:receive-message mailbox :timeout 2) |
|
| 463 |
+ while it |
|
| 464 |
+ do (destructuring-bind (color pos) it |
|
| 465 |
+ (funcall c color pos)))) |
|
| 466 |
+ image-width)))) |
|
| 395 | 467 |
|
| 396 | 468 |
(defun sample-image (out) |
| 397 | 469 |
(let ((image-width 256) |
| 398 | 470 |
(image-height 256)) |
| 399 | 471 |
(alexandria:with-output-to-file (s out :if-exists :supersede) |
| 400 |
- (call-with-ppm-header s (make-size :width image-width :height image-height) |
|
| 401 |
- (lambda (s) |
|
| 402 |
- (write-colors s |
|
| 403 |
- (lambda (c) |
|
| 404 |
- (loop for j from (1- image-height) downto 0 |
|
| 405 |
- do (format *trace-output* |
|
| 406 |
- "~&Scanlines remaining: ~d ~s~%" |
|
| 407 |
- j |
|
| 408 |
- (local-time:now)) |
|
| 409 |
- do |
|
| 410 |
- (loop for i from 0 below image-width |
|
| 411 |
- collect |
|
| 412 |
- (let* ((r (/ (* i 1.0d0) |
|
| 413 |
- (1- image-width))) |
|
| 414 |
- (g (/ (* j 1.0d0) |
|
| 415 |
- (1- image-height))) |
|
| 416 |
- (b 0.15d0)) |
|
| 417 |
- (funcall c (make-color :r r |
|
| 418 |
- :g g |
|
| 419 |
- :b b)))))) |
|
| 420 |
- image-width)) |
|
| 421 |
- (1- #.(expt 2 8)))))) |
|
| 472 |
+ (call-with-ppm-header |
|
| 473 |
+ s (make-size :width image-width :height image-height) |
|
| 474 |
+ (lambda (s) |
|
| 475 |
+ (write-colors |
|
| 476 |
+ s (lambda (c) |
|
| 477 |
+ (loop for j from (1- image-height) downto 0 |
|
| 478 |
+ do (format *trace-output* |
|
| 479 |
+ "~&Scanlines remaining: ~d ~s~%" |
|
| 480 |
+ j |
|
| 481 |
+ (local-time:now)) |
|
| 482 |
+ do |
|
| 483 |
+ (loop for i from 0 below image-width |
|
| 484 |
+ collect |
|
| 485 |
+ (let* ((r (/ (* i 1.0d0) |
|
| 486 |
+ (1- image-width))) |
|
| 487 |
+ (g (/ (* j 1.0d0) |
|
| 488 |
+ (1- image-height))) |
|
| 489 |
+ (b 0.15d0)) |
|
| 490 |
+ (funcall c (make-color :r r |
|
| 491 |
+ :g g |
|
| 492 |
+ :b b)))))) |
|
| 493 |
+ image-width)) |
|
| 494 |
+ (1- #.(expt 2 8)))))) |
| 422 | 495 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,69 @@ |
| 1 |
+(defpackage :fwoar.lisp-sandbox.canvas-server |
|
| 2 |
+ (:use :cl ) |
|
| 3 |
+ (:export |
|
| 4 |
+ #:send-update)) |
|
| 5 |
+(in-package :fwoar.lisp-sandbox.canvas-server) |
|
| 6 |
+ |
|
| 7 |
+(defvar *ws-servers* (make-array 10 :fill-pointer 0 :adjustable t)) |
|
| 8 |
+(defvar *stopped* ()) |
|
| 9 |
+ |
|
| 10 |
+(defun send-update (color pos) |
|
| 11 |
+ (wsd:send |
|
| 12 |
+ (elt *ws-servers* (1- (length *ws-servers*))) |
|
| 13 |
+ (with-output-to-string (s) |
|
| 14 |
+ (yason:encode (list color |
|
| 15 |
+ pos) |
|
| 16 |
+ s)))) |
|
| 17 |
+ |
|
| 18 |
+(defparameter *app* |
|
| 19 |
+ (lambda (env) |
|
| 20 |
+ (cond ((string= "/ws" (getf env :request-uri)) |
|
| 21 |
+ (let* ((ws (wsd:make-server env)) |
|
| 22 |
+ (idx (if *stopped* |
|
| 23 |
+ (setf (aref *ws-servers* |
|
| 24 |
+ (pop *stopped*)) |
|
| 25 |
+ ws) |
|
| 26 |
+ (vector-push-extend ws *ws-servers*)))) |
|
| 27 |
+ idx |
|
| 28 |
+ (lambda (responder) |
|
| 29 |
+ responder |
|
| 30 |
+ (wsd:start-connection ws)))) |
|
| 31 |
+ (t |
|
| 32 |
+ (format *trace-output* "~&~s~%" env) |
|
| 33 |
+ (list 200 '(:content-type "text/html") |
|
| 34 |
+ (list |
|
| 35 |
+ (spinneret:with-html-string |
|
| 36 |
+ (:html |
|
| 37 |
+ (:body |
|
| 38 |
+ (:canvas#out :width 1000 :height 1000) |
|
| 39 |
+ (:script |
|
| 40 |
+ (ps:ps |
|
| 41 |
+ (let* ((canvas (ps:chain document |
|
| 42 |
+ (query-selector "canvas#out"))) |
|
| 43 |
+ (context (ps:chain canvas |
|
| 44 |
+ (get-context "2d"))) |
|
| 45 |
+ (i-d (ps:chain context |
|
| 46 |
+ (create-image-data 1 1))) |
|
| 47 |
+ (ws (ps:new (-web-socket "ws://localhost:5000/ws")))) |
|
| 48 |
+ (ps:chain ws |
|
| 49 |
+ (add-event-listener |
|
| 50 |
+ "message" |
|
| 51 |
+ (lambda (evt) |
|
| 52 |
+ (let ((data (ps:@ i-d data))) |
|
| 53 |
+ (destructuring-bind ((r g b) |
|
| 54 |
+ (x y)) |
|
| 55 |
+ (ps:chain -j-s-o-n |
|
| 56 |
+ (parse (ps:@ evt data))) |
|
| 57 |
+ (setf (aref data 0) r |
|
| 58 |
+ (aref data 1) g |
|
| 59 |
+ (aref data 2) b |
|
| 60 |
+ (aref data 3) 255) |
|
| 61 |
+ (ps:chain context |
|
| 62 |
+ (put-image-data |
|
| 63 |
+ i-d x y)) |
|
| 64 |
+ (values)))))))))))))) |
|
| 65 |
+ #+qwer |
|
| 66 |
+ (lambda ))))) |
|
| 67 |
+(defun setup () |
|
| 68 |
+ (lambda (env) |
|
| 69 |
+ (funcall *app* env))) |
| 0 | 70 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,22 @@ |
| 1 |
+;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Package: ASDF-USER -*- |
|
| 2 |
+(in-package :asdf-user) |
|
| 3 |
+ |
|
| 4 |
+(defsystem :raytracing |
|
| 5 |
+ :description "" |
|
| 6 |
+ :author "Ed L <edward@elangley.org>" |
|
| 7 |
+ :license "MIT" |
|
| 8 |
+ :depends-on (#:alexandria |
|
| 9 |
+ #:bordeaux-threads |
|
| 10 |
+ #:clack |
|
| 11 |
+ #:fwoar-lisputils |
|
| 12 |
+ #:local-time |
|
| 13 |
+ #:parenscript |
|
| 14 |
+ #:spinneret |
|
| 15 |
+ #:uiop |
|
| 16 |
+ #:websocket-driver |
|
| 17 |
+ #:yason |
|
| 18 |
+ (:require :sb-concurrency)) |
|
| 19 |
+ :serial t |
|
| 20 |
+ :components ((:file "canvas-server") |
|
| 21 |
+ (:file "1") |
|
| 22 |
+ )) |