;;; Curvature monotonicity of the parabola ;;; by Peter Salvi, September 2020. ;;; Based on ;;; W.H. Frey, D.A. Field: ;;; Designing Bézier conic segments with monotone curvature. ;;; Computer Aided Geometric Design 17(6), pp. 457-483, 2000. #lang racket ;;; Libraries (require racket/gui) ;;; Parameters (define point-radius 4) (define line-width 2) (define resolution 100) (define optimization-iterations 100) (define bisection-iterations 20) (define epsilon 1e-5) ;;; Default placements (define a0 '(120 350)) (define a1 '(320 50)) (define a2 '(520 350)) ;;; Variables (define dragged #f) (define parameter 0.5) ;;; Basic Maths (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 (point-distance p q) (vlength (v- q p))) (define (scalar-product u v) (apply + (map * u v))) (define (cross-product u v) (- (* (first u) (second v)) (* (second u) (first v)))) (define (to-system u d) (let* ([u (vnormalize u)] [v (list (- (second u)) (first u))]) (list (scalar-product d u) (scalar-product d v)))) (define (from-system u d) (let* ([u (vnormalize u)] [v (list (- (second u)) (first u))]) (v+ (v* u (first d)) (v* v (second d))))) ;;; Bezier Curve (define (bezier-eval-one-point points u) (let* ([n (- (length points) 1)] [v (- 1 u)] [p '(0 0)]) (for ([k (in-range (+ n 1))] [q points]) (set! p (v+ p (v* q (binomial n k) (expt u k) (expt v (- n k)))))) p)) (define (bezier-normal points u) ;; only for quadratic (let ([t (v+ (v* a0 (- u 1)) (v* a1 (- 1 (* 2 u))) (v* a2 u))]) (vnormalize (list (- (second t)) (first t))))) (define (bezier-curvature points u) ;; only for quadratic (let ([d1 (v* (v+ (v* a0 (- u 1)) (v* a1 (- 1 (* 2 u))) (v* a2 u)) 2)] [d2 (v* (v+ a0 (v* a1 -2) a2) 2)]) (/ (cross-product d1 d2) (expt (vlength d1) 3)))) (define (bezier-evaluate points) (for/list ([i (in-range resolution)]) (let* ([u (/ i (- resolution 1))] [p (bezier-eval-one-point points u)]) (make-object point% (first p) (second p))))) ;;; Graphics (define (draw-circle dc p r) (send dc draw-ellipse (- (first p) r) (- (second p) r) (* r 2) (* r 2))) (define (draw-point dc p) (draw-circle dc p point-radius)) (define (draw-segment dc p q) (send dc draw-line (first p) (second p) (first q) (second q))) (define (draw canvas dc) (send dc set-pen "BLUE" line-width 'solid) (draw-segment dc a0 a2) (send dc set-pen "GRAY" line-width 'solid) (draw-segment dc a0 a1) (draw-segment dc a1 a2) (send dc set-pen "RED" line-width 'short-dash) (send dc set-brush "BLACK" 'transparent) (let ([r (/ (point-distance a0 a2) 4)]) (draw-circle dc (v+ (v* a0 3/4) (v* a2 1/4)) r) (draw-circle dc (v+ (v* a0 1/4) (v* a2 3/4)) r)) (let ([bezier-cpts (list a0 a1 a2)]) (let ([p (bezier-eval-one-point bezier-cpts parameter)] [n (bezier-normal bezier-cpts parameter)] [r (/ (bezier-curvature bezier-cpts parameter))]) (send dc set-pen "MAGENTA" line-width 'long-dash) (draw-circle dc (v+ p (v* n r)) r) (send dc set-pen "MAGENTA" line-width 'solid) (send dc set-brush "MAGENTA" 'solid) (draw-point dc p)) (send dc set-pen "GREEN" line-width 'solid) (send dc draw-lines (bezier-evaluate bezier-cpts)) (send dc set-brush "BLACK" 'solid) (send dc set-pen "BLACK" line-width 'solid) (for-each (lambda (p) (draw-point dc p)) bezier-cpts))) ;;; GUI (define (handle-mouse-movement event) (if dragged (let ([p (list (send event get-x) (send event get-y))]) (when dragged (set! a1 p)) #t) #f)) (define (handle-mouse-down event) (if dragged (handle-mouse-up event) (let ([p (list (send event get-x) (send event get-y))]) (when (< (point-distance p a1) point-radius) (set! dragged #t))))) (define (handle-mouse-up event) (set! dragged #f) #t) (define scurve-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 "Parabola Curvature Monotonicity"])] [vbox (new vertical-pane% [parent frame])] [canvas (new scurve-canvas% [parent vbox] [min-width 640] [min-height 480] [paint-callback draw])] [hbox (new horizontal-pane% [parent vbox])]) (let-syntax ([add-slider (syntax-rules () [(_ var a-label box a-min a-max from-int to-int) (let* ([label (new message% [label ""] [parent box] [auto-resize #t])] [set-label (lambda () (send label set-label (string-append a-label (number->string var))))] [slider-tmp #f] [slider (new slider% [label ""] [parent box] [min-value (to-int a-min)] [max-value (to-int a-max)] [init-value (to-int var)] [style '(horizontal plain)] [min-width 200] [stretchable-width #f] [callback (lambda (c e) (let ([v (send slider-tmp get-value)]) (set! var (+ 0.0 (from-int v)))) (set-label) (send canvas refresh))])]) (set! slider-tmp slider) (set-label))])]) (add-slider parameter "U: " hbox 0 1 (lambda (x) (/ x 100)) (lambda (x) (exact-round (* x 100))))) (send frame show #t))