Advertisement
Guest User

Untitled

a guest
Feb 20th, 2013
157
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Lisp 5.07 KB | None | 0 0
  1. #lang racket/gui
  2. (require racket/flonum)
  3. (require racket/future)
  4.  
  5. ;; basic structs -------------------------------------------
  6. (struct pixel (r g b))
  7. (struct vec (x y z))
  8. (struct ray (from dir))
  9. (struct int-res (int? t p))
  10. (struct sphere3D (center radius col))
  11. (struct point (col norm mat))
  12. (struct color (r g b a))
  13.  
  14. ;; helper funcs --------------------------------------------
  15. (define (format-vec v)
  16.   (format "(~a, ~a, ~a)" (vec-x v) (vec-y v) (vec-z v)))
  17.  
  18. (define (print-sphere3D s)
  19.   (printf "sphere3D: (center: ~a, R: ~a)\n " (format-vec (sphere3D-center s))
  20.           (sphere3D-radius s)))
  21.  
  22. (define (format-point p)
  23.   (format "(color: ~a, norm: ~a, material: ~a)"
  24.           (point-col p)
  25.           (point-norm p)
  26.           (point-mat p)))
  27.  
  28. (define (print-int-res ir)
  29.   (printf "intersection: (~a, dis: ~a, point: ~a)\n"
  30.           (int-res-int? ir)
  31.           (int-res-t ir)
  32.           (format-point (int-res-p ir))))
  33.  
  34.  
  35. ;; basic constatns -----------------------------------------
  36. (define cam-direction (vec 0.0 0.0 1.0))
  37. (define screen-width  640)
  38. (define screen-height 480)
  39.  
  40. ;; (define col-red (color 255 0 0 0))
  41. ;; (define col-navy (color 0 155  120 0))
  42. ;; (define col-green (color 0 255  0 0))
  43. ;; (define col-blue (color 0 100 200 0))
  44. ;; (define col-black (color 0 0 0 0))
  45.  
  46. (define col-red (make-object color% 255 0 0 0))
  47. (define col-navy (make-object color% 0 155  120 0))
  48. (define col-green (make-object color% 0 255  0 0))
  49. (define col-blue (make-object color% 0 100 200 0))
  50. (define col-black (make-object color% 0 0 0 0))
  51.  
  52. (define sph-list
  53.   (list (sphere3D (vec 100.0 100.0 0.0) 130.0 col-red)
  54.         (sphere3D (vec 200.0 150.0 22.0) 120.0 col-blue)
  55.         (sphere3D (vec 500.0 300.0 0.0) 49.0 col-navy)))
  56.  
  57.  
  58. ;; vector stuff --------------------------------------------
  59. (define (scalar-mult v1 v2)
  60.   (fl+ (fl* (vec-x v2) (vec-x v1) )
  61.        (fl+   (fl* (vec-y v2) (vec-y v1) )
  62.           (fl* (vec-z v2) (vec-z v1) ))))
  63.  
  64. (define (sqr-norm v)
  65.   (scalar-mult v v))
  66.  
  67. (define (vec-length v)
  68.   (flsqrt (sqr-norm v)))
  69.  
  70. (define (normalize-vec v)
  71.   (let* ([x (vec-x v)]  [y (vec-y v)] [z (vec-z v)]
  72.                            [len (vec-length v)])
  73.     (vec (fl/ x len) (fl/ y len) (fl/ z len))))
  74.  
  75. (define (subtract-vec v2 v1)
  76.   (vec (fl- (vec-x v2) (vec-x v1) )
  77.        (fl- (vec-y v2) (vec-y v1) )
  78.        (fl- (vec-z v2) (vec-z v1) )))
  79.  
  80. (define (get-closer-res i1 i2)
  81.   (if (and (fl> (int-res-t i1) (int-res-t i2))
  82.            (int-res-int? i2))
  83.       i2
  84.       i1))
  85.  
  86. ;; sphere3D intersection
  87. (define (screen-ray x y)
  88.   (ray (vec (->fl x) (->fl y) -1000.0) cam-direction))
  89.  
  90. (define null-point
  91.   (point col-black 0 0))
  92.  
  93. (define (hit-sphere3D r s)
  94.   (let* ([dist-vector (subtract-vec (sphere3D-center s) (ray-from r))]
  95.          [B (scalar-mult dist-vector (ray-dir r))]
  96.          [D (fl+ (fl* B B) (fl+ (fl- 0.0 (sqr-norm dist-vector)) (flexpt (sphere3D-radius s) 2.0)))])
  97.     (if (fl> D 0.0)
  98.         (let ([t0 (fl- B (sqrt D))]
  99.               [t1 (fl+ B (sqrt D))])
  100.           (if (and (fl> t0 0.1)
  101.                    (fl< t0 t1))
  102.               (int-res #t t0 (point (sphere3D-col s) 0.0 0.0))
  103.               (int-res #t t1 (point (sphere3D-col s) 0.0 0.0))))
  104.         (int-res #f 0.0 null-point))))
  105.  
  106.  
  107. (define (ray-cast x y object-list)
  108.   (let ([view-ray (screen-ray x y)])
  109.     (for/fold ([closest-int (int-res #f 10000.0 null-point)])
  110.       ([obj object-list])
  111.       (get-closer-res closest-int
  112.                       (hit-sphere3D view-ray obj)))))
  113.  
  114. (define (render-scene object-list dc bmp)
  115.   (let* ([f (future
  116.        (lambda ()  
  117.          (for* ([x (in-range (/ screen-width 2))]
  118.             [y (in-range screen-height)])
  119.            (let* ([ray-res (ray-cast x y object-list)]
  120.               [pix-col (point-col (int-res-p ray-res))])
  121.          (send bmp set-pixel x y pix-col)))
  122.          ))])
  123.  
  124.     (for* ([x (in-range (/ screen-width 2) screen-width)]
  125.        [y (in-range screen-height)])
  126.       (let* ([ray-res (ray-cast x y object-list)]
  127.          [pix-col (point-col (int-res-p ray-res))])
  128.     (send bmp set-pixel x y pix-col)))
  129.     (touch f)))
  130.  
  131. (define (render-scene-dummy object-list)
  132.   (let* ([f (future
  133.        (lambda ()  
  134.          (for* ([x (/ screen-width 2)]
  135.             [y screen-height])
  136.            (let* ([ray-res (ray-cast x y object-list)]
  137.               [pix-col (point-col (int-res-p ray-res))])
  138.          #t))
  139.          ))])
  140.  
  141.     (for* ([x (in-range (/ screen-width 2) screen-width)]
  142.        [y screen-height])
  143.       (let* ([ray-res (ray-cast x y object-list)]
  144.          [pix-col (point-col (int-res-p ray-res))])
  145.     #t))
  146.     (touch f))
  147. )
  148.  
  149. (define (make-scene-bitmap w h)
  150.   (new bitmap-dc% [bitmap (make-object bitmap% w h)])
  151. )
  152.  
  153. (define (run-no-render)
  154.   (render-scene-dummy sph-list))
  155.  
  156. (require racket/gui)
  157.  
  158. (define (run-tracer)
  159.   (let* ([frame (new frame% [label "racket ray tracer"]
  160.              [width screen-width]
  161.              [height screen-height])]
  162.      [canvas (new canvas% [parent frame])]
  163.      [dc (send canvas get-dc)]
  164.      [bmp (make-scene-bitmap screen-width screen-height)])
  165. ; Show the frame
  166.     (send frame show #t)
  167. ; Wait a second to let the window get ready
  168.     (sleep/yield 1)
  169. ; Draw the scene
  170.     (printf "rendering scene...")
  171.     (time
  172.      (render-scene sph-list dc bmp))
  173.     (send dc draw-bitmap (send bmp get-bitmap) 0 0)
  174.     frame))
  175.  
  176. ;; (run-tracer)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement