retabified
svn: r6999 original commit: 6479c5483d7d4e0690b013f691869b8f804a58ba
This commit is contained in:
Robby Findler
parent
a7d7cb5247
commit
ded3fd08be
|
|
@ -2,8 +2,8 @@
|
||||||
(module autosave (lib "a-unit.ss")
|
(module autosave (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
|
|
@ -20,296 +20,296 @@
|
||||||
|
|
||||||
(export framework:autosave^)
|
(export framework:autosave^)
|
||||||
|
|
||||||
(define autosavable<%>
|
(define autosavable<%>
|
||||||
(interface ()
|
(interface ()
|
||||||
do-autosave))
|
do-autosave))
|
||||||
|
|
||||||
(define objects null)
|
(define objects null)
|
||||||
|
|
||||||
(define autosave-toc-filename
|
(define autosave-toc-filename
|
||||||
(build-path (find-system-path 'pref-dir)
|
(build-path (find-system-path 'pref-dir)
|
||||||
(case (system-type)
|
(case (system-type)
|
||||||
[(unix) ".plt-autosave-toc"]
|
[(unix) ".plt-autosave-toc"]
|
||||||
[else "PLT-autosave-toc"])))
|
[else "PLT-autosave-toc"])))
|
||||||
|
|
||||||
(define autosave-toc-save-filename
|
(define autosave-toc-save-filename
|
||||||
(build-path (find-system-path 'pref-dir)
|
(build-path (find-system-path 'pref-dir)
|
||||||
(case (system-type)
|
(case (system-type)
|
||||||
[(unix) ".plt-autosave-toc-save"]
|
[(unix) ".plt-autosave-toc-save"]
|
||||||
[else "PLT-autosave-toc-save"])))
|
[else "PLT-autosave-toc-save"])))
|
||||||
|
|
||||||
(define autosave-timer%
|
(define autosave-timer%
|
||||||
(class timer%
|
(class timer%
|
||||||
(inherit start)
|
(inherit start)
|
||||||
(field [last-name-mapping #f])
|
(field [last-name-mapping #f])
|
||||||
(define/override (notify)
|
(define/override (notify)
|
||||||
(when (preferences:get 'framework:autosaving-on?)
|
(when (preferences:get 'framework:autosaving-on?)
|
||||||
(let-values ([(new-objects new-name-mapping) (rebuild-object-list)])
|
(let-values ([(new-objects new-name-mapping) (rebuild-object-list)])
|
||||||
(set! objects new-objects)
|
(set! objects new-objects)
|
||||||
(unless (equal? last-name-mapping new-name-mapping)
|
(unless (equal? last-name-mapping new-name-mapping)
|
||||||
(set! last-name-mapping new-name-mapping)
|
(set! last-name-mapping new-name-mapping)
|
||||||
(when (file-exists? autosave-toc-save-filename)
|
(when (file-exists? autosave-toc-save-filename)
|
||||||
(delete-file autosave-toc-save-filename))
|
(delete-file autosave-toc-save-filename))
|
||||||
(when (file-exists? autosave-toc-filename)
|
(when (file-exists? autosave-toc-filename)
|
||||||
(copy-file autosave-toc-filename autosave-toc-save-filename))
|
(copy-file autosave-toc-filename autosave-toc-save-filename))
|
||||||
(call-with-output-file autosave-toc-filename
|
(call-with-output-file autosave-toc-filename
|
||||||
(λ (port)
|
(λ (port)
|
||||||
(write new-name-mapping port))
|
(write new-name-mapping port))
|
||||||
'truncate
|
'truncate
|
||||||
'text))))
|
'text))))
|
||||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||||
(start (* 1000 seconds) #t)))
|
(start (* 1000 seconds) #t)))
|
||||||
(super-new)
|
(super-new)
|
||||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||||
(start (* 1000 seconds) #t))))
|
(start (* 1000 seconds) #t))))
|
||||||
|
|
||||||
;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>)))
|
;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>)))
|
||||||
;; (listof (list (union #f string[filename]) string[filename]))
|
;; (listof (list (union #f string[filename]) string[filename]))
|
||||||
(define (rebuild-object-list)
|
(define (rebuild-object-list)
|
||||||
(let loop ([orig-objects objects]
|
(let loop ([orig-objects objects]
|
||||||
[name-mapping null]
|
[name-mapping null]
|
||||||
[new-objects null])
|
[new-objects null])
|
||||||
(if (null? orig-objects)
|
(if (null? orig-objects)
|
||||||
(values new-objects name-mapping)
|
(values new-objects name-mapping)
|
||||||
(let* ([object-wb (car orig-objects)]
|
(let* ([object-wb (car orig-objects)]
|
||||||
[object (weak-box-value object-wb)])
|
[object (weak-box-value object-wb)])
|
||||||
(if object
|
(if object
|
||||||
(let* ([new-filename (send object do-autosave)]
|
(let* ([new-filename (send object do-autosave)]
|
||||||
[tmp-box (box #f)]
|
[tmp-box (box #f)]
|
||||||
[filename (send object get-filename tmp-box)])
|
[filename (send object get-filename tmp-box)])
|
||||||
(loop (cdr orig-objects)
|
(loop (cdr orig-objects)
|
||||||
(if new-filename
|
(if new-filename
|
||||||
(cons (list (and (not (unbox tmp-box)) filename)
|
(cons (list (and (not (unbox tmp-box)) filename)
|
||||||
new-filename)
|
new-filename)
|
||||||
name-mapping)
|
name-mapping)
|
||||||
name-mapping)
|
name-mapping)
|
||||||
(cons object-wb new-objects)))
|
(cons object-wb new-objects)))
|
||||||
(loop (cdr orig-objects)
|
(loop (cdr orig-objects)
|
||||||
name-mapping
|
name-mapping
|
||||||
new-objects))))))
|
new-objects))))))
|
||||||
|
|
||||||
(define timer #f)
|
(define timer #f)
|
||||||
|
|
||||||
(define (register b)
|
(define (register b)
|
||||||
(unless timer
|
(unless timer
|
||||||
(set! timer (make-object autosave-timer%)))
|
(set! timer (make-object autosave-timer%)))
|
||||||
(set! objects
|
(set! objects
|
||||||
(let loop ([objects objects])
|
(let loop ([objects objects])
|
||||||
(cond
|
(cond
|
||||||
[(null? objects) (list (make-weak-box b))]
|
[(null? objects) (list (make-weak-box b))]
|
||||||
[else (let ([weak-box (car objects)])
|
[else (let ([weak-box (car objects)])
|
||||||
(if (weak-box-value weak-box)
|
(if (weak-box-value weak-box)
|
||||||
(cons weak-box (loop (cdr objects)))
|
(cons weak-box (loop (cdr objects)))
|
||||||
(loop (cdr objects))))]))))
|
(loop (cdr objects))))]))))
|
||||||
|
|
||||||
;; restore-autosave-files/gui : -> (union #f (is-a?/c top-level-window<%>))
|
;; restore-autosave-files/gui : -> (union #f (is-a?/c top-level-window<%>))
|
||||||
;; opens a frame that lists the autosave files that have changed.
|
;; opens a frame that lists the autosave files that have changed.
|
||||||
(define (restore-autosave-files/gui)
|
(define (restore-autosave-files/gui)
|
||||||
|
|
||||||
;; main : -> void
|
;; main : -> void
|
||||||
;; start everything going
|
;; start everything going
|
||||||
(define (main)
|
(define (main)
|
||||||
(when (file-exists? autosave-toc-filename)
|
(when (file-exists? autosave-toc-filename)
|
||||||
;; Load table from file, and check that the file was not corrupted
|
;; Load table from file, and check that the file was not corrupted
|
||||||
(let* ([table (let ([v (with-handlers ([exn:fail? (λ (x) null)])
|
(let* ([table (let ([v (with-handlers ([exn:fail? (λ (x) null)])
|
||||||
(call-with-input-file autosave-toc-filename read))]
|
(call-with-input-file autosave-toc-filename read))]
|
||||||
[path? (λ (x)
|
[path? (λ (x)
|
||||||
(and (string? x)
|
(and (string? x)
|
||||||
(absolute-path? x)))])
|
(absolute-path? x)))])
|
||||||
(if (and (list? v)
|
(if (and (list? v)
|
||||||
(andmap (λ (i)
|
(andmap (λ (i)
|
||||||
(and (list? i)
|
(and (list? i)
|
||||||
(= 2 (length i))
|
(= 2 (length i))
|
||||||
(or (not (car i))
|
(or (not (car i))
|
||||||
(path? (car i)))
|
(path? (car i)))
|
||||||
(path? (cadr i))))
|
(path? (cadr i))))
|
||||||
v))
|
v))
|
||||||
v
|
v
|
||||||
null))]
|
null))]
|
||||||
;; assume that the autosave file was deleted due to the file being saved
|
;; assume that the autosave file was deleted due to the file being saved
|
||||||
[filtered-table
|
[filtered-table
|
||||||
(filter (λ (x) (file-exists? (cadr x))) table)])
|
(filter (λ (x) (file-exists? (cadr x))) table)])
|
||||||
(unless (null? filtered-table)
|
(unless (null? filtered-table)
|
||||||
(let* ([f (new final-frame%
|
(let* ([f (new final-frame%
|
||||||
(label (string-constant recover-autosave-files-frame-title)))]
|
(label (string-constant recover-autosave-files-frame-title)))]
|
||||||
[t (new text% (auto-wrap #t))]
|
[t (new text% (auto-wrap #t))]
|
||||||
[ec (new editor-canvas%
|
[ec (new editor-canvas%
|
||||||
(parent (send f get-area-container))
|
(parent (send f get-area-container))
|
||||||
(editor t)
|
(editor t)
|
||||||
(line-count 2)
|
(line-count 2)
|
||||||
(style '(no-hscroll)))]
|
(style '(no-hscroll)))]
|
||||||
[hp (make-object horizontal-panel% (send f get-area-container))]
|
[hp (make-object horizontal-panel% (send f get-area-container))]
|
||||||
[vp (make-object vertical-panel% hp)])
|
[vp (make-object vertical-panel% hp)])
|
||||||
(send vp set-alignment 'right 'center)
|
(send vp set-alignment 'right 'center)
|
||||||
(make-object grow-box-spacer-pane% hp)
|
(make-object grow-box-spacer-pane% hp)
|
||||||
(send t insert (string-constant autosave-explanation))
|
(send t insert (string-constant autosave-explanation))
|
||||||
(send t hide-caret #t)
|
(send t hide-caret #t)
|
||||||
(send t set-position 0 0)
|
(send t set-position 0 0)
|
||||||
(send t lock #t)
|
(send t lock #t)
|
||||||
|
|
||||||
(for-each (add-table-line vp f) filtered-table)
|
(for-each (add-table-line vp f) filtered-table)
|
||||||
(make-object button%
|
(make-object button%
|
||||||
(string-constant autosave-done)
|
(string-constant autosave-done)
|
||||||
vp
|
vp
|
||||||
(λ (x y)
|
(λ (x y)
|
||||||
(when (send f can-close?)
|
(when (send f can-close?)
|
||||||
(send f on-close)
|
(send f on-close)
|
||||||
(send f show #f))))
|
(send f show #f))))
|
||||||
(send f show #t)
|
(send f show #t)
|
||||||
(yield done-semaphore)
|
(yield done-semaphore)
|
||||||
(void))))))
|
(void))))))
|
||||||
|
|
||||||
(define done-semaphore (make-semaphore 0))
|
(define done-semaphore (make-semaphore 0))
|
||||||
|
|
||||||
(define final-frame%
|
(define final-frame%
|
||||||
(class frame:basic%
|
(class frame:basic%
|
||||||
(define/augment (can-close?) #t)
|
(define/augment (can-close?) #t)
|
||||||
(define/augment (on-close)
|
(define/augment (on-close)
|
||||||
(inner (void) on-close)
|
(inner (void) on-close)
|
||||||
(send (group:get-the-frame-group)
|
(send (group:get-the-frame-group)
|
||||||
remove-frame
|
remove-frame
|
||||||
this)
|
this)
|
||||||
(semaphore-post done-semaphore))
|
(semaphore-post done-semaphore))
|
||||||
(super-new)))
|
(super-new)))
|
||||||
|
|
||||||
;; add-table-line : (is-a? area-container<%>) (union #f (is-a?/c top-level-window<%>))
|
;; add-table-line : (is-a? area-container<%>) (union #f (is-a?/c top-level-window<%>))
|
||||||
;; -> (list (union #f string[filename]) string[filename-file-exists?])
|
;; -> (list (union #f string[filename]) string[filename-file-exists?])
|
||||||
;; -> void
|
;; -> void
|
||||||
;; adds in a line to the overview table showing this pair of files.
|
;; adds in a line to the overview table showing this pair of files.
|
||||||
(define (add-table-line area-container parent)
|
(define (add-table-line area-container parent)
|
||||||
(λ (table-entry)
|
(λ (table-entry)
|
||||||
(letrec ([orig-file (car table-entry)]
|
(letrec ([orig-file (car table-entry)]
|
||||||
[backup-file (cadr table-entry)]
|
[backup-file (cadr table-entry)]
|
||||||
[hp (new horizontal-panel%
|
[hp (new horizontal-panel%
|
||||||
(parent area-container)
|
(parent area-container)
|
||||||
(style '(border))
|
(style '(border))
|
||||||
(stretchable-height #f))]
|
(stretchable-height #f))]
|
||||||
[vp (new vertical-panel%
|
[vp (new vertical-panel%
|
||||||
(parent hp))]
|
(parent hp))]
|
||||||
[msg1-panel (new horizontal-panel%
|
[msg1-panel (new horizontal-panel%
|
||||||
(parent vp))]
|
(parent vp))]
|
||||||
[msg1-label (new message%
|
[msg1-label (new message%
|
||||||
(parent msg1-panel)
|
(parent msg1-panel)
|
||||||
(label (string-constant autosave-original-label:)))]
|
(label (string-constant autosave-original-label:)))]
|
||||||
[msg1 (new message%
|
[msg1 (new message%
|
||||||
(label (or orig-file (string-constant autosave-unknown-filename)))
|
(label (or orig-file (string-constant autosave-unknown-filename)))
|
||||||
(stretchable-width #t)
|
(stretchable-width #t)
|
||||||
(parent msg1-panel))]
|
(parent msg1-panel))]
|
||||||
[msg2-panel (new horizontal-panel%
|
[msg2-panel (new horizontal-panel%
|
||||||
(parent vp))]
|
(parent vp))]
|
||||||
[msg2-label (new message%
|
[msg2-label (new message%
|
||||||
(parent msg2-panel)
|
(parent msg2-panel)
|
||||||
(label (string-constant autosave-autosave-label:)))]
|
(label (string-constant autosave-autosave-label:)))]
|
||||||
[msg2 (new message%
|
[msg2 (new message%
|
||||||
(label backup-file)
|
(label backup-file)
|
||||||
(stretchable-width #t)
|
(stretchable-width #t)
|
||||||
(parent msg2-panel))]
|
(parent msg2-panel))]
|
||||||
[details
|
[details
|
||||||
(make-object button% (string-constant autosave-details) hp
|
(make-object button% (string-constant autosave-details) hp
|
||||||
(λ (x y)
|
(λ (x y)
|
||||||
(show-files table-entry)))]
|
(show-files table-entry)))]
|
||||||
[delete
|
[delete
|
||||||
(make-object button%
|
(make-object button%
|
||||||
(string-constant autosave-delete-button)
|
(string-constant autosave-delete-button)
|
||||||
hp
|
hp
|
||||||
(λ (delete y)
|
(λ (delete y)
|
||||||
(when (delete-autosave table-entry)
|
(when (delete-autosave table-entry)
|
||||||
(disable-line)
|
(disable-line)
|
||||||
(send msg2 set-label (string-constant autosave-deleted)))))]
|
(send msg2 set-label (string-constant autosave-deleted)))))]
|
||||||
[recover
|
[recover
|
||||||
(make-object button%
|
(make-object button%
|
||||||
(string-constant autosave-recover)
|
(string-constant autosave-recover)
|
||||||
hp
|
hp
|
||||||
(λ (recover y)
|
(λ (recover y)
|
||||||
(let ([filename-result (recover-file parent table-entry)])
|
(let ([filename-result (recover-file parent table-entry)])
|
||||||
(when filename-result
|
(when filename-result
|
||||||
(disable-line)
|
(disable-line)
|
||||||
(send msg2 set-label (string-constant autosave-recovered!))
|
(send msg2 set-label (string-constant autosave-recovered!))
|
||||||
(send msg1 set-label filename-result)))))]
|
(send msg1 set-label filename-result)))))]
|
||||||
[disable-line
|
[disable-line
|
||||||
(λ ()
|
(λ ()
|
||||||
(send recover enable #f)
|
(send recover enable #f)
|
||||||
(send details enable #f)
|
(send details enable #f)
|
||||||
(send delete enable #f))])
|
(send delete enable #f))])
|
||||||
(let ([w (max (send msg1-label get-width) (send msg2-label get-width))])
|
(let ([w (max (send msg1-label get-width) (send msg2-label get-width))])
|
||||||
(send msg1-label min-width w)
|
(send msg1-label min-width w)
|
||||||
(send msg2-label min-width w))
|
(send msg2-label min-width w))
|
||||||
(void))))
|
(void))))
|
||||||
|
|
||||||
;; delete-autosave : (list (union #f string[filename]) string[filename]) -> boolean
|
;; delete-autosave : (list (union #f string[filename]) string[filename]) -> boolean
|
||||||
;; result indicates if delete occurred
|
;; result indicates if delete occurred
|
||||||
(define (delete-autosave table-entry)
|
(define (delete-autosave table-entry)
|
||||||
(let ([autosave-file (cadr table-entry)])
|
(let ([autosave-file (cadr table-entry)])
|
||||||
(and (gui-utils:get-choice
|
(and (gui-utils:get-choice
|
||||||
(format (string-constant are-you-sure-delete?)
|
(format (string-constant are-you-sure-delete?)
|
||||||
autosave-file)
|
autosave-file)
|
||||||
(string-constant autosave-delete-title)
|
(string-constant autosave-delete-title)
|
||||||
(string-constant cancel)
|
(string-constant cancel)
|
||||||
(string-constant warning)
|
(string-constant warning)
|
||||||
#f)
|
#f)
|
||||||
(with-handlers ([exn:fail?
|
(with-handlers ([exn:fail?
|
||||||
(λ (exn)
|
(λ (exn)
|
||||||
(message-box
|
(message-box
|
||||||
(string-constant warning)
|
(string-constant warning)
|
||||||
(format (string-constant autosave-error-deleting)
|
(format (string-constant autosave-error-deleting)
|
||||||
autosave-file
|
autosave-file
|
||||||
(if (exn? exn)
|
(if (exn? exn)
|
||||||
(format "~a" (exn-message exn))
|
(format "~a" (exn-message exn))
|
||||||
(format "~s" exn))))
|
(format "~s" exn))))
|
||||||
#f)])
|
#f)])
|
||||||
(delete-file autosave-file)
|
(delete-file autosave-file)
|
||||||
#t))))
|
#t))))
|
||||||
|
|
||||||
;; show-files : (list (union #f string[filename]) string) -> void
|
;; show-files : (list (union #f string[filename]) string) -> void
|
||||||
(define (show-files table-entry)
|
(define (show-files table-entry)
|
||||||
(let ([file1 (car table-entry)]
|
(let ([file1 (car table-entry)]
|
||||||
[file2 (cadr table-entry)])
|
[file2 (cadr table-entry)])
|
||||||
(define frame (make-object show-files-frame%
|
(define frame (make-object show-files-frame%
|
||||||
(if file1
|
(if file1
|
||||||
(string-constant autosave-compare-files)
|
(string-constant autosave-compare-files)
|
||||||
(string-constant autosave-show-autosave))
|
(string-constant autosave-show-autosave))
|
||||||
#f
|
#f
|
||||||
(if file1 600 300)
|
(if file1 600 300)
|
||||||
600))
|
600))
|
||||||
(define hp (new horizontal-panel%
|
(define hp (new horizontal-panel%
|
||||||
(parent (send frame get-area-container))))
|
(parent (send frame get-area-container))))
|
||||||
(when file1
|
(when file1
|
||||||
(add-file-viewer file1 hp (string-constant autosave-original-label)))
|
(add-file-viewer file1 hp (string-constant autosave-original-label)))
|
||||||
(add-file-viewer file2 hp (string-constant autosave-autosave-label))
|
(add-file-viewer file2 hp (string-constant autosave-autosave-label))
|
||||||
(send frame show #t)))
|
(send frame show #t)))
|
||||||
|
|
||||||
;; add-file-viewer : string[filename] -> void
|
;; add-file-viewer : string[filename] -> void
|
||||||
(define (add-file-viewer filename parent label)
|
(define (add-file-viewer filename parent label)
|
||||||
(define vp (make-object vertical-panel% parent))
|
(define vp (make-object vertical-panel% parent))
|
||||||
(define t (make-object show-files-text%))
|
(define t (make-object show-files-text%))
|
||||||
(define msg1 (make-object message% label vp))
|
(define msg1 (make-object message% label vp))
|
||||||
(define msg2 (make-object message% filename vp))
|
(define msg2 (make-object message% filename vp))
|
||||||
(define ec (make-object editor-canvas% vp t))
|
(define ec (make-object editor-canvas% vp t))
|
||||||
(send t load-file filename)
|
(send t load-file filename)
|
||||||
(send t hide-caret #t)
|
(send t hide-caret #t)
|
||||||
(send t lock #t))
|
(send t lock #t))
|
||||||
|
|
||||||
(define show-files-frame% frame:basic%)
|
(define show-files-frame% frame:basic%)
|
||||||
(define show-files-text% text:keymap%)
|
(define show-files-text% text:keymap%)
|
||||||
|
|
||||||
(main))
|
(main))
|
||||||
|
|
||||||
;; recover-file : (union #f (is-a?/c toplevel-window<%>))
|
;; recover-file : (union #f (is-a?/c toplevel-window<%>))
|
||||||
;; (list (union #f string[filename]) string)
|
;; (list (union #f string[filename]) string)
|
||||||
;; -> (union #f string)
|
;; -> (union #f string)
|
||||||
(define (recover-file parent table-entry)
|
(define (recover-file parent table-entry)
|
||||||
(let ([orig-name (or (car table-entry)
|
(let ([orig-name (or (car table-entry)
|
||||||
(parameterize ([finder:dialog-parent-parameter parent])
|
(parameterize ([finder:dialog-parent-parameter parent])
|
||||||
(finder:put-file #f #f #f
|
(finder:put-file #f #f #f
|
||||||
(string-constant autosave-restore-to-where?))))])
|
(string-constant autosave-restore-to-where?))))])
|
||||||
(and orig-name
|
(and orig-name
|
||||||
(let ([autosave-name (cadr table-entry)])
|
(let ([autosave-name (cadr table-entry)])
|
||||||
(let ([tmp-name (and (file-exists? orig-name)
|
(let ([tmp-name (and (file-exists? orig-name)
|
||||||
(make-temporary-file "autosave-repair~a" orig-name))])
|
(make-temporary-file "autosave-repair~a" orig-name))])
|
||||||
(when (file-exists? orig-name)
|
(when (file-exists? orig-name)
|
||||||
(delete-file orig-name))
|
(delete-file orig-name))
|
||||||
(copy-file autosave-name orig-name)
|
(copy-file autosave-name orig-name)
|
||||||
(delete-file autosave-name)
|
(delete-file autosave-name)
|
||||||
(when tmp-name
|
(when tmp-name
|
||||||
(delete-file tmp-name))
|
(delete-file tmp-name))
|
||||||
orig-name))))))
|
orig-name))))))
|
||||||
|
|
|
||||||
|
|
@ -1,181 +1,181 @@
|
||||||
(module canvas (lib "a-unit.ss")
|
(module canvas (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix frame: framework:frame^]
|
[prefix frame: framework:frame^]
|
||||||
[prefix text: framework:text^])
|
[prefix text: framework:text^])
|
||||||
|
|
||||||
(export (rename framework:canvas^
|
(export (rename framework:canvas^
|
||||||
(-color% color%)))
|
(-color% color%)))
|
||||||
|
|
||||||
|
(define basic<%> (interface ((class->interface editor-canvas%))))
|
||||||
|
(define basic-mixin
|
||||||
|
(mixin ((class->interface editor-canvas%)) (basic<%>)
|
||||||
|
(super-new)))
|
||||||
|
|
||||||
|
(define color<%> (interface (basic<%>)))
|
||||||
|
|
||||||
|
(define color-mixin
|
||||||
|
(mixin (basic<%>) (color<%>)
|
||||||
|
(define callback (λ (p v) (set-canvas-background v)))
|
||||||
|
(super-new)
|
||||||
|
(inherit set-canvas-background)
|
||||||
|
(set-canvas-background (preferences:get 'framework:basic-canvas-background))
|
||||||
|
(preferences:add-callback 'framework:basic-canvas-background callback #t)))
|
||||||
|
|
||||||
|
(define delegate<%> (interface (basic<%>)))
|
||||||
|
|
||||||
|
(define delegate-mixin
|
||||||
|
(mixin (basic<%>) (delegate<%>)
|
||||||
|
(inherit get-top-level-window)
|
||||||
|
(define/override (on-superwindow-show shown?)
|
||||||
|
(send (send (get-top-level-window) get-delegatee) set-start/end-para #f #f)
|
||||||
|
(super on-superwindow-show shown?))
|
||||||
|
(super-instantiate ())))
|
||||||
|
|
||||||
|
(define info<%> (interface (basic<%>)))
|
||||||
|
;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>)))
|
||||||
|
(define info-mixin
|
||||||
|
(mixin (basic<%>) (info<%>)
|
||||||
|
(inherit has-focus? get-top-level-window)
|
||||||
|
(define/override (on-focus on?)
|
||||||
|
(super on-focus on?)
|
||||||
|
(send (get-top-level-window) set-info-canvas (and on? this))
|
||||||
|
(when on?
|
||||||
|
(send (get-top-level-window) update-info)))
|
||||||
|
(define/override (set-editor m)
|
||||||
|
(super set-editor m)
|
||||||
|
(let ([tlw (get-top-level-window)])
|
||||||
|
(when (eq? this (send tlw get-info-canvas))
|
||||||
|
(send tlw update-info))))
|
||||||
|
|
||||||
(define basic<%> (interface ((class->interface editor-canvas%))))
|
(super-new)
|
||||||
(define basic-mixin
|
|
||||||
(mixin ((class->interface editor-canvas%)) (basic<%>)
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
(define color<%> (interface (basic<%>)))
|
(unless (is-a? (get-top-level-window) frame:info<%>)
|
||||||
|
(error 'canvas:text-info-mixin
|
||||||
|
"expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e"
|
||||||
|
(get-top-level-window)))
|
||||||
|
|
||||||
(define color-mixin
|
(when (has-focus?)
|
||||||
(mixin (basic<%>) (color<%>)
|
(send (get-top-level-window) update-info))))
|
||||||
(define callback (λ (p v) (set-canvas-background v)))
|
|
||||||
(super-new)
|
(define wide-snip<%> (interface (basic<%>)
|
||||||
(inherit set-canvas-background)
|
recalc-snips
|
||||||
(set-canvas-background (preferences:get 'framework:basic-canvas-background))
|
add-wide-snip
|
||||||
(preferences:add-callback 'framework:basic-canvas-background callback #t)))
|
add-tall-snip))
|
||||||
|
|
||||||
(define delegate<%> (interface (basic<%>)))
|
(define wide-snip-mixin
|
||||||
|
(mixin (basic<%>) (wide-snip<%>)
|
||||||
(define delegate-mixin
|
(inherit get-editor)
|
||||||
(mixin (basic<%>) (delegate<%>)
|
(define/private ((update-snip-size width?) s)
|
||||||
(inherit get-top-level-window)
|
(let* ([width (box 0)]
|
||||||
(define/override (on-superwindow-show shown?)
|
[height (box 0)]
|
||||||
(send (send (get-top-level-window) get-delegatee) set-start/end-para #f #f)
|
[leftm (box 0)]
|
||||||
(super on-superwindow-show shown?))
|
[rightm (box 0)]
|
||||||
(super-instantiate ())))
|
[topm (box 0)]
|
||||||
|
[bottomm (box 0)]
|
||||||
(define info<%> (interface (basic<%>)))
|
[left-edge-box (box 0)]
|
||||||
;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>)))
|
[top-edge-box (box 0)]
|
||||||
(define info-mixin
|
[snip-media (send s get-editor)]
|
||||||
(mixin (basic<%>) (info<%>)
|
[edit (get-editor)]
|
||||||
(inherit has-focus? get-top-level-window)
|
[get-width
|
||||||
(define/override (on-focus on?)
|
(let ([bl (box 0)]
|
||||||
(super on-focus on?)
|
[br (box 0)])
|
||||||
(send (get-top-level-window) set-info-canvas (and on? this))
|
(λ (s)
|
||||||
(when on?
|
(send edit get-snip-location s bl #f #f)
|
||||||
(send (get-top-level-window) update-info)))
|
(send edit get-snip-location s br #f #t)
|
||||||
(define/override (set-editor m)
|
(- (unbox br) (unbox bl))))]
|
||||||
(super set-editor m)
|
[calc-after-width
|
||||||
(let ([tlw (get-top-level-window)])
|
(λ (s)
|
||||||
(when (eq? this (send tlw get-info-canvas))
|
(+ 4 ;; this is compensate for an autowrapping bug
|
||||||
(send tlw update-info))))
|
(let loop ([s s])
|
||||||
|
(cond
|
||||||
(super-new)
|
[(not s) 0]
|
||||||
|
[(member 'hard-newline (send s get-flags)) (get-width s)]
|
||||||
(unless (is-a? (get-top-level-window) frame:info<%>)
|
[(member 'newline (send s get-flags)) (get-width s)]
|
||||||
(error 'canvas:text-info-mixin
|
[else
|
||||||
"expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e"
|
(+ (get-width s)
|
||||||
(get-top-level-window)))
|
2 ;; for the caret
|
||||||
|
(loop (send s next)))]))))])
|
||||||
(when (has-focus?)
|
(when edit
|
||||||
(send (get-top-level-window) update-info))))
|
(send edit
|
||||||
|
run-after-edit-sequence
|
||||||
(define wide-snip<%> (interface (basic<%>)
|
(λ ()
|
||||||
recalc-snips
|
(let ([admin (send edit get-admin)])
|
||||||
add-wide-snip
|
(send admin get-view #f #f width height)
|
||||||
add-tall-snip))
|
(send s get-margin leftm topm rightm bottomm)
|
||||||
|
|
||||||
(define wide-snip-mixin
|
|
||||||
(mixin (basic<%>) (wide-snip<%>)
|
;; when the width is to be maximized and there is a
|
||||||
(inherit get-editor)
|
;; newline just behind the snip, we know that the left
|
||||||
(define/private ((update-snip-size width?) s)
|
;; edge is zero. Special case for efficiency in the
|
||||||
(let* ([width (box 0)]
|
;; console printer
|
||||||
[height (box 0)]
|
(let ([fallback
|
||||||
[leftm (box 0)]
|
(λ ()
|
||||||
[rightm (box 0)]
|
(send edit get-snip-location s left-edge-box top-edge-box))])
|
||||||
[topm (box 0)]
|
(cond
|
||||||
[bottomm (box 0)]
|
[(not width?) (fallback)]
|
||||||
[left-edge-box (box 0)]
|
[(let ([prev (send s previous)])
|
||||||
[top-edge-box (box 0)]
|
(and prev
|
||||||
[snip-media (send s get-editor)]
|
(member 'hard-newline (send prev get-flags))))
|
||||||
[edit (get-editor)]
|
(set-box! left-edge-box 0)]
|
||||||
[get-width
|
[else (fallback)]))
|
||||||
(let ([bl (box 0)]
|
|
||||||
[br (box 0)])
|
(if width?
|
||||||
(λ (s)
|
(let* ([after-width (calc-after-width (send s next))]
|
||||||
(send edit get-snip-location s bl #f #f)
|
[snip-width (max 0 (- (unbox width)
|
||||||
(send edit get-snip-location s br #f #t)
|
(unbox left-edge-box)
|
||||||
(- (unbox br) (unbox bl))))]
|
(unbox leftm)
|
||||||
[calc-after-width
|
(unbox rightm)
|
||||||
(λ (s)
|
after-width
|
||||||
(+ 4 ;; this is compensate for an autowrapping bug
|
;; this two is the space that
|
||||||
(let loop ([s s])
|
;; the caret needs at the right of
|
||||||
(cond
|
;; a buffer.
|
||||||
[(not s) 0]
|
2))])
|
||||||
[(member 'hard-newline (send s get-flags)) (get-width s)]
|
(send* s
|
||||||
[(member 'newline (send s get-flags)) (get-width s)]
|
(set-min-width snip-width)
|
||||||
[else
|
(set-max-width snip-width))
|
||||||
(+ (get-width s)
|
(when snip-media
|
||||||
2 ;; for the caret
|
(send snip-media set-max-width
|
||||||
(loop (send s next)))]))))])
|
(if (send snip-media auto-wrap)
|
||||||
(when edit
|
snip-width
|
||||||
(send edit
|
0))))
|
||||||
run-after-edit-sequence
|
(let ([snip-height (max 0 (- (unbox height)
|
||||||
(λ ()
|
(unbox top-edge-box)
|
||||||
(let ([admin (send edit get-admin)])
|
(unbox topm)
|
||||||
(send admin get-view #f #f width height)
|
(unbox bottomm)))])
|
||||||
(send s get-margin leftm topm rightm bottomm)
|
(send* s
|
||||||
|
(set-min-height snip-height)
|
||||||
|
(set-max-height snip-height))))))))))
|
||||||
;; when the width is to be maximized and there is a
|
(define/public (recalc-snips)
|
||||||
;; newline just behind the snip, we know that the left
|
(let ([editor (get-editor)])
|
||||||
;; edge is zero. Special case for efficiency in the
|
(unless (is-a? editor text:wide-snip<%>)
|
||||||
;; console printer
|
(error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
|
||||||
(let ([fallback
|
(when (eq? (send editor get-canvas) this)
|
||||||
(λ ()
|
(for-each (update-snip-size #t) (send editor get-wide-snips))
|
||||||
(send edit get-snip-location s left-edge-box top-edge-box))])
|
(for-each (update-snip-size #f) (send editor get-tall-snips)))))
|
||||||
(cond
|
(define/public (add-wide-snip snip)
|
||||||
[(not width?) (fallback)]
|
(let ([editor (get-editor)])
|
||||||
[(let ([prev (send s previous)])
|
(unless (is-a? editor text:wide-snip<%>)
|
||||||
(and prev
|
(error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
|
||||||
(member 'hard-newline (send prev get-flags))))
|
(send editor add-wide-snip snip))
|
||||||
(set-box! left-edge-box 0)]
|
((update-snip-size #t) snip))
|
||||||
[else (fallback)]))
|
(define/public (add-tall-snip snip)
|
||||||
|
(let ([editor (get-editor)])
|
||||||
(if width?
|
(unless (is-a? editor text:wide-snip<%>)
|
||||||
(let* ([after-width (calc-after-width (send s next))]
|
(error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
|
||||||
[snip-width (max 0 (- (unbox width)
|
(send editor add-tall-snip snip))
|
||||||
(unbox left-edge-box)
|
((update-snip-size #f) snip))
|
||||||
(unbox leftm)
|
(define/override (on-size width height)
|
||||||
(unbox rightm)
|
(recalc-snips)
|
||||||
after-width
|
(super on-size width height))
|
||||||
;; this two is the space that
|
(super-new)))
|
||||||
;; the caret needs at the right of
|
|
||||||
;; a buffer.
|
(define basic% (basic-mixin editor-canvas%))
|
||||||
2))])
|
(define -color% (color-mixin basic%))
|
||||||
(send* s
|
(define info% (info-mixin basic%))
|
||||||
(set-min-width snip-width)
|
(define delegate% (delegate-mixin basic%))
|
||||||
(set-max-width snip-width))
|
(define wide-snip% (wide-snip-mixin basic%)))
|
||||||
(when snip-media
|
|
||||||
(send snip-media set-max-width
|
|
||||||
(if (send snip-media auto-wrap)
|
|
||||||
snip-width
|
|
||||||
0))))
|
|
||||||
(let ([snip-height (max 0 (- (unbox height)
|
|
||||||
(unbox top-edge-box)
|
|
||||||
(unbox topm)
|
|
||||||
(unbox bottomm)))])
|
|
||||||
(send* s
|
|
||||||
(set-min-height snip-height)
|
|
||||||
(set-max-height snip-height))))))))))
|
|
||||||
(define/public (recalc-snips)
|
|
||||||
(let ([editor (get-editor)])
|
|
||||||
(unless (is-a? editor text:wide-snip<%>)
|
|
||||||
(error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
|
|
||||||
(when (eq? (send editor get-canvas) this)
|
|
||||||
(for-each (update-snip-size #t) (send editor get-wide-snips))
|
|
||||||
(for-each (update-snip-size #f) (send editor get-tall-snips)))))
|
|
||||||
(define/public (add-wide-snip snip)
|
|
||||||
(let ([editor (get-editor)])
|
|
||||||
(unless (is-a? editor text:wide-snip<%>)
|
|
||||||
(error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
|
|
||||||
(send editor add-wide-snip snip))
|
|
||||||
((update-snip-size #t) snip))
|
|
||||||
(define/public (add-tall-snip snip)
|
|
||||||
(let ([editor (get-editor)])
|
|
||||||
(unless (is-a? editor text:wide-snip<%>)
|
|
||||||
(error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
|
|
||||||
(send editor add-tall-snip snip))
|
|
||||||
((update-snip-size #f) snip))
|
|
||||||
(define/override (on-size width height)
|
|
||||||
(recalc-snips)
|
|
||||||
(super on-size width height))
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
(define basic% (basic-mixin editor-canvas%))
|
|
||||||
(define -color% (color-mixin basic%))
|
|
||||||
(define info% (info-mixin basic%))
|
|
||||||
(define delegate% (delegate-mixin basic%))
|
|
||||||
(define wide-snip% (wide-snip-mixin basic%)))
|
|
||||||
|
|
|
||||||
|
|
@ -24,4 +24,3 @@
|
||||||
(right-bracket right-bracket)
|
(right-bracket right-bracket)
|
||||||
(saved-snips saved-snips))))
|
(saved-snips saved-snips))))
|
||||||
(super-instantiate ()))))
|
(super-instantiate ()))))
|
||||||
|
|
||||||
|
|
@ -1,9 +1,9 @@
|
||||||
(module color-model (lib "a-unit.ss")
|
(module color-model (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export framework:color-model^)
|
(export framework:color-model^)
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
@ -11,258 +11,258 @@
|
||||||
;;; matrix ops ;;;
|
;;; matrix ops ;;;
|
||||||
;;; ;;;
|
;;; ;;;
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;; matrix inversion using cramer's rule
|
;; matrix inversion using cramer's rule
|
||||||
|
|
||||||
;; submatrix : (list-of (list-of num)) int int -> (list-of (list-of num))
|
;; submatrix : (list-of (list-of num)) int int -> (list-of (list-of num))
|
||||||
;; submatrix "crosses out" row i and column j from the matrix, returning a new one
|
;; submatrix "crosses out" row i and column j from the matrix, returning a new one
|
||||||
|
|
||||||
(define (submatrix source i j)
|
(define (submatrix source i j)
|
||||||
(let row-loop ([row 0])
|
(let row-loop ([row 0])
|
||||||
(cond
|
(cond
|
||||||
[(eq? row (length source)) null]
|
[(eq? row (length source)) null]
|
||||||
[(eq? row i) (row-loop (+ row 1))]
|
[(eq? row i) (row-loop (+ row 1))]
|
||||||
[else
|
[else
|
||||||
(cons
|
(cons
|
||||||
(let col-loop ([col 0])
|
(let col-loop ([col 0])
|
||||||
(cond
|
(cond
|
||||||
[(eq? col (length (car source))) null]
|
[(eq? col (length (car source))) null]
|
||||||
[(eq? col j) (col-loop (+ col 1))]
|
[(eq? col j) (col-loop (+ col 1))]
|
||||||
[else
|
[else
|
||||||
(cons (list-ref (list-ref source row) col)
|
(cons (list-ref (list-ref source row) col)
|
||||||
(col-loop (+ col 1)))]))
|
(col-loop (+ col 1)))]))
|
||||||
(row-loop (+ row 1)))])))
|
(row-loop (+ row 1)))])))
|
||||||
|
|
||||||
;;(equal? (submatrix test-matrix 1 2)
|
;;(equal? (submatrix test-matrix 1 2)
|
||||||
;; '((1 2 6) (7 8 4)))
|
;; '((1 2 6) (7 8 4)))
|
||||||
|
|
||||||
;; det : (list-of (list-of num)) -> num
|
;; det : (list-of (list-of num)) -> num
|
||||||
|
|
||||||
(define (det matrix)
|
(define (det matrix)
|
||||||
(if (null? matrix)
|
(if (null? matrix)
|
||||||
1
|
1
|
||||||
(let loop ([row 0] [sign 1])
|
(let loop ([row 0] [sign 1])
|
||||||
(if (= row (length matrix))
|
(if (= row (length matrix))
|
||||||
0
|
0
|
||||||
(+ (* sign
|
(+ (* sign
|
||||||
(list-ref (list-ref matrix row) 0)
|
(list-ref (list-ref matrix row) 0)
|
||||||
(det (submatrix matrix row 0)))
|
(det (submatrix matrix row 0)))
|
||||||
(loop (+ row 1) (- sign)))))))
|
(loop (+ row 1) (- sign)))))))
|
||||||
|
|
||||||
;;(define square-test-matrix '((3 20 3) (37 0 8) (2 1 4)))
|
;;(define square-test-matrix '((3 20 3) (37 0 8) (2 1 4)))
|
||||||
|
|
||||||
;;(= (det square-test-matrix) -2553)
|
;;(= (det square-test-matrix) -2553)
|
||||||
|
|
||||||
;; invert : (list-of (list-of num)) -> (list-of (list-of num))
|
;; invert : (list-of (list-of num)) -> (list-of (list-of num))
|
||||||
|
|
||||||
(define (matrix-invert matrix)
|
(define (matrix-invert matrix)
|
||||||
(let-values ([(width height) (matrix-dimension matrix)])
|
(let-values ([(width height) (matrix-dimension matrix)])
|
||||||
(when (not (= width height))
|
(when (not (= width height))
|
||||||
(error 'invert "matrix is not square: ~s" matrix))
|
(error 'invert "matrix is not square: ~s" matrix))
|
||||||
(let ([delta-inv (/ 1 (det matrix))])
|
(let ([delta-inv (/ 1 (det matrix))])
|
||||||
(let row-loop ([row 0] [sign 1])
|
(let row-loop ([row 0] [sign 1])
|
||||||
(if (= row (length matrix))
|
(if (= row (length matrix))
|
||||||
null
|
null
|
||||||
(cons
|
(cons
|
||||||
(let col-loop ([col 0] [sign sign])
|
(let col-loop ([col 0] [sign sign])
|
||||||
(if (= col (length (car matrix)))
|
(if (= col (length (car matrix)))
|
||||||
null
|
null
|
||||||
(cons (* delta-inv
|
(cons (* delta-inv
|
||||||
sign
|
sign
|
||||||
(det (submatrix matrix col row)))
|
(det (submatrix matrix col row)))
|
||||||
(col-loop (+ col 1) (- sign)))))
|
(col-loop (+ col 1) (- sign)))))
|
||||||
(row-loop (+ row 1) (- sign))))))))
|
(row-loop (+ row 1) (- sign))))))))
|
||||||
|
|
||||||
;;(equal? (matrix-invert square-test-matrix)
|
;;(equal? (matrix-invert square-test-matrix)
|
||||||
;; '((8/2553 77/2553 -160/2553) (44/851 -2/851 -29/851) (-1/69 -1/69 20/69)))
|
;; '((8/2553 77/2553 -160/2553) (44/851 -2/851 -29/851) (-1/69 -1/69 20/69)))
|
||||||
|
|
||||||
;; matrix-dimension : (list-of (list-of num)) -> (values num num)
|
;; matrix-dimension : (list-of (list-of num)) -> (values num num)
|
||||||
;; takes a matrix, returns width and height
|
;; takes a matrix, returns width and height
|
||||||
|
|
||||||
(define (matrix-dimension matrix)
|
(define (matrix-dimension matrix)
|
||||||
(when (not (pair? matrix))
|
(when (not (pair? matrix))
|
||||||
(error 'matrix-dimension "matrix argument is not a list: ~s" matrix))
|
(error 'matrix-dimension "matrix argument is not a list: ~s" matrix))
|
||||||
(let ([height (length matrix)])
|
(let ([height (length matrix)])
|
||||||
(when (= height 0)
|
(when (= height 0)
|
||||||
(error 'matrix-dimension "matrix argument is empty: ~s" matrix))
|
(error 'matrix-dimension "matrix argument is empty: ~s" matrix))
|
||||||
(when (not (pair? (car matrix)))
|
(when (not (pair? (car matrix)))
|
||||||
(error 'matrix-dimension "matrix row is not a list: ~s" (car matrix)))
|
(error 'matrix-dimension "matrix row is not a list: ~s" (car matrix)))
|
||||||
(let ([width (length (car matrix))])
|
(let ([width (length (car matrix))])
|
||||||
(when (= width 0)
|
(when (= width 0)
|
||||||
(error 'matrix-dimension "matrix argument has width 0: ~s" matrix))
|
(error 'matrix-dimension "matrix argument has width 0: ~s" matrix))
|
||||||
(let loop ([rows matrix])
|
(let loop ([rows matrix])
|
||||||
(if (null? rows)
|
(if (null? rows)
|
||||||
(values width height)
|
(values width height)
|
||||||
(begin
|
(begin
|
||||||
(when (not (pair? (car rows)))
|
(when (not (pair? (car rows)))
|
||||||
(error 'matrix-dimension "row is not a list: ~s" (car rows)))
|
(error 'matrix-dimension "row is not a list: ~s" (car rows)))
|
||||||
(when (not (= width (length (car rows))))
|
(when (not (= width (length (car rows))))
|
||||||
(error 'matrix-dimension "rows have different widths: ~s and ~s" width (length (car rows))))
|
(error 'matrix-dimension "rows have different widths: ~s and ~s" width (length (car rows))))
|
||||||
(loop (cdr rows))))))))
|
(loop (cdr rows))))))))
|
||||||
|
|
||||||
;; transpose : (list-of (list-of num)) -> (list-of (list-of num))
|
;; transpose : (list-of (list-of num)) -> (list-of (list-of num))
|
||||||
(define (transpose vector) (apply map list vector))
|
(define (transpose vector) (apply map list vector))
|
||||||
|
|
||||||
|
|
||||||
;; test code
|
;; test code
|
||||||
;;(equal? (transpose '((3 2 1) (9 8 7))) '((3 9) (2 8) (1 7)))
|
;;(equal? (transpose '((3 2 1) (9 8 7))) '((3 9) (2 8) (1 7)))
|
||||||
|
|
||||||
;; inner-product : (list-of num) (list-of num) -> num
|
;; inner-product : (list-of num) (list-of num) -> num
|
||||||
(define (inner-product a b)
|
(define (inner-product a b)
|
||||||
(foldl + 0 (map * a b)))
|
(foldl + 0 (map * a b)))
|
||||||
|
|
||||||
;; test code
|
;; test code
|
||||||
;; (= (inner-product '(4 1 3) '(0 3 4)) 15)
|
;; (= (inner-product '(4 1 3) '(0 3 4)) 15)
|
||||||
|
|
||||||
;; matrix-multiply: (list-of (list-of num)) (list-of (list-of num)) -> (list-of (list-of num))
|
;; matrix-multiply: (list-of (list-of num)) (list-of (list-of num)) -> (list-of (list-of num))
|
||||||
;; multiplies the two matrices.
|
;; multiplies the two matrices.
|
||||||
(define (matrix-multiply a b)
|
(define (matrix-multiply a b)
|
||||||
(let-values ([(width-a height-a) (matrix-dimension a)]
|
(let-values ([(width-a height-a) (matrix-dimension a)]
|
||||||
[(width-b height-b) (matrix-dimension b)])
|
[(width-b height-b) (matrix-dimension b)])
|
||||||
(when (not (= width-a height-b))
|
(when (not (= width-a height-b))
|
||||||
(error 'matrix-multiply "matrix dimensions do not match for multiplication"))
|
(error 'matrix-multiply "matrix dimensions do not match for multiplication"))
|
||||||
(let ([b-t (transpose b)])
|
(let ([b-t (transpose b)])
|
||||||
(map (λ (row)
|
(map (λ (row)
|
||||||
(map (λ (col)
|
(map (λ (col)
|
||||||
(inner-product row col))
|
(inner-product row col))
|
||||||
b-t))
|
b-t))
|
||||||
a))))
|
a))))
|
||||||
|
|
||||||
;; test code
|
;; test code
|
||||||
;; (equal? (matrix-multiply '((1 2 3 4) (9 8 3 2)) '((0) (2) (0) (3)))
|
;; (equal? (matrix-multiply '((1 2 3 4) (9 8 3 2)) '((0) (2) (0) (3)))
|
||||||
;; '((16) (22)))
|
;; '((16) (22)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;; ;;;
|
;;; ;;;
|
||||||
;;; color model ;;;
|
;;; color model ;;;
|
||||||
;;; ;;;
|
;;; ;;;
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;; ITU reccommendation phosphors:
|
;; ITU reccommendation phosphors:
|
||||||
|
|
||||||
;; red green blue
|
;; red green blue
|
||||||
;;x 0.64 0.29 0.15
|
;;x 0.64 0.29 0.15
|
||||||
;;y 0.33 0.60 0.06
|
;;y 0.33 0.60 0.06
|
||||||
;;
|
;;
|
||||||
;; white point:
|
;; white point:
|
||||||
;; c : x-w = 0.313, y-w = 0.329, big-y-w = 100.0
|
;; c : x-w = 0.313, y-w = 0.329, big-y-w = 100.0
|
||||||
|
|
||||||
(define x-r 0.64)
|
(define x-r 0.64)
|
||||||
(define y-r 0.33)
|
(define y-r 0.33)
|
||||||
(define x-g 0.29)
|
(define x-g 0.29)
|
||||||
(define y-g 0.60)
|
(define y-g 0.60)
|
||||||
(define x-b 0.15)
|
(define x-b 0.15)
|
||||||
(define y-b 0.06)
|
(define y-b 0.06)
|
||||||
|
|
||||||
(define z-r (- 1 x-r y-r))
|
(define z-r (- 1 x-r y-r))
|
||||||
(define z-g (- 1 x-g y-g))
|
(define z-g (- 1 x-g y-g))
|
||||||
(define z-b (- 1 x-b y-b))
|
(define z-b (- 1 x-b y-b))
|
||||||
|
|
||||||
(define x-w 0.313)
|
(define x-w 0.313)
|
||||||
(define y-w 0.329)
|
(define y-w 0.329)
|
||||||
(define big-y-w 100.0)
|
(define big-y-w 100.0)
|
||||||
|
|
||||||
(define-struct xyz (x y z))
|
(define-struct xyz (x y z))
|
||||||
|
|
||||||
(define (xy-big-y->xyz x y big-y)
|
(define (xy-big-y->xyz x y big-y)
|
||||||
(let ([sigma (/ big-y y)])
|
(let ([sigma (/ big-y y)])
|
||||||
(make-xyz
|
(make-xyz
|
||||||
(* x sigma)
|
(* x sigma)
|
||||||
(* y sigma)
|
(* y sigma)
|
||||||
(* (- 1 x y) sigma))))
|
(* (- 1 x y) sigma))))
|
||||||
|
|
||||||
(define xyz-white (xy-big-y->xyz x-w y-w big-y-w))
|
(define xyz-white (xy-big-y->xyz x-w y-w big-y-w))
|
||||||
|
|
||||||
;;`((,(xyz-x xyz-white) ,x-r ,x-g ,x-b)
|
;;`((,(xyz-x xyz-white) ,x-r ,x-g ,x-b)
|
||||||
;; (,(xyz-y xyz-white) ,y-r ,y-g ,y-b)
|
;; (,(xyz-y xyz-white) ,y-r ,y-g ,y-b)
|
||||||
;; (,(xyz-z xyz-white) ,z-r ,z-g ,z-b))
|
;; (,(xyz-z xyz-white) ,z-r ,z-g ,z-b))
|
||||||
|
|
||||||
;; sigmas were calculated by soving a set of linear equations based upon ntsc standard phosphors
|
;; sigmas were calculated by soving a set of linear equations based upon ntsc standard phosphors
|
||||||
|
|
||||||
(define pre-matrix `((,x-r ,x-g ,x-b)
|
(define pre-matrix `((,x-r ,x-g ,x-b)
|
||||||
(,y-r ,y-g ,y-b)
|
(,y-r ,y-g ,y-b)
|
||||||
(,z-r ,z-g ,z-b)))
|
(,z-r ,z-g ,z-b)))
|
||||||
|
|
||||||
(define-values (sigma-r sigma-g sigma-b)
|
(define-values (sigma-r sigma-g sigma-b)
|
||||||
(let* ([inversion
|
(let* ([inversion
|
||||||
(matrix-invert pre-matrix)]
|
(matrix-invert pre-matrix)]
|
||||||
[sigmas
|
[sigmas
|
||||||
(matrix-multiply inversion `((,(xyz-x xyz-white))
|
(matrix-multiply inversion `((,(xyz-x xyz-white))
|
||||||
(,(xyz-y xyz-white))
|
(,(xyz-y xyz-white))
|
||||||
(,(xyz-z xyz-white))))])
|
(,(xyz-z xyz-white))))])
|
||||||
(apply values (car (transpose sigmas)))))
|
(apply values (car (transpose sigmas)))))
|
||||||
|
|
||||||
;; (printf "should be equal to xyz-white: ~n~a~n"
|
;; (printf "should be equal to xyz-white: ~n~a~n"
|
||||||
;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b))))
|
;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b))))
|
||||||
|
|
||||||
(define rgb->xyz-matrix
|
(define rgb->xyz-matrix
|
||||||
(map (λ (row)
|
(map (λ (row)
|
||||||
(map (λ (row-elt scalar) (* row-elt scalar 1/255)) row `(,sigma-r ,sigma-g ,sigma-b)))
|
(map (λ (row-elt scalar) (* row-elt scalar 1/255)) row `(,sigma-r ,sigma-g ,sigma-b)))
|
||||||
pre-matrix))
|
pre-matrix))
|
||||||
|
|
||||||
(define xyz->rgb-matrix
|
(define xyz->rgb-matrix
|
||||||
(matrix-invert rgb->xyz-matrix))
|
(matrix-invert rgb->xyz-matrix))
|
||||||
|
|
||||||
;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix))
|
;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix))
|
||||||
|
|
||||||
(define (rgb->xyz r g b)
|
(define (rgb->xyz r g b)
|
||||||
(apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b))))))))
|
(apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b))))))))
|
||||||
|
|
||||||
;;(print-struct #t)
|
;;(print-struct #t)
|
||||||
;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255))
|
;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255))
|
||||||
|
|
||||||
(define (xyz->rgb x y z)
|
(define (xyz->rgb x y z)
|
||||||
(car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z)))))))
|
(car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z)))))))
|
||||||
|
|
||||||
;;l* = 116(y/big-y-n)^1/3 - 16, y/big-y-n > 0.01
|
;;l* = 116(y/big-y-n)^1/3 - 16, y/big-y-n > 0.01
|
||||||
;;u* = 13 l*(u-p - u-p-n)
|
;;u* = 13 l*(u-p - u-p-n)
|
||||||
;;v* = 13 l*(v-p - v-p-n)
|
;;v* = 13 l*(v-p - v-p-n)
|
||||||
;;
|
;;
|
||||||
;;u-p = (4x)/(x+15y+3z) v-p = (9y)/(x+15y+3z)
|
;;u-p = (4x)/(x+15y+3z) v-p = (9y)/(x+15y+3z)
|
||||||
;;u-p-n = (same but with -n) v-p-n = (same but with -n)
|
;;u-p-n = (same but with -n) v-p-n = (same but with -n)
|
||||||
|
|
||||||
;; the following transformation is undefined if the y component
|
;; the following transformation is undefined if the y component
|
||||||
;; is zero. So if it is, we bump it up a little.
|
;; is zero. So if it is, we bump it up a little.
|
||||||
|
|
||||||
(define (xyz-tweak xyz)
|
(define (xyz-tweak xyz)
|
||||||
(let* ([y (xyz-y xyz)])
|
(let* ([y (xyz-y xyz)])
|
||||||
(make-xyz (xyz-x xyz) (if (< y 0.01) 0.01 y) (xyz-z xyz))))
|
(make-xyz (xyz-x xyz) (if (< y 0.01) 0.01 y) (xyz-z xyz))))
|
||||||
|
|
||||||
(define-struct luv (l u v))
|
(define-struct luv (l u v))
|
||||||
|
|
||||||
(define (xyz-denom xyz)
|
(define (xyz-denom xyz)
|
||||||
(+ (xyz-x xyz) (* 15 (xyz-y xyz)) (* 3 (xyz-z xyz))))
|
(+ (xyz-x xyz) (* 15 (xyz-y xyz)) (* 3 (xyz-z xyz))))
|
||||||
|
|
||||||
(define (xyz-u-p xyz)
|
(define (xyz-u-p xyz)
|
||||||
(/ (* 4 (xyz-x xyz)) (xyz-denom xyz)))
|
(/ (* 4 (xyz-x xyz)) (xyz-denom xyz)))
|
||||||
|
|
||||||
(define (xyz-v-p xyz)
|
(define (xyz-v-p xyz)
|
||||||
(/ (* 9 (xyz-y xyz)) (xyz-denom xyz)))
|
(/ (* 9 (xyz-y xyz)) (xyz-denom xyz)))
|
||||||
|
|
||||||
(define (xyz->luv xyz)
|
(define (xyz->luv xyz)
|
||||||
(let ([xyz (xyz-tweak xyz)])
|
(let ([xyz (xyz-tweak xyz)])
|
||||||
(let* ([l (- (* 116 (expt (/ (xyz-y xyz) (xyz-y xyz-white))
|
(let* ([l (- (* 116 (expt (/ (xyz-y xyz) (xyz-y xyz-white))
|
||||||
1/3))
|
1/3))
|
||||||
16)]
|
16)]
|
||||||
[u-p (xyz-u-p xyz)]
|
[u-p (xyz-u-p xyz)]
|
||||||
[u-p-white (xyz-u-p xyz-white)]
|
[u-p-white (xyz-u-p xyz-white)]
|
||||||
[v-p (xyz-v-p xyz)]
|
[v-p (xyz-v-p xyz)]
|
||||||
[v-p-white (xyz-v-p xyz-white)])
|
[v-p-white (xyz-v-p xyz-white)])
|
||||||
(make-luv l (* 13 l (- u-p u-p-white)) (* 13 l (- v-p v-p-white))))))
|
(make-luv l (* 13 l (- u-p u-p-white)) (* 13 l (- v-p v-p-white))))))
|
||||||
|
|
||||||
(define (luv-distance a b)
|
(define (luv-distance a b)
|
||||||
(expt (+ (expt (- (luv-l a) (luv-l b)) 2)
|
(expt (+ (expt (- (luv-l a) (luv-l b)) 2)
|
||||||
(expt (- (luv-u a) (luv-u b)) 2)
|
(expt (- (luv-u a) (luv-u b)) 2)
|
||||||
(expt (- (luv-v a) (luv-v b)) 2))
|
(expt (- (luv-v a) (luv-v b)) 2))
|
||||||
1/2))
|
1/2))
|
||||||
|
|
||||||
(define (rgb-color-distance r-a g-a b-a r-b g-b b-b)
|
(define (rgb-color-distance r-a g-a b-a r-b g-b b-b)
|
||||||
(let* ([luv-a (xyz->luv (rgb->xyz r-a g-a b-a))]
|
(let* ([luv-a (xyz->luv (rgb->xyz r-a g-a b-a))]
|
||||||
[luv-b (xyz->luv (rgb->xyz r-b g-b b-b))])
|
[luv-b (xyz->luv (rgb->xyz r-b g-b b-b))])
|
||||||
(luv-distance luv-a luv-b)))
|
(luv-distance luv-a luv-b)))
|
||||||
|
|
||||||
;;(rgb-color-distance 0 0 0 0 0 0)
|
;;(rgb-color-distance 0 0 0 0 0 0)
|
||||||
;; (print-struct #t)
|
;; (print-struct #t)
|
||||||
;; (xyz->luv (make-xyz 95.0 100.0 141.0))
|
;; (xyz->luv (make-xyz 95.0 100.0 141.0))
|
||||||
;; (xyz->luv (make-xyz 60.0 80.0 20.0))
|
;; (xyz->luv (make-xyz 60.0 80.0 20.0))
|
||||||
)
|
)
|
||||||
|
|
@ -85,9 +85,9 @@
|
||||||
|
|
||||||
(define smoothing-options
|
(define smoothing-options
|
||||||
'(default
|
'(default
|
||||||
partly-smoothed
|
partly-smoothed
|
||||||
smoothed
|
smoothed
|
||||||
unsmoothed))
|
unsmoothed))
|
||||||
(define smoothing-option-strings
|
(define smoothing-option-strings
|
||||||
'("Default"
|
'("Default"
|
||||||
"Partly smoothed"
|
"Partly smoothed"
|
||||||
|
|
@ -119,7 +119,7 @@
|
||||||
(send delta set-smoothing-on
|
(send delta set-smoothing-on
|
||||||
(list-ref smoothing-options
|
(list-ref smoothing-options
|
||||||
(send c get-selection))))))]))
|
(send c get-selection))))))]))
|
||||||
|
|
||||||
(define color-button
|
(define color-button
|
||||||
(and (>= (get-display-depth) 8)
|
(and (>= (get-display-depth) 8)
|
||||||
(new button%
|
(new button%
|
||||||
|
|
|
||||||
|
|
@ -8,7 +8,7 @@
|
||||||
(lib "default-lexer.ss" "syntax-color")
|
(lib "default-lexer.ss" "syntax-color")
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
"sig.ss")
|
"sig.ss")
|
||||||
|
|
||||||
(import [prefix icon: framework:icon^]
|
(import [prefix icon: framework:icon^]
|
||||||
[prefix mode: framework:mode^]
|
[prefix mode: framework:mode^]
|
||||||
[prefix text: framework:text^]
|
[prefix text: framework:text^]
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
(module comment-box (lib "a-unit.ss")
|
(module comment-box (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
(lib "etc.ss")
|
(lib "etc.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../decorated-editor-snip.ss"
|
"../decorated-editor-snip.ss"
|
||||||
(lib "include-bitmap.ss" "mrlib")
|
(lib "include-bitmap.ss" "mrlib")
|
||||||
|
|
@ -13,112 +13,112 @@
|
||||||
[prefix keymap: framework:keymap^])
|
[prefix keymap: framework:keymap^])
|
||||||
(export (rename framework:comment-box^
|
(export (rename framework:comment-box^
|
||||||
(-snip% snip%)))
|
(-snip% snip%)))
|
||||||
|
|
||||||
(define snipclass%
|
(define snipclass%
|
||||||
(class decorated-editor-snipclass%
|
(class decorated-editor-snipclass%
|
||||||
(define/override (make-snip stream-in) (instantiate -snip% ()))
|
(define/override (make-snip stream-in) (instantiate -snip% ()))
|
||||||
(super-instantiate ())))
|
(super-instantiate ())))
|
||||||
|
|
||||||
|
(define snipclass (make-object snipclass%))
|
||||||
|
(send snipclass set-version 1)
|
||||||
|
(send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework")))
|
||||||
|
(send (get-the-snip-class-list) add snipclass)
|
||||||
|
|
||||||
|
(define bm (include-bitmap (lib "semicolon.gif" "icons")))
|
||||||
|
|
||||||
|
(define (editor-keymap-mixin %)
|
||||||
|
(class %
|
||||||
|
(define/override (get-keymaps)
|
||||||
|
(cons (keymap:get-file) (super get-keymaps)))
|
||||||
|
(super-instantiate ())))
|
||||||
|
|
||||||
|
(define scheme+copy-self% #f)
|
||||||
|
(define (get-scheme+copy-self%)
|
||||||
|
(unless scheme+copy-self%
|
||||||
|
(set! scheme+copy-self%
|
||||||
|
(class scheme:text%
|
||||||
|
(inherit copy-self-to)
|
||||||
|
(define/override (copy-self)
|
||||||
|
(let ([ed (new scheme+copy-self%)])
|
||||||
|
(copy-self-to ed)
|
||||||
|
ed))
|
||||||
|
(super-new))))
|
||||||
|
scheme+copy-self%)
|
||||||
|
|
||||||
|
(define -snip%
|
||||||
|
(class* decorated-editor-snip% (readable-snip<%>)
|
||||||
|
(inherit get-editor get-style)
|
||||||
|
|
||||||
(define snipclass (make-object snipclass%))
|
(define/override (make-editor) (new (get-scheme+copy-self%)))
|
||||||
(send snipclass set-version 1)
|
(define/override (make-snip) (make-object -snip%))
|
||||||
(send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework")))
|
(define/override (get-corner-bitmap) bm)
|
||||||
(send (get-the-snip-class-list) add snipclass)
|
(define/override (get-position) 'left-top)
|
||||||
|
|
||||||
(define bm (include-bitmap (lib "semicolon.gif" "icons")))
|
(define/override get-text
|
||||||
|
(opt-lambda (offset num [flattened? #t])
|
||||||
|
(let* ([super-res (super get-text offset num flattened?)]
|
||||||
|
[replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))])
|
||||||
|
(if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
|
||||||
|
replaced
|
||||||
|
(string-append replaced "\n")))))
|
||||||
|
|
||||||
(define (editor-keymap-mixin %)
|
|
||||||
(class %
|
|
||||||
(define/override (get-keymaps)
|
|
||||||
(cons (keymap:get-file) (super get-keymaps)))
|
|
||||||
(super-instantiate ())))
|
|
||||||
|
|
||||||
(define scheme+copy-self% #f)
|
(define/override (get-menu)
|
||||||
(define (get-scheme+copy-self%)
|
(let ([menu (make-object popup-menu%)])
|
||||||
(unless scheme+copy-self%
|
(make-object menu-item%
|
||||||
(set! scheme+copy-self%
|
(string-constant convert-to-semicolon-comment)
|
||||||
(class scheme:text%
|
menu
|
||||||
(inherit copy-self-to)
|
(λ (x y)
|
||||||
(define/override (copy-self)
|
(let ([to-ed (find-containing-editor)])
|
||||||
(let ([ed (new scheme+copy-self%)])
|
(when to-ed
|
||||||
(copy-self-to ed)
|
(let ([this-pos (find-this-position)])
|
||||||
ed))
|
(when this-pos
|
||||||
(super-new))))
|
(let ([from-ed (get-editor)])
|
||||||
scheme+copy-self%)
|
(send to-ed begin-edit-sequence)
|
||||||
|
(send from-ed begin-edit-sequence)
|
||||||
|
(copy-contents-with-semicolons-to-position to-ed from-ed (+ this-pos 1))
|
||||||
|
(send to-ed delete this-pos (+ this-pos 1))
|
||||||
|
(send to-ed end-edit-sequence)
|
||||||
|
(send from-ed end-edit-sequence))))))))
|
||||||
|
menu))
|
||||||
|
|
||||||
(define -snip%
|
(inherit get-admin)
|
||||||
(class* decorated-editor-snip% (readable-snip<%>)
|
;; find-containing-editor : -> (union #f editor)
|
||||||
(inherit get-editor get-style)
|
(define/private (find-containing-editor)
|
||||||
|
(let ([admin (get-admin)])
|
||||||
(define/override (make-editor) (new (get-scheme+copy-self%)))
|
(and admin
|
||||||
(define/override (make-snip) (make-object -snip%))
|
(send admin get-editor))))
|
||||||
(define/override (get-corner-bitmap) bm)
|
|
||||||
(define/override (get-position) 'left-top)
|
;; find-this-position : -> (union #f number)
|
||||||
|
(define/private (find-this-position)
|
||||||
(define/override get-text
|
(let ([ed (find-containing-editor)])
|
||||||
(opt-lambda (offset num [flattened? #t])
|
(and ed
|
||||||
(let* ([super-res (super get-text offset num flattened?)]
|
(send ed get-snip-position this))))
|
||||||
[replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))])
|
|
||||||
(if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
|
;; copy-contents-with-semicolons-to-position : (is-a? text%) number -> void
|
||||||
replaced
|
(define/private (copy-contents-with-semicolons-to-position to-ed from-ed pos)
|
||||||
(string-append replaced "\n")))))
|
(let loop ([snip (find-last-snip from-ed)])
|
||||||
|
(cond
|
||||||
|
[snip
|
||||||
(define/override (get-menu)
|
(when (or (memq 'hard-newline (send snip get-flags))
|
||||||
(let ([menu (make-object popup-menu%)])
|
(memq 'newline (send snip get-flags)))
|
||||||
(make-object menu-item%
|
(send to-ed insert "; " pos))
|
||||||
(string-constant convert-to-semicolon-comment)
|
(send to-ed insert (send snip copy) pos)
|
||||||
menu
|
(loop (send snip previous))]
|
||||||
(λ (x y)
|
[else
|
||||||
(let ([to-ed (find-containing-editor)])
|
(send to-ed insert "; " pos)])))
|
||||||
(when to-ed
|
|
||||||
(let ([this-pos (find-this-position)])
|
;; find-last-snip : editor -> snip
|
||||||
(when this-pos
|
;; returns the last snip in the editor
|
||||||
(let ([from-ed (get-editor)])
|
(define/private (find-last-snip ed)
|
||||||
(send to-ed begin-edit-sequence)
|
(let loop ([snip (send ed find-first-snip)]
|
||||||
(send from-ed begin-edit-sequence)
|
[acc (send ed find-first-snip)])
|
||||||
(copy-contents-with-semicolons-to-position to-ed from-ed (+ this-pos 1))
|
(cond
|
||||||
(send to-ed delete this-pos (+ this-pos 1))
|
[snip (loop (send snip next) snip)]
|
||||||
(send to-ed end-edit-sequence)
|
[else acc])))
|
||||||
(send from-ed end-edit-sequence))))))))
|
|
||||||
menu))
|
(define/public (read-special source line column position)
|
||||||
|
(make-special-comment "comment"))
|
||||||
(inherit get-admin)
|
(super-instantiate ())
|
||||||
;; find-containing-editor : -> (union #f editor)
|
(inherit set-snipclass)
|
||||||
(define/private (find-containing-editor)
|
(set-snipclass snipclass))))
|
||||||
(let ([admin (get-admin)])
|
|
||||||
(and admin
|
|
||||||
(send admin get-editor))))
|
|
||||||
|
|
||||||
;; find-this-position : -> (union #f number)
|
|
||||||
(define/private (find-this-position)
|
|
||||||
(let ([ed (find-containing-editor)])
|
|
||||||
(and ed
|
|
||||||
(send ed get-snip-position this))))
|
|
||||||
|
|
||||||
;; copy-contents-with-semicolons-to-position : (is-a? text%) number -> void
|
|
||||||
(define/private (copy-contents-with-semicolons-to-position to-ed from-ed pos)
|
|
||||||
(let loop ([snip (find-last-snip from-ed)])
|
|
||||||
(cond
|
|
||||||
[snip
|
|
||||||
(when (or (memq 'hard-newline (send snip get-flags))
|
|
||||||
(memq 'newline (send snip get-flags)))
|
|
||||||
(send to-ed insert "; " pos))
|
|
||||||
(send to-ed insert (send snip copy) pos)
|
|
||||||
(loop (send snip previous))]
|
|
||||||
[else
|
|
||||||
(send to-ed insert "; " pos)])))
|
|
||||||
|
|
||||||
;; find-last-snip : editor -> snip
|
|
||||||
;; returns the last snip in the editor
|
|
||||||
(define/private (find-last-snip ed)
|
|
||||||
(let loop ([snip (send ed find-first-snip)]
|
|
||||||
[acc (send ed find-first-snip)])
|
|
||||||
(cond
|
|
||||||
[snip (loop (send snip next) snip)]
|
|
||||||
[else acc])))
|
|
||||||
|
|
||||||
(define/public (read-special source line column position)
|
|
||||||
(make-special-comment "comment"))
|
|
||||||
(super-instantiate ())
|
|
||||||
(inherit set-snipclass)
|
|
||||||
(set-snipclass snipclass))))
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,75 +1,75 @@
|
||||||
(module exit (lib "a-unit.ss")
|
(module exit (lib "a-unit.ss")
|
||||||
(require (lib "string-constant.ss" "string-constants")
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^)
|
(import mred^)
|
||||||
(export (rename framework:exit^
|
(export (rename framework:exit^
|
||||||
(-exit exit)))
|
(-exit exit)))
|
||||||
|
|
||||||
(define can?-callbacks '())
|
(define can?-callbacks '())
|
||||||
(define on-callbacks '())
|
(define on-callbacks '())
|
||||||
|
|
||||||
(define insert-can?-callback
|
(define insert-can?-callback
|
||||||
(λ (cb)
|
(λ (cb)
|
||||||
(set! can?-callbacks (cons cb can?-callbacks))
|
(set! can?-callbacks (cons cb can?-callbacks))
|
||||||
(λ ()
|
(λ ()
|
||||||
(set! can?-callbacks
|
(set! can?-callbacks
|
||||||
(let loop ([cb-list can?-callbacks])
|
(let loop ([cb-list can?-callbacks])
|
||||||
(cond
|
(cond
|
||||||
[(null? cb-list) ()]
|
[(null? cb-list) ()]
|
||||||
[(eq? cb (car cb-list)) (cdr cb-list)]
|
[(eq? cb (car cb-list)) (cdr cb-list)]
|
||||||
[else (cons (car cb-list) (loop (cdr cb-list)))]))))))
|
[else (cons (car cb-list) (loop (cdr cb-list)))]))))))
|
||||||
|
|
||||||
(define insert-on-callback
|
(define insert-on-callback
|
||||||
(λ (cb)
|
(λ (cb)
|
||||||
(set! on-callbacks (cons cb on-callbacks))
|
(set! on-callbacks (cons cb on-callbacks))
|
||||||
(λ ()
|
(λ ()
|
||||||
(set! on-callbacks
|
(set! on-callbacks
|
||||||
(let loop ([cb-list on-callbacks])
|
(let loop ([cb-list on-callbacks])
|
||||||
(cond
|
(cond
|
||||||
[(null? cb-list) ()]
|
[(null? cb-list) ()]
|
||||||
[(eq? cb (car cb-list)) (cdr cb-list)]
|
[(eq? cb (car cb-list)) (cdr cb-list)]
|
||||||
[else (cons (car cb-list) (loop (cdr cb-list)))]))))))
|
[else (cons (car cb-list) (loop (cdr cb-list)))]))))))
|
||||||
|
|
||||||
(define is-exiting? #f)
|
(define is-exiting? #f)
|
||||||
(define (set-exiting b) (set! is-exiting? b))
|
(define (set-exiting b) (set! is-exiting? b))
|
||||||
(define (exiting?) is-exiting?)
|
(define (exiting?) is-exiting?)
|
||||||
|
|
||||||
(define (can-exit?) (andmap (λ (cb) (cb)) can?-callbacks))
|
(define (can-exit?) (andmap (λ (cb) (cb)) can?-callbacks))
|
||||||
(define (on-exit) (for-each (λ (cb) (cb)) on-callbacks))
|
(define (on-exit) (for-each (λ (cb) (cb)) on-callbacks))
|
||||||
|
|
||||||
(define (user-oks-exit)
|
(define (user-oks-exit)
|
||||||
(if (preferences:get 'framework:verify-exit)
|
(if (preferences:get 'framework:verify-exit)
|
||||||
(gui-utils:get-choice
|
(gui-utils:get-choice
|
||||||
(if (eq? (system-type) 'windows)
|
(if (eq? (system-type) 'windows)
|
||||||
(string-constant are-you-sure-exit)
|
(string-constant are-you-sure-exit)
|
||||||
(string-constant are-you-sure-quit))
|
(string-constant are-you-sure-quit))
|
||||||
(if (eq? (system-type) 'windows)
|
(if (eq? (system-type) 'windows)
|
||||||
(string-constant exit)
|
(string-constant exit)
|
||||||
(string-constant quit))
|
(string-constant quit))
|
||||||
(if (eq? (system-type) 'windows)
|
(if (eq? (system-type) 'windows)
|
||||||
(string-constant dont-exit)
|
(string-constant dont-exit)
|
||||||
(string-constant dont-quit))
|
(string-constant dont-quit))
|
||||||
(string-constant warning)
|
(string-constant warning)
|
||||||
#f
|
#f
|
||||||
#f
|
#f
|
||||||
'app
|
'app
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[() (not (preferences:get 'framework:verify-exit))]
|
[() (not (preferences:get 'framework:verify-exit))]
|
||||||
[(new) (preferences:set 'framework:verify-exit (not new))]))
|
[(new) (preferences:set 'framework:verify-exit (not new))]))
|
||||||
#t))
|
#t))
|
||||||
|
|
||||||
(define (-exit)
|
(define (-exit)
|
||||||
(set! is-exiting? #t)
|
(set! is-exiting? #t)
|
||||||
(cond
|
(cond
|
||||||
[(can-exit?)
|
[(can-exit?)
|
||||||
(on-exit)
|
(on-exit)
|
||||||
(queue-callback
|
(queue-callback
|
||||||
(λ ()
|
(λ ()
|
||||||
(exit)
|
(exit)
|
||||||
(set! is-exiting? #f)))]
|
(set! is-exiting? #f)))]
|
||||||
[else
|
[else
|
||||||
(set! is-exiting? #f)])))
|
(set! is-exiting? #f)])))
|
||||||
|
|
|
||||||
|
|
@ -1,67 +1,67 @@
|
||||||
|
|
||||||
(module finder (lib "a-unit.ss")
|
(module finder (lib "a-unit.ss")
|
||||||
(require (lib "string-constant.ss" "string-constants")
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "string.ss")
|
(lib "string.ss")
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "etc.ss"))
|
(lib "etc.ss"))
|
||||||
|
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix keymap: framework:keymap^])
|
[prefix keymap: framework:keymap^])
|
||||||
|
|
||||||
(export (rename framework:finder^
|
(export (rename framework:finder^
|
||||||
[-put-file put-file]
|
[-put-file put-file]
|
||||||
[-get-file get-file]))
|
[-get-file get-file]))
|
||||||
|
|
||||||
(define dialog-parent-parameter (make-parameter #f))
|
(define dialog-parent-parameter (make-parameter #f))
|
||||||
|
|
||||||
(define filter-match?
|
(define filter-match?
|
||||||
(λ (filter name msg)
|
(λ (filter name msg)
|
||||||
(let-values ([(base name dir?) (split-path name)])
|
(let-values ([(base name dir?) (split-path name)])
|
||||||
(if (regexp-match-exact? filter (path->bytes name))
|
(if (regexp-match-exact? filter (path->bytes name))
|
||||||
#t
|
#t
|
||||||
(begin
|
(begin
|
||||||
(message-box (string-constant error) msg)
|
(message-box (string-constant error) msg)
|
||||||
#f)))))
|
#f)))))
|
||||||
|
|
||||||
(define default-filters (make-parameter '(("Any" "*.*"))))
|
(define default-filters (make-parameter '(("Any" "*.*"))))
|
||||||
(define default-extension (make-parameter ""))
|
(define default-extension (make-parameter ""))
|
||||||
|
|
||||||
;; dialog wrappers
|
;; dialog wrappers
|
||||||
|
|
||||||
(define (*put-file style)
|
(define (*put-file style)
|
||||||
(opt-lambda ([name #f]
|
(opt-lambda ([name #f]
|
||||||
[directory #f]
|
[directory #f]
|
||||||
[replace? #f]
|
[replace? #f]
|
||||||
[prompt (string-constant select-file)]
|
[prompt (string-constant select-file)]
|
||||||
[filter #f]
|
[filter #f]
|
||||||
[filter-msg (string-constant file-wrong-form)]
|
[filter-msg (string-constant file-wrong-form)]
|
||||||
[parent-win (dialog-parent-parameter)])
|
[parent-win (dialog-parent-parameter)])
|
||||||
(let* ([directory (if (and (not directory) (string? name))
|
(let* ([directory (if (and (not directory) (string? name))
|
||||||
(path-only name)
|
(path-only name)
|
||||||
directory)]
|
directory)]
|
||||||
[name (or (and (string? name) (file-name-from-path name))
|
[name (or (and (string? name) (file-name-from-path name))
|
||||||
name)]
|
name)]
|
||||||
[f (put-file prompt parent-win directory name
|
[f (put-file prompt parent-win directory name
|
||||||
(default-extension) style (default-filters))])
|
(default-extension) style (default-filters))])
|
||||||
(and f (or (not filter) (filter-match? filter f filter-msg))
|
(and f (or (not filter) (filter-match? filter f filter-msg))
|
||||||
(let* ([f (normal-case-path (normalize-path f))]
|
(let* ([f (normal-case-path (normalize-path f))]
|
||||||
[dir (path-only f)]
|
[dir (path-only f)]
|
||||||
[name (file-name-from-path f)])
|
[name (file-name-from-path f)])
|
||||||
(cond
|
(cond
|
||||||
[(not (and (path-string? dir) (directory-exists? dir)))
|
[(not (and (path-string? dir) (directory-exists? dir)))
|
||||||
(message-box (string-constant error)
|
(message-box (string-constant error)
|
||||||
(string-constant dir-dne))
|
(string-constant dir-dne))
|
||||||
#f]
|
#f]
|
||||||
[(or (not name) (equal? name ""))
|
[(or (not name) (equal? name ""))
|
||||||
(message-box (string-constant error)
|
(message-box (string-constant error)
|
||||||
(string-constant empty-filename))
|
(string-constant empty-filename))
|
||||||
#f]
|
#f]
|
||||||
[else f]))))))
|
[else f]))))))
|
||||||
|
|
||||||
(define (*get-file style)
|
(define (*get-file style)
|
||||||
(opt-lambda ([directory #f]
|
(opt-lambda ([directory #f]
|
||||||
[prompt (string-constant select-file)]
|
[prompt (string-constant select-file)]
|
||||||
|
|
@ -80,24 +80,24 @@
|
||||||
(string-constant file-dne))
|
(string-constant file-dne))
|
||||||
#f]
|
#f]
|
||||||
[else f]))))))
|
[else f]))))))
|
||||||
|
|
||||||
;; external interfaces to file functions
|
;; external interfaces to file functions
|
||||||
|
|
||||||
(define std-put-file (*put-file '()))
|
(define std-put-file (*put-file '()))
|
||||||
(define std-get-file (*get-file '()))
|
(define std-get-file (*get-file '()))
|
||||||
(define common-put-file (*put-file '(common)))
|
(define common-put-file (*put-file '(common)))
|
||||||
(define common-get-file (*get-file '(common)))
|
(define common-get-file (*get-file '(common)))
|
||||||
(define common-get-file-list void)
|
(define common-get-file-list void)
|
||||||
|
|
||||||
(define -put-file
|
(define -put-file
|
||||||
(λ args
|
(λ args
|
||||||
(apply (case (preferences:get 'framework:file-dialogs)
|
(apply (case (preferences:get 'framework:file-dialogs)
|
||||||
[(std) std-put-file]
|
[(std) std-put-file]
|
||||||
[(common) common-put-file])
|
[(common) common-put-file])
|
||||||
args)))
|
args)))
|
||||||
(define -get-file
|
(define -get-file
|
||||||
(λ args
|
(λ args
|
||||||
(apply (case (preferences:get 'framework:file-dialogs)
|
(apply (case (preferences:get 'framework:file-dialogs)
|
||||||
[(std) std-get-file]
|
[(std) std-get-file]
|
||||||
[(common) common-get-file])
|
[(common) common-get-file])
|
||||||
args))))
|
args))))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -56,18 +56,18 @@
|
||||||
(and (,create-menu-item-name)
|
(and (,create-menu-item-name)
|
||||||
,(if (a-submenu-item? item)
|
,(if (a-submenu-item? item)
|
||||||
`(instantiate (get-menu%) ()
|
`(instantiate (get-menu%) ()
|
||||||
(label (,(an-item->string-name item)))
|
(label (,(an-item->string-name item)))
|
||||||
(parent ,(menu-item-menu-name item))
|
(parent ,(menu-item-menu-name item))
|
||||||
(help-string (,(an-item->help-string-name item)))
|
(help-string (,(an-item->help-string-name item)))
|
||||||
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))
|
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))
|
||||||
`(instantiate (get-menu-item%) ()
|
`(instantiate (get-menu-item%) ()
|
||||||
(label (,(an-item->string-name item)))
|
(label (,(an-item->string-name item)))
|
||||||
(parent ,(menu-item-menu-name item))
|
(parent ,(menu-item-menu-name item))
|
||||||
(callback (let ([,callback-name (λ (item evt) (,callback-name item evt))])
|
(callback (let ([,callback-name (λ (item evt) (,callback-name item evt))])
|
||||||
,callback-name))
|
,callback-name))
|
||||||
(shortcut ,key)
|
(shortcut ,key)
|
||||||
(help-string (,(an-item->help-string-name item)))
|
(help-string (,(an-item->help-string-name item)))
|
||||||
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))))))))
|
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))))))))
|
||||||
|
|
||||||
;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause))
|
;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause))
|
||||||
(define build-after-super-clause
|
(define build-after-super-clause
|
||||||
|
|
@ -95,7 +95,7 @@
|
||||||
(list)]
|
(list)]
|
||||||
[(generic-method? x)
|
[(generic-method? x)
|
||||||
null]))
|
null]))
|
||||||
|
|
||||||
;; build-before-super-generic-clause : generic -> (listof clause)
|
;; build-before-super-generic-clause : generic -> (listof clause)
|
||||||
(define (build-before-super-generic-clause generic)
|
(define (build-before-super-generic-clause generic)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -145,42 +145,42 @@
|
||||||
|
|
||||||
(pretty-print
|
(pretty-print
|
||||||
`(define standard-menus-mixin
|
`(define standard-menus-mixin
|
||||||
(mixin (basic<%>) (standard-menus<%>)
|
(mixin (basic<%>) (standard-menus<%>)
|
||||||
(inherit on-menu-char on-traverse-char)
|
(inherit on-menu-char on-traverse-char)
|
||||||
|
|
||||||
(define remove-prefs-callback
|
(define remove-prefs-callback
|
||||||
(preferences:add-callback
|
(preferences:add-callback
|
||||||
'framework:menu-bindings
|
'framework:menu-bindings
|
||||||
(λ (p v)
|
(λ (p v)
|
||||||
(let loop ([menu (get-menu-bar)])
|
(let loop ([menu (get-menu-bar)])
|
||||||
(when (is-a? menu menu:can-restore<%>)
|
(when (is-a? menu menu:can-restore<%>)
|
||||||
(if v
|
(if v
|
||||||
(send menu restore-keybinding)
|
(send menu restore-keybinding)
|
||||||
(send menu set-shortcut #f)))
|
(send menu set-shortcut #f)))
|
||||||
(when (is-a? menu menu:can-restore-underscore<%>)
|
(when (is-a? menu menu:can-restore-underscore<%>)
|
||||||
(if v
|
(if v
|
||||||
(send menu restore-underscores)
|
(send menu restore-underscores)
|
||||||
(send menu erase-underscores)))
|
(send menu erase-underscores)))
|
||||||
(when (is-a? menu menu-item-container<%>)
|
(when (is-a? menu menu-item-container<%>)
|
||||||
(for-each loop (send menu get-items)))))))
|
(for-each loop (send menu get-items)))))))
|
||||||
|
|
||||||
(inherit get-menu-bar show can-close? get-edit-target-object)
|
(inherit get-menu-bar show can-close? get-edit-target-object)
|
||||||
,@(apply append (map (λ (x)
|
,@(apply append (map (λ (x)
|
||||||
(cond
|
(cond
|
||||||
[(between? x) (build-before-super-between-clause x)]
|
[(between? x) (build-before-super-between-clause x)]
|
||||||
[(or (after? x) (before? x)) (build-before-super-before/after-clause x)]
|
[(or (after? x) (before? x)) (build-before-super-before/after-clause x)]
|
||||||
[(an-item? x) (build-before-super-item-clause x)]
|
[(an-item? x) (build-before-super-item-clause x)]
|
||||||
[(generic? x) (build-before-super-generic-clause x)]))
|
[(generic? x) (build-before-super-generic-clause x)]))
|
||||||
items))
|
items))
|
||||||
(super-instantiate ())
|
(super-instantiate ())
|
||||||
,@(apply append (map (λ (x)
|
,@(apply append (map (λ (x)
|
||||||
(cond
|
(cond
|
||||||
[(between? x) (build-after-super-between-clause x)]
|
[(between? x) (build-after-super-between-clause x)]
|
||||||
[(an-item? x) (build-after-super-item-clause x)]
|
[(an-item? x) (build-after-super-item-clause x)]
|
||||||
[(or (after? x) (before? x)) (build-after-super-before/after-clause x)]
|
[(or (after? x) (before? x)) (build-after-super-before/after-clause x)]
|
||||||
[(generic? x) (build-after-super-generic-clause x)]))
|
[(generic? x) (build-after-super-generic-clause x)]))
|
||||||
items))
|
items))
|
||||||
(reorder-menus this)))
|
(reorder-menus this)))
|
||||||
port))
|
port))
|
||||||
'text
|
'text
|
||||||
'truncate))
|
'truncate))
|
||||||
|
|
|
||||||
|
|
@ -3,12 +3,12 @@
|
||||||
(require (lib "string-constant.ss" "string-constants")
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "file.ss"))
|
(lib "file.ss"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix application: framework:application^]
|
[prefix application: framework:application^]
|
||||||
[prefix frame: framework:frame^]
|
[prefix frame: framework:frame^]
|
||||||
|
|
@ -16,319 +16,319 @@
|
||||||
[prefix canvas: framework:canvas^]
|
[prefix canvas: framework:canvas^]
|
||||||
[prefix menu: framework:menu^])
|
[prefix menu: framework:menu^])
|
||||||
(export framework:group^)
|
(export framework:group^)
|
||||||
|
|
||||||
|
(define-struct frame (frame id))
|
||||||
|
|
||||||
|
(define mdi-parent #f)
|
||||||
|
|
||||||
|
(define %
|
||||||
|
(class object%
|
||||||
|
|
||||||
(define-struct frame (frame id))
|
[define active-frame #f]
|
||||||
|
[define most-recent-window-box (make-weak-box #f)]
|
||||||
|
[define frame-counter 0]
|
||||||
|
[define frames null]
|
||||||
|
[define todo-to-new-frames void]
|
||||||
|
|
||||||
(define mdi-parent #f)
|
[define windows-menus null]
|
||||||
|
|
||||||
(define %
|
;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%))
|
||||||
(class object%
|
(define/private (get-windows-menu frame)
|
||||||
|
(let ([menu-bar (send frame get-menu-bar)])
|
||||||
|
(and menu-bar
|
||||||
|
(let ([menus (send menu-bar get-items)])
|
||||||
|
(ormap (λ (x)
|
||||||
|
(if (string=? (string-constant windows-menu)
|
||||||
|
(send x get-plain-label))
|
||||||
|
x
|
||||||
|
#f))
|
||||||
|
menus)))))
|
||||||
|
|
||||||
|
(define/private (insert-windows-menu frame)
|
||||||
|
(let ([menu (get-windows-menu frame)])
|
||||||
|
(when menu
|
||||||
|
(set! windows-menus (cons menu windows-menus)))))
|
||||||
|
|
||||||
|
(define/private (remove-windows-menu frame)
|
||||||
|
(let ([menu (get-windows-menu frame)])
|
||||||
|
|
||||||
[define active-frame #f]
|
(when menu
|
||||||
[define most-recent-window-box (make-weak-box #f)]
|
;; to help the (conservative) gc.
|
||||||
[define frame-counter 0]
|
(for-each (λ (i) (send i delete)) (send menu get-items))
|
||||||
[define frames null]
|
|
||||||
[define todo-to-new-frames void]
|
(set! windows-menus
|
||||||
|
(remove
|
||||||
[define windows-menus null]
|
menu
|
||||||
|
windows-menus
|
||||||
;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%))
|
eq?)))))
|
||||||
(define/private (get-windows-menu frame)
|
|
||||||
(let ([menu-bar (send frame get-menu-bar)])
|
(define/private (update-windows-menus)
|
||||||
(and menu-bar
|
(let* ([windows (length windows-menus)]
|
||||||
(let ([menus (send menu-bar get-items)])
|
[default-name (string-constant untitled)]
|
||||||
(ormap (λ (x)
|
[get-name
|
||||||
(if (string=? (string-constant windows-menu)
|
(λ (frame)
|
||||||
(send x get-plain-label))
|
(let ([label (send frame get-label)])
|
||||||
x
|
(if (string=? label "")
|
||||||
#f))
|
(if (method-in-interface? 'get-entire-label (object-interface frame))
|
||||||
menus)))))
|
(let ([label (send frame get-entire-label)])
|
||||||
|
(if (string=? label "")
|
||||||
(define/private (insert-windows-menu frame)
|
default-name
|
||||||
(let ([menu (get-windows-menu frame)])
|
label))
|
||||||
(when menu
|
default-name)
|
||||||
(set! windows-menus (cons menu windows-menus)))))
|
label)))]
|
||||||
|
[sorted/visible-frames
|
||||||
(define/private (remove-windows-menu frame)
|
(sort
|
||||||
(let ([menu (get-windows-menu frame)])
|
(filter (λ (x) (send (frame-frame x) is-shown?)) frames)
|
||||||
|
(λ (f1 f2)
|
||||||
(when menu
|
(string-ci<=? (get-name (frame-frame f1))
|
||||||
;; to help the (conservative) gc.
|
(get-name (frame-frame f2)))))])
|
||||||
(for-each (λ (i) (send i delete)) (send menu get-items))
|
(for-each
|
||||||
|
(λ (menu)
|
||||||
(set! windows-menus
|
(for-each (λ (item) (send item delete)) (send menu get-items))
|
||||||
(remove
|
(when (eq? (system-type) 'macosx)
|
||||||
menu
|
(new menu:can-restore-menu-item%
|
||||||
windows-menus
|
[label (string-constant minimize)]
|
||||||
eq?)))))
|
[parent menu]
|
||||||
|
[callback (λ (x y) (send (send (send menu get-parent) get-frame) iconize #t))]
|
||||||
(define/private (update-windows-menus)
|
[shortcut #\m])
|
||||||
(let* ([windows (length windows-menus)]
|
(new menu:can-restore-menu-item%
|
||||||
[default-name (string-constant untitled)]
|
[label (string-constant zoom)]
|
||||||
[get-name
|
[parent menu]
|
||||||
(λ (frame)
|
[callback (λ (x y)
|
||||||
(let ([label (send frame get-label)])
|
(let ([frame (send (send menu get-parent) get-frame)])
|
||||||
(if (string=? label "")
|
(send frame maximize (not (send frame is-maximized?)))))])
|
||||||
(if (method-in-interface? 'get-entire-label (object-interface frame))
|
(make-object separator-menu-item% menu))
|
||||||
(let ([label (send frame get-entire-label)])
|
(instantiate menu:can-restore-menu-item% ()
|
||||||
(if (string=? label "")
|
(label (string-constant bring-frame-to-front...))
|
||||||
default-name
|
(parent menu)
|
||||||
label))
|
(callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame))))
|
||||||
default-name)
|
(shortcut #\j))
|
||||||
label)))]
|
(instantiate menu:can-restore-menu-item% ()
|
||||||
[sorted/visible-frames
|
(label (string-constant most-recent-window))
|
||||||
(sort
|
(parent menu)
|
||||||
(filter (λ (x) (send (frame-frame x) is-shown?)) frames)
|
(callback (λ (x y) (most-recent-window-to-front)))
|
||||||
(λ (f1 f2)
|
(shortcut #\'))
|
||||||
(string-ci<=? (get-name (frame-frame f1))
|
(make-object separator-menu-item% menu)
|
||||||
(get-name (frame-frame f2)))))])
|
(for-each
|
||||||
(for-each
|
(λ (frame)
|
||||||
(λ (menu)
|
(let ([frame (frame-frame frame)])
|
||||||
(for-each (λ (item) (send item delete)) (send menu get-items))
|
(make-object menu-item%
|
||||||
(when (eq? (system-type) 'macosx)
|
(regexp-replace*
|
||||||
(new menu:can-restore-menu-item%
|
#rx"&"
|
||||||
[label (string-constant minimize)]
|
(gui-utils:trim-string (get-name frame) 200)
|
||||||
[parent menu]
|
"&&")
|
||||||
[callback (λ (x y) (send (send (send menu get-parent) get-frame) iconize #t))]
|
menu
|
||||||
[shortcut #\m])
|
(λ (_1 _2)
|
||||||
(new menu:can-restore-menu-item%
|
(send frame show #t)))))
|
||||||
[label (string-constant zoom)]
|
sorted/visible-frames))
|
||||||
[parent menu]
|
windows-menus)))
|
||||||
[callback (λ (x y)
|
|
||||||
(let ([frame (send (send menu get-parent) get-frame)])
|
;; most-recent-window-to-front : -> void?
|
||||||
(send frame maximize (not (send frame is-maximized?)))))])
|
;; brings the most recent window to the front
|
||||||
(make-object separator-menu-item% menu))
|
(define/private (most-recent-window-to-front)
|
||||||
(instantiate menu:can-restore-menu-item% ()
|
(let ([most-recent-window (weak-box-value most-recent-window-box)])
|
||||||
(label (string-constant bring-frame-to-front...))
|
(when most-recent-window
|
||||||
(parent menu)
|
(send most-recent-window show #t))))
|
||||||
(callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame))))
|
|
||||||
(shortcut #\j))
|
(define/private (update-close-menu-item-state)
|
||||||
(instantiate menu:can-restore-menu-item% ()
|
(let* ([set-close-menu-item-state!
|
||||||
(label (string-constant most-recent-window))
|
(λ (frame state)
|
||||||
(parent menu)
|
(when (is-a? frame frame:standard-menus<%>)
|
||||||
(callback (λ (x y) (most-recent-window-to-front)))
|
(let ([close-menu-item (send frame file-menu:get-close-menu)])
|
||||||
(shortcut #\'))
|
(when close-menu-item
|
||||||
(make-object separator-menu-item% menu)
|
(send close-menu-item enable state)))))])
|
||||||
(for-each
|
(if (eq? (length frames) 1)
|
||||||
(λ (frame)
|
(set-close-menu-item-state! (car frames) #f)
|
||||||
(let ([frame (frame-frame frame)])
|
(for-each (λ (a-frame)
|
||||||
(make-object menu-item%
|
(set-close-menu-item-state! a-frame #t))
|
||||||
(regexp-replace*
|
frames))))
|
||||||
#rx"&"
|
|
||||||
(gui-utils:trim-string (get-name frame) 200)
|
(field [open-here-frame #f])
|
||||||
"&&")
|
(define/public (set-open-here-frame fr) (set! open-here-frame fr))
|
||||||
menu
|
(define/public (get-open-here-frame)
|
||||||
(λ (_1 _2)
|
(cond
|
||||||
(send frame show #t)))))
|
[open-here-frame open-here-frame]
|
||||||
sorted/visible-frames))
|
[else
|
||||||
windows-menus)))
|
(let ([candidates
|
||||||
|
(filter (λ (x) (is-a? (frame-frame x) frame:open-here<%>))
|
||||||
;; most-recent-window-to-front : -> void?
|
frames)])
|
||||||
;; brings the most recent window to the front
|
(if (null? candidates)
|
||||||
(define/private (most-recent-window-to-front)
|
#f
|
||||||
(let ([most-recent-window (weak-box-value most-recent-window-box)])
|
(frame-frame (car candidates))))]))
|
||||||
(when most-recent-window
|
|
||||||
(send most-recent-window show #t))))
|
(public get-mdi-parent frame-label-changed for-each-frame
|
||||||
|
get-active-frame set-active-frame insert-frame
|
||||||
(define/private (update-close-menu-item-state)
|
remove-frame clear on-close-all can-close-all? locate-file get-frames
|
||||||
(let* ([set-close-menu-item-state!
|
frame-shown/hidden)
|
||||||
(λ (frame state)
|
(define (get-mdi-parent)
|
||||||
(when (is-a? frame frame:standard-menus<%>)
|
(when (and (eq? (system-type) 'windows)
|
||||||
(let ([close-menu-item (send frame file-menu:get-close-menu)])
|
(preferences:get 'framework:windows-mdi)
|
||||||
(when close-menu-item
|
(not mdi-parent))
|
||||||
(send close-menu-item enable state)))))])
|
(set! mdi-parent (make-object frame% (application:current-app-name)
|
||||||
(if (eq? (length frames) 1)
|
#f #f #f #f #f
|
||||||
(set-close-menu-item-state! (car frames) #f)
|
'(mdi-parent)))
|
||||||
(for-each (λ (a-frame)
|
(send mdi-parent show #t))
|
||||||
(set-close-menu-item-state! a-frame #t))
|
mdi-parent)
|
||||||
frames))))
|
|
||||||
|
(define (get-frames) (map frame-frame frames))
|
||||||
(field [open-here-frame #f])
|
|
||||||
(define/public (set-open-here-frame fr) (set! open-here-frame fr))
|
(define (frame-label-changed frame)
|
||||||
(define/public (get-open-here-frame)
|
(when (memq frame (map frame-frame frames))
|
||||||
(cond
|
(update-windows-menus)))
|
||||||
[open-here-frame open-here-frame]
|
|
||||||
[else
|
(define (frame-shown/hidden frame)
|
||||||
(let ([candidates
|
(when (memq frame (map frame-frame frames))
|
||||||
(filter (λ (x) (is-a? (frame-frame x) frame:open-here<%>))
|
(update-windows-menus)))
|
||||||
frames)])
|
|
||||||
(if (null? candidates)
|
(define (for-each-frame f)
|
||||||
#f
|
(for-each (λ (x) (f (frame-frame x))) frames)
|
||||||
(frame-frame (car candidates))))]))
|
(set! todo-to-new-frames
|
||||||
|
(let ([old todo-to-new-frames])
|
||||||
(public get-mdi-parent frame-label-changed for-each-frame
|
(λ (frame) (old frame) (f frame)))))
|
||||||
get-active-frame set-active-frame insert-frame
|
|
||||||
remove-frame clear on-close-all can-close-all? locate-file get-frames
|
(define (get-active-frame)
|
||||||
frame-shown/hidden)
|
(cond
|
||||||
(define (get-mdi-parent)
|
[active-frame active-frame]
|
||||||
(when (and (eq? (system-type) 'windows)
|
[(null? frames) #f]
|
||||||
(preferences:get 'framework:windows-mdi)
|
[else (frame-frame (car frames))]))
|
||||||
(not mdi-parent))
|
|
||||||
(set! mdi-parent (make-object frame% (application:current-app-name)
|
(define (set-active-frame f)
|
||||||
#f #f #f #f #f
|
(when (and active-frame
|
||||||
'(mdi-parent)))
|
(not (eq? active-frame f)))
|
||||||
(send mdi-parent show #t))
|
(set! most-recent-window-box (make-weak-box active-frame)))
|
||||||
mdi-parent)
|
(set! active-frame f))
|
||||||
|
|
||||||
(define (get-frames) (map frame-frame frames))
|
(define (insert-frame new-frame)
|
||||||
|
(unless (memf (λ (fr) (eq? (frame-frame fr) new-frame))
|
||||||
(define (frame-label-changed frame)
|
frames)
|
||||||
(when (memq frame (map frame-frame frames))
|
(set! frame-counter (add1 frame-counter))
|
||||||
(update-windows-menus)))
|
(let ([new-frames (cons (make-frame new-frame frame-counter)
|
||||||
|
frames)])
|
||||||
(define (frame-shown/hidden frame)
|
(set! frames new-frames)
|
||||||
(when (memq frame (map frame-frame frames))
|
(update-close-menu-item-state)
|
||||||
(update-windows-menus)))
|
(insert-windows-menu new-frame)
|
||||||
|
(update-windows-menus))
|
||||||
(define (for-each-frame f)
|
(todo-to-new-frames new-frame)))
|
||||||
(for-each (λ (x) (f (frame-frame x))) frames)
|
|
||||||
(set! todo-to-new-frames
|
(define (remove-frame f)
|
||||||
(let ([old todo-to-new-frames])
|
(when (eq? f active-frame)
|
||||||
(λ (frame) (old frame) (f frame)))))
|
(set! active-frame #f))
|
||||||
|
(let ([new-frames
|
||||||
(define (get-active-frame)
|
(remove
|
||||||
|
f frames
|
||||||
|
(λ (f fr) (eq? f (frame-frame fr))))])
|
||||||
|
(set! frames new-frames)
|
||||||
|
(update-close-menu-item-state)
|
||||||
|
(remove-windows-menu f)
|
||||||
|
(update-windows-menus)))
|
||||||
|
|
||||||
|
(define (clear)
|
||||||
|
(set! frames null)
|
||||||
|
#t)
|
||||||
|
|
||||||
|
(define (on-close-all)
|
||||||
|
(for-each (λ (f)
|
||||||
|
(let ([frame (frame-frame f)])
|
||||||
|
(send frame on-close)
|
||||||
|
(send frame show #f)))
|
||||||
|
frames))
|
||||||
|
|
||||||
|
(define (can-close-all?)
|
||||||
|
(andmap (λ (f)
|
||||||
|
(let ([frame (frame-frame f)])
|
||||||
|
(send frame can-close?)))
|
||||||
|
frames))
|
||||||
|
|
||||||
|
(define (locate-file name)
|
||||||
|
(let* ([normalized
|
||||||
|
;; allow for the possiblity of filenames that are urls
|
||||||
|
(with-handlers ([(λ (x) #t)
|
||||||
|
(λ (x) name)])
|
||||||
|
(normal-case-path
|
||||||
|
(normalize-path name)))]
|
||||||
|
[test-frame
|
||||||
|
(λ (frame)
|
||||||
|
(and (is-a? frame frame:basic<%>)
|
||||||
|
(send frame editing-this-file? normalized)))])
|
||||||
|
(let loop ([frames frames])
|
||||||
(cond
|
(cond
|
||||||
[active-frame active-frame]
|
|
||||||
[(null? frames) #f]
|
[(null? frames) #f]
|
||||||
[else (frame-frame (car frames))]))
|
[else
|
||||||
|
(let* ([frame (frame-frame (car frames))])
|
||||||
(define (set-active-frame f)
|
(if (test-frame frame)
|
||||||
(when (and active-frame
|
frame
|
||||||
(not (eq? active-frame f)))
|
(loop (cdr frames))))]))))
|
||||||
(set! most-recent-window-box (make-weak-box active-frame)))
|
|
||||||
(set! active-frame f))
|
|
||||||
|
|
||||||
(define (insert-frame new-frame)
|
|
||||||
(unless (memf (λ (fr) (eq? (frame-frame fr) new-frame))
|
|
||||||
frames)
|
|
||||||
(set! frame-counter (add1 frame-counter))
|
|
||||||
(let ([new-frames (cons (make-frame new-frame frame-counter)
|
|
||||||
frames)])
|
|
||||||
(set! frames new-frames)
|
|
||||||
(update-close-menu-item-state)
|
|
||||||
(insert-windows-menu new-frame)
|
|
||||||
(update-windows-menus))
|
|
||||||
(todo-to-new-frames new-frame)))
|
|
||||||
|
|
||||||
(define (remove-frame f)
|
|
||||||
(when (eq? f active-frame)
|
|
||||||
(set! active-frame #f))
|
|
||||||
(let ([new-frames
|
|
||||||
(remove
|
|
||||||
f frames
|
|
||||||
(λ (f fr) (eq? f (frame-frame fr))))])
|
|
||||||
(set! frames new-frames)
|
|
||||||
(update-close-menu-item-state)
|
|
||||||
(remove-windows-menu f)
|
|
||||||
(update-windows-menus)))
|
|
||||||
|
|
||||||
(define (clear)
|
|
||||||
(set! frames null)
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(define (on-close-all)
|
|
||||||
(for-each (λ (f)
|
|
||||||
(let ([frame (frame-frame f)])
|
|
||||||
(send frame on-close)
|
|
||||||
(send frame show #f)))
|
|
||||||
frames))
|
|
||||||
|
|
||||||
(define (can-close-all?)
|
|
||||||
(andmap (λ (f)
|
|
||||||
(let ([frame (frame-frame f)])
|
|
||||||
(send frame can-close?)))
|
|
||||||
frames))
|
|
||||||
|
|
||||||
(define (locate-file name)
|
|
||||||
(let* ([normalized
|
|
||||||
;; allow for the possiblity of filenames that are urls
|
|
||||||
(with-handlers ([(λ (x) #t)
|
|
||||||
(λ (x) name)])
|
|
||||||
(normal-case-path
|
|
||||||
(normalize-path name)))]
|
|
||||||
[test-frame
|
|
||||||
(λ (frame)
|
|
||||||
(and (is-a? frame frame:basic<%>)
|
|
||||||
(send frame editing-this-file? normalized)))])
|
|
||||||
(let loop ([frames frames])
|
|
||||||
(cond
|
|
||||||
[(null? frames) #f]
|
|
||||||
[else
|
|
||||||
(let* ([frame (frame-frame (car frames))])
|
|
||||||
(if (test-frame frame)
|
|
||||||
frame
|
|
||||||
(loop (cdr frames))))]))))
|
|
||||||
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
(define (choose-a-frame parent)
|
(super-new)))
|
||||||
(letrec-values ([(sorted-frames)
|
|
||||||
(sort
|
(define (choose-a-frame parent)
|
||||||
(send (get-the-frame-group) get-frames)
|
(letrec-values ([(sorted-frames)
|
||||||
(λ (x y) (string-ci<=? (send x get-label) (send y get-label))))]
|
(sort
|
||||||
[(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
|
(send (get-the-frame-group) get-frames)
|
||||||
[(lb) (instantiate list-box% ()
|
(λ (x y) (string-ci<=? (send x get-label) (send y get-label))))]
|
||||||
(label #f)
|
[(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
|
||||||
(choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames))
|
[(lb) (instantiate list-box% ()
|
||||||
(callback (λ (x y) (listbox-callback y)))
|
(label #f)
|
||||||
(parent d))]
|
(choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames))
|
||||||
[(t) (instantiate text:hide-caret/selection% ())]
|
(callback (λ (x y) (listbox-callback y)))
|
||||||
[(ec) (instantiate canvas:basic% ()
|
(parent d))]
|
||||||
(parent d)
|
[(t) (instantiate text:hide-caret/selection% ())]
|
||||||
(stretchable-height #f))]
|
[(ec) (instantiate canvas:basic% ()
|
||||||
[(bp) (instantiate horizontal-panel% ()
|
(parent d)
|
||||||
(parent d)
|
(stretchable-height #f))]
|
||||||
(stretchable-height #f)
|
[(bp) (instantiate horizontal-panel% ()
|
||||||
(alignment '(right center)))]
|
(parent d)
|
||||||
[(cancelled?) #t]
|
(stretchable-height #f)
|
||||||
[(listbox-callback)
|
(alignment '(right center)))]
|
||||||
(λ (evt)
|
[(cancelled?) #t]
|
||||||
(case (send evt get-event-type)
|
[(listbox-callback)
|
||||||
[(list-box)
|
(λ (evt)
|
||||||
|
(case (send evt get-event-type)
|
||||||
(send ok enable (pair? (send lb get-selections)))
|
[(list-box)
|
||||||
|
|
||||||
(let ([full-name
|
(send ok enable (pair? (send lb get-selections)))
|
||||||
(let ([sels (send lb get-selections)])
|
|
||||||
(and (pair? sels)
|
(let ([full-name
|
||||||
(let ([fr (list-ref sorted-frames (car sels))])
|
(let ([sels (send lb get-selections)])
|
||||||
(and (is-a? fr frame:basic%)
|
(and (pair? sels)
|
||||||
(send fr get-filename)))))])
|
(let ([fr (list-ref sorted-frames (car sels))])
|
||||||
(send t begin-edit-sequence)
|
(and (is-a? fr frame:basic%)
|
||||||
(send t erase)
|
(send fr get-filename)))))])
|
||||||
(when full-name
|
(send t begin-edit-sequence)
|
||||||
(send t insert (path->string full-name)))
|
(send t erase)
|
||||||
(send t end-edit-sequence))]
|
(when full-name
|
||||||
[(list-box-dclick)
|
(send t insert (path->string full-name)))
|
||||||
(set! cancelled? #f)
|
(send t end-edit-sequence))]
|
||||||
(send d show #f)]))]
|
[(list-box-dclick)
|
||||||
[(ok cancel)
|
(set! cancelled? #f)
|
||||||
(gui-utils:ok/cancel-buttons
|
(send d show #f)]))]
|
||||||
bp
|
[(ok cancel)
|
||||||
(λ (x y)
|
(gui-utils:ok/cancel-buttons
|
||||||
(set! cancelled? #f)
|
bp
|
||||||
(send d show #f))
|
(λ (x y)
|
||||||
(λ (x y)
|
(set! cancelled? #f)
|
||||||
(send d show #f)))])
|
(send d show #f))
|
||||||
(send ec set-line-count 3)
|
(λ (x y)
|
||||||
(send ec set-editor t)
|
(send d show #f)))])
|
||||||
(send t auto-wrap #t)
|
(send ec set-line-count 3)
|
||||||
(let ([fr (car sorted-frames)])
|
(send ec set-editor t)
|
||||||
(when (and (is-a? fr frame:basic<%>)
|
(send t auto-wrap #t)
|
||||||
(send fr get-filename))
|
(let ([fr (car sorted-frames)])
|
||||||
(send t insert (path->string (send (car sorted-frames) get-filename))))
|
(when (and (is-a? fr frame:basic<%>)
|
||||||
(send lb set-selection 0))
|
(send fr get-filename))
|
||||||
(send d show #t)
|
(send t insert (path->string (send (car sorted-frames) get-filename))))
|
||||||
(unless cancelled?
|
(send lb set-selection 0))
|
||||||
(let ([sels (send lb get-selections)])
|
(send d show #t)
|
||||||
(unless (null? sels)
|
(unless cancelled?
|
||||||
(send (list-ref sorted-frames (car sels)) show #t))))))
|
(let ([sels (send lb get-selections)])
|
||||||
|
(unless (null? sels)
|
||||||
|
(send (list-ref sorted-frames (car sels)) show #t))))))
|
||||||
(define (internal-get-the-frame-group)
|
|
||||||
(let ([the-frame-group (make-object %)])
|
|
||||||
(set! internal-get-the-frame-group (λ () the-frame-group))
|
(define (internal-get-the-frame-group)
|
||||||
(internal-get-the-frame-group)))
|
(let ([the-frame-group (make-object %)])
|
||||||
|
(set! internal-get-the-frame-group (λ () the-frame-group))
|
||||||
(define (get-the-frame-group)
|
(internal-get-the-frame-group)))
|
||||||
(internal-get-the-frame-group)))
|
|
||||||
|
(define (get-the-frame-group)
|
||||||
|
(internal-get-the-frame-group)))
|
||||||
|
|
|
||||||
|
|
@ -3,11 +3,11 @@
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "hierlist.ss" "hierlist")
|
(lib "hierlist.ss" "hierlist")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "string-constant.ss" "string-constants"))
|
(lib "string-constant.ss" "string-constants"))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,72 +1,72 @@
|
||||||
(module icon (lib "a-unit.ss")
|
(module icon (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
(lib "include-bitmap.ss" "mrlib")
|
(lib "include-bitmap.ss" "mrlib")
|
||||||
"bday.ss"
|
"bday.ss"
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^)
|
(import mred^)
|
||||||
(export framework:icon^)
|
(export framework:icon^)
|
||||||
|
|
||||||
(define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons"))))
|
(define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons"))))
|
||||||
(define (get-eof-bitmap) (force eof-bitmap))
|
(define (get-eof-bitmap) (force eof-bitmap))
|
||||||
|
|
||||||
(define anchor-bitmap (delay (include-bitmap (lib "anchor.gif" "icons"))))
|
(define anchor-bitmap (delay (include-bitmap (lib "anchor.gif" "icons"))))
|
||||||
(define (get-anchor-bitmap) (force anchor-bitmap))
|
(define (get-anchor-bitmap) (force anchor-bitmap))
|
||||||
|
|
||||||
(define lock-bitmap (delay (include-bitmap (lib "lock.gif" "icons"))))
|
(define lock-bitmap (delay (include-bitmap (lib "lock.gif" "icons"))))
|
||||||
(define (get-lock-bitmap) (force lock-bitmap))
|
(define (get-lock-bitmap) (force lock-bitmap))
|
||||||
(define unlock-bitmap (delay (include-bitmap (lib "unlock.gif" "icons"))))
|
(define unlock-bitmap (delay (include-bitmap (lib "unlock.gif" "icons"))))
|
||||||
(define (get-unlock-bitmap) (force unlock-bitmap))
|
(define (get-unlock-bitmap) (force unlock-bitmap))
|
||||||
|
|
||||||
(define autowrap-bitmap (delay (include-bitmap (lib "return.xbm" "icons"))))
|
(define autowrap-bitmap (delay (include-bitmap (lib "return.xbm" "icons"))))
|
||||||
(define (get-autowrap-bitmap) (force autowrap-bitmap))
|
(define (get-autowrap-bitmap) (force autowrap-bitmap))
|
||||||
(define paren-highlight-bitmap (delay (include-bitmap (lib "paren.xbm" "icons"))))
|
(define paren-highlight-bitmap (delay (include-bitmap (lib "paren.xbm" "icons"))))
|
||||||
(define (get-paren-highlight-bitmap) (force paren-highlight-bitmap))
|
(define (get-paren-highlight-bitmap) (force paren-highlight-bitmap))
|
||||||
|
|
||||||
(define-syntax (make-get-cursor stx)
|
(define-syntax (make-get-cursor stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ name mask fallback)
|
[(_ name mask fallback)
|
||||||
(syntax
|
(syntax
|
||||||
(let ([ans (delay
|
(let ([ans (delay
|
||||||
(let* ([msk-b (include-bitmap (lib mask "icons"))]
|
(let* ([msk-b (include-bitmap (lib mask "icons"))]
|
||||||
[csr-b (include-bitmap (lib name "icons"))])
|
[csr-b (include-bitmap (lib name "icons"))])
|
||||||
(if (and (send msk-b ok?)
|
(if (and (send msk-b ok?)
|
||||||
(send csr-b ok?))
|
(send csr-b ok?))
|
||||||
(let ([csr (make-object cursor% msk-b csr-b 7 7)])
|
(let ([csr (make-object cursor% msk-b csr-b 7 7)])
|
||||||
(if (send csr ok?)
|
(if (send csr ok?)
|
||||||
csr
|
csr
|
||||||
(make-object cursor% fallback)))
|
(make-object cursor% fallback)))
|
||||||
(make-object cursor% fallback))))])
|
(make-object cursor% fallback))))])
|
||||||
(λ ()
|
(λ ()
|
||||||
(force ans))))]))
|
(force ans))))]))
|
||||||
|
|
||||||
(define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
|
(define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
|
||||||
(define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
|
(define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
|
||||||
|
|
||||||
(define mrf-on-bitmap (delay (include-bitmap (lib "mrf.jpg" "icons"))))
|
(define mrf-on-bitmap (delay (include-bitmap (lib "mrf.jpg" "icons"))))
|
||||||
(define gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons"))))
|
(define gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons"))))
|
||||||
|
|
||||||
(define (make-off-bitmap onb)
|
(define (make-off-bitmap onb)
|
||||||
(let* ([bitmap (make-object bitmap%
|
(let* ([bitmap (make-object bitmap%
|
||||||
(send onb get-width)
|
(send onb get-width)
|
||||||
(send onb get-height))]
|
(send onb get-height))]
|
||||||
[bdc (make-object bitmap-dc% bitmap)])
|
[bdc (make-object bitmap-dc% bitmap)])
|
||||||
(send bdc clear)
|
(send bdc clear)
|
||||||
(send bdc set-bitmap #f)
|
(send bdc set-bitmap #f)
|
||||||
bitmap))
|
bitmap))
|
||||||
|
|
||||||
(define mrf-off-bitmap (delay (make-off-bitmap (force mrf-on-bitmap))))
|
(define mrf-off-bitmap (delay (make-off-bitmap (force mrf-on-bitmap))))
|
||||||
(define gc-off-bitmap (delay (make-off-bitmap (force gc-on-bitmap))))
|
(define gc-off-bitmap (delay (make-off-bitmap (force gc-on-bitmap))))
|
||||||
|
|
||||||
(define (get-gc-on-bitmap)
|
(define (get-gc-on-bitmap)
|
||||||
(force
|
(force
|
||||||
(if (mrf-bday?)
|
(if (mrf-bday?)
|
||||||
mrf-on-bitmap
|
mrf-on-bitmap
|
||||||
gc-on-bitmap)))
|
gc-on-bitmap)))
|
||||||
|
|
||||||
(define (get-gc-off-bitmap)
|
(define (get-gc-off-bitmap)
|
||||||
(force
|
(force
|
||||||
(if (mrf-bday?)
|
(if (mrf-bday?)
|
||||||
mrf-off-bitmap
|
mrf-off-bitmap
|
||||||
gc-off-bitmap))))
|
gc-off-bitmap))))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,8 +1,8 @@
|
||||||
(module main (lib "a-unit.ss")
|
(module main (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix preferences: framework:preferences^]
|
[prefix preferences: framework:preferences^]
|
||||||
|
|
@ -276,7 +276,7 @@
|
||||||
(color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
|
(color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
|
||||||
"light blue"
|
"light blue"
|
||||||
(make-object color% 62 67 155))
|
(make-object color% 62 67 155))
|
||||||
|
|
||||||
|
|
||||||
;; groups
|
;; groups
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,48 +1,48 @@
|
||||||
(module menu (lib "a-unit.ss")
|
(module menu (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../preferences.ss"
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^)
|
(import mred^)
|
||||||
(export framework:menu^)
|
(export framework:menu^)
|
||||||
|
|
||||||
|
(define can-restore<%>
|
||||||
|
(interface (selectable-menu-item<%>)
|
||||||
|
restore-keybinding))
|
||||||
|
|
||||||
|
(define can-restore-mixin
|
||||||
|
(mixin (selectable-menu-item<%>) (can-restore<%>)
|
||||||
|
(inherit set-shortcut get-shortcut)
|
||||||
|
(define saved-shortcut 'not-yet)
|
||||||
|
(define/public (restore-keybinding)
|
||||||
|
(unless (eq? saved-shortcut 'not-yet)
|
||||||
|
(set-shortcut saved-shortcut)))
|
||||||
|
|
||||||
(define can-restore<%>
|
(super-new)
|
||||||
(interface (selectable-menu-item<%>)
|
(set! saved-shortcut (get-shortcut))
|
||||||
restore-keybinding))
|
(unless (preferences:get 'framework:menu-bindings)
|
||||||
|
(set-shortcut #f))))
|
||||||
(define can-restore-mixin
|
|
||||||
(mixin (selectable-menu-item<%>) (can-restore<%>)
|
(define can-restore-underscore<%>
|
||||||
(inherit set-shortcut get-shortcut)
|
(interface (labelled-menu-item<%>)
|
||||||
(define saved-shortcut 'not-yet)
|
erase-underscores
|
||||||
(define/public (restore-keybinding)
|
restore-underscores))
|
||||||
(unless (eq? saved-shortcut 'not-yet)
|
|
||||||
(set-shortcut saved-shortcut)))
|
(define can-restore-underscore-mixin
|
||||||
|
(mixin (labelled-menu-item<%>) (can-restore-underscore<%>)
|
||||||
(super-new)
|
(inherit get-label get-plain-label set-label)
|
||||||
(set! saved-shortcut (get-shortcut))
|
(define/public (erase-underscores)
|
||||||
(unless (preferences:get 'framework:menu-bindings)
|
(set-label (get-plain-label)))
|
||||||
(set-shortcut #f))))
|
(define/public (restore-underscores)
|
||||||
|
(unless (eq? saved-label 'not-yet-saved-label)
|
||||||
(define can-restore-underscore<%>
|
(set-label saved-label)))
|
||||||
(interface (labelled-menu-item<%>)
|
(define saved-label 'not-yet-saved-label)
|
||||||
erase-underscores
|
(super-new)
|
||||||
restore-underscores))
|
(set! saved-label (get-label))
|
||||||
|
(unless (preferences:get 'framework:menu-bindings)
|
||||||
(define can-restore-underscore-mixin
|
(erase-underscores))))
|
||||||
(mixin (labelled-menu-item<%>) (can-restore-underscore<%>)
|
|
||||||
(inherit get-label get-plain-label set-label)
|
(define can-restore-menu-item% (can-restore-mixin menu-item%))
|
||||||
(define/public (erase-underscores)
|
(define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%))
|
||||||
(set-label (get-plain-label)))
|
(define can-restore-underscore-menu% (can-restore-underscore-mixin menu%)))
|
||||||
(define/public (restore-underscores)
|
|
||||||
(unless (eq? saved-label 'not-yet-saved-label)
|
|
||||||
(set-label saved-label)))
|
|
||||||
(define saved-label 'not-yet-saved-label)
|
|
||||||
(super-new)
|
|
||||||
(set! saved-label (get-label))
|
|
||||||
(unless (preferences:get 'framework:menu-bindings)
|
|
||||||
(erase-underscores))))
|
|
||||||
|
|
||||||
(define can-restore-menu-item% (can-restore-mixin menu-item%))
|
|
||||||
(define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%))
|
|
||||||
(define can-restore-underscore-menu% (can-restore-underscore-mixin menu%)))
|
|
||||||
|
|
|
||||||
|
|
@ -1,50 +1,50 @@
|
||||||
(module mode (lib "a-unit.ss")
|
(module mode (lib "a-unit.ss")
|
||||||
(require (lib "surrogate.ss")
|
(require (lib "surrogate.ss")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
"sig.ss")
|
"sig.ss")
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export framework:mode^)
|
(export framework:mode^)
|
||||||
|
|
||||||
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
|
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
|
||||||
(surrogate
|
(surrogate
|
||||||
(augment (void) on-change ())
|
(augment (void) on-change ())
|
||||||
(override on-char (event))
|
(override on-char (event))
|
||||||
(override on-default-char (event))
|
(override on-default-char (event))
|
||||||
(override on-default-event (event))
|
(override on-default-event (event))
|
||||||
(augment (void) on-display-size ())
|
(augment (void) on-display-size ())
|
||||||
(augment (void) on-edit-sequence ())
|
(augment (void) on-edit-sequence ())
|
||||||
(override on-event (event))
|
(override on-event (event))
|
||||||
(override on-focus (on?))
|
(override on-focus (on?))
|
||||||
(augment (void) on-load-file (filename format))
|
(augment (void) on-load-file (filename format))
|
||||||
(override on-local-char (event))
|
(override on-local-char (event))
|
||||||
(override on-local-event (event))
|
(override on-local-event (event))
|
||||||
(override on-new-box (type))
|
(override on-new-box (type))
|
||||||
(override on-new-image-snip (filename kind relative-path? inline?))
|
(override on-new-image-snip (filename kind relative-path? inline?))
|
||||||
(override on-paint (before? dc left top right bottom dx dy draw-caret))
|
(override on-paint (before? dc left top right bottom dx dy draw-caret))
|
||||||
(augment (void) on-save-file (filename format))
|
(augment (void) on-save-file (filename format))
|
||||||
(augment (void) on-snip-modified (snip modified?))
|
(augment (void) on-snip-modified (snip modified?))
|
||||||
|
|
||||||
(augment (void) on-change-style (start len))
|
(augment (void) on-change-style (start len))
|
||||||
(augment (void) on-delete (start len))
|
(augment (void) on-delete (start len))
|
||||||
(augment (void) on-insert (start len))
|
(augment (void) on-insert (start len))
|
||||||
(override on-new-string-snip ())
|
(override on-new-string-snip ())
|
||||||
(override on-new-tab-snip ())
|
(override on-new-tab-snip ())
|
||||||
(augment (void) on-set-size-constraint ())
|
(augment (void) on-set-size-constraint ())
|
||||||
|
|
||||||
(augment (void) after-change-style (start len))
|
(augment (void) after-change-style (start len))
|
||||||
(augment (void) after-delete (start len))
|
(augment (void) after-delete (start len))
|
||||||
(augment (void) after-insert (start len))
|
(augment (void) after-insert (start len))
|
||||||
(augment (void) after-set-position ())
|
(augment (void) after-set-position ())
|
||||||
(augment (void) after-set-size-constraint ())
|
(augment (void) after-set-size-constraint ())
|
||||||
(augment (void) after-edit-sequence ())
|
(augment (void) after-edit-sequence ())
|
||||||
(augment (void) after-load-file (success?))
|
(augment (void) after-load-file (success?))
|
||||||
(augment (void) after-save-file (success?))
|
(augment (void) after-save-file (success?))
|
||||||
|
|
||||||
(augment #t can-change-style? (start len))
|
(augment #t can-change-style? (start len))
|
||||||
(augment #t can-delete? (start len))
|
(augment #t can-delete? (start len))
|
||||||
(augment #t can-insert? (start len))
|
(augment #t can-insert? (start len))
|
||||||
(augment #t can-set-size-constraint? ())
|
(augment #t can-set-size-constraint? ())
|
||||||
(override can-do-edit-operation? (op) (op recursive?))
|
(override can-do-edit-operation? (op) (op recursive?))
|
||||||
(augment #t can-load-file? (filename format))
|
(augment #t can-load-file? (filename format))
|
||||||
(augment #t can-save-file? (filename format)))))
|
(augment #t can-save-file? (filename format)))))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,423 +1,423 @@
|
||||||
|
|
||||||
(module panel (lib "a-unit.ss")
|
(module panel (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "etc.ss"))
|
(lib "etc.ss"))
|
||||||
|
|
||||||
(import [prefix icon: framework:icon^]
|
(import [prefix icon: framework:icon^]
|
||||||
mred^)
|
mred^)
|
||||||
(export framework:panel^)
|
(export framework:panel^)
|
||||||
(init-depend mred^)
|
(init-depend mred^)
|
||||||
|
|
||||||
(define single<%> (interface (area-container<%>) active-child))
|
(define single<%> (interface (area-container<%>) active-child))
|
||||||
(define single-mixin
|
(define single-mixin
|
||||||
(mixin (area-container<%>) (single<%>)
|
(mixin (area-container<%>) (single<%>)
|
||||||
(inherit get-alignment change-children)
|
(inherit get-alignment change-children)
|
||||||
(define/override (after-new-child c)
|
(define/override (after-new-child c)
|
||||||
(unless (is-a? c window<%>)
|
(unless (is-a? c window<%>)
|
||||||
|
|
||||||
;; would like to remove the child here, waiting on a PR submitted
|
|
||||||
;; about change-children during after-new-child
|
|
||||||
(change-children
|
|
||||||
(λ (l)
|
|
||||||
(remq c l)))
|
|
||||||
|
|
||||||
(error 'single-mixin::after-new-child
|
|
||||||
"all children must implement window<%>, got ~e"
|
|
||||||
c))
|
|
||||||
(if current-active-child
|
|
||||||
(send c show #f)
|
|
||||||
(set! current-active-child c)))
|
|
||||||
[define/override (container-size l)
|
|
||||||
(if (null? l)
|
|
||||||
(values 0 0)
|
|
||||||
(values (apply max (map car l)) (apply max (map cadr l))))]
|
|
||||||
[define/override (place-children l width height)
|
|
||||||
(let-values ([(h-align-spec v-align-spec) (get-alignment)])
|
|
||||||
(let ([align
|
|
||||||
(λ (total-size spec item-size)
|
|
||||||
(floor
|
|
||||||
(case spec
|
|
||||||
[(center) (- (/ total-size 2) (/ item-size 2))]
|
|
||||||
[(left top) 0]
|
|
||||||
[(right bottom) (- total-size item-size)]
|
|
||||||
[else (error 'place-children
|
|
||||||
"alignment spec is unknown ~a~n" spec)])))])
|
|
||||||
(map (λ (l)
|
|
||||||
(let*-values ([(min-width min-height v-stretch? h-stretch?)
|
|
||||||
(apply values l)]
|
|
||||||
[(x this-width)
|
|
||||||
(if h-stretch?
|
|
||||||
(values 0 width)
|
|
||||||
(values (align width h-align-spec min-width)
|
|
||||||
min-width))]
|
|
||||||
[(y this-height)
|
|
||||||
(if v-stretch?
|
|
||||||
(values 0 height)
|
|
||||||
(values (align height v-align-spec min-height)
|
|
||||||
min-height))])
|
|
||||||
(list x y this-width this-height)))
|
|
||||||
l)))]
|
|
||||||
|
|
||||||
(inherit get-children begin-container-sequence end-container-sequence)
|
;; would like to remove the child here, waiting on a PR submitted
|
||||||
[define current-active-child #f]
|
;; about change-children during after-new-child
|
||||||
(define/public active-child
|
(change-children
|
||||||
(case-lambda
|
(λ (l)
|
||||||
[() current-active-child]
|
(remq c l)))
|
||||||
[(x)
|
|
||||||
(unless (memq x (get-children))
|
|
||||||
(error 'active-child "got a panel that is not a child: ~e" x))
|
|
||||||
(unless (eq? x current-active-child)
|
|
||||||
(begin-container-sequence)
|
|
||||||
(for-each (λ (x) (send x show #f))
|
|
||||||
(get-children))
|
|
||||||
(set! current-active-child x)
|
|
||||||
(send current-active-child show #t)
|
|
||||||
(end-container-sequence))]))
|
|
||||||
(super-instantiate ())))
|
|
||||||
|
|
||||||
(define single-window<%> (interface (single<%> window<%>)))
|
|
||||||
(define single-window-mixin
|
|
||||||
(mixin (single<%> window<%>) (single-window<%>)
|
|
||||||
(inherit get-client-size get-size)
|
|
||||||
[define/override container-size
|
|
||||||
(λ (l)
|
|
||||||
(let-values ([(super-width super-height) (super container-size l)]
|
|
||||||
[(client-width client-height) (get-client-size)]
|
|
||||||
[(window-width window-height) (get-size)]
|
|
||||||
[(calc-size)
|
|
||||||
(λ (super client window)
|
|
||||||
(+ super (max 0 (- window client))))])
|
|
||||||
|
|
||||||
(values
|
|
||||||
(calc-size super-width client-width window-width)
|
|
||||||
(calc-size super-height client-height window-height))))]
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
(define multi-view<%>
|
|
||||||
(interface (area-container<%>)
|
|
||||||
split-vertically
|
|
||||||
split-horizontally
|
|
||||||
collapse))
|
|
||||||
|
|
||||||
(define multi-view-mixin
|
|
||||||
(mixin (area-container<%>) (multi-view<%>)
|
|
||||||
(init-field parent editor)
|
|
||||||
(public get-editor-canvas% get-vertical% get-horizontal%)
|
|
||||||
[define get-editor-canvas%
|
|
||||||
(λ ()
|
|
||||||
editor-canvas%)]
|
|
||||||
[define get-vertical%
|
|
||||||
(λ ()
|
|
||||||
vertical-panel%)]
|
|
||||||
[define get-horizontal%
|
|
||||||
(λ ()
|
|
||||||
horizontal-panel%)]
|
|
||||||
|
|
||||||
(define/private (split p%)
|
(error 'single-mixin::after-new-child
|
||||||
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
|
"all children must implement window<%>, got ~e"
|
||||||
[ec% (get-editor-canvas%)])
|
c))
|
||||||
(when (and canvas
|
(if current-active-child
|
||||||
(is-a? canvas ec%)
|
(send c show #f)
|
||||||
(eq? (send canvas get-editor) editor))
|
(set! current-active-child c)))
|
||||||
(let ([p (send canvas get-parent)])
|
[define/override (container-size l)
|
||||||
(send p change-children (λ (x) null))
|
(if (null? l)
|
||||||
(let ([pc (make-object p% p)])
|
(values 0 0)
|
||||||
(send (make-object ec% (make-object vertical-panel% pc) editor) focus)
|
(values (apply max (map car l)) (apply max (map cadr l))))]
|
||||||
(make-object ec% (make-object vertical-panel% pc) editor))))))
|
[define/override (place-children l width height)
|
||||||
[define/public split-vertically
|
(let-values ([(h-align-spec v-align-spec) (get-alignment)])
|
||||||
(λ ()
|
(let ([align
|
||||||
(split (get-vertical%)))]
|
(λ (total-size spec item-size)
|
||||||
[define/public split-horizontally
|
(floor
|
||||||
(λ ()
|
(case spec
|
||||||
(split (get-horizontal%)))]
|
[(center) (- (/ total-size 2) (/ item-size 2))]
|
||||||
|
[(left top) 0]
|
||||||
(define/public (collapse)
|
[(right bottom) (- total-size item-size)]
|
||||||
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
|
[else (error 'place-children
|
||||||
[ec% (get-editor-canvas%)])
|
"alignment spec is unknown ~a~n" spec)])))])
|
||||||
(when (and canvas
|
(map (λ (l)
|
||||||
(is-a? canvas ec%)
|
(let*-values ([(min-width min-height v-stretch? h-stretch?)
|
||||||
(eq? (send canvas get-editor) editor))
|
(apply values l)]
|
||||||
(let ([p (send canvas get-parent)])
|
[(x this-width)
|
||||||
(if (eq? p this)
|
(if h-stretch?
|
||||||
(bell)
|
(values 0 width)
|
||||||
(let* ([sp (send p get-parent)]
|
(values (align width h-align-spec min-width)
|
||||||
[p-to-remain (send sp get-parent)])
|
min-width))]
|
||||||
(send p-to-remain change-children (λ (x) null))
|
[(y this-height)
|
||||||
(send (make-object ec% p-to-remain editor) focus)))))))
|
(if v-stretch?
|
||||||
|
(values 0 height)
|
||||||
|
(values (align height v-align-spec min-height)
|
||||||
(super-instantiate () (parent parent))
|
min-height))])
|
||||||
(make-object (get-editor-canvas%) this editor)))
|
(list x y this-width this-height)))
|
||||||
|
l)))]
|
||||||
|
|
||||||
(define single% (single-window-mixin (single-mixin panel%)))
|
(inherit get-children begin-container-sequence end-container-sequence)
|
||||||
(define single-pane% (single-mixin pane%))
|
[define current-active-child #f]
|
||||||
(define multi-view% (multi-view-mixin vertical-panel%))
|
(define/public active-child
|
||||||
|
(case-lambda
|
||||||
|
[() current-active-child]
|
||||||
|
[(x)
|
||||||
|
(unless (memq x (get-children))
|
||||||
|
(error 'active-child "got a panel that is not a child: ~e" x))
|
||||||
|
(unless (eq? x current-active-child)
|
||||||
|
(begin-container-sequence)
|
||||||
|
(for-each (λ (x) (send x show #f))
|
||||||
|
(get-children))
|
||||||
|
(set! current-active-child x)
|
||||||
|
(send current-active-child show #t)
|
||||||
|
(end-container-sequence))]))
|
||||||
|
(super-instantiate ())))
|
||||||
|
|
||||||
|
(define single-window<%> (interface (single<%> window<%>)))
|
||||||
|
(define single-window-mixin
|
||||||
|
(mixin (single<%> window<%>) (single-window<%>)
|
||||||
|
(inherit get-client-size get-size)
|
||||||
|
[define/override container-size
|
||||||
|
(λ (l)
|
||||||
|
(let-values ([(super-width super-height) (super container-size l)]
|
||||||
|
[(client-width client-height) (get-client-size)]
|
||||||
|
[(window-width window-height) (get-size)]
|
||||||
|
[(calc-size)
|
||||||
|
(λ (super client window)
|
||||||
|
(+ super (max 0 (- window client))))])
|
||||||
|
|
||||||
|
(values
|
||||||
|
(calc-size super-width client-width window-width)
|
||||||
|
(calc-size super-height client-height window-height))))]
|
||||||
|
(super-new)))
|
||||||
|
|
||||||
|
(define multi-view<%>
|
||||||
|
(interface (area-container<%>)
|
||||||
|
split-vertically
|
||||||
|
split-horizontally
|
||||||
|
collapse))
|
||||||
|
|
||||||
|
(define multi-view-mixin
|
||||||
|
(mixin (area-container<%>) (multi-view<%>)
|
||||||
|
(init-field parent editor)
|
||||||
|
(public get-editor-canvas% get-vertical% get-horizontal%)
|
||||||
|
[define get-editor-canvas%
|
||||||
|
(λ ()
|
||||||
|
editor-canvas%)]
|
||||||
|
[define get-vertical%
|
||||||
|
(λ ()
|
||||||
|
vertical-panel%)]
|
||||||
|
[define get-horizontal%
|
||||||
|
(λ ()
|
||||||
|
horizontal-panel%)]
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(define/private (split p%)
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
[ec% (get-editor-canvas%)])
|
||||||
|
(when (and canvas
|
||||||
|
(is-a? canvas ec%)
|
||||||
|
(eq? (send canvas get-editor) editor))
|
||||||
|
(let ([p (send canvas get-parent)])
|
||||||
|
(send p change-children (λ (x) null))
|
||||||
|
(let ([pc (make-object p% p)])
|
||||||
|
(send (make-object ec% (make-object vertical-panel% pc) editor) focus)
|
||||||
|
(make-object ec% (make-object vertical-panel% pc) editor))))))
|
||||||
|
[define/public split-vertically
|
||||||
|
(λ ()
|
||||||
|
(split (get-vertical%)))]
|
||||||
|
[define/public split-horizontally
|
||||||
|
(λ ()
|
||||||
|
(split (get-horizontal%)))]
|
||||||
|
|
||||||
;; type gap = (make-gap number area<%> percentage number area<%> percentage)
|
(define/public (collapse)
|
||||||
(define-struct gap (before before-dim before-percentage after after-dim after-percentage))
|
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
|
||||||
|
[ec% (get-editor-canvas%)])
|
||||||
;; type percentage : (make-percentage number)
|
(when (and canvas
|
||||||
(define-struct percentage (%))
|
(is-a? canvas ec%)
|
||||||
|
(eq? (send canvas get-editor) editor))
|
||||||
|
(let ([p (send canvas get-parent)])
|
||||||
|
(if (eq? p this)
|
||||||
|
(bell)
|
||||||
|
(let* ([sp (send p get-parent)]
|
||||||
|
[p-to-remain (send sp get-parent)])
|
||||||
|
(send p-to-remain change-children (λ (x) null))
|
||||||
|
(send (make-object ec% p-to-remain editor) focus)))))))
|
||||||
|
|
||||||
(define dragable<%>
|
|
||||||
(interface (window<%> area-container<%>)
|
|
||||||
after-percentage-change
|
|
||||||
set-percentages
|
|
||||||
get-percentages
|
|
||||||
get-vertical?))
|
|
||||||
|
|
||||||
(define vertical-dragable<%>
|
(super-instantiate () (parent parent))
|
||||||
(interface (dragable<%>)))
|
(make-object (get-editor-canvas%) this editor)))
|
||||||
|
|
||||||
|
(define single% (single-window-mixin (single-mixin panel%)))
|
||||||
|
(define single-pane% (single-mixin pane%))
|
||||||
|
(define multi-view% (multi-view-mixin vertical-panel%))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;; type gap = (make-gap number area<%> percentage number area<%> percentage)
|
||||||
|
(define-struct gap (before before-dim before-percentage after after-dim after-percentage))
|
||||||
|
|
||||||
|
;; type percentage : (make-percentage number)
|
||||||
|
(define-struct percentage (%))
|
||||||
|
|
||||||
|
(define dragable<%>
|
||||||
|
(interface (window<%> area-container<%>)
|
||||||
|
after-percentage-change
|
||||||
|
set-percentages
|
||||||
|
get-percentages
|
||||||
|
get-vertical?))
|
||||||
|
|
||||||
|
(define vertical-dragable<%>
|
||||||
|
(interface (dragable<%>)))
|
||||||
|
|
||||||
|
(define horizontal-dragable<%>
|
||||||
|
(interface (dragable<%>)))
|
||||||
|
|
||||||
|
(define dragable-mixin
|
||||||
|
(mixin (window<%> area-container<%>) (dragable<%>)
|
||||||
|
(init parent)
|
||||||
|
|
||||||
(define horizontal-dragable<%>
|
(define/public (get-vertical?)
|
||||||
(interface (dragable<%>)))
|
(error 'get-vertical "abstract method"))
|
||||||
|
(define/private (min-extent child)
|
||||||
(define dragable-mixin
|
(let-values ([(w h) (send child get-graphical-min-size)])
|
||||||
(mixin (window<%> area-container<%>) (dragable<%>)
|
(if (get-vertical?)
|
||||||
(init parent)
|
(max (send child min-height) h)
|
||||||
|
(max (send child min-width) w))))
|
||||||
(define/public (get-vertical?)
|
(define/private (event-get-dim evt)
|
||||||
(error 'get-vertical "abstract method"))
|
(if (get-vertical?)
|
||||||
(define/private (min-extent child)
|
(send evt get-y)
|
||||||
(let-values ([(w h) (send child get-graphical-min-size)])
|
(send evt get-x)))
|
||||||
(if (get-vertical?)
|
(define/private (get-gap-cursor)
|
||||||
(max (send child min-height) h)
|
(if (get-vertical?)
|
||||||
(max (send child min-width) w))))
|
(icon:get-up/down-cursor)
|
||||||
(define/private (event-get-dim evt)
|
(icon:get-left/right-cursor)))
|
||||||
(if (get-vertical?)
|
|
||||||
(send evt get-y)
|
(inherit get-client-size container-flow-modified)
|
||||||
(send evt get-x)))
|
|
||||||
(define/private (get-gap-cursor)
|
(init-field [bar-thickness 5])
|
||||||
(if (get-vertical?)
|
|
||||||
(icon:get-up/down-cursor)
|
;; percentages : (listof percentage)
|
||||||
(icon:get-left/right-cursor)))
|
(define percentages null)
|
||||||
|
|
||||||
(inherit get-client-size container-flow-modified)
|
;; get-percentages : -> (listof number)
|
||||||
|
(define/public (get-percentages)
|
||||||
(init-field [bar-thickness 5])
|
(map percentage-% percentages))
|
||||||
|
|
||||||
;; percentages : (listof percentage)
|
(define/public (set-percentages ps)
|
||||||
(define percentages null)
|
(unless (and (list? ps)
|
||||||
|
(andmap number? ps)
|
||||||
;; get-percentages : -> (listof number)
|
(= 1 (apply + ps))
|
||||||
(define/public (get-percentages)
|
(andmap positive? ps))
|
||||||
(map percentage-% percentages))
|
(error 'set-percentages
|
||||||
|
"expected a list of numbers that are all positive and sum to 1, got: ~e"
|
||||||
(define/public (set-percentages ps)
|
ps))
|
||||||
(unless (and (list? ps)
|
(unless (= (length ps) (length (get-children)))
|
||||||
(andmap number? ps)
|
(error 'set-percentages
|
||||||
(= 1 (apply + ps))
|
"expected a list of numbers whose length is the number of children: ~a, got ~e"
|
||||||
(andmap positive? ps))
|
(length (get-children))
|
||||||
(error 'set-percentages
|
ps))
|
||||||
"expected a list of numbers that are all positive and sum to 1, got: ~e"
|
(set! percentages (map make-percentage ps))
|
||||||
ps))
|
(container-flow-modified))
|
||||||
(unless (= (length ps) (length (get-children)))
|
|
||||||
(error 'set-percentages
|
(define/pubment (after-percentage-change) (inner (void) after-percentage-change))
|
||||||
"expected a list of numbers whose length is the number of children: ~a, got ~e"
|
|
||||||
(length (get-children))
|
(define/private (get-available-extent)
|
||||||
ps))
|
(let-values ([(width height) (get-client-size)])
|
||||||
(set! percentages (map make-percentage ps))
|
(- (if (get-vertical?) height width)
|
||||||
(container-flow-modified))
|
(* bar-thickness (- (length (get-children)) 1)))))
|
||||||
|
|
||||||
(define/pubment (after-percentage-change) (inner (void) after-percentage-change))
|
(inherit get-children)
|
||||||
|
|
||||||
(define/private (get-available-extent)
|
(define/private (update-percentages)
|
||||||
(let-values ([(width height) (get-client-size)])
|
(let ([len-children (length (get-children))])
|
||||||
(- (if (get-vertical?) height width)
|
(unless (= len-children (length percentages))
|
||||||
(* bar-thickness (- (length (get-children)) 1)))))
|
(let ([rat (/ 1 len-children)])
|
||||||
|
(set! percentages (build-list len-children (λ (i) (make-percentage rat)))))
|
||||||
(inherit get-children)
|
(after-percentage-change))))
|
||||||
|
|
||||||
(define/private (update-percentages)
|
(define/override (after-new-child child)
|
||||||
(let ([len-children (length (get-children))])
|
(update-percentages))
|
||||||
(unless (= len-children (length percentages))
|
|
||||||
(let ([rat (/ 1 len-children)])
|
(define resizing-dim #f)
|
||||||
(set! percentages (build-list len-children (λ (i) (make-percentage rat)))))
|
(define resizing-gap #f)
|
||||||
(after-percentage-change))))
|
|
||||||
|
(inherit set-cursor)
|
||||||
(define/override (after-new-child child)
|
(define/override (on-subwindow-event receiver evt)
|
||||||
(update-percentages))
|
(if (eq? receiver this)
|
||||||
|
(let ([gap
|
||||||
(define resizing-dim #f)
|
(ormap (λ (gap)
|
||||||
(define resizing-gap #f)
|
(and (<= (gap-before-dim gap)
|
||||||
|
(event-get-dim evt)
|
||||||
(inherit set-cursor)
|
(gap-after-dim gap))
|
||||||
(define/override (on-subwindow-event receiver evt)
|
gap))
|
||||||
(if (eq? receiver this)
|
cursor-gaps)])
|
||||||
(let ([gap
|
(set-cursor (and (or gap
|
||||||
(ormap (λ (gap)
|
resizing-dim)
|
||||||
(and (<= (gap-before-dim gap)
|
(let ([c (get-gap-cursor)])
|
||||||
(event-get-dim evt)
|
(and (send c ok?)
|
||||||
(gap-after-dim gap))
|
c))))
|
||||||
gap))
|
|
||||||
cursor-gaps)])
|
|
||||||
(set-cursor (and (or gap
|
|
||||||
resizing-dim)
|
|
||||||
(let ([c (get-gap-cursor)])
|
|
||||||
(and (send c ok?)
|
|
||||||
c))))
|
|
||||||
(cond
|
|
||||||
[(and gap (send evt button-down? 'left))
|
|
||||||
(set! resizing-dim (event-get-dim evt))
|
|
||||||
(set! resizing-gap gap)]
|
|
||||||
[(and resizing-dim (send evt button-up?))
|
|
||||||
(set! resizing-dim #f)
|
|
||||||
(set! resizing-gap #f)]
|
|
||||||
[(and resizing-dim (send evt moving?))
|
|
||||||
(let-values ([(width height) (get-client-size)])
|
|
||||||
(let* ([before-percentage (gap-before-percentage resizing-gap)]
|
|
||||||
[orig-before (percentage-% before-percentage)]
|
|
||||||
[after-percentage (gap-after-percentage resizing-gap)]
|
|
||||||
[orig-after (percentage-% after-percentage)]
|
|
||||||
[available-extent (get-available-extent)]
|
|
||||||
[change-in-percentage (/ (- resizing-dim (event-get-dim evt)) available-extent)]
|
|
||||||
[new-before (- (percentage-% before-percentage) change-in-percentage)]
|
|
||||||
[new-after (+ (percentage-% after-percentage) change-in-percentage)])
|
|
||||||
(when ((floor (* new-before available-extent)) . > . (min-extent (gap-before resizing-gap)))
|
|
||||||
(when ((floor (* new-after available-extent)) . > . (min-extent (gap-after resizing-gap)))
|
|
||||||
(set-percentage-%! before-percentage new-before)
|
|
||||||
(set-percentage-%! after-percentage new-after)
|
|
||||||
(after-percentage-change)
|
|
||||||
(set! resizing-dim (event-get-dim evt))
|
|
||||||
(container-flow-modified)))))]
|
|
||||||
[else (super on-subwindow-event receiver evt)]))
|
|
||||||
(begin
|
|
||||||
(set-cursor #f)
|
|
||||||
(super on-subwindow-event receiver evt))))
|
|
||||||
|
|
||||||
(define cursor-gaps null)
|
|
||||||
|
|
||||||
(define/override (place-children _infos width height)
|
|
||||||
(set! cursor-gaps null)
|
|
||||||
(update-percentages)
|
|
||||||
(cond
|
|
||||||
[(null? _infos) null]
|
|
||||||
[(null? (cdr _infos)) (list (list 0 0 width height))]
|
|
||||||
[else
|
|
||||||
(let ([available-extent (get-available-extent)]
|
|
||||||
[show-error
|
|
||||||
(λ (n)
|
|
||||||
(error 'panel.ss::dragable-panel "internal error.~a" n))])
|
|
||||||
(let loop ([percentages percentages]
|
|
||||||
[children (get-children)]
|
|
||||||
[infos _infos]
|
|
||||||
[dim 0])
|
|
||||||
(cond
|
|
||||||
[(null? percentages)
|
|
||||||
(unless (null? infos) (show-error 1))
|
|
||||||
(unless (null? children) (show-error 2))
|
|
||||||
null]
|
|
||||||
[(null? (cdr percentages))
|
|
||||||
(when (null? infos) (show-error 3))
|
|
||||||
(when (null? children) (show-error 4))
|
|
||||||
(unless (null? (cdr infos)) (show-error 5))
|
|
||||||
(unless (null? (cdr children)) (show-error 6))
|
|
||||||
(if (get-vertical?)
|
|
||||||
(list (list 0 dim width (- height dim)))
|
|
||||||
(list (list dim 0 (- width dim) height)))]
|
|
||||||
[else
|
|
||||||
(when (null? infos) (show-error 7))
|
|
||||||
(when (null? children) (show-error 8))
|
|
||||||
(when (null? (cdr infos)) (show-error 9))
|
|
||||||
(when (null? (cdr children)) (show-error 10))
|
|
||||||
(let* ([info (car infos)]
|
|
||||||
[percentage (car percentages)]
|
|
||||||
[this-space (floor (* (percentage-% percentage) available-extent))])
|
|
||||||
(set! cursor-gaps (cons (make-gap (car children)
|
|
||||||
(+ dim this-space)
|
|
||||||
percentage
|
|
||||||
(cadr children)
|
|
||||||
(+ dim this-space bar-thickness)
|
|
||||||
(cadr percentages))
|
|
||||||
cursor-gaps))
|
|
||||||
(cons (if (get-vertical?)
|
|
||||||
(list 0 dim width this-space)
|
|
||||||
(list dim 0 this-space height))
|
|
||||||
(loop (cdr percentages)
|
|
||||||
(cdr children)
|
|
||||||
(cdr infos)
|
|
||||||
(+ dim this-space bar-thickness))))])))]))
|
|
||||||
|
|
||||||
(define/override (container-size children-info)
|
|
||||||
(update-percentages)
|
|
||||||
(let loop ([percentages percentages]
|
|
||||||
[children-info children-info]
|
|
||||||
[major-size 0]
|
|
||||||
[minor-size 0])
|
|
||||||
(cond
|
(cond
|
||||||
[(null? children-info)
|
[(and gap (send evt button-down? 'left))
|
||||||
(if (get-vertical?)
|
(set! resizing-dim (event-get-dim evt))
|
||||||
(values (ceiling minor-size) (ceiling major-size))
|
(set! resizing-gap gap)]
|
||||||
(values (ceiling major-size) (ceiling minor-size)))]
|
[(and resizing-dim (send evt button-up?))
|
||||||
[(null? percentages)
|
(set! resizing-dim #f)
|
||||||
(error 'panel.ss::dragable-panel "internal error.12")]
|
(set! resizing-gap #f)]
|
||||||
[else
|
[(and resizing-dim (send evt moving?))
|
||||||
(let ([child-info (car children-info)]
|
(let-values ([(width height) (get-client-size)])
|
||||||
[percentage (car percentages)])
|
(let* ([before-percentage (gap-before-percentage resizing-gap)]
|
||||||
(let-values ([(child-major major-stretch? child-minor minor-stretch?)
|
[orig-before (percentage-% before-percentage)]
|
||||||
(if (get-vertical?)
|
[after-percentage (gap-after-percentage resizing-gap)]
|
||||||
(values (list-ref child-info 1)
|
[orig-after (percentage-% after-percentage)]
|
||||||
(list-ref child-info 3)
|
[available-extent (get-available-extent)]
|
||||||
(list-ref child-info 0)
|
[change-in-percentage (/ (- resizing-dim (event-get-dim evt)) available-extent)]
|
||||||
(list-ref child-info 2))
|
[new-before (- (percentage-% before-percentage) change-in-percentage)]
|
||||||
(values (list-ref child-info 0)
|
[new-after (+ (percentage-% after-percentage) change-in-percentage)])
|
||||||
(list-ref child-info 2)
|
(when ((floor (* new-before available-extent)) . > . (min-extent (gap-before resizing-gap)))
|
||||||
(list-ref child-info 1)
|
(when ((floor (* new-after available-extent)) . > . (min-extent (gap-after resizing-gap)))
|
||||||
(list-ref child-info 3)))])
|
(set-percentage-%! before-percentage new-before)
|
||||||
(loop (cdr percentages)
|
(set-percentage-%! after-percentage new-after)
|
||||||
(cdr children-info)
|
(after-percentage-change)
|
||||||
(max (/ child-major (percentage-% percentage)) major-size)
|
(set! resizing-dim (event-get-dim evt))
|
||||||
(max child-minor minor-size))))])))
|
(container-flow-modified)))))]
|
||||||
|
[else (super on-subwindow-event receiver evt)]))
|
||||||
(super-instantiate (parent))))
|
(begin
|
||||||
|
(set-cursor #f)
|
||||||
|
(super on-subwindow-event receiver evt))))
|
||||||
|
|
||||||
(define three-bar-pen-bar-width 8)
|
(define cursor-gaps null)
|
||||||
|
|
||||||
(define three-bar-canvas%
|
(define/override (place-children _infos width height)
|
||||||
(class canvas%
|
(set! cursor-gaps null)
|
||||||
(inherit get-dc get-client-size)
|
(update-percentages)
|
||||||
(define/override (on-paint)
|
(cond
|
||||||
(let ([dc (get-dc)])
|
[(null? _infos) null]
|
||||||
(let-values ([(w h) (get-client-size)])
|
[(null? (cdr _infos)) (list (list 0 0 width height))]
|
||||||
(let ([sx (floor (- (/ w 2) (/ three-bar-pen-bar-width 2)))])
|
[else
|
||||||
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
|
(let ([available-extent (get-available-extent)]
|
||||||
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
|
[show-error
|
||||||
(send dc draw-rectangle 0 0 w h)
|
(λ (n)
|
||||||
|
(error 'panel.ss::dragable-panel "internal error.~a" n))])
|
||||||
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
(let loop ([percentages percentages]
|
||||||
(send dc draw-line sx 1 (+ sx three-bar-pen-bar-width) 1)
|
[children (get-children)]
|
||||||
(send dc draw-line sx 4 (+ sx three-bar-pen-bar-width) 4)
|
[infos _infos]
|
||||||
(send dc draw-line sx 7 (+ sx three-bar-pen-bar-width) 7)
|
[dim 0])
|
||||||
|
(cond
|
||||||
(send dc set-pen (send the-pen-list find-or-create-pen "gray" 1 'solid))
|
[(null? percentages)
|
||||||
(send dc draw-line sx 2 (+ sx three-bar-pen-bar-width) 2)
|
(unless (null? infos) (show-error 1))
|
||||||
(send dc draw-line sx 5 (+ sx three-bar-pen-bar-width) 5)
|
(unless (null? children) (show-error 2))
|
||||||
(send dc draw-line sx 8 (+ sx three-bar-pen-bar-width) 8)))))
|
null]
|
||||||
|
[(null? (cdr percentages))
|
||||||
(super-instantiate ())
|
(when (null? infos) (show-error 3))
|
||||||
(inherit stretchable-height min-height)
|
(when (null? children) (show-error 4))
|
||||||
(stretchable-height #f)
|
(unless (null? (cdr infos)) (show-error 5))
|
||||||
(min-height 10)))
|
(unless (null? (cdr children)) (show-error 6))
|
||||||
|
(if (get-vertical?)
|
||||||
|
(list (list 0 dim width (- height dim)))
|
||||||
|
(list (list dim 0 (- width dim) height)))]
|
||||||
|
[else
|
||||||
|
(when (null? infos) (show-error 7))
|
||||||
|
(when (null? children) (show-error 8))
|
||||||
|
(when (null? (cdr infos)) (show-error 9))
|
||||||
|
(when (null? (cdr children)) (show-error 10))
|
||||||
|
(let* ([info (car infos)]
|
||||||
|
[percentage (car percentages)]
|
||||||
|
[this-space (floor (* (percentage-% percentage) available-extent))])
|
||||||
|
(set! cursor-gaps (cons (make-gap (car children)
|
||||||
|
(+ dim this-space)
|
||||||
|
percentage
|
||||||
|
(cadr children)
|
||||||
|
(+ dim this-space bar-thickness)
|
||||||
|
(cadr percentages))
|
||||||
|
cursor-gaps))
|
||||||
|
(cons (if (get-vertical?)
|
||||||
|
(list 0 dim width this-space)
|
||||||
|
(list dim 0 this-space height))
|
||||||
|
(loop (cdr percentages)
|
||||||
|
(cdr children)
|
||||||
|
(cdr infos)
|
||||||
|
(+ dim this-space bar-thickness))))])))]))
|
||||||
|
|
||||||
|
(define/override (container-size children-info)
|
||||||
(define vertical-dragable-mixin
|
(update-percentages)
|
||||||
(mixin (dragable<%>) (vertical-dragable<%>)
|
(let loop ([percentages percentages]
|
||||||
(define/override (get-vertical?) #t)
|
[children-info children-info]
|
||||||
(super-instantiate ())))
|
[major-size 0]
|
||||||
|
[minor-size 0])
|
||||||
|
(cond
|
||||||
|
[(null? children-info)
|
||||||
|
(if (get-vertical?)
|
||||||
|
(values (ceiling minor-size) (ceiling major-size))
|
||||||
|
(values (ceiling major-size) (ceiling minor-size)))]
|
||||||
|
[(null? percentages)
|
||||||
|
(error 'panel.ss::dragable-panel "internal error.12")]
|
||||||
|
[else
|
||||||
|
(let ([child-info (car children-info)]
|
||||||
|
[percentage (car percentages)])
|
||||||
|
(let-values ([(child-major major-stretch? child-minor minor-stretch?)
|
||||||
|
(if (get-vertical?)
|
||||||
|
(values (list-ref child-info 1)
|
||||||
|
(list-ref child-info 3)
|
||||||
|
(list-ref child-info 0)
|
||||||
|
(list-ref child-info 2))
|
||||||
|
(values (list-ref child-info 0)
|
||||||
|
(list-ref child-info 2)
|
||||||
|
(list-ref child-info 1)
|
||||||
|
(list-ref child-info 3)))])
|
||||||
|
(loop (cdr percentages)
|
||||||
|
(cdr children-info)
|
||||||
|
(max (/ child-major (percentage-% percentage)) major-size)
|
||||||
|
(max child-minor minor-size))))])))
|
||||||
|
|
||||||
(define horizontal-dragable-mixin
|
(super-instantiate (parent))))
|
||||||
(mixin (dragable<%>) (vertical-dragable<%>)
|
|
||||||
(define/override (get-vertical?) #f)
|
(define three-bar-pen-bar-width 8)
|
||||||
(super-instantiate ())))
|
|
||||||
|
(define three-bar-canvas%
|
||||||
(define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%)))
|
(class canvas%
|
||||||
|
(inherit get-dc get-client-size)
|
||||||
(define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%))))
|
(define/override (on-paint)
|
||||||
|
(let ([dc (get-dc)])
|
||||||
|
(let-values ([(w h) (get-client-size)])
|
||||||
|
(let ([sx (floor (- (/ w 2) (/ three-bar-pen-bar-width 2)))])
|
||||||
|
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
|
||||||
|
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
|
||||||
|
(send dc draw-rectangle 0 0 w h)
|
||||||
|
|
||||||
|
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||||
|
(send dc draw-line sx 1 (+ sx three-bar-pen-bar-width) 1)
|
||||||
|
(send dc draw-line sx 4 (+ sx three-bar-pen-bar-width) 4)
|
||||||
|
(send dc draw-line sx 7 (+ sx three-bar-pen-bar-width) 7)
|
||||||
|
|
||||||
|
(send dc set-pen (send the-pen-list find-or-create-pen "gray" 1 'solid))
|
||||||
|
(send dc draw-line sx 2 (+ sx three-bar-pen-bar-width) 2)
|
||||||
|
(send dc draw-line sx 5 (+ sx three-bar-pen-bar-width) 5)
|
||||||
|
(send dc draw-line sx 8 (+ sx three-bar-pen-bar-width) 8)))))
|
||||||
|
|
||||||
|
(super-instantiate ())
|
||||||
|
(inherit stretchable-height min-height)
|
||||||
|
(stretchable-height #f)
|
||||||
|
(min-height 10)))
|
||||||
|
|
||||||
|
|
||||||
|
(define vertical-dragable-mixin
|
||||||
|
(mixin (dragable<%>) (vertical-dragable<%>)
|
||||||
|
(define/override (get-vertical?) #t)
|
||||||
|
(super-instantiate ())))
|
||||||
|
|
||||||
|
(define horizontal-dragable-mixin
|
||||||
|
(mixin (dragable<%>) (vertical-dragable<%>)
|
||||||
|
(define/override (get-vertical?) #f)
|
||||||
|
(super-instantiate ())))
|
||||||
|
|
||||||
|
(define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%)))
|
||||||
|
|
||||||
|
(define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,17 +1,17 @@
|
||||||
(module pasteboard (lib "a-unit.ss")
|
(module pasteboard (lib "a-unit.ss")
|
||||||
(require "sig.ss"
|
(require "sig.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix editor: framework:editor^])
|
[prefix editor: framework:editor^])
|
||||||
(export (rename framework:pasteboard^
|
(export (rename framework:pasteboard^
|
||||||
[-keymap% keymap%]))
|
[-keymap% keymap%]))
|
||||||
(init-depend mred^ framework:editor^)
|
(init-depend mred^ framework:editor^)
|
||||||
|
|
||||||
|
|
||||||
(define basic% (editor:basic-mixin pasteboard%))
|
(define basic% (editor:basic-mixin pasteboard%))
|
||||||
(define standard-style-list% (editor:standard-style-list-mixin basic%))
|
(define standard-style-list% (editor:standard-style-list-mixin basic%))
|
||||||
(define -keymap% (editor:keymap-mixin standard-style-list%))
|
(define -keymap% (editor:keymap-mixin standard-style-list%))
|
||||||
(define file% (editor:file-mixin -keymap%))
|
(define file% (editor:file-mixin -keymap%))
|
||||||
(define backup-autosave% (editor:backup-autosave-mixin file%))
|
(define backup-autosave% (editor:backup-autosave-mixin file%))
|
||||||
(define info% (editor:info-mixin backup-autosave%)))
|
(define info% (editor:info-mixin backup-autosave%)))
|
||||||
|
|
|
||||||
|
|
@ -1,58 +1,58 @@
|
||||||
(module path-utils (lib "a-unit.ss")
|
(module path-utils (lib "a-unit.ss")
|
||||||
(require "sig.ss"
|
(require "sig.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export framework:path-utils^)
|
(export framework:path-utils^)
|
||||||
|
|
||||||
(define (generate-autosave-name name)
|
(define (generate-autosave-name name)
|
||||||
(let-values ([(base name dir?)
|
(let-values ([(base name dir?)
|
||||||
(if name
|
(if name
|
||||||
(split-path name)
|
(split-path name)
|
||||||
(values (find-system-path 'doc-dir)
|
(values (find-system-path 'doc-dir)
|
||||||
(bytes->path-element #"mredauto")
|
(bytes->path-element #"mredauto")
|
||||||
#f))])
|
#f))])
|
||||||
(let* ([base (if (path? base)
|
(let* ([base (if (path? base)
|
||||||
base
|
base
|
||||||
(current-directory))]
|
(current-directory))]
|
||||||
[path (if (relative-path? base)
|
[path (if (relative-path? base)
|
||||||
(build-path (current-directory) base)
|
(build-path (current-directory) base)
|
||||||
base)])
|
base)])
|
||||||
(let loop ([n 1])
|
(let loop ([n 1])
|
||||||
(let* ([numb (string->bytes/utf-8 (number->string n))]
|
(let* ([numb (string->bytes/utf-8 (number->string n))]
|
||||||
[new-name
|
[new-name
|
||||||
(build-path path
|
(build-path path
|
||||||
(if (eq? (system-type) 'windows)
|
(if (eq? (system-type) 'windows)
|
||||||
(bytes->path-element
|
(bytes->path-element
|
||||||
(bytes-append (regexp-replace #rx#"\\..*$"
|
(bytes-append (regexp-replace #rx#"\\..*$"
|
||||||
(path-element->bytes name)
|
(path-element->bytes name)
|
||||||
#"")
|
#"")
|
||||||
#"."
|
#"."
|
||||||
numb))
|
numb))
|
||||||
(bytes->path-element
|
(bytes->path-element
|
||||||
(bytes-append #"#"
|
(bytes-append #"#"
|
||||||
(path-element->bytes name)
|
(path-element->bytes name)
|
||||||
#"#"
|
#"#"
|
||||||
numb
|
numb
|
||||||
#"#"))))])
|
#"#"))))])
|
||||||
(if (file-exists? new-name)
|
(if (file-exists? new-name)
|
||||||
(loop (add1 n))
|
(loop (add1 n))
|
||||||
new-name))))))
|
new-name))))))
|
||||||
|
|
||||||
(define (generate-backup-name full-name)
|
(define (generate-backup-name full-name)
|
||||||
(let-values ([(pre-base name dir?) (split-path full-name)])
|
(let-values ([(pre-base name dir?) (split-path full-name)])
|
||||||
(let ([base (if (path? pre-base)
|
(let ([base (if (path? pre-base)
|
||||||
pre-base
|
pre-base
|
||||||
(current-directory))])
|
(current-directory))])
|
||||||
(let ([name-bytes (path-element->bytes name)])
|
(let ([name-bytes (path-element->bytes name)])
|
||||||
(cond
|
(cond
|
||||||
[(and (eq? (system-type) 'windows)
|
[(and (eq? (system-type) 'windows)
|
||||||
(regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
|
(regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
|
||||||
=>
|
=>
|
||||||
(λ (m)
|
(λ (m)
|
||||||
(build-path base (bytes->path-element (bytes-append (cadr m) #".bak"))))]
|
(build-path base (bytes->path-element (bytes-append (cadr m) #".bak"))))]
|
||||||
[(eq? (system-type) 'windows)
|
[(eq? (system-type) 'windows)
|
||||||
(build-path base (bytes->path-element (bytes-append name-bytes #".bak")))]
|
(build-path base (bytes->path-element (bytes-append name-bytes #".bak")))]
|
||||||
[else
|
[else
|
||||||
(build-path base (bytes->path-element (bytes-append name-bytes #"~")))]))))))
|
(build-path base (bytes->path-element (bytes-append name-bytes #"~")))]))))))
|
||||||
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,20 +1,20 @@
|
||||||
(module sig mzscheme
|
(module sig mzscheme
|
||||||
(require (lib "unit.ss"))
|
(require (lib "unit.ss"))
|
||||||
|
|
||||||
(provide (prefix-all-defined-except framework: framework^)
|
(provide (prefix-all-defined-except framework: framework^)
|
||||||
framework^)
|
framework^)
|
||||||
|
|
||||||
(define-signature number-snip-class^
|
(define-signature number-snip-class^
|
||||||
(snip-class%))
|
(snip-class%))
|
||||||
(define-signature number-snip^ extends number-snip-class^
|
(define-signature number-snip^ extends number-snip-class^
|
||||||
(make-repeating-decimal-snip
|
(make-repeating-decimal-snip
|
||||||
make-fraction-snip))
|
make-fraction-snip))
|
||||||
|
|
||||||
(define-signature comment-box-class^
|
(define-signature comment-box-class^
|
||||||
(snipclass snip%))
|
(snipclass snip%))
|
||||||
(define-signature comment-box^ extends comment-box-class^
|
(define-signature comment-box^ extends comment-box-class^
|
||||||
())
|
())
|
||||||
|
|
||||||
(define-signature menu-class^
|
(define-signature menu-class^
|
||||||
(can-restore<%>
|
(can-restore<%>
|
||||||
can-restore-mixin
|
can-restore-mixin
|
||||||
|
|
@ -25,73 +25,73 @@
|
||||||
can-restore-underscore-menu%))
|
can-restore-underscore-menu%))
|
||||||
(define-signature menu^ extends menu-class^
|
(define-signature menu^ extends menu-class^
|
||||||
())
|
())
|
||||||
|
|
||||||
(define-signature version-class^
|
(define-signature version-class^
|
||||||
())
|
())
|
||||||
(define-signature version^ extends version-class^
|
(define-signature version^ extends version-class^
|
||||||
(add-spec
|
(add-spec
|
||||||
version))
|
version))
|
||||||
|
|
||||||
(define-signature panel-class^
|
(define-signature panel-class^
|
||||||
(single-mixin
|
(single-mixin
|
||||||
single<%>
|
single<%>
|
||||||
|
|
||||||
single-window<%>
|
single-window<%>
|
||||||
single-window-mixin
|
single-window-mixin
|
||||||
|
|
||||||
;;multi-view-mixin
|
;;multi-view-mixin
|
||||||
;;multi-view<%>
|
;;multi-view<%>
|
||||||
|
|
||||||
|
|
||||||
single%
|
single%
|
||||||
single-pane%
|
single-pane%
|
||||||
;;multi-view%
|
;;multi-view%
|
||||||
|
|
||||||
dragable<%>
|
dragable<%>
|
||||||
dragable-mixin
|
dragable-mixin
|
||||||
|
|
||||||
vertical-dragable<%>
|
vertical-dragable<%>
|
||||||
vertical-dragable-mixin
|
vertical-dragable-mixin
|
||||||
vertical-dragable%
|
vertical-dragable%
|
||||||
|
|
||||||
horizontal-dragable<%>
|
horizontal-dragable<%>
|
||||||
horizontal-dragable-mixin
|
horizontal-dragable-mixin
|
||||||
horizontal-dragable%))
|
horizontal-dragable%))
|
||||||
(define-signature panel^ extends panel-class^
|
(define-signature panel^ extends panel-class^
|
||||||
())
|
())
|
||||||
|
|
||||||
(define-signature application-class^
|
(define-signature application-class^
|
||||||
())
|
())
|
||||||
(define-signature application^ extends application-class^
|
(define-signature application^ extends application-class^
|
||||||
(current-app-name))
|
(current-app-name))
|
||||||
|
|
||||||
(define-signature preferences-class^
|
(define-signature preferences-class^
|
||||||
())
|
())
|
||||||
(define-signature preferences^ extends preferences-class^
|
(define-signature preferences^ extends preferences-class^
|
||||||
(put-preferences/gui
|
(put-preferences/gui
|
||||||
add-panel
|
add-panel
|
||||||
add-font-panel
|
add-font-panel
|
||||||
|
|
||||||
add-editor-checkbox-panel
|
add-editor-checkbox-panel
|
||||||
add-warnings-checkbox-panel
|
add-warnings-checkbox-panel
|
||||||
add-scheme-checkbox-panel
|
add-scheme-checkbox-panel
|
||||||
|
|
||||||
add-to-editor-checkbox-panel
|
add-to-editor-checkbox-panel
|
||||||
add-to-warnings-checkbox-panel
|
add-to-warnings-checkbox-panel
|
||||||
add-to-scheme-checkbox-panel
|
add-to-scheme-checkbox-panel
|
||||||
|
|
||||||
add-on-close-dialog-callback
|
add-on-close-dialog-callback
|
||||||
add-can-close-dialog-callback
|
add-can-close-dialog-callback
|
||||||
|
|
||||||
show-dialog
|
show-dialog
|
||||||
hide-dialog))
|
hide-dialog))
|
||||||
|
|
||||||
(define-signature autosave-class^
|
(define-signature autosave-class^
|
||||||
(autosavable<%>))
|
(autosavable<%>))
|
||||||
(define-signature autosave^ extends autosave-class^
|
(define-signature autosave^ extends autosave-class^
|
||||||
(register
|
(register
|
||||||
restore-autosave-files/gui))
|
restore-autosave-files/gui))
|
||||||
|
|
||||||
(define-signature exit-class^
|
(define-signature exit-class^
|
||||||
())
|
())
|
||||||
(define-signature exit^ extends exit-class^
|
(define-signature exit^ extends exit-class^
|
||||||
|
|
@ -103,13 +103,13 @@
|
||||||
can-exit?
|
can-exit?
|
||||||
on-exit
|
on-exit
|
||||||
exit))
|
exit))
|
||||||
|
|
||||||
(define-signature path-utils-class^
|
(define-signature path-utils-class^
|
||||||
())
|
())
|
||||||
(define-signature path-utils^ extends path-utils-class^
|
(define-signature path-utils^ extends path-utils-class^
|
||||||
(generate-autosave-name
|
(generate-autosave-name
|
||||||
generate-backup-name))
|
generate-backup-name))
|
||||||
|
|
||||||
(define-signature finder-class^
|
(define-signature finder-class^
|
||||||
())
|
())
|
||||||
(define-signature finder^ extends finder-class^
|
(define-signature finder^ extends finder-class^
|
||||||
|
|
@ -123,7 +123,7 @@
|
||||||
common-get-file-list
|
common-get-file-list
|
||||||
get-file
|
get-file
|
||||||
put-file))
|
put-file))
|
||||||
|
|
||||||
(define-signature editor-class^
|
(define-signature editor-class^
|
||||||
(basic<%>
|
(basic<%>
|
||||||
standard-style-list<%>
|
standard-style-list<%>
|
||||||
|
|
@ -145,7 +145,7 @@
|
||||||
set-standard-style-list-delta
|
set-standard-style-list-delta
|
||||||
set-default-font-color
|
set-default-font-color
|
||||||
get-default-color-style-name))
|
get-default-color-style-name))
|
||||||
|
|
||||||
(define-signature pasteboard-class^
|
(define-signature pasteboard-class^
|
||||||
(basic%
|
(basic%
|
||||||
standard-style-list%
|
standard-style-list%
|
||||||
|
|
@ -155,7 +155,7 @@
|
||||||
info%))
|
info%))
|
||||||
(define-signature pasteboard^ extends pasteboard-class^
|
(define-signature pasteboard^ extends pasteboard-class^
|
||||||
())
|
())
|
||||||
|
|
||||||
(define-signature text-class^
|
(define-signature text-class^
|
||||||
(basic<%>
|
(basic<%>
|
||||||
foreground-color<%>
|
foreground-color<%>
|
||||||
|
|
@ -204,7 +204,7 @@
|
||||||
input-box-mixin))
|
input-box-mixin))
|
||||||
(define-signature text^ extends text-class^
|
(define-signature text^ extends text-class^
|
||||||
())
|
())
|
||||||
|
|
||||||
(define-signature canvas-class^
|
(define-signature canvas-class^
|
||||||
(basic<%>
|
(basic<%>
|
||||||
color<%>
|
color<%>
|
||||||
|
|
@ -217,7 +217,7 @@
|
||||||
info%
|
info%
|
||||||
delegate%
|
delegate%
|
||||||
wide-snip%
|
wide-snip%
|
||||||
|
|
||||||
basic-mixin
|
basic-mixin
|
||||||
color-mixin
|
color-mixin
|
||||||
delegate-mixin
|
delegate-mixin
|
||||||
|
|
@ -225,7 +225,7 @@
|
||||||
wide-snip-mixin))
|
wide-snip-mixin))
|
||||||
(define-signature canvas^ extends canvas-class^
|
(define-signature canvas^ extends canvas-class^
|
||||||
())
|
())
|
||||||
|
|
||||||
(define-signature frame-class^
|
(define-signature frame-class^
|
||||||
(basic<%>
|
(basic<%>
|
||||||
size-pref<%>
|
size-pref<%>
|
||||||
|
|
@ -277,12 +277,12 @@
|
||||||
remove-empty-menus
|
remove-empty-menus
|
||||||
add-snip-menu-items
|
add-snip-menu-items
|
||||||
setup-size-pref))
|
setup-size-pref))
|
||||||
|
|
||||||
(define-signature group-class^
|
(define-signature group-class^
|
||||||
(%))
|
(%))
|
||||||
(define-signature group^ extends group-class^
|
(define-signature group^ extends group-class^
|
||||||
(get-the-frame-group))
|
(get-the-frame-group))
|
||||||
|
|
||||||
(define-signature handler-class^
|
(define-signature handler-class^
|
||||||
())
|
())
|
||||||
(define-signature handler^ extends handler-class^
|
(define-signature handler^ extends handler-class^
|
||||||
|
|
@ -301,7 +301,7 @@
|
||||||
set-recent-position
|
set-recent-position
|
||||||
set-recent-items-frame-superclass
|
set-recent-items-frame-superclass
|
||||||
size-recently-opened-files))
|
size-recently-opened-files))
|
||||||
|
|
||||||
(define-signature icon-class^
|
(define-signature icon-class^
|
||||||
())
|
())
|
||||||
(define-signature icon^ extends icon-class^
|
(define-signature icon^ extends icon-class^
|
||||||
|
|
@ -312,13 +312,13 @@
|
||||||
get-lock-bitmap
|
get-lock-bitmap
|
||||||
get-unlock-bitmap
|
get-unlock-bitmap
|
||||||
get-anchor-bitmap
|
get-anchor-bitmap
|
||||||
|
|
||||||
get-left/right-cursor
|
get-left/right-cursor
|
||||||
get-up/down-cursor
|
get-up/down-cursor
|
||||||
|
|
||||||
get-gc-on-bitmap
|
get-gc-on-bitmap
|
||||||
get-gc-off-bitmap))
|
get-gc-off-bitmap))
|
||||||
|
|
||||||
(define-signature keymap-class^
|
(define-signature keymap-class^
|
||||||
(aug-keymap%
|
(aug-keymap%
|
||||||
aug-keymap<%>
|
aug-keymap<%>
|
||||||
|
|
@ -326,22 +326,22 @@
|
||||||
(define-signature keymap^ extends keymap-class^
|
(define-signature keymap^ extends keymap-class^
|
||||||
(send-map-function-meta
|
(send-map-function-meta
|
||||||
make-meta-prefix-list
|
make-meta-prefix-list
|
||||||
|
|
||||||
canonicalize-keybinding-string
|
canonicalize-keybinding-string
|
||||||
|
|
||||||
add-to-right-button-menu
|
add-to-right-button-menu
|
||||||
add-to-right-button-menu/before
|
add-to-right-button-menu/before
|
||||||
|
|
||||||
setup-global
|
setup-global
|
||||||
setup-search
|
setup-search
|
||||||
setup-file
|
setup-file
|
||||||
setup-editor
|
setup-editor
|
||||||
|
|
||||||
get-global
|
get-global
|
||||||
get-search
|
get-search
|
||||||
get-file
|
get-file
|
||||||
get-editor
|
get-editor
|
||||||
|
|
||||||
set-chained-keymaps
|
set-chained-keymaps
|
||||||
remove-chained-keymap
|
remove-chained-keymap
|
||||||
|
|
||||||
|
|
@ -349,12 +349,12 @@
|
||||||
|
|
||||||
add-user-keybindings-file
|
add-user-keybindings-file
|
||||||
remove-user-keybindings-file))
|
remove-user-keybindings-file))
|
||||||
|
|
||||||
(define-signature color-class^
|
(define-signature color-class^
|
||||||
(text<%>
|
(text<%>
|
||||||
text-mixin
|
text-mixin
|
||||||
text%
|
text%
|
||||||
|
|
||||||
text-mode<%>
|
text-mode<%>
|
||||||
text-mode-mixin
|
text-mode-mixin
|
||||||
text-mode%))
|
text-mode%))
|
||||||
|
|
@ -382,7 +382,7 @@
|
||||||
text-mode%
|
text-mode%
|
||||||
|
|
||||||
set-mode-mixin
|
set-mode-mixin
|
||||||
|
|
||||||
sexp-snip%
|
sexp-snip%
|
||||||
sexp-snip<%>))
|
sexp-snip<%>))
|
||||||
(define-signature scheme^ extends scheme-class^
|
(define-signature scheme^ extends scheme-class^
|
||||||
|
|
@ -399,17 +399,17 @@
|
||||||
short-sym->style-name
|
short-sym->style-name
|
||||||
|
|
||||||
text-balanced?))
|
text-balanced?))
|
||||||
|
|
||||||
(define-signature main-class^ ())
|
(define-signature main-class^ ())
|
||||||
(define-signature main^ extends main-class^ ())
|
(define-signature main^ extends main-class^ ())
|
||||||
|
|
||||||
(define-signature mode-class^
|
(define-signature mode-class^
|
||||||
(host-text-mixin
|
(host-text-mixin
|
||||||
host-text<%>
|
host-text<%>
|
||||||
surrogate-text%
|
surrogate-text%
|
||||||
surrogate-text<%>))
|
surrogate-text<%>))
|
||||||
(define-signature mode^ extends mode-class^ ())
|
(define-signature mode^ extends mode-class^ ())
|
||||||
|
|
||||||
(define-signature color-model-class^
|
(define-signature color-model-class^
|
||||||
())
|
())
|
||||||
(define-signature color-model^ extends color-model-class^
|
(define-signature color-model^ extends color-model-class^
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,22 +1,22 @@
|
||||||
(module version (lib "a-unit.ss")
|
(module version (lib "a-unit.ss")
|
||||||
(require "sig.ss"
|
(require "sig.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "string.ss")
|
(lib "string.ss")
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
(import)
|
(import)
|
||||||
(export (rename framework:version^
|
(export (rename framework:version^
|
||||||
[-version version]))
|
[-version version]))
|
||||||
|
|
||||||
(define specs null)
|
(define specs null)
|
||||||
|
|
||||||
(define (-version)
|
(define (-version)
|
||||||
(foldr (lambda (entry sofar)
|
(foldr (lambda (entry sofar)
|
||||||
(let ([sep (first entry)]
|
(let ([sep (first entry)]
|
||||||
[num (second entry)])
|
[num (second entry)])
|
||||||
(string-append sofar sep num)))
|
(string-append sofar sep num)))
|
||||||
(version)
|
(version)
|
||||||
specs))
|
specs))
|
||||||
|
|
||||||
(define (add-spec sep num)
|
(define (add-spec sep num)
|
||||||
(set! specs (cons (list (expr->string sep) (format "~a" num))
|
(set! specs (cons (list (expr->string sep) (format "~a" num))
|
||||||
specs))))
|
specs))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user