diff --git a/src/color.ct b/src/color.ct index d33d437..4309a9b 100644 --- a/src/color.ct +++ b/src/color.ct @@ -6,6 +6,7 @@ #:get-r #:get-g #:get-b + #:gamma-correct #:black #:white #:mul @@ -26,16 +27,24 @@ (lisp (-> Color) (r g b) (simd:make-f64.4 r g b 0.0d0))) (inline) - (declare get-r (Color -> F64)) - (define (get-r color) (lisp (-> F64) (color) (cl:nth-value 0 (simd:f64.4-values color)))) + (declare spread (Color -> F64 * F64 * F64)) + (define (spread color) + (let (values r g b _) = (lisp (-> F64 * F64 * F64 * F64) (color) + (simd:f64.4-values color))) + (values r g b)) + (inline) - (declare get-g (Color -> F64)) - (define (get-g color) (lisp (-> F64) (color) (cl:nth-value 1 (simd:f64.4-values color)))) - - (inline) - (declare get-b (Color -> F64)) - (define (get-b color) (lisp (-> F64) (color) (cl:nth-value 2 (simd:f64.4-values color)))) + (declare gamma-correct (Color -> U8 * U8 * U8)) + (define (gamma-correct color) + (let corrected = (lisp (-> Color) (color) + (simd:f64.4-sqrt color))) + (let byte-range = (mul-scalar corrected 255.9990d0)) + (let (values rc gc bc) = (spread byte-range)) + (let r = (unwrap-as U8 (floor rc))) + (let g = (unwrap-as U8 (floor gc))) + (let b = (unwrap-as U8 (floor bc))) + (values r g b)) (inline) (declare black Color) @@ -55,10 +64,10 @@ (declare mul-scalar (Color * F64 -> Color)) (define (mul-scalar col v) "Multiply a color by a given scalar value" - (lisp (-> Color) (col v) (simd:f64.4* col (simd:f64.4-broadcast v)))) + (lisp (-> Color) (col v) (simd:f64.4* col v))) (inline) (declare add (Color * Color -> Color)) (define (add c1 c2) - (lisp (-> Color) (c1 c2) (simd:f64.4* c1 c2))) + (lisp (-> Color) (c1 c2) (simd:f64.4+ c1 c2))) ) diff --git a/src/main.ct b/src/main.ct index 6dc92b3..0ecea34 100644 --- a/src/main.ct +++ b/src/main.ct @@ -24,21 +24,22 @@ (#:m #:ray/material) (#:util #:ray/util) (#:scene #:ray/scene) - (#:ppm #:ray/ppm))) + (#:ppm #:ray/ppm) + (#:simd #:sb-simd-avx))) (cl:in-package #:ray) -(cl:declaim (cl:optimize (cl:speed 2) (cl:safety 1) (cl:debug 1))) +(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0) (cl:debug 0))) (coalton-toplevel - (declare ASPECT-RATIO Fraction) - (define ASPECT-RATIO (/ 16 9)) + (declare ASPECT-RATIO F64) + (define ASPECT-RATIO (/ 16.0d0 9.0d0)) (declare IMAGE-WIDTH UFix) (define IMAGE-WIDTH 1200) (declare IMAGE-HEIGHT UFix) - (define IMAGE-HEIGHT (unwrap-as UFix (floor (/ (into IMAGE-WIDTH) ASPECT-RATIO)))) + (define IMAGE-HEIGHT (unwrap-as UFix (floor (/ (unwrap-as F64 IMAGE-WIDTH) ASPECT-RATIO)))) (declare SAMPLES-PER-PIXEL UFix) (define SAMPLES-PER-PIXEL 500) @@ -122,6 +123,7 @@ (define NUM-THREADS 12) + (inline) (declare get-ray (UFix * UFix -> r:Ray)) (define (get-ray i j) "Construct a camera ray originating at the origin and directed at a randomly sampled point around pixel location (i,j)" @@ -135,7 +137,8 @@ (defocus-disk-sample))) (let direction = (v:vec-sub pixel-sample ray-origin)) (r:Ray ray-origin direction)) - + + (inline) (declare defocus-disk-sample (Void -> v::Vec3)) (define (defocus-disk-sample) (let vec = (v:random-in-unit-disk)) @@ -144,10 +147,12 @@ (v:vec-add CAMERA-CENTER (v:vec-add (v:vec-mul-scalar DEFOCUS-DISK-U x) (v:vec-mul-scalar DEFOCUS-DISK-V y)))) + (inline) (declare sample-square (Void -> F64 * F64)) (define (sample-square) (values (- (util:rand-f64) 0.5d0) (- (util:rand-f64) 0.5d0))) + (inline) (declare hit-any? (r:Ray * F64 * F64 -> Optional h:HitRecord)) (define (hit-any? ray tmin tmax) (let (Tuple closest-hit _) = @@ -160,6 +165,7 @@ scene:complex-world)) closest-hit) + (inline) (declare ray-color (r:Ray * UFix -> c:Color)) (define (ray-color r depth) (cond @@ -179,38 +185,36 @@ (c:add (c:mul-scalar c:white (- 1.0d0 alpha)) (c:mul-scalar (c:make-color 0.5d0 0.7d0 1.0d0) alpha))))))) - - (declare pixel-center (UFix * UFix -> v::Vec3)) - (define (pixel-center i j) - (v:vec-add PIXEL-00-LOC - (v:vec-add (v:vec-mul-scalar PIXEL-DELTA-U (unwrap-as F64 i)) - (v:vec-mul-scalar PIXEL-DELTA-V (unwrap-as F64 j))))) - - (declare generate-pixel (UFix * UFix -> c:Color)) - (define (generate-pixel x y) - (for ((sample 0 (1+ sample)) - (pixel-color c:black - (c:add pixel-color (ray-color (get-ray x y) MAX_DEPTH)))) - :returns (c:mul-scalar pixel-color PIXEL-SAMPLES-SCALE) - :repeat SAMPLES-PER-PIXEL)) + (inline) + (declare generate-pixel ((la:LispArray U8) * UFix * UFix -> Unit)) + (define (generate-pixel buffer x y) + (let offset = (* 3 (+ x (* y IMAGE-WIDTH)))) + (let pixel = (for ((sample 0 (1+ sample)) + (pixel-color c:black + (c:add pixel-color (ray-color (get-ray x y) MAX_DEPTH)))) + :returns (c:mul-scalar pixel-color PIXEL-SAMPLES-SCALE) + :repeat SAMPLES-PER-PIXEL)) + (let (values r g b) = (c:gamma-correct pixel)) + (la:set! buffer offset r) + (la:set! buffer (+ 1 offset) g) + (la:set! buffer (+ 2 offset) b) + Unit) (declare sync-main (Void -> Void)) (define (sync-main) - (let image-buffer = (la:make (* IMAGE-HEIGHT IMAGE-WIDTH) (c:make-color 1.0d0 0.0d0 0.0d0))) + (let image-buffer = (la:make (* (* IMAGE-HEIGHT IMAGE-WIDTH) 3) 0)) (for* ((y 0 (1+ y))) :repeat IMAGE-HEIGHT (print (<> "Scanlines remaining: " (into (- IMAGE-HEIGHT y)))) (for* ((x 0 (1+ x))) :repeat IMAGE-WIDTH - (let color = (generate-pixel x y)) - (let offset = (+ x (* y IMAGE-WIDTH))) - (la:set! image-buffer offset color))) + (generate-pixel image-buffer x y))) (ppm:save-image image-buffer IMAGE-WIDTH IMAGE-HEIGHT COLORS)) (declare threaded-main (Void -> Void)) (define (threaded-main) - (let image-buffer = (la:make (* IMAGE-HEIGHT IMAGE-WIDTH) (c:make-color 1.0d0 0.0d0 0.0d0))) + (let image-buffer = (la:make (* (* IMAGE-HEIGHT IMAGE-WIDTH) 3) 0)) (run-io! (do ;; Setup the worker pool @@ -219,14 +223,12 @@ ;; Send off the work (do-loop-times (y IMAGE-HEIGHT) (io/term:write-line (<> "Scanlines remaining: " (into (- IMAGE-HEIGHT y)))) - (do-submit-job_ pool - (wrap-io - (coalton/experimental/loops:dotimes + (do-submit-job_ pool + (wrap-io + (coalton/experimental/loops:dotimes (x IMAGE-WIDTH) - (let color = (generate-pixel x y)) - (let offset = (+ x (* y IMAGE-WIDTH))) - (la:set! image-buffer offset color)) - Unit))) + (generate-pixel image-buffer x y)) + Unit))) ;; Wait for finish, then cleanup (request-shutdown pool) (await pool))) diff --git a/src/material.ct b/src/material.ct index 10800aa..88e559e 100644 --- a/src/material.ct +++ b/src/material.ct @@ -61,7 +61,10 @@ "Ye olde Schlick approximation for reflectance" (let r0 = (/ (- 1.0d0 refraction-index) (+ 1.0d0 refraction-index))) (let r0-sq = (* r0 r0)) - (+ r0-sq (* (- 1.0d0 r0-sq) (^ (- 1.0d0 cosine) 5)))) + (let sub-cos = (- 1.0d0 cosine)) + (+ r0-sq (* (- 1.0d0 r0-sq) + ; wow obnoxious!! can't use (^ sub-cos 5) because generic math?? + (* (* (* (* sub-cos sub-cos) sub-cos) sub-cos) sub-cos)))) (inline) (declare scatter (r:Ray * v::Vec3 * v::Vec3 * Boolean * Material -> Optional r:Ray * c:Color)) diff --git a/src/ppm.ct b/src/ppm.ct index f8ed4cb..c1c2123 100644 --- a/src/ppm.ct +++ b/src/ppm.ct @@ -12,30 +12,21 @@ (coalton-toplevel (inline) - (declare linear-to-gamma (F64 -> F64)) - (define (linear-to-gamma linear-comp) - "Convert from linear color space to gamma-corrected" - (if (> 0 linear-comp) - 0 - (math:sqrt linear-comp)))) - -(coalton-toplevel - (declare write-pixel (file:FileStream Char * c:Color -> Void)) - (define (write-pixel stream color) - (let rbyte = (floor (* 255.999d0 (linear-to-gamma (c:get-r color))))) - (let gbyte = (floor (* 255.999d0 (linear-to-gamma (c:get-g color))))) - (let bbyte = (floor (* 255.999d0 (linear-to-gamma (c:get-b color))))) - (lisp (-> Void) (stream rbyte gbyte bbyte) - (cl:format stream "~D ~D ~D~%" rbyte gbyte bbyte) + (declare write-pixel (file:FileStream Char * U8 * U8 * U8 -> Void)) + (define (write-pixel stream r g b) + (lisp (-> Void) (stream r g b) + (cl:format stream "~D ~D ~D~%" r g b) (cl:values)))) (coalton-toplevel - (declare write-pixels ((la:LispArray c:Color) * file:FileStream Char -> Void)) + (declare write-pixels ((la:LispArray U8) * file:FileStream Char -> Void)) (define (write-pixels buffer stream) - (for* ((i 0 (1+ i))) + (for* ((i 0 (+ 3 i))) :repeat (la:length buffer) - (let color = (la:aref buffer i)) - (write-pixel stream color)))) + (let r = (la:aref buffer i)) + (let g = (la:aref buffer (+ 1 i))) + (let b = (la:aref buffer (+ 2 i))) + (write-pixel stream r g b)))) (coalton-toplevel (declare write-header (UFix * UFix * UFix * file:FileStream Char -> Void)) @@ -45,7 +36,7 @@ (cl:values)))) (coalton-toplevel - (declare save-image ((la:LispArray c:Color) * UFix * UFix * UFix -> Void)) + (declare save-image ((la:LispArray U8) * UFix * UFix * UFix -> Void)) (define (save-image buffer width height colors) (let result = (file:with-open-file "out.ppm" (fn (stream) diff --git a/src/sphere.ct b/src/sphere.ct index 97d0b79..426e5dc 100644 --- a/src/sphere.ct +++ b/src/sphere.ct @@ -22,8 +22,8 @@ (let oc = (v:vec-sub center origin)) (let a = (v:vec-length-squared direction)) (let h = (v:vec-dot direction oc)) - (let c = (- (v:vec-length-squared oc) (^ radius 2))) - (let discriminant = (- (^ h 2) (* a c))) + (let c = (- (v:vec-length-squared oc) (* radius radius))) + (let discriminant = (- (* h h) (* a c))) (cond ((< discriminant 0) None) (True (let sqrtd = (sqrt discriminant))