From 8a8a8dbe4ba0eb9ece3ca7dabe0e278de64e467e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 16 Dec 2010 10:45:39 -0500 Subject: [PATCH] Separate snip% from the gui --- collects/2htdp/private/image-more.rkt | 7 +- collects/2htdp/private/img-err.rkt | 2 +- collects/mred/mred.rkt | 1 + collects/mred/private/snipfile.rkt | 44 --- collects/mred/private/wxme/cycle.rkt | 2 +- collects/mred/private/wxme/editor-data.rkt | 171 +++++++++++ .../mred/private/wxme/editor-snip-class.rkt | 77 +++++ collects/mred/private/wxme/editor-snip.rkt | 5 +- collects/mred/private/wxme/editor.rkt | 1 + collects/mred/private/wxme/load-one.rkt | 41 +++ collects/mred/private/wxme/pasteboard.rkt | 1 + collects/mred/private/wxme/snip-admin.rkt | 43 ++- collects/mred/private/wxme/snip.rkt | 275 +++--------------- collects/mred/private/wxme/stream.rkt | 1 + collects/mred/private/wxme/style.rkt | 5 +- collects/mred/private/wxme/text.rkt | 1 + collects/mrlib/cache-image-snip.rkt | 3 +- collects/mrlib/image-core.rkt | 28 +- collects/mrlib/private/image-core-bitmap.rkt | 2 +- 19 files changed, 402 insertions(+), 308 deletions(-) create mode 100644 collects/mred/private/wxme/editor-data.rkt create mode 100644 collects/mred/private/wxme/editor-snip-class.rkt create mode 100644 collects/mred/private/wxme/load-one.rkt diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index 9818d1d859..2682a4b0f1 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -5,13 +5,17 @@ racket/match racket/contract racket/class - racket/gui/base + racket/draw + ;(only-in racket/gui/base frame% canvas% slider% horizontal-panel% button%) htdp/error racket/math (for-syntax racket/base racket/list) lang/posn) +;; for testing +; (require racket/gui/base) +#; (define (show-image arg [extra-space 0]) (letrec ([g (to-img arg)] [f (new frame% [label ""])] @@ -1353,7 +1357,6 @@ place-image/align - show-image save-image bring-between diff --git a/collects/2htdp/private/img-err.rkt b/collects/2htdp/private/img-err.rkt index 0f01f54a18..80df118fe6 100644 --- a/collects/2htdp/private/img-err.rkt +++ b/collects/2htdp/private/img-err.rkt @@ -15,7 +15,7 @@ (require htdp/error racket/class lang/posn - racket/gui/base + racket/draw mrlib/image-core (for-syntax racket/base racket/list)) diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 3c9e5ed1c6..15236cdcf0 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -14,6 +14,7 @@ (prefix wx: "private/wxme/snip.ss") (prefix wx: "private/wxme/keymap.ss") (prefix wx: "private/wxme/editor-admin.ss") + (prefix wx: "private/wxme/editor-data.ss") (prefix wx: "private/wxme/editor-snip.ss") (prefix wx: "private/wxme/stream.ss") (prefix wx: "private/wxme/wordbreak.ss") diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 2a609cb24d..593014bb05 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -14,50 +14,6 @@ text-editor-load-handler open-output-text-editor ) - ;; snip-class% and editor-data-class% loaders - - (define (ok-string-element? m) - (and (string? m) - (regexp-match? #rx"^[-a-zA-Z0-9_. ]+$" m) - (not (string=? m "..")) - (not (string=? m ".")))) - - (define (ok-lib-path? m) - (and (pair? m) - (eq? 'lib (car m)) - (pair? (cdr m)) - (list? m) - (andmap ok-string-element? (cdr m)))) - - (let ([load-one - (lambda (str id %) - (let ([m (with-handlers ([exn:fail:read? (lambda (x) #f)]) - (and (regexp-match #rx"^[(].*[)]$" str) - (let* ([p (open-input-string str)] - [m (read p)]) - (and (eof-object? (read p)) - m))))]) - (if (or (ok-lib-path? m) - (and (list? m) - (= (length m) 2) - (ok-lib-path? (car m)) - (ok-lib-path? (cadr m)))) - (let ([m (if (ok-lib-path? m) - m - (car m))]) - (let ([result (dynamic-require m id)]) - (if (is-a? result %) - result - (error 'load-class "not a ~a% instance" id)))) - #f)))]) - ;; install the getters: - (wx:set-get-snip-class! - (lambda (name) - (load-one name 'snip-class wx:snip-class%))) - (wx:set-get-editor-data-class! - (lambda (name) - (load-one name 'editor-data-class wx:editor-data-class%)))) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define readable-snip<%> diff --git a/collects/mred/private/wxme/cycle.rkt b/collects/mred/private/wxme/cycle.rkt index ee30467e8d..c8fa72ec96 100644 --- a/collects/mred/private/wxme/cycle.rkt +++ b/collects/mred/private/wxme/cycle.rkt @@ -18,7 +18,7 @@ (decl extended-text% set-extended-text%!) (decl extended-pasteboard% set-extended-pasteboard%!) -(decl get-snip-class set-get-snip-class!) +;(decl get-snip-class set-get-snip-class!) (decl get-editor-data-class set-get-editor-data-class!) (decl editor-get-file set-editor-get-file!) diff --git a/collects/mred/private/wxme/editor-data.rkt b/collects/mred/private/wxme/editor-data.rkt new file mode 100644 index 0000000000..e2dca23a89 --- /dev/null +++ b/collects/mred/private/wxme/editor-data.rkt @@ -0,0 +1,171 @@ +#lang racket/base + +(require scheme/class + scheme/file file/convertible + "../syntax.ss" + "snip-flags.ss" + "private.ss" + "style.ss" + "load-one.rkt" + ;; used only in contracts + (only-in "cycle.ss" editor-stream-in% editor-stream-out% snip-admin%) + ;; used for real + (only-in "cycle.ss" get-editor-data-class set-get-editor-data-class!) + "../wx/common/event.rkt" + racket/draw + (only-in "wx.ss" begin-busy-cursor end-busy-cursor get-highlight-text-color)) + +(provide get-the-editor-data-class-list + editor-data% + editor-data-class% + location-editor-data% + editor-data-class-list<%> + the-editor-data-class-list ;; parameter + make-the-editor-data-class-list + (struct-out editor-data-class-link)) + +;; ------------------------------------------------------------ + +(defclass editor-data% object% + (properties [[(make-or-false editor-data-class%) dataclass] #f] + [[(make-or-false editor-data%) next] #f]) + (super-new) + (def/public (write [editor-stream-out% f]) + (error 'write "should have overridden")) + + (define/public (get-s-dataclass) dataclass) + (define/public (get-s-next) next) + (define/public (set-s-next v) (set! next v))) + + +(defclass location-editor-data% editor-data% + (inherit set-dataclass) + (init-field x y) + (super-new) + (set-dataclass the-location-editor-data-class) + + (define/public (get-x) x) + (define/public (get-y) y) + + (def/override (write [editor-stream-out% f]) + (send f put x) + (send f put y) + #t)) + +;; ------------------------------------------------------------ + +(defclass editor-data-class% object% + (define classname "wxbad") + (def/public (set-classname [string? s]) + (set! classname (string->immutable-string s))) + (def/public (get-classname) classname) + + (properties [[bool? required?] #f]) + (define/public (get-s-required?) required?) + + (def/public (read [editor-stream-in% f]) (void)) + + (super-new)) + +(defclass location-editor-data-class% editor-data-class% + (inherit set-classname + set-required?) + + (super-new) + + (set-classname "wxloc") + (set-required? #t) + + (def/override (read [editor-stream-in% f]) + (let ([x (send f get-inexact)] + [y (send f get-inexact)]) + (new location-editor-data% [x x][y y])))) + +(define the-location-editor-data-class + (new location-editor-data-class%)) + +;; ------------------------------------------------------------ + +(define-struct editor-data-class-link ([c #:mutable] [name #:mutable] map-position)) + +(defclass editor-data-class-list% object% + (define ht (make-hash)) + (define pos-ht (make-hash)) + (define rev-pos-ht (make-hash)) + + (super-new) + + (add the-location-editor-data-class) + + (def/public (find [string? name]) + (let ([c (hash-ref ht name #f)]) + (or c + (let ([c (get-editor-data-class name)]) + (when c (add c)) + c)))) + + (def/public (find-position [editor-data-class% c]) + (hash-ref pos-ht c 0)) + + (def/public (add [editor-data-class% c]) + (let ([name (send c get-classname)]) + (hash-set! ht name c) + (let ([n (add1 (hash-count pos-ht))]) + (hash-set! pos-ht c n) + (hash-set! rev-pos-ht n c)))) + + (def/public (number) (hash-count ht)) + + (def/public (nth [exact-nonnegative-integer? n]) (hash-ref rev-pos-ht n #f)) + + (def/public (write [editor-stream-out% f]) + (let ([n (number)]) + (send f put n) + (for ([i (in-range 1 (add1 n))]) + (let ([c (nth i)]) + (send f put (string->bytes/utf-8 (send c get-classname))) + + (send f add-dl (make-editor-data-class-link c + #f + i))))) + #t) + + (def/public (read [editor-stream-in% f]) + (let-boxes ([count 0]) + (send f get count) + (for/and ([i (in-range count)]) + (let ([s (send f get-bytes)]) + (and (send f ok?) + (send f add-dl (make-editor-data-class-link + #f + (bytes->string/utf-8 s #\?) + (add1 i))) + #t))))) + + (define/public (find-by-map-position f n) + (ormap (lambda (s) + (and (= n (editor-data-class-link-map-position s)) + (begin + (when (editor-data-class-link-name s) + (let ([c (find (editor-data-class-link-name s))]) + (when (not c) + ;; unknown class/version + (log-error (format "unknown editor data class: ~e" + (editor-data-class-link-name s)))) + (set-editor-data-class-link-name! s #f) + (set-editor-data-class-link-c! s c))) + (editor-data-class-link-c s)))) + (send f get-dl)))) + +(define editor-data-class-list<%> (class->interface editor-data-class-list%)) + +(define (make-the-editor-data-class-list) + (new editor-data-class-list%)) + +(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list))) +(define (get-the-editor-data-class-list) + (the-editor-data-class-list)) + +(set-get-editor-data-class! + (lambda (name) + (load-one name 'editor-data-class editor-data-class%))) \ No newline at end of file diff --git a/collects/mred/private/wxme/editor-snip-class.rkt b/collects/mred/private/wxme/editor-snip-class.rkt new file mode 100644 index 0000000000..47e8cd6117 --- /dev/null +++ b/collects/mred/private/wxme/editor-snip-class.rkt @@ -0,0 +1,77 @@ +#lang racket/base + +(require racket/class + racket/file file/convertible + "../syntax.ss" + "snip-flags.ss" + "private.ss" + "style.ss" + "snip.rkt" + ;; used only in contracts + (only-in "cycle.ss" editor-stream-in% editor-stream-out% snip-admin%) + ;; used for real + (only-in "cycle.ss" + extended-text% extended-pasteboard% extended-editor-snip% + get-editor-data-class) + "../wx/common/event.rkt" + racket/draw) + +(provide the-editor-snip-class) +;; ------------------------------------------------------------ + +(defclass editor-snip-class% snip-class% + (inherit set-classname + set-version) + (inherit-field s-required?) + + (super-new) + + (set-classname "wxmedia") + (set-version 4) + (set! s-required? #t) + + (def/override (read [editor-stream-in% f]) + (let ([vers (send f do-reading-version this)]) + (let ([ed% (case (send f get-exact) + [(1) extended-text%] + [(2) extended-pasteboard%] + [else #f])] + [border? (positive? (send f get-exact))] + [lm (max 0 (send f get-exact))] + [tm (max 0 (send f get-exact))] + [rm (max 0 (send f get-exact))] + [bm (max 0 (send f get-exact))] + [li (max 0 (send f get-exact))] + [ti (max 0 (send f get-exact))] + [ri (max 0 (send f get-exact))] + [bi (max 0 (send f get-exact))] + [min-w (send f get-inexact)] + [max-w (send f get-inexact)] + [min-h (send f get-inexact)] + [max-h (send f get-inexact)] + [tf? (and (vers . > . 1) + (positive? (send f get-exact)))] + [atl? (and (vers . > . 2) + (positive? (send f get-exact)))] + [ubs? (and (vers . > . 3) + (positive? (send f get-exact)))]) + (let ([e (and ed% (new ed%))]) + (let ([snip (make-object extended-editor-snip% + e + border? + lm tm rm bm li ti ri bi + (if (negative? min-w) 'none min-w) + (if (negative? max-w) 'none max-w) + (if (negative? min-h) 'none min-h) + (if (negative? max-h) 'none max-h))]) + (send snip do-set-graphics tf? atl? ubs?) + (if e + (begin + (send e get-style-list) + (send e read-from-file f #t)) + (send snip set-editor #f)) + snip)))))) + +(define the-editor-snip-class (new editor-snip-class%)) + +(send (get-the-snip-class-list) add the-editor-snip-class) diff --git a/collects/mred/private/wxme/editor-snip.rkt b/collects/mred/private/wxme/editor-snip.rkt index 0c74ec3093..cc26fec52e 100644 --- a/collects/mred/private/wxme/editor-snip.rkt +++ b/collects/mred/private/wxme/editor-snip.rkt @@ -7,6 +7,7 @@ "snip-flags.ss" "editor.ss" "editor-admin.ss" + "editor-snip-class.rkt" "snip-admin.ss" "text.ss" "pasteboard.ss" @@ -360,8 +361,8 @@ (when with-border? (let ([pen (send dc get-pen)]) (when (and (pair? caret) - selected-text-color) - (send dc set-pen selected-text-color 1 'solid)) + (send my-admin get-selected-text-color)) + (send dc set-pen (send my-admin get-selected-text-color) 1 'solid)) (let* ([l (+ orig-x left-inset)] [t (+ orig-y top-inset)] [r (+ l w left-margin right-margin diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index 4cffb1617f..3e865000f9 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -11,6 +11,7 @@ "stream.ss" "undo.ss" "keymap.ss" + "editor-data.rkt" (only-in "cycle.ss" text% pasteboard% diff --git a/collects/mred/private/wxme/load-one.rkt b/collects/mred/private/wxme/load-one.rkt new file mode 100644 index 0000000000..abe55c86bd --- /dev/null +++ b/collects/mred/private/wxme/load-one.rkt @@ -0,0 +1,41 @@ +#lang racket/base + +(require racket/class) +(provide load-one) + +;; loaders used for snip-class% and editor-data-class% +(define (ok-string-element? m) + (and (string? m) + (regexp-match? #rx"^[-a-zA-Z0-9_. ]+$" m) + (not (string=? m "..")) + (not (string=? m ".")))) + +(define (ok-lib-path? m) + (and (pair? m) + (eq? 'lib (car m)) + (pair? (cdr m)) + (list? m) + (andmap ok-string-element? (cdr m)))) + +(define load-one + (lambda (str id %) + (let ([m (with-handlers ([exn:fail:read? (lambda (x) #f)]) + (and (regexp-match #rx"^[(].*[)]$" str) + (let* ([p (open-input-string str)] + [m (read p)]) + (and (eof-object? (read p)) + m))))]) + (if (or (ok-lib-path? m) + (and (list? m) + (= (length m) 2) + (ok-lib-path? (car m)) + (ok-lib-path? (cadr m)))) + (let ([m (if (ok-lib-path? m) + m + (car m))]) + (let ([result (dynamic-require m id)]) + (if (is-a? result %) + result + (error 'load-class "not a ~a% instance" id)))) + #f)))) + diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 4bb1e8d7e2..a84dff9e6f 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -6,6 +6,7 @@ "const.ss" "private.ss" "editor.ss" + "editor-data.rkt" "undo.ss" "style.ss" "snip.ss" diff --git a/collects/mred/private/wxme/snip-admin.rkt b/collects/mred/private/wxme/snip-admin.rkt index f794387d53..3e9660bc59 100644 --- a/collects/mred/private/wxme/snip-admin.rkt +++ b/collects/mred/private/wxme/snip-admin.rkt @@ -5,11 +5,13 @@ (only-in "cycle.ss" set-snip-admin%! popup-menu%) - "wx.ss") + (prefix-in wx: "wx.ss")) (provide snip-admin% standard-snip-admin%) +(define TAB-WIDTH 20) + (defclass snip-admin% object% (super-new) @@ -48,7 +50,19 @@ #f) (def/public (modified [snip% s] [any? modified?]) - (void))) + (void)) + + (def/public (get-line-spacing) + #f) + + (def/public (get-selected-text-color) + #f) + + (def/public (call-with-busy-cursor [procedure? thunk]) + (void)) + + (def/public (get-tabs [maybe-box? [length #f]] [maybe-box? [tab-width #f]] [maybe-box? [in-units #f]]) + #f)) (set-snip-admin%! snip-admin%) @@ -146,4 +160,27 @@ (def/override (modified [snip% s] [any? modified?]) (when (eq? (send s get-admin) this) - (send editor on-snip-modified s modified?)))) + (send editor on-snip-modified s modified?))) + + (def/override (get-line-spacing) + (if (object-method-arity-includes? editor 'get-line-spacing 0) + (send editor get-line-spacing) + 0)) + + (def/override (get-tabs [maybe-box? [length #f]] [maybe-box? [tab-width #f]] [maybe-box? [in-units #f]]) + (if (object-method-arity-includes? editor 'get-tabs 3) + (send editor get-tabs length tab-width in-units) + (begin (when length (set-box! length 0)) + (when tab-width (set-box! tab-width TAB-WIDTH)) + (when in-units (set-box! in-units #t)) + null))) + + (def/override (get-selected-text-color) + (wx:get-highlight-text-color)) + + (def/override (call-with-busy-cursor [procedure? thunk]) + (dynamic-wind + wx:begin-busy-cursor + thunk + wx:end-busy-cursor)) + ) diff --git a/collects/mred/private/wxme/snip.rkt b/collects/mred/private/wxme/snip.rkt index 6313c54afe..7261419dcc 100644 --- a/collects/mred/private/wxme/snip.rkt +++ b/collects/mred/private/wxme/snip.rkt @@ -5,30 +5,27 @@ "snip-flags.ss" "private.ss" "style.ss" - "cycle.ss" - "wx.ss") + "load-one.rkt" + ;; used only in contracts + ;(only-in "cycle.ss" editor-stream-in% editor-stream-out% snip-admin%) + ;; used for real + "../wx/common/event.rkt" + racket/draw) (provide snip% snip-class% string-snip% tab-snip% image-snip% - editor-data% - editor-data-class% - location-editor-data% snip-class-list<%> - editor-data-class-list<%> get-the-snip-class-list - get-the-editor-data-class-list - the-editor-snip-class + + get-snip-class the-snip-class-list ;; parameter make-the-snip-class-list - the-editor-data-class-list ;; parameter - make-the-editor-data-class-list (struct-out snip-class-link) - (struct-out editor-data-class-link) snip->admin snip->count @@ -54,10 +51,15 @@ caret-status? - selected-text-color + ;selected-text-color image-type?) +;; these are used only in contracts +;; we don't want the real definitions b/c they require the gui +(define-values (editor-stream-in% editor-stream-out% snip-admin%) + (values object% object% object%)) + (define (symbol-list? l) (and (list? l) (andmap symbol? l))) (define (mutable-string? s) @@ -72,8 +74,6 @@ (exact-nonnegative-integer? (cdr v)) ((car v) . <= . (cdr v))))) -(define selected-text-color (get-highlight-text-color)) - ;; ------------------------------------------------------------ (define MAX-WASTE 3) @@ -81,8 +81,6 @@ (define IMAGE-PIXELS-PER-SCROLL 20.0) (define IMAGE-VOID-SIZE 20.0) -(define TAB-WIDTH 20) - (define (replace-nuls s) (if (for/or ([c (in-string s)]) (or (eq? #\nul c) (eq? #\page c))) @@ -462,7 +460,7 @@ [real? dx] [real? dy] [caret-status? caret]) (unless (has-flag? s-flags INVISIBLE) (if (and (pair? caret) - (or selected-text-color + (or (and s-admin (send s-admin get-selected-text-color)) (eq? 'solid (send dc get-text-mode)))) ;; Draw three parts: before selection, selection, after selection (let ([before (replace-nuls @@ -484,8 +482,8 @@ (send dc get-text-extent before))]) (let ([col (send dc get-text-foreground)] [mode (send dc get-text-mode)]) - (when selected-text-color - (send dc set-text-foreground selected-text-color)) + (when (and s-admin (send s-admin get-selected-text-color)) + (send dc set-text-foreground (send s-admin get-selected-text-color))) (send dc set-text-mode 'transparent) (send dc draw-text sel (+ x w) y #f) (send dc set-text-foreground col) @@ -696,24 +694,19 @@ [media (and admin (send admin get-editor))]) (let-values ([(n tabs tabspace mult) - (if (media . is-a? . text%) - (let-boxes ([n 0] + (let-boxes ([n 0] [space 0] [units? #f] [tabs null]) - (set-box! tabs (send media get-tabs n space units?)) - (values n - tabs - space - (if units? - 1 - (if (zero? str-w) - 1.0 - str-w)))) - (values 0 - #() - TAB-WIDTH - 1))]) + (set-box! tabs (send admin get-tabs n space units?)) + (values n + tabs ;; this should be a vector, right? + space + (if units? + 1 + (if (zero? str-w) + 1.0 + str-w))))]) (set-str-w (let loop ([i 0]) (if (= i n) @@ -1071,11 +1064,11 @@ (path->complete-path base)))))))) (current-directory))) name))]) - (let ([nbm (dynamic-wind - begin-busy-cursor - (lambda () - (make-object bitmap% fullpath kind)) - end-busy-cursor)]) + (let ([nbm (if s-admin + (send s-admin call-with-busy-cursor + (lambda () + (make-object bitmap% fullpath kind))) + (make-object bitmap% fullpath kind))]) (when (send nbm ok?) (do-set-bitmap nbm #f #f)))))) ;; for refresh: @@ -1233,60 +1226,6 @@ (when (and s-admin is-relative-path? filename) (load-file filename filetype #t)))) -;; ------------------------------------------------------------ - -(defclass editor-snip-class% snip-class% - (inherit set-classname - set-version) - (inherit-field s-required?) - - (super-new) - - (set-classname "wxmedia") - (set-version 4) - (set! s-required? #t) - - (def/override (read [editor-stream-in% f]) - (let ([vers (send f do-reading-version this)]) - (let ([ed% (case (send f get-exact) - [(1) extended-text%] - [(2) extended-pasteboard%] - [else #f])] - [border? (positive? (send f get-exact))] - [lm (max 0 (send f get-exact))] - [tm (max 0 (send f get-exact))] - [rm (max 0 (send f get-exact))] - [bm (max 0 (send f get-exact))] - [li (max 0 (send f get-exact))] - [ti (max 0 (send f get-exact))] - [ri (max 0 (send f get-exact))] - [bi (max 0 (send f get-exact))] - [min-w (send f get-inexact)] - [max-w (send f get-inexact)] - [min-h (send f get-inexact)] - [max-h (send f get-inexact)] - [tf? (and (vers . > . 1) - (positive? (send f get-exact)))] - [atl? (and (vers . > . 2) - (positive? (send f get-exact)))] - [ubs? (and (vers . > . 3) - (positive? (send f get-exact)))]) - (let ([e (and ed% (new ed%))]) - (let ([snip (make-object extended-editor-snip% - e - border? - lm tm rm bm li ti ri bi - (if (negative? min-w) 'none min-w) - (if (negative? max-w) 'none max-w) - (if (negative? min-h) 'none min-h) - (if (negative? max-h) 'none max-h))]) - (send snip do-set-graphics tf? atl? ubs?) - (if e - (begin - (send e get-style-list) - (send e read-from-file f #t)) - (send snip set-editor #f)) - snip)))))) ;; ------------------------------------------------------------ @@ -1329,7 +1268,6 @@ (define the-string-snip-class (new string-snip-class%)) (define the-tab-snip-class (new tab-snip-class%)) (define the-image-snip-class (new image-snip-class%)) -(define the-editor-snip-class (new editor-snip-class%)) (define-struct snip-class-link ([c #:mutable] [name #:mutable] [header-flag #:mutable] map-position reading-version)) @@ -1342,7 +1280,7 @@ (add the-string-snip-class) (add the-tab-snip-class) - (add the-editor-snip-class) + ;(add the-editor-snip-class) (add the-image-snip-class) (define/public (reset-header-flags s) @@ -1420,148 +1358,6 @@ ;; ------------------------------------------------------------ -(defclass editor-data% object% - (properties [[(make-or-false editor-data-class%) dataclass] #f] - [[(make-or-false editor-data%) next] #f]) - (super-new) - (def/public (write [editor-stream-out% f]) - (error 'write "should have overridden")) - - (define/public (get-s-dataclass) dataclass) - (define/public (get-s-next) next) - (define/public (set-s-next v) (set! next v))) - - -(defclass location-editor-data% editor-data% - (inherit set-dataclass) - (init-field x y) - (super-new) - (set-dataclass the-location-editor-data-class) - - (define/public (get-x) x) - (define/public (get-y) y) - - (def/override (write [editor-stream-out% f]) - (send f put x) - (send f put y) - #t)) - -;; ------------------------------------------------------------ - -(defclass editor-data-class% object% - (define classname "wxbad") - (def/public (set-classname [string? s]) - (set! classname (string->immutable-string s))) - (def/public (get-classname) classname) - - (properties [[bool? required?] #f]) - (define/public (get-s-required?) required?) - - (def/public (read [editor-stream-in% f]) (void)) - - (super-new)) - -(defclass location-editor-data-class% editor-data-class% - (inherit set-classname - set-required?) - - (super-new) - - (set-classname "wxloc") - (set-required? #t) - - (def/override (read [editor-stream-in% f]) - (let ([x (send f get-inexact)] - [y (send f get-inexact)]) - (new location-editor-data% [x x][y y])))) - -(define the-location-editor-data-class - (new location-editor-data-class%)) - -;; ------------------------------------------------------------ - -(define-struct editor-data-class-link ([c #:mutable] [name #:mutable] map-position)) - -(defclass editor-data-class-list% object% - (define ht (make-hash)) - (define pos-ht (make-hash)) - (define rev-pos-ht (make-hash)) - - (super-new) - - (add the-location-editor-data-class) - - (def/public (find [string? name]) - (let ([c (hash-ref ht name #f)]) - (or c - (let ([c (get-editor-data-class name)]) - (when c (add c)) - c)))) - - (def/public (find-position [editor-data-class% c]) - (hash-ref pos-ht c 0)) - - (def/public (add [editor-data-class% c]) - (let ([name (send c get-classname)]) - (hash-set! ht name c) - (let ([n (add1 (hash-count pos-ht))]) - (hash-set! pos-ht c n) - (hash-set! rev-pos-ht n c)))) - - (def/public (number) (hash-count ht)) - - (def/public (nth [exact-nonnegative-integer? n]) (hash-ref rev-pos-ht n #f)) - - (def/public (write [editor-stream-out% f]) - (let ([n (number)]) - (send f put n) - (for ([i (in-range 1 (add1 n))]) - (let ([c (nth i)]) - (send f put (string->bytes/utf-8 (send c get-classname))) - - (send f add-dl (make-editor-data-class-link c - #f - i))))) - #t) - - (def/public (read [editor-stream-in% f]) - (let-boxes ([count 0]) - (send f get count) - (for/and ([i (in-range count)]) - (let ([s (send f get-bytes)]) - (and (send f ok?) - (send f add-dl (make-editor-data-class-link - #f - (bytes->string/utf-8 s #\?) - (add1 i))) - #t))))) - - (define/public (find-by-map-position f n) - (ormap (lambda (s) - (and (= n (editor-data-class-link-map-position s)) - (begin - (when (editor-data-class-link-name s) - (let ([c (find (editor-data-class-link-name s))]) - (when (not c) - ;; unknown class/version - (log-error (format "unknown editor data class: ~e" - (editor-data-class-link-name s)))) - (set-editor-data-class-link-name! s #f) - (set-editor-data-class-link-c! s c))) - (editor-data-class-link-c s)))) - (send f get-dl)))) - -(define editor-data-class-list<%> (class->interface editor-data-class-list%)) - -(define (make-the-editor-data-class-list) - (new editor-data-class-list%)) - -(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list))) -(define (get-the-editor-data-class-list) - (the-editor-data-class-list)) - -;; ------------------------------------------------------------ - (define snip->admin (class-field-accessor snip% s-admin)) (define snip->count (class-field-accessor snip% s-count)) (define snip->next (class-field-accessor snip% s-next)) @@ -1580,3 +1376,8 @@ (define set-snip-next! (class-field-mutator snip% s-next)) (define snip%-get-text (generic snip% get-text)) + +;; install the getters: +(define get-snip-class + (lambda (name) + (load-one name 'snip-class snip-class%))) \ No newline at end of file diff --git a/collects/mred/private/wxme/stream.rkt b/collects/mred/private/wxme/stream.rkt index 429fb9f53f..3273d025fa 100644 --- a/collects/mred/private/wxme/stream.rkt +++ b/collects/mred/private/wxme/stream.rkt @@ -3,6 +3,7 @@ "../syntax.ss" "private.ss" "snip.ss" + "editor-data.rkt" (only-in "cycle.ss" set-editor-stream-in%! set-editor-stream-out%!)) diff --git a/collects/mred/private/wxme/style.rkt b/collects/mred/private/wxme/style.rkt index 33a35f3e93..ba66187fd1 100644 --- a/collects/mred/private/wxme/style.rkt +++ b/collects/mred/private/wxme/style.rkt @@ -1,11 +1,12 @@ #lang scheme/base (require scheme/class scheme/file - (for-syntax scheme/base) + (for-syntax scheme/base) + racket/draw "../syntax.ss" "cycle.ss" "private.ss" - "wx.ss") + "symbol-predicates.rkt") (provide mult-color<%> add-color<%> diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index be32c886a3..70e7aadf61 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -8,6 +8,7 @@ "mline.ss" "private.ss" "editor.ss" + "editor-data.rkt" "undo.ss" "style.ss" "snip.ss" diff --git a/collects/mrlib/cache-image-snip.rkt b/collects/mrlib/cache-image-snip.rkt index 0e37ec1d28..2dca534fcb 100644 --- a/collects/mrlib/cache-image-snip.rkt +++ b/collects/mrlib/cache-image-snip.rkt @@ -1,5 +1,6 @@ (module cache-image-snip mzscheme - (require mred + (require racket/draw + mred/private/wxme/snip mzlib/class mzlib/string mzlib/contract diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 8d65e27110..5f8b5d3aa6 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -29,16 +29,18 @@ has been moved out). (require racket/class racket/draw - racket/gui/base + (for-syntax racket/base) + file/convertible racket/math racket/contract - "private/image-core-bitmap.ss" - "image-core-wxme.ss" - "private/image-core-snipclass.rkt" - "private/regmk.rkt" - (prefix-in cis: "cache-image-snip.ss") - (for-syntax racket/base) - file/convertible) + "private/image-core-bitmap.ss" ;; safe + "image-core-wxme.ss" ;; safe + "private/image-core-snipclass.rkt" ;; safe + "private/regmk.rkt" ;; safe + ;; the hard cases + mred/private/wxme/snip + (prefix-in cis: "cache-image-snip.ss") ;; safe + ) @@ -220,7 +222,7 @@ has been moved out). (render-image img bdc 0 0) (begin0 (send bdc get-bitmap) - (send bdc set-bitmap #f))) + (send bdc set-bitmap #f)))) (define image% (class* snip% (png-convertible<%> equal<%> image<%>) @@ -285,10 +287,7 @@ has been moved out). (when standard (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))]) (let-values ([(w h d a) (send dc get-text-extent "X" (send standard get-font))]) - (set! scroll-step (+ h - (if (is-a? ed text%) - (send ed get-line-spacing) - 0))))))))) + (set! scroll-step (+ h (send admin get-line-spacing))))))))) ;; if that didn't happen, set it to 12. (unless scroll-step (set! scroll-step 12)))) @@ -1170,7 +1169,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! to-img bitmap->image - image-snip->image) + image-snip->image + image-snip%) ;; method names (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 949acdcb56..9b694af253 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -1,5 +1,5 @@ #lang scheme/base -(require scheme/gui/base +(require racket/draw scheme/class)