From c83ca4ccdbbc8e665019825c3280f9d5c003e146 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 20 Jun 2019 18:23:52 -0400 Subject: [PATCH] fix geometry bug reported by Will Byrd --- task-6.rkt | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/task-6.rkt b/task-6.rkt index 91c1cc7..0302745 100755 --- a/task-6.rkt +++ b/task-6.rkt @@ -9,9 +9,10 @@ (struct circle (x y d action) #:transparent) (define (draw-1-circle dc brush c) - (send dc set-brush brush) (match-define (circle x y d _a) c) - (send dc draw-ellipse x y d d)) + (send dc set-brush brush) + (define r (/ d 2)) + (send dc draw-ellipse (- x r) (- y r) d d)) (define *circles '()) @@ -46,7 +47,12 @@ (set!-values (*circles *history) (values (cons fst (rest *circles)) (rest *history)))))) (define (the-closest xm ym (circles *circles)) - (argmin (distance xm ym) circles)) + (define cdistance (distance xm ym)) + (define-values (good-circles distance*) + (for*/fold ([good-circles '()][distance* '()]) + ((c circles) (d (in-value (cdistance c))) #:when (< d (/ (circle-d c) 2))) + (values (cons c good-circles) (cons d distance*)))) + (and (cons? distance*) (first (argmin second (map list good-circles distance*))))) (define (is-empty-area xm ym (circles *circles)) (define dist (distance xm ym)) @@ -81,7 +87,7 @@ [(eq? 'leave type) (set! *x #f)] [(eq? 'enter type) (set! *x 0)] [(and (eq? 'left-down type) (is-empty-area *x *y)) (add-circle! *x *y)] - [(and (eq? 'right-down type) (cons? *circles)) (lock) (popup-adjuster (the-closest *x *y))]) + [(and (eq? 'right-down type) (the-closest *x *y)) => (λ (tc) (lock) (popup-adjuster tc))]) (paint-callback this 'y))) (define (paint-callback _self _evt)