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

reverted changes to frame.ss

Browse Source 
svn: r7450
This commit is contained in:
Robby Findler 2007-10-08 13:10:05 +00:00
parent 1df81534e7
commit 0d641835a9
1 changed files with 66 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -259,63 +259,6 @@
(define unlocked-message-line1 (string-constant read/write-line1)) (define unlocked-message-line1 (string-constant read/write-line1))
(define unlocked-message-line2 (string-constant read/write-line2)) (define unlocked-message-line2 (string-constant read/write-line2))
(define lock-canvas%
(class canvas%
(field [locked? #f])
(inherit refresh)
(define/public (set-locked l)
(unless (eq? locked? l)
(set! locked? l)
(setup-sizes)
(refresh)))
(inherit get-client-size get-dc)
(define/override (on-paint)
(let* ([dc (get-dc)]
[draw
(λ (str1 str2 bg-color bg-style line-color line-style)
(send dc set-font small-control-font)
(let-values ([(w h) (get-client-size)]
[(tw1 th1 _1 _2) (send dc get-text-extent str1)]
[(tw2 th2 _3 _4) (send dc get-text-extent str2)])
(send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style))
(send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style))
(send dc draw-rectangle 0 0 w h)
(cond
[(string=? str2 "")
(send dc draw-text str1
(- (/ w 2) (/ tw1 2))
(- (* h 1/2) (/ th1 2)))]
[else
(send dc draw-text str1
(- (/ w 2) (/ tw1 2))
(- (* h 1/2) th1))
(send dc draw-text str2
(- (/ w 2) (/ tw2 2))
(* h 1/2))])))])
(when locked?
(draw locked-message-line1 locked-message-line2
"yellow" 'solid "black" 'solid))))
(inherit get-parent min-width min-height stretchable-width stretchable-height)
(define/private (setup-sizes)
(let ([dc (get-dc)])
(if locked?
(let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)]
[(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)])
(min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2))))))
(min-height (inexact->exact (floor (+ 2 hl1 hl2)))))
(begin
(min-width 0)
(min-height 0)))))
(super-new [style '(transparent)])
(send (get-dc) set-font small-control-font)
(setup-sizes)
(stretchable-width #f)
(stretchable-height #t)))
#;
(define lock-canvas% (define lock-canvas%
(class canvas% (class canvas%
(field [locked? #f]) (field [locked? #f])
@ -537,7 +480,7 @@
;; need high priority callbacks to ensure ordering wrt other callbacks ;; need high priority callbacks to ensure ordering wrt other callbacks
(queue-callback t #t)))) (queue-callback t #t))))
(super-new))) (super-instantiate ())))
(define info<%> (interface (basic<%>) (define info<%> (interface (basic<%>)
determine-width determine-width
@ -665,11 +608,15 @@
(define/public (get-info-panel) info-panel) (define/public (get-info-panel) info-panel)
(define/public (update-memory-text) (define/public (update-memory-text)
(when show-memory-text? (when (and show-memory-text?
(for-each memory-canvas)
(λ (memory-canvas) (send memory-text begin-edit-sequence)
(send memory-canvas set-str (format-number (current-memory-use)))) (send memory-text lock #f)
memory-canvases))) (send memory-text erase)
(send memory-text insert (format-number (current-memory-use)))
(ensure-enough-width memory-canvas memory-text)
(send memory-text lock #t)
(send memory-text end-edit-sequence)))
(define/private (format-number n) (define/private (format-number n)
(let* ([mbytes (/ n 1024 1024)] (let* ([mbytes (/ n 1024 1024)]
@ -680,8 +627,7 @@
"." "."
(cond (cond
[(<= after-decimal 9) (format "0~a" after-decimal)] [(<= after-decimal 9) (format "0~a" after-decimal)]
[else (number->string after-decimal)]) [else (number->string after-decimal)]))))
" MB")))
(define/private (pad-to-3 n) (define/private (pad-to-3 n)
(cond (cond
@ -693,21 +639,27 @@
(when show-memory-text? (when show-memory-text?
(let* ([panel (new horizontal-panel% (let* ([panel (new horizontal-panel%
[parent (get-info-panel)] [parent (get-info-panel)]
;[style '(border)] [style '(border)]
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f])] [stretchable-height #f])]
[ec (new position-canvas% [button (new button%
[label (string-constant collect-button-label)]
[parent panel] [parent panel]
[button-up [callback
(λ () (λ x
(collect-garbage) (collect-garbage)
(update-memory-text))] (update-memory-text))])]
[init-width "99.99 MB"])]) [ec (new editor-canvas%
(set! memory-canvases (cons ec memory-canvases)) [parent panel]
[editor memory-text]
[line-count 1]
[style '(no-hscroll no-vscroll)])])
(set! memory-canvas ec)
(determine-width "99.99" ec memory-text)
(update-memory-text) (update-memory-text)
(set! memory-cleanup (set! memory-cleanup
(λ () (λ ()
(remq ec memory-canvases))) (send ec set-editor #f)))
(send panel stretchable-width #f))) (send panel stretchable-width #f)))
[define lock-canvas (make-object lock-canvas% (get-info-panel))] [define lock-canvas (make-object lock-canvas% (get-info-panel))]
@ -770,40 +722,6 @@
(let-values ([(cw ch) (send position-canvas get-client-size)]) (let-values ([(cw ch) (send position-canvas get-client-size)])
(inexact->exact (floor (- cw (unbox wb))))))) (inexact->exact (floor (- cw (unbox wb)))))))
(define position-canvas%
(class canvas%
(inherit min-client-height min-client-width get-dc get-client-size refresh)
(init init-width)
(init-field [button-up #f])
(define str "")
(define/public (set-str _str)
(set! str _str)
(update-client-width str)
(refresh))
(define/private (update-client-width str)
(let ([dc (get-dc)])
(let-values ([(cw _4) (get-client-size)]
[(tw _1 _2 _3) (send dc get-text-extent str)])
(when (< cw tw)
(min-client-width (inexact->exact (floor tw)))))))
(define/override (on-paint)
(let ([dc (get-dc)])
(let-values ([(cw ch) (get-client-size)]
[(tw th _1 _2) (send dc get-text-extent str)])
(send dc draw-text str 0 (/ (- ch th) 2)))))
(define/override (on-event evt)
(when button-up
(when (send evt button-up?)
(let-values ([(cw ch) (get-client-size)])
(when (and (<= (send evt get-x) cw)
(<= (send evt get-y) ch))
(button-up))))))
(super-new (style '(transparent)))
(let ([dc (get-dc)])
(let-values ([(_1 th _2 _3) (send dc get-text-extent str)])
(min-client-height (inexact->exact (floor th)))))
(update-client-width init-width)))
(define text-info<%> (interface (info<%>) (define text-info<%> (interface (info<%>)
set-macro-recording set-macro-recording
overwrite-status-changed overwrite-status-changed
@ -839,15 +757,15 @@
(let* ([edit (get-info-editor)] (let* ([edit (get-info-editor)]
[make-one [make-one
(λ (pos) (λ (pos)
(if line-numbers?
(let* ([line (send edit position-paragraph pos)] (let* ([line (send edit position-paragraph pos)]
[col (find-col edit line pos)]) [col (find-col edit line pos)])
(if line-numbers?
(format "~a:~a" (format "~a:~a"
(add1 line) (add1 line)
(if offset? (if offset?
(add1 col) (add1 col)
col))) col))
(format "~a" pos)))]) (format "~a" pos))))])
(cond (cond
[(not (object? position-canvas)) [(not (object? position-canvas))
(void)] (void)]
@ -863,7 +781,7 @@
(set! last-params (list offset? line-numbers?)) (set! last-params (list offset? line-numbers?))
(set! last-start start) (set! last-start start)
(set! last-end end) (set! last-end end)
(when (object? position-canvas) (when (object? position-edit)
(change-position-edit-contents (change-position-edit-contents
(if (= start end) (if (= start end)
(make-one start) (make-one start)
@ -975,9 +893,20 @@
[parent (get-info-panel)] [parent (get-info-panel)]
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f])) [stretchable-height #f]))
(define position-canvas (new position-canvas% [parent position-parent] [init-width "000:00-000:00"])) (define position-canvas (new editor-canvas%
[parent position-parent]
[style '(no-hscroll no-vscroll)]))
(define position-edit (new text%))
(define/private (change-position-edit-contents str) (define/private (change-position-edit-contents str)
(send position-canvas set-str str)) (send position-edit begin-edit-sequence)
(send position-edit lock #f)
(send position-edit erase)
(send position-edit insert str)
(ensure-enough-width position-canvas position-edit)
(send position-edit lock #t)
(send position-edit end-edit-sequence))
(send (get-info-panel) change-children (send (get-info-panel) change-children
(λ (l) (λ (l)
@ -1023,7 +952,17 @@
(send macro-recording-message show #f) (send macro-recording-message show #f)
(send anchor-message show #f) (send anchor-message show #f)
(send overwrite-message show #f) (send overwrite-message show #f)
(editor-position-changed))) (send* position-canvas
(set-line-count 1)
(set-editor position-edit)
(stretchable-width #f)
(stretchable-height #f))
(determine-width "000:00-000:00"
position-canvas
position-edit)
(editor-position-changed)
(send position-edit hide-caret #t)
(send position-edit lock #t)))
(define click-pref-panel% (define click-pref-panel%
(class horizontal-panel% (class horizontal-panel%
@ -1054,7 +993,7 @@
(define pasteboard-info<%> (interface (info<%>))) (define pasteboard-info<%> (interface (info<%>)))
(define pasteboard-info-mixin (define pasteboard-info-mixin
(mixin (basic<%>) (pasteboard-info<%>) (mixin (basic<%>) (pasteboard-info<%>)
(super-new))) (super-instantiate ())))
(include "standard-menus.ss") (include "standard-menus.ss")
@ -1715,7 +1654,7 @@
(define/public (get-delegatee) delegatee) (define/public (get-delegatee) delegatee)
(super-new) (super-instantiate ())
(define delegatee (instantiate delegatee-text% ())) (define delegatee (instantiate delegatee-text% ()))
(define delegate-ec (instantiate delegatee-editor-canvas% () (define delegate-ec (instantiate delegatee-editor-canvas% ()
@ -2110,7 +2049,7 @@
(define replace-text% (define replace-text%
(class text:keymap% (class text:keymap%
(inherit set-styles-fixed) (inherit set-styles-fixed)
(super-new) (super-instantiate ())
(set-styles-fixed #t))) (set-styles-fixed #t)))
(define find-edit #f) (define find-edit #f)
@ -2469,7 +2408,7 @@
(send replace-canvas set-editor replace-edit)) (send replace-canvas set-editor replace-edit))
(end-container-sequence))) (end-container-sequence)))
(super-new) (super-instantiate ())
(hide-search #t))) (hide-search #t)))
@ -2482,9 +2421,12 @@
(get-editor)) (get-editor))
(define/override (get-editor<%>) text:searching<%>) (define/override (get-editor<%>) text:searching<%>)
(define/override (get-editor%) text:searching%) (define/override (get-editor%) text:searching%)
(super-new))) (super-instantiate ())))
(define memory-canvases '()) (define memory-text% (class text% (super-new)))
(define memory-text (make-object memory-text%))
(define memory-canvas #f)
(send memory-text hide-caret #t)
(define show-memory-text? (define show-memory-text?
(or (with-handlers ([exn:fail:filesystem? (or (with-handlers ([exn:fail:filesystem?
(λ (x) #f)]) (λ (x) #f)])
@ -2504,7 +2446,7 @@
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant happy-birthday-matthew))] (string-constant happy-birthday-matthew))]
[else (super on-event evt)])) [else (super on-event evt)]))
(super-new))) (super-instantiate ())))
(define basic% (register-group-mixin (basic-mixin frame%))) (define basic% (register-group-mixin (basic-mixin frame%)))
(define size-pref% (size-pref-mixin basic%)) (define size-pref% (size-pref-mixin basic%))