Separate snip% from the gui

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
          

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))

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")

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<%>

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!)

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%)))

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)

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 my-admin get-selected-text-color))
-                        (send dc set-pen selected-text-color 1 'solid))
+                        (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 

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%

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))))
+  

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"

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))
+  )

collects/mred/private/wxme/snip.rkt

@@ -5,30 +5,27 @@
          "snip-flags.ss"
          "private.ss"
          "style.ss"
-         "cycle.ss"
+         "load-one.rkt"
-         "wx.ss")
+         ;; 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
+                (when (and s-admin (send s-admin get-selected-text-color))
-                  (send dc set-text-foreground 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]
                                         [space 0]
                                         [units? #f]
                                         [tabs null])
-                                (set-box! tabs (send media get-tabs n space units?))
+                            (set-box! tabs (send admin get-tabs n space units?))
                           (values n
-                                      tabs
+                                  tabs ;; this should be a vector, right?
                                   space
                                   (if units? 
                                       1 
                                       (if (zero? str-w)
                                           1.0
-                                              str-w))))
+                                          str-w))))])
-                            (values 0
-                                    #()
-                                    TAB-WIDTH
-                                    1))])
             (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
+            (let ([nbm (if s-admin
-                           begin-busy-cursor
+                           (send s-admin call-with-busy-cursor
                                  (lambda ()
-                             (make-object bitmap% fullpath kind))
+                                   (make-object bitmap% fullpath kind)))
-                           end-busy-cursor)])
+                           (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%)))

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%!))

collects/mred/private/wxme/style.rkt

@@ -2,10 +2,11 @@
 (require scheme/class
          scheme/file
          (for-syntax scheme/base)         
+         racket/draw
          "../syntax.ss"
          "cycle.ss"
          "private.ss"
-         "wx.ss")
+         "symbol-predicates.rkt")
 
 (provide mult-color<%>
          add-color<%>

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"

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

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"
+         "private/image-core-bitmap.ss" ;; safe
-         "image-core-wxme.ss"
+         "image-core-wxme.ss" ;; safe
-         "private/image-core-snipclass.rkt"
+         "private/image-core-snipclass.rkt" ;; safe
-         "private/regmk.rkt"
+         "private/regmk.rkt" ;; safe
-         (prefix-in cis: "cache-image-snip.ss")
+         ;; the hard cases
-         (for-syntax racket/base)
+         mred/private/wxme/snip
-         file/convertible)
+         (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
+                    (set! scroll-step (+ h (send admin get-line-spacing)))))))))
-                                         (if (is-a? ed text%)
-                                             (send ed get-line-spacing)
-                                             0)))))))))
         ;; 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)

collects/mrlib/private/image-core-bitmap.rkt

@@ -1,5 +1,5 @@
 #lang scheme/base
-(require scheme/gui/base
+(require racket/draw
          scheme/class)