#lang racket/base

;;; This benchmark is a copy of the version from Grift
;;; Original source: https://github.com/Gradual-Typing/benchmarks

;;; RAY -- Ray-trace a simple scene with spheres.
;;; Translated to Scheme from Paul Graham's book ANSI Common Lisp, Example 9.8
;;; And then translated to Racket by Deyaaeldeen Almahallawi

;;; Here we use racket/flonum but not racket/fixnum
;;; Use of generic numeric ops is disadvantage for racket
;;; but there is no safe version of fixnum ops that provides
;;; non-contracted ops and we are trying to compare safe code. 
;;; These safe operations are generally no faster than using
;;; generic primitives like +. (According to the documentation)
;;; -andre

(require racket/flonum)

(define (make-point x y z)
  (vector x y z))

(define (point-x p) (vector-ref p 0))
(define (point-y p) (vector-ref p 1))
(define (point-z p) (vector-ref p 2))

(define (sq x) (fl* x x))

(define (mag x y z) 
  (flsqrt (fl+ (sq x) (fl+ (sq y) (sq z)))))

(define (unit-vector x y z) 
  (let ([d  (mag x y z)])
    (make-point (fl/ x d) (fl/ y d) (fl/ z d))))

(define (distance p1 p2) 
  (mag (fl- (point-x p1) (point-x p2))
       (fl- (point-y p1) (point-y p2))
       (fl- (point-z p1) (point-z p2))))

(define *world* (make-vector 33 (vector 0.0 0.0 (vector 0.0 0.0 0.0))))

(define eye (make-point 0.0 0.0 200.0))

(define (tracer res)
  (let ([extent (* res 100)])
    (do ((y 0 (+ y 1)))
        ((= y extent))
      (do ((x 0 (+ x 1)))
          ((= x extent))
        (let ([color (color-at
                (fl+ -50.0
                      (fl/ (exact->inexact x) (exact->inexact res)))
                (fl+ -50.0
                      (fl/ (exact->inexact y) (exact->inexact res))))])
              (if (and (= x (- extent 1)) (= y (- extent 1)))
                (begin
                  (write color)
                  (newline))
                (void)))))))

(define (color-at x y)
  (let ([ray (unit-vector (fl- x (point-x eye))
                          (fl- y (point-y eye))
                          (fl* -1.0 (point-z eye)))])
    (inexact->exact (flround (fl* (sendray eye ray) 255.0)))))

(define (sendray pt ray)
  (let ([x (loop pt ray 0
                  (vector-length *world*)
                  *world*
                  #f
                  #f
                  1e308)])
    (let ([s (vector-ref x 0)]
          [int (vector-ref x 1)])
      (if s
          (fl* (lambert s int ray)
                (sphere-color s))
          0.0))))

(define (loop pt ray index lst-len lst surface hit dist)
  (if (= index lst-len)
      (vector surface hit)
      (let ([s (vector-ref lst index)])
        (let ([xr  (point-x ray)]
              [yr  (point-y ray)]
              [zr  (point-z ray)]
              [sc  (sphere-center s)])
          (let ([a  (fl+ (sq xr) (fl+ (sq yr) (sq zr)))]
                [b  (fl* 2.0
                          (fl+ (fl* (fl- (point-x pt) (point-x sc)) xr)
                              (fl+ (fl* (fl- (point-y pt) (point-y sc)) yr)
                                    (fl* (fl- (point-z pt) (point-z sc)) zr))))]
                [c  (fl+ (fl+ (sq (fl- (point-x pt) (point-x sc)))
                              (sq (fl- (point-y pt) (point-y sc))))
                          (fl+ (sq (fl- (point-z pt) (point-z sc)))
                              (fl* -1.0 (sq (sphere-radius s)))))])
            (if (zero? a)
                (let ([n  (fl/ (fl* -1.0 c) b)])
                  (let ([h (make-point (fl+ (point-x pt) (fl* n xr))
                                        (fl+ (point-y pt) (fl* n yr))
                                        (fl+ (point-z pt) (fl* n zr)))])
                    (let ([d (distance h pt)])
                      (if (fl< d dist)
                          (loop pt ray (+ index 1) lst-len lst s h d)
                          (loop pt ray (+ index 1) lst-len lst surface hit dist)))))
                (let ([disc (fl- (sq b) (fl* 4.0 (fl* a c)))])
                  (if (negative? disc)
                      (loop pt ray (+ index 1) lst-len lst surface hit dist)
                      (let ([discrt  (flsqrt disc)]
                            (minus-b  (fl* -1.0 b))
                            (two-a  (fl* 2.0 a)))
                        (let ([n (flmin (fl/ (fl+ minus-b discrt) two-a)
                                        (fl/ (fl- minus-b discrt) two-a))])
                          (let ([h (make-point (fl+ (point-x pt) (fl* n xr))
                                                (fl+ (point-y pt) (fl* n yr))
                                                (fl+ (point-z pt) (fl* n zr)))])
                            (let ([d (distance h pt)])
                              (if (fl< d dist)
                                  (loop pt ray (+ index 1) lst-len lst s h d)
                                  (loop pt ray (+ index 1) lst-len lst surface hit dist))))))))))))))


(define (lambert s int ray)
  (let ([n (sphere-normal s int)])
    (flmax 0.0
            (fl+ (fl* (point-x ray) (point-x n))
                (fl+ (fl* (point-y ray) (point-y n))
                      (fl* (point-z ray) (point-z n)))))))

(define (make-sphere color radius center) 
  (vector color radius center))

(define (sphere-color s) 
  (vector-ref s 0))
(define (sphere-radius s) 
  (vector-ref s 1))
(define (sphere-center s) 
  (vector-ref s 2))

(define (defsphere i x y z r c) 
  (let ([s (make-sphere c r (make-point x y z))])
    (begin
      (vector-set! *world* i s)
      s)))

(define (sphere-normal s pt) 
  (let ([c (sphere-center s)])
    (unit-vector (fl- (point-x c) (point-x pt))
                  (fl- (point-y c) (point-y pt))
                  (fl- (point-z c) (point-z pt)))))
(define (main)
  (begin
    (let ([res (read)])
      (defsphere 32 0.0 -300.0 -1200.0 200.0 0.8)
      (defsphere 31 -80.0 -150.0 -1200.0 200.0 0.7)
      (defsphere 30 70.0 -100.0 -1200.0 200.0 0.9)
      (let ([counter (box 29)])
        (begin
          (do ((x -2 (+ x 1)))
              ((> x 2))
            (do ((z 2 (+ z 1)))
                ((> z 7))
              (defsphere
                (unbox counter)
                (fl* (exact->inexact x) 200.0)
                300.0
                (fl* (exact->inexact z) -400.0)
                40.0
                0.75)
              (set-box! counter (- (unbox counter) 1))))))
      (tracer res))))

(time (main))
