From 270f9611fa4c1d1c769860e4e4414808f90f6dfb Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 19 May 2014 21:42:33 -0500 Subject: [PATCH] make the backtrace arrows scale with the font size also tweak the drawing slightly so that when it does scale it looks better --- .../drracket/drracket/private/unit.rkt | 40 +++++++++++++------ 1 file changed, 27 insertions(+), 13 deletions(-) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt index 9fc9e2784c..f671902d68 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt @@ -811,24 +811,38 @@ ;; draw the arrows (when before (when error-arrows - (let ([old-pen (send dc get-pen)]) - (send dc set-pen (send the-pen-list find-or-create-pen "red" 1 'solid)) - (let loop ([pts error-arrows]) - (cond - [(null? pts) (void)] - [(null? (cdr pts)) (void)] - [else (let ([pt1 (car pts)] - [pt2 (cadr pts)]) - (draw-arrow dc dx dy pt1 pt2) - (loop (cdr pts)))])) - (send dc set-pen old-pen))))) + (define old-pen (send dc get-pen)) + (define old-brush (send dc get-brush)) + (send dc set-brush "red" 'solid) + (define font-size-factor + (cond + [(<= (editor:get-current-preferred-font-size) 12) 1] + [else (* (editor:get-current-preferred-font-size) 1/8)])) + (define pen-width font-size-factor) + (define arrow-head-size (* 8 font-size-factor)) + (define arrow-root-radius (* 1 font-size-factor)) + (send dc set-pen (send the-pen-list find-or-create-pen "red" 1 'solid)) + (let loop ([pts error-arrows]) + (cond + [(null? pts) (void)] + [(null? (cdr pts)) (void)] + [else (define pt1 (car pts)) + (define pt2 (cadr pts)) + (draw-arrow dc dx dy pt1 pt2 + pen-width arrow-head-size arrow-root-radius) + (loop (cdr pts))])) + (send dc set-pen old-pen) + (send dc set-brush old-brush)))) - (define/private (draw-arrow dc dx dy pt1 pt2) + (define/private (draw-arrow dc dx dy pt1 pt2 pen-width arrow-head-size arrow-root-radius) (define-values (x1 y1) (find-poss (srcloc-source pt1) (- (srcloc-position pt1) 1) (srcloc-position pt1))) (define-values (x2 y2) (find-poss (srcloc-source pt2) (- (srcloc-position pt2) 1) (srcloc-position pt2))) - (drracket:arrow:draw-arrow dc x1 y1 x2 y2 dx dy)) + (drracket:arrow:draw-arrow dc x1 y1 x2 y2 dx dy + #:pen-width pen-width + #:arrow-head-size arrow-head-size + #:arrow-root-radius arrow-root-radius)) (inherit dc-location-to-editor-location) (define/private (find-poss text left-pos right-pos)