├── .gitignore ├── LICENSE ├── README.md ├── pict-doc ├── info.rkt └── pict │ ├── info.rkt │ └── scribblings │ ├── anim.scrbl │ ├── code.scrbl │ ├── color.scrbl │ ├── conditional.scrbl │ ├── more.scrbl │ ├── pict-diagram.rkt │ ├── pict.scrbl │ ├── shadow.scrbl │ └── tree-layout.scrbl ├── pict-lib ├── info.rkt ├── pict │ ├── balloon.rkt │ ├── code.rkt │ ├── color.rkt │ ├── conditional.rkt │ ├── convert.rkt │ ├── face.rkt │ ├── flash.rkt │ ├── main.rkt │ ├── private │ │ ├── convertible.rkt │ │ ├── hv.rkt │ │ ├── layout.rkt │ │ ├── main.rkt │ │ ├── naive-layered.rkt │ │ ├── pict.rkt │ │ ├── play-pict.rkt │ │ ├── tidier.rkt │ │ ├── transform.rkt │ │ └── utils.rkt │ ├── shadow.rkt │ └── tree-layout.rkt └── texpict │ ├── balloon.rkt │ ├── code.rkt │ ├── doc.txt │ ├── face.rkt │ ├── flash.rkt │ ├── mrpict.rkt │ └── utils.rkt ├── pict-test ├── info.rkt └── tests │ └── pict │ ├── code.rkt │ ├── main.rkt │ └── transform.rkt └── pict └── info.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | 4 | # common backups, autosaves, lock files, OS meta-files 5 | *~ 6 | \#* 7 | .#* 8 | .DS_Store 9 | *.bak 10 | TAGS 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pict 2 | 3 | This the source for the Racket packages: "pict", "pict-doc", "pict-lib", "pict-test". 4 | 5 | ### Contributing 6 | 7 | Contribute to Racket by submitting a [pull request], reporting an 8 | [issue], joining the [development mailing list], or visiting the 9 | IRC or Slack channels. 10 | 11 | ### License 12 | 13 | Racket, including these packages, is free software, see [LICENSE] 14 | for more details. 15 | 16 | By making a contribution, you are agreeing that your contribution 17 | is licensed under the [Apache 2.0] license and the [MIT] license. 18 | 19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt 21 | [pull request]: https://github.com/racket/pict/pulls 22 | [issue]: https://github.com/racket/pict/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | -------------------------------------------------------------------------------- /pict-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define build-deps '("draw-doc" 6 | "gui-doc" 7 | "slideshow-doc" 8 | "draw-lib" 9 | "gui-lib" 10 | "scribble-lib" 11 | "slideshow-lib" 12 | "pict-lib" 13 | "racket-doc" 14 | "scribble-doc")) 15 | (define deps '("base")) 16 | (define update-implies '("pict-lib")) 17 | 18 | (define pkg-desc "documentation part of \"pict\"") 19 | 20 | (define pkg-authors '(mflatt robby)) 21 | 22 | (define license 23 | '(Apache-2.0 OR MIT)) 24 | -------------------------------------------------------------------------------- /pict-doc/pict/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings 4 | '(("scribblings/pict.scrbl" (multi-page) (gui-library 100)))) 5 | -------------------------------------------------------------------------------- /pict-doc/pict/scribblings/anim.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require (for-label pict racket) 4 | scribble/example 5 | scribble/manual) 6 | 7 | @(define ss-eval (make-base-eval)) 8 | @(ss-eval '(require pict pict/code racket/format)) 9 | 10 | @title{Animation Helpers} 11 | 12 | These functions are designed to work with the 13 | slide constructors in @racketmodname[slideshow/play]. 14 | 15 | @declare-exporting[pict slideshow/play] 16 | 17 | @section{Pict Interpolations} 18 | 19 | @defproc[(fade-pict [n (real-in 0.0 1.0)] [p1 pict?] [p2 pict?] 20 | [#:combine combine (pict? pict? . -> . pict?) cc-superimpose] 21 | [#:composite? composite? any/c #t]) 22 | pict?]{ 23 | 24 | Interpolates @racket[p1] and @racket[p2], where the result with 25 | @racket[n] as @racket[0.0] is @racket[p1], and the result with 26 | @racket[n] as @racket[1.0] is @racket[p2]. For intermediate points, 27 | @racket[p1] fades out while @racket[p2] fades in as @racket[n] changes 28 | from @racket[0.0] to @racket[1.0]. At the same time, the width and 29 | height of the generated pict are intermediate between 30 | @racket[p1] and @racket[p2], and the relative baselines and last 31 | pict correspondingly morph within the bounding box. 32 | 33 | The @racket[combine] argument determines how @racket[p1] and 34 | @racket[p2] are aligned for morphing. For example, if @racket[p1] and 35 | @racket[p2] both contain multiple lines of text with the same line 36 | height but different number of lines, then using 37 | @racket[ctl-superimpose] would keep the ascent line in a fixed 38 | location relative to the top of the resulting pict as the rest of the 39 | shape morphs around it. 40 | 41 | The @racket[composite?] argument is passed to the @racket[cellophane] 42 | as used to implement fading. 43 | 44 | @examples[#:eval ss-eval 45 | (define (do-fade n) 46 | (fade-pict n (rectangle 30 30) (disk 30))) 47 | (apply ht-append 10 48 | (for/list ([n (in-range 0 1.2 0.2)]) 49 | (vc-append (text (~r n #:precision 2)) 50 | (do-fade n)))) 51 | ] 52 | 53 | @history[#:changed "1.15" @elem{Added @racket[#:composite?] and enabled compositing by default.}]} 54 | 55 | @defproc[(fade-around-pict [n (real-in 0.0 1.0)] 56 | [p1 pict?] 57 | [make-p2 (pict? . -> . pict?)] 58 | [#:composite? composite? any/c #t]) 59 | pict?]{ 60 | 61 | Similar to @racket[fade-pict], but the target is not a fixed 62 | @racket[_p2], but instead a function @racket[make-p2] that takes a 63 | @racket[launder]ed @racket[ghost] of @racket[p1] and places it into a 64 | larger scene. Also, @racket[p1] does not fade out as @racket[n] 65 | increases; instead, @racket[p1] is placed wherever its ghost appears 66 | in the result of @racket[make-p2]. 67 | 68 | For example, 69 | 70 | @examples[#:eval ss-eval #:label #f #:escape THERE-IS-NO-ESCAPE 71 | (get-current-code-font-size (λ () 20)) 72 | 73 | (define do-fade 74 | (lambda (n) 75 | (fade-around-pict n 76 | (code x) 77 | (lambda (g) (code (+ #,g 1)))))) 78 | 79 | (apply ht-append 10 80 | (for/list ([n (in-range 0 1.2 0.2)]) 81 | (vc-append (text (~r n #:precision 2)) 82 | (do-fade n)))) 83 | ] 84 | 85 | animates the wrapping of @racket[x] with a @racket[(+ .... 1)] form. 86 | 87 | @history[#:changed "1.15" @elem{Added @racket[#:composite?] and enabled compositing by default.}]} 88 | 89 | @defproc[(slide-pict [base pict?] 90 | [p pict?] 91 | [p-from pict?] 92 | [p-to pict?] 93 | [n (real-in 0.0 1.0)]) 94 | pict?]{ 95 | 96 | Pins @racket[p] onto @racket[base], sliding from @racket[p-from] to 97 | @racket[p-to] (which are picts within @racket[base]) as 98 | @racket[n] goes from @racket[0.0] to @racket[1.0]. The top-left 99 | locations of @racket[p-from] and @racket[p-to] determine the placement 100 | of the top-left of @racket[p]. 101 | 102 | The @racket[p-from] and @racket[p-to] picts are typically 103 | @racket[launder]ed @racket[ghost]s of @racket[p] within @racket[base], 104 | but they can be any picts within @racket[base]. 105 | 106 | @examples[#:eval ss-eval 107 | (define (do-slide n) 108 | (define p1 (disk 30 #:color "plum")) 109 | (define p2 (disk 30 #:color "palegreen")) 110 | (define p3 (frame (inset (hc-append 30 p1 p2) 10))) 111 | (slide-pict p3 112 | (disk 10) 113 | p1 p2 n)) 114 | 115 | (apply ht-append 10 116 | (for/list ([n (in-range 0 1.2 0.2)]) 117 | (vc-append (text (~r n #:precision 2)) 118 | (do-slide n)))) 119 | ]} 120 | 121 | @defproc[(slide-pict/center [base pict?] 122 | [p pict?] 123 | [p-from pict?] 124 | [p-to pict?] 125 | [n (real-in 0.0 1.0)]) 126 | pict?]{ 127 | 128 | Like @racket[slide-pict], but aligns the center of @racket[p] 129 | with @racket[p-from] and @racket[p-to]. 130 | 131 | @examples[#:eval ss-eval 132 | (define (do-slide n) 133 | (define p1 (disk 30 #:color "plum")) 134 | (define p2 (disk 30 #:color "palegreen")) 135 | (define p3 (frame (inset (hc-append 30 p1 p2) 10))) 136 | (slide-pict/center p3 137 | (disk 10) 138 | p1 p2 n)) 139 | 140 | (apply ht-append 10 141 | (for/list ([n (in-range 0 1.2 0.2)]) 142 | (vc-append (text (~r n #:precision 2)) 143 | (do-slide n)))) 144 | ]} 145 | 146 | @; -------------------------------------------------- 147 | 148 | @section{Merging Animations} 149 | 150 | @defproc[(sequence-animations [gen (-> (real-in 0.0 1.0) pict?)] 151 | ...) 152 | (-> (real-in 0.0 1.0) pict?)]{ 153 | 154 | Converts a list of @racket[gen] functions into a single function that 155 | uses each @racket[gen] in sequence.} 156 | 157 | @defproc[(reverse-animations [gen (-> (real-in 0.0 1.0) pict?)] 158 | ...) 159 | (-> (real-in 0.0 1.0) pict?)]{ 160 | 161 | Converts a list of @racket[gen] functions into a single function that 162 | run @racket[(sequence-animations gen ...)] in reverse.} 163 | 164 | @; -------------------------------------------------- 165 | 166 | @section{Stretching and Squashing Time} 167 | 168 | @deftogether[( 169 | @defproc[(fast-start [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)] 170 | @defproc[(fast-end [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)] 171 | @defproc[(fast-edges [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)] 172 | @defproc[(fast-middle [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)] 173 | )]{ 174 | 175 | Monotonically but non-uniformly maps @racket[n] with fixed 176 | points at @racket[0.0] and @racket[1.0]. 177 | 178 | Suppose that we have the following definitions for our examples: 179 | 180 | @examples[#:eval ss-eval #:label #f 181 | (define (do-slide n fast-proc) 182 | (define p1 (filled-rectangle 20 20 #:color "yellowgreen")) 183 | (define p2 (filled-rectangle 20 20 #:color "khaki")) 184 | (define p3 (frame (inset (hc-append 25 p1 p2) 10))) 185 | (slide-pict/center 186 | p3 187 | (disk 10) 188 | p1 p2 189 | (code:comment "note use of fast-proc") 190 | (fast-proc n))) 191 | 192 | (define (run-animation fast-proc) 193 | (apply ht-append 10 194 | (for/list ([n (in-range 0 1.09 0.1)]) 195 | (vc-append (text (~r n #:precision 2)) 196 | (do-slide n fast-proc))))) 197 | ] 198 | 199 | A normal use of the animation looks like this: 200 | 201 | @examples[#:eval ss-eval #:label #f 202 | (run-animation (λ (n) n)) 203 | ] 204 | 205 | The @racket[fast-start] mapping is convex, so that 206 | 207 | @racketblock[(slide-pict _base p _p1 _p2 (fast-start n))] 208 | 209 | appears to move quickly away from @racket[_p1] and then slowly as it 210 | approaches @racket[_p2], assuming that @racket[n] increases uniformly. 211 | 212 | Applying it to the animation above produces this: 213 | 214 | @examples[#:eval ss-eval #:label #f 215 | (run-animation fast-start) 216 | ] 217 | 218 | The @racket[fast-end] mapping is concave, so that 219 | 220 | @racketblock[(slide-pict _base _p _p1 _p2 (fast-end _n))] 221 | 222 | appears to move slowly away from @racket[_p1] and then quickly as it 223 | approaches @racket[_p2], assuming that @racket[_n] increases uniformly. 224 | 225 | @examples[#:eval ss-eval #:label #f 226 | (run-animation fast-end) 227 | ] 228 | 229 | The @racket[fast-edges] mapping is convex at first and concave at the 230 | end, so that 231 | 232 | @racketblock[(slide-pict _base _p _p1 _p2 (fast-edges _n))] 233 | 234 | appears to move quickly away from @racket[_p1], then more slowly, and 235 | then quickly again near @racket[_p2], assuming that @racket[_n] increases 236 | uniformly. 237 | 238 | @examples[#:eval ss-eval #:label #f 239 | (run-animation fast-edges) 240 | ] 241 | 242 | The @racket[fast-middle] mapping is concave at first and convex at the 243 | end, so that 244 | 245 | @racketblock[(slide-pict _base _p _p1 _p2 (fast-middle _n))] 246 | 247 | @examples[#:eval ss-eval #:label #f 248 | (run-animation fast-middle) 249 | ] 250 | 251 | appears to move slowly away from @racket[_p1], then more quickly, and 252 | then slowly again near @racket[_p2], assuming that @racket[_n] increases 253 | uniformly.} 254 | 255 | @defproc[(split-phase [n (real-in 0.0 1.0)]) 256 | (values (real-in 0.0 1.0) (real-in 0.0 1.0))]{ 257 | 258 | Splits the progression of @racket[n] from @racket[0.0] to @racket[1.0] 259 | into a progression from @racket[(values 0.0 0.0)] to @racket[(values 260 | 1.0 0.0)] and then @racket[(values 1.0 0.0)] to @racket[(values 1.0 261 | 1.0)]. 262 | 263 | Here is an example that shows how to apply @racket[split-phase] to 264 | the animation from the examples for @racket[fast-start]: 265 | 266 | @examples[#:eval ss-eval #:label #f 267 | (apply ht-append 10 268 | (for/list ([n (in-range 0 1.09 0.1)]) 269 | (define-values (n1 n2) (split-phase n)) 270 | (vc-append (text (~r n #:precision 2)) 271 | (do-slide n1 (λ (n) n)) 272 | (do-slide n2 (λ (n) n))))) 273 | ]} 274 | 275 | @close-eval[ss-eval] 276 | -------------------------------------------------------------------------------- /pict-doc/pict/scribblings/code.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require scribble/manual 3 | scribble/eval 4 | (for-label (except-in racket only drop) 5 | pict/code 6 | pict 7 | racket/gui/base)) 8 | 9 | @(define stx-obj 10 | (tech #:doc '(lib "scribblings/reference/reference.scrbl") "syntax object")) 11 | 12 | @(define ss-eval (make-base-eval)) 13 | @(interaction-eval #:eval ss-eval 14 | (begin 15 | (require pict/code 16 | pict 17 | (for-syntax racket/base)) 18 | (current-code-tt (lambda (s) (text s "monospace" 14))) 19 | (define-code code typeset-code))) 20 | 21 | @title{Typesetting Racket Code} 22 | 23 | @defmodule[pict/code]{This library is re-provided by 24 | @racketmodname[slideshow/code], but 25 | initializes @racket[get-current-code-font-size].} 26 | 27 | @defproc[(typeset-code [stx syntax?]) pict?]{ 28 | 29 | Produces a pict for code in the given @|stx-obj|. The 30 | source-location information of the syntax object determines the line 31 | breaks, line indenting, and space within a row. Empty rows are 32 | ignored. 33 | 34 | Beware that if you use @racket[read-syntax] on a file port, you may 35 | have to turn on line counting via @racket[port-count-lines!] for the 36 | code to typeset properly. 37 | 38 | Normally, @racket[typeset-code] is used through the @racket[code] 39 | syntactic form, which works properly with compilation, and that 40 | escapes to pict-producing code via @racket[unsyntax]. See also 41 | @racket[define-code]. 42 | 43 | Embedded picts within @racket[stx] are used directly. Row elements are 44 | combined using and operator like @racket[htl-append], so use 45 | @racket[code-align] (see below) as necessary to add an ascent to 46 | ascentless picts. More precisely, creation of a line of code uses 47 | @racket[pict-last] to determine the end point of the element most 48 | recently added to a line; the main effect is that closing parentheses 49 | are attached in the right place when a multi-line pict is embedded in 50 | @racket[stx]. 51 | 52 | An identifier that starts with @litchar{_} is italicized in the pict, 53 | and the @litchar{_} is dropped, unless the 54 | @racket[code-italic-underscore-enabled] parameter is set to 55 | @racket[#f]. Also, unless @racket[code-scripts-enabled] is set to 56 | @racket[#f], @litchar{_} and @litchar{^} in the middle of a word 57 | create superscripts and subscripts, respectively (like TeX); for 58 | example @racketidfont{foo^4_ok} is displayed as the identifier 59 | @racketidfont{foo} with a @racketidfont{4} superscript and an 60 | @racketidfont{ok} subscript. 61 | 62 | Further, uses of certain identifiers in @racket[stx] typeset 63 | specially: 64 | 65 | @itemize[ 66 | 67 | @item{@as-index{@racketidfont{code:blank}} --- produces a space.} 68 | 69 | @item{@racket[(#,(as-index (racketidfont "code:comment")) _s ...)] 70 | --- produces a comment (prefixed with a single semicolon), with each @racket[_s] on the same line, 71 | where each @racket[_s] must be a string or a value that is @tech{pict convertible}.} 72 | 73 | @item{@racket[(#,(as-index (racketidfont "code:comment2")) _s ...)] 74 | --- produces a comment (prefixed with two semicolons), with each @racket[_s] on the same line, 75 | where each @racket[_s] must be a string or a value that is @tech{pict convertible}.} 76 | 77 | @item{@racket[(#,(as-index (racketidfont "code:line")) _datum ...)] 78 | --- typesets the @racket[_datum] sequence, which is mostly useful for 79 | the top-level sequence, since @racket[typeset-code] accepts only one 80 | argument.} 81 | 82 | @item{@racket[(#,(as-index (racketidfont "code:contract")) _datum 83 | ...)] --- like @racketidfont{code:line}, but every @racket[_datum] 84 | is colored as a comment, and a @litchar{;} is prefixed to every line.} 85 | 86 | @item{@racket[(#,(as-index (racketidfont "code:template")) _datum 87 | ...)] --- like @racketidfont{code:line}, but a @litchar{;} is 88 | prefixed to every line.} 89 | 90 | @item{@racketidfont{$} --- typesets as a vertical bar (for no 91 | particularly good reason).} 92 | 93 | ]} 94 | 95 | 96 | @defform[(code datum ...)]{ 97 | 98 | The macro form of @racket[typeset-code]. Within a @racket[datum], 99 | @racket[unsyntax] can be used to escape to an expression, and 100 | identifiers bound as syntax to @tech{code transformer}s trigger 101 | transformations. 102 | 103 | For more information, see @racket[typeset-code] and 104 | @racket[define-code], since @racket[code] is defined as 105 | 106 | @racketblock[ 107 | (define-code code typeset-code) 108 | ] 109 | 110 | @defexamples[#:eval ss-eval #:escape potato 111 | (code (+ 1 2)) 112 | (code (+ 1 #,(+ 1 1))) 113 | (code (+ 1 #,(frame (code 2)))) 114 | (define-syntax two (make-code-transformer #'(code 2))) 115 | (code (+ 1 two)) 116 | ]} 117 | 118 | 119 | @defparam[current-code-font style text-style/c]{ 120 | 121 | Parameter for a base font used to typeset text. The default is 122 | @racket[`(bold . modern)]. For even more control, see 123 | @racket[current-code-tt].} 124 | 125 | 126 | @defparam[current-code-tt proc (string? . -> . pict?)]{ 127 | 128 | Parameter for a one-argument procedure to turn a 129 | string into a pict, used to typeset text. The default is 130 | 131 | @racketblock[ 132 | (lambda (s) (text s (current-code-font) ((get-current-code-font-size)))) 133 | ] 134 | 135 | This procedure is not used to typeset subscripts or other items that 136 | require font changes, where @racket[current-code-font] is used 137 | directly.} 138 | 139 | 140 | @defparam[get-current-code-font-size proc (-> exact-nonnegative-integer?)]{ 141 | 142 | A parameter used to access the default font size. The 143 | @racketmodname[slideshow/code] library initializes this parameter to 144 | @racket[current-font-size].} 145 | 146 | 147 | @defparam[current-code-line-sep amt real?]{ 148 | 149 | A parameter that determines the spacing between lines of typeset code. 150 | The default is @racket[2].} 151 | 152 | 153 | @defparam[current-comment-color color (or/c string? (is-a?/c color%))]{ 154 | 155 | A parameter for the color of comments.} 156 | 157 | 158 | @defparam[current-keyword-color color (or/c string? (is-a?/c color%))]{ 159 | 160 | A parameter for the color of syntactic-form names. See 161 | @racket[current-keyword-list].} 162 | 163 | 164 | @defparam[current-id-color color (or/c string? (is-a?/c color%))]{ 165 | 166 | A parameter for the color of identifiers that are not syntactic form 167 | names or constants.} 168 | 169 | 170 | @defparam[current-literal-color color (or/c string? (is-a?/c color%))]{ 171 | 172 | A parameter for the color of literal values, such as strings and 173 | numbers. See also @racket[current-literal-list]} 174 | 175 | 176 | @defparam[current-const-color color (or/c string? (is-a?/c color%))]{ 177 | 178 | A parameter for the color of constant names. See 179 | @racket[current-const-list].} 180 | 181 | 182 | @defparam[current-base-color color (or/c string? (is-a?/c color%))]{ 183 | 184 | A parameter for the color of everything else.} 185 | 186 | 187 | @defparam[current-reader-forms syms (listof symbol?)]{ 188 | 189 | Parameter for a list of symbols indicating which built-in reader forms 190 | should be used. The default is @racket['(quote quasiquote unquote 191 | unquote-splicing syntax quasisyntax unsyntax unsyntax-splicing)]. 192 | Remove a symbol to suppress the corresponding reader output.} 193 | 194 | 195 | @defproc[(code-align [pict pict?]) pict?]{ 196 | 197 | Adjusts the ascent of @racket[pict] so that its bottom aligns with the 198 | baseline for text; use this function when @racket[pict] has no 199 | ascent.} 200 | 201 | 202 | @defparam[current-keyword-list names (listof string?)]{ 203 | 204 | A list of strings to color as syntactic-form names. The default 205 | includes all of the forms provided by @racketmodname[racket/base] 206 | and all of the forms provided by @racketmodname[mzscheme #:indirect].} 207 | 208 | 209 | @defparam[current-const-list names (listof string?)]{ 210 | 211 | A list of strings to color as constant names. The default is 212 | @racket[null].} 213 | 214 | 215 | @defparam[current-literal-list names (listof string?)]{ 216 | 217 | A list of strings to color as literals, in addition to literals such 218 | as strings. The default is @racket[null].} 219 | 220 | @defthing[racket/base-const-list (listof string?)]{ 221 | 222 | A list of strings that could be used to initialize the 223 | @racket[current-const-list] parameter.} 224 | 225 | @defthing[mzscheme-const-list (listof string?)]{ 226 | 227 | A list of strings that could be used to initialize the 228 | @racket[current-const-list] parameter.} 229 | 230 | @defboolparam[code-colorize-enabled on?]{ 231 | 232 | A parameter to enable or disable all code coloring. The default is 233 | @racket[#t].} 234 | 235 | 236 | @defboolparam[code-colorize-quote-enabled on?]{ 237 | 238 | A parameter to control whether the datum under a @racket[quote] is colorized as 239 | a literal (as in this documentation). The default is @racket[#t].} 240 | 241 | 242 | @defboolparam[code-italic-underscore-enabled on?]{ 243 | 244 | A parameter to control whether @litchar{_}-prefixed identifiers are 245 | italicized (dropping the @litchar{_}). The default is @racket[#t].} 246 | 247 | @defboolparam[code-scripts-enabled on?]{ 248 | 249 | A parameter to control whether TeX-style subscripts and subscripts are 250 | recognized in an identifier.} 251 | 252 | @defform*[[(define-code code-id typeset-code-id) 253 | (define-code code-id typeset-code-id escape-id)]]{ 254 | 255 | Defines @racket[code-id] as a macro that uses 256 | @racket[typeset-code-id], which is a function with the same input as 257 | @racket[typeset-code]. The @racket[escape-id] form defaults to 258 | @racket[unsyntax]. 259 | 260 | The resulting @racket[code-id] syntactic form takes a sequence of 261 | @racket[_datum]s: 262 | 263 | @racketblock[ 264 | (code-id _datum ...) 265 | ] 266 | 267 | It produces a pict that typesets the sequence. Source-location 268 | information for the @racket[_datum] determines the layout of code in 269 | the resulting pict. The @racket[code-id] is expanded in such a way 270 | that source location is preserved during compilation (so 271 | @racket[typeset-code-id] receives a syntax object with source 272 | locations intact). 273 | 274 | If a @racket[_datum] contains @racket[(escape-id _expr)]---perhaps as 275 | @RACKET[#,_expr] when @racket[escape-id] is @racket[unsyntax]---then 276 | the @racket[_expr] is evaluated and the result datum is spliced in 277 | place of the @racket[escape-id] form in @racket[_datum]. If the result 278 | is not a syntax object, it is given the source location of the 279 | @racket[escape-id] form. A pict value injected this way as a 280 | @racket[_datum] is rendered as itself. 281 | 282 | If a @racket[_datum] contains @racket[(transform-id _datum ...)] or 283 | @racket[transform-id] for a @racket[transform-id] that is bound as syntax to a 284 | @tech{code transformer}, then the @racket[(transform-id _datum ...)] 285 | or @racket[transform-id] may be replaced with an escaped expression, 286 | depending on the @tech{code transformer}'s result.} 287 | 288 | @deftogether[( 289 | @defproc[(make-code-transformer [proc-or-stx (or/c (syntax? . -> . (or/c syntax? #f)) 290 | syntax?)]) 291 | code-transformer?] 292 | @defthing[prop:code-transformer struct-type-property?] 293 | @defproc[(code-transformer? [v any/c]) boolean?] 294 | )]{ 295 | 296 | Exported @racket[for-syntax] for creating @deftech{code transformers}. 297 | 298 | For @tech{code transformer} created with 299 | @racket[(make-code-transformer _proc)], @racket[proc] takes a syntax 300 | object representing the use of an identifier bound to the transformer, 301 | and it produces an expression whose value replaces the identifier use 302 | within a @racket[code] form or a form defined via 303 | @racket[define-code]. Like a macro transformer, a code transformer is 304 | triggered either by a use of the bound identifier in an 305 | ``application'' position, in which case the transformer receives the 306 | entire ``application'' form, or the identifier by itself can also 307 | trigger the transformer. The @tech{code transformer}'s @racket[_proc] 308 | can return @racket[#f], in which case the use of the identifier is 309 | left untransformed; if the identifier was used in an ``application'' 310 | position, the transformer @racket[_proc] will be called again for the 311 | identifier use by itself. 312 | 313 | A @tech{code transformer} produced by @racket[(make-code-transformer _stx)] 314 | is equivalent to 315 | 316 | @racketblock[ 317 | (make-code-transformer (lambda (use-stx) 318 | (if (identifier? use-stx) 319 | _stx 320 | #f))) 321 | ] 322 | 323 | A structure type with the @racket[prop:code-transformer] property 324 | implements a @tech{code transformer}. The property value must be a 325 | procedure of one argument, which receives the structure and returns a 326 | procedure that is like a @racket[_proc] passed to 327 | @racket[make-code-transformer], except that the property value takes 328 | the structure instance as an argument before the syntax object to 329 | transform. 330 | 331 | The @racket[code-transformer?] predicate returns @racket[#t] for a 332 | value produced by @racket[make-code-transformer] or for an instance of 333 | a structure type with the @racket[prop:code-transformer] property, 334 | @racket[#f] otherwise. 335 | 336 | @examples[ 337 | #:eval ss-eval 338 | (let-syntax ([bag (make-code-transformer #'(code hat))] 339 | [copy (make-code-transformer (syntax-rules () 340 | [(_ c) (code (* 2 c))]))]) 341 | (inset (frame (code ((copy cat) in the bag))) 2)) 342 | ]} 343 | 344 | 345 | @defform[(define-exec-code (pict-id runnable-id string-id) 346 | datum ...)]{ 347 | 348 | Binds @racket[pict-id] to the result of @racket[(code datum ...)], 349 | except that if an identifier @racketidfont{_} appears anywhere in a 350 | @racket[datum], then the identifier and the following expression are 351 | not included for @racket[code]. 352 | 353 | Meanwhile, @racket[runnable-id] is bound to a @|stx-obj| that wraps 354 | the @racket[datum]s in a @racket[begin]. In this case, 355 | @racketidfont{_}s are removed from the @racket[datum]s, but not the 356 | following expression. Thus, an @racketidfont{_} identifier is used to 357 | comment out an expression from the pict, but have it present in the 358 | @|stx-obj| for evaluation. 359 | 360 | The @racket[string-id] is bound to a string representation of the code 361 | that is in the pict. This string is useful for copying to the 362 | clipboard with @racket[(send the-clipboard set-clipboard-string 363 | string-id 0)].} 364 | 365 | 366 | @defform[(define-exec-code/scale scale-expr (pict-id runnable-id string-id) 367 | datum ...)]{ 368 | 369 | Like @racket[define-exec-code], but with a scale to use via 370 | @racket[scale/improve-new-text] when generating the pict.} 371 | 372 | 373 | @deftogether[( 374 | @defthing[comment-color (or/c string? (is-a?/c color%))] 375 | @defthing[keyword-color (or/c string? (is-a?/c color%))] 376 | @defthing[id-color (or/c string? (is-a?/c color%))] 377 | @defthing[literal-color (or/c string? (is-a?/c color%))] 378 | )]{ 379 | 380 | For backward compatibility, the default values for 381 | @racket[current-comment-color], etc.} 382 | 383 | @defproc[(code-pict-bottom-line-pict [pict pict?]) 384 | (or/c pict? #f)]{ 385 | 386 | The same as @racket[pict-last], provided for backward compatibility.} 387 | 388 | @defproc[(pict->code-pict [pict pict?] [bl-pict (or/c pict? #f)]) pict?]{ 389 | 390 | Mainly for backward compatibility: returns @racket[(if bl-pict 391 | (use-last pict (or (pict-last bl-pict) bl-pict)))].} 392 | 393 | @; ---------------------------------------- 394 | 395 | @section{Codeblocks} 396 | 397 | @(require (for-label (only-in scribble/manual codeblock))) 398 | 399 | @defproc[(codeblock-pict [code-string string?] [#:keep-lang-line? keep? any/c #t]) pict?]{ 400 | 401 | Like Scribble's @racket[codeblock] but generates picts. 402 | 403 | Unlike @racket[code], @racket[codeblock-pict] formats and 404 | colors based on the code's language's lexer, which makes it 405 | suitable for use with code that doesn't use Racket syntax. 406 | 407 | When @racket[keep?] is @racket[#f], the first @tt{#lang} 408 | line is removed from the pict. 409 | 410 | @(ss-eval '(require racket/string)) 411 | @defexamples[#:eval ss-eval 412 | (codeblock-pict 413 | #:keep-lang-line? #f 414 | (string-join 415 | '("#lang 2d racket" 416 | "(require 2d/cond)" 417 | "(define (same? a b)" 418 | " #2dcond" 419 | " ╔═════════════╦═══════════════════════╦═════════════╗" 420 | " ║ ║ (pair? a) ║ (number? a) ║" 421 | " ╠═════════════╬═══════════════════════╬═════════════╣" 422 | " ║ (pair? b) ║ (and (same? (car a) ║ #f ║" 423 | " ║ ║ (car b)) ║ ║" 424 | " ║ ║ (same? (cdr a) ║ ║" 425 | " ║ ║ (cdr b))) ║ ║" 426 | " ╠═════════════╬═══════════════════════╬═════════════╣" 427 | " ║ (number? b) ║ #f ║ (= a b) ║" 428 | " ╚═════════════╩═══════════════════════╩═════════════╝)") 429 | "\n")) 430 | ] 431 | 432 | } 433 | 434 | @defparam[current-token-class->color to-color (-> symbol? (or/c string? (is-a?/c color%)))]{ 435 | 436 | A parameter that provides additional control over the colors used by @racket[codeblock-pict]. The 437 | @racket[to-color] procedure is applied to each token class produced by a language’s lexer to map the 438 | class name to a particular color. 439 | 440 | The default value maps the standard set of token classes (as recognized by DrRacket) to the 441 | corresponding colors used by @racket[code]. Specifically, it maps 442 | 443 | @itemlist[ 444 | @item{@racket['no-color], @racket['parenthesis], and @racket['hash-colon-keyword] to 445 | @racket[(current-base-color)],} 446 | @item{@racket['symbol] to @racket[(current-id-color)],} 447 | @item{@racket['keyword] to @racket[(current-keyword-color)],} 448 | @item{@racket['string] and @racket['constant] to @racket[(current-literal-color)],} 449 | @item{@racket['comment] to @racket[(current-comment-color)],} 450 | @item{@racket['white-space] to @racket["white"],} 451 | @item{and everything else to @racket["black"].}] 452 | 453 | It is usually sufficient to adjust the individual color parameters also used by @racket[code], but 454 | @racket[current-token-class->color] allows for more fine-grained control over how 455 | @racket[codeblock-pict] interprets token classes. 456 | 457 | @history[#:added "1.8"]} 458 | 459 | @; ---------------------------------------- 460 | 461 | @(close-eval ss-eval) 462 | -------------------------------------------------------------------------------- /pict-doc/pict/scribblings/color.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label pict pict/color racket/base racket/contract) 4 | scribble/eval) 5 | 6 | @(define the-eval (make-base-eval)) 7 | @(the-eval '(require pict pict/color)) 8 | 9 | @title{Color Helpers} 10 | 11 | @defmodule[pict/color] 12 | 13 | 14 | @deftogether[( 15 | @defproc[(red [pict pict?]) pict?] 16 | @defproc[(orange [pict pict?]) pict?] 17 | @defproc[(yellow [pict pict?]) pict?] 18 | @defproc[(green [pict pict?]) pict?] 19 | @defproc[(blue [pict pict?]) pict?] 20 | @defproc[(purple [pict pict?]) pict?] 21 | @defproc[(black [pict pict?]) pict?] 22 | @defproc[(brown [pict pict?]) pict?] 23 | @defproc[(gray [pict pict?]) pict?] 24 | @defproc[(white [pict pict?]) pict?] 25 | @defproc[(cyan [pict pict?]) pict?] 26 | @defproc[(magenta [pict pict?]) pict?] 27 | )]{ 28 | 29 | These functions apply appropriate colors to picture @racket[p]. 30 | 31 | @examples[#:eval the-eval 32 | (red (disk 20)) 33 | ] 34 | @history[#:added "1.4"]{} 35 | } 36 | 37 | @deftogether[( 38 | @defproc[(light [color color/c]) color/c] 39 | @defproc[(dark [color color/c]) color/c] 40 | )]{ 41 | 42 | These functions produce lighter or darker versions of a color. 43 | 44 | @examples[#:eval the-eval 45 | (hc-append (colorize (disk 20) "red") 46 | (colorize (disk 20) (dark "red")) 47 | (colorize (disk 20) (light "red"))) 48 | ] 49 | 50 | @history[#:added "1.4"]{} 51 | } 52 | 53 | @defthing[color/c flat-contract?]{ 54 | 55 | This contract recognizes color strings, @racket[color%] instances, and RGB color 56 | lists. 57 | 58 | @history[#:added "1.4"]{} 59 | } 60 | 61 | @(close-eval the-eval) 62 | -------------------------------------------------------------------------------- /pict-doc/pict/scribblings/conditional.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label pict pict/conditional racket/base racket/contract) 4 | scribble/eval) 5 | 6 | @(define the-eval (make-base-eval)) 7 | @(the-eval '(require pict pict/conditional)) 8 | 9 | @title{Conditional Combinations} 10 | 11 | @defmodule[pict/conditional] 12 | 13 | These pict control flow operators decide which pict of several to use. All 14 | branches are evaluated; the resulting pict is a combination of the pict chosen 15 | by normal conditional flow with @racket[ghost] applied to all the other picts. 16 | The result is a picture large enough to accommodate each alternative, but showing 17 | only the chosen one. This is useful for staged slides, as the pict chosen may 18 | change with each slide but its size and position will not. 19 | 20 | @defform/subs[(pict-if maybe-combine test-expr then-expr else-expr) 21 | ([maybe-combine code:blank (code:line #:combine combine-expr)])]{ 22 | 23 | Chooses either @racket[then-expr] or @racket[else-expr] based on 24 | @racket[test-expr], similarly to @racket[if]. Combines the chosen, visible 25 | image with the other, invisible image using @racket[combine-expr], defaulting to 26 | @racket[lbl-superimpose]. 27 | 28 | @examples[#:eval the-eval 29 | (let ([f (lambda (x) 30 | (pict-if x 31 | (disk 20) 32 | (disk 40)))]) 33 | (hc-append 10 34 | (frame (f #t)) 35 | (frame (f #f)))) 36 | ] 37 | 38 | @history[#:added "1.4"]{} 39 | } 40 | 41 | @defform/subs[(pict-cond maybe-combine [test-expr pict-expr] ...) 42 | ([maybe-combine code:blank (code:line #:combine combine-expr)])]{ 43 | 44 | Chooses a @racket[pict-expr] based on the first successful @racket[test-expr], 45 | similarly to @racket[cond]. Combines the chosen, visible image with the other, 46 | invisible images using @racket[combine-expr], defaulting to 47 | @racket[lbl-superimpose]. 48 | 49 | @examples[#:eval the-eval 50 | (let ([f (lambda (x) 51 | (pict-cond #:combine cc-superimpose 52 | [(eq? x 'circle) (circle 20)] 53 | [(eq? x 'disk) (disk 40)] 54 | [(eq? x 'text) (text "ok" null 20)]))]) 55 | (hc-append 10 56 | (frame (f 'circle)) 57 | (frame (f 'disk)) 58 | (frame (f 'text)))) 59 | ] 60 | 61 | @history[#:added "1.4"]{} 62 | } 63 | 64 | @defform/subs[(pict-case test-expr maybe-combine [literals pict-expr] ...) 65 | ([maybe-combine code:blank (code:line #:combine combine-expr)])]{ 66 | 67 | Chooses a @racket[pict-expr] based on @racket[test-expr] and each list of 68 | @racket[literals], similarly to @racket[case]. Combines the chosen, visible 69 | image with the other, invisible images using @racket[combine-expr], defaulting 70 | to @racket[lbl-superimpose]. 71 | 72 | @examples[#:eval the-eval 73 | (let ([f (lambda (x) 74 | (pict-case x 75 | [(circle) (circle 20)] 76 | [(disk) (disk 40)] 77 | [(text) (text "ok" null 20)]))]) 78 | (hc-append 10 79 | (frame (f 'circle)) 80 | (frame (f 'disk)) 81 | (frame (f 'text)))) 82 | ] 83 | 84 | @history[#:added "1.4"]{} 85 | } 86 | 87 | @deftogether[( 88 | @defproc[(show [pict pict?] [show? any/c #t]) pict?] 89 | @defproc[(hide [pict pict?] [hide? any/c #t]) pict?] 90 | )]{ 91 | 92 | These functions conditionally show or hide an image, essentially choosing 93 | between @racket[pict] and @racket[(ghost pict)]. The only difference between 94 | the two is the default behavior and the opposite meaning of the @racket[show?] 95 | and @racket[hide?] booleans. Both functions are provided for mnemonic purposes. 96 | 97 | @history[#:added "1.4"]{} 98 | } 99 | 100 | @(close-eval the-eval) 101 | -------------------------------------------------------------------------------- /pict-doc/pict/scribblings/more.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "pict-diagram.rkt" 3 | scribble/eval scribble/manual 4 | pict/face pict 5 | (for-label racket/gui 6 | slideshow/base slideshow/code 7 | pict/flash pict/face pict/balloon 8 | (except-in racket only drop) 9 | pict 10 | pict/convert)) 11 | 12 | 13 | @(define ss-eval (make-base-eval)) 14 | @(ss-eval '(require pict racket/math racket/class racket/draw 15 | racket/list pict/balloon pict/flash)) 16 | 17 | @title{More Pict Constructors} 18 | 19 | 20 | @section{Dingbats} 21 | 22 | @defproc[(cloud [w real?] 23 | [h real?] 24 | [color (or/c string? (is-a?/c color%)) "gray"] 25 | [#:style style (listof (or/c 'square 26 | 'nw 'ne 'sw 'se 27 | 'wide)) 28 | null]) 29 | pict?]{ 30 | 31 | Creates a fluffy cloud. 32 | 33 | Supplying @racket['nw] (northwest), @racket['ne] (northeast), 34 | @racket['sw] (southwest), or @racket['se] (southeast) in 35 | @racket[style] extends the cloud to better cover the corner within its 36 | bounding box in the corresponding direction. The @racket['square] 37 | style is a shorthand for all of those combined. The @racket['wide] 38 | style increases the number of bumps along the cloud's top and bottom 39 | edges. 40 | 41 | @examples[#:eval ss-eval 42 | (cloud 100 75) 43 | (cloud 100 75 "lavenderblush") 44 | (cloud 100 75 #:style '(square wide)) 45 | ] 46 | 47 | @history[#:changed "1.6" @elem{Added @racket[style].}]} 48 | 49 | @defproc[(file-icon [w real?] 50 | [h real?] 51 | [color (or/c string? (is-a?/c color%) any/c)] 52 | [shaded? any/c #f]) 53 | pict?]{ 54 | 55 | Creates a Mac-like file icon, optionally shaded. If @racket[color] is 56 | not a string or @racket[color%] object, it is treated as a boolean, in 57 | which case true means @racket["gray"] and false means 58 | @racket["white"]. 59 | 60 | @examples[#:eval ss-eval 61 | (file-icon 50 60 "bisque") 62 | (file-icon 50 60 "honeydew" #t) 63 | ]} 64 | 65 | @defproc[(standard-fish [w real?] 66 | [h real?] 67 | [#:direction direction (or/c 'left 'right) 'left] 68 | [#:color color (or/c string? (is-a?/c color%)) "blue"] 69 | [#:eye-color eye-color (or/c string? (is-a?/c color%) #f) "black"] 70 | [#:open-mouth open-mouth (or/c boolean? real?) #f]) 71 | pict?]{ 72 | 73 | Creates a fish swimming either @racket['left] or @racket['right]. 74 | If @racket[eye-color] is @racket[#f], no eye is drawn. 75 | 76 | The @racket[open-mouth] argument can be either @racket[#f] (mouth 77 | closed), @racket[#t] (mouth fully open), or a number: @racket[0.0] is 78 | closed, @racket[1.0] is fully open, and numbers in between are 79 | partially open. 80 | 81 | @examples[#:eval ss-eval 82 | (standard-fish 100 50) 83 | (standard-fish 100 50 #:direction 'right #:color "chocolate") 84 | (standard-fish 100 50 #:eye-color "saddlebrown" #:color "salmon") 85 | (standard-fish 100 50 #:open-mouth #t #:color "olive") 86 | ]} 87 | 88 | @defproc[(jack-o-lantern [size real?] 89 | [pumpkin-color (or/c string? (is-a?/c color%)) "orange"] 90 | [face-color (or/c string? (is-a?/c color%)) "black"] 91 | [stem-color (or/c string? (is-a?/c color%)) "brown"]) 92 | pict?]{ 93 | 94 | Creates a jack-o-lantern; use the same pumpkin and face color to get a 95 | plain pumpkin. The @racket[size] determines the width. 96 | 97 | @examples[#:eval ss-eval 98 | (jack-o-lantern 100) 99 | (jack-o-lantern 100 "cadet blue" "khaki" "salmon") 100 | ]} 101 | 102 | @defproc[(angel-wing [w real?] 103 | [h real?] 104 | [left? any/c]) 105 | pict?]{ 106 | 107 | Creates an angel wing, left or right, or any size. The color and pen 108 | width for drawing the wing outline is the current one. 109 | 110 | @examples[#:eval ss-eval 111 | (angel-wing 100 40 #f) 112 | (angel-wing 100 40 #t) 113 | ]} 114 | 115 | @defproc[(desktop-machine [scale real?] 116 | [style (listof symbol?) null]) 117 | pict?]{ 118 | 119 | Produces a picture of ancient desktop computer. The @racket[scale] 120 | argument scales the size relative to the base size of 120 by 115. 121 | 122 | The @racket[style] can include any of the following: 123 | 124 | @itemlist[ 125 | 126 | @item{@racket['plt] --- include a Racket logo on the machine's screen} 127 | 128 | @item{@racket['binary] --- put 1s and 0s on the machine's screen} 129 | 130 | @item{@racket['devil] --- like @racket['binary], and also give the machine 131 | horns and a tail} 132 | 133 | ] 134 | 135 | @examples[#:eval ss-eval 136 | (desktop-machine 1) 137 | (desktop-machine 1 '(devil plt)) 138 | (desktop-machine 1 '(plt binary)) 139 | ]} 140 | 141 | @defproc[(thermometer [#:height-% height-% (between/c 0 1) 1] 142 | [#:color-% color-% (between/c 0 1) height-%] 143 | [#:ticks ticks exact-nonnegative-integer? 4] 144 | [#:start-color start-color (or/c string? (is-a?/c color%)) "lightblue"] 145 | [#:end-color end-color (or/c string? (is-a?/c color%)) "lightcoral"] 146 | [#:top-circle-diameter top-circle-diameter (>/c 0) 40] 147 | [#:bottom-circle-diameter bottom-circle-diameter (>/c 0) 80] 148 | [#:stem-height stem-height (>/c 0) 180] 149 | [#:mercury-inset mercury-inset (>/c 0) 8]) 150 | pict?]{ 151 | Produces a thermometer that consists of a semi-circle on top of a rectangle on 152 | top of a circle. The sizes of the three components are controlled via the 153 | @racket[top-circle-diameter], @racket[stem-height], and @racket[bottom-circle-diameter] 154 | arguments. 155 | 156 | The mercury is drawn the same way, but by creating the three components inset from the 157 | versions that draw the boundary of the thermometer. This inset is controlled by the 158 | @racket[mercury-inset] argument. 159 | 160 | The height of the mercury in the thermometer is controlled by the @racket[height-%] argument. 161 | Its color is interpolated between the @racket[start-color] and @racket[end-color], as 162 | determined by the @racket[color-%] argument. 163 | 164 | Finally, some number of ticks are drawn, based on the @racket[ticks] argument. 165 | 166 | @examples[#:eval ss-eval 167 | (thermometer #:stem-height 90 168 | #:bottom-circle-diameter 40 169 | #:top-circle-diameter 20 170 | #:mercury-inset 4) 171 | ]} 172 | 173 | @defproc[(standard-cat 174 | [width positive?] 175 | [height positive?] 176 | [#:left-ear-extent left-ear-extent (>=/c 0)] 177 | [#:left-ear-arc left-ear-arc (real-in 0 (* 2 pi))] 178 | [#:left-ear-angle left-ear-angle (real-in 0 (* 2 pi))] 179 | [#:right-ear-extent right-ear-extent (>=/c 0)] 180 | [#:right-ear-arc right-ear-arc (real-in 0 (* 2 pi))] 181 | [#:right-ear-angle right-ear-angle (real-in 0 (* 2 pi))] 182 | [#:fur-color fur-color (or/c #f string? (is-a?/c color%))] 183 | [#:fur-border-color fur-border-color (or/c #f string? (is-a?/c color%))] 184 | [#:lip-color lip-color (or/c #f string? (is-a?/c color%))] 185 | [#:lip-border-color lip-border-color (or/c string? (is-a?/c color%))] 186 | [#:lip-border-width lip-border-width (or/c #f (real-in 0 255))] 187 | [#:eye-color eye-color (or/c #f string? (is-a?/c color%))] 188 | [#:nose-color nose-color (or/c #f string? (is-a?/c color%))] 189 | [#:nose nose pict?] 190 | [#:happy? happy? any/c] 191 | [#:eyes eyes (or/c #f pict?)] 192 | [#:left-eye left-eye (if eyes (or/c #f pict?) pict?)] 193 | [#:right-eye right-eye (if eyes (or/c #f pict?) pict?)] 194 | [#:whisker-length whisker-length positive?] 195 | [#:whisker-droop whisker-droop real?] 196 | [#:whisker-width whisker-width (or/c #f (real-in 0 255))] 197 | [#:whisker-color whisker-color (or/c string? (is-a?/c color%))] 198 | [#:whisker-inset? whisker-inset? any/c] 199 | [#:border-width border-width (or/c #f (real-in 0 255))]) 200 | pict?]{ 201 | 202 | Creates a cat face with customizable whiskers, eyes, ears, and mouth. 203 | 204 | The @racket[whisker-width] argument can be either @racket[#f] (no whiskers) or a real between 0 and 255 to specify pen width. Similarly for @racket[border-width], there can be no border around the cat face or a custom-width border. 205 | 206 | Each cat ear can have a custom extent (length), an arc length (width), and angle (position on head). There are constraints on the ear arc lengths and angles to prevent overlap. The default ear angle is dependent on the ear arc length to make the default positioning sensible. The default ear extent is 1/4 the height of the cat face. 207 | 208 | @examples[#:eval ss-eval 209 | (standard-cat 100 90) 210 | (standard-cat 100 90 #:happy? #t) 211 | (standard-cat 100 90 #:left-ear-arc (* pi 1/8) #:right-ear-extent 30) 212 | ] 213 | 214 | @history[#:added "1.10"]} 215 | 216 | @; ---------------------------------------- 217 | 218 | @section{Balloon Annotations} 219 | 220 | @defmodule[pict/balloon]{The @racketmodname[pict/balloon] 221 | library provides functions for creating and placing cartoon-speech 222 | balloons.} 223 | 224 | @defproc[(wrap-balloon [pict pict?] 225 | [spike (or/c 'n 's 'e 'w 'ne 'se 'sw 'nw)] 226 | [dx real?] 227 | [dy real?] 228 | [color (or/c string? (is-a?/c color%)) (current-balloon-color)] 229 | [corner-radius (and/c real? (not/c negative?)) 32]) 230 | balloon?]{ 231 | 232 | Superimposes @racket[pict] on top of a balloon that wraps it. 233 | 234 | The @racket[spike] argument indicates the corner from which a spike 235 | protrudes from the balloon (i.e., the spike that points to whatever 236 | the balloon is about). For example, @racket['n] means ``north,'', 237 | which is a spike in the top middle of the balloon. 238 | 239 | The @racket[dx] and @racket[dy] arguments specify how far the spike 240 | should protrude. For a @racket['w] spike, @racket[dx] should be 241 | negative, etc. 242 | 243 | The @racket[color] argument is the background color for the balloon. 244 | 245 | The @racket[corner-radius] argument determines the radius of the circle 246 | used to round the balloon's corners. As usual, if it is less than 247 | @racket[1], then it acts as a ratio of the balloon's width or height. 248 | 249 | The result is a balloon, not a pict. The @racket[balloon-pict] 250 | function extracts a pict whose @tech{bounding box} does not include the 251 | spike, but includes the rest of the image, and the 252 | @racket[balloon-point-x] and @racket[balloon-point-y] functions 253 | extract the location of the spike point. More typically, the 254 | @racket[pin-balloon] function is used to add a balloon to a pict.} 255 | 256 | @defproc[(pip-wrap-balloon [pict pict?] 257 | [spike (or/c 'n 's 'e 'w 'ne 'se 'sw 'nw)] 258 | [dx real?] 259 | [dy real?] 260 | [color (or/c string? (is-a?/c color%)) (current-balloon-color)] 261 | [corner-radius (and/c real? (not/c negative?)) 32]) 262 | pict?]{ 263 | 264 | Like @racket[wrap-balloon], but produces a zero-sized pict suitable 265 | for use with @racket[pin-over].} 266 | 267 | 268 | @defproc*[([(pin-balloon [balloon balloon?] 269 | [base pict?] 270 | [x real?] 271 | [y real?]) 272 | pict?] 273 | [(pin-balloon [balloon balloon?] 274 | [base pict?] 275 | [at-pict pict-path?] 276 | [find (pict? pict-path? . -> . (values real? real?))]) 277 | pict?])]{ 278 | 279 | Superimposes the pict in @racket[balloon] onto @racket[base] to 280 | produce a new pict. The balloon is positioned so that its spike points 281 | to the location specified by either @racket[x] and @racket[y] 282 | (numbers) or at the position determined by combining @racket[base] and 283 | @racket[at-pict] with @racket[find]. The @racket[find] function uses 284 | its arguments like @racket[lt-find]. 285 | 286 | The resulting pict has the same @tech{bounding box}, descent, and ascent as 287 | @racket[base], even if the balloon extends beyond the bounding box. 288 | 289 | @examples[#:eval ss-eval 290 | (define a-pict (standard-fish 70 40)) 291 | (pin-balloon (balloon 40 30 5 'se 5 5) 292 | (cc-superimpose (blank 300 150) a-pict) 293 | a-pict 294 | lc-find) 295 | (pin-balloon (wrap-balloon (text "Hello!") 'sw -5 3) 296 | (cc-superimpose (blank 300 150) a-pict) 297 | a-pict 298 | rt-find) 299 | ]} 300 | 301 | 302 | @defproc[(balloon [w real?] 303 | [h real?] 304 | [corner-radius (and/c real? (not/c negative?))] 305 | [spike (or/c 'n 's 'e 'w 'ne 'se 'sw 'nw)] 306 | [dx real?] 307 | [dy real?] 308 | [color (or/c string? (is-a?/c color%)) (current-balloon-color)]) 309 | balloon?]{ 310 | 311 | Creates a balloon, much like @racket[wrap-balloon] except that the balloon's 312 | width is @racket[w] and its height is @racket[h].} 313 | 314 | @defproc*[([(balloon? [v any/c]) boolean?] 315 | [(make-balloon [pict pict?] [x real?] [y real?]) balloon?] 316 | [(balloon-pict [balloon balloon?]) pict?] 317 | [(balloon-point-x [balloon balloon?]) real?] 318 | [(balloon-point-y [balloon balloon?]) real?])]{ 319 | 320 | A balloon encapsulates a pict and the position of the balloon's spike 321 | relative to the balloon's top-left corner.} 322 | 323 | @defthing[balloon-color (or/c string? (is-a?/c color%))]{ 324 | 325 | The default background color for a balloon.} 326 | 327 | @defparam[current-balloon-color color (or/c string? (is-a?/c color%))]{ 328 | 329 | Determines the background color for a balloon as created by functions 330 | like @racket[wrap-balloon]. 331 | 332 | @history[#:added "1.9"]} 333 | 334 | @defboolparam[balloon-enable-3d on?]{ 335 | 336 | A parameter that determines whether balloons are drawn with 3-D 337 | shading. This parameter affects balloons at drawing time, not at 338 | construction time.} 339 | 340 | @; ---------------------------------------- 341 | 342 | @section{Face} 343 | 344 | @defmodule[pict/face]{The @racketmodname[pict/face] library 345 | provides functions for a kind of @as-index{Mr. Potatohead}-style face 346 | library.} 347 | 348 | @defthing[default-face-color (or/c string (is-a?/c color%))]{ 349 | 350 | Orange.} 351 | 352 | @; helper for the next defproc 353 | @(define (small-face mood) (scale (face mood) 0.25)) 354 | 355 | @defproc[(face [mood symbol?] 356 | [color (or/c string (is-a?/c color%)) default-face-color]) 357 | pict?]{ 358 | 359 | Returns a pict for a pre-configured face with the given base 360 | color. The built-in configurations, selected by mood-symbol, are as 361 | follows: 362 | 363 | @tabular[#:sep @hspace[2] 364 | (list (list @para{@racket['unhappy] --- @racket[(face* 'none 'plain #t default-face-color 6)]} 365 | @(small-face 'unhappy)) 366 | (list @para{@racket['sortof-unhappy] --- @racket[(face* 'worried 'grimace #t default-face-color 6)]} 367 | @(small-face 'sortof-unhappy)) 368 | (list @para{@racket['sortof-happy] --- @racket[(face* 'worried 'medium #f default-face-color 6)]} 369 | @(small-face 'sortof-happy)) 370 | (list @para{@racket['happy] --- @racket[(face* 'none 'plain #f default-face-color 6)]} 371 | @(small-face 'happy)) 372 | (list @para{@racket['happier] --- @racket[(face* 'none 'large #f default-face-color 3)]} 373 | @(small-face 'happier)) 374 | (list @para{@racket['embarrassed] --- @racket[(face* 'worried 'medium #f default-face-color 3)]} 375 | @(small-face 'embarrassed)) 376 | (list @para{@racket['badly-embarrassed] --- @racket[(face* 'worried 'medium #t default-face-color 3)]} 377 | @(small-face 'badly-embarrassed)) 378 | (list @para{@racket['unhappier] --- @racket[(face* 'normal 'large #t default-face-color 3)]} 379 | @(small-face 'unhappier)) 380 | (list @para{@racket['happiest] --- @racket[(face* 'normal 'huge #f default-face-color 0 -3)]} 381 | @(small-face 'happiest)) 382 | (list @para{@racket['unhappiest] --- @racket[(face* 'normal 'huge #t default-face-color 0 -3)]} 383 | @(small-face 'unhappiest)) 384 | (list @para{@racket['mad] --- @racket[(face* 'angry 'grimace #t default-face-color 0)]} 385 | @(small-face 'mad)) 386 | (list @para{@racket['mean] --- @racket[(face* 'angry 'narrow #f default-face-color 0)]} 387 | @(small-face 'mean)) 388 | (list @para{@racket['surprised] --- @racket[(face* 'worried 'oh #t default-face-color -4 -3 2)]} 389 | @(small-face 'surprised))) 390 | ]} 391 | 392 | @defproc[(face* [eyebrow-kind (or/c 'none 'normal 'worried 'angry)] 393 | [mouth-kind (or/c 'plain 'smaller 'narrow 'medium 'large 394 | 'huge 'grimace 'oh 'tongue)] 395 | [frown? any/c] 396 | [color (or/c string (is-a?/c color%))] 397 | [eye-inset real?] 398 | [eyebrow-dy real?] 399 | [pupil-dx real?] 400 | [pupil-dy real?] 401 | [#:eyebrow-shading? eyebrow-on? any/c #t] 402 | [#:mouth-shading? mouth-on? any/c #t] 403 | [#:eye-shading? eye-on? any/c #t] 404 | [#:tongue-shading? tongue-on? any/c #t] 405 | [#:face-background-shading? face-bg-on? any/c #t] 406 | [#:teeth? teeth-on? any/c #t]) 407 | pict?]{ 408 | 409 | Returns a pict for a face: 410 | 411 | @itemize[ 412 | 413 | @item{@racket[eyebrow-kind] determines the eyebrow shape.} 414 | 415 | @item{@racket[mouth-kind] determines the mouth shape, combined with 416 | @racket[frown?].} 417 | 418 | @item{@racket[frown?] determines whether the mouth is up or down.} 419 | 420 | @item{@racket[color] determines the face color.} 421 | 422 | @item{@racket[eye-inset] adjusts the eye size; recommend values are 423 | between 0 and 10.} 424 | 425 | @item{@racket[eyebrow-dy] adjusts the eyebrows; recommend values: 426 | between -5 and 5.} 427 | 428 | @item{@racket[pupil-dx] adjusts the pupil; recommend values are 429 | between -10 and 10.} 430 | 431 | @item{@racket[pupil-dy] adjusts the pupil; recommend values are 432 | between -15 and 15.} 433 | 434 | ] 435 | 436 | The @racket[#:eyebrow-shading?] through 437 | @racket[#:face-background-shading?] arguments control whether a 438 | shading is used for on a particular feature in the face (shading tends 439 | to look worse than just anti-aliasing when the face is small). The 440 | @racket[#:teeth?] argument controls the visibility of the teeth for 441 | some mouth shapes.} 442 | 443 | @; ---------------------------------------- 444 | 445 | @section{Flash} 446 | 447 | @defmodule[pict/flash] 448 | 449 | @defproc[(filled-flash [width real?] 450 | [height real?] 451 | [n-points exact-positive-integer? 10] 452 | [spike-fraction (real-in 0 1) 0.25] 453 | [rotation real? 0]) 454 | pict?]{ 455 | 456 | Returns a pict for a ``flash'': a spiky oval, like the yellow 457 | background that goes behind a ``new!'' logo on web pages or a box of 458 | cereal. 459 | 460 | The @racket[height] and @racket[width] arguments determine the size of 461 | the oval in which the flash is drawn, prior to rotation. The actual 462 | height and width may be smaller if @racket[points] is not a multiple 463 | of 4, and the actual height and width will be different if the flash 464 | is rotated. 465 | 466 | The @racket[n-points] argument determines the number of points on the 467 | flash. 468 | 469 | The @racket[spike-fraction] argument determines how big the flash 470 | spikes are compared to the bounding oval. 471 | 472 | The @racket[rotation] argument specifies an angle in radians for 473 | counter-clockwise rotation. 474 | 475 | The flash is drawn in the default color. 476 | 477 | @examples[#:eval ss-eval 478 | (filled-flash 100 50) 479 | (filled-flash 100 50 8 0.25 (/ pi 2)) 480 | ]} 481 | 482 | @defproc[(outline-flash [width real?] 483 | [height real?] 484 | [n-points exact-positive-integer? 10] 485 | [spike-fraction (real-in 0 1) 0.25] 486 | [rotation real? 0]) 487 | pict?]{ 488 | 489 | Like @racket[filled-flash], but drawing only the outline. 490 | 491 | @examples[#:eval ss-eval 492 | (outline-flash 100 50) 493 | (outline-flash 100 50 8 0.25 (/ pi 2)) 494 | ]} 495 | 496 | @include-section["code.scrbl"] 497 | 498 | @(close-eval ss-eval) 499 | 500 | -------------------------------------------------------------------------------- /pict-doc/pict/scribblings/pict-diagram.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require pict 3 | racket/class 4 | racket/draw) 5 | 6 | (provide pict-diagram) 7 | 8 | (define pict-diagram 9 | (parameterize ([dc-for-text-size (make-object bitmap-dc% 10 | (make-bitmap 1 1))]) 11 | (let ([t (lambda (s) 12 | (text s `(italic . roman) 12))]) 13 | (let ([top 14 | (hc-append (vline 0 10) 15 | (hline 30 0) 16 | (inset (t "w") 1 0) 17 | (hline 30 0) 18 | (vline 0 10))] 19 | [right 20 | (vc-append (hline 10 0) 21 | (vline 0 25) 22 | (inset (t "h") 0 1) 23 | (vline 0 25) 24 | (hline 10 0))]) 25 | (inset 26 | (vl-append 27 | 2 28 | top 29 | (hc-append 30 | 2 31 | (frame (let* ([line (hline (pict-width top) 0 #:segment 5)] 32 | [top-line (launder line)] 33 | [bottom-line (launder line)] 34 | [top-edge (launder (ghost line))] 35 | [bottom-edge (launder (ghost line))] 36 | [p (vc-append 37 | (/ (pict-height right) 4) 38 | top-edge 39 | top-line 40 | (blank) 41 | bottom-line 42 | bottom-edge)] 43 | [p (pin-arrows-line 44 | 4 p 45 | top-edge ct-find 46 | top-line ct-find)] 47 | [p (pin-arrows-line 48 | 4 p 49 | bottom-edge ct-find 50 | bottom-line ct-find)] 51 | [a (t "a")] 52 | [p (let-values ([(dx dy) (ct-find p top-line)]) 53 | (pin-over p (+ dx 5) (/ (- dy (pict-height a)) 2) a))] 54 | [d (t "d")] 55 | [p (let-values ([(dx dy) (ct-find p bottom-line)]) 56 | (pin-over p 57 | (+ dx 5) 58 | (+ dy (/ (- (- (pict-height p) dy) (pict-height d)) 2)) 59 | d))]) 60 | p)) 61 | right)) 62 | 1))))) 63 | 64 | -------------------------------------------------------------------------------- /pict-doc/pict/scribblings/shadow.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label pict pict/shadow racket/base racket/contract racket/class racket/draw racket/future) 4 | scribble/eval) 5 | 6 | @(define the-eval (make-base-eval)) 7 | @(the-eval '(require pict pict/shadow)) 8 | 9 | @title{Shadows} 10 | 11 | @defmodule[pict/shadow] 12 | 13 | These pict transformations add shadows or blurring in various shapes and 14 | forms. 15 | 16 | @defproc[(blur [p pict?] 17 | [h-radius (and/c real? (not/c negative?))] 18 | [v-radius (and/c real? (not/c negative?)) h-radius]) 19 | pict?]{ 20 | 21 | Blurs @racket[p] using an iterated box blur that approximates a 22 | gaussian blur. The @racket[h-radius] and @racket[v-radius] arguments 23 | control the strength of the horizontal and vertical components of the 24 | blur, respectively. They are given in terms of pict units, which may 25 | not directly correspond to screen pixels. 26 | 27 | The @racket[blur] function takes work proportional to 28 | @racketblock[(* (pict-width p) (pict-height p))] 29 | but it may be sped up by a factor of up to @racket[(processor-count)] 30 | due to the use of @racket[future]s. 31 | 32 | @examples[#:eval the-eval 33 | (blur (text "blur" null 40) 5) 34 | (blur (text "more blur" null 40) 10) 35 | (blur (text "much blur" null 40) 20) 36 | (blur (text "horiz. blur" null 40) 10 0) 37 | ] 38 | The resulting pict has the same bounding box as @racket[p], so when 39 | picts are automatically @racket[clip]ped (as in Scribble documents), 40 | the pict should be @racket[inset] by the blur radius. 41 | @examples[#:eval the-eval 42 | (inset (blur (text "more blur" null 40) 10) 10) 43 | ] 44 | 45 | @history[#:added "1.4"]{} 46 | } 47 | 48 | @defproc[(shadow [p pict?] 49 | [radius (and/c real? (not/c negative?))] 50 | [dx real? 0] 51 | [dy real? dx] 52 | [#:color color (or/c #f string? (is-a?/c color%)) #f] 53 | [#:shadow-color shadow-color (or/c #f string? (is-a?/c color%)) #f]) 54 | pict?]{ 55 | 56 | Creates a shadow effect by superimposing @racket[p] over a 57 | blurred version of @racket[p]. The shadow is offset from @racket[p] by 58 | (@racket[dx], @racket[dy]) units. 59 | 60 | If @racket[color] is not @racket[#f], the foreground part is 61 | @racket[(colorize p color)]; otherwise it is just @racket[p]. If 62 | @racket[shadow-color] is not @racket[#f], the shadow part is produced 63 | by blurring @racket[(colorize p shadow-color)]; otherwise it is 64 | produced by blurring @racket[p]. 65 | 66 | The resulting pict has the same bounding box as @racket[p]. 67 | 68 | @examples[#:eval the-eval 69 | (inset (shadow (text "shadow" null 50) 10) 10) 70 | (inset (shadow (text "shadow" null 50) 10 5) 10) 71 | (inset (shadow (text "shadow" null 50) 72 | 5 0 2 #:color "white" #:shadow-color "red") 73 | 10) 74 | ] 75 | 76 | @history[#:added "1.4"]{} 77 | } 78 | 79 | @defproc[(shadow-frame [pict pict?] ... 80 | [#:sep separation real? 5] 81 | [#:margin margin real? 20] 82 | [#:background-color bg-color (or/c string? (is-a?/c color%)) "white"] 83 | [#:frame-color frame-color (or/c string? (is-a?/c color%)) "gray"] 84 | [#:frame-line-width frame-line-width (or/c real? #f 'no-frame) 0] 85 | [#:shadow-side-length shadow-side-length real? 4] 86 | [#:shadow-top-y-offset shadow-top-y-offset real? 10] 87 | [#:shadow-bottom-y-offset shadow-bottom-y-offset real? 4] 88 | [#:shadow-descent shadow-descent (and/c real? (not/c negative?)) 40] 89 | [#:shadow-alpha-factor shadow-alpha-factor real? 3/4] 90 | [#:blur blur-radius (and/c real? (not/c negative?)) 20]) 91 | pict?]{ 92 | 93 | Surrounds the @racket[pict]s with a rectangular frame that casts a 94 | symmetric ``curled paper'' shadow. 95 | 96 | The @racket[pict]s are vertically appended with @racket[separation] 97 | space between them. They are placed on a rectangular background of 98 | solid @racket[bg-color] with @racket[margin] space on all sides. A 99 | frame of @racket[frame-color] and @racket[frame-line-width] is added 100 | around the rectangle, unless @racket[frame-line-width] is 101 | @racket['no-frame]. The rectangle casts a shadow that extends 102 | @racket[shadow-side-length] to the left and right, starts 103 | @racket[shadow-top-y-offset] below the top of the rectangle and 104 | extends to @racket[shadow-bottom-y-offset] below the bottom of the 105 | rectangle in the center and an additional @racket[shadow-descent] 106 | below that on the sides. The shadow is painted using a linear 107 | gradient; @racket[shadow-alpha-factor] determines its density at the 108 | center. Finally, the shadow is blurred by @racket[blur-radius]; all 109 | previous measurements are pre-blur measurements. 110 | 111 | @examples[#:eval the-eval 112 | (shadow-frame (text "text in a nifty frame" null 60)) 113 | ] 114 | 115 | @history[#:added "1.4"]{} 116 | } 117 | 118 | @(close-eval the-eval) 119 | -------------------------------------------------------------------------------- /pict-doc/pict/scribblings/tree-layout.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require (for-label pict racket pict/tree-layout) 4 | pict/private/layout 5 | scribble/manual 6 | scribble/eval) 7 | 8 | @(define tree-layout-eval (make-base-eval)) 9 | @(tree-layout-eval '(require pict/tree-layout pict)) 10 | 11 | @title{Tree Layout} 12 | 13 | These functions specify tree layouts and functions 14 | that render them as @racket[pict]s. 15 | 16 | @defmodule[pict/tree-layout] 17 | 18 | @defproc[(tree-layout [#:pict node-pict (or/c #f pict?) #f] 19 | [child (or/c tree-layout? tree-edge? #f)] ...) 20 | tree-layout?]{ 21 | Specifies an interior node of a tree for use with one of the renderers below. 22 | 23 | If the children are @racket[tree-layout?]s, then they have edges 24 | created by passing the corresponding @racket[tree-layout?]s directly 25 | to @racket[tree-edge]. Children that are @racket[#f] correspond to 26 | leaf nodes that are not drawn. 27 | 28 | The default @racket[node-pict] (used when @racket[node-pict] is @racket[#f]) 29 | is @|default-node-pict|. 30 | } 31 | 32 | @defproc[(tree-edge [node (and/c tree-layout? (not/c #f))] 33 | [#:edge-color edge-color 34 | (or/c string? 35 | (is-a?/c color%) 36 | (list/c byte? byte? byte?)) 37 | "gray"] 38 | [#:edge-width edge-width 39 | (or/c 'unspecified real? #f) 40 | 'unspecified] 41 | [#:edge-style edge-style 42 | (or/c 'unspecified 'transparent 'solid 'xor 'hilite 43 | 'dot 'long-dash 'short-dash 'dot-dash 44 | 'xor-dot 'xor-long-dash 'xor-short-dash 45 | 'xor-dot-dash) 46 | 'unspecified]) 47 | tree-edge?]{ 48 | This function specifies an edge from some parent to the given @racket[node]. 49 | It it intended to be used with @racket[tree-layout], on a non-@racket[#f] node. 50 | 51 | When @racket[edge-width] is @racket['unspecified], the line width will not be 52 | set. This is intended to allow the line width to be set for the whole pict 53 | via @racket[linewidth]. Otherwise, @racket[edge-width] is interpreted the 54 | same way as the width argument for the @racket[linewidth] function. 55 | @racket[edge-style] behaves similarly, its argument interpreted as the style 56 | argument for the @racket[linestyle] function. 57 | 58 | @examples[#:eval 59 | tree-layout-eval 60 | (naive-layered (tree-layout 61 | (tree-edge #:edge-width 3 (tree-layout)) 62 | (tree-edge #:edge-color "red" 63 | #:edge-style 'dot 64 | (tree-layout))))] 65 | 66 | @history[#:changed "1.3" @list{Added the @racket[#:edge-width] option.} 67 | #:changed "1.9" @list{Added the @racket[#:edge-style] option.}] 68 | } 69 | 70 | @defproc[(tree-layout? [v any/c]) boolean?]{ 71 | Recognizes a tree layout. It returns @racket[#t] 72 | when given @racket[#f] or the result of @racket[tree-layout]. 73 | } 74 | 75 | @defproc[(binary-tree-layout? [v any/c]) boolean?]{ 76 | Recognizes a @racket[tree-layout?] that represents 77 | a binary tree. That is, each interior node 78 | has either two children or is @racket[#f]. Note 79 | that a node with zero children does not count as a 80 | leaf for the purposes of @racket[binary-tree-layout?]. 81 | 82 | @examples[#:eval 83 | tree-layout-eval 84 | (binary-tree-layout? (tree-layout #f #f)) 85 | (binary-tree-layout? #f) 86 | (binary-tree-layout? (tree-layout (tree-layout) (tree-layout)))] 87 | } 88 | 89 | @defproc[(tree-edge? [v any/c]) boolean?]{ 90 | Recognizes an @racket[tree-edge]. 91 | } 92 | 93 | 94 | @defproc[(naive-layered [tree-layout tree-layout?] 95 | [#:x-spacing x-spacing (or/c (and/c real? positive?) #f) #f] 96 | [#:y-spacing y-spacing (or/c (and/c real? positive?) #f) #f] 97 | [#:transform transform (-> real? real? (values real? real?)) values]) 98 | pict?]{ 99 | Uses a naive algorithm that ensures that all nodes at a fixed 100 | depth are the same vertical distance from the root (dubbed ``layered''). 101 | It recursively lays out subtrees and then horizontally 102 | combines them, aligning them at their tops. Then it places 103 | the root node centered over the children nodes. 104 | 105 | The @racket[transform] argument applies a coordinate 106 | transformation to each of the nodes after it has been layed out. 107 | The bounding box of the resulting pict encompasses the corners 108 | of the original bounding box after the transformation has been 109 | applied to them. 110 | 111 | @examples[#:eval 112 | tree-layout-eval 113 | (define (complete d) 114 | (cond 115 | [(zero? d) #f] 116 | [else (define s (complete (- d 1))) 117 | (tree-layout s s)])) 118 | 119 | (naive-layered (complete 4)) 120 | (naive-layered (complete 4) #:transform (lambda (x y) (values y x))) 121 | (naive-layered (tree-layout 122 | (tree-layout) 123 | (tree-layout) 124 | (tree-layout 125 | (tree-layout) 126 | (tree-layout) 127 | (tree-layout 128 | (tree-layout) 129 | (tree-layout))))) 130 | (define right-subtree-with-left-chain 131 | (tree-layout 132 | (tree-layout 133 | (tree-layout #f #f) 134 | (tree-layout 135 | (tree-layout #f #f) 136 | #f)) 137 | (tree-layout 138 | (tree-layout 139 | (tree-layout 140 | (tree-layout 141 | (tree-layout #f #f) 142 | #f) 143 | #f) 144 | #f) 145 | #f))) 146 | (naive-layered right-subtree-with-left-chain)] 147 | 148 | @history[#:changed "1.13" @list{Added the @racket[#:transform] option.}] 149 | } 150 | 151 | @defproc[(binary-tidier [tree-layout binary-tree-layout?] 152 | [#:x-spacing x-spacing (or/c (and/c real? positive?) #f) #f] 153 | [#:y-spacing y-spacing (or/c (and/c real? positive?) #f) #f] 154 | [#:transform transform (-> real? real? (values real? real?)) values]) 155 | pict?]{ 156 | Uses the layout algorithm from 157 | @italic{Tidier Drawing of Trees} by Edward M. Reingold and John S. Tilford 158 | (IEEE Transactions on Software Engineering, Volume 7, Number 2, March 1981) 159 | to lay out @racket[tree-layout]. 160 | 161 | The layout algorithm guarantees a number of properties, namely: 162 | @itemlist[@item{nodes at the same level of tree appear at 163 | the same vertical distance from the top of the pict} 164 | @item{parents are centered over their children, which are 165 | placed from left to right,} 166 | @item{isomorphic subtrees are drawn the same way, no matter 167 | where they appear in the complete tree, and} 168 | @item{a tree and its mirror image produce picts that are 169 | mirror images of each other (which also holds for subtrees 170 | of the complete tree).}] 171 | Within those constraints, the algorithm tries to make as narrow a drawing 172 | as it can, even to the point that one subtree of a given node might cross 173 | under the other one. 174 | 175 | More precisely, it recursively lays out the two subtree and then, 176 | without adjusting the layout of the two subtrees, moves them as 177 | close together as it can, putting the root of the new tree centered 178 | on top of its children. (It does this in linear time, using clever 179 | techniques as discussed in the paper.) 180 | 181 | The @racket[x-spacing] and @racket[y-spacing] are the amount of space that each 182 | row and each column takes up, measured in pixels. If @racket[x-spacing] is @racket[#f], 183 | it is the width of the widest node @racket[pict?] in the tree. 184 | If @racket[y-spacing] is @racket[#f], 185 | it is @racket[1.5] times the width of the widest node @racket[pict?] in the tree. 186 | The @racket[transform] is the same as in @racket[naive-layered]. 187 | 188 | @examples[#:eval 189 | tree-layout-eval 190 | 191 | (binary-tidier (complete 4)) 192 | 193 | 194 | (define (dl t) (tree-layout (tree-layout #f #f) t)) 195 | (define (dr t) (tree-layout t (tree-layout #f #f))) 196 | (binary-tidier 197 | (tree-layout 198 | (dr (dr (dr (dl (dl (dl (complete 2))))))) 199 | (dl (dl (dl (dr (dr (dr (complete 2))))))))) 200 | 201 | 202 | (binary-tidier right-subtree-with-left-chain)] 203 | 204 | @history[#:changed "1.13" @list{Added the @racket[#:transform] option.}] 205 | } 206 | 207 | @defproc[(hv-alternating [tree-layout binary-tree-layout?] 208 | [#:x-spacing x-spacing (or/c (and/c real? positive?) #f) #f] 209 | [#:y-spacing y-spacing (or/c (and/c real? positive?) #f) #f] 210 | [#:transform transform (-> real? real? (values real? real?)) values]) 211 | pict?]{ 212 | 213 | Uses the ``CT'' binary tree layout algorithm from 214 | @italic{A note on optimal area algorithms for upward drawing of binary trees} 215 | by P. Crescenzi, G. Di Battista, and A. Piperno 216 | (Computational Geometry, Theory and Applications, 1992) to lay out @racket[tree-layout]. 217 | 218 | It adds horizontal and vertical space between layers based on @racket[x-spacing] and 219 | @racket[y-spacing]. If either is @racket[#f], @racket[1.5] times the size of the biggest 220 | node is used. The @racket[transform] is the same as in @racket[naive-layered]. 221 | 222 | @examples[#:eval 223 | tree-layout-eval 224 | (hv-alternating (complete 8))] 225 | 226 | @history[#:changed "1.13" @list{Added the @racket[#:transform] option.}] 227 | } 228 | 229 | @history[#:added "6.0.1.4"] 230 | -------------------------------------------------------------------------------- /pict-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("scheme-lib" 6 | "base" 7 | "compatibility-lib" 8 | ["draw-lib" #:version "1.21"] 9 | "syntax-color-lib")) 10 | (define build-deps '("rackunit-lib")) 11 | 12 | (define pkg-desc "implementation (no documentation) part of \"pict\"") 13 | 14 | (define pkg-authors '(mflatt robby)) 15 | 16 | (define version "1.16") 17 | 18 | (define license 19 | '(Apache-2.0 OR MIT)) 20 | -------------------------------------------------------------------------------- /pict-lib/pict/balloon.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require texpict/balloon) 3 | (provide (except-out (all-from-out texpict/balloon) 4 | place-balloon)) 5 | 6 | -------------------------------------------------------------------------------- /pict-lib/pict/code.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require pict 3 | texpict/code 4 | mzlib/unit 5 | racket/contract 6 | racket/class 7 | racket/draw 8 | racket/list 9 | racket/match 10 | racket/string 11 | syntax-color/lexer-contract 12 | syntax-color/module-lexer 13 | "convert.rkt" 14 | (for-syntax racket/base 15 | syntax/to-string 16 | mzlib/list)) 17 | 18 | (define get-current-code-font-size (make-parameter (lambda () 12))) 19 | 20 | (define current-code-line-sep (make-parameter 2)) 21 | (define (current-font-size) ((get-current-code-font-size))) 22 | 23 | (define-values/invoke-unit/infer code@) 24 | 25 | (define-code code typeset-code) 26 | 27 | (provide code 28 | define-code 29 | (for-syntax prop:code-transformer 30 | code-transformer? 31 | make-code-transformer)) 32 | (provide-signature-elements 33 | (except code^ 34 | typeset-code 35 | current-code-font 36 | current-code-tt 37 | current-comment-color 38 | current-keyword-color 39 | current-id-color 40 | current-literal-color 41 | current-const-color 42 | current-base-color 43 | current-reader-forms 44 | code-align 45 | current-keyword-list 46 | current-const-list 47 | current-literal-list)) 48 | (provide 49 | (contract-out 50 | [typeset-code (-> syntax? pict?)] 51 | [current-code-font (parameter/c text-style/c)] 52 | [current-code-tt (parameter/c (-> string? pict?))] 53 | [get-current-code-font-size (parameter/c (-> exact-nonnegative-integer?))] 54 | [current-code-line-sep (parameter/c real?)] 55 | [current-comment-color (parameter/c (or/c string? (is-a?/c color%)))] 56 | [current-keyword-color (parameter/c (or/c string? (is-a?/c color%)))] 57 | [current-id-color (parameter/c (or/c string? (is-a?/c color%)))] 58 | [current-literal-color (parameter/c (or/c string? (is-a?/c color%)))] 59 | [current-const-color (parameter/c (or/c string? (is-a?/c color%)))] 60 | [current-base-color (parameter/c (or/c string? (is-a?/c color%)))] 61 | [current-reader-forms (parameter/c (listof symbol?))] 62 | [code-align (-> pict-convertible? pict?)] 63 | [current-keyword-list (parameter/c (listof string?))] 64 | [current-const-list (parameter/c (listof string?))] 65 | [current-literal-list (parameter/c (listof string?))] 66 | [codeblock-pict (->* (string?) (#:keep-lang-line? any/c) pict?)] 67 | [current-token-class->color (parameter/c (-> symbol? (or/c string? (is-a?/c color%))))])) 68 | 69 | (provide define-exec-code/scale 70 | define-exec-code) 71 | (define-syntax (define-exec-code/scale stx) 72 | (define (drop-to-run l) 73 | (map (lambda (x) 74 | (cond 75 | [(and (pair? (syntax-e x)) 76 | (eq? 'local (syntax-e (car (syntax-e x))))) 77 | (let ([l (syntax->list x)]) 78 | (list* 'local 79 | (drop-to-run (syntax->list (cadr l))) 80 | (cddr l)))] 81 | [(and (pair? (syntax-e x)) 82 | (eq? 'define (syntax-e (car (syntax-e x))))) 83 | (let ([l (syntax->list x)]) 84 | (list* 'define 85 | (cadr l) 86 | (drop-to-run (cddr l))))] 87 | [else x])) 88 | (filter (lambda (x) 89 | (cond 90 | [(eq? '_ (syntax-e x)) 91 | #f] 92 | [(eq? '... (syntax-e x)) 93 | #f] 94 | [(eq? 'code:blank (syntax-e x)) 95 | #f] 96 | [(and (pair? (syntax-e x)) 97 | (memq (syntax-e (car (syntax-e x))) '(code:comment code:comment2))) 98 | #f] 99 | [(and (pair? (syntax-e x)) 100 | (eq? 'code:contract (syntax-e (car (syntax-e x))))) 101 | #f] 102 | [(and (pair? (syntax-e x)) 103 | (eq? 'unsyntax (syntax-e (car (syntax-e x))))) 104 | #f] 105 | [else #t])) 106 | l))) 107 | (define (drop-to-show l) 108 | (foldr (lambda (x r) 109 | (cond 110 | [(and (identifier? x) (eq? '_ (syntax-e x))) 111 | (cdr r)] 112 | [(and (pair? (syntax-e x)) 113 | (eq? 'local (syntax-e (car (syntax-e x))))) 114 | (cons 115 | (let ([l (syntax->list x)]) 116 | (datum->syntax 117 | x 118 | (list* (car l) 119 | (datum->syntax 120 | (cadr l) 121 | (drop-to-show (syntax->list (cadr l))) 122 | (cadr l)) 123 | (cddr l)) 124 | x)) 125 | r)] 126 | [(and (pair? (syntax-e x)) 127 | (eq? 'cond (syntax-e (car (syntax-e x))))) 128 | (cons 129 | (let ([l (syntax->list x)]) 130 | (datum->syntax 131 | x 132 | (list* (car l) 133 | (drop-to-show (cdr l))) 134 | x)) 135 | r)] 136 | [(and (pair? (syntax-e x)) 137 | (eq? 'define (syntax-e (car (syntax-e x))))) 138 | (cons (let ([l (syntax->list x)]) 139 | (datum->syntax 140 | x 141 | (list* (car l) 142 | (cadr l) 143 | (drop-to-show (cddr l))) 144 | x)) 145 | r)] 146 | [else (cons x r)])) 147 | empty 148 | l)) 149 | 150 | (syntax-case stx () 151 | [(_ s (showable-name runnable-name string-name) . c) 152 | #`(begin 153 | (define runnable-name 154 | (quote-syntax 155 | (begin 156 | #,@(drop-to-run (syntax->list #'c))))) 157 | (define showable-name 158 | (scale/improve-new-text 159 | (code 160 | #,@(drop-to-show (syntax->list #'c))) 161 | s)) 162 | (define string-name 163 | #,(syntax->string #'c)))])) 164 | 165 | (define-syntax define-exec-code 166 | (syntax-rules () 167 | [(_ (a b c) . r) 168 | (define-exec-code/scale 1 (a b c) . r)])) 169 | 170 | 171 | ;;------------------------------------------------ 172 | ;; codeblock-pict 173 | 174 | (define (tokenize/color -s) 175 | (define s (string-replace -s "\r\n" "\n")) ; module-lexer does not like \r\n 176 | (define port (open-input-string s)) 177 | (port-count-lines! port) 178 | (let loop ([acc #f] 179 | [rev-tokens+classes '()]) 180 | (define-values (_1 token-class _3 start end _6 next-acc) 181 | (module-lexer port 0 acc)) 182 | (cond 183 | [(equal? token-class 'eof) 184 | (reverse rev-tokens+classes)] 185 | [else 186 | ;; if the token has newlines, split them up, so we can recognize them 187 | ;; more easily later 188 | (define token (substring s (sub1 start) (sub1 end))) 189 | (define lines (add-between (string-split token "\n" #:trim? #f) "\n")) 190 | (define new-tokens+classes 191 | (for/list ([l (in-list lines)]) 192 | (cons l token-class))) 193 | (loop (if (dont-stop? next-acc) 194 | (dont-stop-val next-acc) 195 | next-acc) 196 | (append (reverse new-tokens+classes) rev-tokens+classes))]))) 197 | 198 | (define (tokens->pict ts #:keep-lang-line? [keep-lang-line? #t]) 199 | ;; cache parameter lookups 200 | (define tt (current-code-tt)) 201 | (define keyword-color (current-keyword-color)) 202 | (define token-class->color (current-token-class->color)) 203 | (define (in-keyword-list? token) 204 | (member token (current-keyword-list))) 205 | (define (token->pict t) 206 | (match-define `(,token . ,type) t) 207 | (define color 208 | (cond [(in-keyword-list? token) keyword-color] 209 | [else (token-class->color type)])) 210 | (colorize (tt token) color)) 211 | (define (not-newline? x) (not (equal? (car x) "\n"))) 212 | (define lines 213 | (let loop ([ts ts]) 214 | (cond 215 | [(empty? ts) 216 | '()] 217 | [else 218 | ;; take the next line 219 | (define-values (next-line rest) 220 | (splitf-at ts not-newline?)) 221 | (cons next-line 222 | (loop (if (pair? rest) ; there is a newline to skip 223 | (cdr rest) 224 | rest)))]))) 225 | (define first-line (first lines)) 226 | (define (format-line l) (apply hbl-append (map token->pict l))) 227 | (apply vl-append 228 | (map format-line 229 | ;; FIXME: #lang can span lines 230 | ;; (codeblock has same issue) 231 | (if keep-lang-line? lines (rest lines))))) 232 | 233 | (define current-token-class->color 234 | (make-parameter 235 | (lambda (c) 236 | (define id-color (current-id-color)) 237 | (define comment-color (current-comment-color)) 238 | (define base-color (current-base-color)) 239 | (define literal-color (current-literal-color)) 240 | (define keyword-color (current-keyword-color)) 241 | (case c 242 | [(symbol) id-color] 243 | [(keyword) keyword-color] 244 | [(white-space) "white"] 245 | [(comment) comment-color] 246 | [(no-color) base-color] 247 | [(parenthesis) base-color] ; really? pict has no color for parens? 248 | [(string) literal-color] 249 | [(constant) literal-color] 250 | [(hash-colon-keyword) base-color] 251 | [else "black"])))) ; 'other, or others. to align with DrRacket 252 | 253 | (define (codeblock-pict s #:keep-lang-line? [keep-lang-line? #t]) 254 | (tokens->pict (tokenize/color s) #:keep-lang-line? keep-lang-line?)) 255 | -------------------------------------------------------------------------------- /pict-lib/pict/color.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/class racket/contract racket/draw 4 | "convert.rkt" 5 | pict) 6 | 7 | (define color/c 8 | (or/c string? ;; might be faster 9 | ;;(and/c string? (lambda (s) (send the-color-database find-color s))) 10 | (is-a?/c color%) 11 | (list/c byte? byte? byte?))) 12 | 13 | (provide/contract 14 | [color/c flat-contract?] 15 | [red (-> pict-convertible? pict?)] 16 | [orange (-> pict-convertible? pict?)] 17 | [yellow (-> pict-convertible? pict?)] 18 | [green (-> pict-convertible? pict?)] 19 | [blue (-> pict-convertible? pict?)] 20 | [purple (-> pict-convertible? pict?)] 21 | [black (-> pict-convertible? pict?)] 22 | [brown (-> pict-convertible? pict?)] 23 | [gray (-> pict-convertible? pict?)] 24 | [white (-> pict-convertible? pict?)] 25 | [cyan (-> pict-convertible? pict?)] 26 | [magenta (-> pict-convertible? pict?)] 27 | [light (-> color/c color/c)] 28 | [dark (-> color/c color/c)]) 29 | 30 | (define-syntax-rule (define-colors name ...) 31 | (begin (define (name pict) (colorize pict (symbol->string 'name))) ...)) 32 | 33 | (define-colors 34 | red orange yellow green blue purple 35 | black brown gray white cyan magenta) 36 | 37 | (define (light c) (scale-color 2 c)) 38 | (define (dark c) (scale-color 1/2 c)) 39 | -------------------------------------------------------------------------------- /pict-lib/pict/conditional.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require pict 4 | racket/contract/base 5 | racket/stxparam 6 | "convert.rkt" 7 | (for-syntax racket/base)) 8 | 9 | (provide/contract 10 | [hide (->* [pict-convertible?] [any/c] pict?)] 11 | [show (->* [pict-convertible?] [any/c] pict-convertible?)]) 12 | (provide pict-if pict-cond pict-case) 13 | 14 | ;; The original API in unstable/gui/pict provided a syntax parameter to control 15 | ;; the default combiner. This made the API more complex, and potentially scary 16 | ;; due to its use of a high-powered features. To keep things simpler, the 17 | ;; pict/conditional API does not expose those, but they need to be exposed via 18 | ;; unstable/gui/pict for backwards compatibility. 19 | (module params racket/base 20 | (require racket/splicing racket/stxparam pict 21 | (for-syntax racket/base)) 22 | (provide pict-combine with-pict-combine) 23 | (define-syntax-parameter pict-combine #'ltl-superimpose) 24 | (define-syntax-rule (with-pict-combine combine body ...) 25 | (splicing-syntax-parameterize 26 | ([pict-combine #'combine]) 27 | body ...))) 28 | 29 | (require (submod "." params)) 30 | 31 | (define-syntax (pict-if stx) 32 | (syntax-case stx () 33 | [(_ #:combine combine test success failure) 34 | (syntax/loc stx 35 | (let* ([result test]) 36 | (combine (show success result) 37 | (hide failure result))))] 38 | [(_ test success failure) 39 | (quasisyntax/loc stx 40 | (pict-if #:combine #,(syntax-parameter-value #'pict-combine) 41 | test success failure))])) 42 | 43 | (define-syntax (pict-cond stx) 44 | (syntax-case stx (else) 45 | [(_ #:combine combine [test expr] ... [else default]) 46 | (with-syntax ([(pict ...) (generate-temporaries #'(expr ...))]) 47 | (syntax/loc stx 48 | (let ([pict expr] ... [final default]) 49 | (combine (cond [test pict] ... [else final]) 50 | (ghost pict) ... (ghost final)))))] 51 | [(_ #:combine combine [test pict] ...) 52 | (syntax/loc stx 53 | (pict-cond #:combine combine [test pict] ... [else (blank 0 0)]))] 54 | [(_ [test expr] ...) 55 | (quasisyntax/loc stx 56 | (pict-cond #:combine #,(syntax-parameter-value #'pict-combine) 57 | [test expr] ...))])) 58 | 59 | (define-syntax (pict-case stx) 60 | (syntax-case stx (else) 61 | [(_ test #:combine combine [literals expr] ... [else default]) 62 | (with-syntax ([(pict ...) (generate-temporaries #'(expr ...))]) 63 | (syntax/loc stx 64 | (let ([pict expr] ... [final default]) 65 | (combine (case test [literals pict] ... [else final]) 66 | (ghost pict) ... (ghost final)))))] 67 | [(_ test #:combine combine [literals expr] ...) 68 | (syntax/loc stx 69 | (pict-case test #:combine combine 70 | [literals expr] ... [else (blank 0 0)]))] 71 | [(_ test [literals expr] ...) 72 | (quasisyntax/loc stx 73 | (pict-case test #:combine #,(syntax-parameter-value #'pict-combine) 74 | [literals expr] ...))])) 75 | 76 | (define (hide pict [hide? #t]) 77 | (if hide? (ghost pict) pict)) 78 | 79 | (define (show pict [show? #t]) 80 | (if show? pict (ghost pict))) 81 | -------------------------------------------------------------------------------- /pict-lib/pict/convert.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/pict.rkt" 3 | racket/contract/base 4 | "private/convertible.rkt") 5 | 6 | (provide pict-convert pict-convertible?) 7 | (provide/contract 8 | [prop:pict-convertible (struct-type-property/c (-> pict-convertible? pict?))] 9 | [prop:pict-convertible? (struct-type-property/c predicate/c)]) 10 | -------------------------------------------------------------------------------- /pict-lib/pict/face.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require texpict/face) 3 | (provide (all-from-out texpict/face)) 4 | -------------------------------------------------------------------------------- /pict-lib/pict/flash.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require texpict/flash) 4 | (provide (all-from-out texpict/flash)) 5 | -------------------------------------------------------------------------------- /pict-lib/pict/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/main.rkt" 3 | "convert.rkt" 4 | "private/transform.rkt" 5 | racket/contract 6 | racket/class 7 | racket/draw 8 | racket/list) 9 | 10 | (provide 11 | (except-out (all-from-out "private/main.rkt") 12 | blank 13 | launder 14 | linewidth 15 | use-last 16 | use-last* 17 | pict->bitmap 18 | pict->argb-pixels 19 | argb-pixels->pict 20 | colorize 21 | pin-under pin-over 22 | rectangle filled-rectangle 23 | rounded-rectangle filled-rounded-rectangle 24 | circle disk ellipse filled-ellipse 25 | lt-find 26 | lc-find 27 | lb-find 28 | ltl-find 29 | lbl-find 30 | ct-find 31 | cc-find 32 | cb-find 33 | ctl-find 34 | cbl-find 35 | rt-find 36 | rc-find 37 | rb-find 38 | rtl-find 39 | rbl-find 40 | vl-append 41 | vc-append 42 | vr-append 43 | ht-append 44 | hc-append 45 | hb-append 46 | htl-append 47 | hbl-append 48 | pin-line pin-arrow-line pin-arrows-line 49 | cellophane 50 | frame 51 | dc 52 | table) 53 | 54 | pin-arrow-line 55 | pin-arrows-line 56 | pin-line 57 | (contract-out 58 | [explain 59 | (->* (pict-convertible?) 60 | (#:border (or/c #f string? (is-a?/c color%)) 61 | #:ascent (or/c #f string? (is-a?/c color%)) 62 | #:baseline (or/c #f string? (is-a?/c color%)) 63 | #:scale real? 64 | #:line-width real?) 65 | pict?)] 66 | [explain-child 67 | (->* (pict-convertible?) 68 | (#:border (or/c #f string? (is-a?/c color%)) 69 | #:ascent (or/c #f string? (is-a?/c color%)) 70 | #:baseline (or/c #f string? (is-a?/c color%)) 71 | #:scale real? 72 | #:line-width real?) 73 | #:rest (listof pict-path?) 74 | pict?)] 75 | [launder (-> pict-convertible? pict-convertible?)] 76 | [blank 77 | (case-> 78 | (-> pict?) 79 | (-> real? pict?) 80 | (-> real? real? pict?) 81 | (-> real? real? real? pict?) 82 | (-> real? real? real? real? pict?))] 83 | [frame (->* (pict-convertible?) 84 | (#:segment (or/c #f real?) 85 | #:color (or/c #f string? (is-a?/c color%)) 86 | #:line-width (or/c #f real?)) 87 | pict?)] 88 | [table (->i ([ncols exact-positive-integer?] 89 | [picts (non-empty-listof pict-convertible?)] 90 | [col-aligns (or/c (list*of (->* () #:rest (listof pict-convertible?) pict-convertible?)) 91 | (listof (->* () #:rest (listof pict-convertible?) pict-convertible?)))] 92 | [row-aligns (or/c (list*of (->* () #:rest (listof pict-convertible?) pict-convertible?)) 93 | (listof (->* () #:rest (listof pict-convertible?) pict-convertible?)))] 94 | [col-seps (or/c (listof real?) (list*of real?))] 95 | [row-seps (or/c (listof real?) (list*of real?))]) 96 | #:pre/desc (ncols picts) 97 | (let ((rem (remainder (length picts) ncols))) 98 | (or (zero? rem) 99 | (format "ncols does not divide number of picts (~a % ~a = ~a)" (length picts) ncols rem))) 100 | [result pict?])] 101 | [dc (->i ([draw (-> (is-a?/c dc<%>) real? real? any)] 102 | [w real?] 103 | [h real?]) 104 | ([d (or/c #f real?)] 105 | [a (or/c #f real?)]) 106 | #:pre/name (draw) 107 | "draw proc does not restore the dc state after being called" 108 | (does-draw-restore-the-state-after-being-called? draw) 109 | [p pict?])] 110 | [rename dc unsafe-dc 111 | (->i ([draw (-> (is-a?/c dc<%>) real? real? any)] 112 | [w real?] 113 | [h real?]) 114 | ([d (or/c #f real?)] 115 | [a (or/c #f real?)]) 116 | [p pict?])] 117 | [cellophane (->* (pict-convertible? (real-in 0 1)) 118 | (#:composite? any/c) 119 | pict?)] 120 | 121 | [linewidth (-> (or/c real? #f) pict-convertible? pict?)] 122 | 123 | [lt-find *-find/c] 124 | [lc-find *-find/c] 125 | [lb-find *-find/c] 126 | [ltl-find *-find/c] 127 | [lbl-find *-find/c] 128 | [ct-find *-find/c] 129 | [cc-find *-find/c] 130 | [cb-find *-find/c] 131 | [ctl-find *-find/c] 132 | [cbl-find *-find/c] 133 | [rt-find *-find/c] 134 | [rc-find *-find/c] 135 | [rb-find *-find/c] 136 | [rtl-find *-find/c] 137 | [rbl-find *-find/c] 138 | [vl-append *-append/c] 139 | [vc-append *-append/c] 140 | [vr-append *-append/c] 141 | [ht-append *-append/c] 142 | [hc-append *-append/c] 143 | [hb-append *-append/c] 144 | [htl-append *-append/c] 145 | [hbl-append *-append/c] 146 | 147 | [use-last (-> pict-convertible? pict-path? pict?)] 148 | [use-last* (-> pict-convertible? pict-convertible? pict?)] 149 | 150 | [colorize (-> pict-convertible? 151 | (or/c string? 152 | (is-a?/c color%) 153 | (list/c byte? byte? byte?)) 154 | pict?)] 155 | 156 | [pict->bitmap (->* (pict-convertible?) 157 | ((or/c 'unsmoothed 'smoothed 'aligned) 158 | #:make-bitmap (-> exact-positive-integer? exact-positive-integer? (is-a?/c bitmap%))) 159 | (is-a?/c bitmap%))] 160 | [pict->argb-pixels (->* (pict-convertible?) 161 | ((or/c 'unsmoothed 'smoothed 'aligned)) 162 | (and/c bytes? multiple-of-four-bytes?))] 163 | [argb-pixels->pict (-> (and/c bytes? multiple-of-four-bytes?) 164 | exact-nonnegative-integer? 165 | pict?)] 166 | [pin-under 167 | (->i ([base pict-convertible?] 168 | [dx/fp (or/c real? pict-path?)] 169 | [dy/f (dx/fp) 170 | (if (real? dx/fp) 171 | real? 172 | (-> pict-convertible? pict-path? (values real? real?)))] 173 | [pict pict-convertible?]) 174 | [result pict?])] 175 | [pin-over 176 | (->i ([base pict-convertible?] 177 | [dx/fp (or/c real? pict-path?)] 178 | [dy/f (dx/fp) 179 | (if (real? dx/fp) 180 | real? 181 | (-> pict-convertible? pict-path? (values real? real?)))] 182 | [pict pict-convertible?]) 183 | [result pict?])] 184 | [rectangle (->* ((and/c rational? (not/c negative?)) 185 | (and/c rational? (not/c negative?))) 186 | (#:border-color (or/c #f string? (is-a?/c color%)) 187 | #:border-width (or/c #f (and/c rational? (not/c negative?)))) 188 | pict?)] 189 | [filled-rectangle (->i ([w (and/c rational? (not/c negative?))] 190 | [h (and/c rational? (not/c negative?))]) 191 | (#:draw-border? [draw-border? any/c] 192 | #:color [color (or/c #f string? (is-a?/c color%))] 193 | #:border-color [border-color (or/c #f string? (is-a?/c color%))] 194 | #:border-width [border-width (or/c #f (and/c rational? (not/c negative?)))]) 195 | #:pre (draw-border? border-color border-width) 196 | (if (not draw-border?) 197 | (and (or (unsupplied-arg? border-color) 198 | (not border-color)) 199 | (or (unsupplied-arg? border-width) 200 | (not border-width))) 201 | #t) 202 | [_ pict?])] 203 | [rounded-rectangle (->* ((and/c rational? (not/c negative?)) 204 | (and/c rational? (not/c negative?))) 205 | (rational? 206 | #:angle rational? 207 | #:border-color (or/c #f string? (is-a?/c color%)) 208 | #:border-width (or/c #f (and/c rational? (not/c negative?)))) 209 | pict?)] 210 | [filled-rounded-rectangle (->i ([w (and/c rational? (not/c negative?))] 211 | [h (and/c rational? (not/c negative?))]) 212 | ([corner-radius rational?] 213 | #:angle [angle rational?] 214 | #:draw-border? [draw-border? any/c] 215 | #:color [color (or/c #f string? (is-a?/c color%))] 216 | #:border-color [border-color (or/c #f string? (is-a?/c color%))] 217 | #:border-width [border-width (or/c #f (and/c rational? (not/c negative?)))]) 218 | #:pre (draw-border? border-color border-width) 219 | (if (not draw-border?) 220 | (and (or (unsupplied-arg? border-color) 221 | (not border-color)) 222 | (or (unsupplied-arg? border-width) 223 | (not border-width))) 224 | #t) 225 | [_ pict?])] 226 | [circle (->* ((and/c rational? (not/c negative?))) 227 | (#:border-color (or/c #f string? (is-a?/c color%)) 228 | #:border-width (or/c #f (and/c rational? (not/c negative?)))) 229 | pict?)] 230 | [disk (->i ([r (and/c rational? (not/c negative?))]) 231 | (#:draw-border? [draw-border? any/c] 232 | #:color [color (or/c #f string? (is-a?/c color%))] 233 | #:border-color [border-color (or/c #f string? (is-a?/c color%))] 234 | #:border-width [border-width (or/c #f (and/c rational? (not/c negative?)))]) 235 | #:pre (draw-border? border-color border-width) 236 | (if (not draw-border?) 237 | (and (or (unsupplied-arg? border-color) 238 | (not border-color)) 239 | (or (unsupplied-arg? border-width) 240 | (not border-width))) 241 | #t) 242 | [_ pict?])] 243 | [ellipse (->* ((and/c rational? (not/c negative?)) 244 | (and/c rational? (not/c negative?))) 245 | (#:border-color (or/c #f string? (is-a?/c color%)) 246 | #:border-width (or/c #f (and/c rational? (not/c negative?)))) 247 | pict?)] 248 | [filled-ellipse (->i ([w (and/c rational? (not/c negative?))] 249 | [h (and/c rational? (not/c negative?))]) 250 | (#:draw-border? [draw-border? any/c] 251 | #:color [color (or/c #f string? (is-a?/c color%))] 252 | #:border-color [border-color (or/c #f string? (is-a?/c color%))] 253 | #:border-width [border-width (or/c #f (and/c rational? (not/c negative?)))]) 254 | #:pre (draw-border? border-color border-width) 255 | (if (not draw-border?) 256 | (and (or (unsupplied-arg? border-color) 257 | (not border-color)) 258 | (or (unsupplied-arg? border-width) 259 | (not border-width))) 260 | #t) 261 | [_ pict?])])) 262 | 263 | (define (does-draw-restore-the-state-after-being-called? draw) 264 | (define bdc (new bitmap-dc% [bitmap (make-bitmap 1 1)])) 265 | (prandomize-state bdc) 266 | (define old-state (get-dc-state bdc)) 267 | (draw bdc 0 0) 268 | (equal? (get-dc-state bdc) old-state)) 269 | 270 | ;; randomizes some portions of the state of the given dc; 271 | ;; doesn't pick random values for things that the 'dc' 272 | ;; function promises not to change (e.g. the pen/brush style). 273 | (define (prandomize-state dc) 274 | (send dc set-origin (prandom-real) (prandom-real)) 275 | (send dc set-pen (prandom-color) (prandom 255) 'solid) 276 | (send dc set-brush (prandom-color) 'solid) 277 | (send dc set-alpha (prandom)) 278 | (send dc set-text-background (prandom-color)) 279 | (send dc set-text-foreground (prandom-color)) 280 | (send dc set-text-mode 'transparent) 281 | (send dc set-font (send the-font-list find-or-create-font 282 | (+ 1 (prandom 254)) 283 | (pick-one 'default 'decorative 'roman 'script 284 | 'swiss 'modern 'symbol 'system) 285 | (pick-one 'normal 'italic 'slant) 286 | (pick-one 'normal 'bold 'light))) 287 | ;; set-transformation is relatively expensive 288 | ;; at the moment, so we don't randomize it 289 | #; 290 | (send dc set-transformation 291 | (vector (vector (prandom-real) (prandom-real) (prandom-real) 292 | (prandom-real) (prandom-real) (prandom-real)) 293 | (prandom-real) (prandom-real) (prandom-real) (prandom-real) (prandom-real)))) 294 | 295 | (define (prandom-real) (+ (prandom 1000) (prandom))) 296 | (define (prandom-color) (make-object color% (prandom 255) (prandom 255) (prandom 255))) 297 | (define (pick-one . args) (list-ref args (prandom (length args)))) 298 | (define pict-psrg 299 | (make-pseudo-random-generator)) 300 | (define prandom 301 | (case-lambda 302 | [() 303 | (parameterize ([current-pseudo-random-generator pict-psrg]) 304 | (random))] 305 | [(x) 306 | (parameterize ([current-pseudo-random-generator pict-psrg]) 307 | (random x))])) 308 | 309 | (define (get-dc-state dc) 310 | (vector (pen->vec (send dc get-pen)) 311 | (brush->vec (send dc get-brush)) 312 | (send dc get-alpha) 313 | (font->vec (send dc get-font)) 314 | (let-values ([(ox oy) (send dc get-origin)]) 315 | (cons ox oy)) 316 | (color->vec (send dc get-text-background)) 317 | (send dc get-text-mode) 318 | (send dc get-transformation) 319 | (color->vec (send dc get-text-foreground)))) 320 | 321 | (define (pen->vec pen) 322 | (vector (color->vec (send pen get-color)) 323 | (send pen get-width) 324 | (send pen get-style))) 325 | 326 | (define (brush->vec brush) 327 | (vector (color->vec (send brush get-color)) 328 | (send brush get-style))) 329 | 330 | (define (font->vec font) 331 | (vector (send font get-point-size) 332 | (send font get-family) 333 | (send font get-style) 334 | (send font get-weight))) 335 | 336 | (define (color->vec c) 337 | (vector (send c red) (send c green) (send c blue))) 338 | 339 | (define *-find/c 340 | (->* (pict-convertible? pict-path?) 341 | (#:nth (or/c 'unique exact-nonnegative-integer?)) 342 | (values real? real?))) 343 | 344 | (define *-append/c 345 | (->* () 346 | () 347 | #:rest (or/c (cons/c real? (listof pict-convertible?)) 348 | (listof pict-convertible?)) 349 | pict-convertible?)) 350 | 351 | (define (multiple-of-four-bytes? b) 352 | (zero? (modulo (bytes-length b) 4))) 353 | 354 | (define (explain p 355 | #:border [b "Firebrick"] 356 | #:ascent [a "MediumSeaGreen"] 357 | #:baseline [d "DodgerBlue"] 358 | #:scale [s 5] 359 | #:line-width [lw 1]) 360 | (explain-child* p p b a d s lw)) 361 | (define (explain-child 362 | p 363 | #:border [b "Firebrick"] 364 | #:ascent [a "MediumSeaGreen"] 365 | #:baseline [d "DodgerBlue"] 366 | #:scale [s 5] 367 | #:line-width [lw 1] 368 | . child-path) 369 | (scale 370 | (for/fold ([p p]) 371 | ([c (in-list child-path)]) 372 | (explain-child* p c b a d 1 lw)) 373 | s)) 374 | (define (explain-child* 375 | p 376 | child-path 377 | b a d s lw) 378 | (define t (get-child-transformation p child-path)) 379 | (define child (last (flatten child-path))) 380 | (define cw (pict-width child)) 381 | (define ch (pict-height child)) 382 | (define nw (+ (* 2 lw) (pict-width p))) 383 | (define nh (+ (* 2 lw) (pict-height p))) 384 | (define ncw (+ (* 2 lw) cw)) 385 | (define nch (+ (* 2 lw) ch)) 386 | (define lw/2 (/ lw 2)) 387 | (define annotations 388 | (dc 389 | (lambda (dc dx dy) 390 | (define oldt (send dc get-transformation)) 391 | (define p (send dc get-pen)) 392 | (define br (send dc get-brush)) 393 | (send dc set-brush "white" 'transparent) 394 | (send dc translate dx dy) 395 | (send dc transform t) 396 | (when b 397 | (define t2 (send dc get-transformation)) 398 | (send dc scale (/ ncw cw) (/ nch ch)) 399 | (define path (new dc-path%)) 400 | (send dc set-pen b lw 'solid) 401 | (send path move-to lw/2 lw/2) 402 | (send path line-to lw/2 (- ch lw/2)) 403 | (send path line-to (- cw lw/2) (- ch lw/2)) 404 | (send path line-to (- cw lw/2) lw/2) 405 | (send path close) 406 | (send dc draw-path path 0 0) 407 | (send dc set-transformation t2)) 408 | (when a 409 | (define line (pict-ascent child)) 410 | (send dc set-pen a lw 'solid) 411 | (send dc draw-line lw/2 line 412 | (+ lw lw/2 cw) line)) 413 | (when d 414 | (define line (- (pict-height child) (pict-descent child))) 415 | (send dc set-pen d lw 'solid) 416 | (send dc draw-line lw/2 line 417 | (+ lw lw/2 cw) line)) 418 | (send dc set-transformation oldt) 419 | (send dc set-pen p) 420 | (send dc set-brush br)) 421 | nw nh)) 422 | (scale 423 | (cc-superimpose 424 | p 425 | annotations) 426 | s)) 427 | 428 | 429 | (require "private/play-pict.rkt") 430 | (provide 431 | (contract-out 432 | [fade-pict (->* ((real-in 0.0 1.0) pict-convertible? pict-convertible?) 433 | (#:combine (-> pict-convertible? pict-convertible? pict?) 434 | #:composite? any/c) 435 | pict?)] 436 | [slide-pict (-> pict-convertible? pict-convertible? pict-convertible? pict-convertible? (real-in 0.0 1.0) pict?)] 437 | [slide-pict/center (-> pict-convertible? pict-convertible? pict-convertible? pict-convertible? (real-in 0.0 1.0) pict?)] 438 | [fade-around-pict (->* ((real-in 0.0 1.0) pict-convertible? (-> pict-convertible? pict?)) 439 | (#:composite? any/c) 440 | pict?)] 441 | [sequence-animations (->* () #:rest (listof (-> (real-in 0.0 1.0) pict-convertible?)) 442 | (-> (real-in 0.0 1.0) pict?))] 443 | [reverse-animations (->* () #:rest (listof (-> (real-in 0.0 1.0) pict-convertible?)) 444 | (-> (real-in 0.0 1.0) pict?))] 445 | [fast-start (-> (real-in 0.0 1.0) (real-in 0.0 1.0))] 446 | [fast-end (-> (real-in 0.0 1.0) (real-in 0.0 1.0))] 447 | [fast-edges (-> (real-in 0.0 1.0) (real-in 0.0 1.0))] 448 | [fast-middle (-> (real-in 0.0 1.0) (real-in 0.0 1.0))] 449 | [split-phase (-> (real-in 0.0 1.0) (values (real-in 0.0 1.0) (real-in 0.0 1.0)))])) 450 | -------------------------------------------------------------------------------- /pict-lib/pict/private/convertible.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide prop:pict-convertible prop:pict-convertible? pict-convertible? pict-convert 3 | pict-convertible-ref) 4 | (require "pict.rkt") 5 | -------------------------------------------------------------------------------- /pict-lib/pict/private/hv.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../main.rkt" 3 | "layout.rkt" 4 | racket/match) 5 | 6 | #| 7 | 8 | A note on optimal area algorithms for upward drawing of binary trees 9 | P. Crescenzi, G. Di Battista, and A. Piperno 10 | Computational Geometry, Theory and Applications 2 (1992) 11 | 12 | |# 13 | (provide hv-alternating) 14 | (define (hv-alternating t 15 | #:x-spacing [given-x-spacing #f] 16 | #:y-spacing [given-y-spacing #f] 17 | #:transform [transform #f]) 18 | (define-values (x-size y-size) (compute-spacing t #f #f)) 19 | (define x-spacing (or given-x-spacing (* x-size 1.5))) 20 | (define y-spacing (or given-y-spacing (* y-size 1.5))) 21 | (define t-unique (uniquify-picts t)) 22 | (define main 23 | (inset 24 | (let loop ([t t-unique] 25 | [l #t]) 26 | (match t 27 | [#f (blank)] 28 | [(tree-layout pict (list left right)) 29 | (define left-t (and (tree-edge? left) (tree-edge-child left))) 30 | (define right-t (and (tree-edge? right) (tree-edge-child right))) 31 | (cond 32 | [(and (not left-t) (not right-t)) 33 | (dot-ize pict)] 34 | [(not left-t) 35 | (empty-left (dot-ize pict) x-spacing (loop right-t (not l)))] 36 | [(not right-t) 37 | (empty-right (dot-ize pict) y-spacing (loop left-t (not l)))] 38 | [else 39 | (define left-p (loop left-t (not l))) 40 | (define right-p (loop right-t (not l))) 41 | (define main 42 | ((if l left-right top-bottom) 43 | x-spacing y-spacing 44 | left-p right-p)) 45 | (pin-over 46 | main 47 | (- (/ (pict-width pict) 2)) 48 | (- (/ (pict-height pict) 2)) 49 | pict)])])) 50 | (/ x-size 2) 51 | (/ y-size 2))) 52 | 53 | (transform-tree-pict t-unique main transform)) 54 | 55 | (define (dot-ize p) 56 | (define b (blank)) 57 | (refocus (cc-superimpose b p) b)) 58 | 59 | (define (left-right hgap vgap left right) 60 | (ht-append 61 | hgap 62 | (vl-append (blank 0 vgap) left) 63 | right)) 64 | 65 | (define (top-bottom hgap vgap left right) 66 | (vl-append 67 | vgap 68 | (ht-append (blank hgap 0) left) 69 | right)) 70 | 71 | (define (empty-left pict hgap sub-tree-p) 72 | (ht-append hgap pict sub-tree-p)) 73 | 74 | (define (empty-right pict vgap sub-tree-p) 75 | (vl-append vgap pict sub-tree-p)) 76 | 77 | (module+ test 78 | (require rackunit) 79 | 80 | (check-pred pict? 81 | (hv-alternating 82 | (let* ([p1 (_tree-layout #f #f)] 83 | [p2 (_tree-layout p1 p1)] 84 | [p3 (_tree-layout p2 p2)] 85 | [p4 (_tree-layout p3 p3)]) 86 | (_tree-layout p4 p4)))) 87 | (check-pred 88 | pict? 89 | (hv-alternating (_tree-layout (_tree-layout #f #f) #f))) 90 | (check-pred 91 | pict? 92 | (hv-alternating (_tree-layout #f (_tree-layout #f (_tree-layout #f #f))))) 93 | (check-pred pict? (hv-alternating #f))) 94 | 95 | (module+ main 96 | (define (complete n) 97 | (cond 98 | [(= n 0) #f] 99 | [else 100 | (define t (complete (- n 1))) 101 | (_tree-layout t t)])) 102 | 103 | ;; an example from the paper 104 | (hv-alternating (complete 4))) 105 | 106 | -------------------------------------------------------------------------------- /pict-lib/pict/private/layout.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../main.rkt" racket/match) 3 | 4 | (provide (struct-out tree-layout) 5 | (struct-out tree-edge) 6 | binary-tree-layout? 7 | _tree-layout? 8 | _tree-layout 9 | _tree-edge 10 | default-node-pict 11 | compute-spacing 12 | uniquify-picts 13 | transform-tree-pict) 14 | 15 | ;; values of this struct leak outside, so it cannot be transparent 16 | (struct tree-layout (pict children)) 17 | (struct tree-edge (child edge-color edge-width edge-style)) 18 | 19 | (define _tree-layout 20 | (let ([constructor tree-layout]) 21 | (define (tree-layout #:pict [node-pict #f] 22 | . children) 23 | (constructor (or node-pict default-node-pict) 24 | (for/list ([child (in-list children)]) 25 | (cond 26 | [(tree-edge? child) child] 27 | [(not child) child] 28 | [else (_tree-edge child)])))) 29 | tree-layout)) 30 | 31 | (define _tree-layout? 32 | (let ([predicate tree-layout?]) 33 | (define (tree-layout? v) 34 | (or (not v) (predicate v))) 35 | tree-layout?)) 36 | 37 | (define default-node-pict 38 | (cc-superimpose 39 | (disk 16 #:draw-border? #f) 40 | (colorize (disk 12 #:draw-border? #f) "white"))) 41 | 42 | (define _tree-edge 43 | (let ([constructor tree-edge]) 44 | (define (tree-edge child 45 | #:edge-color [edge-color "gray"] 46 | #:edge-width [edge-width 'unspecified] 47 | #:edge-style [edge-style 'unspecified]) 48 | (constructor child edge-color edge-width edge-style)) 49 | tree-edge)) 50 | 51 | (define (binary-tree-layout? t) 52 | (match t 53 | [#f #t] 54 | [(tree-layout pict (list left right)) 55 | (and (binary-tree-edge? left) 56 | (binary-tree-edge? right))] 57 | [else #f])) 58 | 59 | (define (binary-tree-edge? e) 60 | (match e 61 | [(tree-edge t _ _ _) (binary-tree-layout? t)] 62 | [#f #t])) 63 | 64 | (define (compute-spacing t given-x-spacing given-y-spacing) 65 | (cond 66 | [(and given-x-spacing given-y-spacing) 67 | (values given-x-spacing given-y-spacing)] 68 | [else 69 | (define x-spacing 0) 70 | (define y-spacing 0) 71 | 72 | (let loop ([t t]) 73 | (match t 74 | [#f (void)] 75 | [(tree-layout pict (list children ...)) 76 | (set! x-spacing (max (pict-width pict) x-spacing)) 77 | (set! y-spacing (max (pict-height pict) y-spacing)) 78 | (for ([edge (in-list children)]) 79 | (match edge 80 | [#f (void)] 81 | [(tree-edge child edge-color _ _) 82 | (loop child)]))])) 83 | 84 | (values (or given-x-spacing x-spacing) 85 | (or given-y-spacing y-spacing))])) 86 | 87 | ;; If `transform` is `#f`, then we'll reuse the layout pict and just place 88 | ;; edges on top of it. 89 | (define (transform-tree-pict t layout-pict transform) 90 | (define-values (l-amt t-amt r-amt b-amt) (values #f #f #f #f)) 91 | (define (update-bb! x y) 92 | (set! l-amt (if l-amt (min l-amt x) x)) 93 | (set! r-amt (if r-amt (max r-amt x) x)) 94 | (set! t-amt (if t-amt (min t-amt y) y)) 95 | (set! b-amt (if b-amt (max b-amt y) y))) 96 | (define w (pict-width layout-pict)) 97 | (define h (pict-height layout-pict)) 98 | (when transform 99 | (for ([x `(0 ,w ,w 0)] 100 | [y `(0 0 ,h ,h)]) 101 | (define-values (tx ty) (transform x y)) 102 | (update-bb! tx ty))) 103 | (define (place-node main pict) 104 | (define-values (x y) (lt-find layout-pict pict)) 105 | (define-values (tx ty) (transform x y)) 106 | (pin-over main tx ty pict)) 107 | (define final-pict 108 | (let loop ([t t] 109 | [main (if transform (blank) layout-pict)] 110 | [parent-pict #f]) 111 | (match t 112 | [#f main] 113 | [(tree-edge child edge-color edge-width edge-style) 114 | (define child-pict (tree-layout-pict child)) 115 | (let* ([main (loop child main #f)] 116 | [main (pin-line main 117 | parent-pict cc-find 118 | child-pict cc-find 119 | #:color edge-color 120 | #:under? #t)] 121 | [main (if (unspecified? edge-width) main (linewidth edge-width main))] 122 | [main (if (unspecified? edge-style) main (linestyle edge-style main))]) 123 | main)] 124 | [(tree-layout pict children) 125 | (for/fold ([main (if transform (place-node main pict) main)]) 126 | ([child (in-list children)]) 127 | (loop child main pict))]))) 128 | (if transform (inset final-pict l-amt t-amt r-amt b-amt) final-pict)) 129 | 130 | (define (uniquify-picts t) 131 | (let loop ([t t]) 132 | (match t 133 | [#f #f] 134 | [(tree-layout pict children) 135 | (tree-layout (unique-pict pict) (map loop children))] 136 | [(tree-edge child c w s) 137 | (tree-edge (loop child) c w s)]))) 138 | 139 | (define (unique-pict pict) 140 | (cc-superimpose pict)) 141 | 142 | (define (unspecified? x) 143 | (eq? x 'unspecified)) 144 | -------------------------------------------------------------------------------- /pict-lib/pict/private/main.rkt: -------------------------------------------------------------------------------- 1 | #lang scheme/base 2 | 3 | (require (rename-in "pict.rkt" 4 | [hline t:hline] 5 | [vline t:vline] 6 | [frame t:frame]) 7 | "convertible.rkt" 8 | (rename-in "utils.rkt" 9 | [pin-line t:pin-line] 10 | [pin-arrow-line t:pin-arrow-line] 11 | [pin-arrows-line t:pin-arrows-line]) 12 | (only-in racket/draw dc-path% make-bitmap bitmap% bitmap-dc% color%) 13 | (only-in racket/class new send make-object is-a?/c) 14 | racket/contract) 15 | 16 | (define (hline w h #:segment [seg #f]) 17 | (if seg 18 | (dash-hline w h seg) 19 | (t:hline w h))) 20 | 21 | (define (vline w h #:segment [seg #f]) 22 | (if seg 23 | (dash-vline w h seg) 24 | (t:vline w h))) 25 | 26 | (define (frame p 27 | #:color [col #f] 28 | #:line-width [lw #f] 29 | #:segment [seg #f]) 30 | (let* ([p (pict-convert p)] 31 | [f (if seg 32 | (dash-frame (launder (ghost p)) seg) 33 | (t:frame (launder (ghost p))))] 34 | [f (if col 35 | (colorize f col) 36 | f)] 37 | [f (if lw 38 | (linewidth lw f) 39 | f)]) 40 | (refocus (cc-superimpose p f) 41 | p))) 42 | 43 | (define (label-line label pict src-pict src-coord-fn dest-pict dest-coord-fn 44 | #:x-adjust [x-adjust 0] #:y-adjust [y-adjust 0]) 45 | (let-values ([(src-x src-y) (src-coord-fn pict src-pict)] 46 | [(dest-x dest-y) (dest-coord-fn pict dest-pict)]) 47 | (let* ([src (make-rectangular src-x src-y)] 48 | [dest (make-rectangular dest-x dest-y)] 49 | [adjust (make-rectangular x-adjust y-adjust)] 50 | [v (- dest src)] 51 | [h2 (pict-height label)]) 52 | ;; Ensure that the src is left of dest 53 | (when (< (real-part v) 0) 54 | (set! v (- v)) 55 | (set! src dest)) 56 | (let ([p (+ src 57 | ;; Move the label to sit atop the line. 58 | (/ (* h2 -i v) (magnitude v) 2) 59 | ;; Center the label in the line. 60 | (/ (- v (make-rectangular (pict-width label) 61 | (pict-height label))) 62 | 2) 63 | adjust)]) 64 | (pin-over 65 | pict 66 | (real-part p) 67 | (imag-part p) 68 | label))))) 69 | 70 | (define (pin-line p 71 | src src-find 72 | dest dest-find 73 | #:start-angle [sa #f] #:end-angle [ea #f] 74 | #:start-pull [sp #f] #:end-pull [ep #f] 75 | #:color [col #f] 76 | #:alpha [alpha 1.0] 77 | #:line-width [lw #f] 78 | #:under? [under? #f] 79 | #:solid? [solid? #t] 80 | #:style [style #f] 81 | #:label [label #f] 82 | #:x-adjust-label [x-adjust 0] 83 | #:y-adjust-label [y-adjust 0]) 84 | (define line 85 | (if (not (or sa ea)) 86 | (finish-pin (launder (t:pin-line (ghost p) 87 | src src-find 88 | dest dest-find 89 | #:style style)) 90 | p lw col alpha under?) 91 | (pin-curve* #f #f p src src-find dest dest-find 92 | sa ea sp ep 0 col lw under? #t 93 | style alpha))) 94 | (if label 95 | (label-line label line src src-find dest dest-find 96 | #:x-adjust x-adjust #:y-adjust y-adjust) 97 | line)) 98 | 99 | (define (pin-arrow-line sz p 100 | src src-find 101 | dest dest-find 102 | #:start-angle [sa #f] #:end-angle [ea #f] 103 | #:start-pull [sp #f] #:end-pull [ep #f] 104 | #:color [col #f] 105 | #:alpha [alpha 1.0] 106 | #:line-width [lw #f] 107 | #:under? [under? #f] 108 | #:solid? [solid? #t] 109 | #:style [style #f] 110 | #:hide-arrowhead? [hide-arrowhead? #f] 111 | #:label [label #f] 112 | #:x-adjust-label [x-adjust 0] 113 | #:y-adjust-label [y-adjust 0]) 114 | (define line 115 | (if (not (or sa ea)) 116 | (finish-pin (launder (t:pin-arrow-line sz (ghost p) 117 | src src-find 118 | dest dest-find 119 | #f #f #f solid? 120 | #:hide-arrowhead? hide-arrowhead? 121 | #:style style)) 122 | p lw col alpha under?) 123 | (pin-curve* #f (not hide-arrowhead?) p src src-find dest dest-find 124 | sa ea sp ep sz col lw under? solid? 125 | style alpha))) 126 | (if label 127 | (label-line label line src src-find dest dest-find 128 | #:x-adjust x-adjust #:y-adjust y-adjust) 129 | line)) 130 | 131 | (define (pin-arrows-line sz p 132 | src src-find 133 | dest dest-find 134 | #:start-angle [sa #f] #:end-angle [ea #f] 135 | #:start-pull [sp #f] #:end-pull [ep #f] 136 | #:color [col #f] 137 | #:alpha [alpha 1.0] 138 | #:line-width [lw #f] 139 | #:under? [under? #f] 140 | #:solid? [solid? #t] 141 | #:style [style #f] 142 | #:hide-arrowhead? [hide-arrowhead? #f] 143 | #:label [label #f] 144 | #:x-adjust-label [x-adjust 0] 145 | #:y-adjust-label [y-adjust 0]) 146 | (define line 147 | (if (not (or sa ea)) 148 | (finish-pin (launder (t:pin-arrows-line sz (ghost p) 149 | src src-find 150 | dest dest-find 151 | #f #f #f solid? 152 | #:hide-arrowhead? hide-arrowhead? 153 | #:style style)) 154 | p lw col alpha under?) 155 | (pin-curve* (not hide-arrowhead?) (not hide-arrowhead?) 156 | p src src-find dest dest-find 157 | sa ea sp ep sz col lw under? solid? 158 | style alpha))) 159 | (if label 160 | (label-line label line src src-find dest dest-find 161 | #:x-adjust x-adjust #:y-adjust y-adjust) 162 | line)) 163 | 164 | (define (pin-curve* start-arrow? end-arrow? p 165 | src src-find 166 | dest dest-find 167 | sa ea sp ep 168 | sz col lw 169 | under? solid? 170 | style alpha) 171 | (let-values ([(sx0 sy0) (src-find p src)] 172 | [(dx0 dy0) (dest-find p dest)]) 173 | (let* ([sa (or sa 174 | (get-angle (- sy0 dy0) (- dx0 sx0)))] 175 | [ea (or ea 176 | (get-angle (- sy0 dy0) (- dx0 sx0)))] 177 | [d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))] 178 | [sp (* (or sp 1/4) d)] 179 | [ep (* (or ep 1/4) d)]) 180 | (let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)] 181 | [dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)] 182 | [sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)] 183 | [sy (if start-arrow? (- sy0 (* sz (sin sa))) sy0)] 184 | [path (new dc-path%)] 185 | [maybe-pin-line 186 | (lambda (arrow? p sx sy dx dy) 187 | (if arrow? 188 | (pin-arrow-line 189 | sz 190 | p 191 | p (lambda (a b) (values sx sy)) 192 | p (lambda (a b) (values dx dy)) 193 | #:line-width lw 194 | #:color col 195 | #:under? under? 196 | #:solid? solid? 197 | #:style style 198 | #:alpha alpha) 199 | p))]) 200 | (send path move-to sx sy) 201 | (send path curve-to 202 | (+ sx (* sp (cos sa))) 203 | (- sy (* sp (sin sa))) 204 | (- dx (* ep (cos ea))) 205 | (+ dy (* ep (sin ea))) 206 | dx 207 | dy) 208 | (maybe-pin-line 209 | start-arrow? 210 | (maybe-pin-line 211 | end-arrow? 212 | ((if under? pin-under pin-over) 213 | p 214 | 0 0 215 | (let* ([p (dc (lambda (dc x y) 216 | (let ([b (send dc get-brush)]) 217 | (send dc set-brush "white" 'transparent) 218 | (send dc draw-path path x y) 219 | (send dc set-brush b))) 220 | 0 0)] 221 | [p (if col 222 | (colorize p col) 223 | p)] 224 | [p (if (= alpha 1.0) 225 | p 226 | (cellophane p alpha))] 227 | [p (if lw 228 | (linewidth lw p) 229 | p)] 230 | [p (if style 231 | (linestyle style p) 232 | p)]) 233 | p)) 234 | dx dy dx0 dy0) 235 | sx sy sx0 sy0))))) 236 | 237 | 238 | (define (finish-pin l p lw col alpha under?) 239 | (let* ([l (if lw 240 | (linewidth lw l) 241 | l)] 242 | [l (if col 243 | (colorize l col) 244 | l)] 245 | [l (if (= alpha 1.0) 246 | l 247 | (cellophane l alpha))]) 248 | (if under? 249 | (cc-superimpose l p) 250 | (cc-superimpose p l)))) 251 | 252 | (define fish 253 | (let ([standard-fish 254 | (lambda (w h 255 | #:direction [direction 'left] 256 | #:color [color "blue"] 257 | #:eye-color [eye-color "black"] 258 | #:open-mouth [open-mouth #f]) 259 | (standard-fish w h direction color eye-color open-mouth))]) 260 | standard-fish)) 261 | 262 | (define (pict->bitmap p [smoothing 'aligned] 263 | #:make-bitmap [make-bitmap make-bitmap]) 264 | (define w (pict-width p)) 265 | (define h (pict-height p)) 266 | (define bm (make-bitmap (max 1 (inexact->exact (ceiling w))) 267 | (max 1 (inexact->exact (ceiling h))))) 268 | (unless (send bm ok?) 269 | (error 'pict->bitmap 270 | (string-append "bitmap creation failed\n" 271 | " possible reason: out of memory\n" 272 | " pict width: ~a\n" 273 | " pict height: ~a") 274 | w 275 | h)) 276 | (define dc (make-object bitmap-dc% bm)) 277 | (send dc set-smoothing smoothing) 278 | (draw-pict p dc 0 0) 279 | bm) 280 | 281 | (define (pict->argb-pixels p [smoothing 'aligned]) 282 | (define bm (pict->bitmap p smoothing)) 283 | (define w (send bm get-width)) 284 | (define h (send bm get-height)) 285 | (define bytes (make-bytes (* w h 4))) 286 | (send bm get-argb-pixels 0 0 w h bytes) 287 | bytes) 288 | 289 | (define (argb-pixels->pict b w) 290 | (define h (/ (bytes-length b) w 4)) 291 | (define bm (make-bitmap w (/ (bytes-length b) w 4))) 292 | (send bm set-argb-pixels 0 0 w h b) 293 | (bitmap bm)) 294 | 295 | (define (freeze p 296 | #:inset [_inset 0] 297 | #:scale [extra-scale 1]) 298 | (define inset-list 299 | (cond 300 | [(real? _inset) (list _inset)] 301 | [else _inset])) 302 | (define p* (pict-convert p)) 303 | (define sized (scale (apply inset p* inset-list) extra-scale)) 304 | (define frozen (bitmap (pict->bitmap sized))) 305 | (define unsized (apply inset (scale frozen (/ extra-scale)) (map - inset-list))) 306 | (struct-copy pict p* [draw (pict-draw unsized)])) 307 | 308 | (provide hline vline 309 | frame 310 | pict-path? 311 | pin-line pin-arrow-line pin-arrows-line 312 | (contract-out 313 | [freeze (->* (pict-convertible?) 314 | (#:inset (or/c real? 315 | (list/c real?) 316 | (list/c real? real?) 317 | (list/c real? real? real? real?)) 318 | #:scale real?) 319 | pict?)]) 320 | 321 | 322 | dc-for-text-size 323 | convert-bounds-padding 324 | show-pict 325 | current-expected-text-scale 326 | dc 327 | linewidth 328 | linestyle 329 | 330 | draw-pict 331 | make-pict-drawer 332 | 333 | (contract-out 334 | [text (->* (string?) 335 | (text-style/c 336 | (and/c (between/c 1 1024) integer?) 337 | number?) 338 | pict?)]) 339 | 340 | text-style/c 341 | 342 | (struct-out pict) 343 | (struct-out child) 344 | 345 | black-and-white 346 | 347 | lt-find 348 | lc-find 349 | lb-find 350 | ltl-find 351 | lbl-find 352 | ct-find 353 | cc-find 354 | cb-find 355 | ctl-find 356 | cbl-find 357 | rt-find 358 | rc-find 359 | rb-find 360 | rtl-find 361 | rbl-find 362 | 363 | 364 | launder ; pict -> pict 365 | 366 | blank ; -> pict 367 | ;; w h -> pict 368 | ;; w h d -> pict 369 | 370 | clip-descent ; pict -> pict 371 | clip-ascent ; pict -> pict 372 | baseless ; pict -> pict 373 | inset ; pict i -> pict 374 | ; pict hi vi -> pict 375 | ; pict l t r b -> pict 376 | refocus ; pict pict -> pict 377 | panorama ; pict -> pict 378 | 379 | use-last ; pict pict -> pict 380 | use-last* ; pict pict -> pict 381 | 382 | hline ; w h -> pict 383 | vline ; w h -> pict 384 | 385 | frame ; pict -> pict 386 | 387 | 388 | 389 | ghost ; pict -> pict 390 | 391 | 392 | vl-append ; d pict ... -> pict ; d units between each picture 393 | vc-append 394 | vr-append 395 | ht-append 396 | hc-append 397 | hb-append 398 | htl-append ; align bottoms of ascents 399 | hbl-append ; align tops of descents (normal text alignment) 400 | 401 | lt-superimpose ; pict ... -> pict 402 | lb-superimpose 403 | lc-superimpose 404 | ltl-superimpose 405 | lbl-superimpose 406 | rt-superimpose 407 | rb-superimpose 408 | rc-superimpose 409 | rtl-superimpose 410 | rbl-superimpose 411 | ct-superimpose 412 | cb-superimpose 413 | cc-superimpose 414 | ctl-superimpose 415 | cbl-superimpose 416 | 417 | table ; ncols pict-list col-aligns row-aligns col-seps row-seps -> pict 418 | 419 | colorize ; pict color-string -> pict 420 | 421 | pin-over 422 | pin-under 423 | drop-below-ascent 424 | lift-above-baseline 425 | 426 | (except-out (all-from-out "utils.rkt") 427 | 428 | color-frame color-dash-frame 429 | round-frame color-round-frame 430 | 431 | cons-colorized-picture 432 | arrow-line 433 | arrows-line 434 | 435 | add-line 436 | add-arrow-line 437 | add-arrows-line 438 | 439 | explode-star 440 | 441 | cloud 442 | file-icon 443 | standard-fish 444 | jack-o-lantern 445 | angel-wing 446 | desktop-machine 447 | thermometer 448 | cat-silhouette 449 | standard-cat/transform 450 | happy-eyes 451 | 452 | find-pen find-brush) 453 | (contract-out 454 | [cloud (->* [real? real?] 455 | [(or/c string? (is-a?/c color%)) 456 | #:style (listof (or/c 'square 'nw 'ne 'sw 'se 'wide))] 457 | pict?)] 458 | [file-icon (->* [real? real? any/c] [any/c] pict?)] 459 | [rename fish standard-fish (->* [real? real?] 460 | [#:direction (or/c 'left 'right) 461 | #:color (or/c string? (is-a?/c color%)) 462 | #:eye-color (or/c string? (is-a?/c color%) #f) 463 | #:open-mouth (or/c boolean? (between/c 0 1))] 464 | pict?)] 465 | [jack-o-lantern (->* [real?] 466 | [(or/c string? (is-a?/c color%)) 467 | (or/c string? (is-a?/c color%)) 468 | (or/c string? (is-a?/c color%))] 469 | pict?)] 470 | [angel-wing (-> real? real? any/c pict?)] 471 | [desktop-machine (->* [real?] [(listof symbol?)] pict?)] 472 | [thermometer (->* [] 473 | [#:height-% (between/c 0 1) 474 | #:color-% (between/c 0 1) 475 | #:ticks exact-nonnegative-integer? 476 | #:start-color (or/c string? (is-a?/c color%)) 477 | #:end-color (or/c string? (is-a?/c color%)) 478 | #:top-circle-diameter (>/c 0) 479 | #:bottom-circle-diameter (>/c 0) 480 | #:stem-height (>/c 0) 481 | #:mercury-inset (>/c 0)] 482 | pict?)]) 483 | pict->bitmap 484 | pict->argb-pixels 485 | argb-pixels->pict) 486 | -------------------------------------------------------------------------------- /pict-lib/pict/private/naive-layered.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | "../main.rkt" 4 | "layout.rkt") 5 | (provide naive-layered) 6 | (define (naive-layered t 7 | #:x-spacing [given-x-spacing #f] 8 | #:y-spacing [given-y-spacing #f] 9 | #:transform [transform #f]) 10 | (define-values (x-space y-space) (compute-spacing t given-x-spacing given-y-spacing)) 11 | (define t-unique (uniquify-picts t)) 12 | (define root+tree-pair 13 | (let loop ([t t-unique]) 14 | (match t 15 | [#f (cons #f (blank))] 16 | [(tree-layout pict children) 17 | (cond 18 | [(andmap not children) 19 | (define this-root (ghost (launder pict))) 20 | (cons this-root (cc-superimpose this-root pict))] 21 | [else 22 | (define children-pairs 23 | (for/list ([child (in-list children)]) 24 | (match child 25 | [#f 26 | (define b (blank)) 27 | (cons b b)] 28 | [(tree-edge child color _ _) 29 | (loop child)]))) 30 | (define this-root (launder (ghost pict))) 31 | (define children-roots (map car children-pairs)) 32 | (define children-trees (map cdr children-pairs)) 33 | (define main 34 | (place-parent-over-children 35 | (cc-superimpose this-root pict) 36 | children-roots 37 | (vc-append 38 | y-space 39 | (ghost (launder pict)) 40 | (apply ht-append x-space children-trees)))) 41 | (cons this-root main)])]))) 42 | 43 | (transform-tree-pict t-unique (cdr root+tree-pair) transform)) 44 | 45 | (define (place-parent-over-children parent-root children-roots main) 46 | (define x-min (pict-width main)) 47 | (define x-max 0) 48 | (for ([child-root (in-list children-roots)]) 49 | (when child-root 50 | (define-values (c-min _1) (lc-find main child-root)) 51 | (define-values (c-max _2) (rc-find main child-root)) 52 | (set! x-min (min c-min x-min)) 53 | (set! x-max (max c-max x-max)))) 54 | (pin-over main 55 | (- (/ (+ x-min x-max) 2) (/ (pict-width parent-root) 2)) 56 | 0 57 | parent-root)) 58 | 59 | 60 | (module+ test 61 | (require rackunit) 62 | (check-pred pict? (naive-layered #f)) 63 | (check-pred pict? (naive-layered (_tree-layout))) 64 | (check-pred pict? (naive-layered (_tree-layout 65 | (_tree-layout) 66 | (_tree-layout)))) 67 | (check-pred pict? (naive-layered (_tree-layout 68 | (_tree-layout) 69 | (_tree-layout) 70 | (_tree-layout 71 | (_tree-layout) 72 | (_tree-layout) 73 | (_tree-layout 74 | (_tree-layout) 75 | (_tree-layout))))))) 76 | 77 | (module+ main 78 | (define (complete n) 79 | (cond 80 | [(= n 0) #f] 81 | [else 82 | (define t (complete (- n 1))) 83 | (apply _tree-layout (build-list n (λ (_) t)))])) 84 | 85 | (naive-layered (complete 4)) 86 | (define right-subtree-with-long-left-chain 87 | (_tree-layout 88 | (_tree-layout 89 | (_tree-layout #f #f) 90 | (_tree-layout 91 | (_tree-layout #f #f) 92 | #f)) 93 | (_tree-layout 94 | (_tree-layout 95 | (_tree-layout 96 | (_tree-layout 97 | (_tree-layout #f #f) 98 | #f) 99 | #f) 100 | #f) 101 | #f))) 102 | (naive-layered right-subtree-with-long-left-chain)) 103 | -------------------------------------------------------------------------------- /pict-lib/pict/private/play-pict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list 3 | racket/math 4 | "main.rkt" 5 | "convertible.rkt") 6 | 7 | (provide fade-pict 8 | slide-pict 9 | slide-pict/center 10 | fade-around-pict 11 | sequence-animations 12 | reverse-animations 13 | fast-start 14 | fast-end 15 | fast-edges 16 | fast-middle 17 | split-phase) 18 | 19 | (define (fail-gracefully t) 20 | (with-handlers ([exn:fail? (lambda (x) (values 0 0))]) 21 | (t))) 22 | 23 | (define single-pict (lambda (p) (if (list? p) (last p) p))) 24 | 25 | 26 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;; Animation combinators 28 | 29 | ;; "Morph" from one pict to another. Use `combine' to align 30 | ;; the picts relative to another. Only the bounding box is 31 | ;; actually morphed; the drawing part transitions by fading 32 | ;; the original `a' out and the new `b' in. The `n' argument 33 | ;; ranges from 0.0 (= `a') to 1.0 (= `b'). 34 | (define (fade-pict #:combine [combine cc-superimpose] n a b 35 | #:composite? [composite? #t]) 36 | ;; Combine ghosts of scaled pictures: 37 | (let ([orig (combine (cellophane a (- 1.0 n) #:composite? composite?) 38 | (cellophane b n #:composite? composite?))]) 39 | (cond 40 | [(zero? n) (refocus orig a)] 41 | [(= n 1.0) (refocus orig b)] 42 | [else 43 | (let-values ([(atx aty) (ltl-find orig a)] 44 | [(abx aby) (rbl-find orig a)] 45 | [(btx bty) (ltl-find orig b)] 46 | [(bbx bby) (rbl-find orig b)]) 47 | (let ([da (+ aty (* (- bty aty) n))] 48 | [dd (- (pict-height orig) 49 | (+ aby (* (- bby aby) n)))] 50 | [orig 51 | ;; Generate intermediate last-pict 52 | (let ([ap (or (pict-last a) a)] 53 | [bp (or (pict-last b) b)]) 54 | (let-values ([(al at) (lt-find orig (if (pair? ap) (cons a ap) (list a ap)))] 55 | [(bl bt) (lt-find orig (if (pair? bp) (cons b bp) (list b bp)))] 56 | [(ae) (single-pict ap)] 57 | [(be) (single-pict bp)]) 58 | (let ([ar (+ al (pict-width ae))] 59 | [ab (+ at (pict-height ae))] 60 | [br (+ bl (pict-width be))] 61 | [bb (+ bt (pict-height be))]) 62 | (let ([atl (+ at (pict-ascent ae))] 63 | [abl (- ab (pict-descent ae))] 64 | [btl (+ bt (pict-ascent be))] 65 | [bbl (- bb (pict-descent be))] 66 | [btw (lambda (a b) 67 | (+ a (* (- b a) n)))]) 68 | (let ([t (btw at bt)] 69 | [l (btw al bl)]) 70 | (let ([b (max t (btw ab bb))] 71 | [r (max l (btw ar br))]) 72 | (let ([tl (max t (min (btw atl btl) b))] 73 | [bl (max t (min (btw abl bbl) b))]) 74 | (let ([p (blank (- r l) (- b t) 75 | (- tl t) (- b bl))]) 76 | (let ([orig+p (pin-over orig l t p)]) 77 | (use-last orig+p p))))))))))]) 78 | (let ([p (make-pict (pict-draw orig) 79 | (pict-width orig) 80 | (pict-height orig) 81 | da 82 | dd 83 | (list (make-child orig 0 0 1 1 0 0)) 84 | #f 85 | (pict-last orig))]) 86 | (let ([left (+ atx (* (- btx atx) n))] 87 | [right (+ abx (* (- bbx abx) n))]) 88 | (let ([hp (inset p 89 | (- left) 90 | 0 91 | (- right (pict-width p)) 92 | 0)]) 93 | (let-values ([(atx aty) (lt-find hp a)] 94 | [(abx aby) (lb-find hp a)] 95 | [(btx bty) (lt-find hp b)] 96 | [(bbx bby) (lb-find hp b)]) 97 | (let ([top (+ aty (* (- bty aty) n))] 98 | [bottom (+ aby (* (- bby aby) n))]) 99 | (inset hp 100 | 0 101 | (- top) 102 | 0 103 | (- bottom (pict-height hp))))))))))]))) 104 | 105 | ;; Pin `p' into `base', sliding from `p-from' to `p-to' 106 | ;; (which are picts within `base') as `n' goes from 0.0 to 1.0. 107 | ;; The `p-from' and `p-to' picts are typically ghosts of 108 | ;; `p' within `base', but they can be any picts within 109 | ;; `base'. The top-left locations of `p-from' and `p-to' 110 | ;; determine the placement of the top-left of `p'. 111 | (define (slide-pict base p p-from p-to n) 112 | (let-values ([(x1 y1) (fail-gracefully (lambda () (lt-find base p-from)))] 113 | [(x2 y2) (fail-gracefully (lambda () (lt-find base p-to)))]) 114 | (pin-over base 115 | (+ x1 (* (- x2 x1) n)) 116 | (+ y1 (* (- y2 y1) n)) 117 | p))) 118 | 119 | (define (slide-pict/center base p p-from p-to n) 120 | (let-values ([(x1 y1) (fail-gracefully (lambda () (cc-find base p-from)))] 121 | [(x2 y2) (fail-gracefully (lambda () (cc-find base p-to)))]) 122 | (pin-over base 123 | (- (+ x1 (* (- x2 x1) n)) (/ (pict-width p) 2)) 124 | (- (+ y1 (* (- y2 y1) n)) (/ (pict-height p) 2)) 125 | p))) 126 | 127 | (define (fade-around-pict n base evolved 128 | #:composite? [composite? #t]) 129 | (define tg1 (launder (ghost base))) 130 | (define tg2 (launder (ghost base))) 131 | (slide-pict 132 | (fade-pict n 133 | tg1 134 | (evolved tg2) 135 | #:composite? composite?) 136 | base 137 | tg1 138 | tg2 139 | n)) 140 | 141 | ;; Concatenate a sequence of animations 142 | (define (sequence-animations . l) 143 | (let ([len (length l)]) 144 | (lambda (n) 145 | (cond 146 | [(zero? n) 147 | ((car l) 0.0)] 148 | [(= n 1.0) 149 | ((list-ref l (sub1 len)) n)] 150 | [else 151 | (let ([pos (inexact->exact (floor (* n len)))]) 152 | ((list-ref l pos) (* len (- n (* pos (/ len))))))])))) 153 | 154 | ;; Reverse a sequence of animations 155 | (define (reverse-animations . l) 156 | (let ([s (apply sequence-animations l)]) 157 | (lambda (n) 158 | (s (- 1 n))))) 159 | 160 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | 162 | ;; [0,1] -> [0,1] functions 163 | 164 | (define (fast-start n) 165 | (- 1 (* (- 1 n) (- 1 n)))) 166 | 167 | (define (fast-end n) 168 | (* n n)) 169 | 170 | (define (fast-edges n) 171 | (if (n . < . 0.5) 172 | (- 0.5 (fast-middle (- 0.5 n))) 173 | (+ 0.5 (fast-middle (- n 0.5))))) 174 | 175 | (define (fast-middle n) 176 | (- 0.5 (/ (cos (* n pi)) 2))) 177 | 178 | (define (split-phase opt-n) 179 | (values (* 2 (min opt-n 0.5)) 180 | (* 2 (- (max opt-n 0.5) 0.5)))) 181 | 182 | -------------------------------------------------------------------------------- /pict-lib/pict/private/tidier.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../main.rkt" 3 | racket/match 4 | "layout.rkt") 5 | 6 | (provide binary-tidier) 7 | 8 | #| 9 | 10 | Tidier Drawing of Trees 11 | Edward M. Reingold and John S. Tilford 12 | IEEE Transactions on Software Engineering, 13 | Vol 7, #2, March 1981 14 | 15 | |# 16 | 17 | (define (binary-tidier t 18 | #:x-spacing [given-x-spacing #f] 19 | #:y-spacing [given-y-spacing #f] 20 | #:transform [transform #f]) 21 | (cond 22 | [t 23 | (define-values (x-spacing y-spacing) (compute-spacing t given-x-spacing given-y-spacing)) 24 | (define t-unique (uniquify-picts t)) 25 | (unless given-y-spacing (set! y-spacing (* y-spacing 1.5))) 26 | (define minsep 2) 27 | (define xc (tidier-x-coordinates t-unique minsep)) 28 | (define x-max (let loop ([xc xc]) 29 | (match xc 30 | [#f 0] 31 | [(x-node x left-xc right-xc) 32 | (max x (loop left-xc) (loop right-xc))]))) 33 | (define y-max (let loop ([xc xc]) 34 | (match xc 35 | [#f 0] 36 | [(x-node x left-xc right-xc) 37 | (+ 1 (max (loop left-xc) (loop right-xc)))]))) 38 | 39 | (define main (blank (* x-spacing (+ x-max 1)) 40 | (* y-spacing y-max))) 41 | (let loop ([t t-unique] 42 | [xc xc] 43 | [y 0]) 44 | (match* (t xc) 45 | [(#f #f) (void)] 46 | [((tree-layout pict (list left-t right-t)) 47 | (x-node x left-xc right-xc)) 48 | (define node-pict pict) 49 | (set! main (pin-over main 50 | (* x x-spacing) 51 | (* y y-spacing) 52 | node-pict)) 53 | (match left-t 54 | [#f (void)] 55 | [(tree-edge left-t left-color left-width left-style) 56 | (loop left-t left-xc (+ y 1))]) 57 | (match right-t 58 | [#f (void)] 59 | [(tree-edge right-t right-color right-width right-style) 60 | (loop right-t right-xc (+ y 1))]) 61 | node-pict])) 62 | 63 | (transform-tree-pict t-unique main transform)] 64 | [else (blank)])) 65 | 66 | ;; x-coordinate-tree : (or/c #f x-node?) 67 | 68 | ;; x : exact-positive-integer? 69 | ;; l : x-coordinate-tree? 70 | ;; r : x-coordinate-tree? 71 | (struct x-node (x l r) #:transparent) 72 | 73 | (define (tidier-x-coordinates t minsep) 74 | (cond 75 | [(not t) #f] 76 | [else 77 | (define t-link 78 | (let loop ([t t]) 79 | (match t 80 | [(tree-layout pict (list left right)) 81 | (link (and left (loop (tree-edge-child left))) 82 | (and right (loop (tree-edge-child right))) 83 | #f #f #f #f)]))) 84 | (setup t-link 0 (extreme #f #f #f) (extreme #f #f #f) minsep) 85 | (petrify t-link 0) 86 | 87 | (define smallest 88 | (let loop ([t-link t-link]) 89 | (match t-link 90 | [#f #f] 91 | [(link llink rlink xcoord _ _ _) 92 | (min2/f xcoord (min2/f (loop llink) (loop rlink)))]))) 93 | 94 | (let loop ([t-link t-link]) 95 | (match t-link 96 | [#f #f] 97 | [(link llink rlink xcoord ycoord offset thread) 98 | (x-node (- xcoord smallest) (loop llink) (loop rlink))]))])) 99 | 100 | (define (min2/f a b) 101 | (cond 102 | [(not a) b] 103 | [(not b) a] 104 | [else (min a b)])) 105 | 106 | (struct extreme (addr off lev) #:mutable) 107 | (struct link (llink rlink xcoord ycoord offset thread) #:mutable) 108 | 109 | (define (setup t level rmost lmost minsep) 110 | (cond 111 | [(not t) 112 | (set-extreme-lev! lmost -1) 113 | (set-extreme-lev! rmost -1)] 114 | [else 115 | (define lr (extreme #f #f #f)) 116 | (define ll (extreme #f #f #f)) 117 | (define rr (extreme #f #f #f)) 118 | (define rl (extreme #f #f #f)) 119 | (set-link-ycoord! t level) 120 | (define l (link-llink t)) 121 | (define r (link-rlink t)) 122 | (setup l (+ level 1) lr ll minsep) 123 | (setup r (+ level 1) rr rl minsep) 124 | (cond 125 | [(and (not l) (not r)) 126 | (set-extreme-addr! rmost t) 127 | (set-extreme-addr! lmost t) 128 | (set-extreme-lev! rmost level) 129 | (set-extreme-lev! lmost level) 130 | (set-extreme-off! rmost 0) 131 | (set-extreme-off! lmost 0) 132 | (set-link-offset! t 0)] 133 | [else 134 | (define cursep minsep) 135 | (define rootsep minsep) 136 | (define loffsum 0) 137 | (define roffsum 0) 138 | 139 | (let loop () 140 | (when (and l r) 141 | (when (< cursep minsep) 142 | (set! rootsep (+ rootsep (- minsep cursep))) 143 | (set! cursep minsep)) 144 | (cond 145 | [(link-rlink l) 146 | (set! loffsum (+ loffsum (link-offset l))) 147 | (set! cursep (- cursep (link-offset l))) 148 | (set! l (link-rlink l))] 149 | [else 150 | (set! loffsum (- loffsum (link-offset l))) 151 | (set! cursep (+ cursep (link-offset l))) 152 | (set! l (link-llink l))]) 153 | (cond 154 | [(link-llink r) 155 | (set! roffsum (- roffsum (link-offset r))) 156 | (set! cursep (- cursep (link-offset r))) 157 | (set! r (link-llink r))] 158 | [else 159 | (set! roffsum (+ roffsum (link-offset r))) 160 | (set! cursep (+ cursep (link-offset r))) 161 | (set! r (link-rlink r))]) 162 | (loop))) 163 | 164 | (set-link-offset! t (quotient (+ rootsep 1) 2)) 165 | (set! loffsum (- loffsum (link-offset t))) 166 | (set! roffsum (+ roffsum (link-offset t))) 167 | 168 | (cond 169 | [(or (> (extreme-lev rl) (extreme-lev ll)) (not (link-llink t))) 170 | (extreme-copy! lmost rl) 171 | (set-extreme-off! lmost (+ (extreme-off lmost) (link-offset t)))] 172 | [else 173 | (extreme-copy! lmost ll) 174 | (set-extreme-off! lmost (- (extreme-off lmost) (link-offset t)))]) 175 | (cond 176 | [(or (> (extreme-lev lr) (extreme-lev rr)) (not (link-rlink t))) 177 | (extreme-copy! rmost lr) 178 | (set-extreme-off! rmost (- (extreme-off rmost) (link-offset t)))] 179 | [else 180 | (extreme-copy! rmost rr) 181 | (set-extreme-off! rmost (+ (extreme-off rmost) (link-offset t)))]) 182 | 183 | (cond 184 | [(and l (not (eq? l (link-llink t)))) 185 | (set-link-thread! (extreme-addr rr) #t) 186 | (set-link-offset! (extreme-addr rr) 187 | (abs (- (+ (extreme-off rr) (link-offset t)) loffsum))) 188 | (cond 189 | [(<= (- loffsum (link-offset t)) (extreme-off rr)) 190 | (set-link-llink! (extreme-addr rr) l)] 191 | [else 192 | (set-link-rlink! (extreme-addr rr) l)])] 193 | [(and r (not (eq? r (link-rlink t)))) 194 | (set-link-thread! (extreme-addr ll) #t) 195 | (set-link-offset! (extreme-addr ll) 196 | (abs (- (- (extreme-off ll) (link-offset t)) roffsum))) 197 | (cond 198 | [(>= (+ roffsum (link-offset t)) (extreme-off ll)) 199 | (set-link-rlink! (extreme-addr ll) r)] 200 | [else 201 | (set-link-llink! (extreme-addr ll) r)])])])])) 202 | 203 | (define (extreme-copy! dest src) 204 | (set-extreme-addr! dest (extreme-addr src)) 205 | (set-extreme-off! dest (extreme-off src)) 206 | (set-extreme-lev! dest (extreme-lev src))) 207 | 208 | (define (petrify t xpos) 209 | (when t 210 | (set-link-xcoord! t xpos) 211 | (when (link-thread t) 212 | (set-link-thread! t #f) 213 | (set-link-rlink! t #f) 214 | (set-link-llink! t #f)) 215 | (petrify (link-llink t) (- xpos (link-offset t))) 216 | (petrify (link-rlink t) (+ xpos (link-offset t))))) 217 | 218 | (module+ test 219 | (require rackunit) 220 | (check-equal? (tidier-x-coordinates #f 2) 221 | #f) 222 | (check-equal? (tidier-x-coordinates (_tree-layout #f #f) 2) 223 | (x-node 0 #f #f)) 224 | (check-equal? (tidier-x-coordinates (_tree-layout 225 | (_tree-layout 226 | #f #f) 227 | (_tree-layout 228 | #f #f)) 229 | 2) 230 | (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f))) 231 | 232 | (check-equal? (tidier-x-coordinates (_tree-layout 233 | #f 234 | (_tree-layout 235 | (_tree-layout #f #f) 236 | (_tree-layout #f #f))) 237 | 2) 238 | (x-node 0 #f (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f)))) 239 | (check-equal? (tidier-x-coordinates (_tree-layout 240 | (_tree-layout 241 | (_tree-layout #f #f) 242 | (_tree-layout #f #f)) 243 | #f) 244 | 2) 245 | (x-node 2 (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f)) #f)) 246 | 247 | 248 | ;; this is building up an example from 249 | ;; http://rp-www.cs.usyd.edu.au/~comp5048/Lect2-trees.pdf and from 250 | ;; http://sydney.edu.au/engineering/it/~shhong/comp5048-lec2.pdf 251 | ;; for the tidier algorithm 252 | (define triangle 253 | (_tree-layout 254 | (_tree-layout #f #f) 255 | (_tree-layout #f #f))) 256 | 257 | (define left-subtree 258 | (_tree-layout (_tree-layout #f triangle) 259 | #f)) 260 | 261 | (define right-subtree 262 | (_tree-layout 263 | triangle 264 | (_tree-layout #f #f))) 265 | 266 | (check-equal? (tidier-x-coordinates left-subtree 2) 267 | (x-node 1 (x-node 0 #f (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f))) #f)) 268 | 269 | (check-equal? (tidier-x-coordinates (_tree-layout left-subtree right-subtree) 2) 270 | (x-node 3 271 | (x-node 1 272 | (x-node 0 273 | #f 274 | (x-node 1 275 | (x-node 0 #f #f) 276 | (x-node 2 #f #f))) 277 | #f) 278 | (x-node 5 279 | (x-node 4 280 | (x-node 3 #f #f) 281 | (x-node 5 #f #f)) 282 | (x-node 6 #f #f)))) 283 | 284 | 285 | ;; this is a simplification of the tree in figure 2 from the tidier paper 286 | (define (build-left t) (_tree-layout (_tree-layout #f #f) t)) 287 | (define (build-right t) (_tree-layout t (_tree-layout #f #f))) 288 | (check-equal? (tidier-x-coordinates 289 | (_tree-layout 290 | #f 291 | (build-left 292 | (build-left 293 | (build-right 294 | (build-right 295 | triangle))))) 296 | 2) 297 | (x-node 298 | 0 299 | #f 300 | (x-node 301 | 1 302 | (x-node 0 #f #f) 303 | (x-node 304 | 2 305 | (x-node 1 #f #f) 306 | (x-node 307 | 3 308 | (x-node 309 | 2 310 | (x-node 311 | 1 312 | (x-node 0 #f #f) 313 | (x-node 2 #f #f)) 314 | (x-node 3 #f #f)) 315 | (x-node 4 #f #f)))))) 316 | 317 | 318 | (check-pred pict? (binary-tidier #f)) 319 | (check-pred pict? (binary-tidier (_tree-layout #f #f)))) 320 | 321 | 322 | (module+ main 323 | (define (full d) 324 | (cond 325 | [(zero? d) #f] 326 | [else (define s (full (- d 1))) 327 | (_tree-layout s s)])) 328 | (define triangle (full 1)) 329 | (define (build-left t) (_tree-layout (_tree-layout #f #f) t)) 330 | (define (build-right t) (_tree-layout t (_tree-layout #f #f))) 331 | (define (n-of n f t) (if (zero? n) t (n-of (- n 1) f (f t)))) 332 | ;; this is the example from the paper 333 | (binary-tidier 334 | (_tree-layout 335 | (n-of 3 build-right (n-of 3 build-left triangle)) 336 | (n-of 3 build-left (n-of 3 build-right triangle)))) 337 | (binary-tidier (full 3))) 338 | -------------------------------------------------------------------------------- /pict-lib/pict/private/transform.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "pict.rkt" racket/match racket/list) 3 | (provide get-child-transformation) 4 | 5 | ;; get a matrix suitable for the transform method of 6 | ;; dc<%> which shifts one into the drawing coordinates 7 | ;; of the pict given by the pict path pp. 8 | (define (get-child-transformation p pp) 9 | (convert-affine-form 10 | (uninvert-coordinartes 11 | p (last (flatten pp)) 12 | (cond 13 | [(pict-convertible? pp) 14 | (if (pict-path-element=? p pp) 15 | (vector 1 0 0 16 | 0 1 0 17 | 0 0 1) 18 | (get-child-transformation/search 19 | p (list pp)))] 20 | [else 21 | (get-child-transformation/search 22 | p pp)])))) 23 | 24 | ;; Transformations here are represented by 3x3 25 | ;; matricies to allow for easy composition. This 26 | ;; converts back to the 2x3 form used by dc<%> 27 | (define (convert-affine-form v) 28 | (match-define (vector a b e c d f _ _ _) v) 29 | (vector 30 | a b 31 | c d 32 | e f)) 33 | 34 | (define (get-child-transformation/search pict list) 35 | (cond [(empty? list) 36 | (vector 1 0 0 37 | 0 1 0 38 | 0 0 1)] 39 | [else 40 | (define t 41 | (find-next-target pict (first list))) 42 | (transformation-compose 43 | (get-child-transformation/search (first list) (rest list)) 44 | t)])) 45 | 46 | 47 | (define (find-next-target p target) 48 | (let loop ([p p] 49 | [children (pict-children p)] 50 | [foundk (lambda (t) t)] 51 | [failk (lambda () (error 'explain-child "could not find child pict"))]) 52 | (match children 53 | [(list) (failk)] 54 | [(cons r h) 55 | #:when (pict-path-element=? (child-pict r) target) 56 | (foundk (child->transformation p r))] 57 | [(cons r h) 58 | (loop 59 | (child-pict r) 60 | (pict-children (child-pict r)) 61 | (lambda (t) (foundk (transformation-compose (child->transformation p r) t))) 62 | (lambda () (loop p h foundk failk)))]))) 63 | 64 | (define (transformation-compose1 t1 t2) 65 | (define w 3) 66 | (for*/vector #:length 9 #:fill 0 67 | ([i (in-range w)] 68 | [j (in-range w)]) 69 | (for/sum ([k (in-range w)]) 70 | (* (vector-ref t1 (+ (* i w) k)) 71 | (vector-ref t2 (+ (* w k) j)))))) 72 | 73 | (define (transformation-compose t1 . t2) 74 | (match t2 75 | [(list) t1] 76 | [(cons r h) 77 | (apply 78 | transformation-compose 79 | (transformation-compose1 t1 r) 80 | h)])) 81 | 82 | (define (transformation-apply t v) 83 | (define w 3) 84 | (for/vector #:length 3 #:fill 0 85 | ([i (in-range w)]) 86 | (for/sum ([j (in-range w)]) 87 | (* (vector-ref v j) (vector-ref t (+ (* i w) j)))))) 88 | 89 | ;; switch from the inverted coordinates used by 90 | ;; pict-child to normal drawing coordinates. 91 | (define (uninvert-coordinartes p c t) 92 | (match-define (vector sx sxy dx syx sy dy _ _ _) t) 93 | (match-define 94 | (vector _ _ ndx _ _ ndy _ _ _) 95 | (transformation-compose 96 | (vector 97 | 1 0 0 98 | 0 -1 (pict-height p) 99 | 0 0 1) 100 | t 101 | (vector 102 | 1 0 0 103 | 0 -1 (pict-height c) 104 | 0 0 1))) 105 | (vector 106 | sx sxy ndx 107 | syx sy ndy 108 | 0 0 1)) 109 | 110 | (define (child->transformation parent c) 111 | (vector 112 | (child-sx c) (child-sxy c) (child-dx c) 113 | (child-syx c) (child-sy c) (child-dy c) 114 | 0 0 1)) 115 | -------------------------------------------------------------------------------- /pict-lib/pict/shadow.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base) 3 | racket/unsafe/ops 4 | racket/contract/base 5 | racket/class 6 | racket/draw 7 | racket/future 8 | racket/math 9 | pict 10 | "convert.rkt") 11 | 12 | (define nneg-real/c (and/c real? (not/c negative?))) 13 | 14 | (provide/contract 15 | [blur 16 | (->* (pict-convertible? nneg-real/c) 17 | (nneg-real/c 18 | #:pre-inset? any/c) 19 | pict?)] 20 | [shadow 21 | (->* (pict-convertible? nneg-real/c) 22 | (real? real? 23 | #:color (or/c #f string? (is-a?/c color%)) 24 | #:shadow-color (or/c #f string? (is-a?/c color%))) 25 | pict?)] 26 | [shadow-frame 27 | (->* () 28 | (#:background-color (or/c string? (is-a?/c color%)) 29 | #:frame-color (or/c string? (is-a?/c color%)) 30 | #:frame-line-width (or/c real? #f 'no-frame) 31 | #:shadow-side-length real? 32 | #:shadow-top-y-offset real? 33 | #:shadow-bottom-y-offset real? 34 | #:shadow-descent (and/c real? (not/c negative?)) 35 | #:shadow-alpha-factor real? 36 | #:blur (and/c real? (not/c negative?)) 37 | #:margin real? 38 | #:sep real?) 39 | #:rest (listof pict-convertible?) 40 | pict?)]) 41 | 42 | ;; ---- 43 | 44 | (define (blur p hbr [vbr hbr] 45 | #:pre-inset? [pre-inset? #t]) 46 | (let* ([p* 47 | (cond [pre-inset? (inset p hbr vbr)] 48 | [else p])] 49 | [blurred (*blur p* hbr vbr)]) 50 | (cond [pre-inset? 51 | (struct-copy pict (inset blurred (- hbr) (- vbr)) 52 | [ascent (pict-ascent p)] 53 | [descent (pict-descent p)])] 54 | [else blurred]))) 55 | 56 | (define (shadow p br [dx 0] [dy dx] 57 | #:color [c #f] 58 | #:shadow-color [shc #f] 59 | #:auto-inset? [auto-inset? #f]) 60 | ;; FIXME: should auto-inset also use dx, dy? 61 | (define (colorize* p c) 62 | (if c (colorize p c) p)) 63 | (let ([result 64 | (pin-under (colorize* p c) 65 | dx dy 66 | (blur (colorize* p shc) br))]) 67 | (cond [auto-inset? (inset result br)] 68 | [else result]))) 69 | 70 | ;; ---- 71 | 72 | (define MAX-RADIUS (expt 2 10)) 73 | (define MAX-WEIGHT (expt 2 5)) 74 | (define BOX-ITERATIONS 3) 75 | 76 | (define (*blur p hbr vbr) 77 | (let* ([w (pict-width p)] 78 | [h (pict-height p)] 79 | [drawer (make-pict-drawer p)]) 80 | (dc (lambda (dc x y) 81 | (let-values ([(sx sy) (send dc get-scale)]) 82 | (let* ([pxw (ceil/e (* w sx))] 83 | [pxh (ceil/e (* h sy))] 84 | [hbr* (min (ceil/e (* hbr sx)) pxw MAX-RADIUS)] 85 | [vbr* (min (ceil/e (* vbr sy)) pxh MAX-RADIUS)] 86 | [bmp (make-object bitmap% pxw pxh #f #t)] 87 | [bdc (new bitmap-dc% (bitmap bmp))]) 88 | (send bdc set-scale sx sy) 89 | (send bdc set-font (send dc get-font)) 90 | (send bdc set-pen (send dc get-pen)) 91 | (send bdc set-brush (send dc get-brush)) 92 | (send bdc set-text-foreground (send dc get-text-foreground)) 93 | (when (or (zero? hbr*) (zero? vbr*)) 94 | ;; probably not worth smoothing when about to blur 95 | ;; except when blurring by zero 96 | (send bdc set-smoothing (send dc get-smoothing))) 97 | (drawer bdc 0 0) 98 | (blur! bmp hbr* vbr*) 99 | (send dc set-scale 1.0 1.0) 100 | (send dc draw-bitmap bmp (* x sx) (* y sy)) 101 | (send dc set-scale sx sy)))) 102 | w h))) 103 | 104 | (define (blur! bmp hbr vbr) 105 | (let* ([w (send bmp get-width)] 106 | [h (send bmp get-height)] 107 | [pix (make-bytes (* w h 4))] 108 | [out (make-bytes (* w h 4))]) 109 | (send bmp get-argb-pixels 0 0 w h pix #f #t) 110 | (let ([hbr (ceil/e (/ hbr BOX-ITERATIONS))] 111 | [vbr (ceil/e (/ vbr BOX-ITERATIONS))]) 112 | (box-h pix out hbr w h BOX-ITERATIONS) 113 | (let-values ([(pix* out*) 114 | (cond [(even? BOX-ITERATIONS) (values out pix)] 115 | [else (values pix out)])]) 116 | (box-v pix* out* vbr w h BOX-ITERATIONS))) 117 | (send bmp set-argb-pixels 0 0 w h pix #f #t) 118 | (void))) 119 | 120 | ;; ---- 121 | 122 | ;; iterated box blur 123 | 124 | (define-syntax-rule (box-line* radius start end get-val set-val) 125 | (let ([non-zero-alpha? 126 | (for/or ([outi (in-range start end)]) 127 | (positive? (get-val outi 0)))]) 128 | (cond [non-zero-alpha? 129 | (for/fold ([wA 0] [wR 0] [wG 0] [wB 0] [wW 0]) 130 | ([leadI (in-range start (+ end radius))]) 131 | ;; (eprintf "leadI = ~s, wA = ~s, wW = ~s\n" leadI wA wW) 132 | (let*-values ([(outI) (unsafe-fx- leadI radius)] 133 | [(tailI) (unsafe-fx- leadI (unsafe-fx+ radius radius))] 134 | [(addA addR addG addB addW) 135 | (cond [(unsafe-fx< leadI end) 136 | (values (get-val leadI 0) 137 | (get-val leadI 1) 138 | (get-val leadI 2) 139 | (get-val leadI 3) 140 | 1)] 141 | [else (values 0 0 0 0 0)])] 142 | [(dropA dropR dropG dropB dropW) 143 | (cond [(unsafe-fx>= tailI start) 144 | (values (get-val tailI 0) 145 | (get-val tailI 1) 146 | (get-val tailI 2) 147 | (get-val tailI 3) 148 | 1)] 149 | [else (values 0 0 0 0 0)])] 150 | [(nwA) (unsafe-fx+ wA addA)] 151 | [(nwR) (unsafe-fx+ wR addR)] 152 | [(nwG) (unsafe-fx+ wG addG)] 153 | [(nwB) (unsafe-fx+ wB addB)] 154 | [(nwW) (unsafe-fx+ wW addW)]) 155 | (when (and (unsafe-fx>= outI start) (unsafe-fx< outI end)) 156 | ;; (eprintf "setting ~a = (~a,...)\n" outI (quotient nwA nwW)) 157 | (set-val outI 0 (unsafe-fxquotient nwA nwW)) 158 | (set-val outI 1 (unsafe-fxquotient nwR nwW)) 159 | (set-val outI 2 (unsafe-fxquotient nwG nwW)) 160 | (set-val outI 3 (unsafe-fxquotient nwB nwW))) 161 | (values (unsafe-fx- nwA dropA) 162 | (unsafe-fx- nwR dropR) 163 | (unsafe-fx- nwG dropG) 164 | (unsafe-fx- nwB dropB) 165 | (unsafe-fx- nwW dropW))))] 166 | [else 167 | (for ([outI (in-range start end)]) 168 | (set-val outI 0 0) 169 | (set-val outI 1 0) 170 | (set-val outI 2 0) 171 | (set-val outI 3 0))]))) 172 | 173 | (define (box-h in out radius w h iterations) 174 | (for/async ([row (in-range h)]) 175 | (for ([iter (in-range iterations)]) 176 | (let ([start (* row w)] 177 | [end (* (add1 row) w)] 178 | [in (if (even? iter) in out)] 179 | [out (if (even? iter) out in)]) 180 | (define-syntax-rule (get-val i offset) 181 | (bytes-ref in (unsafe-fx+ offset (unsafe-fx* 4 i)))) 182 | (define-syntax-rule (set-val i offset v) 183 | (bytes-set! out (unsafe-fx+ offset (unsafe-fx* 4 i)) v)) 184 | (box-line* radius start end get-val set-val))))) 185 | 186 | (define (box-v in out radius w h iterations) 187 | (for/async ([col (in-range w)]) 188 | (for ([iter (in-range iterations)]) 189 | (let ([start 0] 190 | [end h] 191 | [in (if (even? iter) in out)] 192 | [out (if (even? iter) out in)]) 193 | (define-syntax-rule (get-val i offset) 194 | (bytes-ref in (unsafe-fx+ (unsafe-fx* 4 (unsafe-fx+ (unsafe-fx* w i) col)) offset))) 195 | (define-syntax-rule (set-val i offset v) 196 | (bytes-set! out (unsafe-fx+ (unsafe-fx* 4 (unsafe-fx+ (unsafe-fx* w i) col)) offset) v)) 197 | (box-line* radius start end get-val set-val))))) 198 | 199 | (define (ceil/e x) (inexact->exact (ceiling x))) 200 | 201 | ;; ---- 202 | 203 | ;; used for benchmarking to force effectively lazy dc pict constructor 204 | (define (p->bmp p) 205 | (let* ([bmp (make-object bitmap% (ceil/e (pict-width p)) (ceil/e (pict-height p)))] 206 | [bdc (new bitmap-dc% (bitmap bmp))]) 207 | (draw-pict p bdc 0 0) 208 | bmp)) 209 | 210 | ;; ============================================================ 211 | ;; Boxes with Keynote-style shadows 212 | 213 | (define (shadow-frame #:background-color [background-color "white"] 214 | #:frame-color [frame-color "gray"] 215 | #:frame-line-width [frame-line-width 0] 216 | #:shadow-side-length [s-side-len 4.0] 217 | #:shadow-top-y-offset [s-top-dy 10.0] 218 | #:shadow-bottom-y-offset [s-bot-dy 4.0] 219 | #:shadow-descent [s-desc 40.0] 220 | #:shadow-alpha-factor [s-alpha 3/4] 221 | #:blur [blur-radius 20] 222 | #:margin [margin-len 20] 223 | #:sep [sep 5] 224 | . picts) 225 | ;; shadow-alpha-factor: 226 | ;; - default 3/4 good for a heavy shadow, if blur is enabled 227 | ;; - about 1/4 or 1/5 good for light shadow w/o blur 228 | (let* ([pict (apply vl-append sep picts)] 229 | [pict (inset pict margin-len)] 230 | [w (pict-width pict)] 231 | [h (pict-height pict)] 232 | [without-frame (colorize (filled-rectangle w h #:draw-border? #f) background-color)] 233 | [main-box 234 | (if (equal? frame-line-width 'no-frame) 235 | without-frame 236 | (frame without-frame 237 | #:color frame-color #:line-width frame-line-width))] 238 | [w* (+ w s-side-len s-side-len)] 239 | [shadow (arch w* w* (+ h (- s-bot-dy s-top-dy)) s-desc)] 240 | [shadow (brush/linear-gradient 241 | shadow 242 | (mk-shadow-grad-stops w* s-side-len s-alpha))] 243 | [shadow 244 | (cond [(zero? blur-radius) shadow] 245 | [#t ;; use-smart-blur? 246 | (smart-blur shadow w h blur-radius 247 | s-side-len s-top-dy s-bot-dy s-desc)] 248 | [else (blur shadow blur-radius)])] 249 | [result 250 | (pin-under (cc-superimpose main-box pict) 251 | (- s-side-len) s-top-dy 252 | shadow)] 253 | [result 254 | (inset result s-side-len 0 255 | s-side-len (+ s-desc (- s-top-dy s-bot-dy)))]) 256 | (inset result blur-radius))) 257 | 258 | ;; smart-blur: blur only visible edges 259 | (define (smart-blur shadow w0 h0 blur-radius s-side-len s-top-dy s-bot-dy s-desc) 260 | (define (blur-part p x1 y1 x2 y2 lpad tpad rpad bpad) 261 | (let* ([p (viewport p (- x1 lpad) (- y1 tpad) (+ x2 rpad) (+ y2 bpad))] 262 | [p (blur p blur-radius #:pre-inset? #f)] 263 | [p (clip (inset p (- lpad) (- tpad) (- rpad) (- bpad)))]) 264 | p)) 265 | (define (viewport p x1 y1 x2 y2) 266 | (clip (pin-over (blank (- x2 x1) (- y2 y1)) (- x1) (- y1) p))) 267 | (let* ([shadow* (inset shadow blur-radius)] 268 | [w* (pict-width shadow*)] 269 | [h* (pict-height shadow*)] 270 | [BR blur-radius] 271 | 272 | [yTopBot (+ BR (- s-top-dy))] 273 | [yMidBot (+ yTopBot h0)] 274 | [xLeftRight (+ BR s-side-len)] 275 | 276 | [top-part 277 | (blur-part shadow* 278 | 0 0 w* yTopBot 279 | 0 0 0 BR)] 280 | [left-part 281 | (blur-part shadow* 282 | 0 yTopBot xLeftRight yMidBot 283 | 0 BR BR BR)] 284 | [right-part 285 | (blur-part shadow* 286 | (- w* xLeftRight) yTopBot w* yMidBot 287 | BR BR 0 BR)] 288 | [bot-part 289 | (blur-part shadow* 290 | 0 yMidBot w* h* 291 | 0 BR 0 0)] 292 | 293 | [result (blank w* h*)] 294 | [result (pin-over result 0 0 top-part)] 295 | [result (pin-over result 0 yTopBot left-part)] 296 | [result (pin-over result (- w* xLeftRight) yTopBot right-part)] 297 | [result (pin-over result 0 yMidBot bot-part)]) 298 | (inset result (- blur-radius)))) 299 | 300 | (define (mk-shadow-grad-stops w s-side-len s-alpha) 301 | (let* ([epsA (/ s-side-len w)] 302 | [epsZ (- 1.0 epsA)] 303 | [alphaA (max 0 (min 1 (* s-alpha 0.16)))] 304 | [alphaB (max 0 (min 1 (* s-alpha 0.25)))] 305 | [alphaC (max 0 (min 1 (* s-alpha 1.00)))]) 306 | (list (list 0.00 (make-object color% 0 0 0 alphaA)) 307 | (list epsA (make-object color% 0 0 0 alphaB)) 308 | (list 0.25 (make-object color% 0 0 0 alphaC)) 309 | (list 0.75 (make-object color% 0 0 0 alphaC)) 310 | (list epsZ (make-object color% 0 0 0 alphaB)) 311 | (list 1.00 (make-object color% 0 0 0 alphaA))))) 312 | 313 | ;; ---- 314 | 315 | (define (arch outer-w inner-w solid-h leg-h) 316 | (dc (lambda (dc X Y) 317 | (draw-arch dc X Y outer-w inner-w solid-h leg-h)) 318 | outer-w (+ solid-h leg-h))) 319 | 320 | (define (draw-arch dc X Y outer-w inner-w solid-h leg-h) 321 | (cond [(zero? leg-h) 322 | (send dc draw-rectangle X Y outer-w solid-h)] 323 | [else 324 | (let ([path (new dc-path%)]) 325 | (dc-path-arch path X Y outer-w inner-w solid-h leg-h) 326 | (send dc draw-path path))])) 327 | 328 | ;; closes path's current sub-path and draws the outline of an arch, clockwise 329 | ;; requires leg-h != 0 330 | (define (dc-path-arch path X Y outer-w inner-w solid-h leg-h) 331 | (let* ([xA X] 332 | [xB (+ X outer-w)] 333 | [xMid (/ (+ xA xB) 2.0)] 334 | [ySolidEnd (+ Y solid-h)] 335 | [yEnd (+ Y solid-h leg-h)] 336 | [hdx (/ (- outer-w inner-w) 2.0)] 337 | [xAi (+ xA hdx)] 338 | [xBi (- xB hdx)] 339 | [radius (+ (/ leg-h 2) (/ (sqr inner-w) 8 leg-h))] 340 | [diameter (+ radius radius)] 341 | [theta (asin (/ (- radius leg-h) radius))]) 342 | (send* path 343 | (move-to xA Y) 344 | (line-to xB Y) 345 | (line-to xB ySolidEnd) 346 | (line-to xB yEnd) 347 | (line-to xBi yEnd) 348 | (arc (- xMid radius) ySolidEnd 349 | diameter diameter 350 | theta 351 | (- pi theta)) 352 | ;; ends at *roughly* xAi yEnd 353 | (line-to xAi yEnd) 354 | (line-to xA yEnd) 355 | (line-to xA ySolidEnd) 356 | (line-to xA Y)))) 357 | 358 | ;; ==== 359 | 360 | (define no-pen (make-object pen% "BLACK" 1 'transparent)) 361 | 362 | (define (brush/linear-gradient p stops) 363 | (let* ([drawer (make-pict-drawer p)] 364 | [w (pict-width p)] 365 | [h (pict-height p)]) 366 | (dc (lambda (dc X Y) 367 | (let* ([grad 368 | (new linear-gradient% 369 | ;; Apparently gradient handles scaling, 370 | ;; rotation, etc automatically (???) 371 | (x0 X) (y0 Y) (x1 (+ X w)) (y1 Y) 372 | (stops stops))] 373 | [new-brush (new brush% (gradient grad))] 374 | [old-pen (send dc get-pen)] 375 | [old-brush (send dc get-brush)]) 376 | (send* dc 377 | (set-pen no-pen) 378 | (set-brush new-brush)) 379 | (drawer dc X Y) 380 | (send* dc 381 | (set-pen old-pen) 382 | (set-brush old-brush)))) 383 | w h))) 384 | 385 | #| 386 | ;; FIXME: 387 | ;; (arch ....) by itself draws outline 388 | ;; (colorize (arch ....) "red") draws filled (no outline, or same color) 389 | 390 | Problem: picts, colorize, etc not designed to inherit brush. See 391 | texpict/utils: filled-rectangle, eg, makes new brush from pen color; 392 | rectangle makes new transparent brush. 393 | 394 | |# 395 | 396 | ;; ---- 397 | 398 | ;; provided by unstable/gui/pict, for backwards compatibility 399 | (module+ unstable 400 | (provide/contract 401 | [blur-bitmap! 402 | (->* ((is-a?/c bitmap%) exact-nonnegative-integer?) 403 | (exact-nonnegative-integer?) 404 | void?)] 405 | [arch 406 | (-> real? real? real? real? 407 | pict?)]) 408 | (define (blur-bitmap! bmp hbr [vbr hbr]) 409 | (blur! bmp hbr vbr))) 410 | -------------------------------------------------------------------------------- /pict-lib/pict/tree-layout.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract 3 | racket/class 4 | racket/draw 5 | "main.rkt" 6 | "convert.rkt" 7 | "private/tidier.rkt" 8 | "private/layout.rkt" 9 | "private/hv.rkt" 10 | "private/naive-layered.rkt") 11 | 12 | (provide 13 | (contract-out 14 | [rename _tree-layout 15 | tree-layout 16 | (->* () 17 | (#:pict pict-convertible?) 18 | #:rest (listof (or/c tree-edge? tree-layout? #f)) 19 | tree-layout?)] 20 | [rename _tree-edge 21 | tree-edge 22 | (->* ((and/c _tree-layout? (not/c #f))) 23 | (#:edge-color (or/c string? 24 | (is-a?/c color%) 25 | (list/c byte? byte? byte?)) 26 | #:edge-width (or/c 'unspecified real? #f) 27 | #:edge-style (or/c 'unspecified 28 | 'transparent 'solid 'xor 'hilite 29 | 'dot 'long-dash 'short-dash 'dot-dash 30 | 'xor-dot 'xor-long-dash 'xor-short-dash 31 | 'xor-dot-dash)) 32 | tree-edge?)] 33 | 34 | 35 | [tree-edge? (-> any/c boolean?)] 36 | [rename _tree-layout? tree-layout? (-> any/c boolean?)] 37 | [binary-tree-layout? (-> any/c boolean?)] 38 | [binary-tidier (->* (binary-tree-layout?) 39 | (#:x-spacing (or/c (and/c real? positive?) #f) 40 | #:y-spacing (or/c (and/c real? positive?) #f) 41 | #:transform (-> real? real? (values real? real?))) 42 | pict?)] 43 | [hv-alternating (->* (binary-tree-layout?) 44 | (#:x-spacing (or/c (and/c real? positive?) #f) 45 | #:y-spacing (or/c (and/c real? positive?) #f) 46 | #:transform (-> real? real? (values real? real?))) 47 | pict?)] 48 | [naive-layered (->* (tree-layout?) 49 | (#:x-spacing (or/c (and/c real? positive?) #f) 50 | #:y-spacing (or/c (and/c real? positive?) #f) 51 | #:transform (-> real? real? (values real? real?))) 52 | pict?)])) 53 | -------------------------------------------------------------------------------- /pict-lib/texpict/balloon.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require pict/private/pict 4 | pict/private/utils 5 | racket/draw 6 | mzlib/class 7 | mzlib/math) 8 | 9 | (provide wrap-balloon pip-wrap-balloon 10 | place-balloon 11 | pin-balloon 12 | (rename-out [mk-balloon balloon]) 13 | make-balloon 14 | balloon? 15 | balloon-pict 16 | balloon-point-x 17 | balloon-point-y 18 | balloon-color 19 | balloon-enable-3d 20 | current-balloon-color) 21 | 22 | (define-struct balloon (pict point-x point-y)) 23 | 24 | (define no-pen (find-pen "white" 1 'transparent)) 25 | (define no-brush (find-brush "white" 'transparent)) 26 | (define black-pen (find-pen "black")) 27 | 28 | (define balloon-enable-3d (make-parameter #t (lambda (x) (and x #t)))) 29 | 30 | (define (series dc steps start-c end-c f pen? brush?) 31 | (if (balloon-enable-3d) 32 | (color-series dc steps #e0.5 start-c end-c f pen? brush?) 33 | (color-series dc 0 0 start-c end-c f pen? brush?))) 34 | 35 | (define (mk-balloon w h corner-radius spike-pos dx dy 36 | [color (current-balloon-color)]) 37 | (let ([dw (if (< corner-radius 1) 38 | (* corner-radius w) 39 | corner-radius)] 40 | [dh (if (< corner-radius 1) 41 | (* corner-radius h) 42 | corner-radius)] 43 | [dxbig (lambda (v) (if (> (abs dx) (abs dy)) 44 | v 45 | 0))] 46 | [dybig (lambda (v) (if (<= (abs dx) (abs dy)) 47 | v 48 | 0))]) 49 | (let-values ([(bx0 by0 bx1 by1 x0 y0 x1 y1 xc yc mx0 mx1 my0 my1 mfx mfy) 50 | (case spike-pos 51 | [(w) (values -1 -0.5 -1 0.5 52 | 1 (/ (- h dh) 2) 53 | 1 (/ (+ h dh) 2) 54 | 1 (/ h 2) 55 | 0.5 1 0.5 -1 56 | 1 0)] 57 | [(nw) (values 0 0 0 0 58 | 0 dh 59 | dw 0 60 | 0 0 61 | 1 -0.5 -1 0.5 62 | (dxbig 1) (dybig 1))] 63 | [(e) (values 1 -0.5 1 0.5 64 | (sub1 w) (/ (- h dh) 2) 65 | (sub1 w) (/ (+ h dh) 2) 66 | (sub1 w) (/ h 2) 67 | -1 -1 1 -1 68 | -1 0)] 69 | [(ne) (values 0 0 0 0 70 | (- w dw) 0 71 | w dh 72 | w 0 73 | 0.5 -1 0.5 -1 74 | (dxbig -1) (dybig 1))] 75 | [(s) (values -0.5 1 0.5 1 76 | (/ (- w dw) 2) (sub1 h) 77 | (/ (+ w dw) 2) (sub1 h) 78 | (/ w 2) (sub1 h) 79 | 1 -1 -1 -1 80 | 0 -1)] 81 | [(n) (values -0.5 -1 0.5 -1 82 | (/ (- w dw) 2) 1 83 | (/ (+ w dw) 2) 1 84 | (/ w 2) 1 85 | 1 -1 1 1 86 | 0 1)] 87 | [(sw) (values 0 0 0 0 88 | 0 (- (sub1 h) dh) 89 | dw (sub1 h) 90 | 0 (sub1 h) 91 | 0.5 -1 0.5 -1 92 | (dxbig 1) (dybig -1))] 93 | [(se) (values 0 1 0 1 94 | (- w dw) (sub1 h) 95 | w (- (sub1 h) dh) 96 | w (sub1 h) 97 | 0.5 -1 -1 0.5 98 | (dxbig -1) (dybig -1))])]) 99 | (let ([xf (+ xc dx)] 100 | [yf (+ yc dy)] 101 | [dark-color (scale-color #e0.6 color)]) 102 | (make-balloon 103 | (dc (lambda (dc x y) 104 | (let ([b (send dc get-brush)] 105 | [p (send dc get-pen)] 106 | [draw-once 107 | (lambda (i rr?) 108 | (when rr? 109 | (send dc draw-rounded-rectangle 110 | (+ x (/ i 2)) (+ y (/ i 2)) 111 | (- w i) (- h i) 112 | (if (and (< (* 2 corner-radius) (- w i)) 113 | (< (* 2 corner-radius) (- h i))) 114 | corner-radius 115 | (/ (min (- w i) (- h i)) 2))) 116 | (let ([p (send dc get-pen)]) 117 | (send dc set-pen no-pen) 118 | (send dc draw-polygon (list (make-object point% (+ x0 (* i mx0)) (+ y0 (* i my0))) 119 | (make-object point% (+ xf (* i mfx)) (+ yf (* i mfy))) 120 | (make-object point% (+ x1 (* i mx1)) (+ y1 (* i my1)))) 121 | x y) 122 | (send dc set-pen p))) 123 | (send dc draw-line (+ x x0 bx0 (* i mx0)) (+ y y0 by0 (* i my0)) 124 | (+ x xf (* i mfx)) (+ y yf (* i mfy))) 125 | (send dc draw-line (+ x x1 bx1 (* i mx1)) (+ y y1 by1 (* i my1)) 126 | (+ x xf (* i mfx)) (+ y yf (* i mfy))))]) 127 | (series dc 5 128 | dark-color 129 | (if (string? color) (make-object color% color) color) 130 | (lambda (i) (draw-once i #t)) 131 | #t #t) 132 | (when (balloon-enable-3d) 133 | (send dc set-brush no-brush) 134 | (send dc set-pen (find-pen dark-color 0.5)) 135 | (draw-once 0 #f)) 136 | 137 | (send dc set-pen p) 138 | (send dc set-brush b))) 139 | w h 0 0) 140 | xf yf))))) 141 | 142 | (define balloon-color (make-object color% 255 255 170)) 143 | (define current-balloon-color (make-parameter balloon-color)) 144 | 145 | (define corner-size 32) 146 | 147 | (define wrap-balloon 148 | (lambda (p corner dx dy [color (current-balloon-color)] [c-rad corner-size] 149 | #:factor [factor 1]) 150 | (let ([b (mk-balloon (+ (pict-width p) (* 2 c-rad)) 151 | (+ (pict-height p) c-rad) 152 | c-rad 153 | corner dx dy 154 | color)]) 155 | (make-balloon 156 | (scale (cc-superimpose 157 | (balloon-pict b) 158 | p) 159 | factor) 160 | (* factor (balloon-point-x b)) 161 | (* factor (balloon-point-y b)))))) 162 | 163 | (define pip-wrap-balloon 164 | (lambda (p corner dx dy [color (current-balloon-color)] [c-rad corner-size] 165 | #:factor [factor 1]) 166 | (pin-balloon (wrap-balloon p corner dx dy color c-rad #:factor factor) (blank 0) 0 0))) 167 | 168 | (define (do-place-balloon flip-proc? balloon p to find-to) 169 | (let-values ([(x y) (if (and (number? to) 170 | (number? find-to)) 171 | (values to (- (pict-height p) 172 | find-to)) 173 | (if flip-proc? 174 | (let-values ([(x y) (find-to p to)]) 175 | (values x (- (pict-height p) y))) 176 | (find-to p to)))]) 177 | (cons-picture 178 | p 179 | `((place ,(- x (balloon-point-x balloon)) 180 | ,(- y ; up-side down! 181 | (- (pict-height (balloon-pict balloon)) 182 | (balloon-point-y balloon))) 183 | ,(balloon-pict balloon)))))) 184 | 185 | (define (place-balloon balloon p to find-to) 186 | (do-place-balloon #f balloon p to find-to)) 187 | 188 | (define (pin-balloon balloon p to find-to) 189 | (do-place-balloon #t balloon p to find-to)) 190 | -------------------------------------------------------------------------------- /pict-lib/texpict/face.rkt: -------------------------------------------------------------------------------- 1 | #lang mzscheme 2 | 3 | (require racket/draw 4 | pict/private/pict 5 | pict/private/utils 6 | mzlib/class 7 | mzlib/math 8 | mzlib/etc 9 | mzlib/kw) 10 | 11 | (provide face face* default-face-color) 12 | 13 | (define no-brush (find-brush "white" 'transparent)) 14 | (define no-pen (find-pen "white" 1 'transparent)) 15 | 16 | (define (series dc steps start-c end-c f pen? brush?) 17 | (color-series dc steps #e0.5 start-c end-c f pen? brush?)) 18 | 19 | (define default-face-color (make-object color% "orange")) 20 | 21 | (define face* 22 | (lambda/kw (eyebrows-kind 23 | mouth-kind 24 | frown? 25 | #:optional 26 | [in-face-color default-face-color] 27 | [eye-inset 0] 28 | [eyebrow-dy 0] 29 | [eye-dx 0] 30 | [eye-dy 0] 31 | #:key 32 | (mouth-shading? #t) 33 | (eye-shading? #t) 34 | (eyebrow-shading? #t) 35 | (tongue-shading? #t) 36 | (face-background-shading? #t) 37 | (teeth? #t)) 38 | 39 | (define face-color (if (string? in-face-color) 40 | (make-object color% in-face-color) 41 | in-face-color)) 42 | (define face-bright-edge-color (scale-color #e1.6 face-color)) 43 | (define face-edge-color (scale-color #e0.8 face-color)) 44 | (define face-dark-edge-color (scale-color #e0.6 face-color)) 45 | (define face-hard-edge-color (scale-color #e0.8 face-edge-color)) 46 | (let ([w 300] 47 | [h 300]) 48 | (dc (lambda (dc x y) 49 | (define old-pen (send dc get-pen)) 50 | (define old-brush (send dc get-brush)) 51 | 52 | (define (one-eye l? p? dd look?) 53 | (define s (if p? 1/3 1)) 54 | (define sdd (if p? 1 1/2)) 55 | (define dx (+ (if p? (* 1/5 w 1/3) 0) (if look? eye-dx 0))) 56 | (define dy (+ (if p? (* 1/4 w 1/3) 0) (if look? eye-dy 0))) 57 | (send dc draw-ellipse 58 | (+ x (* w (if l? 1/5 3/5)) dx (* dd sdd)) (+ y (* h 1/5) dy (* dd sdd)) 59 | (- (* w 1/5 s) (* 2 dd)) (- (* h 1/4 s) (* 2 dd)))) 60 | 61 | (define (one-eye-brow l? dd dy dr) 62 | (send dc draw-arc 63 | (+ x (* w (if l? 1/5 3/5))) 64 | (+ y (* h 3/20) dd dy) 65 | (* w 1/5) 66 | (* h 1/4) 67 | ((if l? + -) (* pi 1/3) dr) ((if l? + -) (* pi 2/3) dr))) 68 | 69 | (define (eye-series steps start-c end-c p? extra-inset look?) 70 | (series dc 71 | (if eye-shading? steps 0) 72 | start-c end-c 73 | (lambda (i) 74 | (one-eye #t p? (+ extra-inset i) look?) 75 | (one-eye #f p? (+ extra-inset i) look?)) 76 | #f #t)) 77 | 78 | (define (eyebrows dy dr) 79 | (send dc set-brush no-brush) 80 | (series dc 81 | (if eyebrow-shading? 3 0) 82 | face-hard-edge-color 83 | face-edge-color 84 | (lambda (i) 85 | (one-eye-brow #t i dy dr) 86 | (one-eye-brow #f i dy dr)) 87 | #t #f) 88 | (send dc set-pen no-pen)) 89 | 90 | (define (normal-eyebrows dy) 91 | (eyebrows dy 0)) 92 | 93 | (define (worried-eyebrows dy) 94 | (eyebrows dy 0.3)) 95 | 96 | (define (angry-eyebrows dy) 97 | (eyebrows dy -0.3)) 98 | 99 | (define (smile sw sh i da path dy flip?) 100 | ;; Either draw or set path. 101 | ((if path 102 | (lambda (x y w h s e) 103 | (send path arc x y w h s e)) 104 | (lambda (x y w h s e) 105 | (send dc draw-arc x y w h s e))) 106 | (+ x (/ (- w sw) 2) (* 1/6 sw)) 107 | (+ y (/ (- sh h) 2) (* 1/8 h) dy (if flip? i 0) (if flip? (- (* h 1/2) (- sh h)) 0)) 108 | (* sw 2/3) (+ (if flip? 0 i) (* h 2/3)) 109 | (- (* pi (- 5/4 (if flip? 1 0))) da) (+ (* pi (- 7/4 (if flip? 1 0))) da))) 110 | 111 | (define (plain-smile flip? tongue? narrow?) 112 | (send dc set-brush no-brush) 113 | (series dc 114 | (if mouth-shading? 3 0) 115 | (make-object color% "black") 116 | face-edge-color 117 | (lambda (i) 118 | (let ([da (if narrow? (* pi -1/8) 0)]) 119 | (smile w h i da #f 0 flip?) 120 | (smile w h (+ 1 (- i)) da #f 0 flip?))) 121 | #t #f) 122 | (when tongue? 123 | (let ([path (new dc-path%)] 124 | [rgn (make-object region% dc)]) 125 | (smile w h 2 0 path 0 flip?) 126 | (send path line-to (+ w x) (+ h y)) 127 | (send path line-to x (+ h y)) 128 | (send rgn set-path path) 129 | (send dc set-clipping-region rgn) 130 | (send dc set-pen no-pen) 131 | (let ([dx (+ x (if flip? 132 | (* 1/3 w) 133 | (* 1/2 w)))] 134 | [dy (+ y (if flip? 135 | (* 1/2 h) 136 | (* 13/20 h)))] 137 | [tw (* 1/5 w)] 138 | [th (* 1/4 h)]) 139 | (series dc 140 | (if tongue-shading? 3 0) 141 | face-color 142 | (make-object color% "red") 143 | (lambda (i) 144 | (send dc draw-ellipse dx dy (- tw i) (- th i))) 145 | #f #t) 146 | (series dc 147 | (if tongue-shading? 4 0) 148 | (make-object color% "black") 149 | (scale-color 0.6 (make-object color% "red")) 150 | (lambda (i) 151 | (send dc draw-line (- (+ dx i) (* tw 1/10)) dy (+ dx (* tw 0.65)) (+ dy (* th 0.75)))) 152 | #t #f) 153 | (send dc set-clipping-region #f))))) 154 | 155 | (define (teeth) 156 | ;; Assumes clipping region is set 157 | (send dc set-brush (find-brush "white")) 158 | (send dc draw-ellipse x y w h) 159 | (when teeth? 160 | (series dc 161 | 5 162 | (make-object color% "darkgray") 163 | (make-object color% "lightgray") 164 | (lambda (i) 165 | (let loop ([j 0][delta 0][tw (* w 1/10)]) 166 | (unless (= j 5) 167 | (send dc draw-rectangle 168 | (+ x (* w 1/2) delta 1) y 169 | (- tw i 1) h) 170 | (send dc draw-rectangle 171 | (+ x (* w 1/2) (- delta) (- tw) 1) y 172 | (- tw i 1) h) 173 | (loop (add1 j) (+ delta tw) (* 8/10 tw))))) 174 | #f #t))) 175 | 176 | (define (toothy-smile tw th ta bw bh ba flip? ddy) 177 | (let-values ([(path) (make-object dc-path%)] 178 | [(tmp-rgn1) (make-object region% dc)] 179 | [(dy) (+ ddy (/ (- h (if flip? (+ th (abs (- bh th))) th)) 2))]) 180 | ;; Teeth: 181 | (smile tw th 0 ta path dy flip?) 182 | (send path reverse) 183 | (smile bw bh 0 ba path dy flip?) 184 | (send tmp-rgn1 set-path path) 185 | (send dc set-clipping-region tmp-rgn1) 186 | (teeth) 187 | (send dc set-clipping-region #f) 188 | 189 | ;; Smile edges: 190 | (send dc set-brush no-brush) 191 | (series dc 192 | (if mouth-shading? 3 0) 193 | (if flip? face-bright-edge-color face-hard-edge-color) 194 | (if flip? face-color face-edge-color) 195 | (lambda (i) 196 | (smile bw bh (if flip? i (- i)) ba #f dy flip?)) 197 | #t #f) 198 | (series dc 199 | (if mouth-shading? 3 0) 200 | (if flip? face-hard-edge-color face-bright-edge-color) 201 | (if flip? face-edge-color face-color) 202 | (lambda (i) 203 | (smile tw th (if flip? (- i) i) ta #f dy flip?)) 204 | #t #f))) 205 | 206 | (define (grimace tw th ta flip?) 207 | (let-values ([(path) (make-object dc-path%)] 208 | [(tmp-rgn1) (make-object region% dc)] 209 | [(dy) (/ (- h th) 2)] 210 | [(elx ely) (values (+ x (* w 0.27)) (+ y (* h 0.65) (if flip? 3 1)))]) 211 | ;; Teeth: 212 | (smile tw th 0 ta path (+ (if flip? -30 0) dy) flip?) 213 | (send path arc elx ely 30 30 (* 1/2 pi) (* 3/2 pi) #t) 214 | (send path reverse) 215 | (send path arc (- (+ x w) (- elx x) 30) ely 30 30 (* 1/2 pi) (* 3/2 pi) #f) 216 | (smile tw th 0 ta path (+ (if flip? 0 -30) dy) flip?) 217 | (send tmp-rgn1 set-path path) 218 | (send dc set-clipping-region tmp-rgn1) 219 | (teeth) 220 | (send dc set-clipping-region #f) 221 | 222 | ;; Smile edges: 223 | (send dc set-brush no-brush) 224 | (let ([sides (lambda (top? i) 225 | (send dc draw-arc (- elx (/ i 2)) (- ely (/ i 2)) 30 (+ 30 i) 226 | (* pi (if top? 1 1/2)) (* pi (if top? 3/2 1))) 227 | (send dc draw-arc (+ (- (+ x w) (- elx x) 30) (/ i 2)) (- ely (/ i 2)) 30 (+ 30 i) 228 | (* pi (if top? -1/2 0)) (* pi (if top? 0 1/2))))]) 229 | (series dc 230 | (if mouth-shading? 3 0) 231 | (if flip? face-bright-edge-color face-hard-edge-color) 232 | (if flip? face-color face-edge-color) 233 | (lambda (i) 234 | (sides flip? i) 235 | (smile tw th (if flip? i (- i)) ta #f (+ (if flip? -2 -30) dy) flip?)) 236 | #t #f) 237 | (series dc 238 | (if mouth-shading? 3 0) 239 | (if flip? face-hard-edge-color face-bright-edge-color) 240 | (if flip? face-edge-color face-color) 241 | (lambda (i) 242 | (sides (not flip?) i) 243 | (smile tw th (if flip? (- i) i) ta #f (+ (if flip? -30 0) dy) flip?)) 244 | #t #f)))) 245 | 246 | (define (medium-grimace flip?) 247 | (grimace 248 | (* 1.2 w) (* h 0.9) (- (* 0.1 pi)) 249 | flip?)) 250 | 251 | (define (narrow-grimace flip?) 252 | (grimace 253 | (* 1.2 w) (* h 0.9) (- (* 0.1 pi)) 254 | flip?)) 255 | 256 | (define (large-smile flip?) 257 | (toothy-smile 258 | w (* 1.05 h) (* 0.10 pi) 259 | (* 1.1 w) (* h 0.95) (* 0.05 pi) 260 | flip? 0)) 261 | 262 | (define (largest-smile flip?) 263 | (toothy-smile 264 | w (* 1.1 h) (* 0.14 pi) 265 | (* 1.2 w) (* h 0.9) (* 0.05 pi) 266 | flip? (if flip? (* h 0.1) 0))) 267 | 268 | (define (narrow-smile flip?) 269 | (toothy-smile 270 | (* 0.8 w) (* h 0.7) (- (* 0.00 pi)) 271 | (* 1.0 w) (* h 0.6) (- (* 0.06 pi)) 272 | flip? (if flip? (- (* h 0.2)) 0))) 273 | 274 | (define (medium-smile flip?) 275 | (toothy-smile 276 | (* 0.8 w) (* h 0.9) (* 0.08 pi) 277 | (* 1.0 w) (* h 0.75) (- (* 0.01 pi)) 278 | flip? 0)) 279 | 280 | (define (oh) 281 | (let ([do-draw 282 | (λ (i) 283 | (let ([sw (* w 7/20)] 284 | [sh (* h 8/20)]) 285 | (send dc draw-ellipse 286 | (+ x i (/ (- w sw) 2)) 287 | (+ y (* i .75) (* h 1/4) (* h -1/16) (/ (- h sh) 2)) 288 | (- sw (* i 2)) 289 | (- sh (* i 2)))))]) 290 | (series dc 291 | (if mouth-shading? 5 0) 292 | face-color 293 | face-dark-edge-color 294 | do-draw 295 | #t #t) 296 | (send dc set-brush (find-brush "black")) 297 | (send dc set-pen no-pen) 298 | (do-draw 9))) 299 | 300 | (define (draw-eyes inset) 301 | ;; Draw eyes 302 | (eye-series 10 303 | (make-object color% "lightgray") 304 | (make-object color% "white") 305 | #f 306 | inset 307 | #f) 308 | 309 | ;; Draw pupils 310 | (eye-series 3 311 | (make-object color% 220 220 220) 312 | (make-object color% "black") 313 | #t 314 | 0 315 | #t)) 316 | 317 | (send dc set-pen no-pen) 318 | 319 | ;; Draw face background 320 | (series dc 321 | (if face-background-shading? 3 0) 322 | face-edge-color 323 | face-color 324 | (lambda (i) 325 | (send dc draw-ellipse 326 | (+ x (/ i 2)) (+ y (/ i 2)) 327 | (- w (* 2 i)) (- h (* 2 i)))) 328 | #f #t) 329 | 330 | (draw-eyes eye-inset) 331 | (case eyebrows-kind 332 | [(normal) (normal-eyebrows eyebrow-dy)] 333 | [(worried) (worried-eyebrows eyebrow-dy)] 334 | [(angry) (angry-eyebrows eyebrow-dy)] 335 | [(none) (void)]) 336 | (case mouth-kind 337 | [(plain) (plain-smile frown? #f #f)] 338 | [(smaller) (plain-smile frown? #f #t)] 339 | [(narrow) (narrow-smile frown?)] 340 | [(medium) (medium-smile frown?)] 341 | [(large) (large-smile frown?)] 342 | [(huge) (largest-smile frown?)] 343 | [(grimace) (medium-grimace frown?)] 344 | [(oh) (oh)] 345 | [(tongue) (plain-smile frown? #t #f)]) 346 | 347 | (send dc set-brush old-brush) 348 | (send dc set-pen old-pen)) 349 | w h 0 0)))) 350 | 351 | (define-syntax (case/good-error-message stx) 352 | (syntax-case stx (else) 353 | [(_ test [(sym ...) e] ... [else x last-e]) 354 | (syntax 355 | (case test 356 | [(sym ...) e] ... 357 | [else (let ([x (apply append '((sym ...) ...))]) last-e)]))])) 358 | 359 | (define face 360 | (opt-lambda (mood [face-color default-face-color]) 361 | (case/good-error-message mood 362 | [(unhappy) 363 | (face* 'none 'plain #t face-color 6)] 364 | [(sortof-happy) 365 | (face* 'worried 'medium #f face-color 6)] 366 | [(sortof-unhappy) 367 | (face* 'worried 'grimace #t face-color 6)] 368 | [(happy) 369 | (face* 'none 'plain #f face-color 6)] 370 | [(happier) 371 | (face* 'none 'large #f face-color 3)] 372 | [(embarrassed embarassed) ; keep older misspelled name 373 | (face* 'worried 'medium #f face-color 3)] 374 | [(badly-embarrassed badly-embarassed) ; here too 375 | (face* 'worried 'medium #t face-color 3)] 376 | [(unhappier) 377 | (face* 'normal 'large #t face-color 3)] 378 | [(happiest) 379 | (face* 'normal 'huge #f face-color 0 -3)] 380 | [(unhappiest) 381 | (face* 'normal 'huge #t face-color 0 -3)] 382 | [(mad) 383 | (face* 'angry 'grimace #t face-color 0)] 384 | [(mean) 385 | (face* 'angry 'narrow #f face-color 0)] 386 | [(surprised) 387 | (face* 'worried 'oh #t face-color -4 -3 2)] 388 | [else all-ids (error 'face "unknown mood: ~e, expected one of ~s" mood all-ids)]))) 389 | -------------------------------------------------------------------------------- /pict-lib/texpict/flash.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/math 3 | racket/draw 4 | racket/class 5 | pict/private/pict) 6 | 7 | (provide filled-flash 8 | outline-flash) 9 | 10 | (define-syntax-rule (define-flash id filled?) 11 | (define (id w h [points 10] [spike-fraction 0.25] [rotation 0]) 12 | (do-flash filled? w h points spike-fraction rotation))) 13 | 14 | (define-flash filled-flash #t) 15 | (define-flash outline-flash #f) 16 | 17 | (define (do-flash filled? w h points spike-fraction rotation) 18 | (define p (new dc-path%)) 19 | (define delta (/ pi points)) 20 | (define in (- 1 spike-fraction)) 21 | (send p move-to 1 0) 22 | 23 | (for/fold ([angle delta]) 24 | ([point (in-range points)]) 25 | (send p line-to (* in (cos angle)) (* in (sin angle))) 26 | (define new-angle (+ angle delta)) 27 | (send p line-to (cos new-angle) (sin new-angle)) 28 | (+ new-angle delta)) 29 | 30 | (send p close) 31 | 32 | (send p scale (/ w 2) (/ h 2)) 33 | (unless (zero? rotation) 34 | (send p rotate rotation)) 35 | (define-values (bx by bw bh) (send p get-bounding-box)) 36 | (send p translate (- bx) (- by)) 37 | 38 | (define no-brush 39 | (send the-brush-list find-or-create-brush "white" 'transparent)) 40 | 41 | (dc (λ (dc x y) 42 | (define b (send dc get-brush)) 43 | (if filled? 44 | (send dc set-brush (send (send dc get-pen) get-color) 'solid) 45 | (send dc set-brush no-brush)) 46 | (send dc draw-path p x y) 47 | (send dc set-brush b)) 48 | bw bh)) 49 | -------------------------------------------------------------------------------- /pict-lib/texpict/mrpict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require pict/private/pict) 3 | (provide (all-from-out pict/private/pict)) 4 | 5 | -------------------------------------------------------------------------------- /pict-lib/texpict/utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require pict/private/utils) 3 | (provide (all-from-out pict/private/utils)) 4 | -------------------------------------------------------------------------------- /pict-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base")) 6 | 7 | (define pkg-desc "tests for \"pict-lib\"") 8 | 9 | (define pkg-authors '(mflatt robby stamourv "spencer@florence.io")) 10 | (define build-deps '("pict-lib" 11 | "rackunit-lib" 12 | "htdp-lib" 13 | ["draw-lib" #:version "1.19"])) 14 | (define update-implies '("pict-lib")) 15 | 16 | (define license 17 | '(Apache-2.0 OR MIT)) 18 | -------------------------------------------------------------------------------- /pict-test/tests/pict/code.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require pict 3 | rackunit 4 | (for-syntax syntax/parse) 5 | pict/code) 6 | 7 | (unless (equal? (pict-width (code a b)) 8 | (pict-width (code a b))) 9 | (error "indentation seems to affect a `code` pict's width")) 10 | 11 | 12 | (define-syntax ccode 13 | (syntax-parser 14 | [(_ a b ...) 15 | #`(#,'code #,(syntax->datum #'a) b ...)])) 16 | 17 | (define-namespace-anchor nsa) 18 | (define ns (namespace-anchor->namespace nsa)) 19 | (check-not-exn 20 | (lambda () (eval #'(ccode a b c) ns))) 21 | 22 | 23 | ;; Test error handling for code:comment 24 | (check-exn (λ (e) 25 | (regexp-match? #rx"code:comment.*string\\?" (exn-message e))) 26 | (λ () (code (code:comment 3)))) 27 | 28 | 29 | ;; codeblock-pict 30 | 31 | ;; test by rendering to a record-dc, and checking the resulting list 32 | ;; of commands 33 | ;; Note: this test failing does not imply that the code is broken 34 | ;; changes to the record-dc format (in response to changes in dc), 35 | ;; for example, would break it 36 | ;; if the test fails, look at the picture, and if it looks fine, 37 | ;; then update the expected hash 38 | (require racket/class racket/draw file/md5 rackunit) 39 | (define (test-pict-hash p h) 40 | (define rdc (new record-dc%)) 41 | (draw-pict p rdc 0 0) 42 | (define commands (send rdc get-recorded-datum)) 43 | ;; commands may include literal floating-point numbers 44 | ;; of course, this means that different machines, with different FPUs, may 45 | ;; compute different results, which changes the hash 46 | ;; KAAAAHAAAAAAAAAAAN! 47 | (define rounded-commands 48 | (let loop ([commands commands]) 49 | (cond [(list? commands) 50 | (map loop commands)] 51 | [(flonum? commands) 52 | ;; not even rounding is enough to paper over the differences 53 | ;; just give up and consider all floats equivalent 54 | 'float] 55 | [else 56 | commands]))) 57 | (define hash (md5 (format "~s" rounded-commands))) 58 | (check-equal? hash h)) 59 | 60 | (define example 61 | #<> 84 | #lang racket 85 | 1 86 | >> 87 | ) 88 | (check-not-exn 89 | (λ () (test-pict-hash (codeblock-pict example2) #"62ec308dd6bed21018107ea44aae18dc"))) 90 | 91 | ;; windows newlines should work 92 | (define example3 "#lang racket\r\n(define x 2)\r\nx") 93 | (test-pict-hash (codeblock-pict example3) #"928d024d7811fb97952f1bad0ab97371") 94 | 95 | ;; ascent should not be zero for a single line 96 | (define example4 (codeblock-pict #:keep-lang-line? #f "#lang racket\n(define foo 42)")) 97 | (check-pred (λ (v) (> v 0)) (pict-ascent example4)) 98 | 99 | (test-pict-hash 100 | (typeset-code 101 | #'(begin (code:comment "single comment") 102 | (code:comment2 "double comment") 103 | (void))) 104 | #"537157490dcb25174111b1b7045ee035") 105 | -------------------------------------------------------------------------------- /pict-test/tests/pict/transform.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/math 3 | pict) 4 | 5 | (define a (cc-superimpose (rectangle 30 30) (rectangle 10.0 20.0))) 6 | (define b (cc-superimpose (rectangle 30 30) (rectangle 10.0 20.0))) 7 | 8 | (define c (frame (rotate (vc-append a b) (- (/ pi 2))))) 9 | (define d (frame (shear (vc-append a b) 0.5 0))) 10 | (define d2 (frame (shear (vc-append a b) -0.5 0.0))) 11 | (define dy (frame (shear (vc-append a b) 0 0.5))) 12 | (define dy2 (frame (shear (vc-append a b) 0 1.5))) 13 | 14 | (define (check-cc-find p a x y) 15 | (define-values (cx cy) (cc-find p a)) 16 | (unless (and (equal? x cx) 17 | (equal? y cy)) 18 | (error 'check "wrong find result: (~s, ~s) vs. (~s, ~s)" x y cx cy))) 19 | 20 | (check-cc-find c a 45.0 15.0) 21 | (check-cc-find d a 22.5 15.0) 22 | (check-cc-find d2 a 37.5 15.0) 23 | (check-cc-find dy a 15.0 22.5) 24 | (check-cc-find dy2 a 15.0 37.5) 25 | -------------------------------------------------------------------------------- /pict/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("pict-lib" 6 | "pict-doc")) 7 | (define implies '("pict-lib" 8 | "pict-doc")) 9 | 10 | (define pkg-desc "Building pictures with functional combinators") 11 | 12 | (define pkg-authors '(mflatt robby)) 13 | 14 | (define license 15 | '(Apache-2.0 OR MIT)) 16 | --------------------------------------------------------------------------------