Something went wrong. Try again.
A ray tracer in Coalton
Something went wrong. Try again.
1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374(cl:defpackage #:ray/color (:use #:coalton #:coalton-prelude) (:local-nicknames (#:simd #:sb-simd-avx2)) (:export #:Color #:make-color #:get-r #:get-g #:get-b #:gamma-correct #:black #:white #:mul #:mul-scalar #:add))
(cl:in-package #:ray/color)
(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0) (cl:debug 0)))
(coalton-toplevel (repr :native (sb-simd-avx:f64.4)) (define-type Color) (inline) (declare make-color (F64 * F64 * F64 -> Color)) (define (make-color r g b) (lisp (-> Color) (r g b) (simd:make-f64.4 r g b 0.0d0))) (inline) (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 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) (define black (make-color 0.0d0 0.0d0 0.0d0)) (inline) (declare white Color) (define white (make-color 1.0d0 1.0d0 1.0d0)) (inline) (declare mul (Color * Color -> Color)) (define (mul c1 c2) "Multiply two colors together" (lisp (-> Color) (c1 c2) (simd:f64.4* c1 c2)))
(inline) (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 v))) (inline) (declare add (Color * Color -> Color)) (define (add c1 c2) (lisp (-> Color) (c1 c2) (simd:f64.4+ c1 c2))))