#lang scheme/base (require scheme/class scheme/port scheme/file "../syntax.ss" "const.ss" "private.ss" racket/snip/private/private "editor.ss" "editor-data.rkt" "undo.ss" racket/snip racket/snip/private/snip-flags "standard-snip-admin.rkt" "keymap.ss" (only-in "cycle.ss" printer-dc% set-pasteboard%!) "wordbreak.ss" "stream.ss" "wx.ss") (provide pasteboard% add-pasteboard-keymap-functions) ;; ---------------------------------------- (define LINE-HEIGHT 16.0) (define DOT-WIDTH 5.0) (define HALF-DOT-WIDTH 2.0) (define (inbox? lx x) (and ((- lx HALF-DOT-WIDTH) . <= . x) ((+ (- lx HALF-DOT-WIDTH) DOT-WIDTH) . >= . x))) (define black-brush (send the-brush-list find-or-create-brush "black" 'xor)) (define white-brush (send the-brush-list find-or-create-brush "white" 'solid)) (define invisi-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) (define invisi-brush (send the-brush-list find-or-create-brush "black" 'transparent)) (define rb-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'xor-dot)) (define rb-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) (define arrow (make-object cursor% 'arrow)) ;; ---------------------------------------- (define-struct loc (x y w h r b hm vm startx starty selected? need-resize? snip) #:mutable) ;; ---------------------------------------- (defclass pasteboard% editor% (inherit-field s-admin s-custom-cursor s-custom-cursor-overrides? s-own-caret? s-caret-snip s-keymap s-style-list s-noundomode s-modified? s-offscreen s-filename s-temp-filename? s-user-locked? s-need-on-display-size?) (inherit on-change get-default-style set-modified on-paint wait-sequence-lock begin-sequence-lock end-sequence-lock do-own-caret on-focus scroll-editor-to do-set-caret-owner install-copy-buffer begin-copy-buffer end-copy-buffer free-old-copies do-write-headers-footers read-snips-from-file do-own-x-selection do-buffer-paste add-undo-rec get-dc on-local-event on-local-char on-edit-sequence after-edit-sequence on-display-size) (define dragable? #t) (define selection-visible? #t) (define snips #f) (define last-snip #f) (define snip-location-list (make-hasheq)) (define/private (snip-loc snip) (hash-ref snip-location-list snip #f)) (define snip-admin (new standard-snip-admin% [editor this])) (define last-time 0) (define start-x 0.0) (define start-y 0.0) (define last-x 0.0) (define last-y 0.0) (define orig-x 0.0) (define orig-y 0.0) (define orig-w 0.0) (define orig-h 0.0) (define max-width 'none) (define min-width 'none) (define max-height 'none) (define min-height 'none) (define keep-size? #f) (define dragging? #f) (define rubberband? #f) (define rb-x 0.0) (define rb-y 0.0) (define rb-w 0.0) (define rb-h 0.0) (define need-resize? #f) (define resizing #f) ; a snip (define sizedxm 0.0) (define sizedym 0.0) (define scroll-step LINE-HEIGHT) (define total-width 0.0) (define total-height 0.0) (define real-width 0.0) (define real-height 0.0) (define update-left 0.0) (define update-right 0.0) (define update-right-end #f) (define update-top 0.0) (define update-bottom 0.0) (define update-bottom-end #f) (define update-nonempty? #f) (define no-implicit-update? #f) (define size-cache-invalid? #f) (define write-locked 0) (define flow-locked? #f) (define sequence 0) (define delayedscrollbias 'none) (define delayedscrollsnip #f) (define delayedscroll-x 0.0) (define delayedscroll-y 0.0) (define delayedscroll-w 0.0) (define delayedscroll-h 0.0) (define sequence-streak? #f) (define changed? #f) (define prev-mouse-snip #f) (super-new) ;; ---------------------------------------- (define/private (rubber-band-update x y w h) (when (and s-admin (not (zero? w)) (not (zero? h))) (let-values ([(x w) (if (w . < . 0) (values (+ x w) (- w)) (values x w))] [(y h) (if (h . < . 0) (values (+ y h) (- h)) (values y h))]) (let ([r (+ x w)] [b (+ y h)]) (let-boxes ([vx 0.0] [vy 0.0] [vw 0.0] [vh 0.0]) (send s-admin get-view vx vy vw vh) (let ([x (max x vx)] [y (max y vy)] [r (min r (+ vx vw))] [b (min b (+ vy vh))]) (unless (or (x . >= . r) (y . >= . b)) (set! rb-x x) (set! rb-y y) (set! rb-w (- r x)) (set! rb-h (- b y)) (update rb-x rb-y rb-w rb-h)))))))) (def/override (adjust-cursor [mouse-event% event]) (if (not s-admin) #f (let-boxes ([scrollx 0.0] [scrolly 0.0] [dc #f]) (set-box! dc (send s-admin get-dc scrollx scrolly)) (if (not dc) #f (let ([x (+ (send event get-x) scrollx)] [y (+ (send event get-y) scrolly)]) (or (and (not s-custom-cursor-overrides?) (or (and s-caret-snip (send event dragging?) (let-boxes ([x 0.0] [y 0.0]) (get-snip-location s-caret-snip x y) (let ([c (send s-caret-snip adjust-cursor dc (- x scrollx) (- y scrolly) x y event)]) c))) ;; find snip: (let ([snip (find-snip x y)]) (and snip (eq? snip s-caret-snip) (let-boxes ([x 0.0] [y 0.0]) (get-snip-location snip x y) (let ([c (send snip adjust-cursor dc (- x scrollx) (- y scrolly) x y event)]) c)))))) s-custom-cursor arrow)))))) (def/override (on-event [mouse-event% event]) (when s-admin (let-values ([(dc x y scrollx scrolly) ;; first, find clicked-on snip: (let ([x (send event get-x)] [y (send event get-y)]) (let-boxes ([scrollx 0.0] [scrolly 0.0] [dc #f]) (set-box! dc (send s-admin get-dc scrollx scrolly)) ;; FIXME: old code returned if !dc (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))]) (let ([snip (find-snip x y)]) (when (and prev-mouse-snip (not (eq? snip prev-mouse-snip))) (let ([loc (snip-loc prev-mouse-snip)]) (send prev-mouse-snip on-event dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly) (loc-x loc) (loc-y loc) event))) (set! prev-mouse-snip #f) (when (and snip (has-flag? (snip->flags snip) HANDLES-ALL-MOUSE-EVENTS) (not (eq? snip s-caret-snip))) (let ([loc (snip-loc snip)]) (set! prev-mouse-snip snip) (send snip on-event dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly) (loc-x loc) (loc-y loc) event))) (if (and s-caret-snip (or (not (send event button-down?)) (eq? snip s-caret-snip))) (let ([loc (snip-loc s-caret-snip)]) (send s-caret-snip on-event dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly) (loc-x loc) (loc-y loc) event)) (on-local-event event)))))) (def/override (on-default-event [mouse-event% event]) (when s-admin (let-boxes ([scrollx 0.0] [scrolly 0.0] [dc #f]) (set-box! dc (send s-admin get-dc scrollx scrolly)) (when dc (let-boxes ([x (+ (send event get-x) scrollx)] [y (+ (send event get-y) scrolly)]) (interactive-adjust-mouse x y) (when (or (send event button-down?) (and (send event moving?) (not (send event dragging?))) (send event button-up?)) (set! keep-size? #f) (when dragging? (if resizing (begin (begin-edit-sequence) ;; move & resize back without undo (when (or (sizedxm . < . 0.0) (sizedym . < . 0.0)) (move-to resizing orig-x orig-y)) (resize resizing orig-w orig-h) (set! dragging? #f) ;; re-move and re-size with undo: (do-event-resize last-x last-y) (after-interactive-resize resizing) (end-edit-sequence) (set! resizing #f)) (finish-dragging event))) (when rubberband? (set! rubberband? #f) (rubber-band-update start-x start-y (- last-x start-x) (- last-y start-y)) (add-selected start-x start-y (- last-x start-x) (- last-y start-y)) (update-all))) (if (or (send event button-down?) (and (send event dragging?) (not dragging?) (not rubberband?))) (let ([snip (find-snip x y)]) (if dragable? (begin (if snip (let ([loc (snip-loc snip)]) (set! orig-x (loc-x loc)) (set! orig-y (loc-y loc)) (set! orig-w (loc-w loc)) (set! orig-h (loc-h loc)) (if (not (loc-selected? loc)) (begin (unless (send event get-shift-down) (no-selected)) (set-caret-owner #f) (add-selected snip) (init-dragging event)) (let ([interval (abs (- (send event get-time-stamp) last-time))]) (if (and (send event button-down?) (interval . < . (if s-keymap (send s-keymap get-double-click-interval) (get-double-click-threshold)))) (on-double-click snip event) (let-boxes ([dx sizedxm] [dy sizedym] [f? #f]) (set-box! f? (find-dot loc x y dx dy)) (set! sizedxm dx) (set! sizedym dy) (when f? (set! resizing snip)) (init-dragging event))))) (when (send event button-down?) (set! last-time (send event get-time-stamp)))) (begin (unless (send event get-shift-down) (no-selected)) (set-caret-owner #f) (set! rubberband? #t))) (set! start-x x) (set! last-x x) (set! start-y y) (set! last-y y)) ;; not dragable: (set-caret-owner snip))) ;; not a new click: (when dragable? (when (send event dragging?) (cond [rubberband? (begin-edit-sequence) ;; erase old (rubber-band-update start-x start-y (- last-x start-x) (- last-y start-y)) ;; draw new: (rubber-band-update start-x start-y (- x start-x) (- y start-y)) (end-edit-sequence)] [resizing (do-event-resize x y)] [else (do-event-move x y)])) (set! last-x x) (set! last-y y)))))))) (def/public (on-double-click [snip% snip] [mouse-event% evt]) (when (has-flag? (snip->flags snip) HANDLES-EVENTS) (no-selected) (set-caret-owner snip))) (def/override (on-char [key-event% event]) (when s-admin (let-boxes ([scrollx 0.0] [scrolly 0.0] [dc #f]) (set-box! dc (send s-admin get-dc scrollx scrolly)) (when dc (let ([x (+ (send event get-x) scrollx)] [y (+ (send event get-y) scrolly)]) (if s-caret-snip (let ([loc (snip-loc s-caret-snip)]) (send s-caret-snip on-char dc (loc-x loc) (loc-y loc) (- x scrollx) (- y scrolly) event)) (on-local-char event))))))) (def/override (on-default-char [key-event% event]) (when s-admin (let ([code (send event get-key-code)]) (case code [(#\rubout #\backspace) (delete)] [(right) (move 1 0)] [(left) (move -1 0)] [(up) (move 0 -1)] [(down) (move 0 1)])))) (define/private (init-dragging e) (define (phase1) (if resizing (if (not (can-interactive-resize? resizing)) (set! resizing #f) (begin (on-interactive-resize resizing) (phase2))) (when (can-interactive-move? e) (on-interactive-move e) (phase2)))) (define (phase2) (set! dragging? #t) (set! keep-size? #t) (let loop ([s #f]) (let ([s (find-next-selected-snip s)]) (when s (let ([loc (snip-loc s)]) (set-loc-startx! loc (loc-x loc)) (set-loc-starty! loc (loc-y loc))) (loop s))))) (phase1)) (define/private (finish-dragging e) (begin-edit-sequence) ;; move back without undo and remember final (let loop ([s #f]) (let ([s (find-next-selected-snip s)]) (when s (let* ([loc (snip-loc s)] [x (loc-startx loc)] [y (loc-starty loc)]) (set-loc-startx! loc (loc-x loc)) (set-loc-starty! loc (loc-y loc)) (move-to s x y)) (loop s)))) (set! dragging? #f) ;; move to final position with undo: (let loop ([s #f]) (let ([s (find-next-selected-snip s)]) (when s (let* ([loc (snip-loc s)]) (move-to s (loc-startx loc) (loc-starty loc))) (loop s)))) (after-interactive-move e) (end-edit-sequence)) (define/private (do-event-move event-x event-y) (let ([dx (- event-x start-x)] [dy (- event-y start-y)]) (begin-edit-sequence) (let loop ([s #f]) (let ([s (find-next-selected-snip s)]) (when s (let ([loc (snip-loc s)]) (let-boxes ([x (+ (loc-startx loc) dx)] [y (+ (loc-starty loc) dy)]) (interactive-adjust-move s x y) (move-to s x y))) (loop s)))) (end-edit-sequence))) (define/private (do-event-resize event-x event-y) (let ([dx (- event-x start-x)] [dy (- event-y start-y)]) (let-boxes ([w (max 0.0 (+ orig-w (* dx sizedxm)))] [h (max 0.0 (+ orig-h (* dy sizedym)))]) (interactive-adjust-resize resizing w h) (let ([w (max 0.0 w)] [h (max 0.0 h)]) (let ([x (+ orig-x (if (sizedxm . < . 0) (- orig-w w) 0.0))] [y (+ orig-y (if (sizedym . < . 0) (- orig-h h) 0.0))]) (begin-edit-sequence) (when (resize resizing w h) (when (or (sizedxm . < . 0) (sizedym . < . 0)) (move-to resizing x y))) (end-edit-sequence)))))) (def/public (interactive-adjust-mouse [(make-box real?) x] [(make-box real?) y]) (set-box! x (max 0.0 (unbox x))) (set-box! y (max 0.0 (unbox y)))) (def/public (interactive-adjust-resize [snip% s] [(make-box real?) w] [(make-box real?) h]) (void)) (def/public (interactive-adjust-move [snip% s][(make-box real?) x] [(make-box real?) y]) (set-box! x (max 0.0 (unbox x))) (set-box! y (max 0.0 (unbox y)))) ;; ---------------------------------------- (def/public (set-selected [snip% snip]) (begin-edit-sequence) (no-selected) (add-selected snip) (end-edit-sequence)) (define/private (do-select snip on?) (let ([loc (snip-loc snip)]) (when (and loc (not (eq? (loc-selected? loc) on?))) (set! write-locked (add1 write-locked)) (if (can-select? snip on?) (begin (on-select snip on?) (set! write-locked (sub1 write-locked)) (set-loc-selected?! loc on?) (after-select snip on?) (update-location loc)) (set! write-locked (sub1 write-locked)))))) (def/public (remove-selected [snip% snip]) (do-select snip #f)) (define/private (add-selected-region x y w h) (let-values ([(x w) (if (w . < . 0) (values (+ x w) (- w)) (values x w))] [(y h) (if (h . < . 0) (values (+ y h) (- h)) (values y h))]) (let ([r (+ x w)] [b (+ y h)]) (begin-edit-sequence) (let loop ([s snips]) (when s (let ([loc (snip-loc s)]) (when (and loc (not (loc-selected? loc)) ((loc-x loc) . <= . r) ((loc-y loc) . <= . b) ((loc-r loc) . >= . x) ((loc-b loc) . >= . y)) (add-selected s))) (loop (snip->next s)))) (end-edit-sequence)))) (define/public (add-selected . args) (case-args args [([real? x] [real? y] [real? w] [real? h]) (add-selected-region x y w h)] [([snip% snip]) (do-select snip #t)] (method-name 'pasteboard% 'add-selected))) (def/override (select-all) (begin-edit-sequence) (let loop ([s snips]) (when s (add-selected s) (loop (snip->next s)))) (end-edit-sequence)) (def/public (no-selected) (begin-edit-sequence) (let loop ([s snips]) (when s (remove-selected s) (loop (snip->next s)))) (end-edit-sequence)) ;; ---------------------------------------- (define/private (do-insert snip before x y) (unless (or s-user-locked? (not (zero? write-locked)) (send snip is-owned?)) (when (not (snip->snipclass snip)) (error (method-name 'pasteboard% 'insert) "cannot insert a snip without a snipclass: ~e" snip)) (set! write-locked (add1 write-locked)) (begin-edit-sequence) (let ([ok? (or (can-insert? snip before x y) (begin (end-edit-sequence) (set! write-locked (sub1 write-locked)) #f))]) (when ok? (on-insert snip before x y) (set! write-locked (sub1 write-locked)) (let ([snip (if (send snip is-owned?) ;; disaster: can/on-insert made the snip owned (new image-snip%) snip)]) (let ([search (and (snip-loc before) before)]) (set-snip-next! snip search) (if search (begin (set-snip-prev! snip (snip->prev search)) (set-snip-prev! search snip)) (begin (set-snip-prev! snip last-snip) (set! last-snip snip))) (if (snip->prev snip) (set-snip-next! (snip->prev snip) snip) (set! snips snip))) (let ([loc (make-loc x y 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 #f #t snip)]) (hash-set! snip-location-list snip loc) (set-snip-style! snip (send s-style-list convert (snip->style snip))) (when (eq? (snip->style snip) (send s-style-list basic-style)) (let ([s (get-default-style)]) (when s (set-snip-style! snip s)))) (send snip size-cache-invalid) (snip-set-admin snip snip-admin) (when (zero? s-noundomode) (let ([is (make-object insert-snip-record% snip sequence-streak?)]) (add-undo-rec is))) (when (positive? sequence) (set! sequence-streak? #t)) (set! changed? #t) (unless s-modified? (set-modified #t)) (set! need-resize? #t) (update-location loc) (set! write-locked (add1 write-locked)) (end-edit-sequence) (set! write-locked (sub1 write-locked)) (when (zero? sequence) (update-needed)) (after-insert snip before x y))))))) (define/override (insert . args) (case-args args [([snip% snip] [(make-or-false snip%) [before #f]]) (let-values ([(x y) (get-center)]) (do-insert snip before x y))] [([snip% snip] [(make-or-false snip%) before] [real? x] [real? y]) (do-insert snip before x y)] [([snip% snip] [real? x] [real? y]) (do-insert snip #f x y)] (method-name 'pasteboard% 'insert))) (define/private (delete-some del?) (unless (or s-user-locked? (not (zero? write-locked))) (let ([del (make-object delete-snip-record% sequence-streak?)]) (when (positive? sequence) (set! sequence-streak? #t)) (begin-edit-sequence) (let loop ([s snips]) (when s (let ([next (snip->next s)]) (when (del? s) (-delete s del)) (loop next)))) (when (zero? s-noundomode) (add-undo-rec del)) (end-edit-sequence)))) (define/public (delete . args) (case-args args [() (delete-some (lambda (s) (loc-selected? (snip-loc s))))] [([snip% s]) (unless (or s-user-locked? (not (zero? write-locked))) (let ([del (make-object delete-snip-record% sequence-streak?)]) (when (positive? sequence) (set! sequence-streak? #t)) (-delete s del) (when (zero? s-noundomode) (add-undo-rec del))))] (method-name 'pasteboard% 'insert))) (def/public (erase) (delete-some (lambda (s) #t))) (define/private (-delete del-snip del) (when (snip-loc del-snip) (when (eq? del-snip prev-mouse-snip) (set! prev-mouse-snip #f)) (set! write-locked (add1 write-locked)) (begin-edit-sequence) (let ([ok? (or (can-delete? del-snip) (begin (end-edit-sequence) (set! write-locked (sub1 write-locked)) #f))]) (and ok? (begin (on-delete del-snip) (set! write-locked (sub1 write-locked)) (let ([update-cursor? (and (eq? del-snip s-caret-snip) (begin (send s-caret-snip own-caret #f) (set! s-caret-snip #f) #t))]) (update-snip del-snip) (if (snip->prev del-snip) (set-snip-next! (snip->prev del-snip) (snip->next del-snip)) (set! snips (snip->next del-snip))) (if (snip->next del-snip) (set-snip-prev! (snip->next del-snip) (snip->prev del-snip)) (set! last-snip (snip->prev del-snip))) (let ([loc (snip-loc del-snip)]) (hash-remove! snip-location-list del-snip) (when del (send del insert-snip del-snip (snip->next del-snip) (loc-x loc) (loc-y loc)))) (set-snip-next! del-snip #f) (set-snip-prev! del-snip #f) (set-snip-flags! del-snip (add-flag (snip->flags del-snip) CAN-DISOWN)) (snip-set-admin del-snip #f) (set-snip-flags! del-snip (remove-flag (snip->flags del-snip) CAN-DISOWN)) (unless del (unless (send del-snip get-admin) (set-snip-flags! del-snip (remove-flag (snip->flags del-snip) OWNED)))) (unless s-modified? (set-modified #t)) (after-delete del-snip) (set! changed? #t) (set! need-resize? #t) (set! write-locked (add1 write-locked)) (end-edit-sequence) (set! write-locked (sub1 write-locked)) (when (zero? sequence) (update-needed)) (when update-cursor? (when s-admin (send s-admin update-cursor))) #t)))))) (def/public (remove [snip% del-snip]) (unless (or s-user-locked? (not (zero? write-locked))) (-delete del-snip #f))) ;; ---------------------------------------- (def/public (move-to [snip% snip] [real? x] [real? y]) (unless (or s-user-locked? (not (zero? write-locked))) (let ([loc (snip-loc snip)]) (when (and loc (not (and (= (loc-x loc) x) (= (loc-y loc) y)))) (set! write-locked (add1 write-locked)) (begin-edit-sequence) (if (not (can-move-to? snip x y dragging?)) (begin (end-edit-sequence) (set! write-locked (sub1 write-locked))) (begin (on-move-to snip x y dragging?) (set! write-locked (sub1 write-locked)) (update-location loc) (unless dragging? (let ([rec (make-object move-snip-record% snip (loc-x loc) (loc-y loc) #f sequence-streak?)]) (when (positive? sequence) (set! sequence-streak? #t)) (when (zero? s-noundomode) (add-undo-rec rec)))) (set-loc-x! loc x) (set-loc-y! loc y) (set-loc-r! loc (+ x (loc-w loc))) (set-loc-b! loc (+ y (loc-h loc))) (set-loc-hm! loc (+ x (/ (loc-w loc) 2))) (set-loc-vm! loc (+ y (/ (loc-h loc) 2))) (update-location loc) (when (and (not dragging?) (not s-modified?)) (set-modified #t)) (after-move-to snip x y dragging?) (set! need-resize? #t) (set! write-locked (add1 write-locked)) (end-edit-sequence) (set! write-locked (sub1 write-locked)) (set! changed? #t) (when (zero? sequence) (update-needed)))))))) (define/public (move . args) (case-args args [([snip% snip] [real? dx] [real? dy]) (unless (or s-user-locked? (not (zero? write-locked))) (let ([loc (snip-loc snip)]) (when loc (move-to snip (+ (loc-x loc) dx) (+ (loc-y loc) dy)))))] [([real? dx] [real? dy]) (unless (or s-user-locked? (not (zero? write-locked))) (begin-edit-sequence) (for ([loc (in-hash-values snip-location-list)]) (when (loc-selected? loc) (move (loc-snip loc) dx dy))) (end-edit-sequence))] (method-name 'pasteboard% 'move))) (def/public (resize [snip% snip] [real? w] [real? h]) (if (not s-admin) #f (let ([loc (snip-loc snip)]) (if (not loc) #f (let ([oldw (loc-w loc)] [oldh (loc-h loc)]) (set! write-locked (add1 write-locked)) (begin-edit-sequence) (if (not (can-resize? snip w h)) (begin (end-edit-sequence) (set! write-locked (sub1 write-locked)) #f) (begin (on-resize snip w h) (set! write-locked (sub1 write-locked)) (update-location loc) (let ([rv? (and (send snip resize w h) (begin (when (not dragging?) (when (zero? s-noundomode) (let ([rs (make-object resize-snip-record% snip oldw oldh sequence-streak?)]) (add-undo-rec rs)) (when (positive? sequence) (set! sequence-streak? #t)))) #t))]) (when (and rv? (not dragging?) (not s-modified?)) (set-modified #t)) (after-resize snip w h rv?) (update-location loc) (set! write-locked (add1 write-locked)) (end-edit-sequence) (set! write-locked (sub1 write-locked)) (set! changed? #t) (when (zero? sequence) (update-needed)) rv?)))))))) ;; ---------------------------------------- (define/private (do-change-style style delta snip) (unless (or s-user-locked? (not (zero? write-locked))) (let ([rec (make-object style-change-snip-record% sequence-streak?)]) (when (positive? sequence) (set! sequence-streak? #t)) (let ([style (or style (and (not delta) (or (get-default-style) (send s-style-list basic-style))))]) (begin-edit-sequence) (let ([didit? (if snip (begin (send rec add-style-change snip (snip->style snip)) (set-snip-style! snip (or style (send s-style-list find-or-create-style (snip->style snip) delta))) (send snip size-cache-invalid) (update-snip snip) #t) (for/fold ([didit? #f]) ([loc (in-hash-keys snip-location-list)]) (if (loc-selected? loc) (let ([snip (loc-snip loc)]) (send rec add-style-change (loc-snip loc) (snip->style snip)) (set-snip-style! snip (or style (send s-style-list find-or-create-style (snip->style snip) delta))) (send snip size-cache-invalid) (set-loc-need-resize?! loc #t) (set! need-resize? #t) (update-location loc) #t) didit?)))]) (when didit? (when (zero? s-noundomode) (add-undo-rec rec)) (set! changed? #t) (when (not s-modified?) (set-modified #t)))) (end-edit-sequence))))) (define/public (change-style . args) (case-args args [() (do-change-style #f #f #f)] [([not delta]) (do-change-style #f #f #f)] [([style-delta% delta]) (do-change-style #f delta #f)] [([style-delta% delta] [snip% snip]) (do-change-style #f delta snip)] [([style<%> style] [snip% snip]) (do-change-style style #f snip)] [([style-delta% delta] [not snip]) (do-change-style #f delta #f)] [([style<%> style] [not snip]) (do-change-style style #f #f)] [([not style] [snip% snip]) (do-change-style style #f snip)] [([not style] [not snip]) (do-change-style #f #f snip)] (method-name 'pasteboard% 'change-style))) ;; ---------------------------------------- (define/private (set-between snip before after) (unless (or s-user-locked? (not (zero? write-locked)) (not (snip-loc snip)) (eq? snip before) (eq? snip after) (and before (not (snip-loc before))) (and after (not (snip-loc after)))) (set! write-locked (add1 write-locked)) (if (not (can-reorder? snip (or before after) (and before #t))) (set! write-locked (sub1 write-locked)) (begin (on-reorder snip (or before after) (and before #t)) (set! write-locked (sub1 write-locked)) ;; remove snip from current pos: (if (snip->prev snip) (set-snip-next! (snip->prev snip) (snip->next snip)) (set! snips (snip->next snip))) (if (snip->next snip) (set-snip-prev! (snip->next snip) (snip->prev snip)) (set! last-snip (snip->prev snip))) ;; insert before `before' or after `after': (if before (begin (set-snip-prev! snip (snip->prev before)) (set-snip-next! snip before) (set-snip-prev! before snip) (if (snip->prev snip) (set-snip-next! (snip->prev snip) snip) (set! snips snip))) (begin (set-snip-next! snip (snip->next after)) (set-snip-prev! snip after) (set-snip-next! after snip) (if (snip->next snip) (set-snip-prev! (snip->next snip) snip) (set! last-snip snip)))) (set! changed? #t) (unless s-modified? (set-modified #t)) (update-snip snip) (after-reorder snip (or before after) (and before #t)))))) (def/public (set-before [snip% snip] [(make-or-false snip%) before]) (set-between snip (or before snips) #f)) (def/public (set-after [snip% snip] [(make-or-false snip%) after]) (set-between snip #f (or after last-snip))) (def/public (raise [snip% snip]) (set-between snip (snip->prev snip) #f)) (def/public (lower [snip% snip]) (set-between snip #f (snip->next snip))) ;; ---------------------------------------- (define/private (snip-set-admin snip a) (let ([orig-admin (snip->admin snip)]) ;; lock during set-admin! [???] (send snip set-admin a) (if (not (eq? (send snip get-admin) a)) ;; something went wrong (cond [(and (not a) (eq? (snip->admin snip) orig-admin)) ;; force admin to null (set-snip-admin! snip #f) snip] [a ;; snip didn't accept membership into this editor; give up on it (let ([naya (new snip%)]) (set-snip-prev! naya (snip->prev snip)) (set-snip-next! naya (snip->next snip)) (if (snip->prev snip) (set-snip-next! (snip->prev naya) naya) (set! snips naya)) (if (snip->next snip) (set-snip-prev! (snip->next naya) naya) (set! last-snip naya)) (set-snip-admin! snip #f) (send naya set-admin a) naya)] [else snip]) snip))) ;; ---------------------------------------- (define/override (really-can-edit? op) (if (and (not (eq? op 'copy)) (positive? write-locked)) #f (case op [(clear cut copy kill) (and (find-next-selected-snip #f) #t)] [(select-all) (and snips #t)] [else #t]))) ;; ---------------------------------------- (define/private (find-dot loc x y dxm dym) (define (check-y can-mid?) (cond [(inbox? (loc-y loc) y) (set-box! dym -1) #t] [(and can-mid? (inbox? (loc-vm loc) y)) (set-box! dym 0) #t] [(inbox? (loc-b loc) y) (set-box! dym 1) #t] [else #f])) (cond [(inbox? (loc-x loc) x) (set-box! dxm -1) (check-y #t)] [(inbox? (loc-hm loc) x) (set-box! dxm 0) (check-y #f)] [(inbox? (loc-r loc) x) (set-box! dxm 1) (check-y #t)] [else #f])) (def/public (find-snip [real? x] [real? y] [(make-or-false snip%) [after #f]]) (let ([dummy (box 0)]) (let loop ([s (if after (if (snip-loc after) (snip->next after) #f) snips)]) (and s (let ([loc (snip-loc s)]) (cond [(and ((loc-x loc) . <= . x) ((loc-y loc) . <= . y) ((loc-r loc) . >= . x) ((loc-b loc) . >= . y)) s] [(and (loc-selected? loc) (find-dot loc x y dummy dummy)) s] [else (loop (snip->next s))])))))) (def/override (find-first-snip) snips) (def/public (is-selected? [snip% asnip]) (let ([loc (snip-loc asnip)]) (and loc (loc-selected? loc)))) (def/public (find-next-selected-snip [(make-or-false snip%) start]) (let loop ([s (if start (if (snip-loc start) (snip->next start) #f) snips)]) (and s (if (loc-selected? (snip-loc s)) s (loop (snip->next s)))))) ;; ---------------------------------------- (define/private (draw dc dx dy cx cy cw ch show-caret bg-color) (when s-admin (set! write-locked (add1 write-locked)) (set! flow-locked? #t) (let ([dcx (+ cx dx)] [dcy (+ cy dy)] [cr (+ cx cw)] [cb (+ cy ch)]) (let ([dcr (+ dcx cw)] [dcb (+ dcy ch)]) (when bg-color (let ([save-pen (send dc get-pen)] [save-brush (send dc get-brush)]) (let ([wb (if (and (= 255 (send bg-color red)) (= 255 (send bg-color green)) (= 255 (send bg-color blue))) white-brush (send the-brush-list find-or-create-brush bg-color 'solid))]) (send dc set-brush wb) (send dc set-pen invisi-pen) (send dc draw-rectangle dcx dcy cw ch) (send dc set-brush save-brush) (send dc set-pen save-pen)))) (on-paint #t dc cx cy cr cb dx dy (if (not s-caret-snip) show-caret 'no-caret)) (let loop ([snip last-snip] [old-style #f]) (if snip (let ([loc (snip-loc snip)]) (when (and ((loc-x loc) . <= . cr) ((loc-y loc) . <= . cb) ((loc-r loc) . >= . cx) ((loc-b loc) . >= . cy)) (send (snip->style snip) switch-to dc old-style) (let ([old-style (snip->style snip)]) (let ([x (+ (loc-x loc) dx)] [y (+ (loc-y loc) dy)]) (send snip draw dc x y dcx dcy dcr dcb dx dy (if (eq? snip s-caret-snip) show-caret 'no-caret)) (when (and (eq? show-caret 'show-caret) s-own-caret? selection-visible? (loc-selected? loc)) (let ([oldbrush (send dc get-brush)] [oldpen (send dc get-pen)]) (send dc set-brush black-brush) (send dc set-pen invisi-pen) (let ([r (+ (loc-r loc) dx)] [b (+ (loc-b loc) dy)] [hm (+ (loc-hm loc) dx)] [vm (+ (loc-vm loc) dy)] [rect (lambda (x y) (send dc draw-rectangle (- x HALF-DOT-WIDTH) (- y HALF-DOT-WIDTH) DOT-WIDTH DOT-WIDTH))]) (rect x y) (rect hm y) (rect r y) (rect r vm) (rect r b) (rect hm b) (rect x b) (rect x vm)) (send dc set-pen oldpen) (send dc set-brush oldbrush)))))) (loop (snip->prev snip) old-style)) (let ([bs (send s-style-list basic-style)]) (send bs switch-to dc old-style)))) (on-paint #f dc cx cy cr cb dx dy (if (not s-caret-snip) show-caret 'no-caret)) (when rubberband? (let ([a (send dc get-alpha)]) (send dc set-alpha (* a 0.5)) (send dc set-brush rb-brush) (send dc set-pen invisi-pen) (send dc draw-rectangle (+ rb-x dx) (+ rb-y dy) rb-w rb-h) (send dc set-pen rb-pen) (send dc set-alpha a) (send dc set-brush invisi-brush) (send dc draw-rectangle (+ rb-x dx) (+ rb-y dy) rb-w rb-h))) (set! flow-locked? #f) (set! write-locked (sub1 write-locked)))))) ;; called by the administrator to trigger a redraw (def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] [(symbol-in no-caret show-inactive-caret show-caret) show-caret] [(make-or-false color%) bg-color]) (cond [(not s-admin) (void)] [(or (width . <= . 0) (height . <= . 0)) (void)] [(or flow-locked? (positive? sequence)) ;; we're busy. invalidate so that everything is refreshed later. (update left top width height)] [else (let-boxes ([x 0.0] [y 0.0] [dc #f]) (set-box! dc (send s-admin get-dc x y)) (when dc (begin-sequence-lock) (send s-offscreen ready-offscreen width height) ;; make sure all location information is integral, ;; so we can shift the coordinate system and generally ;; update on pixel boundaries (let ([x (->long (floor x))] [y (->long (floor y))] [bottom (->long (ceiling (+ top height)))] [right (->long (ceiling (+ left width)))] [top (->long (floor top))] [left (->long (floor left))]) (let ([width (- right left)] [height (- bottom top)] [ps? (or (dc . is-a? . post-script-dc%) (dc . is-a? . printer-dc%))]) (if (and bg-color (not (send s-offscreen is-in-use?)) (send s-offscreen get-bitmap) (send (send s-offscreen get-bitmap) ok?) (send (send s-offscreen get-dc) ok?) (not ps?)) ;; draw to offscreen (begin (send s-offscreen set-in-use #t) (draw (send s-offscreen get-dc) (- left) (- top) left top width height show-caret bg-color) (send dc draw-bitmap-section (send (send s-offscreen get-dc) get-bitmap) (- left x) (- top y) 0 0 width height 'solid) (send s-offscreen set-last-used #f) (send s-offscreen set-in-use #f)) ;; draw directly (let ([pen (send dc get-pen)] [brush (send dc get-brush)] [font (send dc get-font)] [fg (send dc get-text-foreground)] [bg (send dc get-text-background)] [bgmode (send dc get-text-mode)] [rgn (send dc get-clipping-region)]) (send dc suspend-flush) (send dc set-clipping-rect (- left x) (- top y) width height) (dynamic-wind void (lambda () (draw dc (- x) (- y) left top width height show-caret bg-color)) (lambda () (send dc set-clipping-region rgn) (send dc set-brush brush) (send dc set-pen pen) (send dc set-font font) (send dc set-text-foreground fg) (send dc set-text-background bg) (send dc set-text-mode bgmode) (send dc resume-flush))))))) (end-sequence-lock)))])) ;; ---------------------------------------- (define/private (loc-resize loc dc) (let-boxes ([ww 0.0] [hh 0.0]) (send (loc-snip loc) get-extent dc (loc-x loc) (loc-y loc) ww hh #f #f #f #f) (set-loc-w! loc ww) (set-loc-h! loc hh) (set-loc-r! loc (+ (loc-x loc) ww)) (set-loc-b! loc (+ (loc-y loc) hh)) (set-loc-hm! loc (+ (loc-x loc) (/ ww 2))) (set-loc-vm! loc (+ (loc-y loc) (/ hh 2))) (set-loc-need-resize?! loc #f))) (define/private (check-recalc) (when s-admin (let ([dc (send s-admin get-dc)]) (when dc (when need-resize? (let-values ([(r b) (for/fold ([r 0.0] [b 0.0]) ([loc (in-hash-values snip-location-list)]) (when size-cache-invalid? (send (loc-snip loc) size-cache-invalid) (set-loc-need-resize?! loc #t)) (when (loc-need-resize? loc) (loc-resize loc dc)) (values (max r (+ (loc-r loc) HALF-DOT-WIDTH)) (max b (+ (loc-b loc) HALF-DOT-WIDTH))))]) (set! real-width (max (min r (if (symbol? max-width) +inf.0 max-width)) (if (symbol? min-width) -inf.0 min-width))) (set! real-height (max (min b (if (symbol? max-height) +inf.0 max-height)) (if (symbol? min-height) -inf.0 min-height))) (set! need-resize? #f))) (set! size-cache-invalid? #f) (when (not keep-size?) (when (or (not (= real-width total-width)) (not (= real-height total-height))) (set! total-width real-width) (set! total-height real-height) (send s-admin resized #f))))))) (define/private (update x y w h) (unless (and delayedscrollsnip (zero? sequence) (not flow-locked?) (let ([s delayedscrollsnip]) (set! delayedscrollsnip #f) (scroll-to s delayedscroll-x delayedscroll-y delayedscroll-w delayedscroll-h #t delayedscrollbias))) (let ([r (if (symbol? w) x (+ x w))] [b (if (symbol? h) y (+ y h))]) (let ([x (max x 0.0)] [y (max y 0.0)] [r (max r 0.0)] [b (max b 0.0)]) (set! no-implicit-update? #f) (if (not update-nonempty?) (begin (set! update-top y) (set! update-left x) (set! update-bottom b) (set! update-bottom-end (and (symbol? h) h)) (set! update-right r) (set! update-right-end (and (symbol? w) w)) (set! update-nonempty? #t)) (begin (set! update-top (min y update-top)) (set! update-left (min x update-left)) (set! update-bottom (max b update-bottom)) (when (symbol? h) (if (eq? h 'display-end) (set! update-bottom-end 'display-end) (unless (eq? update-bottom-end 'display-end) (set! update-bottom-end 'end)))) (set! update-right (max r update-right)) (when (symbol? w) (if (eq? w 'display-end) (set! update-right-end 'display-end) (unless (eq? update-right-end 'display-end) (set! update-right-end 'end)))))) (unless (or (positive? sequence) (not s-admin) flow-locked?) (check-recalc) (let-boxes ([vx 0.0] [vy 0.0] [vw 0.0] [vh 0.0]) (when (or (eq? update-bottom-end 'display-end) (eq? update-right-end 'display-end)) (send s-admin get-max-view x y w h)) (case update-bottom-end [(end) (set! update-bottom (max update-bottom real-height))] [(display-end) (set! update-bottom (max update-bottom vh))]) (case update-right-end [(end) (set! update-right (max update-right real-width))] [(display-end) (set! update-right (max update-right vw))])) (set! update-nonempty? #f) (when changed? (set! changed? #f) (set! write-locked (add1 write-locked)) (on-change) (set! write-locked (sub1 write-locked))) (when (or (not (= update-top update-bottom)) (not (= update-left update-right))) (let ([w (+ (- update-right update-left) 1)] [h (+ (- update-bottom update-top) 1)]) (when (and (w . > . 0) (h . > . 0)) (send s-admin needs-update update-left update-top w h))))))))) (define/private (update-location loc) (when s-admin (when (loc-need-resize? loc) (let ([dc (send s-admin get-dc)]) (when dc (loc-resize loc dc)) ;; otherwise, still need resize... )) (update (- (loc-x loc) HALF-DOT-WIDTH) (- (loc-y loc) HALF-DOT-WIDTH) (+ (loc-w loc) DOT-WIDTH) (+ (loc-h loc) DOT-WIDTH)))) (define/private (update-snip snip) (let ([loc (snip-loc snip)]) (when loc (update-location loc)))) (define/private (update-selected) (begin-edit-sequence) (for ([loc (in-hash-values snip-location-list)]) (when (loc-selected? loc) (update-location loc))) (end-edit-sequence)) (define/private (update-all) (update 0.0 0.0 -1.0 -1.0)) (define/private (update-needed) (when (or (and update-nonempty? (not no-implicit-update?)) delayedscrollsnip) (update update-left update-top 0 0))) (def/override (invalidate-bitmap-cache [real? [x 0.0]] [real? [y 0.0]] [(make-alts nonnegative-real? (symbol-in end display-end)) [w 'end]] [(make-alts nonnegative-real? (symbol-in end display-end)) [h 'end]]) (update x y w h)) ;; ---------------------------------------- (def/override (own-caret [any? ownit?]) (when (do-own-caret ownit?) (update-selected) (on-focus ownit?))) (def/override (blink-caret) (when s-caret-snip (let-boxes ([dc #f] [dx 0.0] [dy 0.0]) (set-box! dc (send s-admin get-dc dx dy)) (when dc (let-boxes ([x 0.0] [y 0.0] [ok? #f]) (set-box! ok? (get-snip-location s-caret-snip y)) (when ok? (send s-caret-snip blink-caret dc (- x dx) (- y dy)))))))) (def/override (size-cache-invalid) (set! size-cache-invalid? #t) (set! need-resize? #t)) (def/override (get-extent [maybe-box? w] [maybe-box? h]) (check-recalc) (when w (set-box! w total-width)) (when h (set-box! h total-height))) ;; ---------------------------------------- (def/public (scroll-to [snip% snip] [real? localx] [real? localy] [nonnegative-real? w] [nonnegative-real? h] [any? refresh?] [(symbol-in start end none) [bias 'none]]) (cond [(positive? sequence) (set! delayedscrollsnip snip) (set! delayedscroll-x localx) (set! delayedscroll-y localy) (set! delayedscroll-w w) (set! delayedscroll-h h) #f] [s-admin (let-boxes ([x 0.0] [y 0.0]) (get-snip-location snip x y) (if (scroll-editor-to (+ x localx) (+ y localy) w h refresh? bias) (begin (set! update-top 0.0) (set! update-left 0.0) (set! update-bottom -1.0) (set! update-right -1.0) (set! update-nonempty? #t) #t) #f))] [else #f])) (def/override (set-caret-owner [(make-or-false snip%) snip] [(symbol-in immediate display global) [dist 'immediate]]) (when (do-set-caret-owner snip dist) (update-all) (on-focus (not snip)))) (def/override (resized [snip% snip] [any? redraw-now?]) (let ([loc (snip-loc snip)]) (when (and loc (not (loc-need-resize? loc))) (set! changed? #t) (let ([niu? (or (not update-nonempty?) no-implicit-update?)]) (when (not redraw-now?) (set! sequence (add1 sequence))) (begin-edit-sequence) (update-location loc) (set-loc-need-resize?! loc #t) (set! need-resize? #t) (update-location loc) (end-edit-sequence) (when (not redraw-now?) (set! sequence (sub1 sequence))) (when niu? (set! no-implicit-update? #t)))))) (def/override (recounted [snip% snip] [any? redraw-now?]) (resized snip redraw-now?) #t) (def/override (needs-update [snip% snip] [real? localx] [real? localy] [nonnegative-real? w] [nonnegative-real? h]) (let-boxes ([x 0.0] [y 0.0]) (get-snip-location snip x y) (update (+ x localx) (+ y localy) w h))) (def/override (release-snip [snip% snip]) (if (-delete snip #f) (begin (when (and (not (snip->admin snip)) (has-flag? (snip->flags snip) OWNED)) (set-snip-flags! snip (remove-flag (snip->flags snip) OWNED))) #t) #f)) ;; ---------------------------------------- (def/override (scroll-line-location [exact-integer? line]) (* line scroll-step)) (def/override (num-scroll-lines) (->long (/ (- (+ total-height scroll-step) 1) scroll-step))) (def/override (find-scroll-line [real? y]) (let ([y (max 0 y)]) (->long (/ y scroll-step)))) (def/public (set-scroll-step [real? s]) (unless (= scroll-step s) (set! scroll-step s) (when s-admin (send s-admin resized #t)))) (def/public (get-scroll-step) scroll-step) ;; ---------------------------------------- (def/override (set-min-width [(make-alts real? (symbol-in none)) w]) (set! min-width (if (and (real? w) (w . <= . 0)) 'none w)) (set! need-resize? #t) (update-all)) (def/override (set-max-width [(make-alts real? (symbol-in none)) w]) (set! max-width (if (and (real? w) (w . <= . 0)) 'none w)) (set! need-resize? #t) (update-all)) (def/override (set-min-height [(make-alts real? (symbol-in none)) h]) (set! min-height (if (and (real? h) (h . <= . 0)) 'none h)) (set! need-resize? #t) (update-all)) (def/override (set-max-height [(make-alts real? (symbol-in none)) h]) (set! max-height (if (and (real? h) (h . <= . 0)) 'none h)) (set! need-resize? #t) (update-all)) (def/override (get-min-width) min-width) (def/override (get-max-width) max-width) (def/override (get-min-height) min-height) (def/override (get-max-height) max-height) ;; ---------------------------------------- (def/override (copy-self) (let ([pb (new pasteboard%)]) (copy-self-to pb) pb)) (def/override (copy-self-to [editor<%> pb]) (when (pb . is-a? . pasteboard%) (super copy-self-to pb) (send pb set-dragable (get-dragable)) (send pb set-selection-visible (get-selection-visible)) (send pb set-scroll-step (get-scroll-step)))) ;; ---------------------------------------- (def/override (get-descent) 0.0) (def/override (get-space) 0.0) (def/public (get-center) (let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0]) (if (not s-admin) (begin (set-box! w total-width) (set-box! h total-height)) (send s-admin get-view x y w h #t)) (let ([w (if (w . > . 1000.0) 500.0 ; don't believe it w)] [h (if (h . > . 1000.0) 500.0 ; don't believe it h)]) (values (/ w 2) (/ h 2))))) ;; ---------------------------------------- (def/override (get-flattened-text) (let ([p (open-output-string)]) (let loop ([s snips]) (when s (display (send s get-text 0 (snip->count s) #t) p) (loop (snip->next s)))) (get-output-string p))) (def/override (clear) (delete)) (def/override (cut [any? [extend? #f]] [exact-integer? [time 0]]) (copy extend? time) (clear)) (def/public (do-copy [exact-integer? time] [bool? extend?]) (set-common-copy-region-data! #f) (let ([sl (if (and extend? copy-style-list) copy-style-list s-style-list)]) (let loop ([snip snips]) (when snip (let ([loc (snip-loc snip)]) (when (loc-selected? loc) (let ([asnip (send snip copy)]) (send asnip set-admin #f) (set-snip-style! asnip (send sl convert (snip->style asnip))) (cons-common-copy-buffer! asnip) (cons-common-copy-buffer2! (get-snip-data snip))))) (loop (snip->next snip)))) (install-copy-buffer time sl))) (def/override (copy [bool? [extend? #f]] [exact-integer? [time 0]]) (begin-copy-buffer) (when (not extend?) (free-old-copies)) (do-copy time extend?) (end-copy-buffer)) (define/private (do-generic-paste cb time) (unless (or s-user-locked? (positive? write-locked)) (let-values ([(start) snips] [(cx cy) (get-center)]) (do-buffer-paste cb time #f) (if (and s-admin (not (eq? snips start))) (let ([dc (get-dc)]) (when dc ;; get top/left/bottom/right of pasted group: (let loop ([snip snips] [left +inf.0] [top +inf.0] [right -inf.0] [bottom -inf.0]) (if (eq? snip start) (let ([dx (- cx (/ (left + right) 2))] [dy (- cy (/ (top + bottom) 2))]) ;; shift the pasted group to center: (move dx dy)) (let ([loc (snip-loc snip)]) (add-selected snip) (when (loc-need-resize? loc) (loc-resize loc dc)) (loop (snip->next snip) (min (loc-x loc) left) (min (loc-y loc) top) (max (loc-r loc) right) (max (loc-b loc) bottom))))))) ;; just select them: (let loop ([snip snips]) (unless (eq? snip start) (add-selected snip) (loop (snip->next snip)))))))) (def/public (do-paste [exact-integer? time]) (do-generic-paste the-clipboard time)) (def/public (do-paste-x-selection [exact-integer? time]) (do-generic-paste the-x-selection-clipboard time)) (define/private (generic-paste x-sel? time) (unless (or s-user-locked? (positive? write-locked)) (begin-edit-sequence) (no-selected) (if x-sel? (do-paste-x-selection time) (do-paste time)) (end-edit-sequence))) (def/override (paste [exact-integer? [time 0]]) (generic-paste #f time)) (def/override (paste-x-selection [exact-integer? [time 0]]) (generic-paste #t time)) (define/override (insert-paste-snip snip data) (insert snip snip) (set-snip-data snip data)) (define/override (insert-paste-string str) (let ([snip (new string-snip%)]) (set-snip-style! snip (or (get-default-style) (send s-style-list basic-style))) (send snip insert str) (insert-paste-snip snip #f))) (def/override (kill [exact-integer? [time 0]]) (cut time)) (define/override (own-x-selection on? update? force?) (do-own-x-selection on? force?)) ;; ---------------------------------------- (def/override (get-snip-location [snip% thesnip] [maybe-box? [x #f]] [maybe-box? [y #f]] [bool? [bottom-right? #f]]) (if (and bottom-right? (not s-admin)) #f (begin (when bottom-right? (check-recalc)) (let ([loc (snip-loc thesnip)]) (and loc (begin (when x (set-box! x (+ (loc-x loc) (if bottom-right? (loc-w loc) 0.0)))) (when y (set-box! y (+ (loc-y loc) (if bottom-right? (loc-h loc) 0.0)))) #t)))))) ;; ---------------------------------------- (def/override (get-snip-data [snip% snip]) (let ([loc (snip-loc snip)] [sup (super get-snip-data snip)]) (if (not loc) sup (let ([data (new location-editor-data% [x (loc-x loc)] [y (loc-y loc)])]) (send data set-next sup) data)))) (def/override (set-snip-data [snip% snip] [editor-data% data]) (let loop ([data data]) (when data (let ([c (send data get-dataclass)]) (when c (let ([name (send c get-classname)]) (when (equal? name "wxloc") (move-to snip (send data get-x) (send data get-y)))))) (loop (send data get-next))))) (def/override (insert-port [input-port? f] [(symbol-in guess same copy standard text text-force-cr) [format 'guess]] [any? [replace-styles? #f]]) (if (or s-user-locked? (not (zero? write-locked))) 'standard (do-insert-file (method-name 'pasteboard% 'insert-file) f replace-styles?))) (define/private (do-insert-file who f clear-styles?) (when (not (detect-wxme-file who f #f)) (error who "not a WXME file")) (let* ([b (make-object editor-stream-in-file-base% f)] [mf (make-object editor-stream-in% b)]) (when (not (and (read-editor-version mf b #f #t) (read-editor-global-header mf) (send mf ok?) (read-from-file mf clear-styles?) (read-editor-global-footer mf) (begin ;; if STD-STYLE wasn't loaded, re-create it: (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (send mf ok?)))) (error who "error loading the file"))) 'standard) (def/override (save-port [output-port? f] [(symbol-in guess same copy standard text text-force-cr) [format 'same]] [any? [show-errors? #t]]) (let* ([b (make-object editor-stream-out-file-base% f)] [mf (make-object editor-stream-out% b)]) (when (not (and (write-editor-version mf b) (write-editor-global-header mf) (send mf ok?) (write-to-file mf) (write-editor-global-footer mf) (send mf ok?))) (error (method-name 'pasteboard% 'save-port) "error writing the file")) #t)) (def/override (write-to-file [editor-stream-out% f]) (and (do-write-headers-footers f #t) (write-snips-to-file f s-style-list #f snips #f #f this) (do-write-headers-footers f #f))) (def/override (read-from-file [editor-stream-in% f] [bool? [overwritestyle? #f]]) (if (or s-user-locked? (not (zero? write-locked))) #f (read-snips-from-file f overwritestyle?))) (define/override (do-read-insert snip) (insert snip #f) #t) (def/override (set-filename [(make-or-false path-string?) name][any? [temp? #f]]) (set! s-filename (if (string? name) (string->path name) name)) (set! s-temp-filename? temp?) (let loop ([snip snips]) (when snip (when (has-flag? (snip->flags snip) USES-BUFFER-PATH) ;; just a notification (send snip set-admin snip-admin)) (loop (snip->next snip))))) ;; ---------------------------------------- (def/override (style-has-changed [(make-or-false style<%>) style]) (when (not style) (set! changed? #t) (update-all))) ;; ---------------------------------------- (def/override (begin-edit-sequence [any? [undoable? #t]] [any? [interrupt-seqs? #t]]) (wait-sequence-lock) (when (or (positive? s-noundomode) (not undoable?)) (set! s-noundomode (add1 s-noundomode))) (when (and (zero? sequence) (zero? write-locked)) (on-edit-sequence)) (set! sequence (add1 sequence))) (def/override (end-edit-sequence) (set! sequence (sub1 sequence)) (when (and (zero? sequence) (zero? write-locked)) (set! sequence-streak? #f) (update-needed) (after-edit-sequence)) (when (positive? s-noundomode) (set! s-noundomode (sub1 s-noundomode))) (when (and (zero? sequence) s-need-on-display-size?) (set! s-need-on-display-size? #f) (on-display-size))) (def/override (refresh-delayed?) (or (positive? sequence) (not s-admin) (send s-admin refresh-delayed?))) (def/override (in-edit-sequence?) (positive? sequence)) (def/override (locations-computed?) (not need-resize?)) ;; ---------------------------------------- (def/public (get-dragable) dragable?) (def/public (set-dragable [bool? d?]) (set! dragable? d?)) (def/public (get-selection-visible) selection-visible?) (def/public (set-selection-visible [bool? v]) (set! selection-visible? v)) ;; ---------------------------------------- (def/public (can-insert? [snip% a] [(make-or-false snip%) b] [real? x] [real? y]) #t) (def/public (on-insert [snip% a] [(make-or-false snip%) b] [real? x] [real? y]) (void)) (def/public (after-insert [snip% a] [(make-or-false snip%) b] [real? x] [real? y]) (void)) (def/public (can-delete? [snip% s]) #t) (def/public (on-delete [snip% s]) (void)) (def/public (after-delete [snip% s]) (void)) (def/public (can-move-to? [snip% s] [real? x] [real? y] [bool? dragging?]) #t) (def/public (on-move-to [snip% s] [real? x] [real? y] [bool? dragging?]) (void)) (def/public (after-move-to [snip% s] [real? x] [real? y] [bool? dragging?]) (void)) (def/public (can-resize? [snip% s] [real? w] [real? h]) #t) (def/public (on-resize [snip% s] [real? w] [real? h]) (void)) (def/public (after-resize [snip% s] [real? w] [real? h] [any? resized?]) (void)) (def/public (can-select? [snip% s] [bool? on?]) #t) (def/public (on-select [snip% s] [bool? on?]) (void)) (def/public (after-select [snip% s] [bool? on?]) (void)) (def/public (can-reorder? [snip% s] [(make-or-false snip%) other] [bool? before?]) #t) (def/public (on-reorder [snip% s] [(make-or-false snip%) other] [bool? before?]) (void)) (def/public (after-reorder [snip% s] [(make-or-false snip%) other] [bool? before?]) (void)) (def/public (can-interactive-move? [mouse-event% e]) #t) (def/public (on-interactive-move [mouse-event% e]) (void)) (def/public (after-interactive-move [mouse-event% e]) (void)) (def/public (can-interactive-resize? [snip% s]) #t) (def/public (on-interactive-resize [snip% s]) (void)) (def/public (after-interactive-resize [snip% s]) (void)) (define/override (do-begin-print dc fit?) (size-cache-invalid) (set! write-locked (add1 write-locked)) (on-change) (set! write-locked (sub1 write-locked)) #f) (define/override (do-end-print dc data) (size-cache-invalid) (set! write-locked (add1 write-locked)) (on-change) (set! write-locked (sub1 write-locked))) (define/override (do-has-print-page? dc page) (do-has/print-page dc page #f)) (def/override (print-to-dc [dc<%> dc] [exact-integer? [page -1]]) (do-has/print-page dc page #t) (void)) (define/private (do-has/print-page dc page print?) (check-recalc) (let-values ([(w h) (send dc get-size)]) (let-boxes ([w w] [h h] [hm 0] [vm 0]) (begin (when (or (zero? (unbox w)) (zero? (unbox h))) (get-default-print-size w h)) (unless (zero? page) (send (current-ps-setup) get-editor-margin hm vm))) (let ([W (- w (* 2 hm))] [H (- h (* 2 vm))] [eps? (zero? page)]) (let-boxes ([w 0.0] [h 0.0]) (get-extent w h) (let ([hcount (if eps? 1 (->long (ceiling (/ w W))))] [vcount (if eps? 1 (->long (ceiling (/ h H))))]) (if (not print?) (page . <= . (* hcount vcount)) (let-values ([(start end) (cond [(zero? page) (values 1 1)] [(negative? page) (values 1 (* hcount vcount))] [else (values page page)])]) (for ([p (in-range start (add1 end))]) (let ([vpos (quotient (- p 1) hcount)] [hpos (modulo (- p 1) hcount)]) (let ([x (* hpos W)] [y (* vpos H)]) (when (page . <= . 0) (send dc start-page)) (draw dc (+ (- x) hm) (+ (- y) vm) x y (+ x (if eps? w W)) (+ y (if eps? h H)) 'no-caret #f) (when (page . <= . 0) (send dc end-page))))))))))))) ;; ---------------------------------------- ) (set-pasteboard%! pasteboard%) ;; ------------------------------------------------------------ (define/top (add-pasteboard-keymap-functions [keymap% tab]) (void))