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

add a convertible interface to texpict that lets

Browse Source 
values be convertiable to picts.

use that interface in DrRacket, but via the suboptimal
screen-bitmap route (for now)
This commit is contained in:
Robby Findler 2012-02-24 07:37:21 -06:00
parent 868cc4388f
commit df4dbe615f
6 changed files with 134 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/drracket/private/language.rkt
View File

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

40
collects/scribblings/slideshow/picts.scrbl
View File

@ -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?].
}

27
collects/texpict/mrpict.rkt
View File

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

8
collects/texpict/private/common-unit.rkt
View File

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

19
collects/texpict/private/convertible.rkt Normal file
View File

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

5
collects/texpict/private/mrpict-extra.rkt
View File

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