#lang racket (require gigls/unsafe) (define Sam-destroys-the-universe! (lambda (n width height) (letrec ([background ; Builds a procedure for a background of the given width and height for our image series. (lambda (n width height) (image-compute ; If the given n value is even a horizonatally and vertically striped background is created. (lambda (col row) (rgb-new 60 (* 120 (+ 1 (sin (* pi (/ 2 width) col)))) (* 60 (+ 1 (tan (* pi (/ 2 height) row)))))) width height))] [world (image-show (background n width height))] ; The background procedure is called to create a new image. [t (turtle-new world)] ; The previously created image becomes the world for a new turtle. [single-star-create! ; Builds a procedure to use the given n, width, height and new turtle. (lambda (turtle n width height) (let* ([color1 (color-name->rgb (list-ref (context-list-colors) (modulo n 147)))] [color2 (color-name->rgb (list-ref (context-list-colors) (modulo (* 2 n) 147)))] [color3 (color-name->rgb (list-ref (context-list-colors) (modulo (* 3 n) 147)))] [color4 (color-name->rgb (list-ref (context-list-colors) (modulo (* 4 n) 147)))] ; Four distinct colors are chosen from the total context list of colors depending on n. ; Then the procedure for one point of the star is created, which uses the turtle and n with different portions ; colored the four different colors. [build-point (lambda (turtle n c1 c2 c3 c4) (turtle-set-color! turtle c1) (turtle-down! turtle) (turtle-forward! turtle (round (* n .5))) (turtle-set-color! turtle c2) (turtle-forward! turtle (round (* n .5))) (turtle-turn! turtle 414) (turtle-set-color! turtle c3) (turtle-turn! turtle 144) (turtle-forward! turtle (round (* n .8))) (turtle-set-color! turtle c4) (turtle-forward! turtle (round (* n .5))) (turtle-turn! turtle 324) (turtle-forward! turtle (round (* n .25))) (turtle-set-color! turtle c1))]) (turtle-teleport! turtle width height) ; The turtle is moved to a point specified by the width and height. (if (< n 400) (repeat 9 build-point turtle n color1 color2 color3 color4) ; If the n value is below 400, then an eight pointed star is created. (repeat 20 build-point turtle n color1 color2 color3 color4))))] ; If the n value is above 400, then a nineteen pointed star is created. [multiple-stars! ; Builds multiple copies of our single star of varying sizes and positions. (lambda (turtle n width height) (let ([new-star (single-star-create! turtle n width height)]) ; Creates of a single star with a given n, width and height. (if (> n 0) (cond ; If n is positive then stars are created. [(> n 900) new-star (multiple-stars! turtle (round (- n 500)) width height)] ; If n is above 900, then one star is created in the lower right corner of the image and ; another star with a decreased n value is recursively called. [(> n 800) new-star (multiple-stars! turtle (round (- n 500)) (round (/ (image-width (turtle-world turtle)) 10)) (round (/ (image-height (turtle-world turtle)) 4)))] ; If n is above 800 and above each increment of one hundred above zero, then another star is recursively created with ; a decreased n value and newly specified width and height values determining its size and position, until n is negative ; at which point, the procedure stops. [(> n 700) new-star (multiple-stars! turtle (round (- n 400)) (round (/ (image-width (turtle-world turtle)) 10)) (image-height (turtle-world turtle)))] [(> n 600) new-star (multiple-stars! turtle (round (- n 400)) (round (/ (image-width (turtle-world turtle)) 4)) (round (* (image-height (turtle-world turtle)) .75)))] [(> n 500) new-star (multiple-stars! turtle (round (- n 300)) (round (/ (image-width (turtle-world turtle)) 2)) 0)] [(> n 400) new-star (multiple-stars! turtle (round (- n 200)) (round (* (image-width (turtle-world turtle)) .8)) (round (/ (image-height (turtle-world turtle)) 4)))] [(> n 300) new-star (multiple-stars! turtle (round (- n 200)) (round (/ (image-width (turtle-world turtle)) 3)) (round (/ (image-height (turtle-world turtle)) 3)))] [(> n 200) new-star (multiple-stars! turtle (round (- n 100)) (round (* (image-width (turtle-world turtle)) .6)) (round (/ (image-height (turtle-world turtle)) 2)))] [(> n 100) new-star (multiple-stars! turtle (round (- n 100)) (round (* (image-width (turtle-world turtle)) .95)) (round (* (image-height (turtle-world turtle)) .95)))] [(> n 0) new-star]) (display "Done :)"))))]) ; Just to be nice, when the procedure is done, a happy message is displayed. (multiple-stars! t n width height) (context-set-brush! "Sparks") (image-draw-line! world 0 (round (* height .75)) (round (* width .5)) height)))) ; ; After the previous procedures are defined by the letrec, they are called via ; ; the multiple-stars! procedure. ; (context-set-fgcolor! 0) ; ; The we create an overlaying frame for the image by first ; ; setting the frame color to black ; (image-show ; (drawing->image ; (drawing-group (drawing-vscale ; (drawing-hscale drawing-unit-square ; width) ; (round (* height .02))) ; Top edge ; (drawing-vshift ; (drawing-vscale ; (drawing-hscale drawing-unit-square ; width) ; (round (* height .02))) ; (round (* height .96))) ; Bottom edge ; (drawing-vscale ; (drawing-hscale drawing-unit-square ; (round (* height .02))) ; height) ; Left edge ; (drawing-vshift ; (drawing-vscale ; (drawing-hscale drawing-unit-square ; (round (* width .02))) ; height) ; (round (* height .96))) ; Right edge ; )))