Something went wrong. Try again.
A ray tracer in Coalton
Something went wrong. Try again.
12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061(cl:defpackage #:ray/ppm (:use #:coalton #:coalton-prelude) (:local-nicknames (#:file #:coalton/file) (#:c #:ray/color) (#:math #:coalton/math) (#:la #:coalton/lisparray)) (:export #:save-image))
(cl:in-package #:ray/ppm)
(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0) (cl:debug 0)))
(coalton-toplevel (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)))
(declare write-pixel (file:FileStream Char * c:Color -> Void)) (define (write-pixel stream (c:Color r g b)) (let rbyte = (floor (* 255.999d0 (linear-to-gamma r)))) (let gbyte = (floor (* 255.999d0 (linear-to-gamma g)))) (let bbyte = (floor (* 255.999d0 (linear-to-gamma b)))) (lisp (-> Void) (stream rbyte gbyte bbyte) (cl:format stream "~D ~D ~D~%" rbyte gbyte bbyte) (cl:values)))
(declare write-pixels ((la:LispArray c:Color) * file:FileStream Char -> Void)) (define (write-pixels buffer stream) (for* ((i 0 (1+ i))) :repeat (la:length buffer) (let color = (la:aref buffer i)) (write-pixel stream color))) (declare write-header (UFix * UFix * UFix * file:FileStream Char -> Void)) (define (write-header width height colors stream) (lisp (-> Void) (width height colors stream) (cl:format stream "P3~%~D ~D~%~D~%" width height colors) (cl:values))) (declare save-image ((la:LispArray c:Color) * UFix * UFix * UFix -> Void)) (define (save-image buffer width height colors) (let result = (file:with-open-file "out.ppm" (fn (stream) (write-header width height colors stream) (write-pixels buffer stream) (Ok 0)) :direction file::Output :if-exists file::Supersede)) (match result ((Ok _) (print "Wrote file!")) ((Err errored) (match errored ((file:FileError str) (print "File error: ") (print str)) (_None (print "Unknown error occurred"))))))
)