Drawing a spiral of Theodorus

theodorus.rkt

#lang racket
#|
(spiral n w) draws an n-triangle spiral of Theodorus having an innermost
  triangle of leg-length w.
See https://en.wikipedia.org/wiki/Spiral_of_Theodorus
|#
(require 2htdp/image)
(provide spiral)

;; Int+ Num+ -> Image
;; Draw a spiral of Theodorus consisting of n triangles, the innermost having
;; leg length w.
(define (spiral n [w 10])
  (define max-side (sqrt n))
  (define-values (img _)
    (for/fold ([img (put-pinhole 0 0 (square 0 'solid 'white))]
               [angle 0]) ; in radians
              ([side^2 (in-range 1 (+ 1 n))])
      (define side (sqrt side^2))
      (values
       (underlay/pinhole
        (rotate angle (tri side (rainbow-color (- (sqr (/ side max-side 1.15))))))
        img)
       (+ angle (radians->degrees (atan (/ 1 side)))))))
  (scale w (clear-pinhole img)))

;; Int+ Color -> Image
;; draw a single right triangle of given side length & color,
;; with pinhole at the small angle's vertex.
(define (tri side c)
  (define △
    (flip-horizontal (overlay (right-triangle side 1 'outline 'white)
                              (right-triangle side 1 'solid c))))
  (put-pinhole 0 (image-height △) △))

;; rainbow-color : Num[0..1] -> Color
;; create a color for a point on a percentage scale.
(define (rainbow-color %)
  (define (inmod x m) ; generalized modulo; racket's is restricted to integers
    (- x (* m (floor (/ x m)))))
  ; Compute a hue; the HSV color being generated has s = v = 1.
  (define hue (inmod (+ 1 (* % 6)) 6))
  ; Convert to RGB. See https://en.wikipedia.org/wiki/HSL_and_HSV#From_HSV
  ; or http://stackoverflow.com/questions/2353211/hsl-to-rgb-color-conversion
  (define X (abs (- (inmod hue 2) 1)))
  (define-values (r g b) ; as percentages
    (cond [(< hue 1) (values 1 X 0)]
          [(< hue 2) (values 1 0 X)]
          [(< hue 3) (values X 0 1)]
          [(< hue 4) (values 0 X 1)]
          [(< hue 5) (values 0 1 X)]
          [(< hue 6) (values X 1 0)]
          [else (error 'rainbow-color "shouldn't happen")]))
  (make-color (->255 r) (->255 g) (->255 b)))

(define (->255 c) (exact-round (* 255 c)))