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

contracts.ss -> contract.ss

Browse Source 
original commit: 51992dcc33e9214beb02f7ee7396d3ad8a2c2e3b
This commit is contained in:
Mike MacHenry 2003-10-18 06:44:58 +00:00
parent f83f729d72
commit 14ee490d8e
8 changed files with 220 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss
View File

@ -12,6 +12,7 @@
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "list.ss")
"snip-lib.ss"
"interface.ss"
"constants.ss")
@ -80,7 +81,7 @@
;; a snip that can contain an aligned-pasteboard<%> and also be stretched within an aligned-pasteboard<%>
(define aligned-editor-snip%
(class* editor-snip% (aligned-pasteboard-parent<%> aligned-snip<%>)
(inherit get-editor get-margin)
(inherit get-editor get-margin set-min-width set-min-height)
(init
(stretchable-width true)
@ -150,7 +151,9 @@
;; set-aligned-min-size (-> (void))
;; calculates and stores the minimum height and width of the snip
(define/public (set-aligned-min-sizes)
(send (get-editor) set-aligned-min-sizes))
(send (get-editor) set-aligned-min-sizes)
(set-min-width (get-aligned-min-width))
(set-min-height (get-aligned-min-height)))
(super-instantiate ())
))
@ -192,7 +195,15 @@
[right (box 0)]
[bottom (box 0)])
(get-margin left top right bottom)
(+ (unbox left) (unbox right))))
(+ (unbox left)
(let* ([ed (get-editor)]
[last (send ed last-line)])
(let loop ([line 0])
(if (= line last)
0
(max (send ed line-length line)
(loop (add1 line))))))
(unbox right))))
;; get-aligned-min-height (-> number?)
;; the minimum height of the snip based on the children
@ -207,6 +218,70 @@
(* (send editor line-location 0 false)
(add1 (send editor last-line))))))
; ; get-aligned-min-width (-> number?)
; ; the minimum width of the snip based on the children
; (inherit get-max-width set-max-width get-min-width set-min-width)
; (define/public (get-aligned-min-width)
; (let* ([parent (snip-parent this)]
; [ed (get-editor)]
; [ed-max (send ed get-max-width)]
; [ed-min (send ed get-min-width)]
; [this-max (get-max-width)]
; [this-min (get-min-width)])
; (when (is-a? parent aligned-pasteboard<%>)
; (send parent ignore-resizing true))
; (send parent begin-edit-sequence)
; (send ed begin-edit-sequence)
; (send ed set-max-width 'none)
; (send ed set-min-width 'none)
; (set-max-width 'none)
; (set-min-width 'none)
; (begin0
; (let ([left (box 0)]
; [top (box 0)]
; [right (box 0)]
; [bottom (box 0)])
; (get-margin left top right bottom)
; (+ (unbox left)
; (snip-width this)))
; (send ed set-max-width ed-max)
; (send ed set-max-width ed-min)
; (set-min-width this-min)
; (set-max-width this-max)
; (send ed end-edit-sequence)
; (send parent end-edit-sequence)
; (when (is-a? parent aligned-pasteboard<%>)
; (send parent ignore-resizing false)))))
;
; ; get-aligned-min-height (-> number?)
; ; the minimum height of the snip based on the children
; (inherit get-max-height set-max-height get-min-height set-min-height)
; (define/public (get-aligned-min-height)
; (let* ([parent (snip-parent this)]
; [ed (get-editor)]
; [ed-max (send ed get-max-height)]
; [ed-min (send ed get-min-height)]
; [this-max (get-max-height)]
; [this-min (get-min-height)])
; (when (is-a? parent aligned-pasteboard<%>)
; (send parent ignore-resizing true))
; (send parent begin-edit-sequence)
; (send ed begin-edit-sequence)
; (send ed set-max-height 'none)
; (send ed set-min-height 'none)
; (set-max-height 'none)
; (set-min-height 'none)
; (begin0
; (snip-height this)
; (send ed set-max-height ed-max)
; (send ed set-min-height ed-min)
; (set-min-height this-min)
; (set-max-height this-max)
; (send ed end-edit-sequence)
; (send parent end-edit-sequence)
; (when (is-a? parent aligned-pasteboard<%>)
; (send parent ignore-resizing false)))))
(super-instantiate ())
))
)

12
collects/mrlib/private/aligned-pasteboard/aligned-pasteboard.ss
View File

@ -1,11 +1,9 @@
(module aligned-pasteboard mzscheme
(require
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "click-forwarding-editor.ss" "mrlib")
"geometry-managed-pasteboard.ss"
"event-handling-pasteboard.ss"
"locked-pasteboard.ss")
(provide
@ -13,17 +11,15 @@
horizontal-pasteboard%)
;; contruct the basic mixin that both pasteboards will be created from
(define (make-aligned-pasteboard type)
(define (click/lock type)
(editor:basic-mixin
(click-forwarding-editor-mixin
(locked-pasteboard-mixin
(event-handling-pasteboard-mixin
(geometry-managed-pasteboard-mixin
pasteboard% type))))))
(make-aligned-pasteboard type)))))
(define vertical-pasteboard%
(make-aligned-pasteboard 'vertical))
(click/lock 'vertical))
(define horizontal-pasteboard%
(make-aligned-pasteboard 'horizontal))
(click/lock 'horizontal))
)

2
collects/mrlib/private/aligned-pasteboard/alignment.ss
View File

@ -22,7 +22,7 @@
(require
(lib "match.ss")
(lib "contracts.ss")
(lib "contract.ss")
(lib "etc.ss")
(lib "list.ss"))

137
collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss
View File

@ -2,21 +2,22 @@
(require
(lib "class.ss")
(lib "contracts.ss")
(lib "contract.ss")
(lib "list.ss")
(lib "etc.ss")
(lib "match.ss")
"interface.ss"
(lib "mred.ss" "mred") "interface.ss"
"alignment.ss"
"snip-lib.ss")
"snip-lib.ss"
"pasteboard-lib.ss")
(provide/contract
(geometry-managed-pasteboard-mixin (class? (symbols 'vertical 'horizontal) . -> . class?)))
(make-aligned-pasteboard ((symbols 'vertical 'horizontal) . -> . class?)))
;; mixin to add geometry management to pasteboard with the give type of alignement
(define (geometry-managed-pasteboard-mixin super% type)
(class* super% (aligned-pasteboard<%>)
(inherit resize move-to find-first-snip
(define (make-aligned-pasteboard type)
(class* pasteboard% (aligned-pasteboard<%>)
(inherit resize move-to find-first-snip refresh-delayed?
begin-edit-sequence end-edit-sequence)
(field
@ -28,6 +29,10 @@
[aligned-min-height 0]
[aligned-rects empty])
;;temp fix
(define/public (ignore-resizing ignore?)
(set! ignore-resizing? ignore?))
;; get-aligned-min-width (-> number?)
;; the aligned-min-width of the pasteboard
(define/public (get-aligned-min-width)
@ -81,8 +86,122 @@
($ dim x width stretchable-width?)
($ dim y height stretchable-height?)))
(move-to snip x y)
(when (or stretchable-height? stretchable-width?)
(resize snip width height))]))
(when (or stretchable-height? stretchable-width? (is-a? snip aligned-pasteboard-parent<%>))
(resize snip width height))
;(resize snip width height)
;(when (is-a? snip editor-snip%)
; (send snip set-min-width 'none)
; (send (send snip get-editor) set-min-width 'none))
]))
(field [in-edit-sequence? false])
;; after-insert ((is-a?/c snip%) (is-a?/c snip%) number? number? . -> . void?)
;; called after a snip is inserted to the pasteboard
(rename [super-after-insert after-insert])
(define/override (after-insert snip before x y)
(calc/realign)
(super-after-insert snip before x y))
;; after-delete ((is-a?/c snip%) . -> . void?)
;; called after a snip is deleted from the pasteboard%
(rename [super-after-delete after-delete])
(define/override (after-delete snip)
(calc/realign)
(super-after-delete snip))
;; after-reorder ((is-a?/c snip%) (is-a?/c snip%) boolean? . -> . void?)
;; called after a snip is moved in the front to back snip order
(rename [super-after-reorder after-reorder])
(define/override (after-reorder snip to-snip before?)
(realign)
(super-after-reorder snip to-snip before?))
;; resized ((is-a?/c snip%) . -> . void?)
;; called when a snip inside the editor is resized
(rename [super-resized resized])
(define/override (resized snip redraw-now?)
(super-resized snip redraw-now?)
(unless ignore-resizing?
(when (or redraw-now?
(and (not (refresh-delayed?))
(needs-resize? snip)
))
(calc/realign))))
;; after-edit-sequence (-> void?)
;; called after an edit-sequence ends
(rename [super-after-edit-sequence after-edit-sequence])
(define/override (after-edit-sequence)
(set! in-edit-sequence? false)
(when needs-realign? (calc/realign)))
(rename [super-on-edit-sequence on-edit-sequence])
(define/override (on-edit-sequence)
(set! in-edit-sequence? true)
(super-on-edit-sequence))
;; calc/realign (-> void?)
;; sends a message to the pasteboard to recalculate min sizes and realign
(define/private (calc/realign)
(if in-edit-sequence?
(set! needs-realign? true)
(let* ([root (pasteboard-root this)]
[parent (pasteboard-parent root)])
(when parent
(send parent set-aligned-min-sizes)
(send root realign)))))
;; needs-resize? ((is-a?/c snip%) . -> . boolean?)
;; determines if the snip's size is smaller than it's min size
(define/private (needs-resize? snip)
(with-handlers ([exn? (lambda a false)])
(match-let ([($ rect
($ dim _ alloted-width _)
($ dim _ alloted-height _))
(find-rect snip)])
(if (is-a? snip aligned-snip<%>)
(or (< alloted-width (send snip get-aligned-min-width))
(< alloted-height (send snip get-aligned-min-height)))
(if (empty? aligned-rects)
false
(match-let ([($ rect
($ dim _ actual-width _)
($ dim _ actual-height _))
(build-rect snip)])
(not (and (= alloted-width actual-width)
(= alloted-height actual-height)))))))))
;(define/private (needs-resize? snip)
; (cond
; [(is-a? snip aligned-snip<%>)
; (or (< (snip-width snip)
; (send snip get-aligned-min-width))
; (< (snip-height snip)
; (send snip get-aligned-min-height))
; (and (not (send snip stretchable-width))
; (> (snip-width snip)
; (send snip get-aligned-min-width)))
; (and (not (send snip stretchable-height))
; (> (snip-height snip)
; (send snip get-aligned-min-height))))]
; [else false]))
;; find-rect ((is-a?/c snip%) . -> . rect?)
;; finds the rect that corresponds to the given snip
(define/private (find-rect target-snip)
(letrec ([find-rect-aux
(lambda (snip rects)
(cond
[(or (equal? snip false) (empty? rects))
(error 'find-rect "Snip not found")]
[else
(if (equal? snip target-snip)
(car rects)
(find-rect-aux (send snip next)
(rest rects)))]))])
(find-rect-aux (find-first-snip) aligned-rects)))
(super-instantiate ())
))

3
collects/mrlib/private/aligned-pasteboard/interface.ss
View File

@ -12,6 +12,9 @@
;; the interface that must be implemented for a pasteboard to be contained in an aligned-pasteboard-parent<%>
(define aligned-pasteboard<%>
(interface (editor<%>)
;; temp fix
ignore-resizing
;; get-alignment (-> (values symbol? symbol?))
;; get the pasteboards current alignment specification
;; status: possible future feature

2
collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss
View File

@ -3,7 +3,7 @@
(require
(lib "class.ss")
(lib "etc.ss")
(lib "contracts.ss"))
(lib "contract.ss"))
(provide/contract
(locked-pasteboard-mixin mixin-contract))

2
collects/mrlib/private/aligned-pasteboard/pasteboard-lib.ss
View File

@ -3,7 +3,7 @@
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "contracts.ss")
(lib "contract.ss")
(lib "etc.ss")
"interface.ss"
"snip-lib.ss")

2
collects/mrlib/private/aligned-pasteboard/snip-lib.ss
View File

@ -5,7 +5,7 @@
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "list.ss")
(lib "contracts.ss")
(lib "contract.ss")
"interface.ss")
;; a snip