;;; Scheme Recursive Art Contest Entry ;;; ;;; Please do not include your name or personal info in this file. ;;; ;;; Title: ;;; ;;; Description: ;;; (define (cadr x) (car (cdr x))) (define (caddr x) (cadr (cdr x))) (define (cadddr x) (caddr (cdr x))) (define (max a b) (if (> a b) a b)) (define (min a b) (if (< a b) a b)) (define (dot a b) (+ (* (car a) (car b)) (* (cadr a) (cadr b)) (* (caddr a) (caddr b)))) (define (scale a k) (list (* (car a) k) (* (cadr a) k) (* (caddr a) k))) (define (norm a) (define mag (sqrt (dot a a))) (scale a (/ 1 mag)) ) (define (tuple-dec expr) (begin (define x (scale expr (/ 1 255))) (rgb (car x) (cadr x) (caddr x)) )) (define (sub a b) (list (- (car a) (car b)) (- (cadr a) (cadr b)) (- (caddr a) (caddr b)))) (define-macro (for var lst code) (list 'let '() (list 'define (list 'comp var) code) '(define (run lst) (if (not (null? lst)) (begin (comp (car lst)) (run (cdr lst))) ) ) (list 'run lst) ) ) (define (range minn maxx) (define (iter minn maxx tot) (if (< maxx minn) tot (iter minn (- maxx 1) (cons maxx tot)) ) ) (iter minn maxx nil)) (define (between x minn maxx) (if (< x minn) false (begin (if (> x maxx) false true))) ) ;;; vars (define camera '(0 1 0)) (define light '(1 1 0)) (define black '(0 0 0)) (define amb 0.5) (define s1 '(1 (0 1 3) (255 255 1))) (define (render height sphere) (begin (define psize 1) (define size (min (/ height psize) (/ height psize))) (for x (range 0 size) (for y (range 0 size) (cond ((between x (/ size 3.6) (/ size 2.2)) (begin (pixelsize psize) (pixel x y "black"))) ((between y (/ size 2.8) (/ size 2.4)) (begin (pixelsize psize) (pixel x y "black"))) (else (begin (define ss (- (/ x size) 0.5)) (define ss2 (- (/ y size) 0.5)) (define expr (list ss ss2 1)) (define direction (norm expr)) (define color (scale (trace_ray camera direction sphere) 0.95)) (pixelsize psize) (pixel x y (tuple-dec color)) ))) ) ))) (define (trace_ray source direction sphere) (define distance (inter source direction sphere)) (if (null? distance) black (begin (define x 0.99996) (define y 0.99996) (define z 1.00007) (cond ((< (caddr (caddr sphere)) 230) (define y 0.999993)) ((< (car (caddr sphere)) 150) (define y 1.000007)) ) (set-cdr! (cdr sphere) (cons `(,(min 255 (* (car (caddr sphere)) x)) ,(min 255 (* (cadr (caddr sphere)) y)) ,(min 255 (* (caddr (caddr sphere)) z))) nil)) (define center (cadr sphere)) (define color (caddr sphere)) (print color) (define surface (sub source (scale (scale direction distance) -1))) ;; so I don't have to write an add procedure : ) (ill surface center color) )) ) (define (ill surface center color) (begin (define sur (norm (sub surface center))) (define lt (norm (sub light surface))) (define intensity (max amb (dot sur lt))) (scale color intensity) )) (define (inter source direction sphere) (begin (define r (car sphere)) (define center (cadr sphere)) (define a (sub source center)) (define b (* -1 (dot a direction))) (define y (+ (- (* b b) (dot a a)) (* r r))) (cond ((<= y 0) nil) (else (cond((> (- b (sqrt y)) 0) (- b (sqrt y))) ((> (+ b (sqrt y)) 0) (+ b (sqrt y))) (else nil) )) ) ) ) ; Siers (define (draw) (begin (bgcolor "#000000") (render (screen_height) s1) (exitonclick) )) ; Please leave this last line alone. You may add additional procedures above ; this line. (draw)