diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 939a0972..f641a17f 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -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@)) diff --git a/collects/framework/private/application.ss b/collects/framework/private/application.ss index b9a30ccd..b4de56c6 100644 --- a/collects/framework/private/application.ss +++ b/collects/framework/private/application.ss @@ -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)))) \ No newline at end of file + (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)))))) \ No newline at end of file diff --git a/collects/framework/private/autosave.ss b/collects/framework/private/autosave.ss index fafa5012..4c916529 100644 --- a/collects/framework/private/autosave.ss +++ b/collects/framework/private/autosave.ss @@ -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))))])))))))) diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss index ffbbda47..8776b9a3 100644 --- a/collects/framework/private/canvas.ss +++ b/collects/framework/private/canvas.ss @@ -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%))))) diff --git a/collects/framework/private/color-model.ss b/collects/framework/private/color-model.ss index 4fbc932d..3a83cfa1 100644 --- a/collects/framework/private/color-model.ss +++ b/collects/framework/private/color-model.ss @@ -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)) -) \ No newline at end of file + ;;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)) + ))) \ No newline at end of file diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 5ff22249..5bb060d8 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -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))))))) diff --git a/collects/framework/private/exit.ss b/collects/framework/private/exit.ss index 729b48bf..486ec0e1 100644 --- a/collects/framework/private/exit.ss +++ b/collects/framework/private/exit.ss @@ -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))))) \ No newline at end of file + (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))))))) \ No newline at end of file diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss index 3d4d7c54..173e1069 100644 --- a/collects/framework/private/finder.ss +++ b/collects/framework/private/finder.ss @@ -1,69 +1,69 @@ -;;; finder.ss +(module finder mzscheme + (require (lib "unitsig.ss") + "../sig.ss" + (lib "string.ss") + (lib "function.ss") + (lib "file.ss")) -;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler + (define finder@ + (unit/sig framework:finder^ + (import [preferences : framework:preferences^] + [gui-utils : framework:gui-utils^] + [keymap : framework:keymap^]) -(unit/sig framework:finder^ - (import mred^ - [preferences : framework:preferences^] - [gui-utils : framework:gui-utils^] - [keymap : framework:keymap^] - [mzlib:string : mzlib:string^] - [mzlib:function : mzlib:function^] - [mzlib:file : mzlib:file^]) + (rename [-put-file put-file] + [-get-file get-file]) + + (define dialog-parent-parameter (make-parameter #f)) - (rename [-put-file put-file] - [-get-file get-file]) - - (define dialog-parent-parameter (make-parameter #f)) + (define filter-match? + (lambda (filter name msg) + (let-values ([(base name dir?) (split-path name)]) + (if (mzlib:string:regexp-match-exact? filter name) + #t + (begin + (message-box "Error" msg) + #f))))) + + (define last-directory #f) + + (define make-relative + (lambda (s) s)) + + (define current-find-file-directory + (opt-lambda ([dir 'get]) + (cond + [(eq? dir 'get) + (if (not last-directory) + (set! last-directory (current-directory))) + last-directory] + [(and (string? dir) + (directory-exists? dir)) + (set! last-directory dir) + #t] + [else #f]))) + + (define build-updir + (lambda (dir) + (let-values ([(base _1 _2) (split-path dir)]) + (or base dir)))) - (define filter-match? - (lambda (filter name msg) - (let-values ([(base name dir?) (split-path name)]) - (if (mzlib:string:regexp-match-exact? filter name) - #t - (begin - (message-box "Error" msg) - #f))))) - - (define last-directory #f) - - (define make-relative - (lambda (s) s)) - - (define current-find-file-directory - (opt-lambda ([dir 'get]) - (cond - [(eq? dir 'get) - (if (not last-directory) - (set! last-directory (current-directory))) - last-directory] - [(and (string? dir) - (directory-exists? dir)) - (set! last-directory dir) - #t] - [else #f]))) - - (define build-updir - (lambda (dir) - (let-values ([(base _1 _2) (split-path dir)]) - (or base dir)))) - - (define default-extension - (let ([val #f]) - (case-lambda - [() val] - [(x) - (unless (or (string? x) - (not x)) - (error 'finder:default-extension - "expected a string or #f, got: ~e" - x)) - (set! val x)]))) - - ; the finder-dialog% class controls the user interface for dialogs - - (define finder-dialog% - (class dialog% (parent-win + (define default-extension + (let ([val #f]) + (case-lambda + [() val] + [(x) + (unless (or (string? x) + (not x)) + (error 'finder:default-extension + "expected a string or #f, got: ~e" + x)) + (set! val x)]))) + + ; the finder-dialog% class controls the user interface for dialogs + + (define finder-dialog% + (class dialog% (parent-win save-mode? replace-ok? multi-mode? @@ -73,698 +73,698 @@ prompt file-filter file-filter-msg) - - (inherit center show) - - (private - [default-width 500] - [default-height 400] - dirs - current-dir - last-selected) - - (private - - [set-directory ; sets directory in listbox - - (lambda (dir) ; dir is normalized - (when (directory-exists? dir) - (gui-utils:show-busy-cursor - (lambda () - (set! current-dir dir) - (set! last-directory dir) - (let-values - ([(dir-list menu-list) - (let loop ([this-dir dir] - [dir-list null] - [menu-list null]) - (let-values ([(base-dir in-dir dir?) - (split-path this-dir)]) - (if (eq? (system-type) 'windows) - (mzlib:string:string-lowercase! in-dir)) - (let* ([dir-list (cons this-dir dir-list)] - [menu-list (cons in-dir menu-list)]) - (if base-dir - (loop base-dir dir-list menu-list) - ; No more - (values dir-list menu-list)))))]) - (set! dirs (reverse dir-list)) - (send dir-choice clear) - (let loop ([choices (reverse menu-list)]) - (unless (null? choices) - (send dir-choice append (car choices)) - (loop (cdr choices)))) - (send dir-choice set-selection 0)) - - (send name-list clear) - (send name-list set - (mzlib:function:quicksort - (let ([no-periods? - (not (preferences:get - 'framework:show-periods-in-dirlist))]) - (let loop ([l (directory-list dir)]) - (if (null? l) - null - (let ([s (car l)] - [rest (loop (cdr l))]) - (cond - [(and no-periods? - (<= 1 (string-length s)) - (char=? (string-ref s 0) #\.)) - rest] - [(directory-exists? (build-path dir s)) - (cons s rest)] - [(or (not file-filter) - (mzlib:string:regexp-match-exact? - file-filter s)) - (cons s rest)] - [else rest]))))) - ;(if (eq? (system-type) 'unix) string (send name-list get-number) 0)]) - - (cond - - [(and save-mode? - non-empty? - (not (string? name))) 'nothing-selected] - - [(and save-mode? - non-empty? - (string=? name "")) - (let ([file (send directory-field get-value)]) - (if (directory-exists? file) - (set-directory (normal-case-path (mzlib:file:normalize-path file))) - (message-box - "Error" - "You must specify a file name")))] - - [(and save-mode? - non-empty? - file-filter - (not (mzlib:string:regexp-match-exact? file-filter name))) - (message-box "Error" file-filter-msg)] - - [else - - ; if dir in edit box, go to that dir - - (let ([dir-name (send directory-field get-value)]) - - (if (directory-exists? dir-name) - (set-directory (normal-case-path (mzlib:file:normalize-path dir-name))) - - ; otherwise, try to return absolute path - - (let* ([relative-name (make-relative name)] - [file-in-edit (file-exists? dir-name)] - [file (if (or file-in-edit - (not relative-name) - save-mode?) - dir-name - (build-path current-dir relative-name))]) - - ; trying to open a file that doesn't exist - - (if (and (not save-mode?) (not file-in-edit)) - (message-box - "Error" - (string-append "The file \"" - dir-name - "\" does not exist.")) - - ; saving a file, which may exist, or - ; opening an existing file - - (if (or (not save-mode?) - (not (file-exists? file)) - replace-ok? - (eq? (message-box "Warning" - (string-append - "The file " - file - " already exists. " - "Replace it?") - #f - '(yes-no)) - 'yes)) - (let ([normal-path - (with-handlers - ([(lambda (_) #t) - (lambda (_) - (message-box - "Warning" - (string-append - "The file " - file - " contains nonexistent directory or cycle.")) - #f)]) - (normal-case-path - (mzlib:file:normalize-path file)))]) - (when normal-path - (set-box! result-box normal-path) - (show #f))))))))]))))] - - [add-one - (lambda (name) - (unless (or (directory-exists? name) - (send result-list find-string name)) - (send result-list append - (normal-case-path (mzlib:file:normalize-path name)))))] - - [do-add - (lambda args - (let ([name (send name-list get-string-selection)]) - (if (string? name) - (let ([name (build-path current-dir - (make-relative name))]) - (add-one name)))))] - - [do-add-all - (lambda args - (let loop ([n 0]) - (when (< n (send name-list get-number)) - (let ([name (send name-list get-string n)]) - (let ([name (build-path current-dir - (make-relative name))]) - (add-one name) - (loop (add1 n)))))))] - - [do-remove - (lambda args - (let loop ([n 0]) - (if (< n (send result-list get-number)) - (if (send result-list is-selected? n) - (begin - (send result-list delete n) - (loop n)) - (loop (add1 n))))))] - - [do-cancel - (lambda args - (set-box! result-box #f) - (show #f))]) - - (override - [on-close (lambda () #f)]) - - (sequence - (super-init (if save-mode? "Put file" "Get file") - parent-win - default-width - default-height - #f #f - '(resize-border))) - - (private - - [main-panel (make-object vertical-panel% this)] - - [top-panel (make-object horizontal-panel% main-panel)] - - [_1 (make-object message% prompt top-panel)] - - [dir-choice (make-object choice% #f null top-panel do-dir)] - - [middle-panel (make-object horizontal-panel% main-panel)] - [left-middle-panel (make-object vertical-panel% middle-panel)] - [right-middle-panel (when multi-mode? - (make-object vertical-panel% middle-panel))] - - [name-list% - - (class-asi list-box% - - (inherit - get-string-selection - get-string - get-selection - get-number - get-first-visible-item - number-of-visible-items - set-first-visible-item - set-selection) - - (override - [on-subwindow-char + + (inherit center show) + + (private + [default-width 500] + [default-height 400] + dirs + current-dir + last-selected) + + (private + + [set-directory ; sets directory in listbox - (lambda (_ key) - (let ([code (send key get-key-code)] - [num-items (get-number)] - [curr-pos (get-selection)]) - (cond - [(or (equal? code 'numpad-return) - (equal? code #\return)) - (if multi-mode? - (do-add) - (do-ok))] - - ; look for letter at beginning of a filename - [(char? code) - (let ([next-matching - (let loop ([pos (add1 curr-pos)]) - (cond - [(>= pos num-items) #f] - [else - (let ([first-char (string-ref (get-string pos) 0)]) - (if (char-ci=? code first-char) - pos - (loop (add1 pos))))]))]) - (if next-matching - (set-selection-and-edit next-matching) + (lambda (dir) ; dir is normalized + (when (directory-exists? dir) + (gui-utils:show-busy-cursor + (lambda () + (set! current-dir dir) + (set! last-directory dir) + (let-values + ([(dir-list menu-list) + (let loop ([this-dir dir] + [dir-list null] + [menu-list null]) + (let-values ([(base-dir in-dir dir?) + (split-path this-dir)]) + (if (eq? (system-type) 'windows) + (mzlib:string:string-lowercase! in-dir)) + (let* ([dir-list (cons this-dir dir-list)] + [menu-list (cons in-dir menu-list)]) + (if base-dir + (loop base-dir dir-list menu-list) + ; No more + (values dir-list menu-list)))))]) + (set! dirs (reverse dir-list)) + (send dir-choice clear) + (let loop ([choices (reverse menu-list)]) + (unless (null? choices) + (send dir-choice append (car choices)) + (loop (cdr choices)))) + (send dir-choice set-selection 0)) + + (send name-list clear) + (send name-list set + (mzlib:function:quicksort + (let ([no-periods? + (not (preferences:get + 'framework:show-periods-in-dirlist))]) + (let loop ([l (directory-list dir)]) + (if (null? l) + null + (let ([s (car l)] + [rest (loop (cdr l))]) + (cond + [(and no-periods? + (<= 1 (string-length s)) + (char=? (string-ref s 0) #\.)) + rest] + [(directory-exists? (build-path dir s)) + (cons s rest)] + [(or (not file-filter) + (mzlib:string:regexp-match-exact? + file-filter s)) + (cons s rest)] + [else rest]))))) + ;(if (eq? (system-type) 'unix) string (send name-list get-number) 0)]) + + (cond + + [(and save-mode? + non-empty? + (not (string? name))) 'nothing-selected] + + [(and save-mode? + non-empty? + (string=? name "")) + (let ([file (send directory-field get-value)]) + (if (directory-exists? file) + (set-directory (normal-case-path (mzlib:file:normalize-path file))) + (message-box + "Error" + "You must specify a file name")))] + + [(and save-mode? + non-empty? + file-filter + (not (mzlib:string:regexp-match-exact? file-filter name))) + (message-box "Error" file-filter-msg)] + + [else + + ; if dir in edit box, go to that dir + + (let ([dir-name (send directory-field get-value)]) + + (if (directory-exists? dir-name) + (set-directory (normal-case-path (mzlib:file:normalize-path dir-name))) + + ; otherwise, try to return absolute path + + (let* ([relative-name (make-relative name)] + [file-in-edit (file-exists? dir-name)] + [file (if (or file-in-edit + (not relative-name) + save-mode?) + dir-name + (build-path current-dir relative-name))]) + + ; trying to open a file that doesn't exist + + (if (and (not save-mode?) (not file-in-edit)) + (message-box + "Error" + (string-append "The file \"" + dir-name + "\" does not exist.")) + + ; saving a file, which may exist, or + ; opening an existing file + + (if (or (not save-mode?) + (not (file-exists? file)) + replace-ok? + (eq? (message-box "Warning" + (string-append + "The file " + file + " already exists. " + "Replace it?") + #f + '(yes-no)) + 'yes)) + (let ([normal-path + (with-handlers + ([(lambda (_) #t) + (lambda (_) + (message-box + "Warning" + (string-append + "The file " + file + " contains nonexistent directory or cycle.")) + #f)]) + (normal-case-path + (mzlib:file:normalize-path file)))]) + (when normal-path + (set-box! result-box normal-path) + (show #f))))))))]))))] + + [add-one + (lambda (name) + (unless (or (directory-exists? name) + (send result-list find-string name)) + (send result-list append + (normal-case-path (mzlib:file:normalize-path name)))))] + + [do-add + (lambda args + (let ([name (send name-list get-string-selection)]) + (if (string? name) + (let ([name (build-path current-dir + (make-relative name))]) + (add-one name)))))] + + [do-add-all + (lambda args + (let loop ([n 0]) + (when (< n (send name-list get-number)) + (let ([name (send name-list get-string n)]) + (let ([name (build-path current-dir + (make-relative name))]) + (add-one name) + (loop (add1 n)))))))] + + [do-remove + (lambda args + (let loop ([n 0]) + (if (< n (send result-list get-number)) + (if (send result-list is-selected? n) + (begin + (send result-list delete n) + (loop n)) + (loop (add1 n))))))] + + [do-cancel + (lambda args + (set-box! result-box #f) + (show #f))]) + + (override + [on-close (lambda () #f)]) + + (sequence + (super-init (if save-mode? "Put file" "Get file") + parent-win + default-width + default-height + #f #f + '(resize-border))) + + (private + + [main-panel (make-object vertical-panel% this)] + + [top-panel (make-object horizontal-panel% main-panel)] + + [_1 (make-object message% prompt top-panel)] + + [dir-choice (make-object choice% #f null top-panel do-dir)] + + [middle-panel (make-object horizontal-panel% main-panel)] + [left-middle-panel (make-object vertical-panel% middle-panel)] + [right-middle-panel (when multi-mode? + (make-object vertical-panel% middle-panel))] + + [name-list% + + (class-asi list-box% + + (inherit + get-string-selection + get-string + get-selection + get-number + get-first-visible-item + number-of-visible-items + set-first-visible-item + set-selection) + + (override + [on-subwindow-char + + (lambda (_ key) + (let ([code (send key get-key-code)] + [num-items (get-number)] + [curr-pos (get-selection)]) + (cond + [(or (equal? code 'numpad-return) + (equal? code #\return)) + (if multi-mode? + (do-add) + (do-ok))] + + ; look for letter at beginning of a filename + [(char? code) + (let ([next-matching + (let loop ([pos (add1 curr-pos)]) + (cond + [(>= pos num-items) #f] + [else + (let ([first-char (string-ref (get-string pos) 0)]) + (if (char-ci=? code first-char) + pos + (loop (add1 pos))))]))]) + (if next-matching + (set-selection-and-edit next-matching) + + ;; didn't find anything forward; start again at front of list + (let loop ([pos 0] + [last-before 0]) (cond - [(char-ci=? code first-char) - (set-selection-and-edit pos)] - [(char-ci<=? first-char code) - (loop (+ pos 1) - pos)] - [else - (set-selection-and-edit last-before)]))] - [else (set-selection-and-edit last-before)]))))] - - ; movement keys - [(and (eq? code 'up) - (> curr-pos 0)) - (set-selection-and-edit (sub1 curr-pos))] - - [(and (eq? code 'down) - (< curr-pos (sub1 num-items))) - (let* ([num-vis (number-of-visible-items)] - [curr-first (get-first-visible-item)] - [new-curr-pos (add1 curr-pos)] - [new-first (if (< new-curr-pos (+ curr-first num-vis)) - curr-first ; no scroll needed - (add1 curr-first))]) - (set-first-visible-item new-first) - (set-selection-and-edit new-curr-pos))] - - [(and (eq? code 'prior) - (> curr-pos 0)) - (let* ([num-vis (number-of-visible-items)] - [new-first (- (get-first-visible-item) num-vis)]) - (set-first-visible-item (max new-first 0)) - (set-selection-and-edit (max 0 (- curr-pos num-vis))))] - - [(and (eq? code 'next) - (< curr-pos (sub1 num-items))) - (let* ([num-vis (number-of-visible-items)] - [new-first (+ (get-first-visible-item) num-vis)]) - (set-first-visible-item - (min new-first (- (get-number) num-vis))) - (set-selection-and-edit - (min (sub1 num-items) (+ curr-pos num-vis))))] - - [else #f])))]) - - (public - [set-selection-and-edit - (lambda (pos) - (when (> (get-number) 0) - (let* ([first-item (get-first-visible-item)] - [last-item (sub1 (+ (number-of-visible-items) - first-item))]) - (if (or (< pos first-item) (> pos last-item)) - (set-first-visible-item pos)) - (set-selection pos))) - (set-edit))] - [on-default-action + [(<= pos num-items) + (let ([first-char (string-ref (get-string pos) 0)]) + (cond + [(char-ci=? code first-char) + (set-selection-and-edit pos)] + [(char-ci<=? first-char code) + (loop (+ pos 1) + pos)] + [else + (set-selection-and-edit last-before)]))] + [else (set-selection-and-edit last-before)]))))] + + ; movement keys + [(and (eq? code 'up) + (> curr-pos 0)) + (set-selection-and-edit (sub1 curr-pos))] + + [(and (eq? code 'down) + (< curr-pos (sub1 num-items))) + (let* ([num-vis (number-of-visible-items)] + [curr-first (get-first-visible-item)] + [new-curr-pos (add1 curr-pos)] + [new-first (if (< new-curr-pos (+ curr-first num-vis)) + curr-first ; no scroll needed + (add1 curr-first))]) + (set-first-visible-item new-first) + (set-selection-and-edit new-curr-pos))] + + [(and (eq? code 'prior) + (> curr-pos 0)) + (let* ([num-vis (number-of-visible-items)] + [new-first (- (get-first-visible-item) num-vis)]) + (set-first-visible-item (max new-first 0)) + (set-selection-and-edit (max 0 (- curr-pos num-vis))))] + + [(and (eq? code 'next) + (< curr-pos (sub1 num-items))) + (let* ([num-vis (number-of-visible-items)] + [new-first (+ (get-first-visible-item) num-vis)]) + (set-first-visible-item + (min new-first (- (get-number) num-vis))) + (set-selection-and-edit + (min (sub1 num-items) (+ curr-pos num-vis))))] + + [else #f])))]) + + (public + [set-selection-and-edit + (lambda (pos) + (when (> (get-number) 0) + (let* ([first-item (get-first-visible-item)] + [last-item (sub1 (+ (number-of-visible-items) + first-item))]) + (if (or (< pos first-item) (> pos last-item)) + (set-first-visible-item pos)) + (set-selection pos))) + (set-edit))] + [on-default-action + (lambda () + (when (> (get-number) 0) + (let* ([which (get-string-selection)] + [dir (build-path current-dir + (make-relative which))]) + (if (directory-exists? dir) + (set-directory (normal-case-path + (mzlib:file:normalize-path dir))) + (if multi-mode? + (do-add) + (do-ok))))))]))] + + [name-list (make-object name-list% + #f null left-middle-panel do-name-list + '(single))] + + [set-focus-to-name-list + (lambda () + (send name-list focus))] + + [save-panel (when save-mode? (make-object horizontal-panel% main-panel))] + + [directory-panel (make-object horizontal-panel% main-panel)] + + [dot-panel (when (eq? 'unix (system-type)) + (make-object horizontal-panel% main-panel))] + + [bottom-panel (make-object horizontal-panel% main-panel)] + + [directory-field + (keymap:call/text-keymap-initializer (lambda () - (when (> (get-number) 0) - (let* ([which (get-string-selection)] - [dir (build-path current-dir - (make-relative which))]) - (if (directory-exists? dir) - (set-directory (normal-case-path - (mzlib:file:normalize-path dir))) - (if multi-mode? - (do-add) - (do-ok))))))]))] - - [name-list (make-object name-list% - #f null left-middle-panel do-name-list - '(single))] - - [set-focus-to-name-list - (lambda () - (send name-list focus))] - - [save-panel (when save-mode? (make-object horizontal-panel% main-panel))] - - [directory-panel (make-object horizontal-panel% main-panel)] - - [dot-panel (when (eq? 'unix (system-type)) - (make-object horizontal-panel% main-panel))] - - [bottom-panel (make-object horizontal-panel% main-panel)] - - [directory-field - (keymap:call/text-keymap-initializer - (lambda () - (make-object text-field% - "Full pathname" - directory-panel - (lambda (txt evt) - (when (eq? (send evt get-event-type) 'text-field-enter) - (let ([dir (send directory-field get-value)]) - (if (directory-exists? dir) - (set-directory (normal-case-path - (mzlib:file:normalize-path dir))) - (if multi-mode? - (do-add) - (do-ok)))))))))] + (make-object text-field% + "Full pathname" + directory-panel + (lambda (txt evt) + (when (eq? (send evt get-event-type) 'text-field-enter) + (let ([dir (send directory-field get-value)]) + (if (directory-exists? dir) + (set-directory (normal-case-path + (mzlib:file:normalize-path dir))) + (if multi-mode? + (do-add) + (do-ok)))))))))] - [result-list - (when multi-mode? - (make-object list-box% - #f - null - right-middle-panel - do-result-list - '(multiple)))] - [add-panel - (when multi-mode? - (make-object horizontal-panel% left-middle-panel))] - - [remove-panel - (when multi-mode? - (make-object horizontal-panel% right-middle-panel))] - - [do-updir - (lambda () - (set-directory (build-updir current-dir)) - (set-focus-to-name-list))]) + [result-list + (when multi-mode? + (make-object list-box% + #f + null + right-middle-panel + do-result-list + '(multiple)))] + [add-panel + (when multi-mode? + (make-object horizontal-panel% left-middle-panel))] + + [remove-panel + (when multi-mode? + (make-object horizontal-panel% right-middle-panel))] + + [do-updir + (lambda () + (set-directory (build-updir current-dir)) + (set-focus-to-name-list))]) + + (sequence + + (when (eq? (system-type) 'unix) + (let ([dot-cb + (make-object check-box% + "Show files and directories that begin with a dot" + dot-panel + do-period-in/exclusion)]) + (send dot-panel stretchable-height #f) + (send dot-cb set-value + (preferences:get 'framework:show-periods-in-dirlist)))) + + (send directory-panel stretchable-height #f) + + (when multi-mode? + (send add-panel stretchable-height #f) + (send remove-panel stretchable-height #f) + (send result-list stretchable-width #t)) + + (make-object button% + "Up directory" + top-panel + (lambda (button evt) (do-updir))) + + (send dir-choice stretchable-width #t) + (send name-list stretchable-width #t) + (send top-panel stretchable-height #f) + (send bottom-panel stretchable-height #f) + + (when save-mode? + (send save-panel stretchable-height #f))) + + (private + + [add-button (when multi-mode? + (make-object horizontal-panel% add-panel) + (make-object button% + "Add" + add-panel + do-add))] + [add-all-button (when multi-mode? + (begin0 + (make-object button% + "Add all" + add-panel do-add-all) + (make-object horizontal-panel% add-panel)))] + [remove-button (when multi-mode? + (make-object horizontal-panel% remove-panel) + (begin0 + (make-object button% "Remove" remove-panel do-remove) + (make-object horizontal-panel% remove-panel)))]) + (sequence + (make-object vertical-panel% bottom-panel)) + (private + [ok-button + (make-object button% "OK" bottom-panel do-ok (if multi-mode? '() '(border)))] + [cancel-button (make-object button% "Cancel" bottom-panel do-cancel)]) + (sequence + (make-object grow-box-spacer-pane% bottom-panel) + + (cond + [(and start-dir + (directory-exists? start-dir)) + (set-directory (normal-case-path + (mzlib:file:normalize-path start-dir)))] + [last-directory (set-directory last-directory)] + [else (set-directory (current-directory))]) + + (send ok-button min-width (send cancel-button get-width)) + + (center 'both) + + (show #t)))) - (sequence - - (when (eq? (system-type) 'unix) - (let ([dot-cb - (make-object check-box% - "Show files and directories that begin with a dot" - dot-panel - do-period-in/exclusion)]) - (send dot-panel stretchable-height #f) - (send dot-cb set-value - (preferences:get 'framework:show-periods-in-dirlist)))) - - (send directory-panel stretchable-height #f) - - (when multi-mode? - (send add-panel stretchable-height #f) - (send remove-panel stretchable-height #f) - (send result-list stretchable-width #t)) - - (make-object button% - "Up directory" - top-panel - (lambda (button evt) (do-updir))) - - (send dir-choice stretchable-width #t) - (send name-list stretchable-width #t) - (send top-panel stretchable-height #f) - (send bottom-panel stretchable-height #f) - - (when save-mode? - (send save-panel stretchable-height #f))) + ; make-common takes a dialog-maker + ; used to make one dialog object per session, now created each time - (private - - [add-button (when multi-mode? - (make-object horizontal-panel% add-panel) - (make-object button% - "Add" - add-panel - do-add))] - [add-all-button (when multi-mode? - (begin0 - (make-object button% - "Add all" - add-panel do-add-all) - (make-object horizontal-panel% add-panel)))] - [remove-button (when multi-mode? - (make-object horizontal-panel% remove-panel) - (begin0 - (make-object button% "Remove" remove-panel do-remove) - (make-object horizontal-panel% remove-panel)))]) - (sequence - (make-object vertical-panel% bottom-panel)) - (private - [ok-button - (make-object button% "OK" bottom-panel do-ok (if multi-mode? '() '(border)))] - [cancel-button (make-object button% "Cancel" bottom-panel do-cancel)]) - (sequence - (make-object grow-box-spacer-pane% bottom-panel) + (define make-common + (lambda (make-dialog) + (lambda args + (let ([result-box (box #f)]) + (apply make-dialog result-box args) + (unbox result-box))))) + + ; the common versions of these functions have their visual + ; interfaces under Scheme control + + (define common-put-file + (make-common + (opt-lambda (result-box + [name #f] + [in-directory #f] + [replace? #f] + [prompt "Select file"] + [filter #f] + [filter-msg "Invalid form"] + [parent-win (dialog-parent-parameter)]) + (let* ([directory (if (and (not in-directory) + (string? name)) + (mzlib:file:path-only name) + in-directory)] + [saved-directory last-directory] + [name (or (and (string? name) + (mzlib:file:file-name-from-path name)) + name)]) + (make-object finder-dialog% + parent-win + #t + replace? + #f + result-box + directory + name + prompt + filter + filter-msg) + (when in-directory (set! last-directory saved-directory)))))) + + (define common-get-file + (make-common + (opt-lambda + (result-box + [directory #f] + [prompt "Select file"] + [filter #f] + [filter-msg "Bad name"] + [parent-win (dialog-parent-parameter)]) + (let ([saved-directory last-directory]) + (make-object finder-dialog% + parent-win ; parent window + #f ; save-mode? + #f ; replace-ok? + #f ; multi-mode? + result-box ; boxed results + directory ; start-dir + #f ; start-name + prompt ; prompt + filter ; file-filter + filter-msg) ; file-filter-msg + (when directory (set! last-directory saved-directory)))))) + + (define common-get-file-list + (make-common + (opt-lambda (result-box + [directory #f] + [prompt "Select files"] + [filter #f] + [filter-msg "Bad name"] + [parent-win (dialog-parent-parameter)]) + (make-object + finder-dialog% + parent-win ; parent window + #f ; save-mode? + #f ; replace-ok? + #t ; multi-mode? + result-box ; boxed results + directory ; directory + #f ; start-name + prompt ; prompt + filter ; file-filter + filter-msg ; file-filter-msg + )))) + + ; the std- and common- forms both have opt-lambda's, with the same + ; list of args. Should the opt-lambda's be placed in the dispatching function? + + (define std-put-file + (opt-lambda ([name #f] + [directory #f] + [replace? #f] + [prompt "Select file"] + [filter #f] + [filter-msg "That filename does not have the right form."] + [parent-win (dialog-parent-parameter)]) + (let* ([directory (if (and (not directory) + (string? name)) + (mzlib:file:path-only name) + directory)] + [name (or (and (string? name) + (mzlib:file:file-name-from-path name)) + name)] + [f (put-file + prompt + parent-win + directory + name + (default-extension))]) - (cond - [(and start-dir - (directory-exists? start-dir)) - (set-directory (normal-case-path - (mzlib:file:normalize-path start-dir)))] - [last-directory (set-directory last-directory)] - [else (set-directory (current-directory))]) - - (send ok-button min-width (send cancel-button get-width)) - - (center 'both) - - (show #t)))) - - ; make-common takes a dialog-maker - ; used to make one dialog object per session, now created each time - - (define make-common - (lambda (make-dialog) - (lambda args - (let ([result-box (box #f)]) - (apply make-dialog result-box args) - (unbox result-box))))) - - ; the common versions of these functions have their visual - ; interfaces under Scheme control - - (define common-put-file - (make-common - (opt-lambda (result-box - [name #f] - [in-directory #f] - [replace? #f] - [prompt "Select file"] - [filter #f] - [filter-msg "Invalid form"] - [parent-win (dialog-parent-parameter)]) - (let* ([directory (if (and (not in-directory) - (string? name)) - (mzlib:file:path-only name) - in-directory)] - [saved-directory last-directory] - [name (or (and (string? name) - (mzlib:file:file-name-from-path name)) - name)]) - (make-object finder-dialog% - parent-win - #t - replace? - #f - result-box - directory - name - prompt - filter - filter-msg) - (when in-directory (set! last-directory saved-directory)))))) - - (define common-get-file - (make-common - (opt-lambda - (result-box - [directory #f] - [prompt "Select file"] - [filter #f] - [filter-msg "Bad name"] - [parent-win (dialog-parent-parameter)]) - (let ([saved-directory last-directory]) - (make-object finder-dialog% - parent-win ; parent window - #f ; save-mode? - #f ; replace-ok? - #f ; multi-mode? - result-box ; boxed results - directory ; start-dir - #f ; start-name - prompt ; prompt - filter ; file-filter - filter-msg) ; file-filter-msg - (when directory (set! last-directory saved-directory)))))) - - (define common-get-file-list - (make-common - (opt-lambda (result-box - [directory #f] - [prompt "Select files"] - [filter #f] - [filter-msg "Bad name"] - [parent-win (dialog-parent-parameter)]) - (make-object - finder-dialog% - parent-win ; parent window - #f ; save-mode? - #f ; replace-ok? - #t ; multi-mode? - result-box ; boxed results - directory ; directory - #f ; start-name - prompt ; prompt - filter ; file-filter - filter-msg ; file-filter-msg - )))) - - ; the std- and common- forms both have opt-lambda's, with the same - ; list of args. Should the opt-lambda's be placed in the dispatching function? - - (define std-put-file - (opt-lambda ([name #f] - [directory #f] - [replace? #f] - [prompt "Select file"] - [filter #f] - [filter-msg "That filename does not have the right form."] - [parent-win (dialog-parent-parameter)]) - (let* ([directory (if (and (not directory) - (string? name)) - (mzlib:file:path-only name) - directory)] - [name (or (and (string? name) - (mzlib:file:file-name-from-path name)) - name)] - [f (put-file - prompt - parent-win - directory - name - (default-extension))]) - - (if (or (not f) - (and filter - (not (filter-match? filter - f - filter-msg)))) - #f - (let* ([f (normal-case-path (mzlib:file:normalize-path f))] - [dir (mzlib:file:path-only f)] - [name (mzlib:file:file-name-from-path f)]) - (cond - [(not (and (string? dir) (directory-exists? dir))) - (message-box "Error" "That directory does not exist.") - #f] - [(or (not name) (equal? name "")) - (message-box "Error" "Empty filename.") - #f] - [else f])))))) - - (define std-get-file - (opt-lambda ([directory #f] - [prompt "Select file"] - [filter #f] - [filter-msg "That filename does not have the right form."] - [parent-win (dialog-parent-parameter)]) - (let ([f (get-file - prompt - parent-win - directory)]) - - (if f - (if (or (not filter) (filter-match? filter f filter-msg)) - (let ([f (mzlib:file:normalize-path f)]) + (if (or (not f) + (and filter + (not (filter-match? filter + f + filter-msg)))) + #f + (let* ([f (normal-case-path (mzlib:file:normalize-path f))] + [dir (mzlib:file:path-only f)] + [name (mzlib:file:file-name-from-path f)]) (cond - [(directory-exists? f) - (message-box "Error" "That is a directory name.") - #f] - [(not (file-exists? f)) - (message-box "Error" "File does not exist.") - #f] - [else f])) - #f) - #f)))) - - ; external interfaces to file functions - - (define -put-file - (lambda args - (let ([actual-fun - (case (preferences:get 'framework:file-dialogs) - [(std) std-put-file] - [(common) common-put-file])]) - (apply actual-fun args)))) - - (define -get-file - (lambda args - (let ([actual-fun - (case (preferences:get 'framework:file-dialogs) - [(std) std-get-file] - [(common) common-get-file])]) - (apply actual-fun args))))) + [(not (and (string? dir) (directory-exists? dir))) + (message-box "Error" "That directory does not exist.") + #f] + [(or (not name) (equal? name "")) + (message-box "Error" "Empty filename.") + #f] + [else f])))))) + + (define std-get-file + (opt-lambda ([directory #f] + [prompt "Select file"] + [filter #f] + [filter-msg "That filename does not have the right form."] + [parent-win (dialog-parent-parameter)]) + (let ([f (get-file + prompt + parent-win + directory)]) + + (if f + (if (or (not filter) (filter-match? filter f filter-msg)) + (let ([f (mzlib:file:normalize-path f)]) + (cond + [(directory-exists? f) + (message-box "Error" "That is a directory name.") + #f] + [(not (file-exists? f)) + (message-box "Error" "File does not exist.") + #f] + [else f])) + #f) + #f)))) + + ; external interfaces to file functions + + (define -put-file + (lambda args + (let ([actual-fun + (case (preferences:get 'framework:file-dialogs) + [(std) std-put-file] + [(common) common-put-file])]) + (apply actual-fun args)))) + + (define -get-file + (lambda args + (let ([actual-fun + (case (preferences:get 'framework:file-dialogs) + [(std) std-get-file] + [(common) common-get-file])]) + (apply actual-fun args))))))) \ No newline at end of file diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index f94c2d65..0cafe63c 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1,4 +1,5 @@ - +(module frame mzscheme + (require (lib (unit/sig framework:frame^ (import mred^ [group : framework:group^]