suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Separate snip% from the gui

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-12-16 10:45:39 -05:00
parent 398add4e29
commit 8a8a8dbe4b
19 changed files with 402 additions and 308 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/2htdp/private/image-more.rkt
View File

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

2
collects/2htdp/private/img-err.rkt
View File

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

1
collects/mred/mred.rkt
View File

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

44
collects/mred/private/snipfile.rkt
View File

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

2
collects/mred/private/wxme/cycle.rkt
View File

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

171
collects/mred/private/wxme/editor-data.rkt Normal file
View File

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

77
collects/mred/private/wxme/editor-snip-class.rkt Normal file
View File

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

5
collects/mred/private/wxme/editor-snip.rkt
View File

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

1
collects/mred/private/wxme/editor.rkt
View File

@ -11,6 +11,7 @@
"stream.ss"
"undo.ss"
"keymap.ss"
"editor-data.rkt"
(only-in "cycle.ss"
text%
pasteboard%

41
collects/mred/private/wxme/load-one.rkt Normal file
View File

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

1
collects/mred/private/wxme/pasteboard.rkt
View File

@ -6,6 +6,7 @@
"const.ss"
"private.ss"
"editor.ss"
"editor-data.rkt"
"undo.ss"
"style.ss"
"snip.ss"

43
collects/mred/private/wxme/snip-admin.rkt
View File

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

259
collects/mred/private/wxme/snip.rkt
View File

@ -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]
[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))))
(values 0
#()
TAB-WIDTH
1))])
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
(let ([nbm (if s-admin
(send s-admin call-with-busy-cursor
(lambda ()
(make-object bitmap% fullpath kind))
end-busy-cursor)])
(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%)))

1
collects/mred/private/wxme/stream.rkt
View File

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

3
collects/mred/private/wxme/style.rkt
View File

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

1
collects/mred/private/wxme/text.rkt
View File

@ -8,6 +8,7 @@
"mline.ss"
"private.ss"
"editor.ss"
"editor-data.rkt"
"undo.ss"
"style.ss"
"snip.ss"

3
collects/mrlib/cache-image-snip.rkt
View File

@ -1,5 +1,6 @@
(module cache-image-snip mzscheme
(require mred
(require racket/draw
mred/private/wxme/snip
mzlib/class
mzlib/string
mzlib/contract

28
collects/mrlib/image-core.rkt
View File

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

2
collects/mrlib/private/image-core-bitmap.rkt
View File

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