;;; File: ;;; hw11.scm ;;; Authors: ;;; Samuel A. Rebelsky (compiler, editor) ;;; Various members of CSC151 2007S (see below) ;;; Summary: ;;; A variety of interesting drawing procedures. Each procedure ;;; takes three parameters, each of which is a number between 0 ;;; and 9, inclusive. ;;; Procedures: ;;; clock ;;; cuboid ;;; draw-face ;;; draw-face-2 ;;; draw-face-3 ;;; draw-mark ;;; egg ;;; face-with-hair ;;; house-scene ;;; Procedure: ;;; hw11 ;;; Parameters: ;;; None ;;; Perpetrator: ;;; Sam Rebelsky ;;; Purpose: ;;; To make it easier to reload this file after changes (define hw11 (lambda () (load "/home/rebelsky/Web/Courses/CS151/2007S/Examples/hw11.scm"))) ;;; Procedure: ;;; clock ;;; Perpetrators: ;;; Thorson Kahn ;;; Mark Sullivan (define clock (lambda (val1 val2 val3 ) (set-bgcolor BLACK) (let ((image (create-image 1000 1000))) (let* ((brushes (list "Sparks" "Diagonal Star (17)" "Circle (09)" "Diagonal Star (25)" "Circle Fuzzy (13)" "Manju's Flower")) (colors (list AQUAMARINE CORAL DUSTY_ROSE VIOLET_RED SPICY_PINK TURQUOISE QUARTZ ROYAL_BLUE OLD_GOLD NEON_PINK)) (brush (list-ref brushes (modulo val2 5))) (color (list-ref colors val1))) (select-ellipse image REPLACE 300 300 400 400) (set-fgcolor color) (set-brush brush) (stroke image) (fill-bgcolor image) (select-nothing image) (line image 500 500 500 500) (line image 500 340 500 340) (line image 500 660 500 660) (line image 340 500 340 500) (line image 640 500 640 500) (set-fgcolor (list-ref colors val1)) (let* ((r-2-hour (* 150 150)) (x (* 15 val2)) (y (sqrt (- r-2-hour (* x x)))) (variable val3) ) (cond ((> 2.5 variable) (line image 500 500 (+ x 500) (+ y 500))) ((> 5 variable) (line image 500 500 (- 500 x) (+ y 500)) ) ((> 7.5 variable) (line image 500 500 (+ x 500) (- 500 y))) (else ((line image 500 500 (- 500 x) (- 500 y)))))) (let* ((r-2-minute (* 175 175)) (x (* 17.5 val3)) (y (sqrt (- r-2-minute (* x x)))) (variable val3)) (cond ((> 2.5 variable) (line image 500 500 (+ x 500) (+ y 500))) ((> 5 variable) (line image 500 500 (- 500 x) (+ y 500)) ) ((> 7.5 variable) (line image 500 500 (+ x 500) (- 500 y))) (else ((line image 500 500 (- 500 x) (- 500 y))))))) (show-image image)))) ;;; Procedure: ;;; cube ;;; Perpetrators: ;;; Jason Thumma ;;; Eric Thumma (define cube (let ((brushtype (lambda (a) (list-ref (list "Circle (09)" "sphere (29)" "Bird" "qbert" "qbert#1" "Gecko" "Calligraphic Brush" "Circle (03)" "Circle (07)" "Circle (05)") a))) (colortype (lambda (b) (list-ref (list BLAH_GREY BLOOD_ORANGE BRONZE_II CARDINAL_RED CORN_FLOWER_BLUE MEDIUM_TURQUOISE DARK_PURPLE MUSTARD NEON_AVOCADO NEON_PINK CERULEAN) b)))) (lambda (a b c) (let ((img (create-image 800 800))) (set-brush (brushtype a)) (set-bgcolor WHITE) (set-fgcolor (colortype b)) (let ((x (* 80 a)) (y (* 80 b)) (z (* 20 c))) (select-rectangle img REPLACE x y z z) (stroke img) (let ((x2 (/ (+ x x z) 2)) (y2 (/ (+ y y z) 2))) (line img x y (- x2 z) (- y2 z)) (line img x (+ y z) (- x2 z) y2) (line img (+ x z) y x2 (- y2 z)) (line img (+ x z) (+ y z) x2 y2) (select-rectangle img REPLACE (- x2 z) (- y2 z) z z) (stroke img) (select-nothing img) (show-image img))))))) ;;; Procedure: ;;; cuboid ;;; Perpetrator ;;; Clarence "CJ" Moore (define cuboid (lambda (val1 val2 val3) (let ((img (create-image 400 400))) (line img 0 0 (* 40 val1) 0) (line img (* 20 val3) (* 10 val3) (+ (* 40 val1) (* 20 val3)) (* 10 val3)) (line img 0 (* 40 val2) (* 40 val1) (* 40 val2)) (line img (* 20 val3) (+ (* 40 val2) (* 10 val3)) (+ (* 40 val1) (* 20 val3)) (+ (* 40 val2) (* 10 val3))) (line img 0 0 0 (* 40 val2)) (line img (* 20 val3) (* 10 val3) (* 20 val3) (+ (* 40 val2) (* 10 val3))) (line img (* 40 val1) 0 (* 40 val1) (* 40 val2)) (line img (+ (* 40 val1) (* 20 val3)) (* 10 val3) (+ (* 40 val1) (* 20 val3)) (+ (* 40 val2) (* 10 val3))) (line img 0 0 (* 20 val3) (* 10 val3)) (line img (* 40 val1) 0 (+ (* 40 val1) (* 20 val3)) (* 10 val3)) (line img 0 (* 40 val2) (* 20 val3) (+ (* 40 val2) (* 10 val3))) (line img (* 40 val1) (* 40 val2) (+ (* 40 val1) (* 20 val3)) (+ (* 40 val2) (* 10 val3))) (show-image img)))) ;;; Procedure: ;;; house-scene ;;; Perpetrator: ;;; Jayme Siegel ;;; Parameter Effects: ;;; val1 - House width ;;; val2 - Colors ;;; val3 - House height and brush size (define house-scene (lambda (val1 val2 val3) (let* (; Image Definitions (image-width 500) (image-height 500) (image (create-image image-width image-height)) (ground-level (* image-height (/ 4 5))) ; House Definitions (house-width (modulo (* 148 (+ 1 val1)) 500)) (house-height (modulo (* 50 (+ 1 val3)) (* ground-level (/ 2 3)))) (house-left (/ (- image-width house-width) 2)) ; Left Side of House (house-right (- image-width house-left)) ; Right Side of House (house-top (- ground-level house-height)) ; Top Side of House (roof-peak (- house-top (/ house-height 2))) ; Peak of Roof ; Door Definitions (door-width (/ house-width 3)) (door-height (/ house-height 2)) (door-left (/ (- image-width door-width) 2)) ; Left Side of Door (door-right (- image-width door-left)) ; Right Side of Door (door-top (- ground-level door-height)) ; Top Side of Door (knob-width (+ (/ door-width 3) door-left)) ; Horizontal Knob Position (knob-height (+ (/ door-height 2) door-top)) ; Vertical Knob Position ; Color Definitions (blues (list COBALT_BLUE CORN_FLOWER_BLUE DARK_SLATE_BLUE DEEP_MIDNIGHT_BLUE LIGHT_STEEL_BLUE MEDIUM_SLATE_BLUE MIDNIGHT_BLUE NEW_MIDNIGHT_BLUE OCEAN_BLUE PALE_BLUE)) (greens (list ALGAE_GREEN DARK_FOREST_GREEN DARK_OLIVE_GREEN FOREST_GREEN GREEN_COPPER LIGHT_AVOCADO_GREEN LIME_GREEN MEDIUM_SEA_GREEN MEDIUM_SPRING_GREEN PARROT_GREEN)) (reds (list BLOOD_ORANGE BLOOD_RED DUSTY_ROSE FIREBRICK INDIAN_RED MANDARIAN_ORANGE NOVA_SCOTIA_SALMON PYRIDIUM_ORANGE SCARLET SIENNA)) (sky-color (list-ref blues val2)) (ground-color (list-ref greens val2)) (house-color (list-ref reds val2)) ; Brush Definitions (brushes (list "Circle (01)" "Circle (03)" "Circle (05)" "Circle (07)" "Circle (09)" "Circle (11)")) (outline-brush (list-ref brushes (modulo val3 6)))) ; Color the Sky (select-rectangle image REPLACE 0 0 image-width ground-level) (set-fgcolor sky-color) (fill-fgcolor image) (select-nothing image) ; Color the Ground (select-rectangle image REPLACE 0 ground-level image-width image-height) (set-fgcolor ground-color) (fill-fgcolor image) (select-nothing image) ; Build the House (select-rectangle image REPLACE house-left house-top house-width house-height) (set-fgcolor house-color) (fill-fgcolor image) (set-fgcolor BLACK) (set-brush outline-brush) (stroke image) (select-nothing image) ; Build the Roof (line image house-left house-top (/ image-width 2) roof-peak) (line image house-right house-top (/ image-width 2) roof-peak) ; Build the Door (select-rectangle image REPLACE door-left door-top door-width door-height) (stroke image) (select-nothing image) ; Show the Drawing (blot image knob-width knob-height) (show-image image)))) ;;; Procedure: ;;; draw-face ;;; Perpetrators: ;;; Jordan Medalia ;;; Tommy Olson ;;; Parameters: ;;; val1 - contributes to face, eye, and mouth colors ;;; val2 - face height; contributes to face, eye, and mouth colors ;;; val3 - eye height; contributes to face, eye, and mouth colors (define draw-face (lambda (val1 val2 val3) (let ((image (create-image 600 600)) (width 340) (height (+ 200 (* val2 10))) (eye-height (+ 4 (* val3 2)))) (set-bgcolor WHITE) ; Draw the face shape (set-fgcolor (list (* val1 10) (* val2 25) (* val3 30))) (set-brush "Circle (05)") (select-ellipse image REPLACE 100 40 width 470) (fill-fgcolor image) ; Draw the eyes (set-fgcolor WHITE) (set-brush "Circle (19)") (set-bgcolor (list (* val1 25) (* val2 12) (* val3 20))) (select-ellipse image REPLACE 160 200 (+ 80 (/ width 50)) (+ 90 eye-height)) (fill-bgcolor image) (stroke image) (select-ellipse image REPLACE 300 200 (+ 80 (/ width 50)) (+ 90 eye-height)) (fill-bgcolor image) (stroke image) ; Draw the mouth (set-fgcolor (list (* val1 7) (* val2 5) (* val3 24))) (set-brush "Calligraphic Brush") (select-ellipse image REPLACE 208 370 100 100) (fill-fgcolor image) (set-fgcolor (list (* val1 27) (* val2 15) (* val3 4))) (stroke image) (select-nothing image) (show-image image) image))) ;;; Procedure: ;;; draw-mark ;;; Perpetrator: ;;; Cyrus Witthuas ;;; Parameters: (define draw-mark (letrec ( (draw-head (lambda (img x) (let ((face-width 120) (face-height (+ 100 (* 10 x)))) (select-ellipse img REPLACE 20 40 face-width face-height) (set-fgcolor YELLOW) (fill-fgcolor img) (set-fgcolor BLACK) (set-brush "Circle (03)") (stroke img) (select-nothing img)))) (draw-eyes (lambda (img x y) (let ((eye-height (+ 40 (/ (+ 100 (* 10 x)) 3))) (eye-color (list STEEL_BLUE CORN_FLOWER_BLUE LIGHT_AVOCADO_GREEN LIGHT_GREY HOT_PINK OCEAN_BLUE SIENNA WHITE ORCHID BROWN))) (select-ellipse img REPLACE 30 eye-height 30 30) (select-ellipse img ADD 100 eye-height 30 30) (set-fgcolor (list-ref eye-color y)) (fill-fgcolor img) (set-brush "Circle (01)") (set-fgcolor BLACK) (stroke img) (select-nothing img)))) (draw-smile (lambda (img x) (let ((mouth-height (+ 40 (* 1 (/ (+ 100 (* 10 x)) 2))))) (select-ellipse img REPLACE 50 mouth-height 60 40) (select-ellipse img SUBTRACT 50 (- mouth-height 10) 60 45) (set-fgcolor BLACK) (fill-fgcolor img) (select-nothing img)))) (draw-bowtie (lambda (img x z) (let ((bowtie-height (+ 40 (+ 100 (* 10 x)))) (bowtie-color (list BROWN TEAL SALMON ORANGE PARROT_GREEN NEON_BLUE NEON_AVOCADO BLOOD_RED VIOLET GOLD)) (bowtie-height (* 6 z))) (set-brush "Circle (03)") (set-fgcolor (list-ref bowtie-color z)) (draw-hourglass img 20 bowtie-height 20)))) (draw-hourglass (lambda (img bowtie-width bowtie-height n) (cond ((< 0 n) (line img (- 80 bowtie-width) (- bowtie-height n) (+ 80 bowtie-width) (+ bowtie-height n)) (line img (- 80 bowtie-width) (+ bowtie-height n) (+ 81 bowtie-width) (- bowtie-height n)) (draw-hourglass img bowtie-width bowtie-height (- n 1))) (else))))) (lambda (x y z) (let ((img (create-image 160 (+ 80 (+ 100 (* 10 x)))))) (draw-head img x) (draw-eyes img x y) (select-nothing img) (draw-bowtie img x z) (draw-smile img x) (show-image img))))) ;;; Procedure: ;;; draw-face-2 ;;; Perpetrators: ;;; Katherine Ingram ;;; Jesse Peterson-Brandt ;;; Nathan Greenfield ;;; Parameters: ;;; val1 - affects face height and eye color ;;; val2 - affects face width, mouth shape, and mouth color ;;; val3 - affects face color (define draw-face-2 (let ((face-colors (list BAKERS_CHOCOLATE BRONZE DARK_TAN DARK_WOOD DUSTY_ROSE INDIAN_RED MUSTARD MEDIUM_WOOD ORCHID POPCORN)) (mouth-colors (list BLACK BLOOD_RED CARDINAL_RED DARK_CHERRY_RED DARK_OLIVE_GREEN DARK_ORCHID DEEP_PURPLE FELDSPAR FIREBRICK VIOLET_RED)) (eye-colors (list ALGAE_GREEN CERULEAN DEEP_MIDNIGHT_BLUE BLAH_GREY CYAN DARK_BROWN DARK_FOREST_GREEN SILVER SIENNA SKY_BLUE)) ) (lambda (val1 val2 val3) (let ((image (create-image 300 300)) (face-height (- 300 (+ 10 (* 10 val1)))) (face-width (- 250 (* (/ 50 9) val2)))) (select-ellipse image REPLACE 25 5 face-width face-height) (set-fgcolor (list-ref face-colors val3) image) (fill-fgcolor image) (select-nothing image) (let ((ellipse-width (- 150 (* (/ 50 9) val2))) (ellipse-height 75)) (select-ellipse image REPLACE (/ face-width 3) (- face-height 90) ellipse-width ellipse-height) (select-ellipse image SUBTRACT (+ (* 3 val2) (/ face-width 4)) (- face-height 105) ellipse-width ellipse-height)) (set-fgcolor (list-ref mouth-colors val2) image) (fill-fgcolor image) (select-nothing image) (let ((eye-width 40) (eye-height 35)) (select-ellipse image REPLACE (/ face-width 3) (/ face-height 4) eye-width eye-height) (select-ellipse image ADD (+ 25 (* 2 (/ face-width 3))) (/ face-height 4) eye-width eye-height)) (set-fgcolor (list-ref eye-colors val1) image) (fill-fgcolor image) (select-nothing image) (let ((nose-width (+ 25 (/ face-width 2))) (nose-height (- (/ face-height 2) 15))) (set-fgcolor BLACK image) (set-brush "Circle (13)") (line image nose-width nose-height (+ 20 nose-width) (+ 40 nose-height)) (line image (+ 20 nose-width) (+ 40 nose-height) nose-width (+ 40 nose-height))) (show-image image))))) ;;; Procedure ;;; face-with-hair ;;; Perpetrators: ;;; Lin Ji ;;; Chengdong Yang ;;; Parameters: ;;; val1 - face width ;;; val2 - eye color ;;; val3 - hair (consistency and straight/curly) (define face-with-hair (let ((brushes (list "Circle (03)" "Circle (05)" "Circle Fuzzy (03)" "Felt Pen" "Calligraphic Brush")) (eye-colors (list BLUE GREEN COPPER GREY BROWN DIM_GREY STEEL_BLUE PALE_BLUE DARK_BROWN VERY_DARK_BROWN))) (lambda (val1 val2 val3) (set-bgcolor WHITE) (let ((image (create-image 256 256))) (set-bgcolor YELLOW) (set-fgcolor BLACK) (set-brush "Circle (07)") (select-ellipse image REPLACE (+ 40 val1) 50 (- 175 (* 2 val1)) 150) (fill-bgcolor image) (stroke image) (select-nothing image) (set-bgcolor RED) (set-brush "Circle (05)") (select-ellipse image REPLACE 90 150 65 28) (select-ellipse image SUBTRACT 73 138 130 37) (stroke image) (fill-bgcolor image) (select-nothing image) (set-bgcolor (list-ref eye-colors val2)) (select-ellipse image REPLACE 87 100 20 30) (select-ellipse image ADD 145 100 20 30) (fill-bgcolor image) (select-nothing image) (set-brush (list-ref brushes (modulo val3 (length brushes)))) (if (< val3 5) (begin (select-ellipse image REPLACE 76 50 35 35) (select-ellipse image ADD 116 52 35 35) (select-ellipse image ADD 154 53 35 35) (select-ellipse image SUBTRACT 81 51 20 22) (select-ellipse image SUBTRACT 118 55 20 22) (select-ellipse image SUBTRACT 155 57 20 22) (stroke image) (select-nothing image)) (begin (line image 100 57 80 98) (line image 112 52 128 82) (line image 136 55 174 78))) (show-image image))))) ;;; Procedure: ;;; draw-house ;;; Perpetrator: ;;; Paden Roder ;;; Parameters: ;;; val1 - left side of the house ;;; val2 - top of the house; choice of windows ;;; val3 - house color (define draw-house (lambda (val1 val2 val3) (set-bgcolor SKY_BLUE) (let* ((image (create-image 400 400)) (housecolors (list PERIWINKLE GREEN COPPER GREY CERULEAN RED YELLOW SEATTLE_SALMON GREEN ORANGE)) (housecolor (list-ref housecolors val3)) (siding (lambda () (set-fgcolor housecolor))) (inside (lambda () (set-fgcolor WHITE))) (outline (lambda () (set-fgcolor BLACK))) (hleft (+ 10 (* val1 18))) (htop (- 300 (* val2 30))) (hwidth (* (- 200 hleft) 2)) (hheight (- 400 htop)) (wleft 190) (wwidth 20) (wheight 20)) (set-bgcolor SKY_BLUE) (set-fgcolor BLACK) (select-rectangle image REPLACE hleft htop hwidth hheight) (stroke image) (siding) (fill-fgcolor image) (select-nothing image) (outline) (select-rectangle image REPLACE 190 360 20 40) (stroke image) (set-fgcolor BROWN) (fill-fgcolor image) (select-nothing image) (cond ((and (>= val2 2) (< val2 6)) (select-rectangle image REPLACE wleft 250 wwidth wheight) (outline) (stroke image) (inside) (fill-fgcolor image) (select-nothing image)) ((and (>= val2 6) (<= val2 9)) (select-rectangle image REPLACE wleft 250 wwidth wheight) (outline) (stroke image) (inside) (fill-fgcolor image) (select-nothing image) (select-rectangle image REPLACE wleft 150 wwidth wheight) (outline) (stroke image) (inside) (fill-fgcolor image) (select-nothing image)) ((= val2 9) (select-rectangle image REPLACE wleft 250 wwidth wheight) (outline) (stroke image) (inside) (fill-fgcolor image) (select-nothing image) (select-rectangle image REPLACE wleft 150 wwidth wheight) (outline) (stroke image) (inside) (fill-fgcolor image) (select-nothing image) (select-rectangle image REPLACE wleft 50 wwidth wheight) (outline) (stroke image) (inside) (fill-fgcolor image) (select-nothing image)) (else (select-nothing image))) (show-image image)))) ;;; Procedure: ;;; egg ;;; Perpetrators: ;;; Anjali Malik ;;; Mark Haley (define egg (let ((brushes (list "Calligraphic Brush" "Circle (03)" "Circle (05)" "Circle Fuzzy (03)" "Felt Pen" "Gecko" "ka blam!" "Nova" "yeah you!" "Circle Fuzzy (05)"))) (lambda (egg-size color brush-number) (let ((image (create-image 400 400)) (fill-color (list (* color 10) (* color 20) (* color 30))) (brush (list-ref brushes brush-number))) (set-bgcolor WHITE) (set-fgcolor fill-color) (set-brush brush) (select-ellipse image REPLACE 100 50 (* egg-size 20) (* egg-size 30)) (stroke image) (select-nothing image) (show-image image))))) ;;; Procedure: ;;; draw-face-3 ;;; Perpetrator: ;;; Mark D'Agostino (define draw-face-3 (lambda (val1 val2 val3) (let ((image (create-image 400 400))) (show-image image) (set-bgcolor (list (* 10 val2) (* 20 val2) (* 30 val3))) (select-all image REPLACE) (fill-bgcolor image) (select-nothing image) (select-ellipse image REPLACE 0 0 400 400) (set-fgcolor (list (* 28 val1) (* 28 val2) (* 28 val3))) (fill-fgcolor image) (select-nothing image) (select-ellipse image REPLACE 100 100 75 75) (set-fgcolor (list (* 30 val1) (* 20 val1) (* 10 val1))) (fill-fgcolor image) (select-nothing image) (select-ellipse image REPLACE 225 100 75 75) (fill-fgcolor image) (set-fgcolor (list (* 20 val3) (* 10 val3) (* 30 val3))) (select-nothing image) (set-brush "Circle (19)") (if (< val3 7) (line image 100 250 150 300) (line image 100 300 150 250)) (if (< val3 7) (line image 150 300 250 300) (line image 150 250 250 250)) (if (< val3 7) (line image 250 300 300 250) (line image 250 250 300 300)))))