From df4dbe615f4554d7b8828f410c91d04d271d9386 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 24 Feb 2012 07:37:21 -0600 Subject: [PATCH] add a convertible interface to texpict that lets values be convertiable to picts. use that interface in DrRacket, but via the suboptimal screen-bitmap route (for now) --- collects/drracket/private/language.rkt | 55 ++++++++++++++++++++-- collects/scribblings/slideshow/picts.scrbl | 40 ++++++++++++++++ collects/texpict/mrpict.rkt | 27 ++++++----- collects/texpict/private/common-unit.rkt | 8 ++-- collects/texpict/private/convertible.rkt | 19 ++++++++ collects/texpict/private/mrpict-extra.rkt | 5 +- 6 files changed, 134 insertions(+), 20 deletions(-) create mode 100644 collects/texpict/private/convertible.rkt diff --git a/collects/drracket/private/language.rkt b/collects/drracket/private/language.rkt index 033b469141..b70ad9039a 100644 --- a/collects/drracket/private/language.rkt +++ b/collects/drracket/private/language.rkt @@ -25,7 +25,7 @@ mrlib/syntax-browser compiler/distribute compiler/bundle-dist - file/convertible + (prefix-in file: file/convertible) "rep.rkt") (import [prefix drracket:debug: drracket:debug^] @@ -370,6 +370,9 @@ (real? x) (not (integer? x))))]) (define convert-table (make-hasheq)) + (define pict:convertible? + (with-handlers ((exn:fail? (λ (exn) (λ (val) #f)))) + (dynamic-require 'texpict/mrpict 'convertible?))) (parameterize ([pretty-print-pre-print-hook (λ (val port) (void))] [pretty-print-post-print-hook (λ (val port) (void))] [pretty-print-exact-as-decimal #f] @@ -393,11 +396,16 @@ (cond [(not (port-writes-special? port)) (oh value display? port)] [(is-a? value snip%) 1] + [(pict:convertible? value) 1] [(use-number-snip? value) 1] [(syntax? value) 1] [(to-snip-value? value) 1] - [(and (convertible? value) - (convert value 'png-bytes #f)) + [(hash-ref convert-table value #f) + ;; this handler can be called multiple times per value + ;; avoid building the png bytes more than once + 1] + [(and (file:convertible? value) + (file:convert value 'png-bytes #f)) => (λ (converted) (hash-set! convert-table value converted) @@ -420,6 +428,8 @@ [else (write-special value port) 1])] + [(pict:convertible? value) + (write-special (mk-pict-snip value))] [(use-number-snip? value) (write-special (case (simple-settings-fraction-style settings) @@ -454,6 +464,45 @@ (simple-settings-show-sharing settings))]) (thunk)))) + (define pict-snip% + (class snip% + (init-field w h d a bm) + (define/override (get-extent dc x y [wb #f] [hb #f] [descent #f] [space #f] [lspace #f] [rspace #f]) + (set-box/f lspace 0) + (set-box/f rspace 0) + (set-box/f wb w) + (set-box/f hb h) + (set-box/f descent d) + (set-box/f space a)) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (send dc draw-bitmap bm x y)) + (define/override (copy) (new pict-snip% [w w] [h h] [d d] [a a] [bm bm])) + (super-new))) + + (define (mk-pict-snip convertible) + (define-syntax-rule + (dyn name args ...) + ((dynamic-require 'texpict/mrpict 'name) args ...)) + (define pict (dyn convert convertible)) + (define w (dyn pict-width pict)) + (define h (dyn pict-height pict)) + (define a (dyn pict-ascent pict)) + (define d (dyn pict-descent pict)) + ;; this would be better if it could use a record-dc% + ;; instead of a bitmap; for now we use a screen-bitmap + ;; as a stop-gap measure (note that this wont' have an + ;; alpha channel under windows so that means that when we + ;; are in white-on-black mode, it will have a white background + ;; (which is ugly, but maybe preferable to black on black, I guess)) + (define bm (make-screen-bitmap (inexact->exact (ceiling w)) + (inexact->exact (ceiling h)))) + (define bdc (make-object bitmap-dc% bm)) + (dyn draw-pict pict bdc 0 0) + (send bdc set-bitmap #f) + (new pict-snip% [w w] [h h] [d d] [a a] [bm bm])) + + (define (set-box/f b v) (when (box? b) (set-box! b v))) + ;; drscheme-inspector : inspector (define drscheme-inspector (current-inspector)) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index cc808e6f1a..b028979d3e 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -1120,3 +1120,43 @@ frame's drawing area.} A parameter used to refine text measurements to better match an expected scaling of the image. The @racket[scale/improve-new-text] form sets this parameter while also scaling the resulting pict.} + +@section{Convertion to @racket[pict?]s} + +This section describes a protocol for values to be +able to convert themselves to @racket[pict?]s. The +protocol is used by DrRacket's REPL to render values +that it prints out. + +@defthing[prop:convertible struct-type-property?]{ + +A property whose value should be a procedure matching the +contract @racket[(-> any/c pict?)]. The +procedure is called when a structure with the property is passed to +@racket[convert]; the argument to the procedure is the +structure, and the procedure's result should be a pict. +} + +@defthing[prop:convertible? struct-type-property?]{ +A property whose value should be a predicate procedure +(i.e., matching the contract @racket[predicate/c]). + +If this property is not set, then it is assumed to be +the function @racket[(λ (x) #t)]. + +If this property is set, then this procedure is called +by @racket[convertible?] to determine if this particular +value is convertible (thereby supporting situations +where some instances of a given struct are convertible +to picts, but others are not). +} + +@defproc[(convertible? [v any/c]) boolean?]{ +Returns @racket[#t] if @racket[v] supports the conversion protocol +(by being a struct with the @racket[prop:convertible] property) +and @racket[#f] otherwise. +} + +@defproc[(convert [v convertible?]) pict?]{ + Requests a data conversion from @racket[v] to a @racket[pict?]. +} diff --git a/collects/texpict/mrpict.rkt b/collects/texpict/mrpict.rkt index cb38d9016b..d813d75a2d 100644 --- a/collects/texpict/mrpict.rkt +++ b/collects/texpict/mrpict.rkt @@ -1,14 +1,14 @@ - -(module mrpict mzscheme +#lang racket/base (require mzlib/unit - mzlib/contract - mzlib/class + racket/contract + racket/class racket/draw) (require racket/draw/draw-sig racket/draw/draw-unit "private/mrpict-sig.rkt" "private/common-sig.rkt" + "private/convertible.rkt" "mrpict-sig.rkt" "mrpict-unit.rkt") @@ -32,7 +32,7 @@ make-pict-drawer) (define family/c - (symbols 'base 'default 'decorative 'roman 'script 'swiss 'modern 'symbol 'system)) + (or/c 'base 'default 'decorative 'roman 'script 'swiss 'modern 'symbol 'system)) (define text-style/c (flat-rec-contract @@ -46,10 +46,15 @@ text-style/c)))) (provide/contract - [text (opt-> (string?) - (text-style/c - (and/c (between/c 1 255) integer?) - number?) - pict?)]) + [text (->* (string?) + (text-style/c + (and/c (between/c 1 255) integer?) + number?) + pict?)]) - (provide text-style/c)) + (provide text-style/c) + + (provide convert convertible?) + (provide/contract + [prop:convertible (struct-type-property/c (-> convertible? pict?))]) + \ No newline at end of file diff --git a/collects/texpict/private/common-unit.rkt b/collects/texpict/private/common-unit.rkt index c6442500d7..7cb13ff1b8 100644 --- a/collects/texpict/private/common-unit.rkt +++ b/collects/texpict/private/common-unit.rkt @@ -3,7 +3,8 @@ (require racket/draw racket/class racket/list - file/convertible) + (prefix-in file: file/convertible) + "convertible.rkt") (require "common-sig.rkt") @@ -22,8 +23,9 @@ panbox ; panorama box, computed on demand last) ; a descendent for the bottom-right #:mutable - #:property prop:convertible (lambda (v mode default) - (convert-pict v mode default))) + #:property prop:convertible (λ (v) v) + #:property file:prop:convertible (lambda (v mode default) + (convert-pict v mode default))) (define-struct child (pict dx dy sx sy syx sxy)) (define-struct bbox (x1 y1 x2 y2 ay dy)) diff --git a/collects/texpict/private/convertible.rkt b/collects/texpict/private/convertible.rkt new file mode 100644 index 0000000000..b324b7c2ff --- /dev/null +++ b/collects/texpict/private/convertible.rkt @@ -0,0 +1,19 @@ +#lang racket/base +(provide prop:convertible prop:convertible? convertible? convert) + +(define-values (prop:convertible -convertible? convertible-ref) + (make-struct-type-property 'convertible)) + +(define-values (prop:convertible? convertible?? convertible?-ref) + (make-struct-type-property 'convertible?)) + +(define (convertible? x) + (and (-convertible? x) + (if (convertible?? x) + ((convertible?-ref x) x) + #t))) + +(define (convert v) + (unless (convertible? v) + (raise-type-error 'convert "convertible" v)) + ((convertible-ref v) v)) diff --git a/collects/texpict/private/mrpict-extra.rkt b/collects/texpict/private/mrpict-extra.rkt index 2126db46e8..8cf8023a3f 100644 --- a/collects/texpict/private/mrpict-extra.rkt +++ b/collects/texpict/private/mrpict-extra.rkt @@ -1,7 +1,6 @@ #lang scheme/unit - (require mzlib/class - mzlib/etc) + (require racket/class) (require racket/draw/draw-sig racket/gui/dynamic) @@ -16,7 +15,7 @@ texpict-common-setup^) (define show-pict - (opt-lambda (p [w #f] [h #f]) + (λ (p [w #f] [h #f]) (define the-pict p) (define pict-drawer (make-pict-drawer the-pict)) (define no-redraw? #f)