1519 lines
51 KiB
Racket
1519 lines
51 KiB
Racket
#lang scheme/base
|
|
(require scheme/class
|
|
scheme/file
|
|
"../syntax.ss"
|
|
"snip-flags.ss"
|
|
"private.ss"
|
|
"style.ss"
|
|
"cycle.ss"
|
|
"wx.ss")
|
|
|
|
(define (symbol-list? l)
|
|
(and (list? l) (andmap symbol? l)))
|
|
(define (mutable-string? s)
|
|
(and (string? s) (not (immutable? s))))
|
|
|
|
(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
|
|
|
|
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
|
|
snip->next
|
|
snip->prev
|
|
snip->flags
|
|
snip->line
|
|
snip->style
|
|
snip->snipclass
|
|
|
|
set-snip-admin!
|
|
set-snip-line!
|
|
set-snip-style!
|
|
set-snip-flags!
|
|
set-snip-count!
|
|
set-snip-prev!
|
|
set-snip-next!
|
|
|
|
snip%-get-text
|
|
|
|
string-snip-buffer
|
|
string-snip-dtext)
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define MAX-WASTE 3)
|
|
(define MIN-WASTE-CHECK 24)
|
|
(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)))
|
|
(regexp-replace* #rx"\f"
|
|
(regexp-replace* #rx"\0" s " ")
|
|
"^L")
|
|
s))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(defclass snip-class% object%
|
|
(define classname "wxbad")
|
|
(def/public (set-classname [string? s])
|
|
(set! classname (string->immutable-string s)))
|
|
(def/public (get-classname) classname)
|
|
|
|
(properties [[exact-nonnegative-integer? version] 0])
|
|
(field [s-required? #f])
|
|
(define/public (get-s-required?) s-required?)
|
|
|
|
(super-new)
|
|
|
|
(def/public (read-header [editor-stream-in% f]) #t)
|
|
(def/public (write-header [editor-stream-out% f]) #t)
|
|
(def/public (reading-version [editor-stream-in% f])
|
|
(send f do-reading-version this))
|
|
|
|
(def/public (read [editor-stream-in% f]) (error "should have been overridden")))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(defclass snip% object%
|
|
;; For use only by the owning editor:
|
|
(field [s-prev #f]
|
|
[s-next #f]
|
|
[s-line #f])
|
|
(define/public (set-s-prev p) (set! s-prev p))
|
|
(define/public (set-s-next p) (set! s-next p))
|
|
(define/public (set-s-line l) (set! s-line l))
|
|
|
|
(field [s-admin #f]
|
|
[s-count 1]
|
|
[s-flags NO-FLAGS]
|
|
[s-snipclass #f]
|
|
[s-style (send the-style-list basic-style)])
|
|
(define/public (set-s-admin a) (set! s-admin a))
|
|
(define/public (set-s-count v) (set! s-count v))
|
|
(define/public (set-s-flags v) (set! s-flags v))
|
|
(define/public (set-s-snipclass v) (set! s-snipclass v))
|
|
(define/public (set-s-style s) (set! s-style s))
|
|
|
|
(def/public (set-snipclass [snip-class% c])
|
|
(set! s-snipclass c))
|
|
(def/public (get-snipclass) s-snipclass)
|
|
|
|
(def/public (get-count) s-count)
|
|
(def/public (get-flags) (flags->symbols s-flags))
|
|
|
|
(super-new)
|
|
|
|
(def/public (~)
|
|
(set! s-next #f)
|
|
(set! s-prev #f)
|
|
(set! s-line #f))
|
|
|
|
(def/public (next) s-next)
|
|
(def/public (previous) s-prev)
|
|
(def/public (get-admin) s-admin)
|
|
|
|
(def/public (set-admin [(make-or-false snip-admin%) a])
|
|
(unless (and (not (eq? a s-admin))
|
|
(has-flag? s-flags OWNED)
|
|
(or a
|
|
(not (has-flag? s-flags CAN-DISOWN))))
|
|
(set! s-admin a)
|
|
(size-cache-invalid)
|
|
(if (not a)
|
|
(begin
|
|
(set! s-prev #f)
|
|
(set! s-next #f)
|
|
(set! s-line #f))
|
|
(set! s-flags (add-flag OWNED s-flags)))))
|
|
|
|
(def/public (set-count [exact-nonnegative-integer? new-count])
|
|
(let ([old-count s-count]
|
|
[new-count (max new-count 1)])
|
|
(set! s-count new-count)
|
|
(when s-admin
|
|
(unless (send s-admin recounted this #t)
|
|
(set! s-count old-count)))))
|
|
|
|
(def/public (set-flags [symbol-list? new-flags])
|
|
(s-set-flags (symbols->flags new-flags)))
|
|
|
|
(define/public (s-set-flags new-flags)
|
|
(let* (;; make sure that wxSNIP-HARD_NEWLINE implies a wxSNIP-NEWLINE
|
|
[new-flags (if (has-flag? new-flags HARD-NEWLINE)
|
|
(add-flag new-flags NEWLINE)
|
|
(remove-flag new-flags NEWLINE))]
|
|
;; make sure ownership and splitness flags don't change
|
|
[new-flags (copy-flag s-flags new-flags OWNED)]
|
|
[new-flags (copy-flag s-flags new-flags CAN-DISOWN)]
|
|
[new-flags (copy-flag s-flags new-flags CAN-SPLIT)])
|
|
(set! s-flags new-flags)
|
|
(when s-admin
|
|
(send s-admin resized this #t))))
|
|
|
|
(def/public (on-event [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [mouse-event% event])
|
|
(void))
|
|
|
|
(def/public (adjust-cursor [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [mouse-event% event])
|
|
#f)
|
|
|
|
(def/public (on-char [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [key-event% event])
|
|
(void))
|
|
|
|
(def/public (do-edit-operation [symbol? op] [any? [recur? #t]] [exact-integer? [timestamp 0]])
|
|
(void))
|
|
|
|
(def/public (can-do-edit-operation? [symbol? op] [any? [recur? #t]])
|
|
#f)
|
|
|
|
(def/public (match? [snip% other])
|
|
(and (eq? s-snipclass (snip->snipclass other))
|
|
(= s-count (get-field s-count other))))
|
|
|
|
(def/public (own-caret [any? own?])
|
|
(void))
|
|
|
|
(def/public (blink-caret [dc<%> dc] [real? ex] [real? ey])
|
|
(void))
|
|
|
|
(def/public (size-cache-invalid)
|
|
(void))
|
|
|
|
(def/public (get-extent [dc<%> dc] [real? ex] [real? ey]
|
|
[maybe-box? [w #f]] [maybe-box? [h #f]]
|
|
[maybe-box? [descent #f]] [maybe-box? [space #f]]
|
|
[maybe-box? [lspace #f]] [maybe-box? [rspace #f]])
|
|
(when w (set-box! w 0.0))
|
|
(when h (set-box! h 0.0))
|
|
(when descent (set-box! descent 0.0))
|
|
(when space (set-box! space 0.0))
|
|
(when lspace (set-box! lspace 0.0))
|
|
(when rspace (set-box! rspace 0.0)))
|
|
|
|
(def/public (partial-offset [dc<%> dc] [real? ex] [real? ey] [exact-nonnegative-integer? offset])
|
|
(if (zero? offset)
|
|
0.0
|
|
(let-boxes ([w 0.0])
|
|
(get-extent dc ex ey w #f #f #f #f #f)
|
|
w)))
|
|
|
|
(def/public (draw [dc<%> dc] [real? x] [real? y]
|
|
[real? left] [real? top] [real? bottom] [real? right]
|
|
[real? dx] [real? dy] [symbol? caret])
|
|
(void))
|
|
|
|
(def/public (split [exact-nonnegative-integer? position] [box? first] [box? second])
|
|
(let ([snip (new snip%)])
|
|
(send snip set-s-count position)
|
|
(set! s-count (- s-count position))
|
|
|
|
(set-box! first snip)
|
|
(set-box! second this)
|
|
|
|
(when (and (not (has-flag? s-flags CAN-SPLIT)) s-admin)
|
|
(send s-admin resized this #t))))
|
|
|
|
(def/public (merge-with [snip% other])
|
|
#f)
|
|
|
|
(def/public (get-text! [mutable-string? s] [exact-nonnegative-integer? offset]
|
|
[exact-integer? num] [exact-nonnegative-integer? dt])
|
|
(unless (num . <= . 0)
|
|
(let ([str (get-text (+ offset dt) num #f)])
|
|
(if (not str)
|
|
(for ([i (in-range num)])
|
|
(string-set! s i #\.))
|
|
(string-copy! s 0 str 0 (min num (string-length str) (string-length s)))))))
|
|
|
|
(def/public (get-text [exact-nonnegative-integer? offset] [exact-integer? num]
|
|
[any? [flattened? #f]])
|
|
(make-string (min num (max 0 (- s-count (max 0 offset)))) #\.))
|
|
|
|
(def/public (set-style [style<%> s])
|
|
(unless (has-flag? s-flags OWNED)
|
|
(set! s-style s)))
|
|
|
|
(def/public (get-style)
|
|
s-style)
|
|
|
|
(def/public (copy)
|
|
(let ([s (new snip%)])
|
|
(do-copy-to s)
|
|
s))
|
|
|
|
(define/public (do-copy-to dest)
|
|
(send dest set-s-count s-count)
|
|
(send dest set-s-flags
|
|
(remove-flag (remove-flag (remove-flag s-flags OWNED)
|
|
CAN-DISOWN)
|
|
CAN-SPLIT))
|
|
(send dest set-s-snipclass s-snipclass)
|
|
(send dest set-s-style s-style))
|
|
|
|
(def/public (write [editor-stream-out% f])
|
|
(void))
|
|
|
|
(def/public (resize [real? w] [real? h])
|
|
#f)
|
|
|
|
(def/public (get-num-scroll-steps)
|
|
1)
|
|
|
|
(def/public (find-scroll-step [real? n])
|
|
0)
|
|
|
|
(def/public (get-scroll-step-offset [exact-integer? n])
|
|
0)
|
|
|
|
(def/public (is-owned?)
|
|
(has-flag? s-flags OWNED))
|
|
|
|
(def/public (release-from-owner)
|
|
(if (not (has-flag? s-flags OWNED))
|
|
#t
|
|
(if (not s-admin)
|
|
#f
|
|
(if (send s-admin release-snip this)
|
|
(not (has-flag? s-flags OWNED))
|
|
#f))))
|
|
|
|
(def/public (set-unmodified)
|
|
(void)))
|
|
|
|
(defclass internal-snip% snip%
|
|
(super-new)
|
|
(def/override (set-count [exact-integer? c])
|
|
;; reject change
|
|
(void)))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(defclass string-snip-class% snip-class%
|
|
(inherit set-classname
|
|
set-version)
|
|
(inherit-field s-required?)
|
|
|
|
(super-new)
|
|
|
|
(set-classname "wxtext")
|
|
(set-version 3)
|
|
(set! s-required? #t)
|
|
|
|
(def/override (read [editor-stream-in% f])
|
|
(s-read (make-object string-snip% 0) f))
|
|
|
|
(def/public (s-read [string-snip% snip] [editor-stream-in% f])
|
|
(let ([flags (send f get-exact)])
|
|
(let ([pos (send f tell)])
|
|
(let ([count (send f get-exact)])
|
|
(send f jump-to pos)
|
|
(let ([count (if (count . < . 0)
|
|
10; this is a failure; we make up something
|
|
count)])
|
|
(send snip s-read count f))
|
|
(send snip set-s-flags flags)
|
|
snip)))))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(defclass string-snip% internal-snip%
|
|
(inherit-field s-style
|
|
s-count
|
|
s-flags
|
|
s-admin
|
|
s-snipclass)
|
|
|
|
(init-rest args)
|
|
|
|
(super-new)
|
|
(set! s-count 0)
|
|
|
|
(field [str-w -1.0]
|
|
[s-dtext 0]
|
|
[s-buffer ""])
|
|
(define/public (set-str-w v) (set! str-w v))
|
|
(define/public (get-s-dtext) s-dtext)
|
|
|
|
(let-values ([(str len)
|
|
(cond
|
|
;; handle common case for split, first:
|
|
[(and (pair? args)
|
|
(exact-nonnegative-integer? (car args))
|
|
(null? (cdr args)))
|
|
(values "" (car args))]
|
|
[else
|
|
(case-args
|
|
args
|
|
[() (values "" 0)]
|
|
[([exact-nonnegative-integer? len])
|
|
(values "" len)]
|
|
[([string? str])
|
|
(values str (string-length str))]
|
|
[([string? str] [exact-nonnegative-integer? len])
|
|
(values str len)]
|
|
(init-name 'string-snip%))])])
|
|
|
|
(set! s-flags (add-flag (add-flag s-flags IS-TEXT) CAN-APPEND))
|
|
|
|
(let ([len (max 20 (* 2 (min len 5000)))])
|
|
(set! s-buffer (make-string len)))
|
|
|
|
(set! s-snipclass the-string-snip-class)
|
|
|
|
(unless (equal? str "")
|
|
(insert str (min (string-length str) len) 0)))
|
|
|
|
(def/override (~)
|
|
(set! s-buffer ""))
|
|
|
|
(def/override (size-cache-invalid)
|
|
(set! str-w -1.0))
|
|
|
|
(define/private (get-text-extent dc count)
|
|
(let ([font (send s-style get-font)])
|
|
(let-values ([(w h d a)
|
|
(send dc get-text-extent (replace-nuls (substring s-buffer s-dtext (+ s-dtext count)))
|
|
font #f)])
|
|
w)))
|
|
|
|
(def/override (get-extent [dc<%> dc] [real? ex] [real? ey]
|
|
[maybe-box? [wo #f]] [maybe-box? [ho #f]]
|
|
[maybe-box? [dso #f]] [maybe-box? [so #f]]
|
|
[maybe-box? [ls #f]] [maybe-box? [rs #f]])
|
|
(when (str-w . < . 0)
|
|
(let ([count s-count])
|
|
(if (or (has-flag? s-flags INVISIBLE)
|
|
(zero? count)
|
|
(and (= count 1)
|
|
(or (eq? (string-ref s-buffer s-dtext) #\newline)
|
|
(eq? (string-ref s-buffer s-dtext) #\tab))))
|
|
(if (and (= count 1)
|
|
(eq? (string-ref s-buffer s-dtext) #\tab))
|
|
(set! str-w (send s-style get-text-width dc))
|
|
(set! str-w 0.0))
|
|
(set! str-w (get-text-extent dc count)))))
|
|
|
|
(when wo (set-box! wo str-w))
|
|
(when ho
|
|
(set-box! ho (send s-style get-text-height dc)))
|
|
(when dso
|
|
(set-box! dso (send s-style get-text-descent dc)))
|
|
(when so
|
|
(set-box! so (send s-style get-text-space dc)))
|
|
(when ls (set-box! ls 0.0))
|
|
(when rs (set-box! rs 0.0)))
|
|
|
|
(def/override (partial-offset [dc<%> dc] [real? ex] [real? ey]
|
|
[exact-nonnegative-integer? offset])
|
|
(get-text-extent dc (min offset s-count)))
|
|
|
|
(def/override (draw [dc<%> dc] [real? x] [real? y]
|
|
[real? left] [real? top] [real? bottom] [real? right]
|
|
[real? dx] [real? dy] [symbol? caret])
|
|
(unless (has-flag? s-flags INVISIBLE)
|
|
(send dc draw-text (replace-nuls (substring s-buffer s-dtext (+ s-dtext s-count))) x y #f)
|
|
(when (eq? (system-type) 'unix)
|
|
(when (send s-style get-underlined)
|
|
(let ([descent (send s-style get-text-descent dc)]
|
|
[h (send s-style get-text-height dc)])
|
|
(let ([y (if (descent . >= . 2)
|
|
(+ y (- h (/ descent 2)))
|
|
(+ y (- h descent)))])
|
|
(send dc draw-line x y (+ x str-w) y)))))))
|
|
|
|
(def/override (split [exact-nonnegative-integer? position] [box? first] [box? second])
|
|
(let ([count s-count])
|
|
(unless (or (position . < . 0)
|
|
(position . > . count))
|
|
(let ([snip (make-object string-snip% position)])
|
|
|
|
(set! str-w -1.0)
|
|
|
|
(let ([s (string-snip-buffer snip)])
|
|
(unless ((string-length s) . >= . position)
|
|
(set-string-snip-buffer! s (make-string position))))
|
|
|
|
(string-copy! (string-snip-buffer snip)
|
|
0
|
|
s-buffer
|
|
s-dtext
|
|
(+ position s-dtext))
|
|
(set-snip-count! snip position)
|
|
(set! s-dtext (+ s-dtext position))
|
|
|
|
(let ([count (- count position)])
|
|
(set! s-count count)
|
|
|
|
(when ((string-length s-buffer) . > . (max MIN-WASTE-CHECK (* MAX-WASTE (add1 count))))
|
|
(let ([s (make-string count)])
|
|
(string-copy! s 0 s-buffer s-dtext (+ s-dtext count))
|
|
(set! s-dtext 0)
|
|
(set! s-buffer s))))
|
|
|
|
(set-box! first snip)
|
|
(set-box! second this)
|
|
|
|
(when (and s-admin (not (has-flag? s-flags CAN-SPLIT)))
|
|
(send s-admin resized this #t))))))
|
|
|
|
(def/override (merge-with [snip% pred])
|
|
(set! str-w -1.0)
|
|
(insert-with-offset (string-snip-buffer pred)
|
|
(snip->count pred)
|
|
(string-snip-dtext pred)
|
|
0)
|
|
(when (not (has-flag? s-flags CAN-SPLIT))
|
|
(send s-admin resized this #t))
|
|
this)
|
|
|
|
(define/public (insert-with-offset s len delta pos)
|
|
(unless (or (len . <= . 0)
|
|
(pos . < . 0))
|
|
(let ([count s-count])
|
|
(cond
|
|
[((string-length s-buffer) . < . (+ count len))
|
|
(let ([s (make-string (* 2 (+ count len)))])
|
|
(string-copy! s 0 s-buffer s-dtext (+ s-dtext count))
|
|
(set! s-buffer s)
|
|
(set! s-dtext 0))]
|
|
[((+ s-dtext count len) . > . (string-length s-buffer))
|
|
(string-copy! s-buffer 0 s-buffer s-dtext (+ s-dtext count))
|
|
(set! s-dtext 0)])
|
|
|
|
(when (pos . < . count)
|
|
(string-copy! s-buffer (+ s-dtext pos len)
|
|
s-buffer (+ s-dtext pos)
|
|
(+ s-dtext count)))
|
|
(string-copy! s-buffer
|
|
(+ s-dtext pos)
|
|
s
|
|
delta
|
|
(+ delta len))
|
|
(set! s-count (+ count len))
|
|
(set! str-w -1.0)
|
|
(when (not (has-flag? s-flags CAN-SPLIT))
|
|
(when s-admin
|
|
(unless (send s-admin recounted this #t)
|
|
(set! s-count count)))))))
|
|
|
|
(def/public (insert [string? str] [exact-nonnegative-integer? len]
|
|
[exact-nonnegative-integer? [pos 0]])
|
|
(insert-with-offset str len 0 pos))
|
|
|
|
(def/override (get-text! [mutable-string? s] [exact-nonnegative-integer? offset]
|
|
[exact-integer? num] [exact-nonnegative-integer? dt])
|
|
(when (positive? num)
|
|
(string-copy! s dt s-buffer (+ s-dtext offset) (+ s-dtext (min (+ offset num) s-count)))))
|
|
|
|
(def/override (get-text [exact-nonnegative-integer? offset] [exact-integer? num]
|
|
[any? [flat? #f]])
|
|
(let ([num (min num (max 0 (- s-count offset)))])
|
|
(if (num . <= . 0)
|
|
""
|
|
(let ([s (make-string num)])
|
|
(get-text! s offset num 0)
|
|
s))))
|
|
|
|
(def/override (copy)
|
|
(let ([snip (new string-snip%)])
|
|
(do-copy-to snip)
|
|
snip))
|
|
|
|
(def/override (do-copy-to [snip% snip])
|
|
(super do-copy-to snip)
|
|
(set-snip-count! snip 0)
|
|
(send snip insert-with-offset s-buffer s-count s-dtext 0))
|
|
|
|
(def/override (write [editor-stream-out% f])
|
|
(let* ([write-flags s-flags]
|
|
[write-flags (remove-flag write-flags OWNED)]
|
|
[write-flags (remove-flag write-flags CAN-DISOWN)]
|
|
[write-flags (remove-flag write-flags CAN-SPLIT)])
|
|
(send f put write-flags)
|
|
(let ([bytes (string->bytes/utf-8 s-buffer 0 s-dtext (+ s-dtext s-count))])
|
|
(send f put (bytes-length bytes) bytes))))
|
|
|
|
(def/public (read [exact-nonnegative-integer? len]
|
|
[editor-stream-in% f])
|
|
(s-read len f))
|
|
|
|
(define/public (s-read len f)
|
|
(unless (len . < . 0) ; tolerate a 0-length snip, to be filtered out later
|
|
(when ((string-length s-buffer) . < . len)
|
|
(set! s-buffer (make-string (* 2 len))))
|
|
(set! s-dtext 0)
|
|
(let ([rv (send f do-reading-version the-string-snip-class)])
|
|
(cond
|
|
[(not (= rv 2))
|
|
;; read latin-1 (version < 2) or utf-8 (version > 2)
|
|
(let ([b (make-bytes len)]
|
|
[l2 (box len)])
|
|
(send f get-unterminated-bytes! l2 b)
|
|
(let ([len (unbox l2)]
|
|
[s (if (rv . < . 2)
|
|
(bytes->string/latin-1 b #\? 0 len)
|
|
(bytes->string/utf-8 b #\? 0 len))])
|
|
(string-copy! s-buffer 0 s 0 (string-length s))
|
|
(set! s-count (string-length s))))]
|
|
[else
|
|
;; version 2 wrote out UTF-32 directly -- bad idea,
|
|
;; because it uses the machine's endianness.
|
|
(let ([b (make-bytes (* len 4))]
|
|
[l2 (box len)]
|
|
[big? (system-big-endian?)])
|
|
(send f get-unterminated-bytes! len b)
|
|
(let ([len (unbox l2)])
|
|
(for ([i (in-range len)])
|
|
(let ([c (integer-bytes->integer b #f big? (* i 4) (* (add1 i) 4))])
|
|
(string-set! s-buffer i (char->integer c))))))]))
|
|
(set! str-w -1.0))))
|
|
|
|
(define string-snip-buffer (class-field-accessor string-snip% s-buffer))
|
|
(define string-snip-dtext (class-field-accessor string-snip% s-dtext))
|
|
(define set-string-snip-buffer! (class-field-mutator string-snip% s-buffer))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(defclass tab-snip-class% string-snip-class%
|
|
(inherit set-classname
|
|
set-version
|
|
s-read)
|
|
(inherit-field s-required?)
|
|
|
|
(super-new)
|
|
|
|
(set-classname "wxtab")
|
|
(set-version 1)
|
|
(set! s-required? #t)
|
|
|
|
(def/override (read [editor-stream-in% f])
|
|
(let ([ts (new tab-snip%)])
|
|
(s-read ts f))))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(defclass tab-snip% string-snip%
|
|
(inherit-field s-snipclass
|
|
s-flags
|
|
s-admin
|
|
str-w)
|
|
(inherit set-str-w
|
|
set-s-snipclass
|
|
do-copy-to)
|
|
|
|
(super-new)
|
|
|
|
(set-s-snipclass the-tab-snip-class)
|
|
(set! s-flags (remove-flag (add-flag s-flags WIDTH-DEPENDS-ON-X)
|
|
CAN-APPEND))
|
|
|
|
(def/override (get-extent [dc<%> dc] [real? ex] [real? ey]
|
|
[maybe-box? [wi #f]] [maybe-box? [h #f]]
|
|
[maybe-box? [descent #f]] [maybe-box? [space #f]]
|
|
[maybe-box? [lspace #f]] [maybe-box? [rspace #f]])
|
|
(let* ([old-w str-w]
|
|
[changed? (old-w . < . 0)])
|
|
(super get-extent dc ex ey wi h descent space lspace rspace)
|
|
|
|
(when changed?
|
|
;; w is now width of a space
|
|
(let* ([admin s-admin]
|
|
[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?))
|
|
(values n
|
|
tabs
|
|
space
|
|
(if units?
|
|
1
|
|
(if (zero? str-w)
|
|
1.0
|
|
str-w))))
|
|
(values 0
|
|
#()
|
|
TAB-WIDTH
|
|
1))])
|
|
(set-str-w
|
|
(let loop ([i 0])
|
|
(if (= i n)
|
|
(let ([base (if (zero? n)
|
|
0
|
|
(vector-ref tabs (- n 1)))])
|
|
(let ([tabspace (* tabspace mult)])
|
|
(+ base (- (->long tabspace)
|
|
(modulo (->long (- ex base))
|
|
(->long tabspace))))))
|
|
(let ([v (vector-ref tabs i)])
|
|
(if ((* mult v) . > . ex)
|
|
(- (* mult v) ex)
|
|
(loop (add1 i))))))))))
|
|
|
|
(when wi (set-box! wi str-w))))
|
|
|
|
(def/override (partial-offset [dc<%> dc] [real? x] [real? y]
|
|
[exact-nonnegative-integer? offset])
|
|
(if (zero? offset)
|
|
0.0
|
|
(let-boxes ([w 0.0])
|
|
(get-extent dc x y w #f #f #f #f #f)
|
|
w)))
|
|
|
|
(def/override (draw [dc<%> dc] [real? x] [real? y]
|
|
[real? left] [real? top] [real? bottom] [real? right]
|
|
[real? dx] [real? dy] [symbol? caret])
|
|
;; draw nothing
|
|
(void))
|
|
|
|
(def/override (copy)
|
|
(let ([snip (new tab-snip%)])
|
|
(do-copy-to snip)
|
|
snip)))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define IMG-MOVE-BUF-SIZE 500)
|
|
|
|
(define (int->img-type type)
|
|
(case type
|
|
[(#x2) 'bmp]
|
|
[(#x8) 'xbm]
|
|
[(#x200) 'xpm]
|
|
[(#x1000) 'gif]
|
|
[(#x11000) 'gif/mask]
|
|
[(#x4000) 'jpeg]
|
|
[(#x8000) 'png]
|
|
[(#x18000) 'png/mask]
|
|
[(#x12000) 'unknown/mask]
|
|
[else 'unknown]))
|
|
|
|
(define (img-type->int type)
|
|
(case type
|
|
[(bmp) #x2]
|
|
[(xbm) #x8]
|
|
[(xpm) #x200]
|
|
[(gif) #x1000]
|
|
[(gif/mask) #x11000]
|
|
[(jpeg) #x4000]
|
|
[(png) #x8000]
|
|
[(png/mask) #x18000]
|
|
[(unknown/mask) #x12000]
|
|
[else #x2000]))
|
|
|
|
(defclass image-snip-class% snip-class%
|
|
(inherit set-classname
|
|
set-version)
|
|
(inherit-field s-required?)
|
|
|
|
(super-new)
|
|
|
|
(set-classname "wximage")
|
|
(set-version 2)
|
|
|
|
(def/override (read [editor-stream-in% f])
|
|
(let ([scl (get-the-snip-class-list)]
|
|
[can-inline? ((send f do-reading-version this) . > . 1)])
|
|
(let ([filename (let ([s (send f get-bytes #f)])
|
|
(subbytes s 0 (max 0 (sub1 (bytes-length s)))))])
|
|
(let-boxes ([type 0]
|
|
[w 0.0]
|
|
[h 0.0]
|
|
[dx 0.0]
|
|
[dy 0.0]
|
|
[relative 0])
|
|
(begin
|
|
(send f get type)
|
|
(send f get w)
|
|
(send f get h)
|
|
(send f get dx)
|
|
(send f get dy)
|
|
(send f get relative))
|
|
|
|
(let-values ([(loadfile
|
|
type
|
|
inlined?
|
|
delfile)
|
|
(if (and (equal? filename #"")
|
|
can-inline?
|
|
(positive? type))
|
|
;; read inlined image
|
|
(let-boxes ([len 0])
|
|
(send f get-fixed len)
|
|
(if (and (len . > . 0)
|
|
(send f ok?))
|
|
(let ([fname (make-temporary-file "img~a")])
|
|
(call-with-output-file*
|
|
fname
|
|
#:exists 'truncate
|
|
(lambda (fi)
|
|
(for ([i (in-range len)])
|
|
(display (send f get-unterminated-bytes) fi))))
|
|
(values fname
|
|
'unknown/mask
|
|
#t
|
|
fname))
|
|
(values filename
|
|
(int->img-type type)
|
|
#f
|
|
#f)))
|
|
(values filename
|
|
(int->img-type type)
|
|
#f
|
|
#f))])
|
|
(let ([snip (make-object image-snip%
|
|
(if (equal? loadfile #"")
|
|
#f
|
|
(if (bytes? loadfile)
|
|
(bytes->path loadfile)
|
|
loadfile))
|
|
type
|
|
(positive? relative)
|
|
inlined?)])
|
|
(when delfile
|
|
(delete-file delfile))
|
|
(send snip resize w h)
|
|
(send snip set-offset dx dy)
|
|
|
|
snip)))))))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
;; old implementation prevented bitmap modifications while installed
|
|
;; in an image snip
|
|
(define (marked-as-selected? bm) #f)
|
|
(define (mark-as-selected bm) (void))
|
|
(define (unmark-as-selected bm) (void))
|
|
|
|
(define black-color (make-object color% 0 0 0))
|
|
|
|
(defclass* image-snip% internal-snip% (equal<%>)
|
|
(inherit-field s-admin
|
|
s-flags)
|
|
(inherit set-snipclass)
|
|
|
|
(init-rest args)
|
|
|
|
(super-new)
|
|
|
|
(define filename #f)
|
|
(define filetype 0) ; file != #f => type of file, otherwise loaded 1 => XBM and 2 => XPM
|
|
(define bm #f)
|
|
(define mask #f)
|
|
(define is-relative-path? #f)
|
|
|
|
(define w 0.0)
|
|
(define h 0.0)
|
|
(define vieww -1.0)
|
|
(define viewh -1.0)
|
|
(define viewdx 0.0)
|
|
(define viewdy 0.0)
|
|
(define contents-changed? #f)
|
|
|
|
(set-snipclass the-image-snip-class)
|
|
|
|
(case-args
|
|
args
|
|
[([bitmap% bm] [(make-or-false bitmap%) [mask #f]])
|
|
(set-bitmap bm mask)]
|
|
[([(make-or-false path-string?) [name #f]]
|
|
[(symbol-in unknown unknown/mask gif gif/mask
|
|
jpeg png png/mask
|
|
xbm xpm bmp pict)
|
|
[kind 'unknown]]
|
|
[bool? [relative-path? #f]]
|
|
[bool? [inline? #t]])
|
|
(load-file name kind relative-path? inline?)]
|
|
(init-name 'bitmap%))
|
|
|
|
(define (size-cache-invalid)
|
|
(set! contents-changed? #t))
|
|
|
|
(def/override (get-extent [dc<%> dc] [real? ex] [real? ey]
|
|
[maybe-box? [wi #f]] [maybe-box? [hi #f]]
|
|
[maybe-box? [descent #f]] [maybe-box? [space #f]]
|
|
[maybe-box? [lspace #f]] [maybe-box? [rspace #f]])
|
|
(when contents-changed?
|
|
(let-values ([(_w _h)
|
|
(if (and bm (send bm ok?))
|
|
(values
|
|
(if (vieww . < . 0)
|
|
(send bm get-width)
|
|
vieww)
|
|
(if (viewh . < . 0)
|
|
(send bm get-height)
|
|
viewh))
|
|
(values 0 0))])
|
|
(set! w (if (zero? _w)
|
|
IMAGE-VOID-SIZE
|
|
_w))
|
|
(set! h (if (zero? _h)
|
|
IMAGE-VOID-SIZE
|
|
_h))))
|
|
(when wi (set-box! wi w))
|
|
(when hi (set-box! hi h))
|
|
(when descent
|
|
(if (or (not bm)
|
|
(not (send bm ok?)))
|
|
(set-box! descent 1.0)
|
|
(set-box! descent 0.0)))
|
|
(when space (set-box! space 0.0))
|
|
(when lspace (set-box! lspace 0.0))
|
|
(when rspace (set-box! rspace 0.0)))
|
|
|
|
(def/override (draw [dc<%> dc] [real? x] [real? y]
|
|
[real? left] [real? top] [real? bottom] [real? right]
|
|
[real? dx] [real? dy] [symbol? caret])
|
|
(if (or (not bm)
|
|
(not (send bm ok?)))
|
|
(begin
|
|
(send dc draw-rectangle
|
|
(+ x 1) (+ y 1)
|
|
(- w 2) (- h 2))
|
|
(send dc draw-line
|
|
(+ x 1) (+ y 1)
|
|
(+ x w -2) (+ y h -2))
|
|
(send dc draw-line
|
|
(+ x 1) (+ y h -2)
|
|
(+ x w -2) (+ y 1)))
|
|
(let ([msk (or mask
|
|
(let ([mask (send bm get-loaded-mask)])
|
|
(and mask
|
|
(send mask ok?)
|
|
(= w (send mask get-width))
|
|
(= w (send mask get-height))
|
|
mask)))])
|
|
(send dc draw-bitmap-section bm x y 0 0 w h
|
|
'solid black-color msk))))
|
|
|
|
(def/override (copy)
|
|
(let ([s (new image-snip%)])
|
|
(do-copy-to s)
|
|
s))
|
|
|
|
(def/override (write [editor-stream-out% f])
|
|
(send f put (if (path? filename)
|
|
(path->bytes filename)
|
|
#""))
|
|
(let ([write-mode
|
|
(if filename
|
|
(begin
|
|
(send f put (img-type->int filetype))
|
|
#f)
|
|
(cond
|
|
[(not bm) (send f put 0) #f]
|
|
[(= (send bm get-depth) 1)
|
|
(send f put 1)
|
|
'bm]
|
|
[else
|
|
(send f put 2)
|
|
'pm]))])
|
|
(send f put vieww)
|
|
(send f put viewh)
|
|
(send f put viewdx)
|
|
(send f put viewdy)
|
|
(send f put (if is-relative-path? 1 0))
|
|
|
|
(when write-mode
|
|
;; inline the image
|
|
(let ([lenpos (send f tell)])
|
|
(send f put-fixed 0)
|
|
|
|
(let ([num-lines
|
|
(let ([fname (make-temporary-file "img~a")])
|
|
(send bm save-file fname 'png)
|
|
(begin0
|
|
(call-with-input-file*
|
|
fname
|
|
(lambda (fi)
|
|
(let loop ([numlines 0])
|
|
(let ([s (read-bytes IMG-MOVE-BUF-SIZE fi)])
|
|
(if (eof-object? s)
|
|
numlines
|
|
(begin
|
|
(send f put-unterminated s)
|
|
(loop (add1 numlines))))))))
|
|
(delete-file fname)))])
|
|
|
|
(let ([end (send f tell)])
|
|
(send f jump-to lenpos)
|
|
(send f put-fixed num-lines)
|
|
(send f jump-to end)))))))
|
|
|
|
(def/public (load-file [(make-or-false path-string?) [name #f]]
|
|
[(symbol-in unknown unknown/mask gif gif/mask
|
|
jpeg png png/mask
|
|
xbm xpm bmp pict)
|
|
[kind 'unknown]]
|
|
[bool? [rel-path? #f]]
|
|
[bool? [inline? #t]])
|
|
(do-set-bitmap #f #f #f)
|
|
|
|
(let* ([rel-path? (and rel-path?
|
|
name
|
|
(relative-path? name))]
|
|
[name (if rel-path?
|
|
name
|
|
(and name (path->complete-path name)))])
|
|
(set! s-flags
|
|
(if rel-path?
|
|
(add-flag s-flags USES-BUFFER-PATH)
|
|
(remove-flag s-flags USES-BUFFER-PATH)))
|
|
|
|
(let ([name (and name (if (string? name)
|
|
(string->path name)
|
|
name))])
|
|
(unless inline?
|
|
(set! filename name)
|
|
(set! filetype kind))
|
|
|
|
(when name
|
|
(let ([fullpath (if rel-path?
|
|
(path->complete-path
|
|
name
|
|
(or (and s-admin
|
|
(let ([e (send s-admin get-editor)])
|
|
(and e
|
|
(let ([fn (send e get-filename)])
|
|
(and fn
|
|
(let-values ([(base name dir?) (split-path fn)])
|
|
(and (path? base)
|
|
(path->complete-path base))))))))
|
|
(current-directory)))
|
|
name)])
|
|
(let ([nbm (dynamic-wind
|
|
begin-busy-cursor
|
|
(lambda ()
|
|
(make-object bitmap% fullpath kind))
|
|
end-busy-cursor)])
|
|
(when (send nbm ok?)
|
|
(do-set-bitmap nbm #f #f))))))
|
|
;; for refresh:
|
|
(set-bitmap bm mask)))
|
|
|
|
(define/override (do-copy-to d)
|
|
(if (d . is-a? . snip%)
|
|
((send d do-copy-to #f)
|
|
filename
|
|
filetype
|
|
is-relative-path?
|
|
vieww
|
|
viewh
|
|
viewdx
|
|
viewdy
|
|
bm mask)
|
|
(lambda (-filename -filetype -relative-path?
|
|
-vieww -viewh -viewdx -viewdy
|
|
-bm -mask)
|
|
(set! filename -filename)
|
|
(set! filetype -filetype)
|
|
(set! is-relative-path? -relative-path?)
|
|
(set! vieww -vieww)
|
|
(set! viewh -viewh)
|
|
(set! viewdx -viewdx)
|
|
(set! viewdy -viewdy)
|
|
(set! bm -bm)
|
|
(set! mask -mask)
|
|
(mark-as-selected bm)
|
|
(mark-as-selected mask))))
|
|
|
|
(def/public (get-filename [maybe-box? [rel? #f]])
|
|
(when rel?
|
|
(set-box! rel? (and filename is-relative-path?)))
|
|
filename)
|
|
|
|
(def/public (get-filetype)
|
|
(if filename
|
|
filetype
|
|
'unknown))
|
|
|
|
(def/public (set-bitmap [(make-or-false bitmap%) map]
|
|
[(make-or-false bitmap%) [msk #f]])
|
|
(do-set-bitmap map msk #t))
|
|
|
|
(define/private (do-set-bitmap map msk refresh?)
|
|
(unless (or (marked-as-selected? map)
|
|
(marked-as-selected? msk))
|
|
(unmark-as-selected bm)
|
|
(unmark-as-selected mask)
|
|
|
|
(set! bm #f)
|
|
(set! mask #f)
|
|
|
|
(let ([map (and map (send map ok?) map)]
|
|
[msk (and msk (send msk ok?) msk)])
|
|
(set! bm map)
|
|
(set! mask msk)
|
|
|
|
(mark-as-selected bm)
|
|
(mark-as-selected msk))
|
|
|
|
(when refresh?
|
|
(set! contents-changed? #t)
|
|
(when s-admin
|
|
(send s-admin resized this #t)))))
|
|
|
|
(def/public (get-bitmap)
|
|
bm)
|
|
|
|
(def/public (get-bitmap-mask)
|
|
mask)
|
|
|
|
(def/public (equal-to? [image-snip% other] [any? recur])
|
|
(send other other-equal-to? this recur))
|
|
|
|
(def/public (other-equal-to? [image-snip% other] [any? recur])
|
|
(let* ([bm (send this get-bitmap)]
|
|
[bm2 (send other get-bitmap)])
|
|
(and
|
|
bm (send bm ok?)
|
|
bm2 (send bm ok?)
|
|
(= (send bm get-depth) (send bm2 get-depth))
|
|
(let ([w (send bm get-width)]
|
|
[h (send bm get-height)])
|
|
(and
|
|
(= w (send bm2 get-width))
|
|
(= h (send bm2 get-height))
|
|
(let ([s1 (make-bytes (* w h 4))]
|
|
[s2 (make-bytes (* w h 4))])
|
|
(send bm get-argb-pixels 0 0 w h s1 #f)
|
|
(send bm2 get-argb-pixels 0 0 w h s2 #f)
|
|
(let ([mask (send this get-bitmap-mask)])
|
|
(when (and mask
|
|
(send mask ok?)
|
|
(= w (send mask get-width))
|
|
(= h (send mask get-height)))
|
|
(send mask get-argb-pixels 0 0 w h s1 #t)))
|
|
(let ([mask2 (send other get-bitmap-mask)])
|
|
(when (and mask2
|
|
(send mask2 ok?)
|
|
(= w (send mask2 get-width))
|
|
(= h (send mask2 get-height)))
|
|
(send mask2 get-argb-pixels 0 0 w h s2 #t)))
|
|
(equal? s1 s2)))))))
|
|
|
|
(define/private (do-hash-code hash-code)
|
|
(if (and bm
|
|
(send bm ok?))
|
|
(let ([w (send bm get-width)]
|
|
[h (send bm get-height)])
|
|
(let ([s1 (make-bytes (* w h 4))])
|
|
(send bm get-argb-pixels 0 0 w h s1 #f)
|
|
(when (and mask
|
|
(send mask ok?)
|
|
(= w (send mask get-width))
|
|
(= h (send mask get-height)))
|
|
(send mask get-argb-pixels 0 0 w h s1 #t))
|
|
(hash-code s1)))
|
|
0))
|
|
|
|
(def/public (equal-hash-code-of [any? recur])
|
|
(do-hash-code equal-hash-code))
|
|
(def/public (equal-secondary-hash-code-of [any? recur])
|
|
(do-hash-code equal-secondary-hash-code))
|
|
|
|
(def/public (set-offset [real? x] [real? y])
|
|
(set! viewdx x)
|
|
(set! viewdy y)
|
|
(set! contents-changed? #t)
|
|
(when s-admin
|
|
(send s-admin needs-update this 0 0 w h)))
|
|
|
|
(def/override (resize [real? w] [real? h])
|
|
(set! vieww w)
|
|
(set! viewh h)
|
|
(set! contents-changed? #t)
|
|
(when s-admin
|
|
(send s-admin resized this #t))
|
|
#t)
|
|
|
|
(def/override (get-num-scroll-steps)
|
|
(max (->long (/ h IMAGE-PIXELS-PER-SCROLL))
|
|
1))
|
|
|
|
(def/override (find-scroll-step [real? y])
|
|
(->long (/ y IMAGE-PIXELS-PER-SCROLL)))
|
|
|
|
(def/override (get-scroll-step-offset [exact-integer? i])
|
|
(* i IMAGE-PIXELS-PER-SCROLL))
|
|
|
|
(def/override (set-admin [(make-or-false snip-admin%) a])
|
|
(when (not (eq? a s-admin))
|
|
(super set-admin a))
|
|
(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))))))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(defclass snip-class-list% object%
|
|
(define ht (make-hash))
|
|
(define pos-ht (make-hash))
|
|
(define rev-pos-ht (make-hash))
|
|
|
|
(super-new)
|
|
|
|
(def/public (find [string? name])
|
|
(let ([c (hash-ref ht name #f)])
|
|
(or c
|
|
(let ([c (get-snip-class name)])
|
|
(when c (add c))
|
|
c))))
|
|
|
|
(def/public (find-position [snip-class% c])
|
|
(hash-ref pos-ht c -1))
|
|
|
|
(def/public (add [snip-class% c])
|
|
(let ([name (send c get-classname)])
|
|
(let ([old (hash-ref ht name #f)])
|
|
(hash-set! ht name c)
|
|
(let ([n (if old
|
|
(hash-ref pos-ht old)
|
|
(hash-count pos-ht))])
|
|
(when old (hash-remove! pos-ht old))
|
|
(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)))
|
|
|
|
(define snip-class-list<%> (class->interface snip-class-list%))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(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))
|
|
|
|
(defclass standard-snip-class-list% snip-class-list%
|
|
(inherit add
|
|
number
|
|
nth
|
|
find)
|
|
(super-new)
|
|
|
|
(add the-string-snip-class)
|
|
(add the-tab-snip-class)
|
|
(add the-editor-snip-class)
|
|
(add the-image-snip-class)
|
|
|
|
(define/public (reset-header-flags s)
|
|
(send s set-sl null)
|
|
(send s set-dl null))
|
|
|
|
(def/public (write [editor-stream-out% f])
|
|
(let ([n (number)])
|
|
(send f put n)
|
|
(for ([i (in-range n)])
|
|
(let ([c (nth i)])
|
|
(send f put (string->bytes/utf-8 (send c get-classname)))
|
|
(send f put (send c get-version))
|
|
(send f put (if (send c get-s-required?) 1 0))
|
|
|
|
(send f add-sl (make-snip-class-link c
|
|
#f
|
|
0
|
|
i
|
|
0)))))
|
|
#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)])
|
|
(let-boxes ([version 0]
|
|
[required 0])
|
|
(begin
|
|
(send f get version)
|
|
(send f get required))
|
|
(and (send f ok?)
|
|
(send f add-sl (make-snip-class-link
|
|
#f
|
|
(bytes->string/utf-8 s #\?)
|
|
0
|
|
i
|
|
version))
|
|
#t))))))
|
|
|
|
(define/public (find-by-map-position f n)
|
|
(ormap (lambda (s)
|
|
(and (= n (snip-class-link-map-position s))
|
|
(begin
|
|
(when (snip-class-link-name s)
|
|
(let ([c (find (snip-class-link-name s))])
|
|
(cond
|
|
[(not c)
|
|
(log-error (format "unknown snip class: ~e (version: ~e)"
|
|
(snip-class-link-name s)
|
|
(snip-class-link-reading-version s)))]
|
|
[((send c get-version) . < . (snip-class-link-reading-version s))
|
|
;; unknown class/version;
|
|
;; since we #f out sl->name, error is only shown once
|
|
(log-error (format "unknown snip class: ~e; found version: ~e, need at least version ~e"
|
|
(snip-class-link-name s)
|
|
(send c get-version)
|
|
(snip-class-link-reading-version s)))]
|
|
[else
|
|
;; no prolems
|
|
(void)])
|
|
(set-snip-class-link-name! s #f)
|
|
(set-snip-class-link-c! s c)))
|
|
(snip-class-link-c s))))
|
|
(send f get-sl))))
|
|
|
|
(define (make-the-snip-class-list)
|
|
(new standard-snip-class-list%))
|
|
|
|
(define the-snip-class-list (make-parameter (make-the-snip-class-list)))
|
|
|
|
(define (get-the-snip-class-list)
|
|
(the-snip-class-list))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(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))
|
|
(define snip->prev (class-field-accessor snip% s-prev))
|
|
(define snip->flags (class-field-accessor snip% s-flags))
|
|
(define snip->line (class-field-accessor snip% s-line))
|
|
(define snip->style (class-field-accessor snip% s-style))
|
|
(define snip->snipclass (class-field-accessor snip% s-snipclass))
|
|
|
|
(define set-snip-admin! (class-field-mutator snip% s-admin))
|
|
(define set-snip-line! (class-field-mutator snip% s-line))
|
|
(define set-snip-style! (class-field-mutator snip% s-style))
|
|
(define set-snip-flags! (class-field-mutator snip% s-flags))
|
|
(define set-snip-count! (class-field-mutator snip% s-count))
|
|
(define set-snip-prev! (class-field-mutator snip% s-prev))
|
|
(define set-snip-next! (class-field-mutator snip% s-next))
|
|
|
|
(define snip%-get-text (generic snip% get-text))
|