improve the way check syntax draws arrows
(a little bit thicker line and some alpha)
This commit is contained in:
Robby Findler
parent
6067cab1ef
commit
3f987d76b7
|
|
@ -48,20 +48,29 @@
|
|||
|
||||
; dc<%> real real real real real real -> void
|
||||
; draw one arrow
|
||||
; The reason of the "-0.5" in the definition of start-x and end-x in the let
|
||||
; right below is because, well, after numerous experiments done under carefully
|
||||
; controlled conditions by a team of independent experts, it was thought to
|
||||
; be The Right Thing for the arrows to be drawn correctly, maybe.
|
||||
(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)]
|
||||
(define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy
|
||||
#:pen-width [pen-width #f])
|
||||
(define the-pen-width (or pen-width (send (send dc get-pen) get-width)))
|
||||
(let ([uncropped-start-x (+ uncropped-pre-start-x dx (- (/ the-pen-width 2)))]
|
||||
[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)]
|
||||
[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)]
|
||||
[(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
|
||||
(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 set-pen saved-pen)
|
||||
(when (and (< smallest start-x largest)
|
||||
(< smallest start-y largest))
|
||||
(send dc draw-ellipse
|
||||
|
|
|
|||
|
|
@ -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 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)
|
||||
(start-text start-pos-left start-pos-right
|
||||
end-text end-pos-left end-pos-right
|
||||
actual? level)) ;; level is one of 'lexical, 'top-level, 'import
|
||||
(define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos))
|
||||
actual? level) ;; level is one of 'lexical, 'top-level, 'import
|
||||
#:transparent)
|
||||
(define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent)
|
||||
|
||||
;; color : string
|
||||
;; text: text:basic<%>
|
||||
|
|
@ -777,7 +778,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
[end-y (arrow-end-y arrow)])
|
||||
(unless (and (= start-x end-x)
|
||||
(= 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)))
|
||||
(let-values ([(fw fh _d _v) (send dc get-text-extent "x")])
|
||||
(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-font (send dc get-font)]
|
||||
[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 the-font-list find-or-create-font
|
||||
(send old-font get-point-size)
|
||||
|
|
@ -795,6 +798,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
'normal
|
||||
'bold))
|
||||
(send dc set-text-foreground templ-color)
|
||||
(send dc set-alpha 0.5)
|
||||
(hash-for-each tacked-hash-table
|
||||
(λ (arrow v)
|
||||
(when v
|
||||
|
|
@ -811,63 +815,67 @@ If the namespace does not, they are colored the unbound color.
|
|||
(draw-arrow2 arrow))))
|
||||
(when (and cursor-location
|
||||
cursor-text)
|
||||
(let* ([arrow-record (hash-ref arrow-records cursor-text #f)])
|
||||
(when arrow-record
|
||||
(for ([ele (in-list (interval-map-ref arrow-record cursor-location null))])
|
||||
(cond [(var-arrow? ele)
|
||||
(if (var-arrow-actual? ele)
|
||||
(begin (send dc set-pen var-pen)
|
||||
(send dc set-brush untacked-brush))
|
||||
(begin (send dc set-pen templ-pen)
|
||||
(send dc set-brush untacked-brush)))
|
||||
(draw-arrow2 ele)]
|
||||
[(tail-arrow? ele)
|
||||
(send dc set-pen tail-pen)
|
||||
(send dc set-brush untacked-brush)
|
||||
(for-each-tail-arrows draw-arrow2 ele)])))))
|
||||
(define arrow-record (hash-ref arrow-records cursor-text #f))
|
||||
(define tail-arrows '())
|
||||
(when arrow-record
|
||||
(for ([ele (in-list (interval-map-ref arrow-record cursor-location null))])
|
||||
(cond [(var-arrow? ele)
|
||||
(if (var-arrow-actual? ele)
|
||||
(begin (send dc set-pen var-pen)
|
||||
(send dc set-brush untacked-brush))
|
||||
(begin (send dc set-pen templ-pen)
|
||||
(send dc set-brush untacked-brush)))
|
||||
(draw-arrow2 ele)]
|
||||
[(tail-arrow? ele)
|
||||
(set! tail-arrows (cons ele tail-arrows))])))
|
||||
|
||||
(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-pen old-pen)
|
||||
(send dc set-font old-font)
|
||||
(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
|
||||
;; cross the "#lang ..." line, if it is present.
|
||||
(super on-paint before dc left top right bottom dx dy draw-caret))
|
||||
|
||||
;; 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
|
||||
(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
|
||||
tail-arrow-other-pos tail-arrow-other-text)
|
||||
(for ([tail-arrow (in-list tail-arrows)])
|
||||
(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)])
|
||||
(let loop ([tail-arrow tail-arrow])
|
||||
(unless (hash-ref traversal-ht tail-arrow (λ () #f))
|
||||
(hash-set! traversal-ht tail-arrow #t)
|
||||
(unless (hash-ref call-f-ht tail-arrow (λ () #f))
|
||||
(hash-set! call-f-ht tail-arrow #t)
|
||||
(f tail-arrow))
|
||||
(let* ([next-pos (tail-arrow-pos tail-arrow)]
|
||||
[next-text (tail-arrow-text tail-arrow)]
|
||||
[arrow-record (hash-ref arrow-records next-text #f)])
|
||||
(when arrow-record
|
||||
(for ([ele (in-list (interval-map-ref arrow-record next-pos null))])
|
||||
(cond
|
||||
[(tail-arrow? ele)
|
||||
(let ([other-pos (tail-arrow-other-pos ele)]
|
||||
[other-text (tail-arrow-other-text ele)])
|
||||
(when (and (= other-pos next-pos)
|
||||
(eq? other-text next-text))
|
||||
(loop ele)))]))))))))
|
||||
|
||||
(for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text
|
||||
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))
|
||||
;; traversal-ht ensures that we don't loop in the arrow traversal.
|
||||
(let ([traversal-ht (make-hasheq)])
|
||||
(let loop ([tail-arrow tail-arrow])
|
||||
(unless (hash-ref traversal-ht tail-arrow #f)
|
||||
(hash-set! traversal-ht tail-arrow #t)
|
||||
(unless (hash-ref call-f-ht tail-arrow #f)
|
||||
(hash-set! call-f-ht tail-arrow #t)
|
||||
(f tail-arrow))
|
||||
(let* ([next-pos (tail-arrow-pos tail-arrow)]
|
||||
[next-text (tail-arrow-text tail-arrow)]
|
||||
[arrow-record (hash-ref arrow-records next-text #f)])
|
||||
(when arrow-record
|
||||
(for ([ele (in-list (interval-map-ref arrow-record next-pos null))])
|
||||
(cond
|
||||
[(tail-arrow? ele)
|
||||
(let ([other-pos (tail-arrow-other-pos ele)]
|
||||
[other-text (tail-arrow-other-text ele)])
|
||||
(when (and (= other-pos next-pos)
|
||||
(eq? other-text next-text))
|
||||
(loop ele)))]))))))))
|
||||
(for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text
|
||||
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)))
|
||||
|
||||
(define last-known-mouse-x #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)
|
||||
(for-each-tail-arrows
|
||||
(λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow))))
|
||||
arrow)]))
|
||||
(list arrow))]))
|
||||
arrows)
|
||||
(for-each
|
||||
(λ (arrow)
|
||||
|
|
@ -1090,7 +1098,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(for-each-tail-arrows
|
||||
(λ (arrow)
|
||||
(hash-set! tacked-hash-table arrow (not untack-arrows?)))
|
||||
arrow)]))
|
||||
(list arrow))]))
|
||||
arrows))
|
||||
(invalidate-bitmap-cache))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user