hangman-spin.scm

(define H 500)
(define r (/ H 2))

(define (ypos x)
  (if (<= x 1)
      (/ (sqrt (- 1 (sqr (- (* 2 x) 1)))) 2)
      (/ (sqrt (- 1 (sqr (- (* 2 x) 3)))) -2)))
(define (ypos-as-posn x)
  (make-posn (* x r)
             (* (+ 1 (ypos x)) r)))
(define (div-by n)
  (lambda (x) (/ x n)))

(define (range start stop)
  (if (<= start stop)
      (cons start (range (+ 1 start) stop))
      (list)))
(define (do-pairwise action lst)
  (if (>= (length lst) 2)
      (begin (action (car lst) (cadr lst))
             (do-pairwise action (cdr lst)))
      'done))

(define (make-rotate degree x0 y0)
  (let ((c (cos degree))
        (s (sin degree)))
    (lambda (posn) (make-posn (+ (- (* c (- (posn-x posn) x0)) (* s (- (posn-y posn) y0))) x0)
                              (+ (+ (* s (- (posn-x posn) x0)) (* c (- (posn-y posn) y0))) y0)))))


(define points (map ypos-as-posn
                    (map (div-by r) (range 0 H))))
(start H H)

(define (draw-lines points) (do-pairwise (lambda (a b) (draw-solid-line a b 'black)) points))
(define (clear-lines points) (do-pairwise (lambda (a b) (clear-solid-line a b 'black)) points))

(define (make-rotated-posn x y x0 y0 degree)
    (let ((c (cos degree))
        (s (sin degree)))
 (make-posn (+ (- (* c (- x x0)) (* s (- y y0))) x0)
            (+ (+ (* s (- x x0)) (* c (- y y0))) y0))))

(define (draw-hangman degree)
  (and
  (draw-circle (make-rotated-posn 275 111 r r degree) 90 'red)
  (draw-solid-line (make-rotated-posn 288 49 r r degree) (make-rotated-posn 265 67 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 273 50 r r degree) (make-rotated-posn 282 74 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 339 73 r r degree) (make-rotated-posn 316 88 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 326 73 r r degree) (make-rotated-posn 335 94 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 240 191 r r degree) (make-rotated-posn 231 361 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 239 241 r r degree) (make-rotated-posn 171 201 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 243 239 r r degree) (make-rotated-posn 301 231 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 234 364 r r degree) (make-rotated-posn 147 402 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 231 360 r r degree) (make-rotated-posn 295 414 r r degree) 'black)
  (draw-solid-line (make-rotated-posn 221 142 r r degree) (make-rotated-posn 251 178 r r degree) 'black)
  ))


(define (clear-hangman degree)
  (and
  (clear-circle (make-rotated-posn 275 111 r r degree) 90 'red)
  (clear-solid-line (make-rotated-posn 288 49 r r degree) (make-rotated-posn 265 67 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 273 50 r r degree) (make-rotated-posn 282 74 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 339 73 r r degree) (make-rotated-posn 316 88 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 326 73 r r degree) (make-rotated-posn 335 94 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 240 191 r r degree) (make-rotated-posn 231 361 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 239 241 r r degree) (make-rotated-posn 171 201 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 243 239 r r degree) (make-rotated-posn 301 231 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 234 364 r r degree) (make-rotated-posn 147 402 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 231 360 r r degree) (make-rotated-posn 295 414 r r degree) 'black)
  (clear-solid-line (make-rotated-posn 221 142 r r degree) (make-rotated-posn 251 178 r r degree) 'black)
  ))


(define (main n stop)
  (if (< n stop)
      (let ((degree (/ n -2)))
        (begin
          (draw-hangman degree)
          (sleep-for-a-while 0.1)
          (clear-hangman degree)
          (main (+ n 1) stop)))
      'done))
(wait-for-mouse-click)
(main 0 72000000)