...
original commit: e5aae825b0b9acb174260f0cf9d95f2c6da5db13
This commit is contained in:
Robby Findler
parent
6b645ab01c
commit
f4b47c38f8
|
|
@ -1,45 +1,9 @@
|
|||
(require-relative-library "frameworks.ss")
|
||||
(module framework mzscheme
|
||||
(require (lib "unitsig.ss"))
|
||||
|
||||
(require-library "string.ss")
|
||||
(require-library "function.ss")
|
||||
(require-library "pretty.ss")
|
||||
(require-library "file.ss")
|
||||
(require-library "thread.ss")
|
||||
(require "framework-unit.ss"
|
||||
"sig.ss")
|
||||
|
||||
(require-relative-library "test.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig frameworkc^
|
||||
(compound-unit/sig
|
||||
(import [core:string : mzlib:string^]
|
||||
[core:function : mzlib:function^]
|
||||
[core:pretty-print : mzlib:pretty-print^]
|
||||
[core:file : mzlib:file^]
|
||||
[core:thread : mzlib:thread^]
|
||||
[framework:keys : framework:keys^]
|
||||
[framework:test : framework:test^]
|
||||
[m : mred^])
|
||||
(link [prefs-file : framework:prefs-file^ ((require-relative-library "prefs-file.ss"))]
|
||||
[f : frameworkc^ ((require-relative-library "frameworkc.ss")
|
||||
core:string
|
||||
core:function
|
||||
core:pretty-print
|
||||
core:file
|
||||
core:thread
|
||||
m
|
||||
framework:keys
|
||||
framework:test
|
||||
prefs-file)])
|
||||
(export (open f)))
|
||||
#f
|
||||
mzlib:string^
|
||||
mzlib:function^
|
||||
mzlib:pretty-print^
|
||||
mzlib:file^
|
||||
mzlib:thread^
|
||||
(keys : framework:keys^)
|
||||
(test : framework:test^)
|
||||
mred^)
|
||||
(provide-signature-elements framework^)
|
||||
|
||||
(define-values/invoke-unit/sig framework^ framework@))
|
||||
|
|
|
|||
|
|
@ -1,10 +1,15 @@
|
|||
(unit/sig framework:application^
|
||||
(import)
|
||||
(module application mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss")
|
||||
|
||||
(define current-app-name (make-parameter
|
||||
"MrEd"
|
||||
(lambda (x)
|
||||
(unless (string? x)
|
||||
(error 'current-app-name
|
||||
"the app name must be a string"))
|
||||
x))))
|
||||
(define application@
|
||||
(unit/sig framework:application^
|
||||
(import)
|
||||
|
||||
(define current-app-name (make-parameter
|
||||
"MrEd"
|
||||
(lambda (x)
|
||||
(unless (string? x)
|
||||
(error 'current-app-name
|
||||
"the app name must be a string"))
|
||||
x))))))
|
||||
|
|
@ -1,47 +1,52 @@
|
|||
(unit/sig framework:autosave^
|
||||
(import mred^
|
||||
[exit : framework:exit^]
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
(define objects null)
|
||||
(module autosave mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(define autosave-timer%
|
||||
(class timer% ()
|
||||
(inherit start)
|
||||
(override
|
||||
[notify
|
||||
(lambda ()
|
||||
(when (preferences:get 'framework:autosaving-on?)
|
||||
(set! objects
|
||||
(let loop ([list objects])
|
||||
(if (null? list)
|
||||
null
|
||||
(let ([object (weak-box-value (car list))])
|
||||
(if object
|
||||
(begin
|
||||
(send object do-autosave)
|
||||
(cons (car list) (loop (cdr list))))
|
||||
(loop (cdr list))))))))
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t)))])
|
||||
(sequence
|
||||
(super-init)
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t)))))
|
||||
(define autosave@
|
||||
(unit/sig framework:autosave^
|
||||
(import [exit : framework:exit^]
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
(define objects null)
|
||||
|
||||
(define timer #f)
|
||||
(define autosave-timer%
|
||||
(class timer% ()
|
||||
(inherit start)
|
||||
(override
|
||||
[notify
|
||||
(lambda ()
|
||||
(when (preferences:get 'framework:autosaving-on?)
|
||||
(set! objects
|
||||
(let loop ([list objects])
|
||||
(if (null? list)
|
||||
null
|
||||
(let ([object (weak-box-value (car list))])
|
||||
(if object
|
||||
(begin
|
||||
(send object do-autosave)
|
||||
(cons (car list) (loop (cdr list))))
|
||||
(loop (cdr list))))))))
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t)))])
|
||||
(sequence
|
||||
(super-init)
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t)))))
|
||||
|
||||
(define register
|
||||
(lambda (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 timer #f)
|
||||
|
||||
(define register
|
||||
(lambda (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))))]))))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,167 +1,171 @@
|
|||
(module canvas mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(unit/sig framework:canvas^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^]
|
||||
[frame : framework:frame^])
|
||||
|
||||
(define basic<%> (interface ((class->interface editor-canvas%))))
|
||||
(define basic-mixin
|
||||
(mixin ((class->interface editor-canvas%)) (basic<%>) args
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define info<%> (interface (basic<%>)))
|
||||
;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>)))
|
||||
(define info-mixin
|
||||
(mixin (basic<%>) (info<%>) (parent [editor #f] . args)
|
||||
(inherit has-focus? get-top-level-window)
|
||||
(rename [super-on-focus on-focus]
|
||||
[super-set-editor set-editor])
|
||||
(override
|
||||
[on-focus
|
||||
(lambda (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)))]
|
||||
[set-editor
|
||||
(lambda (m)
|
||||
(super-set-editor m)
|
||||
(let ([tlw (get-top-level-window)])
|
||||
(when (eq? this (send tlw get-info-canvas))
|
||||
(send tlw update-info))))])
|
||||
(sequence
|
||||
(apply super-init parent editor args)
|
||||
(define canvas@
|
||||
(unit/sig framework:canvas^
|
||||
(import [preferences : framework:preferences^]
|
||||
[frame : framework:frame^])
|
||||
|
||||
(define basic<%> (interface ((class->interface editor-canvas%))))
|
||||
(define basic-mixin
|
||||
(mixin ((class->interface editor-canvas%)) (basic<%>) args
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define info<%> (interface (basic<%>)))
|
||||
;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>)))
|
||||
(define info-mixin
|
||||
(mixin (basic<%>) (info<%>) (parent [editor #f] . args)
|
||||
(inherit has-focus? get-top-level-window)
|
||||
(rename [super-on-focus on-focus]
|
||||
[super-set-editor set-editor])
|
||||
(override
|
||||
[on-focus
|
||||
(lambda (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)))]
|
||||
[set-editor
|
||||
(lambda (m)
|
||||
(super-set-editor m)
|
||||
(let ([tlw (get-top-level-window)])
|
||||
(when (eq? this (send tlw get-info-canvas))
|
||||
(send tlw update-info))))])
|
||||
(sequence
|
||||
(apply super-init parent editor args)
|
||||
|
||||
(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))
|
||||
|
||||
;; wx: this need to collude with
|
||||
;; the edit, since the edit has the right callbacks.
|
||||
(define wide-snip-mixin
|
||||
(mixin (basic<%>) (wide-snip<%>) args
|
||||
(inherit get-editor)
|
||||
(rename [super-on-size on-size])
|
||||
(private
|
||||
[wide-snips null]
|
||||
[tall-snips null]
|
||||
[update-snip-size
|
||||
(lambda (width?)
|
||||
(lambda (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)])
|
||||
(lambda (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
|
||||
(lambda (s)
|
||||
(+ 4 ;; this is compensate for an autowrapping bug
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(not s) 0]
|
||||
[(member 'hard-newline (send s get-flags)) 0]
|
||||
[(member 'newline (send s get-flags)) 0]
|
||||
[else
|
||||
(if s
|
||||
(+ (get-width s)
|
||||
2 ;; for the caret
|
||||
(loop (send s next)))
|
||||
0)]))))])
|
||||
(when edit
|
||||
(send edit
|
||||
run-after-edit-sequence
|
||||
(lambda ()
|
||||
(let ([admin (send edit get-admin)])
|
||||
(send admin get-view #f #f width height)
|
||||
(send s get-margin leftm topm rightm bottomm)
|
||||
;; wx: this need to collude with
|
||||
;; the edit, since the edit has the right callbacks.
|
||||
(define wide-snip-mixin
|
||||
(mixin (basic<%>) (wide-snip<%>) args
|
||||
(inherit get-editor)
|
||||
(rename [super-on-size on-size])
|
||||
(private
|
||||
[wide-snips null]
|
||||
[tall-snips null]
|
||||
[update-snip-size
|
||||
(lambda (width?)
|
||||
(lambda (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)])
|
||||
(lambda (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
|
||||
(lambda (s)
|
||||
(+ 4 ;; this is compensate for an autowrapping bug
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(not s) 0]
|
||||
[(member 'hard-newline (send s get-flags)) 0]
|
||||
[(member 'newline (send s get-flags)) 0]
|
||||
[else
|
||||
(if s
|
||||
(+ (get-width s)
|
||||
2 ;; for the caret
|
||||
(loop (send s next)))
|
||||
0)]))))])
|
||||
(when edit
|
||||
(send edit
|
||||
run-after-edit-sequence
|
||||
(lambda ()
|
||||
(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
|
||||
(lambda ()
|
||||
(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
|
||||
(lambda ()
|
||||
(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)))))))))))])
|
||||
(public
|
||||
[recalc-snips
|
||||
(lambda ()
|
||||
(for-each (update-snip-size #t) wide-snips)
|
||||
(for-each (update-snip-size #f) tall-snips))])
|
||||
(public
|
||||
[add-wide-snip
|
||||
(lambda (snip)
|
||||
(set! wide-snips (cons snip wide-snips))
|
||||
((update-snip-size #t) snip))]
|
||||
[add-tall-snip
|
||||
(lambda (snip)
|
||||
(set! tall-snips (cons snip tall-snips))
|
||||
((update-snip-size #f) snip))])
|
||||
(override
|
||||
[on-size
|
||||
(lambda (width height)
|
||||
(recalc-snips)
|
||||
(super-on-size width height))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(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)))))))))))])
|
||||
(public
|
||||
[recalc-snips
|
||||
(lambda ()
|
||||
(for-each (update-snip-size #t) wide-snips)
|
||||
(for-each (update-snip-size #f) tall-snips))])
|
||||
(public
|
||||
[add-wide-snip
|
||||
(lambda (snip)
|
||||
(set! wide-snips (cons snip wide-snips))
|
||||
((update-snip-size #t) snip))]
|
||||
[add-tall-snip
|
||||
(lambda (snip)
|
||||
(set! tall-snips (cons snip tall-snips))
|
||||
((update-snip-size #f) snip))])
|
||||
(override
|
||||
[on-size
|
||||
(lambda (width height)
|
||||
(recalc-snips)
|
||||
(super-on-size width height))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define basic% (basic-mixin editor-canvas%))
|
||||
(define info% (info-mixin basic%))
|
||||
(define wide-snip% (wide-snip-mixin basic%)))
|
||||
(define basic% (basic-mixin editor-canvas%))
|
||||
(define info% (info-mixin basic%))
|
||||
(define wide-snip% (wide-snip-mixin basic%)))))
|
||||
|
|
|
|||
|
|
@ -1,272 +1,269 @@
|
|||
(unit/sig framework:color-model^
|
||||
(import mzlib:function^)
|
||||
(module canvas mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "function.ss"))
|
||||
|
||||
;(require-library "function.ss")
|
||||
(define color-model@
|
||||
(unit/sig framework:color-model^
|
||||
(import)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; ;;;
|
||||
;;; matrix ops ;;;
|
||||
;;; ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; matrix inversion using cramer's rule
|
||||
|
||||
;; matrix inversion using cramer's rule
|
||||
|
||||
; submatrix : (list-of (list-of num)) int int -> (list-of (list-of num))
|
||||
; submatrix "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)))])))
|
||||
|
||||
;(equal? (submatrix test-matrix 1 2)
|
||||
; '((1 2 6) (7 8 4)))
|
||||
|
||||
; 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 square-test-matrix '((3 20 3) (37 0 8) (2 1 4)))
|
||||
|
||||
;(= (det square-test-matrix) -2553)
|
||||
;; 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)))])))
|
||||
|
||||
;;(equal? (submatrix test-matrix 1 2)
|
||||
;; '((1 2 6) (7 8 4)))
|
||||
|
||||
;; 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 square-test-matrix '((3 20 3) (37 0 8) (2 1 4)))
|
||||
|
||||
;;(= (det square-test-matrix) -2553)
|
||||
|
||||
;; 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))))))))
|
||||
|
||||
;;(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
|
||||
|
||||
(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))
|
||||
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; 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 (lambda (row)
|
||||
(map (lambda (col)
|
||||
(inner-product row col))
|
||||
b-t))
|
||||
a))))
|
||||
|
||||
; 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))))))))
|
||||
|
||||
;(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
|
||||
|
||||
(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))
|
||||
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; 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 (lambda (row)
|
||||
(map (lambda (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)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; ;;;
|
||||
;;; color model ;;;
|
||||
;;; ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; 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
|
||||
|
||||
(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 x-w 0.313)
|
||||
(define y-w 0.329)
|
||||
(define big-y-w 100.0)
|
||||
|
||||
(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 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))
|
||||
|
||||
; sigmas were calculated by soving a set of linear equations based upon ntsc standard 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
|
||||
|
||||
(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 x-w 0.313)
|
||||
(define y-w 0.329)
|
||||
(define big-y-w 100.0)
|
||||
|
||||
(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 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))
|
||||
|
||||
;; 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-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))))
|
||||
|
||||
(define rgb->xyz-matrix
|
||||
(map (lambda (row)
|
||||
(map (lambda (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))
|
||||
|
||||
'(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))))))))
|
||||
|
||||
'(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 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)))))
|
||||
|
||||
;; (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 (lambda (row)
|
||||
(map (lambda (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))
|
||||
|
||||
;;(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))))))))
|
||||
|
||||
;;(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)))))))
|
||||
|
||||
;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.
|
||||
|
||||
(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 (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-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 (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)))
|
||||
|
||||
'(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))
|
||||
)
|
||||
;;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.
|
||||
|
||||
(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 (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-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 (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)))
|
||||
|
||||
;;(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))
|
||||
)))
|
||||
|
|
@ -1,452 +1,457 @@
|
|||
(unit/sig framework:editor^
|
||||
(import mred^
|
||||
[autosave : framework:autosave^]
|
||||
[finder : framework:finder^]
|
||||
[path-utils : framework:path-utils^]
|
||||
[keymap : framework:keymap^]
|
||||
[icon : framework:icon^]
|
||||
[preferences : framework:preferences^]
|
||||
[text : framework:text^]
|
||||
[pasteboard : framework:pasteboard^]
|
||||
[frame : framework:frame^]
|
||||
[gui-utils : framework:gui-utils^]
|
||||
[mzlib:file : mzlib:file^])
|
||||
|
||||
(rename [-keymap<%> keymap<%>])
|
||||
(module editor mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "file.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(define basic<%>
|
||||
(interface (editor<%>)
|
||||
has-focus?
|
||||
editing-this-file?
|
||||
local-edit-sequence?
|
||||
run-after-edit-sequence
|
||||
get-top-level-window
|
||||
on-close
|
||||
save-file-out-of-date?))
|
||||
|
||||
(define basic-mixin
|
||||
(mixin (editor<%>) (basic<%>) args
|
||||
(inherit get-filename save-file
|
||||
refresh-delayed?
|
||||
get-canvas
|
||||
get-max-width get-admin)
|
||||
|
||||
(rename [super-can-save-file? can-save-file?])
|
||||
(override
|
||||
[can-save-file?
|
||||
(lambda (filename format)
|
||||
(and (if (equal? filename (get-filename))
|
||||
(if (save-file-out-of-date?)
|
||||
(gui-utils:get-choice
|
||||
"The file has beeen modified since it was last saved. Overwrite the modifications?"
|
||||
"Overwrite"
|
||||
"Cancel"
|
||||
"Warning"
|
||||
#f
|
||||
(get-top-level-focus-window))
|
||||
#t)
|
||||
#t)
|
||||
(super-can-save-file? filename format)))])
|
||||
|
||||
(rename [super-after-save-file after-save-file]
|
||||
[super-after-load-file after-load-file])
|
||||
(private
|
||||
[last-saved-file-time #f])
|
||||
(override
|
||||
[after-save-file
|
||||
(lambda (sucess?)
|
||||
(when sucess?
|
||||
(let ([filename (get-filename)])
|
||||
(set! last-saved-file-time
|
||||
(and filename
|
||||
(file-exists? filename)
|
||||
(file-or-directory-modify-seconds filename)))))
|
||||
(super-after-save-file sucess?))]
|
||||
[after-load-file
|
||||
(lambda (sucess?)
|
||||
(when sucess?
|
||||
(let ([filename (get-filename)])
|
||||
(set! last-saved-file-time
|
||||
(and filename
|
||||
(file-exists? filename)
|
||||
(file-or-directory-modify-seconds filename)))))
|
||||
(super-after-load-file sucess?))])
|
||||
(public
|
||||
[save-file-out-of-date?
|
||||
(lambda ()
|
||||
(and
|
||||
last-saved-file-time
|
||||
(let ([fn (get-filename)])
|
||||
(and fn
|
||||
(file-exists? fn)
|
||||
(let ([ms (file-or-directory-modify-seconds fn)])
|
||||
(< last-saved-file-time ms))))))])
|
||||
|
||||
(private
|
||||
[has-focus #f])
|
||||
(rename [super-on-focus on-focus])
|
||||
(override
|
||||
[on-focus
|
||||
(lambda (x)
|
||||
(set! has-focus x))])
|
||||
(public
|
||||
[has-focus?
|
||||
(lambda ()
|
||||
has-focus)])
|
||||
(define editor@
|
||||
(unit/sig framework:editor^
|
||||
(import [autosave : framework:autosave^]
|
||||
[finder : framework:finder^]
|
||||
[path-utils : framework:path-utils^]
|
||||
[keymap : framework:keymap^]
|
||||
[icon : framework:icon^]
|
||||
[preferences : framework:preferences^]
|
||||
[text : framework:text^]
|
||||
[pasteboard : framework:pasteboard^]
|
||||
[frame : framework:frame^]
|
||||
[gui-utils : framework:gui-utils^])
|
||||
|
||||
(rename [super-begin-edit-sequence begin-edit-sequence]
|
||||
[super-end-edit-sequence end-edit-sequence])
|
||||
(private
|
||||
[edit-sequence-count 0])
|
||||
(override
|
||||
[begin-edit-sequence
|
||||
(case-lambda
|
||||
[() (begin-edit-sequence #t)]
|
||||
[(undoable?)
|
||||
(set! edit-sequence-count (+ edit-sequence-count 1))
|
||||
(super-begin-edit-sequence undoable?)])]
|
||||
[end-edit-sequence
|
||||
(lambda ()
|
||||
(set! edit-sequence-count (- edit-sequence-count 1))
|
||||
(when (< edit-sequence-count 0)
|
||||
(error 'end-edit-sequence "extra end-edit-sequence"))
|
||||
(super-end-edit-sequence))])
|
||||
(rename [-keymap<%> keymap<%>])
|
||||
|
||||
(public
|
||||
[on-close void]
|
||||
[get-top-level-window
|
||||
(lambda ()
|
||||
(let loop ([text this])
|
||||
(let ([editor-admin (send text get-admin)])
|
||||
(cond
|
||||
[(is-a? editor-admin editor-snip-editor-admin<%>)
|
||||
(let* ([snip (send editor-admin get-snip)]
|
||||
[snip-admin (send snip get-admin)])
|
||||
(loop (send snip-admin get-editor)))]
|
||||
[(send text get-canvas) => (lambda (canvas)
|
||||
(send canvas get-top-level-window))]
|
||||
[else
|
||||
#f]))))])
|
||||
(define basic<%>
|
||||
(interface (editor<%>)
|
||||
has-focus?
|
||||
editing-this-file?
|
||||
local-edit-sequence?
|
||||
run-after-edit-sequence
|
||||
get-top-level-window
|
||||
on-close
|
||||
save-file-out-of-date?))
|
||||
|
||||
(public [editing-this-file? (lambda () #f)])
|
||||
(define basic-mixin
|
||||
(mixin (editor<%>) (basic<%>) args
|
||||
(inherit get-filename save-file
|
||||
refresh-delayed?
|
||||
get-canvas
|
||||
get-max-width get-admin)
|
||||
|
||||
(private
|
||||
[edit-sequence-queue null]
|
||||
[edit-sequence-ht (make-hash-table)])
|
||||
(rename [super-can-save-file? can-save-file?])
|
||||
(override
|
||||
[can-save-file?
|
||||
(lambda (filename format)
|
||||
(and (if (equal? filename (get-filename))
|
||||
(if (save-file-out-of-date?)
|
||||
(gui-utils:get-choice
|
||||
"The file has beeen modified since it was last saved. Overwrite the modifications?"
|
||||
"Overwrite"
|
||||
"Cancel"
|
||||
"Warning"
|
||||
#f
|
||||
(get-top-level-focus-window))
|
||||
#t)
|
||||
#t)
|
||||
(super-can-save-file? filename format)))])
|
||||
|
||||
(rename [super-after-save-file after-save-file]
|
||||
[super-after-load-file after-load-file])
|
||||
(private
|
||||
[last-saved-file-time #f])
|
||||
(override
|
||||
[after-save-file
|
||||
(lambda (sucess?)
|
||||
(when sucess?
|
||||
(let ([filename (get-filename)])
|
||||
(set! last-saved-file-time
|
||||
(and filename
|
||||
(file-exists? filename)
|
||||
(file-or-directory-modify-seconds filename)))))
|
||||
(super-after-save-file sucess?))]
|
||||
[after-load-file
|
||||
(lambda (sucess?)
|
||||
(when sucess?
|
||||
(let ([filename (get-filename)])
|
||||
(set! last-saved-file-time
|
||||
(and filename
|
||||
(file-exists? filename)
|
||||
(file-or-directory-modify-seconds filename)))))
|
||||
(super-after-load-file sucess?))])
|
||||
(public
|
||||
[save-file-out-of-date?
|
||||
(lambda ()
|
||||
(and
|
||||
last-saved-file-time
|
||||
(let ([fn (get-filename)])
|
||||
(and fn
|
||||
(file-exists? fn)
|
||||
(let ([ms (file-or-directory-modify-seconds fn)])
|
||||
(< last-saved-file-time ms))))))])
|
||||
|
||||
(private
|
||||
[in-local-edit-sequence? #f])
|
||||
(public
|
||||
[local-edit-sequence? (lambda () in-local-edit-sequence?)]
|
||||
[run-after-edit-sequence
|
||||
(case-lambda
|
||||
[(t) (run-after-edit-sequence t #f)]
|
||||
[(t sym)
|
||||
(unless (and (procedure? t)
|
||||
(= 0 (arity t)))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected procedure of arity zero, got: ~s~n" t))
|
||||
(unless (or (symbol? sym) (not sym))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected second argument to be a symbol, got: ~s~n"
|
||||
sym))
|
||||
(if (refresh-delayed?)
|
||||
(if in-local-edit-sequence?
|
||||
(private
|
||||
[has-focus #f])
|
||||
(rename [super-on-focus on-focus])
|
||||
(override
|
||||
[on-focus
|
||||
(lambda (x)
|
||||
(set! has-focus x))])
|
||||
(public
|
||||
[has-focus?
|
||||
(lambda ()
|
||||
has-focus)])
|
||||
|
||||
(rename [super-begin-edit-sequence begin-edit-sequence]
|
||||
[super-end-edit-sequence end-edit-sequence])
|
||||
(private
|
||||
[edit-sequence-count 0])
|
||||
(override
|
||||
[begin-edit-sequence
|
||||
(case-lambda
|
||||
[() (begin-edit-sequence #t)]
|
||||
[(undoable?)
|
||||
(set! edit-sequence-count (+ edit-sequence-count 1))
|
||||
(super-begin-edit-sequence undoable?)])]
|
||||
[end-edit-sequence
|
||||
(lambda ()
|
||||
(set! edit-sequence-count (- edit-sequence-count 1))
|
||||
(when (< edit-sequence-count 0)
|
||||
(error 'end-edit-sequence "extra end-edit-sequence"))
|
||||
(super-end-edit-sequence))])
|
||||
|
||||
(public
|
||||
[on-close void]
|
||||
[get-top-level-window
|
||||
(lambda ()
|
||||
(let loop ([text this])
|
||||
(let ([editor-admin (send text get-admin)])
|
||||
(cond
|
||||
[(symbol? sym)
|
||||
(hash-table-put! edit-sequence-ht sym t)]
|
||||
[else (set! edit-sequence-queue
|
||||
(cons t edit-sequence-queue))])
|
||||
(let ([snip-admin (get-admin)])
|
||||
(cond
|
||||
[(not snip-admin)
|
||||
(t)] ;; refresh-delayed? is always #t when there is no admin.
|
||||
[(is-a? snip-admin editor-snip-editor-admin<%>)
|
||||
(send (send (send (send snip-admin get-snip) get-admin) get-editor)
|
||||
run-after-edit-sequence t sym)]
|
||||
[else
|
||||
(message-box "run-after-edit-sequence error"
|
||||
(format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
|
||||
snip-admin))
|
||||
'(t)])))
|
||||
(t))
|
||||
(void)])]
|
||||
[extend-edit-sequence-queue
|
||||
(lambda (l ht)
|
||||
(hash-table-for-each ht (lambda (k t)
|
||||
(hash-table-put!
|
||||
edit-sequence-ht
|
||||
k t)))
|
||||
(set! edit-sequence-queue (append l edit-sequence-queue)))])
|
||||
(rename
|
||||
[super-after-edit-sequence after-edit-sequence]
|
||||
[super-on-edit-sequence on-edit-sequence])
|
||||
(override
|
||||
[on-edit-sequence
|
||||
(lambda ()
|
||||
(super-on-edit-sequence)
|
||||
(set! in-local-edit-sequence? #t))]
|
||||
[after-edit-sequence
|
||||
(lambda ()
|
||||
(set! in-local-edit-sequence? #f)
|
||||
(super-after-edit-sequence)
|
||||
(let ([queue edit-sequence-queue]
|
||||
[ht edit-sequence-ht]
|
||||
[find-enclosing-edit
|
||||
(lambda (edit)
|
||||
(let ([admin (send edit get-admin)])
|
||||
(cond
|
||||
[(is-a? admin editor-snip-editor-admin<%>)
|
||||
(send (send (send admin get-snip) get-admin) get-editor)]
|
||||
[else #f])))])
|
||||
(set! edit-sequence-queue null)
|
||||
(set! edit-sequence-ht (make-hash-table))
|
||||
(let loop ([edit (find-enclosing-edit this)])
|
||||
[(is-a? editor-admin editor-snip-editor-admin<%>)
|
||||
(let* ([snip (send editor-admin get-snip)]
|
||||
[snip-admin (send snip get-admin)])
|
||||
(loop (send snip-admin get-editor)))]
|
||||
[(send text get-canvas) => (lambda (canvas)
|
||||
(send canvas get-top-level-window))]
|
||||
[else
|
||||
#f]))))])
|
||||
|
||||
(public [editing-this-file? (lambda () #f)])
|
||||
|
||||
(private
|
||||
[edit-sequence-queue null]
|
||||
[edit-sequence-ht (make-hash-table)])
|
||||
|
||||
(private
|
||||
[in-local-edit-sequence? #f])
|
||||
(public
|
||||
[local-edit-sequence? (lambda () in-local-edit-sequence?)]
|
||||
[run-after-edit-sequence
|
||||
(case-lambda
|
||||
[(t) (run-after-edit-sequence t #f)]
|
||||
[(t sym)
|
||||
(unless (and (procedure? t)
|
||||
(= 0 (arity t)))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected procedure of arity zero, got: ~s~n" t))
|
||||
(unless (or (symbol? sym) (not sym))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected second argument to be a symbol, got: ~s~n"
|
||||
sym))
|
||||
(if (refresh-delayed?)
|
||||
(if in-local-edit-sequence?
|
||||
(cond
|
||||
[(symbol? sym)
|
||||
(hash-table-put! edit-sequence-ht sym t)]
|
||||
[else (set! edit-sequence-queue
|
||||
(cons t edit-sequence-queue))])
|
||||
(let ([snip-admin (get-admin)])
|
||||
(cond
|
||||
[(not snip-admin)
|
||||
(t)] ;; refresh-delayed? is always #t when there is no admin.
|
||||
[(is-a? snip-admin editor-snip-editor-admin<%>)
|
||||
(send (send (send (send snip-admin get-snip) get-admin) get-editor)
|
||||
run-after-edit-sequence t sym)]
|
||||
[else
|
||||
(message-box "run-after-edit-sequence error"
|
||||
(format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
|
||||
snip-admin))
|
||||
'(t)])))
|
||||
(t))
|
||||
(void)])]
|
||||
[extend-edit-sequence-queue
|
||||
(lambda (l ht)
|
||||
(hash-table-for-each ht (lambda (k t)
|
||||
(hash-table-put!
|
||||
edit-sequence-ht
|
||||
k t)))
|
||||
(set! edit-sequence-queue (append l edit-sequence-queue)))])
|
||||
(rename
|
||||
[super-after-edit-sequence after-edit-sequence]
|
||||
[super-on-edit-sequence on-edit-sequence])
|
||||
(override
|
||||
[on-edit-sequence
|
||||
(lambda ()
|
||||
(super-on-edit-sequence)
|
||||
(set! in-local-edit-sequence? #t))]
|
||||
[after-edit-sequence
|
||||
(lambda ()
|
||||
(set! in-local-edit-sequence? #f)
|
||||
(super-after-edit-sequence)
|
||||
(let ([queue edit-sequence-queue]
|
||||
[ht edit-sequence-ht]
|
||||
[find-enclosing-edit
|
||||
(lambda (edit)
|
||||
(let ([admin (send edit get-admin)])
|
||||
(cond
|
||||
[(is-a? admin editor-snip-editor-admin<%>)
|
||||
(send (send (send admin get-snip) get-admin) get-editor)]
|
||||
[else #f])))])
|
||||
(set! edit-sequence-queue null)
|
||||
(set! edit-sequence-ht (make-hash-table))
|
||||
(let loop ([edit (find-enclosing-edit this)])
|
||||
(cond
|
||||
[(and edit (not (send edit local-edit-sequence?)))
|
||||
(loop (find-enclosing-edit edit))]
|
||||
[edit (send edit extend-edit-sequence-queue queue ht)]
|
||||
[else
|
||||
(hash-table-for-each ht (lambda (k t) (t)))
|
||||
(for-each (lambda (t) (t)) queue)]))))])
|
||||
|
||||
(override
|
||||
[on-new-box
|
||||
(lambda (type)
|
||||
(cond
|
||||
[(and edit (not (send edit local-edit-sequence?)))
|
||||
(loop (find-enclosing-edit edit))]
|
||||
[edit (send edit extend-edit-sequence-queue queue ht)]
|
||||
[else
|
||||
(hash-table-for-each ht (lambda (k t) (t)))
|
||||
(for-each (lambda (t) (t)) queue)]))))])
|
||||
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
|
||||
[else (make-object editor-snip% (make-object pasteboard:basic%))]))])
|
||||
|
||||
|
||||
(override
|
||||
[get-file (lambda (d)
|
||||
(parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-window)])
|
||||
(finder:get-file d)))]
|
||||
[put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-window)])
|
||||
(finder:put-file f d)))])
|
||||
|
||||
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
|
||||
(override
|
||||
[on-new-box
|
||||
(lambda (type)
|
||||
(cond
|
||||
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
|
||||
[else (make-object editor-snip% (make-object pasteboard:basic%))]))])
|
||||
(define -keymap<%> (interface (basic<%>) get-keymaps))
|
||||
(define keymap-mixin
|
||||
(mixin (basic<%>) (-keymap<%>) args
|
||||
(public
|
||||
[get-keymaps
|
||||
(lambda ()
|
||||
(list (keymap:get-global)))])
|
||||
(inherit set-keymap)
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(let ([keymap (make-object keymap:aug-keymap%)])
|
||||
(set-keymap keymap)
|
||||
(for-each (lambda (k) (send keymap chain-to-keymap k #f))
|
||||
(get-keymaps))))))
|
||||
|
||||
|
||||
(override
|
||||
[get-file (lambda (d)
|
||||
(parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-window)])
|
||||
(finder:get-file d)))]
|
||||
[put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-window)])
|
||||
(finder:put-file f d)))])
|
||||
(define autowrap<%> (interface (basic<%>)))
|
||||
(define autowrap-mixin
|
||||
(mixin (basic<%>) (autowrap<%>) args
|
||||
|
||||
(rename [super-on-close on-close])
|
||||
(override
|
||||
[on-close
|
||||
(lambda ()
|
||||
(remove-callback)
|
||||
(super-on-close))])
|
||||
|
||||
(inherit auto-wrap)
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(auto-wrap
|
||||
(preferences:get
|
||||
'framework:auto-set-wrap?)))
|
||||
(private
|
||||
[remove-callback
|
||||
(preferences:add-callback
|
||||
'framework:auto-set-wrap?
|
||||
(let ([autowrap-mixin-pref-callback
|
||||
(lambda (p v)
|
||||
(auto-wrap v))])
|
||||
autowrap-mixin-pref-callback))])))
|
||||
|
||||
(define file<%> (interface (-keymap<%>)))
|
||||
(define file-mixin
|
||||
(mixin (-keymap<%>) (file<%>) args
|
||||
(inherit get-filename lock get-style-list
|
||||
is-modified? change-style set-modified
|
||||
get-top-level-window)
|
||||
(rename [super-after-save-file after-save-file]
|
||||
[super-after-load-file after-load-file]
|
||||
[super-get-keymaps get-keymaps]
|
||||
[super-set-filename set-filename])
|
||||
|
||||
(override
|
||||
[editing-this-file? (lambda () #t)])
|
||||
|
||||
(inherit get-canvases)
|
||||
(private
|
||||
[check-lock
|
||||
(lambda ()
|
||||
(let* ([filename (get-filename)]
|
||||
[lock? (and filename
|
||||
(file-exists? filename)
|
||||
(not (member
|
||||
'write
|
||||
(file-or-directory-permissions
|
||||
filename))))])
|
||||
(lock lock?)))]
|
||||
[update-filename
|
||||
(lambda (name)
|
||||
(let ([filename (if name
|
||||
(mzlib:file:file-name-from-path (mzlib:file:normalize-path name))
|
||||
"")])
|
||||
(for-each (lambda (canvas)
|
||||
(let ([tlw (send canvas get-top-level-window)])
|
||||
(when (is-a? tlw frame:editor<%>)
|
||||
(send tlw set-label filename))))
|
||||
(get-canvases))))])
|
||||
(override
|
||||
[after-save-file
|
||||
(lambda (success)
|
||||
(when success
|
||||
(check-lock))
|
||||
(super-after-save-file success))]
|
||||
|
||||
[after-load-file
|
||||
(lambda (sucessful?)
|
||||
(when sucessful?
|
||||
(check-lock))
|
||||
(super-after-load-file sucessful?))]
|
||||
|
||||
[set-filename
|
||||
(case-lambda
|
||||
[(name) (set-filename name #f)]
|
||||
[(name temp?)
|
||||
(super-set-filename name temp?)
|
||||
(unless temp?
|
||||
(update-filename name))])]
|
||||
|
||||
[get-keymaps
|
||||
(lambda ()
|
||||
(cons (keymap:get-file) (super-get-keymaps)))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(define backup-autosave<%>
|
||||
(interface (basic<%>)
|
||||
backup?
|
||||
autosave?
|
||||
do-autosave
|
||||
remove-autosave))
|
||||
|
||||
|
||||
(define -keymap<%> (interface (basic<%>) get-keymaps))
|
||||
(define keymap-mixin
|
||||
(mixin (basic<%>) (-keymap<%>) args
|
||||
(public
|
||||
[get-keymaps
|
||||
(lambda ()
|
||||
(list (keymap:get-global)))])
|
||||
(inherit set-keymap)
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(let ([keymap (make-object keymap:aug-keymap%)])
|
||||
(set-keymap keymap)
|
||||
(for-each (lambda (k) (send keymap chain-to-keymap k #f))
|
||||
(get-keymaps))))))
|
||||
; what about checking the autosave files when a file is opened?
|
||||
(define backup-autosave-mixin
|
||||
(mixin (basic<%>) (backup-autosave<%>) args
|
||||
(inherit is-modified? get-filename save-file)
|
||||
(rename [super-on-save-file on-save-file]
|
||||
[super-on-change on-change]
|
||||
[super-on-close on-close]
|
||||
[super-set-modified set-modified])
|
||||
(private
|
||||
[auto-saved-name #f]
|
||||
[auto-save-out-of-date? #t]
|
||||
[auto-save-error? #f]
|
||||
[file-old?
|
||||
(lambda (filename)
|
||||
(if (and filename
|
||||
(file-exists? filename))
|
||||
(let ([modified-seconds (file-or-directory-modify-seconds filename)]
|
||||
[old-seconds (- (current-seconds) (* 7 24 60 60))])
|
||||
(< modified-seconds old-seconds))
|
||||
#t))])
|
||||
(public
|
||||
[backup? (lambda () #t)])
|
||||
(override
|
||||
[on-save-file
|
||||
(lambda (name format)
|
||||
(super-on-save-file name format)
|
||||
(set! auto-save-error? #f)
|
||||
(when (and (backup?)
|
||||
(not (eq? format 'copy))
|
||||
(file-exists? name))
|
||||
(let ([back-name (path-utils:generate-backup-name name)])
|
||||
(when (or (not (file-exists? back-name))
|
||||
(file-old? back-name))
|
||||
(when (file-exists? back-name)
|
||||
(delete-file back-name))
|
||||
(with-handlers ([(lambda (x) #t) void])
|
||||
(copy-file name back-name))))))]
|
||||
[on-close
|
||||
(lambda ()
|
||||
(super-on-close)
|
||||
(remove-autosave)
|
||||
(set! autosave? (lambda () #f)))]
|
||||
[on-change
|
||||
(lambda ()
|
||||
(super-on-change)
|
||||
(set! auto-save-out-of-date? #t))]
|
||||
[set-modified
|
||||
(lambda (modified?)
|
||||
(when auto-saved-name
|
||||
(if modified?
|
||||
(set! auto-save-out-of-date? #t)
|
||||
(remove-autosave)))
|
||||
(super-set-modified modified?))])
|
||||
(public
|
||||
[autosave? (lambda () #t)]
|
||||
[do-autosave
|
||||
(lambda ()
|
||||
(when (and (autosave?)
|
||||
(not auto-save-error?)
|
||||
(is-modified?)
|
||||
(or (not auto-saved-name)
|
||||
auto-save-out-of-date?))
|
||||
(let* ([orig-name (get-filename)]
|
||||
[old-auto-name auto-saved-name]
|
||||
[auto-name (path-utils:generate-autosave-name orig-name)]
|
||||
[success (save-file auto-name 'copy)])
|
||||
(if success
|
||||
(begin
|
||||
(when old-auto-name
|
||||
(delete-file old-auto-name))
|
||||
(set! auto-saved-name auto-name)
|
||||
(set! auto-save-out-of-date? #f))
|
||||
(begin
|
||||
(message-box
|
||||
"Warning"
|
||||
(format "Error autosaving ~s.~n~a~n~a"
|
||||
(or orig-name "Untitled")
|
||||
"Autosaving is turned off"
|
||||
"until the file is saved."))
|
||||
(set! auto-save-error? #t))))))]
|
||||
[remove-autosave
|
||||
(lambda ()
|
||||
(when auto-saved-name
|
||||
(when (file-exists? auto-saved-name)
|
||||
(delete-file auto-saved-name))
|
||||
(set! auto-saved-name #f)))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(autosave:register this))))
|
||||
|
||||
(define autowrap<%> (interface (basic<%>)))
|
||||
(define autowrap-mixin
|
||||
(mixin (basic<%>) (autowrap<%>) args
|
||||
|
||||
(rename [super-on-close on-close])
|
||||
(override
|
||||
[on-close
|
||||
(lambda ()
|
||||
(remove-callback)
|
||||
(super-on-close))])
|
||||
|
||||
(inherit auto-wrap)
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(auto-wrap
|
||||
(preferences:get
|
||||
'framework:auto-set-wrap?)))
|
||||
(private
|
||||
[remove-callback
|
||||
(preferences:add-callback
|
||||
'framework:auto-set-wrap?
|
||||
(let ([autowrap-mixin-pref-callback
|
||||
(lambda (p v)
|
||||
(auto-wrap v))])
|
||||
autowrap-mixin-pref-callback))])))
|
||||
|
||||
(define file<%> (interface (-keymap<%>)))
|
||||
(define file-mixin
|
||||
(mixin (-keymap<%>) (file<%>) args
|
||||
(inherit get-filename lock get-style-list
|
||||
is-modified? change-style set-modified
|
||||
get-top-level-window)
|
||||
(rename [super-after-save-file after-save-file]
|
||||
[super-after-load-file after-load-file]
|
||||
[super-get-keymaps get-keymaps]
|
||||
[super-set-filename set-filename])
|
||||
|
||||
(override
|
||||
[editing-this-file? (lambda () #t)])
|
||||
|
||||
(inherit get-canvases)
|
||||
(private
|
||||
[check-lock
|
||||
(lambda ()
|
||||
(let* ([filename (get-filename)]
|
||||
[lock? (and filename
|
||||
(file-exists? filename)
|
||||
(not (member
|
||||
'write
|
||||
(file-or-directory-permissions
|
||||
filename))))])
|
||||
(lock lock?)))]
|
||||
[update-filename
|
||||
(lambda (name)
|
||||
(let ([filename (if name
|
||||
(mzlib:file:file-name-from-path (mzlib:file:normalize-path name))
|
||||
"")])
|
||||
(for-each (lambda (canvas)
|
||||
(let ([tlw (send canvas get-top-level-window)])
|
||||
(when (is-a? tlw frame:editor<%>)
|
||||
(send tlw set-label filename))))
|
||||
(get-canvases))))])
|
||||
(override
|
||||
[after-save-file
|
||||
(lambda (success)
|
||||
(when success
|
||||
(check-lock))
|
||||
(super-after-save-file success))]
|
||||
|
||||
[after-load-file
|
||||
(lambda (sucessful?)
|
||||
(when sucessful?
|
||||
(check-lock))
|
||||
(super-after-load-file sucessful?))]
|
||||
|
||||
[set-filename
|
||||
(case-lambda
|
||||
[(name) (set-filename name #f)]
|
||||
[(name temp?)
|
||||
(super-set-filename name temp?)
|
||||
(unless temp?
|
||||
(update-filename name))])]
|
||||
|
||||
[get-keymaps
|
||||
(lambda ()
|
||||
(cons (keymap:get-file) (super-get-keymaps)))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define backup-autosave<%>
|
||||
(interface (basic<%>)
|
||||
backup?
|
||||
autosave?
|
||||
do-autosave
|
||||
remove-autosave))
|
||||
|
||||
; what about checking the autosave files when a file is opened?
|
||||
(define backup-autosave-mixin
|
||||
(mixin (basic<%>) (backup-autosave<%>) args
|
||||
(inherit is-modified? get-filename save-file)
|
||||
(rename [super-on-save-file on-save-file]
|
||||
[super-on-change on-change]
|
||||
[super-on-close on-close]
|
||||
[super-set-modified set-modified])
|
||||
(private
|
||||
[auto-saved-name #f]
|
||||
[auto-save-out-of-date? #t]
|
||||
[auto-save-error? #f]
|
||||
[file-old?
|
||||
(lambda (filename)
|
||||
(if (and filename
|
||||
(file-exists? filename))
|
||||
(let ([modified-seconds (file-or-directory-modify-seconds filename)]
|
||||
[old-seconds (- (current-seconds) (* 7 24 60 60))])
|
||||
(< modified-seconds old-seconds))
|
||||
#t))])
|
||||
(public
|
||||
[backup? (lambda () #t)])
|
||||
(override
|
||||
[on-save-file
|
||||
(lambda (name format)
|
||||
(super-on-save-file name format)
|
||||
(set! auto-save-error? #f)
|
||||
(when (and (backup?)
|
||||
(not (eq? format 'copy))
|
||||
(file-exists? name))
|
||||
(let ([back-name (path-utils:generate-backup-name name)])
|
||||
(when (or (not (file-exists? back-name))
|
||||
(file-old? back-name))
|
||||
(when (file-exists? back-name)
|
||||
(delete-file back-name))
|
||||
(with-handlers ([(lambda (x) #t) void])
|
||||
(copy-file name back-name))))))]
|
||||
[on-close
|
||||
(lambda ()
|
||||
(super-on-close)
|
||||
(remove-autosave)
|
||||
(set! autosave? (lambda () #f)))]
|
||||
[on-change
|
||||
(lambda ()
|
||||
(super-on-change)
|
||||
(set! auto-save-out-of-date? #t))]
|
||||
[set-modified
|
||||
(lambda (modified?)
|
||||
(when auto-saved-name
|
||||
(if modified?
|
||||
(set! auto-save-out-of-date? #t)
|
||||
(remove-autosave)))
|
||||
(super-set-modified modified?))])
|
||||
(public
|
||||
[autosave? (lambda () #t)]
|
||||
[do-autosave
|
||||
(lambda ()
|
||||
(when (and (autosave?)
|
||||
(not auto-save-error?)
|
||||
(is-modified?)
|
||||
(or (not auto-saved-name)
|
||||
auto-save-out-of-date?))
|
||||
(let* ([orig-name (get-filename)]
|
||||
[old-auto-name auto-saved-name]
|
||||
[auto-name (path-utils:generate-autosave-name orig-name)]
|
||||
[success (save-file auto-name 'copy)])
|
||||
(if success
|
||||
(begin
|
||||
(when old-auto-name
|
||||
(delete-file old-auto-name))
|
||||
(set! auto-saved-name auto-name)
|
||||
(set! auto-save-out-of-date? #f))
|
||||
(begin
|
||||
(message-box
|
||||
"Warning"
|
||||
(format "Error autosaving ~s.~n~a~n~a"
|
||||
(or orig-name "Untitled")
|
||||
"Autosaving is turned off"
|
||||
"until the file is saved."))
|
||||
(set! auto-save-error? #t))))))]
|
||||
[remove-autosave
|
||||
(lambda ()
|
||||
(when auto-saved-name
|
||||
(when (file-exists? auto-saved-name)
|
||||
(delete-file auto-saved-name))
|
||||
(set! auto-saved-name #f)))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(autosave:register this))))
|
||||
|
||||
(define info<%> (interface (basic<%>)))
|
||||
(define info-mixin
|
||||
(mixin (basic<%>) (info<%>) args
|
||||
(inherit get-top-level-window run-after-edit-sequence)
|
||||
(rename [super-lock lock])
|
||||
(override
|
||||
[lock
|
||||
(lambda (x)
|
||||
(super-lock x)
|
||||
(run-after-edit-sequence
|
||||
(rec send-frame-update-lock-icon
|
||||
(lambda ()
|
||||
(let ([frame (get-top-level-window)])
|
||||
(when (is-a? frame frame:info<%>)
|
||||
(send frame lock-status-changed)))))
|
||||
'framework:update-lock-icon))])
|
||||
(sequence (apply super-init args)))))
|
||||
(define info<%> (interface (basic<%>)))
|
||||
(define info-mixin
|
||||
(mixin (basic<%>) (info<%>) args
|
||||
(inherit get-top-level-window run-after-edit-sequence)
|
||||
(rename [super-lock lock])
|
||||
(override
|
||||
[lock
|
||||
(lambda (x)
|
||||
(super-lock x)
|
||||
(run-after-edit-sequence
|
||||
(rec send-frame-update-lock-icon
|
||||
(lambda ()
|
||||
(let ([frame (get-top-level-window)])
|
||||
(when (is-a? frame frame:info<%>)
|
||||
(send frame lock-status-changed)))))
|
||||
'framework:update-lock-icon))])
|
||||
(sequence (apply super-init args)))))))
|
||||
|
|
|
|||
|
|
@ -1,62 +1,68 @@
|
|||
(unit/sig framework:exit^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^]
|
||||
[gui-utils : framework:gui-utils^])
|
||||
(rename (-exit exit))
|
||||
|
||||
(define frame-exiting (make-parameter #f))
|
||||
(module exit mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "file.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(define can?-callbacks '())
|
||||
(define on-callbacks '())
|
||||
|
||||
(define insert-can?-callback
|
||||
(lambda (cb)
|
||||
(set! can?-callbacks (cons cb can?-callbacks))
|
||||
(lambda ()
|
||||
(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 exit@
|
||||
(unit/sig framework:exit^
|
||||
(import [preferences : framework:preferences^]
|
||||
[gui-utils : framework:gui-utils^])
|
||||
(rename (-exit exit))
|
||||
|
||||
(define frame-exiting (make-parameter #f))
|
||||
|
||||
(define insert-on-callback
|
||||
(lambda (cb)
|
||||
(set! on-callbacks (cons cb on-callbacks))
|
||||
(lambda ()
|
||||
(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 exiting? #f)
|
||||
(define can?-callbacks '())
|
||||
(define on-callbacks '())
|
||||
|
||||
(define insert-can?-callback
|
||||
(lambda (cb)
|
||||
(set! can?-callbacks (cons cb can?-callbacks))
|
||||
(lambda ()
|
||||
(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 (can-exit?) (and (user-oks-exit)
|
||||
(andmap (lambda (cb) (cb)) can?-callbacks)))
|
||||
(define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks))
|
||||
(define insert-on-callback
|
||||
(lambda (cb)
|
||||
(set! on-callbacks (cons cb on-callbacks))
|
||||
(lambda ()
|
||||
(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 exiting? #f)
|
||||
|
||||
(define (user-oks-exit)
|
||||
(if (preferences:get 'framework:verify-exit)
|
||||
(let*-values ([(w capw)
|
||||
(if (eq? (system-type) 'windows)
|
||||
(values "exit" "Exit")
|
||||
(values "quit" "Quit"))]
|
||||
[(message)
|
||||
(string-append "Are you sure you want to "
|
||||
w
|
||||
"?")]
|
||||
[(user-says) (gui-utils:get-choice message capw "Cancel" "Warning" #f
|
||||
(frame-exiting))])
|
||||
user-says)
|
||||
#t))
|
||||
(define (can-exit?) (and (user-oks-exit)
|
||||
(andmap (lambda (cb) (cb)) can?-callbacks)))
|
||||
(define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks))
|
||||
|
||||
(define -exit
|
||||
(opt-lambda ()
|
||||
(unless exiting?
|
||||
(set! exiting? #t)
|
||||
(when (can-exit?)
|
||||
(on-exit)
|
||||
(queue-callback (lambda () (exit))))
|
||||
(set! exiting? #f)))))
|
||||
(define (user-oks-exit)
|
||||
(if (preferences:get 'framework:verify-exit)
|
||||
(let*-values ([(w capw)
|
||||
(if (eq? (system-type) 'windows)
|
||||
(values "exit" "Exit")
|
||||
(values "quit" "Quit"))]
|
||||
[(message)
|
||||
(string-append "Are you sure you want to "
|
||||
w
|
||||
"?")]
|
||||
[(user-says) (gui-utils:get-choice message capw "Cancel" "Warning" #f
|
||||
(frame-exiting))])
|
||||
user-says)
|
||||
#t))
|
||||
|
||||
(define -exit
|
||||
(opt-lambda ()
|
||||
(unless exiting?
|
||||
(set! exiting? #t)
|
||||
(when (can-exit?)
|
||||
(on-exit)
|
||||
(queue-callback (lambda () (exit))))
|
||||
(set! exiting? #f)))))))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,4 +1,5 @@
|
|||
|
||||
(module frame mzscheme
|
||||
(require (lib
|
||||
(unit/sig framework:frame^
|
||||
(import mred^
|
||||
[group : framework:group^]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user