suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve the way check syntax draws arrows

Browse Source 
(a little bit thicker line and some alpha)
This commit is contained in:
Robby Findler 2011-08-13 14:30:30 -05:00
parent 6067cab1ef
commit 3f987d76b7
2 changed files with 76 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/drracket/arrow.rkt
View File

@ -48,20 +48,29 @@
; dc<%> real real real real real real -> void ; dc<%> real real real real real real -> void
; draw one arrow ; draw one arrow
; The reason of the "-0.5" in the definition of start-x and end-x in the let (define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy
; right below is because, well, after numerous experiments done under carefully #:pen-width [pen-width #f])
; controlled conditions by a team of independent experts, it was thought to (define the-pen-width (or pen-width (send (send dc get-pen) get-width)))
; be The Right Thing for the arrows to be drawn correctly, maybe. (let ([uncropped-start-x (+ uncropped-pre-start-x dx (- (/ the-pen-width 2)))]
(define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy)
(let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)]
[uncropped-start-y (+ uncropped-pre-start-y dy)] [uncropped-start-y (+ uncropped-pre-start-y dy)]
[uncropped-end-x (+ uncropped-pre-end-x dx -0.5)] [uncropped-end-x (+ uncropped-pre-end-x dx (- (/ the-pen-width 2)))]
[uncropped-end-y (+ uncropped-pre-end-y dy)] [uncropped-end-y (+ uncropped-pre-end-y dy)]
[old-smoothed (send dc get-smoothing)]) [old-smoothed (send dc get-smoothing)])
(let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)] (let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)]
[(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)]) [(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
(send dc set-smoothing 'aligned) (send dc set-smoothing 'aligned)
(define saved-pen (send dc get-pen))
(when pen-width
(send dc set-pen
(let ([p (send dc get-pen)])
(send the-pen-list find-or-create-pen
(send p get-color)
pen-width
(send p get-style)
(send p get-cap)
(send p get-join)))))
(send dc draw-line start-x start-y end-x end-y) (send dc draw-line start-x start-y end-x end-y)
(send dc set-pen saved-pen)
(when (and (< smallest start-x largest) (when (and (< smallest start-x largest)
(< smallest start-y largest)) (< smallest start-y largest))
(send dc draw-ellipse (send dc draw-ellipse

112
collects/drracket/private/syncheck/gui.rkt
View File

@ -190,12 +190,13 @@ If the namespace does not, they are colored the unbound color.
(define-struct graphic (pos* locs->thunks draw-fn click-fn)) (define-struct graphic (pos* locs->thunks draw-fn click-fn))
(define-struct arrow (start-x start-y end-x end-y) #:mutable) (define-struct arrow (start-x start-y end-x end-y) #:mutable #:transparent)
(define-struct (var-arrow arrow) (define-struct (var-arrow arrow)
(start-text start-pos-left start-pos-right (start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level)) ;; level is one of 'lexical, 'top-level, 'import actual? level) ;; level is one of 'lexical, 'top-level, 'import
(define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos)) #:transparent)
(define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent)
;; color : string ;; color : string
;; text: text:basic<%> ;; text: text:basic<%>
@ -777,7 +778,8 @@ If the namespace does not, they are colored the unbound color.
[end-y (arrow-end-y arrow)]) [end-y (arrow-end-y arrow)])
(unless (and (= start-x end-x) (unless (and (= start-x end-x)
(= start-y end-y)) (= start-y end-y))
(drracket:arrow:draw-arrow dc start-x start-y end-x end-y dx dy) (drracket:arrow:draw-arrow dc start-x start-y end-x end-y dx dy
#:pen-width 2)
(when (and (var-arrow? arrow) (not (var-arrow-actual? arrow))) (when (and (var-arrow? arrow) (not (var-arrow-actual? arrow)))
(let-values ([(fw fh _d _v) (send dc get-text-extent "x")]) (let-values ([(fw fh _d _v) (send dc get-text-extent "x")])
(send dc draw-text "?" (send dc draw-text "?"
@ -787,7 +789,8 @@ If the namespace does not, they are colored the unbound color.
[old-pen (send dc get-pen)] [old-pen (send dc get-pen)]
[old-font (send dc get-font)] [old-font (send dc get-font)]
[old-text-foreground (send dc get-text-foreground)] [old-text-foreground (send dc get-text-foreground)]
[old-text-mode (send dc get-text-mode)]) [old-text-mode (send dc get-text-mode)]
[old-alpha (send dc get-alpha)])
(send dc set-font (send dc set-font
(send the-font-list find-or-create-font (send the-font-list find-or-create-font
(send old-font get-point-size) (send old-font get-point-size)
@ -795,6 +798,7 @@ If the namespace does not, they are colored the unbound color.
'normal 'normal
'bold)) 'bold))
(send dc set-text-foreground templ-color) (send dc set-text-foreground templ-color)
(send dc set-alpha 0.5)
(hash-for-each tacked-hash-table (hash-for-each tacked-hash-table
(λ (arrow v) (λ (arrow v)
(when v (when v
@ -811,63 +815,67 @@ If the namespace does not, they are colored the unbound color.
(draw-arrow2 arrow)))) (draw-arrow2 arrow))))
(when (and cursor-location (when (and cursor-location
cursor-text) cursor-text)
(let* ([arrow-record (hash-ref arrow-records cursor-text #f)]) (define arrow-record (hash-ref arrow-records cursor-text #f))
(when arrow-record (define tail-arrows '())
(for ([ele (in-list (interval-map-ref arrow-record cursor-location null))]) (when arrow-record
(cond [(var-arrow? ele) (for ([ele (in-list (interval-map-ref arrow-record cursor-location null))])
(if (var-arrow-actual? ele) (cond [(var-arrow? ele)
(begin (send dc set-pen var-pen) (if (var-arrow-actual? ele)
(send dc set-brush untacked-brush)) (begin (send dc set-pen var-pen)
(begin (send dc set-pen templ-pen) (send dc set-brush untacked-brush))
(send dc set-brush untacked-brush))) (begin (send dc set-pen templ-pen)
(draw-arrow2 ele)] (send dc set-brush untacked-brush)))
[(tail-arrow? ele) (draw-arrow2 ele)]
(send dc set-pen tail-pen) [(tail-arrow? ele)
(send dc set-brush untacked-brush) (set! tail-arrows (cons ele tail-arrows))])))
(for-each-tail-arrows draw-arrow2 ele)])))))
(send dc set-pen tail-pen)
(send dc set-brush untacked-brush)
(for-each-tail-arrows draw-arrow2 tail-arrows))
(send dc set-brush old-brush) (send dc set-brush old-brush)
(send dc set-pen old-pen) (send dc set-pen old-pen)
(send dc set-font old-font) (send dc set-font old-font)
(send dc set-text-foreground old-text-foreground) (send dc set-text-foreground old-text-foreground)
(send dc set-text-mode old-text-mode))) (send dc set-text-mode old-text-mode)
(send dc set-alpha old-alpha)))
;; do the drawing before calling super so that the arrows don't ;; do the drawing before calling super so that the arrows don't
;; cross the "#lang ..." line, if it is present. ;; cross the "#lang ..." line, if it is present.
(super on-paint before dc left top right bottom dx dy draw-caret)) (super on-paint before dc left top right bottom dx dy draw-caret))
;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void ;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void
(define/private (for-each-tail-arrows f tail-arrow) (define/private (for-each-tail-arrows f tail-arrows)
;; call-f-ht ensures that `f' is only called once per arrow ;; call-f-ht ensures that `f' is only called once per arrow
(define call-f-ht (make-hasheq)) (define call-f-ht (make-hash))
(define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text (for ([tail-arrow (in-list tail-arrows)])
tail-arrow-other-pos tail-arrow-other-text) (define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text
tail-arrow-other-pos tail-arrow-other-text)
;; traversal-ht ensures that we don't loop in the arrow traversal.
(let ([traversal-ht (make-hasheq)]) ;; traversal-ht ensures that we don't loop in the arrow traversal.
(let loop ([tail-arrow tail-arrow]) (let ([traversal-ht (make-hasheq)])
(unless (hash-ref traversal-ht tail-arrow (λ () #f)) (let loop ([tail-arrow tail-arrow])
(hash-set! traversal-ht tail-arrow #t) (unless (hash-ref traversal-ht tail-arrow #f)
(unless (hash-ref call-f-ht tail-arrow (λ () #f)) (hash-set! traversal-ht tail-arrow #t)
(hash-set! call-f-ht tail-arrow #t) (unless (hash-ref call-f-ht tail-arrow #f)
(f tail-arrow)) (hash-set! call-f-ht tail-arrow #t)
(let* ([next-pos (tail-arrow-pos tail-arrow)] (f tail-arrow))
[next-text (tail-arrow-text tail-arrow)] (let* ([next-pos (tail-arrow-pos tail-arrow)]
[arrow-record (hash-ref arrow-records next-text #f)]) [next-text (tail-arrow-text tail-arrow)]
(when arrow-record [arrow-record (hash-ref arrow-records next-text #f)])
(for ([ele (in-list (interval-map-ref arrow-record next-pos null))]) (when arrow-record
(cond (for ([ele (in-list (interval-map-ref arrow-record next-pos null))])
[(tail-arrow? ele) (cond
(let ([other-pos (tail-arrow-other-pos ele)] [(tail-arrow? ele)
[other-text (tail-arrow-other-text ele)]) (let ([other-pos (tail-arrow-other-pos ele)]
(when (and (= other-pos next-pos) [other-text (tail-arrow-other-text ele)])
(eq? other-text next-text)) (when (and (= other-pos next-pos)
(loop ele)))])))))))) (eq? other-text next-text))
(loop ele)))]))))))))
(for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text (for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text
tail-arrow-from-pos tail-arrow-from-text) tail-arrow-from-pos tail-arrow-from-text)
(for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text
tail-arrow-to-pos tail-arrow-to-text)) tail-arrow-to-pos tail-arrow-to-text)))
(define last-known-mouse-x #f) (define last-known-mouse-x #f)
(define last-known-mouse-y #f) (define last-known-mouse-y #f)
@ -1079,7 +1087,7 @@ If the namespace does not, they are colored the unbound color.
[(tail-arrow? arrow) [(tail-arrow? arrow)
(for-each-tail-arrows (for-each-tail-arrows
(λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))) (λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow))))
arrow)])) (list arrow))]))
arrows) arrows)
(for-each (for-each
(λ (arrow) (λ (arrow)
@ -1090,7 +1098,7 @@ If the namespace does not, they are colored the unbound color.
(for-each-tail-arrows (for-each-tail-arrows
(λ (arrow) (λ (arrow)
(hash-set! tacked-hash-table arrow (not untack-arrows?))) (hash-set! tacked-hash-table arrow (not untack-arrows?)))
arrow)])) (list arrow))]))
arrows)) arrows))
(invalidate-bitmap-cache)) (invalidate-bitmap-cache))