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