#lang racket
(require racket/gui)
(define alpha 2/3) (define point-radius 4)
(define line-width 2)
(define resolution 100)
(define curvature-resolution 60)
(define curvature-scaling 1/3)
(define p0 '(80 380))
(define p1 '(330 90))
(define p2 '(580 380))
(define d0 '(0 -300))
(define d1a '(-300 0))
(define d1b '(300 0))
(define d2 '(0 -300))
(define points? #t)
(define circle? #f)
(define linear? #t)
(define curved? #f)
(define control-points? #f)
(define curvature? #f)
(define curvature 300)
(define dragged #f)
(define (binomial n k)
(if (= k 0)
1
(* (/ n k) (binomial (- n 1) (- k 1)))))
(define (v+ . args) (apply map + args))
(define (v- . args) (apply map - args))
(define (v* u . args) (map (lambda (x) (apply * x args)) u))
(define (vlength u) (sqrt (apply + (map (lambda (x) (* x x)) u))))
(define (vnormalize u) (v* u (/ (vlength u))))
(define (vperp u) (list (second u) (- (first u))))
(define (point-distance p q) (vlength (v- q p)))
(define (scalar-product u v) (apply + (map * u v)))
(define (cross-product-length u v) (abs (- (* (first u) (second v)) (* (second u) (first v)))))
(define (linear-ribbon p d)
(lambda (u)
(v+ p (v* d u))))
(define (linear-ribbon-derivative d)
(lambda (k u) (if (= k 1) d (list 0 0))))
(define (curved-ribbon-cp-% p d)
(let ([n (vnormalize (vperp d))]
[q (v* (v+ p0 p2) 1/2)])
(when (< (scalar-product (v- q p1) n) 0)
(set! n (v* n -1)))
(list p (v+ p (v* d alpha))
(if (= curvature 0)
(v+ p d)
(v+ p d (v* n (scalar-product d d) 2 alpha alpha (/ curvature)))))))
(define (curved-ribbon p d)
(let ([points (curved-ribbon-cp-% p d)])
(lambda (u)
(v+ (v* (first points) (- 1 u) (- 1 u))
(v* (second points) 2 (- 1 u) u)
(v* (third points) u u)))))
(define (curved-ribbon-derivative p d)
(let ([points (curved-ribbon-cp-% p d)])
(lambda (k u)
(if (= k 1)
(v+ (v* (first points) -2 (- 1 u))
(v* (second points) 2 (- 1 (* 2 u)))
(v* (third points) 2 u))
(v+ (v* (first points) 2)
(v* (second points) -4)
(v* (third points) 2))))))
(define (curved-ribbon-points p d)
(let ([r (curved-ribbon p d)])
(for/list ([i (in-range resolution)])
(let* ([u (/ i (- resolution 1) 3)]
[p (r u)])
(make-object point% (first p) (second p))))))
(define (curved-ribbon-cp p d)
(map (lambda (p) (make-object point% (first p) (second p)))
(curved-ribbon-cp-% p d)))
(define (curve-points ribbon1 ribbon2)
(for/list ([i (in-range resolution)])
(let* ([u (/ i (- resolution 1))]
[p (v+ (v* (ribbon1 u) (+ (* 2 u u u) (* -3 u u) 1))
(v* (ribbon2 (- 1 u)) (+ (* -2 u u u) (* 3 u u))))])
(make-object point% (first p) (second p)))))
(define (curve-derivative r1 r1d r2 r2d k)
(if (= k 1)
(lambda (u)
(v+ (v* (r1d 1 u) (+ (* 2 u u u) (* -3 u u) 1))
(v* (r1 u) (+ (* 6 u u) (* -6 u)))
(v* (r2d 1 (- 1 u)) (+ (* 2 u u u) (* -3 u u)))
(v* (r2 (- 1 u)) (+ (* -6 u u) (* 6 u)))))
(lambda (u)
(v+ (v* (r1d 2 u) (+ (* 2 u u u) (* -3 u u) 1))
(v* (r1d 1 u) 2 (+ (* 6 u u) (* -6 u)))
(v* (r1 u) (+ (* 12 u) -6))
(v* (r2d 2 (- 1 u)) (+ (* -2 u u u) (* 3 u u)))
(v* (r2d 1 (- 1 u)) 2 (+ (* 6 u u) (* -6 u)))
(v* (r2 (- 1 u)) (+ (* -12 u) 6))))))
(define (curve-curvature r1 r1d r2 r2d)
(lambda (u)
(let* ([d1 ((curve-derivative r1 r1d r2 r2d 1) u)]
[d2 ((curve-derivative r1 r1d r2 r2d 2) u)]
[l (vlength d1)]
[d1d2 (cross-product-length d1 d2)])
(if (not (= d1d2 0))
(/ (* l l l) d1d2)
0))))
(define (show-segment dc a b)
(send dc draw-lines
(list (make-object point% (first a) (second a))
(make-object point% (first b) (second b)))))
(define (show-curvature-lines dc r1 r1d r2 r2d)
(let ([der (curve-derivative r1 r1d r2 r2d 1)]
[curv (curve-curvature r1 r1d r2 r2d)])
(for/list ([i (in-range curvature-resolution)])
(let* ([u (/ i (- curvature-resolution 1))]
[p (v+ (v* (r1 u) (+ (* 2 u u u) (* -3 u u) 1))
(v* (r2 (- 1 u)) (+ (* -2 u u u) (* 3 u u))))]
[n (vnormalize (vperp (der u)))]
[c (curv u)])
(show-segment dc p (v+ p (v* n curvature-scaling c)))))))
(define (curvature-center)
(let ([n (vnormalize (vperp d1a))]
[q (v* (v+ p0 p2) 1/2)])
(if (< (scalar-product (v- q p1) n) 0)
(v+ p1 (v* n -1 curvature))
(v+ p1 (v* n curvature)))))
(define (best-curvature)
(/ (+ ((curve-curvature (linear-ribbon p0 d0) (linear-ribbon-derivative d0)
(linear-ribbon p1 d1a) (linear-ribbon-derivative d1a))
1)
((curve-curvature (linear-ribbon p1 d1b) (linear-ribbon-derivative d1b)
(linear-ribbon p2 d2) (linear-ribbon-derivative d2))
0))
2))
(define (draw-point dc p)
(send dc draw-ellipse
(- (first p) point-radius) (- (second p) point-radius)
(* point-radius 2) (* point-radius 2)))
(define (draw canvas dc)
(when linear?
(send dc set-pen "GREEN" line-width 'solid)
(send dc draw-lines (curve-points (linear-ribbon p0 d0) (linear-ribbon p1 d1a)))
(send dc draw-lines (curve-points (linear-ribbon p1 d1b) (linear-ribbon p2 d2)))
(when (and curvature? (not dragged))
(show-curvature-lines dc (linear-ribbon p0 d0) (linear-ribbon-derivative d0)
(linear-ribbon p1 d1a) (linear-ribbon-derivative d1a))
(show-curvature-lines dc (linear-ribbon p1 d1b) (linear-ribbon-derivative d1b)
(linear-ribbon p2 d2) (linear-ribbon-derivative d2))))
(when curved?
(send dc set-pen "LIGHT BLUE" line-width 'solid)
(send dc draw-lines (curve-points (linear-ribbon p0 d0) (curved-ribbon p1 d1a)))
(send dc draw-lines (curve-points (curved-ribbon p1 d1b) (linear-ribbon p2 d2)))
(when (and curvature? (not dragged))
(show-curvature-lines dc (linear-ribbon p0 d0) (linear-ribbon-derivative d0)
(curved-ribbon p1 d1a) (curved-ribbon-derivative p1 d1a))
(show-curvature-lines dc (curved-ribbon p1 d1b) (curved-ribbon-derivative p1 d1b)
(linear-ribbon p2 d2) (linear-ribbon-derivative d2))))
(when (and circle? (not (= curvature 0)))
(send dc set-pen "BLACK" line-width 'short-dash)
(send dc set-brush "BLACK" 'transparent)
(let* ([2r (* curvature 2)]
[center (curvature-center)]
[left (- (first center) curvature)]
[top (- (second center) curvature)])
(send dc draw-ellipse left top 2r 2r)))
(when control-points?
(send dc set-pen "RED" line-width 'solid)
(send dc draw-lines (curved-ribbon-cp p1 d1a))
(send dc draw-lines (curved-ribbon-points p1 d1a))
(send dc draw-lines (curved-ribbon-cp p1 d1b))
(send dc draw-lines (curved-ribbon-points p1 d1b)))
(when points?
(let ([p0+d0 (v+ p0 (v* d0 1/3))]
[p1+d1a (v+ p1 (v* d1a 1/3))]
[p1+d1b (v+ p1 (v* d1b 1/3))]
[p2+d2 (v+ p2 (v* d2 1/3))])
(send dc set-brush "BLACK" 'solid)
(send dc set-pen "BLACK" line-width 'solid)
(for-each (lambda (p) (draw-point dc p)) (list p0 p1 p2))
(send dc set-brush "BLUE" 'solid)
(send dc set-pen "BLUE" line-width 'solid)
(for-each (lambda (p) (draw-point dc p)) (list p0+d0 p1+d1a p1+d1b p2+d2))
(send dc draw-line (first p0) (second p0) (first p0+d0) (second p0+d0))
(send dc draw-line (first p1) (second p1) (first p1+d1a) (second p1+d1a))
(send dc draw-line (first p1) (second p1) (first p1+d1b) (second p1+d1b))
(send dc draw-line (first p2) (second p2) (first p2+d2) (second p2+d2)))))
(define (handle-mouse-movement event)
(if dragged
(let ([p (list (send event get-x) (send event get-y))])
(case dragged
[(0) (set! p0 p)]
[(1) (set! d0 (v* (v- p p0) 3))]
[(2) (set! p1 p)]
[(3) (set! d1a (v* (v- p p1) 3))
(set! d1b (v* (vnormalize d1a) (vlength d1b) -1))]
[(4) (set! d1b (v* (v- p p1) 3))
(set! d1a (v* (vnormalize d1b) (vlength d1a) -1))]
[(5) (set! p2 p)]
[(6) (set! d2 (v* (v- p p2) 3))])
#t)
#f))
(define (handle-mouse-down event)
(if dragged
(handle-mouse-up event)
(let* ([p (list (send event get-x) (send event get-y))]
[p0+d0 (v+ p0 (v* d0 1/3))]
[p1+d1a (v+ p1 (v* d1a 1/3))]
[p1+d1b (v+ p1 (v* d1b 1/3))]
[p2+d2 (v+ p2 (v* d2 1/3))]
[points (list p0 p0+d0 p1 p1+d1a p1+d1b p2 p2+d2)])
(for ([i (in-range 7)]
[pi points])
(when (< (point-distance p pi) point-radius)
(set! dragged i))))))
(define (handle-mouse-up event)
(set! dragged #f)
#t)
(define my-canvas%
(class canvas%
(inherit refresh)
(define/override (on-event event)
(when (case (send event get-event-type)
[(motion) (handle-mouse-movement event)]
[(left-down) (handle-mouse-down event)]
[(left-up) (handle-mouse-up event)])
(refresh)))
(super-new)))
(let* ([frame (new frame% [label "Linear vs. Curved Ribbons"])]
[vbox (new vertical-pane% [parent frame])]
[canvas (new my-canvas% [parent vbox]
[min-width 640]
[min-height 480]
[paint-callback draw])]
[hbox1 (new horizontal-pane% [parent vbox])]
[hbox2 (new horizontal-pane% [parent vbox])])
(let-syntax ([add-option (syntax-rules ()
[(_ var a-label box)
(new check-box% [parent box]
[label a-label] [value var]
[callback (lambda (c e)
(set! var (not var))
(send canvas refresh))])])])
(add-option points? "Show points and ribbons" hbox1)
(add-option linear? "Show curve with linear ribbon" hbox1)
(add-option curved? "Show curve with curved ribbon" hbox1)
(add-option control-points? "Show curved ribbon with control points" hbox1)
(add-option circle? "Show circle" hbox2)
(add-option curvature? "Show curvature" hbox2))
(let ([slider
(new slider% [label "Curvature radius:"] [parent hbox2]
[style '(horizontal plain)] [init-value curvature]
[min-value 0] [max-value 1000]
[callback (lambda (b e)
(set! curvature (send b get-value))
(send canvas refresh))])])
(new button% [parent hbox2] [label "Best fit curvature"] [stretchable-width #t]
[callback (lambda (b e)
(set! curvature (best-curvature))
(send canvas refresh)
(send slider set-value (inexact->exact (round curvature))))]))
(send frame show #t))