368 lines
15 KiB
Racket
368 lines
15 KiB
Racket
#|
|
|
|
|
todo:
|
|
|
|
pict snip :
|
|
- snipclass for running snips outside of drscheme
|
|
- need to toggle the picts back to scheme code when
|
|
important things happen (save, execute, etc).
|
|
- should save the true pict size when it gets recorded.
|
|
- show the true size in the GUI
|
|
- when a snip is deleted from inside the pasteboard, remove it from the caches
|
|
- check that when a snip is inserted, things revert (?).
|
|
maybe something better should happen?
|
|
- test up-to-date? flag
|
|
|#
|
|
|
|
(module tool mzscheme
|
|
(require drscheme/tool
|
|
mred
|
|
mzlib/class
|
|
mzlib/unit
|
|
mzlib/contract
|
|
string-constants
|
|
framework
|
|
texpict/mrpict
|
|
texpict/pict-value-snip
|
|
mzlib/list
|
|
"private/pict-box-lib.ss"
|
|
"private/image-snipr.ss")
|
|
|
|
(provide tool@
|
|
get-snp/poss
|
|
build-lib-pict-stx)
|
|
|
|
(define orig-inspector (current-code-inspector))
|
|
(define orig-lcp (current-library-collection-paths))
|
|
|
|
(define-syntax syntax/cert
|
|
(syntax-rules ()
|
|
[(_ stx tmpl) (let ([stx stx])
|
|
(syntax-recertify
|
|
(syntax/loc stx tmpl)
|
|
stx
|
|
orig-inspector
|
|
#f))]))
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
(define original-output-port (current-output-port))
|
|
(define (oprintf . args) (apply fprintf original-output-port args))
|
|
|
|
(define sc-hide-picts (string-constant slideshow-hide-picts))
|
|
(define sc-show-picts (string-constant slideshow-show-picts))
|
|
(define sc-cannot-show-picts (string-constant slideshow-cannot-show-picts))
|
|
(define sc-insert-pict-box (string-constant slideshow-insert-pict-box))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; pict box
|
|
;;
|
|
|
|
|
|
(define pict-pasteboard%
|
|
(class pasteboard%
|
|
(inherit get-admin)
|
|
|
|
(define/augment (after-insert snip before x y)
|
|
(let ([admin (get-admin)])
|
|
(when (is-a? admin editor-snip-editor-admin<%>)
|
|
(send (send admin get-snip) inserted-snip)))
|
|
(inner (void) after-insert snip before x y))
|
|
|
|
(super-new)))
|
|
|
|
(define pict-snip%
|
|
(class* decorated-editor-snip% (readable-snip<%>)
|
|
(inherit get-editor)
|
|
|
|
(define show-picts? #f)
|
|
|
|
;; only for use in the copy method and the read snipclass method
|
|
(define/public (set-show-picts b) (set! show-picts? b))
|
|
|
|
;; up-to-date? : boolean
|
|
;; indicates if the recent shapes cache is up to date
|
|
(define up-to-date? #f)
|
|
|
|
;; only for use in the copy method and the read snipclass method
|
|
(define/public (set-up-to-date b) (set! up-to-date? b))
|
|
|
|
;; bitmap-table : hash-table[snip -o> bitmap]
|
|
;; maps from the true (Scheme) snip to its current bitmap
|
|
(define bitmap-table (make-hash-table))
|
|
|
|
;; only for use in the copy method and the read snipclass method
|
|
(define/public (set-bitmap-table bt) (set! bitmap-table bt))
|
|
|
|
(define/override (make-editor) (make-object pict-pasteboard%))
|
|
(define/override (get-corner-bitmap) slideshow-bm)
|
|
|
|
(define/override (copy)
|
|
(let* ([cp (make-object pict-snip%)]
|
|
[ed (send cp get-editor)])
|
|
(send (get-editor) copy-self-to ed)
|
|
(let ([bt (make-hash-table)])
|
|
(hash-table-for-each bitmap-table (lambda (k v) (hash-table-put! bt (send k copy) v)))
|
|
(send cp set-bitmap-table bt)
|
|
(send cp set-show-picts show-picts?)
|
|
(send cp set-up-to-date up-to-date?)
|
|
cp)))
|
|
|
|
|
|
(define/override (get-menu)
|
|
(let ([menu (instantiate popup-menu% () (title #f))])
|
|
(cond
|
|
[show-picts?
|
|
(make-object checkable-menu-item%
|
|
sc-hide-picts
|
|
menu
|
|
(lambda (x y)
|
|
(hide-picts)))]
|
|
[up-to-date?
|
|
(make-object checkable-menu-item%
|
|
sc-show-picts
|
|
menu
|
|
(lambda (x y)
|
|
(show-picts)))]
|
|
[else
|
|
(let ([m (make-object menu-item%
|
|
sc-cannot-show-picts
|
|
menu
|
|
(lambda (x y) void))])
|
|
(send m enable #f))])
|
|
menu))
|
|
|
|
(define/public (update-bitmap-table sub-snips sub-bitmaps)
|
|
(let ([hidden-table (make-hash-table)])
|
|
(let loop ([snip (send (get-editor) find-first-snip)])
|
|
(cond
|
|
[snip
|
|
(when (is-a? snip image-snip/r%)
|
|
(hash-table-put! hidden-table (send snip get-orig-snip) snip))
|
|
(loop (send snip next))]
|
|
[else (void)]))
|
|
(for-each (lambda (snip bitmap)
|
|
(hash-table-put! bitmap-table snip bitmap)
|
|
(let ([showing (hash-table-get hidden-table snip (lambda () #f))])
|
|
(when showing
|
|
(send showing set-bitmap bitmap))))
|
|
sub-snips
|
|
sub-bitmaps)
|
|
(set! up-to-date? #t)))
|
|
|
|
(define/private (show-picts)
|
|
(let ([pb (get-editor)])
|
|
(set! show-picts? #t)
|
|
(send pb begin-edit-sequence)
|
|
|
|
(set! system-insertion? #t)
|
|
(hash-table-for-each
|
|
bitmap-table
|
|
(lambda (snip bitmap)
|
|
(let ([bm-snip (make-object image-snip/r% bitmap snip)])
|
|
(let-values ([(x y) (snip-location pb snip)])
|
|
(send snip release-from-owner)
|
|
(send pb insert bm-snip x y)))))
|
|
(set! system-insertion? #f)
|
|
|
|
(send pb end-edit-sequence)))
|
|
|
|
(define/private (hide-picts)
|
|
(let ([pb (get-editor)])
|
|
(set! show-picts? #f)
|
|
|
|
(send pb begin-edit-sequence)
|
|
|
|
(let ([all-snips (let loop ([snip (send pb find-first-snip)])
|
|
(cond
|
|
[snip (cons snip (loop (send snip next)))]
|
|
[else null]))])
|
|
(set! system-insertion? #t)
|
|
(for-each (lambda (snip)
|
|
(when (is-a? snip image-snip/r%)
|
|
(let ([real-snip (send snip get-orig-snip)])
|
|
(let-values ([(x y) (snip-location pb snip)])
|
|
(send snip release-from-owner)
|
|
(send pb insert real-snip x y)))))
|
|
all-snips)
|
|
(set! system-insertion? #f))
|
|
|
|
(send pb end-edit-sequence)))
|
|
|
|
;; called on user thread
|
|
(define/public (read-special file line col pos)
|
|
(let ([ans-chan (make-channel)])
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(channel-put ans-chan (get-snp/poss this)))))
|
|
(let ([snp/poss (channel-get ans-chan)])
|
|
(build-lib-pict-stx
|
|
(lambda (ids)
|
|
(with-syntax ([(ids ...) ids]
|
|
[this this]
|
|
[build-bitmap/check build-bitmap/check]
|
|
[drs-eventspace drs-eventspace]
|
|
[(subsnips ...) (map snp/pos-snp snp/poss)]
|
|
[(bitmap-ids ...) (generate-ids "drawer-id" (map snp/pos-snp snp/poss))])
|
|
(syntax
|
|
(let ([bitmap-ids (build-bitmap/check ids (pict-width ids) (pict-height ids) draw-pict pict?)] ...)
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(lambda () ;; drs eventspace
|
|
(send this update-bitmap-table
|
|
(list subsnips ...)
|
|
(list bitmap-ids ...)))))))))
|
|
snp/poss))))
|
|
|
|
(define/override (write stream-out)
|
|
(send stream-out put (if show-picts? 1 0))
|
|
(send stream-out put (if up-to-date? 1 0))
|
|
(send (get-editor) write-to-file stream-out))
|
|
(define/override (make-snip) (new pict-snip%))
|
|
|
|
(define system-insertion? #f)
|
|
(define/public (inserted-snip)
|
|
(unless system-insertion?
|
|
(set! up-to-date? #f)
|
|
(when show-picts?
|
|
(hide-picts))))
|
|
|
|
(inherit show-border set-snipclass)
|
|
(super-new)
|
|
(show-border #t)
|
|
(set-snipclass lib-pict-snipclass)))
|
|
|
|
(define lib-pict-snipclass%
|
|
(class snip-class%
|
|
(define/override (read stream-in)
|
|
(let* ([snip (new pict-snip%)]
|
|
[editor (send snip get-editor)]
|
|
[show-picts? (not (zero? (send stream-in get-exact)))]
|
|
[up-to-date? (not (zero? (send stream-in get-exact)))])
|
|
(send editor read-from-file stream-in #f)
|
|
(send snip set-up-to-date up-to-date?)
|
|
(send snip set-show-picts show-picts?)
|
|
(let ([bt (make-hash-table)])
|
|
(let loop ([snip (send editor find-first-snip)])
|
|
(cond
|
|
[(is-a? snip snip%)
|
|
(when (is-a? snip image-snip/r%)
|
|
(let ([orig (send snip get-orig-snip)]
|
|
[bm (send snip get-bitmap)])
|
|
(hash-table-put! bt orig bm)))
|
|
(loop (send snip next))]
|
|
[else (void)]))
|
|
(send snip set-bitmap-table bt))
|
|
snip))
|
|
(super-new)))
|
|
|
|
;; build-bitmap/check : pict number number (pict dc number number -> void) (any -> boolean) -> bitmap
|
|
;; called on user-thread with a pict that the user made
|
|
(define (build-bitmap/check pict w h draw-pict pict?)
|
|
(unless (pict? pict)
|
|
(error 'pict-snip "expected a pict to be the result of each embedded snip, got ~e"
|
|
pict))
|
|
(let* ([bm (make-object bitmap%
|
|
(max 1 (add1 (inexact->exact (ceiling w))))
|
|
(max 1 (add1 (inexact->exact (ceiling h)))))]
|
|
[bdc (make-object bitmap-dc% bm)])
|
|
(send bdc clear)
|
|
(send bdc set-smoothing 'aligned)
|
|
(draw-pict pict bdc 0 0)
|
|
(send bdc set-bitmap #f)
|
|
bm))
|
|
|
|
(define (set-box/f b v) (when (box? b) (set-box! b v)))
|
|
|
|
(define slideshow-bm
|
|
(let ([bm (make-object bitmap% (build-path (collection-path "slideshow") "slideshow.bmp"))])
|
|
(and (send bm ok?)
|
|
bm)))
|
|
|
|
(define drs-eventspace (current-eventspace))
|
|
|
|
(define (add-special-menu-item menu frame)
|
|
(let* ([find-insertion-point ;; -> (union #f editor<%>)
|
|
;; returns the editor (if there is one) with the keyboard focus
|
|
(lambda ()
|
|
(let ([editor (send frame get-edit-target-object)])
|
|
(and editor
|
|
(is-a? editor editor<%>)
|
|
(let loop ([editor editor])
|
|
(let ([focused (send editor get-focus-snip)])
|
|
(if (and focused
|
|
(is-a? focused editor-snip%))
|
|
(loop (send focused get-editor))
|
|
editor))))))]
|
|
[insert-snip
|
|
(lambda (make-obj)
|
|
(let ([editor (find-insertion-point)])
|
|
(when editor
|
|
(let ([snip (make-obj)])
|
|
(send editor insert snip)
|
|
(send editor set-caret-owner snip 'display)))))]
|
|
[demand-callback ;; : menu-item% -> void
|
|
;; enables the menu item when there is an editor available.
|
|
(lambda (item)
|
|
(send item enable (find-insertion-point)))])
|
|
(instantiate menu:can-restore-menu-item% ()
|
|
(label sc-insert-pict-box)
|
|
(parent menu)
|
|
(demand-callback demand-callback)
|
|
(callback
|
|
(lambda (menu evt)
|
|
(insert-snip
|
|
(lambda () (new pict-snip%))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; wire it up
|
|
;;
|
|
|
|
(define (phase1) (void))
|
|
(define (phase2) (void))
|
|
|
|
(define orig-namespace (current-namespace))
|
|
|
|
(define (pict->image-snip p)
|
|
(let* ([pict-width (dynamic-require 'texpict/mrpict 'pict-width)]
|
|
[pict-height (dynamic-require 'texpict/mrpict 'pict-height)]
|
|
[draw-pict (dynamic-require 'texpict/mrpict 'draw-pict)]
|
|
[bm (make-object bitmap%
|
|
(max 1 (add1 (inexact->exact (ceiling (pict-width p)))))
|
|
(max 1 (add1 (inexact->exact (ceiling (pict-height p))))))]
|
|
[bdc (make-object bitmap-dc% bm)])
|
|
(send bdc clear)
|
|
(send bdc set-smoothing 'aligned)
|
|
(draw-pict p bdc 0 0)
|
|
(send bdc set-bitmap #f)
|
|
(make-object image-snip% bm)))
|
|
|
|
(drscheme:language:add-snip-value
|
|
;; Convert to print?
|
|
(lambda (x)
|
|
;; if the require fails, then we cannot display the pict.
|
|
;; this can happen when, for example, there is no mred module
|
|
;; in the namespace
|
|
(let ([pict? (with-handlers ((exn:fail? (λ (x) #f)))
|
|
(dynamic-require 'texpict/mrpict 'pict?))])
|
|
(and pict?
|
|
(pict? x))))
|
|
;; Converter:
|
|
pict->image-snip
|
|
;; Namespace setup:
|
|
(λ ()
|
|
(with-handlers ((exn:fail? void))
|
|
;; code running in this thunk cannot fail, or else drscheme gets wedged.
|
|
(dynamic-require 'texpict/mrpict #f))))
|
|
|
|
(define lib-pict-snipclass (make-object lib-pict-snipclass%))
|
|
(send lib-pict-snipclass set-version 2)
|
|
(send lib-pict-snipclass set-classname (format "~s" '(lib "pict-snipclass.ss" "slideshow")))
|
|
(send (get-the-snip-class-list) add lib-pict-snipclass))))
|