From 87da1008976d87adfa08c2b35a9b8f4e22c0f833 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 19 Feb 2003 23:20:25 +0000 Subject: [PATCH] .. original commit: 343c3815669377f94237020d687839b3c96c0229 --- collects/framework/private/frame.ss | 34 +++++++++++--------- collects/mrlib/graph.ss | 48 +++++++++++++---------------- 2 files changed, 42 insertions(+), 40 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index f59efe9c..9dc3c47d 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -287,7 +287,7 @@ close-status-line update-status-line)) - ;; status-line = (make-status-line (is-a?/c message%) symbol number) + ;; status-line = (make-status-line (union #f (is-a?/c message%)) symbol number) (define-struct status-line (message id count)) (define status-line-mixin @@ -312,12 +312,7 @@ (cond [(null? status-lines) (list - (make-status-line (instantiate message% () - (parent status-line-container-panel) - (label "") - (stretchable-width #t)) - id - 1))] + (make-status-line #f id 1))] [else (let ([status-line (car status-lines)]) (if (eq? (status-line-id status-line) id) (cons (make-status-line (status-line-message status-line) @@ -338,9 +333,11 @@ [matched? (eq? (status-line-id status-line) id)]) (cond [(and matched? (= 1 (status-line-count status-line))) - (send status-line-container-panel change-children - (lambda (l) - (remq (status-line-message status-line) l))) + (let ([message (status-line-message status-line)]) + (when message + (send status-line-container-panel change-children + (lambda (l) + (remq message l))))) (cdr status-lines)] [matched? (cons (make-status-line (status-line-message status-line) @@ -354,9 +351,18 @@ (lambda () (let* ([status-line (find-status-line id msg-txt)] [msg (status-line-message status-line)] - [current-txt (send msg get-label)]) - (unless (equal? msg-txt current-txt) - (send msg set-label msg-txt)))))) + [current-txt (and msg (send msg get-label))]) + (when (and (not msg) + (not (equal? msg-txt ""))) + (let ([new-msg (instantiate message% () + (parent status-line-container-panel) + (label "") + (stretchable-width #t))]) + (set-status-line-message! status-line new-msg) + (set! msg new-msg))) + (when msg + (unless (equal? msg-txt current-txt) + (send msg set-label msg-txt))))))) (define/private (find-status-line id msg-txt) (let loop ([status-lines status-lines]) @@ -368,7 +374,7 @@ status-line (loop (cdr status-lines))))]))) - (field [eventspace-main-thread (current-thread)]) + (field [eventspace-main-thread (current-thread)]) ;; replace by using new primitive in 203.5 called eventspace-main-thread (inherit get-eventspace) (define/private (do-main-thread t) (if (eq? (current-thread) eventspace-main-thread) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 4cab2460..27b39319 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -118,18 +118,12 @@ (interface () on-mouse-over-snips)) + (define-struct rect (left top right bottom)) + (define graph-pasteboard-mixin (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>) (inherit find-first-snip find-next-selected-snip) - - (define (invalidate-between from to) - (let-values ([(xf yf wf hf) (get-position from)] - [(xt yt wt ht) (get-position to)]) - (invalidate-bitmap-cache (min xf xt) - (min yf yt) - (max (+ xf wf) (+ xt wt)) - (max (+ yf hf) (+ yt ht))))) - + (inherit dc-location-to-editor-location get-canvas) (rename [super-on-event on-event]) (field (currently-overs null)) @@ -160,7 +154,7 @@ (rename [super-interactive-adjust-move interactive-adjust-move]) (define/override (interactive-adjust-move snip x y) - (invalidate-snip-to-children/parents snip) + (invalidate-to-children/parents snip) (super-interactive-adjust-move snip x y)) ;; invalidate-selected-snips : -> void @@ -169,24 +163,26 @@ (define/private (invalidate-selected-snips) (let loop ([snip (find-next-selected-snip #f)]) (when snip - (invalidate-snip-to-children/parents snip) + (invalidate-to-children/parents snip) (loop (find-next-selected-snip snip))))) - ;; invalidate-snip-to-children : snip -> void - ;; invalidates a region including the snip and all its children and parents - (define (invalidate-snip-to-children/parents snip) - (when (and (is-a? snip graph-snip<%>) - (send snip get-admin)) - (for-each - (lambda (child) - (when (send child get-admin) - (invalidate-between snip child))) - (send snip get-children)) - (for-each - (lambda (parent) - (when (send parent get-admin) - (invalidate-between snip parent))) - (send snip get-parents)))) + (define (add-to-rect from to rect) + (let-values ([(xf yf wf hf) (get-position from)] + [(xt yt wt ht) (get-position to)]) + (make-rect + (if rect + (min xf xt (rect-left rect)) + (min xf xt)) + (if rect + (min yf yt (rect-top rect)) + (min yf yt)) + (if rect + (max (+ xf wf) (+ xt wt) (rect-right rect)) + (max (+ xf wf) (+ xt wt))) + (if rect + (max (+ yf hf) (+ yt ht) (rect-bottom rect)) + (max (+ yf hf) (+ yt ht)))))) + ;; find-snips-under-mouse : num num -> (listof graph-snip<%>) (define (find-snips-under-mouse x y)