;tiny raytracer for lispme interpreter
;by micah taylor

(define (trace)
 (setup)
 (start 0 0) #n)

(define (setup)
 (begin
  (set! resx2 (/ resx 2))
  (set! resy2 (/ resy 2))
  (set! light (norm light))))

;test code for debugging
(define (test x y)
 (setup)
 (if (< y resy)
  (if (= x resx)
   (test 0 (+ y 1))
   (cons
    (shade (sphr-norm
     (intersect (proj x y) spheres 0 0 100)))
    (test (+ x 1) y)))))

;main pixel loop
(define (start x y)
 (if (< y resy)
  (if (= x resx)
   (start 0 (+ y 1))
   (begin
    (write-pixel x y
     (shade (sphr-norm (intersect
      (proj x y) spheres 0 0 100))))
    (start (+ x 1) y)))))

(define (proj x y)
 (norm (vector
  (/ (- x resx2) resx2)
  (/ (- y resy2) resy2)
  1)))

;sphere intersect test 1
(define (sphere-dis v s)
 (let* (
   (b (* -2 (dp v s)))
   (c (- (dp s s) (vr s 3)))
   (d (dscrm b c)))
  (if (positive? d)
   (sphr-dis b c d)
         inf)))

;sphere intersect test 2
(define (sphr-dis b c d)
 (let
   ((t0 (/ (- (- 0 b) (sqrt d)) 2))
   (t1 (/ (+ (- 0 b) (sqrt d)) 2)))
  (if (and (< t0 0) (< t1 0))
   inf
   (if (< t0 t1) t0 t1))))

;descriminent
(define (dscrm b c)
 (- (* b b) (* 4 c)))

;main intersect loop
(define
 (intersect v o n c d)
 (if (eq? c (vl o))
  (if (eq? d inf)
   (vector 0 n v)
   (vector d n v))
  (let
   ((newd (sphere-dis v (vr o c))))
   (if (< d newd)
    (intersect v o n (+ 1 c) d)
    (intersect v o c (+ c 1) newd)))))

;sphere normal
(define (sphr-norm d)
 (if (eq? 0 (vr0 d))
  (vector 0 0 0)
  (let (
    (p (vmul (vr2 d) (vr0 d)))
    (o (vr spheres (vr1 d))))
   (norm (vsub p o)))))

;diffuse shading
(define (shade n)
 (- (dp n light)))

(define (dither c)
 (if (> (* c 70) (random 100)) 1 0))

(define (write-pixel x y c)
 (move x y)
 (let ((newc (dither c)))
  (set-fg newc)
      (set-bg newc)
  (draw x y)))

;normalize vector
(define (norm v)
 (let
  ((len (vlength v)))
  (vector
   (/ (vr0 v) len)
   (/ (vr1 v) len)
   (/ (vr2 v) len))))

;subtract vectors
(define (vsub a b)
 (vector
  (- (vr0 a) (vr0 b))
  (- (vr1 a) (vr1 b))
  (- (vr2 a) (vr2 b))))

;scalar multiply vector
(define (vmul v s)
 (vector
  (* s (vr0 v))
  (* s (vr1 v))
  (* s (vr2 v))))

;dot product
(define (dp a b)
 (+ (* (vr0 a) (vr0 b))
    (* (vr1 a) (vr1 b))
    (* (vr2 a) (vr2 b))))

;vector length
(define (vlength v)
 (sqrt (+
  (expt (vr0 v) 2)
  (expt (vr1 v) 2)
  (expt (vr2 v) 2))))

;shortcuts
(define (vr0 v)
 (vector-ref v 0))
(define (vr1 v)
 (vector-ref v 1))
(define (vr2 v)
 (vector-ref v 2))
(define (vr v n)
 (vector-ref v n))
(define (vl v)
 (vector-length v))

(define resx2 0);set later
(define resy2 0);set later
(define resx 50)
(define resy 50)
(define inf 100)

;incoming light vector
(define light
(vector 1 -1 1))

; spheres are x, y, z, radius
(define spheres
 (vector
  (vector 0 0 5 1)
  (vector 1 1 3 1)))