donut

donut.rkt

(define *theta-spacing* 0.07)
(define *phi-spacing* 0.02)
(define *screen-width* 300)
(define *screen-height* 240)
(define R1 1)
(define R2 2)
(define K2 5)
(define K1 (/ (* 3 K2 *screen-width*) (* 8 (+ R1 R2))))
(define (clip n min max) (if (< n min) min (if (> n max) max n)))
(define donutcvs
  (class canvas%
    (super-new)
    (inherit get-dc refresh)
    (define A 0.0)
    (define B 0.0)
    (define tick? #f)
    (define/public (run)
      (set! tick? #t)
      (refresh))
    (define (canvas-frame)
      (define dc (get-dc))
      (send dc set-brush "black" 'solid)
      (send dc set-alpha 1)
      (send dc draw-rectangle 0 0 *screen-width* *screen-height*)
      (send dc set-pen "white" 1 'solid)
      (define-values (ca sa cb sb)
        (values (cos A) (sin A) (cos B) (sin B)))
      (for ([j (in-range 0.0 6.28 0.3)])
        (let ((ct (cos j)) (st (sin j)))
          (for ([i (in-range 0.0 6.28 0.1)])
            (let ([sp (sin i)] [cp (cos i)]
                  [ox (+ R2 (* R1 ct))] [oy (+ R1 st)])
              (let ([x (- (* ox (+ (* cb cp) (* sa sb sp))) (* oy ca sb))]
                    [y (+ (* ox (- (* sb cp) (* sa cb sp))) (* oy ca cb))]
                    [ooz (/ 1 (+ K2 (* ca ox sp) (* sa oy)))])
                (let ([xp (+ (/ *screen-width* 2) (* K1 ooz x))]
                      [yp (- (/ *screen-height* 2) (* K1 ooz y))])
                  (let ([l (clip (* 0.7 (+ (* cp ct sb) (- (* sa ct sp)) (- (* sa st)) 
                                           (* cb (- (* ca st) (* ct sa sp)))))
                                 0.0 1.0)])
                    (send dc set-alpha l)
                    (send dc draw-point xp yp)))))))))
    (define/override (on-paint)
      (when tick? 
        (set! tick? #f)
        (canvas-frame)
        (set! A (+ A *theta-spacing*))
        (set! B (+ B *phi-spacing*))
        (queue-callback (λ _ (send this run)) #f)))))
(define sema (make-semaphore 0))
(define frame (make-object (class frame% (define/augment (on-close) 
                                           (semaphore-post sema)
                                           (inner (void) on-close))
                             (super-new)) "mmm... donut..."))
(define cvs (make-object donutcvs frame))
(send cvs min-width *screen-width*)
(send cvs min-height *screen-height*)
(send cvs run)
(send frame show #t)
(void (yield sema))