ex: 2.49: implement wave painter

1 files changed, 68 insertions, 0 deletions

diff --git a/ex/2/49.rkt b/ex/2/49.rkt
index f98364e..601d17c 100644
--- a/ex/2/49.rkt
+++ b/ex/2/49.rkt
@@ -83,3 +83,71 @@
            (make-segment v-mr v-mb)
            (make-segment v-mb v-ml)
            (make-segment v-ml v-mt)))))
+
+
+(define (wave->painter)
+  (let* ((h-ls (make-vect 0.426 0.000))    ; head - left start
+         (h-le (make-vect 0.349 0.164))    ; head - left end
+         (h-rs (make-vect 0.505 0.000))    ; head - right start
+         (h-re (make-vect 0.577 0.165))    ; head - right end
+         (n-le (make-vect 0.434 0.287))    ; neck - left end
+         (n-re (make-vect 0.499 0.283))    ; neck - right end
+
+         (sh-le (make-vect 0.302 0.288))   ; shoulder - left end
+         (sh-re (make-vect 0.620 0.290))   ; shoulder - right end
+
+         (lh-ts (make-vect 0.000 0.200))   ; left hand - top start
+         (lh-te (make-vect 0.257 0.400))   ; left hand - top end
+         (lh-bs (make-vect 0.000 0.316))   ; left hand - bottom start
+         (lh-be (make-vect 0.296 0.533))   ; left hand - bottom end
+
+         (uat-ls sh-le)                    ; upper arm top - left start
+         (uat-le lh-te)                    ; upper arm top - left end
+         (uab-ls (make-vect 0.398 0.371))  ; upper arm bottom - left end
+         (uab-le lh-be)                    ; upper arm bottom - left end
+
+         (uat-rs sh-re)                    ; upper arm top - right start
+         (uat-re (make-vect 1.000 0.550))  ; upper arm top - right end
+         (uab-rs (make-vect 1.000 0.660))  ; upper arm bottom - right start
+         (uab-re (make-vect 0.563 0.376))  ; upper arm bottom - right end
+
+         (wll-os uab-ls)                   ; waist left leg - outside start
+         (wll-oe (make-vect 0.290 1.000))  ; waist left leg - outside end
+         (wll-is (make-vect 0.490 0.642))  ; waist left leg - inside start
+         (wll-ie (make-vect 0.384 1.000))  ; waist left leg - inside end
+
+         (wrl-os uab-re)                   ; waist right leg - outside start
+         (wrl-oe (make-vect 0.730 1.000))  ; waist right leg - outside end
+         (wrl-is wll-is)                   ; waist right leg - inside start
+         (wrl-ie (make-vect 0.650 1.000))) ; waist right leg - inside end
+    (segments->painter
+     (list
+      ;; head
+      (make-segment h-ls h-le)
+      (make-segment h-rs h-re)
+      (make-segment h-le n-le)
+      (make-segment h-re n-re)
+
+      ;; neck
+      (make-segment n-le sh-le)
+      (make-segment n-re sh-re)
+
+      ;; left hand
+      (make-segment lh-ts lh-te)
+      (make-segment lh-bs lh-be)
+
+      ;; upper arm left
+      (make-segment uat-ls uat-le)
+      (make-segment uab-ls uab-le)
+
+      ;; upper arm right
+      (make-segment uat-rs uat-re)
+      (make-segment uab-rs uab-re)
+
+      ;; waist - legs
+      (make-segment wll-os wll-oe)
+      (make-segment wll-is wll-ie)
+      (make-segment wrl-os wrl-oe)
+      (make-segment wrl-is wrl-ie)))))
+
+;;; https://ricketyspace.net/sicp/2.49.webm