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

..

Browse Source 
original commit: 343c3815669377f94237020d687839b3c96c0229
This commit is contained in:
Robby Findler 2003-02-19 23:20:25 +00:00
parent cf071cfa82
commit 87da100897
2 changed files with 42 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/framework/private/frame.ss
View File

@ -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)

48
collects/mrlib/graph.ss
View File

@ -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)