├── .gitignore ├── LICENSE ├── README.md ├── draw-doc ├── info.rkt └── scribblings │ └── draw │ ├── bitmap-class.scrbl │ ├── bitmap-dc-class.scrbl │ ├── blurbs.rkt │ ├── brush-class.scrbl │ ├── brush-list-class.scrbl │ ├── color-class.scrbl │ ├── color-database-intf.scrbl │ ├── common.rkt │ ├── conveniences.scrbl │ ├── dc-intf.scrbl │ ├── dc-path-class.scrbl │ ├── draw-contracts.scrbl │ ├── draw-funcs.scrbl │ ├── draw-unit.scrbl │ ├── draw.scrbl │ ├── fire.png │ ├── font-class.scrbl │ ├── font-list-class.scrbl │ ├── font-name-directory-intf.scrbl │ ├── gl-config-class.scrbl │ ├── gl-context-intf.scrbl │ ├── guide.scrbl │ ├── info.rkt │ ├── libs.scrbl │ ├── linear-gradient-class.scrbl │ ├── pdf-dc-class.scrbl │ ├── pen-class.scrbl │ ├── pen-list-class.scrbl │ ├── point-class.scrbl │ ├── post-script-dc-class.scrbl │ ├── ps-setup-class.scrbl │ ├── radial-gradient-class.scrbl │ ├── record-dc-class.scrbl │ ├── region-class.scrbl │ ├── svg-dc-class.scrbl │ ├── unsafe.scrbl │ └── water.png ├── draw-lib ├── file │ ├── gif.rkt │ └── private │ │ └── octree-quantize.rkt ├── info.rkt ├── net │ └── gifwrite.rkt └── racket │ ├── draw.rkt │ └── draw │ ├── arrow.rkt │ ├── bmp.rkt │ ├── draw-sig.rkt │ ├── draw-unit.rkt │ ├── gif.rkt │ ├── private │ ├── bitmap-dc.rkt │ ├── bitmap.rkt │ ├── brush.rkt │ ├── color.rkt │ ├── contract.rkt │ ├── dc-intf.rkt │ ├── dc-path.rkt │ ├── dc.rkt │ ├── define.rkt │ ├── emoji-sequences.rkt │ ├── emoji.rkt │ ├── fmod.rkt │ ├── font-dir.rkt │ ├── font-syms.rkt │ ├── font.rkt │ ├── gl-config.rkt │ ├── gl-context.rkt │ ├── gradient.rkt │ ├── hold.rkt │ ├── libs.rkt │ ├── local.rkt │ ├── lock.rkt │ ├── lzw.rkt │ ├── page-dc.rkt │ ├── pen.rkt │ ├── point.rkt │ ├── post-script-dc.rkt │ ├── ps-setup.rkt │ ├── record-dc.rkt │ ├── region.rkt │ ├── svg-dc.rkt │ ├── syntax.rkt │ ├── transform.rkt │ ├── utils.rkt │ ├── write-bytes.rkt │ └── xp.rkt │ ├── unsafe │ ├── brush.rkt │ ├── bstr.rkt │ ├── cairo-lib.rkt │ ├── cairo.rkt │ ├── callback.rkt │ ├── glib.rkt │ ├── jpeg.rkt │ ├── pango.rkt │ └── png.rkt │ ├── xbm.rkt │ └── xpm.rkt ├── draw-test ├── info.rkt └── tests │ └── racket │ └── draw │ ├── .gitignore │ ├── bitmap-stress.rkt │ ├── blits.rkt │ ├── bmp.rkt │ ├── clip-check.rkt │ ├── color.rkt │ ├── dc.rkt │ ├── draw.rkt │ ├── font-maps.rkt │ ├── font.rkt │ ├── gif.rkt │ ├── info.rkt │ ├── jpeg.rkt │ ├── png.rkt │ ├── record-dc.rkt │ ├── scale-png.rkt │ └── unsafe-draw.rkt └── draw └── 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 | # draw 2 | 3 | This the source for the Racket packages: "draw", "draw-doc", "draw-lib", "draw-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/draw/pulls 22 | [issue]: https://github.com/racket/draw/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | -------------------------------------------------------------------------------- /draw-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define build-deps '("gui-doc" 6 | "pict-doc" 7 | "at-exp-lib" 8 | "base" 9 | "gui-lib" 10 | "pict-lib" 11 | "scribble-lib" 12 | "draw-lib" 13 | "racket-doc")) 14 | (define update-implies '("draw-lib")) 15 | 16 | (define pkg-desc "documentation part of \"draw\"") 17 | 18 | (define pkg-authors '(mflatt)) 19 | 20 | (define license 21 | '(Apache-2.0 OR MIT)) 22 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/bitmap-dc-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[bitmap-dc% object% (dc<%>)]{ 5 | 6 | A @racket[bitmap-dc%] object allows drawing directly into a bitmap. A 7 | @racket[bitmap%] object must be supplied at initialization or 8 | installed into a bitmap DC using @method[bitmap-dc% set-bitmap] 9 | before any other method of the DC is called, except @method[dc<%> 10 | get-text-extent], @method[dc<%> get-char-height], or @method[dc<%> 11 | get-char-width]. If any other @racket[bitmap-dc%] method is called 12 | before a bitmap is selected, the method call is ignored. 13 | 14 | Drawing to a @racket[bitmap-dc%] with a color bitmap is guaranteed to 15 | produce the same result as drawing into a @racket[canvas%] instance 16 | (with appropriate clipping and offsets). Thus, a @racket[bitmap-dc%] 17 | can be used for offscreen staging of canvas content. 18 | 19 | 20 | @defconstructor[([bitmap (or/c (is-a?/c bitmap%) #f)])]{ 21 | 22 | Creates a new bitmap DC. If @racket[bitmap] is not @racket[#f], it is 23 | installed into the DC so that drawing commands on the DC draw to 24 | @racket[bitmap]. Otherwise, no bitmap is installed into the DC and 25 | @method[bitmap-dc% set-bitmap] must be called before any other method 26 | of the DC is called. 27 | 28 | } 29 | 30 | @defmethod[(draw-bitmap-section-smooth [source (is-a?/c bitmap%)] 31 | [dest-x real?] 32 | [dest-y real?] 33 | [dest-width (and/c real? (not/c negative?))] 34 | [dest-height (and/c real? (not/c negative?))] 35 | [src-x real?] 36 | [src-y real?] 37 | [src-width (and/c real? (not/c negative?))] 38 | [src-height (and/c real? (not/c negative?))] 39 | [style (or/c 'solid 'opaque 'xor) 'solid] 40 | [color (is-a?/c color%) (send the-color-database find-color "black")] 41 | [mask (or/c (is-a?/c bitmap%) #f) #f]) 42 | boolean?]{ 43 | 44 | The same as @method[dc<%> draw-bitmap-section], except that 45 | @racket[dest-width] and @racket[dest-height] cause the DC's 46 | transformation to be adjusted while drawing the bitmap so that the 47 | bitmap is scaled; and, if the DC's smoothing mode is 48 | @racket['unsmoothed], it is changed to @racket['aligned] while 49 | drawing.} 50 | 51 | @defmethod[(get-argb-pixels [x exact-nonnegative-integer?] 52 | [y exact-nonnegative-integer?] 53 | [width exact-nonnegative-integer?] 54 | [height exact-nonnegative-integer?] 55 | [pixels (and/c bytes? (not/c immutable?))] 56 | [just-alpha? any/c #f] 57 | [pre-multiplied? any/c #f]) 58 | void?]{ 59 | 60 | Gets a rectangle of pixels in the bitmap, subject to the same rules 61 | and performance characteristics of @method[bitmap-dc% get-pixel], 62 | except that the block get is likely to be faster than the sequence of 63 | individual gets. Also, the @racket[bitmap%] class also provides the 64 | same method directly, so it is not necessary to select a bitmap into 65 | a DC to extracts its pixel values. 66 | 67 | The pixel RGB values and alphas are copied into @racket[pixels] 68 | (or just alpha values if @racket[just-alpha?] is true). The first byte 69 | represents an alpha value of the pixel at (@racket[x], @racket[y]), 70 | the second byte represents a red value of the pixel at (@racket[x], 71 | @racket[y]), the third byte is the green value, etc. In this way, the 72 | first @math{@racket[width] * @racket[height] * 4} bytes of 73 | @racket[pixels] are set to reflect the current pixel values in the 74 | DC. The pixels are in row-major order, left to right then top to 75 | bottom. 76 | 77 | If the bitmap has an alpha channel, then the alpha value for each pixel 78 | is always set in @racket[pixels]. 79 | If @racket[just-alpha?] is false and the bitmap does not have an alpha 80 | channel, then the alpha value for each pixel is set to 255. If 81 | @racket[just-alpha?] is true, then @italic{only} the alpha value is set 82 | for each pixel; if the bitmap has no alpha channel, then the alpha 83 | value is based on each pixel's inverted RGB average. Thus, when a 84 | bitmap has a separate mask bitmap, the same @racket[pixels] byte 85 | string is in general filled from two bitmaps: one (the main image) 86 | for the pixel values and one (the mask) for the alpha values. 87 | 88 | If @racket[pre-multiplied?] is true, @racket[just-alpha?] is false, 89 | and the bitmap has an alpha channel, then RGB values in the result 90 | are scaled by the corresponding alpha value (i.e., multiplied by the 91 | alpha value and then divided by 255). 92 | 93 | If the bitmap has a @tech{backing scale} other than @racket[1.0], the 94 | result of @method[bitmap-dc% get-argb-pixels] is as if the bitmap is 95 | drawn to a bitmap with a backing scale of @racket[1.0] and the pixels 96 | of the target bitmap are returned.} 97 | 98 | 99 | @defmethod[(get-bitmap) 100 | (or/c (is-a?/c bitmap%) #f)]{ 101 | 102 | Gets the bitmap currently installed in the DC, or @racket[#f] if no 103 | bitmap is installed. See @method[bitmap-dc% set-bitmap] for more 104 | information. 105 | 106 | } 107 | 108 | @defmethod[(get-pixel [x exact-nonnegative-integer?] 109 | [y exact-nonnegative-integer?] 110 | [color (is-a?/c color%)]) 111 | boolean?]{ 112 | 113 | Fills @racket[color] with the color of the current pixel at position 114 | (@racket[x], @racket[y]) in the drawing context. If the color is 115 | successfully obtained, the return value is @racket[#t], otherwise the 116 | result is @racket[#f]. 117 | 118 | } 119 | 120 | @defmethod[(set-argb-pixels [x real?] 121 | [y real?] 122 | [width exact-nonnegative-integer?] 123 | [height exact-nonnegative-integer?] 124 | [pixels bytes?] 125 | [just-alpha? any/c #f] 126 | [pre-multiplied? any/c #f]) 127 | void?]{ 128 | 129 | Sets a rectangle of pixels in the bitmap, unless 130 | the DC's current bitmap was produced by @racket[make-screen-bitmap] or 131 | @xmethod[canvas% make-bitmap] (in which case @|MismatchExn|). 132 | 133 | The pixel RGB values are taken from @racket[pixels]. The first byte 134 | represents an alpha value, the second byte represents a red value to 135 | used for the pixel at (@racket[x], @racket[y]), the third byte is a blue 136 | value, etc. In this way, the first 137 | @math{@racket[width] * @racket[height] * 4} bytes of @racket[pixels] 138 | determine the new pixel values in the DC. The pixels are in row-major 139 | order, left to right then top to bottom. 140 | 141 | If @racket[just-alpha?] is false, then the alpha value for each pixel is 142 | used only if the DC's current bitmap has an alpha channel. If 143 | @racket[just-alpha?] is true and the bitmap has an alpha channel, then the 144 | bitmap is not modified. If 145 | @racket[just-alpha?] is true and the bitmap has no alpha channel, then each 146 | pixel is set based @italic{only} on the alpha value, but inverted to serve 147 | as a mask. Thus, when working with bitmaps that have an associated mask 148 | bitmap instead of an alpha channel, the same 149 | @racket[pixels] byte string is used with two bitmaps: one 150 | (the main image) for the pixel values and one (the mask) for the 151 | alpha values. 152 | 153 | If @racket[pre-multiplied?] is true, @racket[just-alpha?] is false, 154 | and the bitmap has an alpha channel, then RGB values in 155 | @racket[pixels] are interpreted as scaled by the corresponding alpha value 156 | (i.e., multiplied by the alpha value and then divided by 255). If an 157 | R, G, or B value is greater than its corresponding alpha value (which 158 | is not possible if the value is properly scaled), then it is effectively 159 | reduced to the alpha value. 160 | 161 | If the bitmap has a @tech{backing scale} other than @racket[1.0], then 162 | @racket[pixels] are effectively scaled by the backing scale to obtain 163 | pixel values that are installed into the bitmap.} 164 | 165 | 166 | @defmethod[(set-bitmap [bitmap (or/c (is-a?/c bitmap%) #f)]) 167 | void?]{ 168 | 169 | Installs a bitmap into the DC, so that drawing operations on the bitmap 170 | DC draw to the bitmap. A bitmap is removed from a DC by setting the 171 | bitmap to @racket[#f]. 172 | 173 | A bitmap can be selected into at most one bitmap DC, and only when it 174 | is not used by a control (as a label) or in a @racket[pen%] or 175 | @racket[brush%] (as a stipple). If the argument to @method[bitmap-dc% 176 | set-bitmap] is already in use by another DC, a control, a 177 | @racket[pen%], or a @racket[brush%], @|MismatchExn|. 178 | 179 | } 180 | 181 | @defmethod[(set-pixel [x real?] 182 | [y real?] 183 | [color (is-a?/c color%)]) 184 | void?]{ 185 | 186 | Sets a pixel in the bitmap. 187 | 188 | The current clipping region might not affect the pixel change. Under 189 | X, interleaving drawing commands with @method[bitmap-dc% set-pixel] 190 | calls (for the same @racket[bitmap-dc%] object) incurs a substantial 191 | performance penalty, except for interleaved calls to 192 | @method[bitmap-dc% get-pixel], @method[bitmap-dc% get-argb-pixels], 193 | and @method[bitmap-dc% set-argb-pixels]. 194 | 195 | }} 196 | 197 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/blurbs.rkt: -------------------------------------------------------------------------------- 1 | #readerscribble/reader 2 | (module blurbs racket/base 3 | (require scribble/struct 4 | scribble/manual 5 | scribble/scheme 6 | scribble/decode 7 | racket/set 8 | racket/class 9 | racket/draw 10 | (only-in racket/draw/private/color normalize-color-name) 11 | (for-label racket/draw 12 | racket/base) 13 | (for-syntax racket/base)) 14 | 15 | (provide (all-defined-out)) 16 | 17 | (define (p . l) 18 | (decode-paragraph l)) 19 | 20 | (define PrintNote 21 | (make-splice 22 | (list 23 | @p{Be sure to use the following methods to start/end drawing:} 24 | @itemize[@item{@method[dc<%> start-doc]} 25 | @item{@method[dc<%> start-page]} 26 | @item{@method[dc<%> end-page]} 27 | @item{@method[dc<%> end-doc]}] 28 | @p{Attempts to use a drawing method outside of an active page raises an exception.}))) 29 | 30 | (define reference-doc '(lib "scribblings/reference/reference.scrbl")) 31 | 32 | (define SeeMzParam @elem{(see @secref[#:doc reference-doc "parameters"])}) 33 | 34 | (define DrawSizeNote "") 35 | 36 | (define MismatchExn @elem{an @racket[exn:fail:contract] exception is raised}) 37 | 38 | ;; currently also used by the `2htdp/image` docs: 39 | (define (colorName color-name ignored r g b) 40 | (make-element #f 41 | (list (make-element `(bg-color ,r ,g ,b) 42 | (list (hspace 5))) 43 | (hspace 1) 44 | (make-element 'tt (if (bytes? color-name) 45 | (bytes->string/latin-1 color-name) 46 | color-name))))) 47 | 48 | (define (colors . colors) 49 | (define all-colors 50 | (apply set (map normalize-color-name (send the-color-database get-names)))) 51 | (define result 52 | (tabular 53 | (for/list ([color-name (in-list colors)]) 54 | (define color (send the-color-database find-color color-name)) 55 | (set! all-colors (set-remove all-colors (normalize-color-name color-name))) 56 | (list (colorName color-name #f (send color red) (send color green) (send color blue)))))) 57 | (unless (set-empty? all-colors) 58 | (error 'colors "did not cover ~s" (sort (set->list all-colors) stringsymbol (string-append "GRacket:" s))) 67 | 68 | (define (boxisfill which what) 69 | @elem{The @|which| box is filled with @|what|.}) 70 | (define (boxisfillnull which what) 71 | @elem{The @|which| box is filled with @|what|, unless @|which| is @racket[#f].}) 72 | 73 | ) 74 | 75 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/brush-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt" 3 | scribble/eval 4 | (for-label racket/draw/unsafe/brush 5 | (only-in ffi/unsafe cpointer?))) 6 | 7 | @(define class-eval (make-base-eval)) 8 | @(interaction-eval #:eval class-eval (require racket/class racket/draw)) 9 | @defclass/title[brush% object% ()]{ 10 | 11 | A brush is a drawing tool with a color and a style that is used for 12 | filling in areas, such as the interior of a rectangle or ellipse. In 13 | a monochrome destination, all non-white brushes are drawn as black. 14 | 15 | In addition to its color and style, a brush can have a @deftech{brush stipple} bitmap. 16 | Painting with a 17 | stipple brush is similar to calling @method[dc<%> draw-bitmap] with 18 | the stipple bitmap in the filled region. 19 | 20 | As an alternative to a color, style, and stipple, a brush can have a 21 | @deftech{gradient} that is a @racket[linear-gradient%] or 22 | @racket[radial-gradient%]. When a brush has a gradient and the target 23 | for drawing is not monochrome, then other brush settings are 24 | ignored. With a gradient, for each point in a drawing destination, 25 | the gradient associates a color to the point based on starting and 26 | ending colors and starting and ending lines (for a linear gradient) 27 | or circles (for a radial gradient); a gradient-assigned color is 28 | applied for each point that is touched when drawing with the brush. 29 | 30 | By default, coordinates in a stipple or gradient are transformed by the 31 | drawing context's transformation when the brush is used, but a brush 32 | can have its own @deftech{brush transformation} that is used, instead. 33 | A brush transformation has the same representation and meaning as for 34 | @xmethod[dc<%> get-transformation]. 35 | 36 | A @deftech{brush style} is one of the following (but is ignored if the brush 37 | has a @tech{gradient} and the target is not monochrome): 38 | 39 | @itemize[ 40 | 41 | @item{@indexed-racket['transparent] --- Draws with no effect (on the 42 | interior of the drawn shape).} 43 | 44 | @item{@indexed-racket['solid] --- Draws using the brush's color. If a 45 | monochrome @tech{brush stipple} is installed into the brush, black pixels 46 | from the stipple are transferred to the destination using the 47 | brush's color, and white pixels from the stipple are not 48 | transferred.} 49 | 50 | @item{@indexed-racket['opaque] --- The same as @racket['solid] for a color 51 | @tech{brush stipple}. For a monochrome stipple, white pixels from 52 | the stipple are 53 | transferred to the destination using the destination's 54 | background color.} 55 | 56 | @item{@indexed-racket['xor] --- The same as @racket['solid], accepted 57 | only for partial backward compatibility.} 58 | 59 | @item{@indexed-racket['hilite] --- Draws with black and a @racket[0.3] alpha.} 60 | 61 | @item{@indexed-racket['panel] --- The same as @racket['solid], accepted 62 | only for partial backward compatibility.} 63 | 64 | @item{The following modes correspond to built-in @tech{brush stipples} drawn in 65 | @racket['solid] mode: 66 | 67 | @itemize[ 68 | @item{@indexed-racket['bdiagonal-hatch] --- diagonal lines, top-left to bottom-right} 69 | @item{@indexed-racket['crossdiag-hatch] --- crossed diagonal lines} 70 | @item{@indexed-racket['fdiagonal-hatch] --- diagonal lines, top-right to bottom-left} 71 | @item{@indexed-racket['cross-hatch] --- crossed horizontal and vertical lines} 72 | @item{@indexed-racket['horizontal-hatch] --- horizontal lines} 73 | @item{@indexed-racket['vertical-hatch] --- vertical lines} 74 | ] 75 | 76 | However, when a specific @tech{brush stipple} is installed into the brush, 77 | the above modes are ignored and @racket['solid] is 78 | used, instead.} 79 | 80 | ] 81 | 82 | @index['("drawing" "outlines")]{To} draw outline shapes (such as 83 | unfilled boxes and ellipses), use the @racket['transparent] brush 84 | style. 85 | 86 | To avoid creating multiple brushes with the same characteristics, use 87 | the global @racket[brush-list%] object 88 | @indexed-racket[the-brush-list], or provide a color and style to 89 | @xmethod[dc<%> set-brush]. 90 | 91 | See also @racket[make-brush]. 92 | 93 | 94 | @defconstructor[([color (or/c string? (is-a?/c color%)) "black"] 95 | [style brush-style/c 'solid] 96 | [stipple (or/c #f (is-a?/c bitmap%)) 97 | #f] 98 | [gradient (or/c #f 99 | (is-a?/c linear-gradient%) 100 | (is-a?/c radial-gradient%)) 101 | #f] 102 | [transformation (or/c #f (vector/c (vector/c real? real? real? 103 | real? real? real?) 104 | real? real? real? real? real?)) 105 | #f])]{ 106 | 107 | Creates a brush with the given color, @tech{brush style}, @tech{brush 108 | stipple}, @tech{gradient}, and @tech{brush transformation} (which is 109 | kept only if the gradient or stipple is non-@racket[#f]). For the 110 | case that the color is specified using a name, see 111 | @racket[color-database<%>] for information about color names; if the 112 | name is not known, the brush's color is black.} 113 | 114 | @defmethod[(get-color) 115 | (is-a?/c color%)]{ 116 | 117 | Returns the brush's color. 118 | 119 | } 120 | 121 | @defmethod[(get-gradient) 122 | (or/c (is-a?/c linear-gradient%) 123 | (is-a?/c radial-gradient%) 124 | #f)]{ 125 | 126 | Gets the @tech{gradient}, or @racket[#f] if the brush has no gradient.} 127 | 128 | 129 | @defmethod[(get-handle) (or/c cpointer? #f)]{ 130 | 131 | Returns a low-level handle for the brush content, but only for brushes 132 | created with @racket[make-handle-brush]; otherwise, the result is @racket[#f].} 133 | 134 | 135 | @defmethod[(get-stipple) 136 | (or/c (is-a?/c bitmap%) #f)]{ 137 | 138 | Gets the @tech{brush stipple} bitmap, or @racket[#f] if the brush has no stipple.} 139 | 140 | 141 | @defmethod[(get-style) 142 | brush-style/c]{ 143 | 144 | Returns the @tech{brush style}. See @racket[brush%] for information about 145 | brush styles.} 146 | 147 | 148 | @defmethod[(get-transformation) (or/c #f (vector/c (vector/c real? real? real? real? real? real?) 149 | real? real? real? real? real?))]{ 150 | 151 | Returns the brush's @tech{brush transformation}, if any. 152 | 153 | If a brush with a stipple or gradient also has a transformation, then the 154 | transformation applies to the stipple or gradient's coordinates instead of the 155 | target drawing context's transformation; otherwise, the target drawing 156 | context's transformation applies to stipple and gradient coordinates.} 157 | 158 | 159 | @defmethod[(is-immutable?) 160 | boolean?]{ 161 | 162 | Returns @racket[#t] if the brush object is immutable. 163 | 164 | } 165 | 166 | 167 | @defmethod*[([(set-color [color (is-a?/c color%)]) 168 | void?] 169 | [(set-color [color-name string?]) 170 | void?] 171 | [(set-color [red byte?] [green byte?] [blue byte?]) 172 | void?])]{ 173 | 174 | Sets the brush's color. A brush cannot be modified if it was obtained 175 | from a @racket[brush-list%] or while it is selected into a drawing 176 | context. 177 | 178 | For the case that the color is specified using a string, see 179 | @racket[color-database<%>] for information about color names. 180 | 181 | } 182 | 183 | @defmethod[(set-stipple [bitmap (or/c (is-a?/c bitmap%) #f)] 184 | [transformation (or/c #f (vector/c (vector/c real? real? real? 185 | real? real? real?) 186 | real? real? real? real? real?)) 187 | #f]) 188 | void?]{ 189 | 190 | Sets or removes the @tech{brush stipple} bitmap, where @racket[#f] 191 | removes the stipple. The @tech{brush transformation} is set at the 192 | same time to @racket[transformation]. See @racket[brush%] for 193 | information about drawing with stipples. 194 | 195 | If @racket[bitmap] is modified while is associated with a brush, the 196 | effect on the brush is unspecified. A brush cannot be modified if it 197 | was obtained from a @racket[brush-list%] or while it is selected into 198 | a drawing context. 199 | 200 | } 201 | 202 | @defmethod[(set-style [style brush-style/c]) 203 | void?]{ 204 | 205 | Sets the @tech{brush style}. See 206 | @racket[brush%] for information about the possible styles. 207 | 208 | A brush cannot be modified if it was obtained from a 209 | @racket[brush-list%] or while it is selected into a drawing 210 | context. 211 | 212 | }} 213 | 214 | @(close-eval class-eval) 215 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/brush-list-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[brush-list% object% ()]{ 5 | 6 | A @racket[brush-list%] object maintains a list of @racket[brush%] 7 | objects to avoid creating brushes repeatedly. A @racket[brush%] 8 | object in a brush list cannot be mutated. 9 | 10 | A global brush list, @racket[the-brush-list], is created 11 | automatically. 12 | 13 | 14 | @defconstructor[()]{ 15 | 16 | Creates an empty brush list. 17 | 18 | } 19 | 20 | @defmethod*[([(find-or-create-brush [color (or/c string? (is-a?/c color%))] 21 | [style (or/c 'transparent 'solid 'opaque 22 | 'xor 'hilite 'panel 23 | 'bdiagonal-hatch 'crossdiag-hatch 24 | 'fdiagonal-hatch 'cross-hatch 25 | 'horizontal-hatch 'vertical-hatch)]) 26 | (is-a?/c brush%)] 27 | [(find-or-create-brush [color-name string?] 28 | [style (or/c 'transparent 'solid 'opaque 29 | 'xor 'hilite 'panel 30 | 'bdiagonal-hatch 'crossdiag-hatch 31 | 'fdiagonal-hatch 'cross-hatch 32 | 'horizontal-hatch 'vertical-hatch)]) 33 | (or/c (is-a?/c brush%) #f)])]{ 34 | 35 | Finds a brush of the given specification, or creates one and adds it 36 | to the list. See @racket[brush%] for a further explanation of the 37 | arguments, which are the same as @racket[brush%]'s initialization 38 | arguments. 39 | 40 | }} 41 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/color-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[color% object% ()]{ 5 | 6 | A color is an object representing a red-green-blue (RGB) combination 7 | of primary colors plus an ``alpha'' for opacity. Each red, green, or 8 | blue component of the color is an exact integer in the range 0 to 9 | 255, inclusive, and the alpha value is a real number between 0 and 1, 10 | inclusive. For example, (0, 0, 0, 1.0) is solid black, (255, 255, 11 | 255, 1.0) is solid white, (255, 0, 0, 1.0) is solid red, and (255, 0, 12 | 0, 0.5) is translucent red. 13 | 14 | See @racket[color-database<%>] for information about obtaining a color 15 | object using a color name, and see also @racket[make-color]. 16 | 17 | 18 | @defconstructor*/make[(() 19 | ([red byte?] [green byte?] [blue byte?] 20 | [alpha (real-in 0 1) 1.0]) 21 | ([color-name-or-obj (or/c string? (is-a?/c color%))]))]{ 22 | 23 | Creates a new color. 24 | 25 | If three or four arguments are supplied to the constructor, the 26 | color is created with those RGB and alpha values. 27 | 28 | If a single @racket[color%] object is supplied, the color 29 | is created with the same RGB and alpha values as the given 30 | color. 31 | 32 | If a string is supplied, then it is passed to the 33 | @racket[color-database<%>]'s @method[color-database<%> find-color] 34 | method to find a color (signaling an error if the color is not in 35 | the @racket[color-database<%>]'s @method[color-database<%> get-names] 36 | method's result). 37 | 38 | If no arguments are supplied, the new color is black. 39 | } 40 | 41 | @defmethod[(red) byte?]{ 42 | Returns the red component of the color.} 43 | 44 | @defmethod[(green) byte?]{ 45 | Returns the green component of the color.} 46 | 47 | @defmethod[(blue) byte?]{ 48 | Returns the blue component of the color.} 49 | 50 | @defmethod[(alpha) (real-in 0 1)]{ 51 | Returns the alpha component (i.e., opacity) of the color.} 52 | 53 | @defmethod[(set [red byte?] [green byte?] [blue byte?] 54 | [alpha (real-in 0 1) 1.0]) 55 | void?]{ 56 | Sets the four (red, green, blue, and alpha) component values of the color.} 57 | 58 | @defmethod[(copy-from [src (is-a?/c color%)]) (is-a?/c color%)]{ 59 | Copies the RGB values of another color object to this one, returning 60 | this object as the result.} 61 | 62 | @defmethod[(is-immutable?) boolean?]{ 63 | Returns @racket[#t] if the color object is immutable. 64 | 65 | See also @racket[make-color] and @xmethod[color-database<%> find-color].} 66 | 67 | @defmethod[(ok?) #t]{ 68 | Returns @racket[#t] to indicate that the color object is valid. 69 | 70 | (Historically, the result could be @racket[#f], but color objects 71 | are now always valid.)} 72 | 73 | } 74 | 75 | @section{Equality} 76 | 77 | We can compare instances of @racket[color%] using @racket[equal?]. Two 78 | @racket[color%] instances are equal if the red, green, blue, and alpha 79 | values are equal. I.e., a mutable and an immutable 80 | @racket[color%] instance are equal as long as their values are equal. 81 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/color-database-intf.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt" 3 | racket/draw) 4 | 5 | @(define color-db-eval (make-base-eval)) 6 | @(interaction-eval 7 | #:eval color-db-eval 8 | (require racket/draw pict racket/class)) 9 | 10 | @definterface/title[color-database<%> ()]{ 11 | 12 | The global @indexed-racket[the-color-database] object is an instance of 13 | @racket[color-database<%>]. It maintains a database of standard RGB 14 | colors for a predefined set of named colors (such as ``black'' and 15 | ``light gray''). See @method[color-database<%> find-color] for 16 | information on how color names are normalized. 17 | 18 | The following colors are in the database: 19 | @(colors 20 | "Orange Red" 21 | "Tomato" 22 | "Dark Red" 23 | "Red" 24 | "Firebrick" 25 | "Crimson" 26 | "Deep Pink" 27 | "Maroon" 28 | "Indian Red" 29 | "Medium Violet Red" 30 | "Violet Red" 31 | "Light Coral" 32 | "Hot Pink" 33 | "Pale Violet Red" 34 | "Light Pink" 35 | "Rosy Brown" 36 | "Pink" 37 | "Orchid" 38 | "Lavender Blush" 39 | "Snow" 40 | "Chocolate" 41 | "Saddle Brown" 42 | "Brown" 43 | "Dark Orange" 44 | "Coral" 45 | "Sienna" 46 | "Orange" 47 | "Salmon" 48 | "Peru" 49 | "Dark Goldenrod" 50 | "Goldenrod" 51 | "Sandy Brown" 52 | "Light Salmon" 53 | "Dark Salmon" 54 | "Gold" 55 | "Yellow" 56 | "Olive" 57 | "Burlywood" 58 | "Tan" 59 | "Navajo White" 60 | "Peach Puff" 61 | "Khaki" 62 | "Dark Khaki" 63 | "Moccasin" 64 | "Wheat" 65 | "Bisque" 66 | "Pale Goldenrod" 67 | "Blanched Almond" 68 | "Medium Goldenrod" 69 | "Papaya Whip" 70 | "Misty Rose" 71 | "Lemon Chiffon" 72 | "Antique White" 73 | "Cornsilk" 74 | "Light Goldenrod Yellow" 75 | "Old Lace" 76 | "Linen" 77 | "Light Yellow" 78 | "Sea Shell" 79 | "Beige" 80 | "Floral White" 81 | "Ivory" 82 | "Green" 83 | "Lawn Green" 84 | "Chartreuse" 85 | "Green Yellow" 86 | "Yellow Green" 87 | "Medium Forest Green" 88 | "Olive Drab" 89 | "Dark Olive Green" 90 | "Dark Sea Green" 91 | "Lime" 92 | "Dark Green" 93 | "Lime Green" 94 | "Forest Green" 95 | "Spring Green" 96 | "Medium Spring Green" 97 | "Sea Green" 98 | "Medium Sea Green" 99 | "Aquamarine" 100 | "Light Green" 101 | "Pale Green" 102 | "Medium Aquamarine" 103 | "Turquoise" 104 | "Light Sea Green" 105 | "Medium Turquoise" 106 | "Honeydew" 107 | "Mint Cream" 108 | "Royal Blue" 109 | "Dodger Blue" 110 | "Deep Sky Blue" 111 | "CornflowerBlue" 112 | "Steel Blue" 113 | "Light Sky Blue" 114 | "Dark Turquoise" 115 | "Cyan" 116 | "Aqua" 117 | "Dark Cyan" 118 | "Teal" 119 | "Sky Blue" 120 | "Cadet Blue" 121 | "CadetBlue" 122 | "Dark Slate Gray" 123 | "Light Slate Gray" 124 | "Slate Gray" 125 | "Light Steel Blue" 126 | "Light Blue" 127 | "Powder Blue" 128 | "Pale Turquoise" 129 | "Light Cyan" 130 | "Alice Blue" 131 | "Azure" 132 | "Medium Blue" 133 | "Cornflower Blue" 134 | "Dark Blue" 135 | "Midnight Blue" 136 | "Navy" 137 | "Blue" 138 | "Indigo" 139 | "Blue Violet" 140 | "Medium Slate Blue" 141 | "Slate Blue" 142 | "Purple" 143 | "Dark Slate Blue" 144 | "Dark Violet" 145 | "Dark Orchid" 146 | "Medium Purple" 147 | "Cornflower Blue" 148 | "Medium Orchid" 149 | "Magenta" 150 | "Fuchsia" 151 | "Dark Magenta" 152 | "Violet" 153 | "Plum" 154 | "Lavender" 155 | "Thistle" 156 | "Ghost White" 157 | "White" 158 | "White Smoke" 159 | "Gainsboro" 160 | "Light Gray" 161 | "Silver" 162 | "Gray" 163 | "Dark Gray" 164 | "Dim Gray" 165 | "Black") 166 | 167 | See also @racket[color%]. 168 | 169 | 170 | @defmethod[(find-color [color-name string?]) 171 | (or/c (is-a?/c color%) #f)]{ 172 | 173 | Finds a color by name (character case is ignored). If no 174 | color is found for the name, @racket[#f] is returned, 175 | otherwise the result is an immutable color object. 176 | 177 | Color names are normalized by case and spaces are removed 178 | from colors before they are looked up in the database, with 179 | two exceptions: @racket["cornflower blue"] and 180 | @racket["cadet blue"]. For those two colors, the names are 181 | compared in a case-insensitive way, but spaces are not 182 | removed, as the spaceless versions of those names are 183 | different colors than the ones with spaces in them. 184 | 185 | @examples[#:eval color-db-eval 186 | (define (show-colors-named . names) 187 | (apply 188 | hc-append 189 | 2 190 | (for/list ([name (in-list names)]) 191 | (colorize 192 | (filled-rectangle 60 40) 193 | (send the-color-database find-color name))))) 194 | 195 | (show-colors-named "blue" 196 | "BLUE" 197 | "B L U E") 198 | 199 | (show-colors-named "cornflowerblue" 200 | "CORNFLOWERBLUE" 201 | "CORN flow ERB lue" 202 | "cornflower blue" 203 | "CORNFLOWER BLUE" 204 | "cornflower blue " 205 | " CORNFLOWER BLUE" 206 | "cornflower blue")] 207 | 208 | @history[#:changed "1.16" @elem{Changed normalization to more generally remove spaces.}]} 209 | 210 | 211 | @defmethod[(get-names) (listof string?)]{ 212 | 213 | Returns an alphabetically sorted list of case-folded color names for which 214 | @method[color-database<%> find-color] returns a @racket[color%] value.} 215 | 216 | } 217 | 218 | @(close-eval color-db-eval) 219 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/common.rkt: -------------------------------------------------------------------------------- 1 | (module common racket/base 2 | (require scribble/manual 3 | scribble/basic 4 | scribble/eval 5 | racket/class 6 | racket/contract 7 | "blurbs.rkt" 8 | (only-in scribblings/reference/mz AllUnix exnraise)) 9 | (provide (all-from-out scribble/manual) 10 | (all-from-out scribble/basic) 11 | (all-from-out scribble/eval) 12 | (all-from-out racket/class) 13 | (all-from-out racket/contract) 14 | (all-from-out "blurbs.rkt") 15 | (all-from-out scribblings/reference/mz)) 16 | 17 | (require (for-label racket/draw 18 | racket/gui/base 19 | racket/class 20 | racket/contract 21 | racket/base)) 22 | (provide (for-label (all-from-out racket/draw) 23 | (all-from-out racket/gui/base) 24 | (all-from-out racket/class) 25 | (all-from-out racket/contract) 26 | (all-from-out racket/base)))) 27 | 28 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/conveniences.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "common.rkt" (for-label racket/draw/arrow)) 4 | 5 | @title{Drawing Conveniences} 6 | 7 | This section presents higher-level APIs that provide additional conveniences 8 | over the @racket[racket/draw] API. 9 | 10 | @section{Arrows} 11 | @defmodule[racket/draw/arrow] 12 | 13 | @defproc[(draw-arrow [dc (is-a?/c dc<%>)] 14 | [start-x real?] 15 | [start-y real?] 16 | [end-x real?] 17 | [end-y real?] 18 | [dx real?] 19 | [dy real?] 20 | [#:pen-width pen-width (or/c real? #f) #f] 21 | [#:arrow-head-size arrow-head-size real? 8] 22 | [#:arrow-root-radius arrow-root-radius real? 2.5]) 23 | void?]{ 24 | Draws an arrow on @racket[dc] from (@racket[start-x], @racket[start-y]) to 25 | (@racket[end-x], @racket[end-y]). (@racket[dx], @racket[dy]) is the top-left 26 | location for drawing. 27 | If @racket[pen-width] is @racket[#f], the current pen width is used. 28 | 29 | @history[#:added "1.9"]{} 30 | } 31 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/draw-contracts.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @title{Drawing Contracts} 5 | 6 | @local-table-of-contents[] 7 | 8 | This page documents the contracts that are used to describe 9 | the specification of @racketmodname[racket/draw] objects 10 | and functions. 11 | 12 | @defthing[font-family/c flat-contract?]{ 13 | Recognizes font designations. Corresponds to the @racket[_family] 14 | initialization argument of the @racket[font%] class. 15 | 16 | Equivalent to the following definition: 17 | @racketblock[ 18 | (or/c 'default 'decorative 'roman 'script 'swiss 19 | 'modern 'symbol 'system)] 20 | } 21 | 22 | @defthing[font-style/c flat-contract?]{ 23 | Recognizes font styles. Corresponds to the @racket[_style] 24 | initialization argument of the @racket[font%] class. 25 | 26 | Equivalent to the following definition: 27 | @racketblock[(or/c 'normal 'italic 'slant)] 28 | } 29 | 30 | @defthing[font-weight/c flat-contract?]{ 31 | Recognizes @tech{font weights}. Corresponds to the @racket[_weight] 32 | initialization argument of the @racket[font%] class. 33 | } 34 | 35 | @defthing[font-smoothing/c flat-contract?]{ 36 | Recognizes a font smoothing amount. 37 | Corresponds to the @racket[_smoothing] 38 | initialization argument of the @racket[font%] class. 39 | 40 | Equivalent to the following definition: 41 | @racketblock[(or/c 'default 'partly-smoothed 42 | 'smoothed 'unsmoothed)] 43 | } 44 | 45 | @defthing[font-hinting/c flat-contract?]{ 46 | Recognizes font hinting modes. Corresponds to the @racket[_hinting] 47 | initialization argument of the @racket[font%] class. 48 | 49 | Equivalent to the following definition: 50 | @racketblock[(or/c 'aligned 'unaligned)] 51 | } 52 | 53 | @defthing[font-feature-settings/c flat-contract?]{ 54 | Recognizes font @tech{OpenType feature settings}. Corresponds to the 55 | @racket[_feature-settings] initialization argument of the @racket[font%] 56 | class. 57 | 58 | Equivalent to the following definition: 59 | @racketblock[(and/c hash-equal? 60 | hash-strong? 61 | (hash/c (and/c string? #px"^[ !#-~]{4}$") 62 | exact-nonnegative-integer? 63 | #:immutable #t))] 64 | @history[#:added "1.19"] 65 | } 66 | 67 | @defthing[pen-style/c flat-contract?]{ 68 | Recognizes pen styles. Corresponds 69 | to the @racket[_style] initialization argument of the 70 | @racket[pen%] class. 71 | 72 | Equivalent to the following definition: 73 | @racketblock[ 74 | (or/c 'transparent 'solid 'xor 'hilite 75 | 'dot 'long-dash 'short-dash 'dot-dash 76 | 'xor-dot 'xor-long-dash 'xor-short-dash 77 | 'xor-dot-dash)] 78 | } 79 | 80 | @defthing[pen-cap-style/c flat-contract?]{ 81 | Recognizes pen cap styles. Corresponds 82 | to the @racket[_cap] initialization argument of the 83 | @racket[pen%] class. 84 | 85 | Equivalent to the following definition: 86 | @racketblock[(or/c 'round 'projecting 'butt)] 87 | } 88 | 89 | @defthing[pen-join-style/c flat-contract?]{ 90 | Recognizes pen join styles. Corresponds 91 | to the @racket[_join] initialization argument of the 92 | @racket[pen%] class. 93 | 94 | Equivalent to the following definition: 95 | @racketblock[(or/c 'round 'bevel 'miter)] 96 | } 97 | 98 | @defthing[brush-style/c flat-contract?]{ 99 | Recognizes brush styles. Corresponds 100 | to the @racket[_style] initialization argument of the 101 | @racket[brush%] class. 102 | 103 | Equivalent to the following definition: 104 | @racketblock[ 105 | (or/c 'transparent 'solid 'opaque 106 | 'xor 'hilite 'panel 107 | 'bdiagonal-hatch 'crossdiag-hatch 108 | 'fdiagonal-hatch 'cross-hatch 109 | 'horizontal-hatch 'vertical-hatch)] 110 | } 111 | 112 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/draw-unit.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt" 3 | (for-label racket/draw/draw-unit racket/draw/draw-sig)) 4 | 5 | @title{Signature and Unit} 6 | 7 | The @racketmodname[racket/draw/draw-sig] and 8 | @racketmodname[racket/draw/draw-unit] libraries define the 9 | @racket[draw^] signature and @racket[draw@] implementation. 10 | 11 | @section{Draw Unit} 12 | 13 | @defmodule[racket/draw/draw-unit] 14 | 15 | @defthing[draw@ unit?]{ 16 | Re-exports all of the exports of @racketmodname[racket/draw].} 17 | 18 | 19 | @section{Draw Signature} 20 | 21 | @defmodule[racket/draw/draw-sig] 22 | 23 | @defsignature[draw^ ()] 24 | 25 | Includes all of the identifiers exported by @racketmodname[racket/draw]. 26 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/draw.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @title{The Racket Drawing Toolkit} 5 | 6 | @author["Matthew Flatt" "Robert Bruce Findler" "John Clements"] 7 | 8 | @declare-exporting[racket/draw] 9 | 10 | @defmodule*/no-declare[(racket/draw)]{The 11 | @racketmodname[racket/draw] library provides all of the class, 12 | interface, and procedure bindings defined in this manual.} 13 | 14 | @table-of-contents[] 15 | 16 | @;------------------------------------------------------------------------ 17 | 18 | @include-section["guide.scrbl"] 19 | @include-section["bitmap-class.scrbl"] 20 | @include-section["bitmap-dc-class.scrbl"] 21 | @include-section["brush-class.scrbl"] 22 | @include-section["brush-list-class.scrbl"] 23 | @include-section["color-class.scrbl"] 24 | @include-section["color-database-intf.scrbl"] 25 | @include-section["dc-intf.scrbl"] 26 | @include-section["dc-path-class.scrbl"] 27 | @include-section["font-class.scrbl"] 28 | @include-section["font-list-class.scrbl"] 29 | @include-section["font-name-directory-intf.scrbl"] 30 | @include-section["gl-config-class.scrbl"] 31 | @include-section["gl-context-intf.scrbl"] 32 | @include-section["linear-gradient-class.scrbl"] 33 | @include-section["pdf-dc-class.scrbl"] 34 | @include-section["pen-class.scrbl"] 35 | @include-section["pen-list-class.scrbl"] 36 | @include-section["point-class.scrbl"] 37 | @include-section["post-script-dc-class.scrbl"] 38 | @include-section["ps-setup-class.scrbl"] 39 | @include-section["radial-gradient-class.scrbl"] 40 | @include-section["record-dc-class.scrbl"] 41 | @include-section["region-class.scrbl"] 42 | @include-section["svg-dc-class.scrbl"] 43 | @include-section["draw-funcs.scrbl"] 44 | @include-section["draw-contracts.scrbl"] 45 | @include-section["draw-unit.scrbl"] 46 | @include-section["unsafe.scrbl"] 47 | @include-section["conveniences.scrbl"] 48 | @include-section["libs.scrbl"] 49 | 50 | @;------------------------------------------------------------------------ 51 | 52 | @(bibliography 53 | 54 | (bib-entry #:key "Adobe99" 55 | #:author "Adobe Systems Incorporated" 56 | #:title "PostScript Language Reference, third edition" 57 | #:is-book? #t 58 | #:url "http://partners.adobe.com/public/developer/en/ps/PLRM.pdf" 59 | #:date "1999") 60 | 61 | ) 62 | 63 | @;------------------------------------------------------------------------ 64 | 65 | @index-section[] 66 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/fire.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/draw/55819da32ae19b9c900bb2c64edb8600dd8c720d/draw-doc/scribblings/draw/fire.png -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/font-list-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[font-list% object% ()]{ 5 | 6 | A @racket[font-list%] object maintains a list of @racket[font%] 7 | objects to avoid repeatedly creating fonts. 8 | 9 | A global font list, @racket[the-font-list], is created automatically. 10 | 11 | 12 | @defconstructor[()]{ 13 | 14 | Creates an empty font list. 15 | 16 | } 17 | 18 | @defmethod*[([(find-or-create-font [size (real-in 0.0 1024.0)] 19 | [family (or/c 'default 'decorative 'roman 'script 20 | 'swiss 'modern 'symbol 'system)] 21 | [style (or/c 'normal 'italic 'slant)] 22 | [weight (or/c 'normal 'bold 'light)] 23 | [underline? any/c #f] 24 | [smoothing (or/c 'default 'partly-smoothed 'smoothed 'unsmoothed) 'default] 25 | [size-in-pixels? any/c #f] 26 | [hinting (or/c 'aligned 'unaligned) 'aligned] 27 | [feature-settings font-feature-settings/c (hash)]) 28 | (is-a?/c font%)] 29 | [(find-or-create-font [size (real-in 0.0 1024.0)] 30 | [face string?] 31 | [family (or/c 'default 'decorative 'roman 'script 32 | 'swiss 'modern 'symbol 'system)] 33 | [style (or/c 'normal 'italic 'slant)] 34 | [weight (or/c 'normal 'bold 'light)] 35 | [underline any/c #f] 36 | [smoothing (or/c 'default 'partly-smoothed 'smoothed 'unsmoothed) 'default] 37 | [size-in-pixels? any/c #f] 38 | [hinting (or/c 'aligned 'unaligned) 'aligned] 39 | [feature-settings font-feature-settings/c (hash)]) 40 | (is-a?/c font%)])]{ 41 | 42 | Finds an existing font in the list or creates a new one (that is 43 | automatically added to the list). The arguments are the same as for 44 | creating a @racket[font%] instance. 45 | 46 | See also @racket[make-font] and @racket[current-font-list]. 47 | 48 | @history[#:changed "1.4" @elem{Changed @racket[size] to allow non-integer and zero values.} 49 | #:changed "1.19" @elem{Added the optional @racket[feature-settings] argument.}]}} 50 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/font-name-directory-intf.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt" scribble/bnf) 3 | 4 | @definterface/title[font-name-directory<%> ()]{ 5 | 6 | There is one @racket[font-name-directory<%>] object: 7 | @racket[the-font-name-directory]. It implements a mapping from font 8 | specifications (face, family, style, and weight) to information for 9 | rendering text on a specific device. Programmers rarely need to 10 | directly invoke methods of @racket[the-font-name-directory]. It is 11 | used automatically when drawing text to a @racket[dc<%>] 12 | object. Nevertheless, @racket[the-font-name-directory] is available 13 | so that programmers can query or modify the mapping manually. A 14 | programmer may also need to understand how the face-and-family 15 | mapping works. 16 | 17 | To extract mapping information from @racket[the-font-name-directory], 18 | first obtain a @defterm{font ID}, which is an index based on a family 19 | and optional face string. Font IDs are returned by 20 | @method[font-name-directory<%> find-or-create-font-id] and 21 | @method[font-name-directory<%> get-font-id] . A Font ID can be 22 | combined with a weight and style to obtain a specific mapping value 23 | via @method[font-name-directory<%> get-screen-name] or 24 | @method[font-name-directory<%> get-post-script-name]. 25 | 26 | For a family without a face string, the corresponding font ID has a 27 | useful built-in mapping for every platform and device. For a family with a 28 | face string, @racket[the-font-name-directory] interprets the string 29 | (in a platform-specific way) to generate a mapping for 30 | drawing (to a canvas's @racket[dc<%>], a @racket[bitmap-dc%], or a 31 | @racket[printer-dc%]). 32 | 33 | Currently, on all platforms, a face string is interpreted as a 34 | @hyperlink["http://www.pango.org"]{Pango} font description when it 35 | contains a comma, otherwise it is treated as a family name. A 36 | face can thus be just a family name such as @racket["Helvetica"], a family 37 | followed by a comma and font modifiers as in @racket["Helvetica, Bold"], or a sequence of comma-separated 38 | familie names followed by space-separated font options as an 39 | @racket["Helvetica, Arial, bold italic"]. Any size in a font 40 | description is overridden by a given @racket[font%]'s size. Any 41 | (slant) style or weight options in a font description are overridden 42 | by a non-@racket['normal] value for a given @racket[font%]'s style or 43 | weight, respectively. 44 | 45 | @defmethod[(find-family-default-font-id [family (or/c 'default 'decorative 'roman 'script 46 | 'swiss 'modern 'symbol 'system)]) 47 | exact-integer?]{ 48 | 49 | Gets the font ID representing the default font for a family. See 50 | @racket[font%] for information about font families. 51 | 52 | } 53 | 54 | @defmethod[(find-or-create-font-id [name string?] 55 | [family (or/c 'default 'decorative 'roman 'script 56 | 'swiss 'modern 'symbol 'system)]) 57 | exact-integer?]{ 58 | 59 | Gets the face name for a font ID, initializing the mapping for 60 | the face name if necessary. 61 | 62 | Font ID are useful only as mapping indices for 63 | @indexed-racket[the-font-name-directory]. 64 | 65 | } 66 | 67 | @defmethod[(get-face-name [font-id exact-integer?]) 68 | (or/c string? #f)]{ 69 | 70 | Gets the face name for a font ID. If the font ID corresponds to 71 | the default font for a particular family, @racket[#f] is returned. 72 | 73 | } 74 | 75 | @defmethod[(get-family [font-id exact-integer?]) 76 | (or/c 'default 'decorative 'roman 'script 77 | 'swiss 'modern 'symbol 'system)]{ 78 | 79 | Gets the family for a font ID. See 80 | @racket[font%] for information about font families. 81 | 82 | } 83 | 84 | @defmethod[(get-font-id [name string?] 85 | [family (or/c 'default 'decorative 'roman 'script 86 | 'swiss 'modern 'symbol 'system)]) 87 | exact-integer?]{ 88 | 89 | Gets the font ID for a face name paired with a default family. If the 90 | mapping for the given pair is not already initialized, @racket[0] is 91 | returned. See also @method[font-name-directory<%> 92 | find-or-create-font-id]. 93 | 94 | Font ID are useful only as mapping indices for 95 | @indexed-racket[the-font-name-directory]. 96 | 97 | } 98 | 99 | @defmethod[(get-post-script-name [font-id exact-integer?] 100 | [weight (or/c 'normal 'bold 'light)] 101 | [style (or/c 'normal 'italic 'slant)]) 102 | (or/c string? #f)]{ 103 | 104 | Gets a PostScript font description for a font ID, weight, and style 105 | combination. 106 | 107 | See @racket[font%] for information about @racket[weight] and 108 | @racket[style]. 109 | 110 | } 111 | 112 | @defmethod[(get-screen-name [font-id exact-integer?] 113 | [weight (or/c 'normal 'bold 'light)] 114 | [style (or/c 'normal 'italic 'slant)]) 115 | (or/c string? #f)]{ 116 | 117 | Gets a platform-dependent screen font description (used for drawing to a 118 | canvas's @racket[dc<%>], a @racket[bitmap-dc%], or a 119 | @racket[printer-dc%]) for a font ID, weight, and style combination. 120 | 121 | See @racket[font%] for information about @racket[weight] and 122 | @racket[style]. 123 | 124 | } 125 | 126 | @defmethod[(set-post-script-name [font-id exact-integer?] 127 | [weight (or/c 'normal 'bold 'light)] 128 | [style (or/c 'normal 'italic 'slant)] 129 | [name string?]) 130 | void?]{ 131 | 132 | Sets a PostScript font description for a font ID, weight, and style 133 | combination. See also @method[font-name-directory<%> 134 | get-post-script-name]. 135 | 136 | See @racket[font%] for information about @racket[weight] and @racket[style]. 137 | 138 | } 139 | 140 | @defmethod[(set-screen-name [font-id exact-integer?] 141 | [weight (or/c 'normal 'bold 'light)] 142 | [style (or/c 'normal 'italic 'slant)] 143 | [name string?]) 144 | void?]{ 145 | 146 | Sets a platform-dependent screen font description (used for drawing to a 147 | canvas's @racket[dc<%>], a @racket[bitmap-dc%], or a 148 | @racket[printer-dc%]) for a font ID, weight, and style combination. 149 | 150 | See @racket[font%] for information about @racket[weight] and 151 | @racket[style]. 152 | 153 | }} 154 | 155 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/gl-config-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[gl-config% object% ()]{ 5 | 6 | A @racket[gl-config%] object encapsulates configuration information 7 | for an OpenGL drawing context. Use a @racket[gl-config%] object as an 8 | initialization argument for @racket[canvas%] or provide it to 9 | @racket[make-gl-bitmap]. 10 | 11 | 12 | @defconstructor[()]{ 13 | 14 | Creates a GL configuration that indicates legacy OpenGL, double 15 | buffering, a depth buffer of size one, no stencil buffer, no 16 | accumulation buffer, no multisampling, and not stereo. 17 | 18 | } 19 | 20 | @defmethod[(get-accum-size) 21 | (integer-in 0 256)]{ 22 | 23 | Reports the accumulation-buffer size (for each of red, green, blue, 24 | and alpha) that the configuration requests, where zero means no 25 | accumulation buffer is requested. 26 | 27 | } 28 | 29 | @defmethod[(get-depth-size) 30 | (integer-in 0 256)]{ 31 | 32 | Reports the depth-buffer size that the configuration requests, where 33 | zero means no depth buffer is requested. 34 | 35 | } 36 | 37 | @defmethod[(get-double-buffered) 38 | boolean?]{ 39 | 40 | Reports whether the configuration requests double buffering or not. 41 | 42 | } 43 | 44 | @defmethod[(get-hires-mode) 45 | boolean?]{ 46 | 47 | Determines whether to use hires mode. On Mac OS, hires mode means that the 48 | created OpenGL contexts will have access to the full Retina resolution 49 | and will not be scaled by the drawing system. On other platforms, hires mode 50 | has no effect. 51 | 52 | @history[#:added "1.5"]} 53 | 54 | 55 | @defmethod[(get-legacy?) 56 | boolean?]{ 57 | 58 | Determines whether to use legacy ``Compatibility'' OpenGL or ``Core'' OpenGL. 59 | Core OpenGL profiles are currently supported on Mac OS (version 10.7 and up) 60 | and Linux (if the graphics drivers support them). 61 | 62 | @history[#:added "1.2"]} 63 | 64 | @defmethod[(get-multisample-size) 65 | (integer-in 0 256)]{ 66 | 67 | Reports the multisampling size that the configuration requests, where 68 | zero means no multisampling is requested. 69 | 70 | } 71 | 72 | @defmethod[(get-share-context) 73 | (or/c #f (is-a?/c gl-context<%>))]{ 74 | 75 | Returns a @racket[gl-context<%>] object that shares certain objects 76 | (textures, display lists, etc.) with newly created OpenGL drawing 77 | contexts, or @racket[#f] is none is set. 78 | 79 | See also @method[gl-config% set-share-context]. 80 | 81 | } 82 | 83 | 84 | @defmethod[(get-stencil-size) 85 | (integer-in 0 256)]{ 86 | 87 | Reports the stencil-buffer size that the configuration requests, where 88 | zero means no stencil buffer is requested. 89 | 90 | } 91 | 92 | @defmethod[(get-stereo) 93 | boolean?]{ 94 | 95 | Reports whether the configuration requests stereo or not. 96 | 97 | } 98 | 99 | @defmethod[(get-sync-swap) 100 | boolean?]{ 101 | 102 | Reports whether the configuration requests buffer-swapping 103 | synchronization with the screen refresh. 104 | 105 | @history[#:added "1.10"]} 106 | 107 | @defmethod[(set-accum-size [on? (integer-in 0 256)]) 108 | void?]{ 109 | 110 | Adjusts the configuration to request a particular accumulation-buffer 111 | size for every channel (red, green, blue, and alpha), where zero 112 | means no accumulation buffer is requested. 113 | 114 | } 115 | 116 | @defmethod[(set-depth-size [on? (integer-in 0 256)]) 117 | void?]{ 118 | 119 | Adjusts the configuration to request a particular depth-buffer size, 120 | where zero means no depth buffer is requested. 121 | 122 | } 123 | 124 | @defmethod[(set-double-buffered [on? any/c]) 125 | void?]{ 126 | 127 | Adjusts the configuration to request double buffering or not. 128 | 129 | } 130 | 131 | @defmethod[(set-hires-mode [hires-mode any/c]) 132 | void?]{ 133 | 134 | Adjusts the configuration to request hires mode or not; see 135 | @method[gl-config get-hires-mode]. 136 | 137 | @history[#:added "1.5"]} 138 | 139 | @defmethod[(set-legacy? [legacy? any/c]) 140 | void?]{ 141 | 142 | Adjusts the configuration to request legacy mode or not; see 143 | @method[gl-config get-legacy?]. 144 | 145 | @history[#:added "1.2"]} 146 | 147 | 148 | @defmethod[(set-multisample-size [on? (integer-in 0 256)]) 149 | void?]{ 150 | 151 | Adjusts the configuration to request a particular multisample size, 152 | where zero means no multisampling is requested. If a multisampling 153 | context is not available, this request will be ignored. 154 | 155 | } 156 | 157 | @defmethod[(set-share-context [context (or/c #f (is-a?/c gl-context<%>))]) 158 | void?]{ 159 | 160 | Determines a @racket[gl-context<%>] object that shares certain objects 161 | (textures, display lists, etc.) with newly created OpenGL drawing 162 | contexts, where @racket[#f] indicates 163 | that no sharing should occur. 164 | 165 | When a context @racket[_B] shares objects with context @racket[_A], it 166 | is also shares objects with every other context sharing with 167 | @racket[_A], and vice versa. 168 | 169 | If an OpenGL implementation does not support sharing, @racket[context] 170 | is effectively ignored when a new context is created. 171 | Sharing should be supported in all versions of Mac OS. 172 | On Windows and Linux, sharing is provided by the presence of the 173 | @tt{WGL_ARB_create_context} and @tt{GLX_ARB_create_context} extensions, 174 | respectively (and OpenGL 3.2 requires both). 175 | 176 | } 177 | 178 | @defmethod[(set-stencil-size [on? (integer-in 0 256)]) 179 | void?]{ 180 | 181 | Adjusts the configuration to request a particular stencil-buffer size, 182 | where zero means no stencil buffer is requested. 183 | 184 | } 185 | 186 | @defmethod[(set-stereo [on? any/c]) 187 | void?]{ 188 | 189 | Adjusts the configuration to request stereo or not.} 190 | 191 | 192 | @defmethod[(set-sync-swap [on? any/c]) 193 | void?]{ 194 | 195 | Adjusts the configuration to request buffer-swapping 196 | synchronization with the screen refresh or not. 197 | 198 | @history[#:added "1.10"]} 199 | 200 | } 201 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/gl-context-intf.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt" 3 | (for-label (only-in ffi/unsafe cpointer?))) 4 | 5 | @definterface/title[gl-context<%> ()]{ 6 | 7 | A @racket[gl-context<%>] object represents a context for drawing with 8 | @as-index{OpenGL} to a specific @racket[dc<%>] instance. To obtain a 9 | @racket[gl-context<%>] object, call @method[dc<%> get-gl-context] of 10 | the target drawing context. 11 | 12 | Only canvas @racket[dc<%>] and @racket[bitmap-dc%] objects containing 13 | a bitmap from @racket[make-gl-bitmap] support OpenGL (always on 14 | Windows and Mac OS, sometimes on Unix). Normal @racket[dc<%>] 15 | drawing and OpenGL drawing can be mixed in a @racket[bitmap-dc%], but 16 | a canvas that uses the @racket['gl] style to support OpenGL does not 17 | reliably support normal @racket[dc<%>] drawing; use a bitmap if you 18 | need to mix drawing modes, and use a canvas to maximize OpenGL 19 | performance. 20 | 21 | When the target bitmap for a @racket[bitmap-dc%] context is changed 22 | via @method[bitmap-dc% set-bitmap], the associated 23 | @racket[gl-context<%>] changes. Canvas contexts are normally double 24 | buffered, and bitmap contexts are single buffered. 25 | 26 | The @racketmodname[racket/gui/base] library provides no OpenGL 27 | routines. Instead, they must be obtained from a separate library, 28 | such as @racketmodname[sgl #:indirect]. The facilities in 29 | @racketmodname[racket/gui/base] merely manage the current OpenGL 30 | context, connecting it to windows and bitmaps. 31 | 32 | Only one OpenGL context can be active at a time across all threads and 33 | eventspaces. OpenGL contexts are not protected 34 | against interference among threads; that is, if a thread selects one 35 | of its OpenGL contexts, then other threads can write into the context 36 | via OpenGL commands. However, if all threads issue OpenGL commands 37 | only within a thunk passed to @method[gl-context<%> call-as-current], 38 | then drawing from the separate threads will not interfere, because 39 | @method[gl-context<%> call-as-current] uses a lock to serialize 40 | context selection across all threads in Racket. 41 | 42 | @defmethod[(call-as-current [thunk (-> any)] 43 | [alternate evt? never-evt] 44 | [enable-breaks? any/c #f]) 45 | any/c]{ 46 | 47 | Calls a thunk with this OpenGL context as the current context for 48 | OpenGL commands. 49 | 50 | The method blocks to obtain a lock that protects the global OpenGL 51 | context, and it releases the lock when the thunk returns or 52 | escapes. The lock is re-entrant, so a nested use of the method in the 53 | same thread with the same OpenGL context does not obtain or release 54 | the lock. 55 | 56 | The lock prevents interference among OpenGL-using threads. If a 57 | thread is terminated while holding the context lock, the lock is 58 | released. Continuation jumps into the thunk do not grab the lock or 59 | set the OpenGL context. See @racket[gl-context<%>] for more 60 | information on interference. 61 | 62 | The method accepts an alternate @tech[#:doc 63 | reference-doc]{synchronizable event} for use while blocking for the 64 | context lock; see also @racket[sync]. 65 | 66 | The result of the method call is the result of the thunk if it is 67 | called, or the result of the alternate event if it is chosen instead 68 | of the context lock. 69 | 70 | If @method[gl-context<%> ok?] returns @racket[#f] at the time that 71 | this method is called, then @|MismatchExn|. 72 | 73 | If @racket[enable-breaks?] is true, then the method uses 74 | @racket[sync/enable-break] while blocking for the context-setting 75 | lock instead of @racket[sync]. 76 | 77 | } 78 | 79 | @defmethod[(get-handle) cpointer?]{ 80 | 81 | Returns a handle to the platform's underlying context. The value that the 82 | pointer represents depends on the platform: 83 | 84 | @itemize[ 85 | @item{Windows: @tt{HGLRC}} 86 | @item{Mac OS: @tt{NSOpenGLContext}} 87 | @item{Unix: @tt{GLXContext}} 88 | ] 89 | 90 | Note that these values are not necessary the most ``low-level'' context objects, 91 | but are instead the ones useful to Racket. For example, a @tt{NSOpenGLContext} 92 | wraps a @tt{CGLContextObj}. 93 | } 94 | 95 | @defmethod[(ok?) 96 | boolean?]{ 97 | 98 | Returns @racket[#t] if this context is available OpenGL drawing, 99 | @racket[#f] otherwise. 100 | 101 | A context is unavailable if OpenGL support is disabled at compile time 102 | or run time, if the context is associated with a 103 | @racket[bitmap-dc%] with no selected bitmap or with a monochrome 104 | selected bitmap, if the context is for a canvas that no longer 105 | exists, or if there was a low-level error when preparing the context. 106 | 107 | } 108 | 109 | @defmethod[(swap-buffers) 110 | void?]{ 111 | 112 | Swaps the front (visible) and back (OpenGL-drawing) buffer for a 113 | context associated with a canvas, and has no effect on a bitmap 114 | context. 115 | 116 | This method implicitly uses @method[gl-context<%> call-as-current] to 117 | obtain the context lock. Since the lock is re-entrant, however, the 118 | @method[gl-context<%> swap-buffers] method can be safely used within 119 | a @method[gl-context<%> call-as-current] thunk. 120 | 121 | }} 122 | 123 | @defproc[(get-current-gl-context) gl-context<%>]{ 124 | If within the dynamic extent of a @method[gl-context<%> call-as-current] 125 | method call, returns the current context; otherwise returns @racket[#f]. 126 | This is possibly most useful for caching context-dependent state or data, 127 | such as extension strings. Create such caches using @racket[make-weak-hasheq]. 128 | 129 | @history[#:added "1.3"] 130 | } 131 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings '(("draw.scrbl" (multi-page) (racket-core -21)))) 4 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/libs.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @title[#:tag "libs"]{Platform Dependencies} 5 | 6 | On Windows and Mac OS, the Racket distribution includes all 7 | necessary libraries that are not part of a stock installation of the 8 | operating system, and the libraries are included in any distribution 9 | created with @exec{raco distribute} (see @secref[#:doc '(lib 10 | "scribblings/raco/raco.scrbl") "exe-dist"]). 11 | 12 | On Unix, the following system libraries must be installed. Numbers 13 | in square brackets indicate a version that is tried first, and if that 14 | fails, the name without the version is tried. 15 | 16 | @itemlist[ 17 | @item{@filepath{libglib-2.0[.0]}} 18 | @item{@filepath{libgmodule-2.0[.0]}} 19 | @item{@filepath{libgobject-2.0[.0]}} 20 | @item{@filepath{libpango-1.0[.0]}} 21 | @item{@filepath{libpangocairo-1.0[.0]}} 22 | @item{@filepath{libcairo[.2]}} 23 | @item{@filepath{libjpeg[.{62,8,9}]}} 24 | @item{@filepath{libpng[{16[.16],15[.15],12[.0]]}}} 25 | ] 26 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/linear-gradient-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt" scribble/eval 3 | (for-label pict)) 4 | 5 | @(define class-eval (make-base-eval)) 6 | @(interaction-eval #:eval class-eval (require racket/class racket/draw pict)) 7 | 8 | @defclass/title[linear-gradient% object% ()]{ 9 | 10 | A @deftech{linear gradient} is used with a @racket[brush%] to fill 11 | areas with smooth color transitions. 12 | Color transitions are based on a line, where colors are assigned to 13 | stop points along the line, and colors for in-between points are 14 | interpolated from the stop-point colors. The color of a point on the 15 | gradient's line is propagated to all points in the drawing context 16 | that are touched by a line through the point and perpendicular to the 17 | gradient's line. 18 | 19 | 20 | @defconstructor[([x0 real?] 21 | [y0 real?] 22 | [x1 real?] 23 | [y1 real?] 24 | [stops (listof (list/c (real-in 0 1) (is-a?/c color%)))])]{ 25 | 26 | Creates a linear gradient with a line from (@racket[x0], @racket[y0]) 27 | to end point (@racket[x1], @racket[y1]). The @racket[stops] list 28 | assigns colors to stop points along the line, where @racket[0.0] 29 | corresponds to (@racket[x0], @racket[y0]), @racket[1.0] corresponds to 30 | (@racket[x1], @racket[y1]), and numbers in between correspond to 31 | points in between. 32 | 33 | Elements in @racket[stops] are implicitly sorted by point (i.e., by 34 | the number between @racket[0.0] and @racket[1.0]). Order is preserved 35 | for multiple elements for the same point, in which case the first 36 | element for a given point is treated infinitesimally before the point, 37 | and additional elements between the first and last for a stop point 38 | are effectively ignored. 39 | 40 | @examples[ 41 | #:eval class-eval 42 | (define ellipse-brush 43 | (new brush% 44 | [gradient 45 | (new linear-gradient% 46 | [x0 0] 47 | [y0 200] 48 | [x1 200] 49 | [y1 00] 50 | [stops 51 | (list (list 0 (make-object color% 255 0 0)) 52 | (list 0.5 (make-object color% 0 255 0)) 53 | (list 1 (make-object color% 0 0 255)))])])) 54 | 55 | (define rectangle-brush 56 | (new brush% 57 | [gradient 58 | (new linear-gradient% 59 | [x0 0] 60 | [y0 100] 61 | [x1 100] 62 | [y1 0] 63 | [stops 64 | (list (list 0 (make-object color% 255 0 0)) 65 | (list 0.5 (make-object color% 0 255 0)) 66 | (list 1 (make-object color% 0 0 255)))])])) 67 | 68 | (dc 69 | (λ (dc dx dy) 70 | (define old-pen (send dc get-pen)) 71 | (define old-brush (send dc get-brush)) 72 | (define-values (ox oy) (send dc get-origin)) 73 | (send dc set-pen "black" 1 'transparent) 74 | (send dc set-brush ellipse-brush) 75 | 76 | (send dc set-origin (+ ox dx 50) (+ oy dy 50)) 77 | (send dc draw-ellipse 0 0 200 200) 78 | 79 | (send dc set-brush rectangle-brush) 80 | (send dc set-origin (+ ox dx 300) (+ oy dy 50)) 81 | (send dc draw-rectangle 0 0 200 200) 82 | 83 | (send dc set-pen old-pen) 84 | (send dc set-brush old-brush) 85 | (send dc set-origin ox oy)) 86 | 550 300) 87 | ]} 88 | 89 | 90 | @defmethod[(get-line) 91 | (values real? real? real? real?)]{ 92 | 93 | Returns the gradient's control line as @racket[_x0], @racket[_y0], 94 | @racket[_x1], and @racket[_y1]. 95 | 96 | } 97 | 98 | @defmethod[(get-stops) 99 | (listof (list/c (real-in/c 0 1) (is-a?/c color%)))]{ 100 | 101 | Returns the gradient's list of color stops. 102 | 103 | }} 104 | 105 | @(close-eval class-eval) 106 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/pdf-dc-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[pdf-dc% object% (dc<%>)]{ 5 | 6 | Like @racket[post-script-dc%], but generates a PDF file instead of a 7 | PostScript file. 8 | 9 | @defconstructor[([interactive any/c #t] 10 | [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] 11 | [use-paper-bbox any/c #f] 12 | [as-eps any/c #t] 13 | [width (or/c (and/c real? (not/c negative?)) #f) #f] 14 | [height (or/c (and/c real? (not/c negative?)) #f) #f] 15 | [output (or/c path-string? output-port? #f) #f])]{ 16 | 17 | See @racket[post-script-dc%] for information on the arguments. The 18 | @racket[as-eps] argument is allowed for consistency with 19 | @racket[post-script-dc%], but its value is ignored.}} 20 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/pen-list-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[pen-list% object% ()]{ 5 | 6 | A @racket[pen-list%] object maintains a list of @racket[pen%] 7 | objects to avoid repeatedly creating pen objects. A @racket[pen%] 8 | object in a pen list cannot be mutated. 9 | 10 | A global pen list @indexed-racket[the-pen-list] is created automatically. 11 | 12 | 13 | @defconstructor[()]{ 14 | 15 | Creates an empty pen list. 16 | 17 | 18 | } 19 | 20 | @defmethod*[([(find-or-create-pen [color (is-a?/c color%)] 21 | [width (real-in 0 255)] 22 | [style (or/c 'transparent 'solid 'xor 'hilite 23 | 'dot 'long-dash 'short-dash 'dot-dash 24 | 'xor-dot 'xor-long-dash 'xor-short-dash 25 | 'xor-dot-dash)] 26 | [cap (or/c 'round 'projecting 'butt) 'round] 27 | [join (or/c 'round 'bevel 'miter) 'round]) 28 | (is-a?/c pen%)] 29 | [(find-or-create-pen [color-name string?] 30 | [width (real-in 0 255)] 31 | [style (or/c 'transparent 'solid 'xor 'hilite 32 | 'dot 'long-dash 'short-dash 'dot-dash 33 | 'xor-dot 'xor-long-dash 'xor-short-dash 34 | 'xor-dot-dash)] 35 | [cap (or/c 'round 'projecting 'butt) 'round] 36 | [join (or/c 'round 'bevel 'miter) 'round]) 37 | (or/c (is-a?/c pen%) #f)])]{ 38 | 39 | Finds a pen of the given specification, or creates one and adds it to 40 | the list. The arguments are the same as for creating a @racket[pen%] 41 | instance plus a cap and join style as for @method[pen% set-cap] and 42 | @method[pen% set-join]. When @racket[color-name] is provided, however, the return 43 | value is @racket[#f] when no color matching @racket[color-name] can be 44 | found in @racket[the-color-database]. 45 | 46 | }} 47 | 48 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/point-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[point% object% ()]{ 5 | 6 | A @racket[point%] is used for certain drawing commands. It 7 | encapsulates two real numbers. 8 | 9 | @defconstructor*/make[(() 10 | ([x real?] 11 | [y real?]))]{ 12 | 13 | Creates a point. If @racket[x] and @racket[y] are not supplied, they 14 | are set to @racket[0]. 15 | } 16 | 17 | @defmethod[(get-x) 18 | real?]{ 19 | Gets the point x-value. 20 | 21 | } 22 | 23 | @defmethod[(get-y) 24 | real?]{ 25 | Gets the point y-value. 26 | 27 | } 28 | 29 | @defmethod[(set-x [x real?]) 30 | void?]{ 31 | Sets the point x-value. 32 | 33 | } 34 | 35 | @defmethod[(set-y [y real?]) 36 | void?]{ 37 | 38 | Sets the point y-value. 39 | 40 | }} 41 | 42 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/post-script-dc-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[post-script-dc% object% (dc<%>)]{ 5 | 6 | A @racket[post-script-dc%] object is a PostScript device context, that 7 | can write PostScript files on any platform. See also 8 | @racket[ps-setup%] and @racket[pdf-dc%]. 9 | 10 | @|PrintNote| 11 | 12 | See also @racket[printer-dc%]. 13 | 14 | 15 | @defconstructor[([interactive any/c #t] 16 | [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] 17 | [use-paper-bbox any/c #f] 18 | [as-eps any/c #t] 19 | [width (or/c (and/c real? (not/c negative?)) #f) #f] 20 | [height (or/c (and/c real? (not/c negative?)) #f) #f] 21 | [output (or/c path-string? output-port? #f) #f])]{ 22 | 23 | If @racket[interactive] is true, the user is given a dialog for 24 | setting printing parameters (see @racket[get-ps-setup-from-user]); 25 | the resulting configuration is installed as the current 26 | configuration). If the user chooses to print to a file (the only 27 | possibility on Windows and Mac OS), another dialog is given to 28 | select the filename. If the user hits cancel in either of these 29 | dialogs, then @method[dc<%> ok?] returns @racket[#f]. 30 | 31 | If @racket[parent] is not @racket[#f], it is used as the parent window of 32 | the configuration dialog. 33 | 34 | If @racket[interactive] is @racket[#f], then the settings returned by 35 | @racket[current-ps-setup] are used. A file dialog is still presented 36 | to the user if the @method[ps-setup% get-file] method returns 37 | @racket[#f] and @racket[output] is @racket[#f], and the user may 38 | hit @onscreen{Cancel} in that case so that @method[dc<%> ok?] returns @racket[#f]. 39 | 40 | If @racket[use-paper-bbox] is @racket[#f], then the PostScript 41 | bounding box for the output is determined by @racket[width] and 42 | @racket[height] (which are rounded upward using @racket[ceiling]). 43 | If @racket[use-paper-bbox] is not @racket[#f], then 44 | the bounding box is determined by the current paper size (as 45 | specified by @racket[current-ps-setup]). When @racket[width] or 46 | @racket[height] is @racket[#f], then the corresponding dimension is 47 | determined by the paper size, even if @racket[use-paper-bbox] is 48 | @racket[#f]. 49 | 50 | @index["Encapsulated PostScript (EPS)"]{If} @racket[as-eps] is 51 | @racket[#f], then the generated PostScript does not include an 52 | Encapsulated PostScript (EPS) header, and instead includes a generic 53 | PostScript header. The margin and translation factors specified by 54 | @racket[current-ps-setup] are used only when @racket[as-eps] is 55 | @racket[#f]. If @racket[as-eps] is true, then the generated 56 | PostScript includes a header that identifiers it as EPS. 57 | 58 | When @racket[output] is not @racket[#f], then file-mode output is 59 | written to @racket[output]. If @racket[output] is @racket[#f], then 60 | the destination is determined via @racket[current-ps-setup] or by 61 | prompting the user for a pathname. When @racket[output] is a port, 62 | then data is written to @racket[port] by a thread that is created 63 | with the @racket[post-script-dc%] instance; in case that writing 64 | thread's custodian is shut down, calling @method[dc<%> end-doc] 65 | resumes the port-writing thread with @racket[thread-resume] 66 | and @racket[(current-thread)] as the second argument. 67 | 68 | See also @racket[ps-setup%] and @racket[current-ps-setup]. The 69 | settings for a particular @racket[post-script-dc%] object are fixed to 70 | the values in the current configuration when the object is created 71 | (after the user has interactively adjusted them when 72 | @racket[interactive] is true). 73 | 74 | }} 75 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/radial-gradient-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt" scribble/eval (for-label pict)) 3 | 4 | @(define class-eval (make-base-eval)) 5 | @(interaction-eval #:eval class-eval (require racket/class racket/draw pict)) 6 | 7 | @defclass/title[radial-gradient% object% ()]{ 8 | 9 | A @deftech{radial gradient} is used with a @racket[brush%] to fill 10 | areas with smooth color transitions. 11 | Color transitions are based on two circles and the sequence of 12 | circles that ``morph'' from the starting circle to the ending 13 | circle. Normally, one of the two circles defining a gradient is 14 | nested within the other; in that case, points within the inner circle 15 | get the same color as the inner circle's edge, while points outside 16 | the outer circle get the same color as the outer circle's edge. 17 | 18 | @defconstructor[([x0 real?] 19 | [y0 real?] 20 | [r0 real?] 21 | [x1 real?] 22 | [y1 real?] 23 | [r1 real?] 24 | [stops (listof (list/c (real-in 0 1) (is-a?/c color%)))])]{ 25 | 26 | Creates a radial gradient with the starting circle as the one with 27 | radius @racket[r0] centered at (@racket[x0], @racket[y0]) and the 28 | ending circle as the one with radius @racket[r1] centered at 29 | (@racket[x1], @racket[y1]). The @racket[stops] list assigns colors to 30 | circles, where @racket[0.0] corresponds to the starting circle, 31 | @racket[1.0] corresponds to the ending circle, and numbers in between 32 | correspond to circles in between. 33 | 34 | The order of elements within @racket[stops] and duplicate points are 35 | treated in the same way for as @racket[linear-gradient%]. 36 | 37 | @examples[ 38 | #:eval class-eval 39 | (define ellipse-brush 40 | (new brush% 41 | [gradient 42 | (new radial-gradient% 43 | [x0 100] [y0 100] [r0 0] 44 | [x1 100] [y1 100] [r1 100] 45 | [stops 46 | (list (list 0 (make-object color% 0 0 255)) 47 | (list 0.5 (make-object color% 0 255 0)) 48 | (list 1 (make-object color% 255 0 0)))])])) 49 | 50 | (define rectangle-brush 51 | (new brush% 52 | [gradient 53 | (new radial-gradient% 54 | [x0 100] [y0 100] [r0 10] 55 | [x1 100] [y1 100] [r1 100] 56 | [stops 57 | (list (list 0 (make-object color% 255 0 0)) 58 | (list 0.5 (make-object color% 0 255 0)) 59 | (list 1 (make-object color% 0 0 255)))])])) 60 | 61 | (dc 62 | (λ (dc dx dy) 63 | (define old-pen (send dc get-pen)) 64 | (define old-brush (send dc get-brush)) 65 | (define-values (ox oy) (send dc get-origin)) 66 | 67 | (send dc set-pen "black" 1 'transparent) 68 | (send dc set-brush ellipse-brush) 69 | (send dc set-origin (+ ox dx 50) (+ oy dy 50)) 70 | (send dc draw-ellipse 0 0 200 200) 71 | 72 | (send dc set-origin (+ ox dx 300) (+ oy dy 50)) 73 | (send dc set-brush rectangle-brush) 74 | (send dc draw-rectangle 0 0 200 200) 75 | 76 | (send dc set-pen old-pen) 77 | (send dc set-brush old-brush) 78 | (send dc set-origin ox oy)) 79 | 550 300) 80 | ]} 81 | 82 | @defmethod[(get-circles) 83 | (values real? real? real? real? real? real?)]{ 84 | 85 | Returns the gradient's boundary circles as @racket[_x0], @racket[_y0], 86 | @racket[_r0], @racket[_x1], @racket[_y1], and @racket[_r1]. 87 | 88 | } 89 | 90 | @defmethod[(get-stops) 91 | (listof (list/c (real-in 0 1) (is-a?/c color%)))]{ 92 | 93 | Returns the gradient's list of color stops. 94 | 95 | }} 96 | 97 | 98 | @(close-eval class-eval) 99 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/record-dc-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[record-dc% object% (dc<%>)]{ 5 | 6 | A @racket[record-dc%] object records drawing actions for replay into 7 | another drawing context. The recorded drawing operations can be 8 | extracted as a procedure via @method[record-dc% 9 | get-recorded-procedure], or the actions can be extracted as a datum 10 | (that can be printed with @racket[write] and recreated with 11 | @racket[read]) via @method[record-dc% get-recorded-datum]. 12 | 13 | When drawing recorded actions, the target drawing context's pen, 14 | brush, font, text, background, text background, and text foreground do 15 | not affect the recorded actions. The target drawing context's 16 | transformation, alpha, and clipping region compose with settings in 17 | the recorded actions (so that, for example, a recorded action to set 18 | the clipping region actually intersects the region with the drawing 19 | context's clipping region at the time that the recorded commands are 20 | replayed). After recoded commands are replayed, all settings in the 21 | target drawing context, such as its clipping region or current font, 22 | are as before the replay. 23 | 24 | 25 | @defconstructor[([width (>=/c 0) 640] 26 | [height (>=/c 0) 480])]{ 27 | 28 | Creates a new recording DC. The optional @racket[width] and 29 | @racket[height] arguments determine the result of @method[dc<%> 30 | get-size] on the recording DC; the @racket[width] and 31 | @racket[height] arguments do not clip drawing.} 32 | 33 | 34 | @defmethod[(get-recorded-datum) any/c]{ 35 | 36 | Extracts a recorded drawing to a value that can be printed with 37 | @racket[write] and re-read with @racket[read]. Use 38 | @racket[recorded-datum->procedure] to convert the datum to a drawing 39 | procedure.} 40 | 41 | 42 | @defmethod[(get-recorded-procedure) ((is-a?/c dc<%>) . -> . void?)]{ 43 | 44 | Extracts a recorded drawing to a procedure that can be applied to 45 | another DC to replay the drawing commands to the given DC. 46 | 47 | The @method[record-dc% get-recorded-procedure] method can be more 48 | efficient than composing @method[record-dc% get-recorded-datum] and 49 | @racket[recorded-datum->procedure].}} 50 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/svg-dc-class.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt") 3 | 4 | @defclass/title[svg-dc% object% (dc<%>)]{ 5 | 6 | Similar to @racket[post-script-dc%], but generates a SVG (scalable 7 | vector graphics) file instead of a PostScript file. 8 | 9 | @|PrintNote| 10 | 11 | @defconstructor[([width (and/c real? (not/c negative?))] 12 | [height (and/c real? (not/c negative?))] 13 | [output (or/c path-string? output-port?)] 14 | [exists (or/c 'error 'append 'update 'can-update 15 | 'replace 'truncate 16 | 'must-truncate 'truncate/replace) 17 | 'error])]{ 18 | 19 | The @racket[width] and @racket[height] arguments determine the width 20 | and height of the generated image. 21 | 22 | The image is written to @racket[output]. If @racket[output] is a path 23 | and the file exists already, then @racket[exists] determines how 24 | the existing file is handled in the same way as for the @racket[#:exists] 25 | argument to @racket[open-output-file].} 26 | 27 | } 28 | 29 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/unsafe.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "common.rkt" 3 | (for-label (except-in ffi/unsafe ->) 4 | racket/draw/unsafe/brush 5 | racket/draw/unsafe/cairo-lib)) 6 | 7 | @title[#:tag "unsafe"]{Unsafe Libraries} 8 | 9 | The @racketmodname[racket/draw] library is currently implemented using Cairo 10 | and Pango. The @xmethod[bitmap% get-handle] method exposes the 11 | underlying Cairo surface for a @racket[bitmap%] object, while 12 | @racket[make-handle-brush] supports the creation of a brush from an 13 | existing Cairo surface. The representation of handles for these 14 | methods, however, is subject to change if the @racketmodname[racket/draw] 15 | library is implemented differently in the future. 16 | 17 | @section{Handle Brushes} 18 | 19 | @defmodule[racket/draw/unsafe/brush] 20 | 21 | @defproc[(make-handle-brush [handle cpointer?] 22 | [width exact-nonnegative-integer?] 23 | [height exact-nonnegative-integer?] 24 | [transformation (or/c #f (vector/c (vector/c real? real? real? 25 | real? real? real?) 26 | real? real? real? real? real?))] 27 | [#:copy? copy? any/c #t]) 28 | (is-a?/c brush%)]{ 29 | 30 | Creates a brush given a @racket[handle] that (currently) is a 31 | @tt{cairo_surface_t}. If @racket[copy?] is true, then the surface is 32 | copied, so that it can be freed or modified after the brush is 33 | created; if @racket[copy?] is @racket[#f], the surface must remain available 34 | and unchanged as long as the brush can be used. 35 | 36 | The @racket[width] and @racket[height] arguments specify the surface 37 | bounds for use when the surface must be copied---even when 38 | @racket[copy?] is @racket[#f]. The surface may need to be converted to a 39 | stipple bitmap, for example, when drawing to a monochrome target. 40 | 41 | The given surface is treated much like a stipple bitmap: it is 42 | implicitly repeated, and the given @racket[transformation] (if any) 43 | determines the surface's alignment relative to the target drawing 44 | context. 45 | 46 | When the brush is used with a @racket[record-dc%] object, and if that 47 | object's @method[record-dc% get-recorded-datum] method is called, then the 48 | surface is effectively converted to a stipple bitmap for the result datum.} 49 | 50 | 51 | @section{Cairo Library} 52 | 53 | @defmodule[racket/draw/unsafe/cairo-lib] 54 | 55 | @defthing[cairo-lib (or/c ffi-lib? #f)]{ 56 | 57 | A reference to the Cairo library for use with functions such as 58 | @racket[get-ffi-obj], or @racket[#f] if Cairo is unavailable.} 59 | 60 | 61 | -------------------------------------------------------------------------------- /draw-doc/scribblings/draw/water.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/draw/55819da32ae19b9c900bb2c64edb8600dd8c720d/draw-doc/scribblings/draw/water.png -------------------------------------------------------------------------------- /draw-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '(("base" #:version "8.17.0.3") 7 | ("draw-i386-macosx-3" #:platform "i386-macosx") 8 | ("draw-x86_64-macosx-3" #:platform "x86_64-macosx") 9 | ("draw-ppc-macosx-3" #:platform "ppc-macosx") 10 | ("draw-aarch64-macosx-3" #:platform "aarch64-macosx") 11 | ("draw-win32-i386-3" #:platform "win32\\i386") 12 | ("draw-win32-x86_64-3" #:platform "win32\\x86_64") 13 | ("draw-win32-arm64-3" #:platform "win32\\arm64") 14 | ("draw-x86_64-linux-natipkg-3" #:platform "x86_64-linux-natipkg") 15 | ("draw-x11-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg") 16 | ("draw-ttf-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg"))) 17 | 18 | (define pkg-desc "implementation (no documentation) part of \"draw\"") 19 | 20 | (define pkg-authors '(mflatt)) 21 | 22 | (define version "1.22") 23 | 24 | (define license 25 | '(Apache-2.0 OR MIT)) 26 | -------------------------------------------------------------------------------- /draw-lib/net/gifwrite.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require file/gif) 4 | (provide (all-from-out file/gif)) 5 | -------------------------------------------------------------------------------- /draw-lib/racket/draw.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/contract/base 4 | "draw/private/contract.rkt" 5 | "draw/private/color.rkt" 6 | "draw/private/point.rkt" 7 | "draw/private/font.rkt" 8 | "draw/private/font-dir.rkt" 9 | "draw/private/font-syms.rkt" 10 | "draw/private/pen.rkt" 11 | "draw/private/brush.rkt" 12 | "draw/private/gradient.rkt" 13 | "draw/private/region.rkt" 14 | "draw/private/bitmap.rkt" 15 | "draw/private/dc-path.rkt" 16 | "draw/private/dc-intf.rkt" 17 | "draw/private/bitmap-dc.rkt" 18 | "draw/private/record-dc.rkt" 19 | "draw/private/post-script-dc.rkt" 20 | "draw/private/ps-setup.rkt" 21 | "draw/private/svg-dc.rkt" 22 | "draw/private/gl-config.rkt" 23 | "draw/private/gl-context.rkt") 24 | 25 | (provide color-database<%> 26 | the-color-database 27 | font-list% the-font-list make-font 28 | font-name-directory<%> the-font-name-directory 29 | (contract-out 30 | [current-font-list (parameter/c (or/c (is-a?/c font-list%) #f))] 31 | [the-pen-list (instanceof/c pen-list%/c)] 32 | [the-brush-list (instanceof/c brush-list%/c)]) 33 | dc<%> 34 | recorded-datum->procedure 35 | ps-setup% current-ps-setup 36 | get-face-list 37 | get-family-builtin-face 38 | gl-context<%> 39 | get-current-gl-context 40 | (contract-out 41 | [make-bitmap ((exact-positive-integer? 42 | exact-positive-integer?) 43 | (any/c 44 | #:backing-scale (>/c 0.0)) 45 | . ->* . (instanceof/c bitmap%/c))] 46 | [make-platform-bitmap ((exact-positive-integer? 47 | exact-positive-integer?) 48 | (#:backing-scale (>/c 0.0)) 49 | . ->* . (instanceof/c bitmap%/c))] 50 | [make-monochrome-bitmap ((exact-positive-integer? 51 | exact-positive-integer?) 52 | ((or/c #f bytes?)) 53 | . ->* . (instanceof/c bitmap%/c))] 54 | [read-bitmap (((or/c path-string? input-port?)) 55 | ((or/c 'unknown 'unknown/mask 'unknown/alpha 56 | 'gif 'gif/mask 'gif/alpha 57 | 'jpeg 'jpeg/alpha 58 | 'png 'png/mask 'png/alpha 59 | 'xbm 'xbm/alpha 'xpm 'xpm/alpha 60 | 'bmp 'bmp/alpha) 61 | (or/c (is-a?/c color%) #f) 62 | any/c 63 | #:save-data-from-file? any/c 64 | #:backing-scale (>/c 0.0) 65 | #:try-@2x? any/c) 66 | . ->* . (instanceof/c bitmap%/c))]) 67 | 68 | ;; predicates/contracts 69 | brush-style/c 70 | pen-cap-style/c 71 | pen-join-style/c 72 | pen-style/c 73 | font-family/c 74 | font-weight/c 75 | font-style/c 76 | font-smoothing/c 77 | font-hinting/c 78 | font-feature-settings/c) 79 | 80 | (provide/contract [color% color%/c] 81 | [point% point%/c] 82 | [font% font%/c] 83 | [pen% pen%/c] 84 | [pen-list% pen-list%/c] 85 | [brush% brush%/c] 86 | [brush-list% brush-list%/c] 87 | [bitmap-dc% bitmap-dc%/c] 88 | [post-script-dc% post-script-dc%/c] 89 | [pdf-dc% pdf-dc%/c] 90 | [svg-dc% svg-dc%/c] 91 | [record-dc% record-dc%/c] 92 | [linear-gradient% linear-gradient%/c] 93 | [radial-gradient% radial-gradient%/c] 94 | [region% region%/c] 95 | [dc-path% dc-path%/c] 96 | [gl-config% gl-config%/c] 97 | [bitmap% bitmap%/c] 98 | [make-color make-color/c] 99 | [make-pen make-pen/c] 100 | [make-brush make-brush/c]) 101 | 102 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/draw-sig.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/signature 2 | 3 | bitmap% 4 | bitmap-dc% 5 | brush% 6 | brush-list% 7 | color% 8 | color-database<%> 9 | current-ps-setup 10 | dc<%> 11 | dc-path% 12 | font% 13 | font-list% 14 | font-name-directory<%> 15 | get-face-list 16 | get-family-builtin-face 17 | gl-config% 18 | gl-context<%> 19 | linear-gradient% 20 | make-bitmap 21 | make-platform-bitmap 22 | make-monochrome-bitmap 23 | pdf-dc% 24 | pen% 25 | pen-list% 26 | point% 27 | post-script-dc% 28 | ps-setup% 29 | radial-gradient% 30 | region% 31 | svg-dc% 32 | the-brush-list 33 | the-color-database 34 | the-font-list 35 | the-font-name-directory 36 | the-pen-list 37 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/draw-unit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/unit 3 | racket/draw 4 | "draw-sig.rkt") 5 | 6 | (provide draw@) 7 | (define-unit-from-context draw@ draw^) 8 | 9 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/bitmap-dc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | ffi/unsafe/atomic 4 | "syntax.rkt" 5 | "../unsafe/cairo.rkt" 6 | "color.rkt" 7 | "bitmap.rkt" 8 | "dc.rkt" 9 | "local.rkt") 10 | 11 | (provide bitmap-dc% 12 | bitmap-dc-backend%) 13 | 14 | (define bitmap-dc-backend% 15 | (class default-dc-backend% 16 | (init [(_bm bitmap) #f]) 17 | (inherit reset-cr) 18 | 19 | (define c #f) 20 | (define bm #f) 21 | (define b&w? #f) 22 | 23 | (super-new) 24 | 25 | (when _bm 26 | (do-set-bitmap _bm #f) 27 | ;; Needed if the bitmap has a device scale: 28 | (when c (init-cr-matrix c))) 29 | 30 | (define/override (init-cr-matrix cr) 31 | (when bm 32 | (define s (send bm get-cairo-device-scale)) 33 | (unless (= s 1) 34 | (cairo_scale cr s s))) 35 | (super init-cr-matrix cr)) 36 | 37 | (define/override (init-effective-matrix mx) 38 | (when bm 39 | (define s (send bm get-cairo-device-scale)) 40 | (unless (= s 1) 41 | (cairo_matrix_scale mx s s)))) 42 | 43 | (define/override (ok?) (and c #t)) 44 | 45 | (define/private (do-set-bitmap v reset?) 46 | (when c 47 | (cairo_destroy c) 48 | (set! c #f)) 49 | (set! bm v) 50 | (when (and bm (send bm ok?)) 51 | (set! c (cairo_create (send bm get-cairo-target-surface))) 52 | (set! b&w? (not (send bm is-color?))))) 53 | 54 | (define/public (internal-set-bitmap v [direct? #f]) 55 | (if direct? 56 | (do-set-bitmap v #t) 57 | (call-as-atomic 58 | (lambda () 59 | (do-set-bitmap v #t) 60 | (when c (reset-cr c)))))) 61 | 62 | (define/public (internal-get-bitmap) bm) 63 | 64 | (def/override (get-size) 65 | (let ([bm bm]) 66 | (if bm 67 | (values (exact->inexact (send bm get-width)) 68 | (exact->inexact (send bm get-height))) 69 | (values 1 1)))) 70 | 71 | (define/override (get-cr) c) 72 | (define/override (release-cr cr) (when bm (send bm drop-alpha-s))) 73 | 74 | (define/override (end-cr) (void)) 75 | 76 | (define/override (dc-adjust-smoothing s) 77 | (if b&w? 78 | 'unsmoothed 79 | s)) 80 | 81 | (def/override (get-backing-scale) 82 | (let ([bm (internal-get-bitmap)]) 83 | (if bm 84 | (exact->inexact (send bm get-backing-scale)) 85 | 1.0))) 86 | 87 | (define/override (install-color cr c a bg?) 88 | (if b&w? 89 | (begin 90 | (cairo_set_operator cr CAIRO_OPERATOR_SOURCE) 91 | (if (or (zero? a) 92 | (zero? (color-alpha c))) 93 | (super install-color cr c a bg?) 94 | (if (if bg? 95 | ;; Background: all non-black to white 96 | (not (and (= (color-red c) 0) 97 | (= (color-green c) 0) 98 | (= (color-blue c) 0) 99 | (= (color-alpha c) 1.0))) 100 | ;; Foreground: all non-white to black: 101 | (and (= (color-red c) 255) 102 | (= (color-green c) 255) 103 | (= (color-blue c) 255) 104 | (= (color-alpha c) 1.0))) 105 | (cairo_set_source_rgba cr 1.0 1.0 1.0 0.0) 106 | (cairo_set_source_rgba cr 0.0 0.0 0.0 1.0)))) 107 | (super install-color cr c a bg?))) 108 | 109 | (define/override (collapse-bitmap-b&w?) b&w?) 110 | 111 | (define/override (get-clear-operator) 112 | (if (or b&w? (and bm (send bm has-alpha-channel?))) 113 | CAIRO_OPERATOR_CLEAR 114 | CAIRO_OPERATOR_OVER)))) 115 | 116 | (define black (send the-color-database find-color "black")) 117 | 118 | (define bitmap-dc% 119 | (class (dc-mixin bitmap-dc-backend%) 120 | (inherit draw-bitmap-section 121 | internal-set-bitmap 122 | internal-get-bitmap 123 | get-size 124 | get-transformation 125 | set-transformation 126 | get-smoothing 127 | set-smoothing 128 | scale 129 | get-font) 130 | 131 | (def/override (get-gl-context) 132 | (let ([bm (internal-get-bitmap)]) 133 | (and bm 134 | (send bm get-bitmap-gl-context)))) 135 | 136 | (define/public (set-bitmap v) 137 | (internal-set-bitmap v)) 138 | 139 | (def/public (get-bitmap) 140 | (internal-get-bitmap)) 141 | 142 | (define/public (set-pixel x y c) 143 | (let ([s (bytes (inexact->exact (round (* 255 (color-alpha c)))) 144 | (color-red c) 145 | (color-green c) 146 | (color-blue c))]) 147 | (set-argb-pixels x y 1 1 s))) 148 | 149 | (define/public (get-pixel x y c) 150 | (let-values ([(w h) (get-size)]) 151 | (let ([b (make-bytes 4)]) 152 | (get-argb-pixels x y 1 1 b) 153 | (send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3) 154 | (/ (bytes-ref b 0) 255)) 155 | (and (<= 0 x w) (<= 0 y h))))) 156 | 157 | (define/public (set-argb-pixels x y w h bstr 158 | [set-alpha? #f] 159 | [pre-mult? #f]) 160 | (let ([bm (internal-get-bitmap)]) 161 | (when bm 162 | (send bm set-argb-pixels x y w h bstr set-alpha? pre-mult?)))) 163 | 164 | (define/public (get-argb-pixels x y w h bstr 165 | [get-alpha? #f] 166 | [pre-mult? #f]) 167 | (let ([bm (internal-get-bitmap)]) 168 | (when bm 169 | (send bm get-argb-pixels x y w h bstr get-alpha? pre-mult?)))) 170 | 171 | (define/public (draw-bitmap-section-smooth src dest-x dest-y 172 | dest-w dest-h 173 | src-x src-y 174 | src-w src-h 175 | [style 'solid] 176 | [color black] 177 | [mask #f]) 178 | (let ([sx (if (zero? src-w) 1.0 (/ dest-w src-w))] 179 | [sy (if (zero? src-h) 1.0 (/ dest-h src-h))]) 180 | (let ([t (get-transformation)] 181 | [s (get-smoothing)]) 182 | (scale sx sy) 183 | (when (eq? s 'unsmoothed) (set-smoothing 'aligned)) 184 | (begin0 185 | (draw-bitmap-section src (/ dest-x sx) (/ dest-y sy) src-x src-y src-w src-h style color mask) 186 | (when (eq? s 'unsmoothed) (set-smoothing 'unsmoothed)) 187 | (set-transformation t))))) 188 | 189 | (define/override (get-text-extent s 190 | [use-font (get-font)] 191 | [combine? #f] 192 | [offset 0]) 193 | (if (internal-get-bitmap) 194 | (super get-text-extent s use-font combine? offset) 195 | (send (get-temp-bitmap-dc) get-text-extent s use-font combine? offset))) 196 | 197 | (def/override (get-char-width) 198 | (if (internal-get-bitmap) 199 | (super get-char-width) 200 | (send (get-temp-bitmap-dc) get-char-width))) 201 | 202 | (def/override (get-char-height) 203 | (if (internal-get-bitmap) 204 | (super get-char-height) 205 | (send (get-temp-bitmap-dc) get-char-height))) 206 | 207 | (define temp-dc #f) 208 | (define/private (get-temp-bitmap-dc) 209 | (let ([dc (or (and temp-dc (weak-box-value temp-dc)) 210 | (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))]) 211 | (set! temp-dc (make-weak-box dc)) 212 | dc))]) 213 | (send dc set-font (get-font)) 214 | dc)) 215 | 216 | (super-new))) 217 | 218 | (install-bitmap-dc-class! bitmap-dc%) 219 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/brush.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | ffi/unsafe 4 | ffi/unsafe/atomic 5 | "../unsafe/cairo.rkt" 6 | "color.rkt" 7 | "syntax.rkt" 8 | "local.rkt" 9 | "bitmap.rkt" 10 | "gradient.rkt" 11 | "transform.rkt") 12 | 13 | (provide brush% 14 | make-brush 15 | brush-list% the-brush-list 16 | brush-style-symbol?) 17 | 18 | (define (brush-style-symbol? s) 19 | (memq s '(transparent solid opaque 20 | xor hilite panel 21 | bdiagonal-hatch crossdiag-hatch 22 | fdiagonal-hatch cross-hatch 23 | horizontal-hatch vertical-hatch))) 24 | 25 | (define black (send the-color-database find-color "black")) 26 | 27 | (define-local-member-name 28 | s-set-key 29 | set-surface-handle-info 30 | set-immutable) 31 | 32 | (defclass brush% object% 33 | (define key #f) 34 | (define/public (s-set-key k) (set! key k)) 35 | 36 | (define color black) 37 | (properties #:check-immutable check-immutable 38 | [[brush-style-symbol? style] 'solid]) 39 | 40 | (init [(_color color) black] 41 | [(_style style) 'solid] 42 | [(_stipple stipple) #f] 43 | [(_gradient gradient) #f] 44 | [(_transformation transformation) #f]) 45 | 46 | (set! color 47 | (cond 48 | [(string? _color) (or (send the-color-database find-color _color) black)] 49 | [(color . is-a? . color%) 50 | (color->immutable-color _color)] 51 | [else 52 | (raise-type-error (init-name 'brush%) 53 | "string or color%" 54 | _color)])) 55 | 56 | (set! style 57 | (if (brush-style-symbol? _style) 58 | _style 59 | (raise-type-error (init-name 'brush%) 60 | "brush style symbol" 61 | _style))) 62 | 63 | (define immutable? #f) 64 | (define lock-count 0) 65 | (define stipple #f) 66 | (define gradient #f) 67 | (define transformation #f) 68 | (define surface-handle #f) 69 | 70 | (when _gradient 71 | (unless (or (_gradient . is-a? . linear-gradient%) 72 | (_gradient . is-a? . radial-gradient%)) 73 | (raise-type-error (init-name 'brush%) 74 | "linear-gradient% object, radial-gradient% object, or #f" 75 | _gradient)) 76 | (set! gradient _gradient)) 77 | 78 | (when _stipple 79 | (unless (_stipple . is-a? . bitmap%) 80 | (raise-type-error (init-name 'brush%) 81 | "bitmap% or #f" 82 | _stipple))) 83 | 84 | (when _transformation 85 | (unless (transformation-vector? _transformation) 86 | (raise-type-error (init-name 'brush%) 87 | "transformation-vector" 88 | _transformation)) 89 | (when (or _gradient _stipple) 90 | (set! transformation (transformation-vector->immutable 91 | _transformation)))) 92 | 93 | (super-new) 94 | 95 | (when _stipple 96 | (set-stipple _stipple)) 97 | 98 | (define/public (set-immutable) (set! immutable? #t)) 99 | (define/public (is-immutable?) (or immutable? (positive? lock-count))) 100 | (define/public (adjust-lock v) (set! lock-count (+ lock-count v))) 101 | 102 | (define/private (check-immutable s) 103 | (when (or immutable? (positive? lock-count)) 104 | (error (method-name 'brush% s) "object is ~a" 105 | (if immutable? "immutable" "locked")))) 106 | 107 | (define/public (set-color . args) 108 | (check-immutable 'set-color) 109 | (case-args 110 | args 111 | [([color% _color]) 112 | (set! color (color->immutable-color _color))] 113 | [([string? _color]) 114 | (set! color (send the-color-database find-color _color))] 115 | [([byte? r] [byte? g] [byte? b]) 116 | (let ([c (make-object color% r g b)]) 117 | (send c set-immutable) 118 | (set! color c))] 119 | (method-name 'brush% 'set-color))) 120 | 121 | (define/public (get-color) color) 122 | (define/public (get-gradient) gradient) 123 | (define/public (get-transformation) transformation) 124 | 125 | (def/public (get-stipple) stipple) 126 | (define/public (set-stipple s [t #f]) 127 | (check-immutable 'set-stipple) 128 | (set! stipple s) 129 | (set! transformation (and s t))) 130 | 131 | (define/public (get-surface-handle-info) surface-handle) ; local 132 | (def/public (get-handle) (and surface-handle 133 | (vector-ref surface-handle 0))) 134 | (define/public (set-surface-handle-info h t) 135 | (set! surface-handle h) 136 | (set! transformation t))) 137 | 138 | ;; color style stipple gradient transformation -> brush% 139 | ;; produce an immutable brush% object 140 | (define (make-brush #:color [color black] 141 | #:style [style 'solid] 142 | #:stipple [stipple #f] 143 | #:gradient [gradient #f] 144 | #:transformation [transformation #f] 145 | #:immutable? [immutable? #t]) 146 | (or (and (not (or stipple gradient transformation (not immutable?))) 147 | (send the-brush-list find-or-create-brush color style)) 148 | (let () 149 | (define brush (make-object brush% color style stipple gradient transformation)) 150 | (when immutable? 151 | (send brush set-immutable)) 152 | brush))) 153 | 154 | ;; unsafe (and so exported by `racket/draw/unsafe/brush'): 155 | (provide (protect-out make-handle-brush)) 156 | (define (make-handle-brush handle width height [t #f] 157 | #:copy? [copy? #t]) 158 | ;; for argument checking: 159 | (define/top (make-handle-brush [cpointer? handle] 160 | [exact-nonnegative-integer? width] 161 | [exact-nonnegative-integer? height] 162 | [(make-or-false transformation-vector?) t]) 163 | 'ok) 164 | (make-handle-brush handle width height t) 165 | ;; arguments are ok, so proceed: 166 | (define s-in (cast handle _pointer _cairo_surface_t)) 167 | (define s 168 | (if copy? 169 | (let () 170 | (define s (cairo_surface_create_similar s-in CAIRO_CONTENT_COLOR_ALPHA width height)) 171 | (define cr (cairo_create s)) 172 | (let* ([p (cairo_pattern_create_for_surface s-in)]) 173 | (cairo_set_source cr p) 174 | (cairo_pattern_destroy p) 175 | (cairo_rectangle cr 0 0 width height) 176 | (cairo_fill cr) 177 | (cairo_destroy cr)) 178 | s) 179 | s-in)) 180 | (define b (new brush%)) 181 | (send b set-surface-handle-info (vector s width height 182 | ;; cache for bitmap version: 183 | #f 184 | ;; retain original if not copied: 185 | (if copy? #f handle)) 186 | t) 187 | b) 188 | 189 | (provide (protect-out surface-handle-info->bitmap)) 190 | (define (surface-handle-info->bitmap hi) 191 | (or (vector-ref hi 3) 192 | (let () 193 | (define width (vector-ref hi 1)) 194 | (define height (vector-ref hi 2)) 195 | (define bm (make-bitmap width height)) 196 | (define s (send bm get-cairo-surface)) 197 | (define cr (cairo_create s)) 198 | (let* ([p (cairo_pattern_create_for_surface (vector-ref hi 0))]) 199 | (cairo_set_source cr p) 200 | (cairo_pattern_destroy p) 201 | (cairo_rectangle cr 0 0 width height) 202 | (cairo_fill cr) 203 | (cairo_destroy cr)) 204 | (vector-set! hi 3 bm) 205 | bm))) 206 | 207 | ;; ---------------------------------------- 208 | 209 | (defclass brush-list% object% 210 | (define brushes (make-weak-hash)) 211 | (super-new) 212 | (define/public (find-or-create-brush . args) 213 | (let-values ([(col s) 214 | (case-args 215 | args 216 | [([color% _color] 217 | [brush-style-symbol? _style]) 218 | (values (color->immutable-color _color) _style)] 219 | [([string? _color] 220 | [brush-style-symbol? _style]) 221 | (values (or (send the-color-database find-color _color) 222 | black) 223 | _style)] 224 | (method-name 'find-or-create-brush 'brush-list%))]) 225 | (let ([key (vector (send col red) (send col green) (send col blue) 226 | (send col alpha) 227 | s)]) 228 | (start-atomic) 229 | (begin0 230 | (let ([e (hash-ref brushes key #f)]) 231 | (or (and e 232 | (ephemeron-value e)) 233 | (let* ([f (make-object brush% col s)] 234 | [e (make-ephemeron key f)]) 235 | (send f set-immutable) 236 | (send f s-set-key key) 237 | (hash-set! brushes key e) 238 | f))) 239 | (end-atomic)))))) 240 | 241 | (define the-brush-list (new brush-list%)) 242 | 243 | 244 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/dc-intf.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; drawing context interface 4 | 5 | (require "bitmap.rkt" 6 | "brush.rkt" 7 | "color.rkt" 8 | "dc-path.rkt" 9 | "font.rkt" 10 | "gl-context.rkt" 11 | "pen.rkt" 12 | "point.rkt" 13 | racket/class 14 | racket/contract) 15 | 16 | (provide dc<%>) 17 | 18 | ;; dummy value to avoid cycles via "region.rkt" 19 | (define region% object%) 20 | 21 | ;; repeated here from "contract.rkt" to avoid cycles 22 | (define pen-style/c 23 | (or/c 'transparent 'solid 'xor 'hilite 24 | 'dot 'long-dash 'short-dash 'dot-dash 25 | 'xor-dot 'xor-long-dash 'xor-short-dash 26 | 'xor-dot-dash)) 27 | 28 | (define brush-style/c 29 | (or/c 'transparent 'solid 'opaque 30 | 'xor 'hilite 'panel 31 | 'bdiagonal-hatch 'crossdiag-hatch 32 | 'fdiagonal-hatch 'cross-hatch 33 | 'horizontal-hatch 'vertical-hatch)) 34 | 35 | (define dc<%> 36 | (interface () 37 | [cache-font-metrics-key (->m exact-integer?)] 38 | [clear (->m void?)] 39 | [copy (->m real? real? 40 | (and/c real? (not/c negative?)) 41 | (and/c real? (not/c negative?)) 42 | real? real? 43 | void?)] 44 | [draw-arc (->m real? real? 45 | (and/c real? (not/c negative?)) 46 | (and/c real? (not/c negative?)) 47 | real? real? 48 | void?)] 49 | [draw-bitmap (->*m ((is-a?/c bitmap%) 50 | real? real?) 51 | ((or/c 'solid 'opaque 'xor) 52 | (is-a?/c color%) 53 | (or/c (is-a?/c bitmap%) #f)) 54 | boolean?)] 55 | [draw-bitmap-section (->*m ((is-a?/c bitmap%) 56 | real? real? 57 | real? real? 58 | (and/c real? (not/c negative?)) 59 | (and/c real? (not/c negative?))) 60 | ((or/c 'solid 'opaque 'xor) 61 | (is-a?/c color%) 62 | (or/c (is-a?/c bitmap%) #f)) 63 | boolean?)] 64 | [draw-ellipse (->m real? real? 65 | (and/c real? (not/c negative?)) 66 | (and/c real? (not/c negative?)) 67 | void?)] 68 | [draw-line (->m real? real? 69 | real? real? 70 | void?)] 71 | [draw-lines (->*m ((or/c (listof (is-a?/c point%)) 72 | (listof (cons/c real? real?)))) 73 | (real? real?) 74 | void?)] 75 | [draw-path (->*m ((is-a?/c dc-path%)) 76 | (real? real? (or/c 'odd-even 'winding)) 77 | void?)] 78 | [draw-point (->m real? real? void?)] 79 | [draw-polygon (->*m ((or/c (listof (is-a?/c point%)) 80 | (listof (cons/c real? real?)))) 81 | (real? real? (or/c 'odd-even 'winding)) 82 | void?)] 83 | [draw-rectangle (->m real? real? 84 | (and/c real? (not/c negative?)) 85 | (and/c real? (not/c negative?)) 86 | void?)] 87 | [draw-rounded-rectangle (->*m (real? real? 88 | (and/c real? (not/c negative?)) 89 | (and/c real? (not/c negative?))) 90 | (real?) 91 | void?)] 92 | [draw-spline (->m real? real? real? 93 | real? real? real? 94 | void?)] 95 | [draw-text (->*m (string? real? real?) 96 | (any/c exact-nonnegative-integer? real?) 97 | void?)] 98 | [end-doc (->m void?)] 99 | [end-page (->m void?)] 100 | [start-alpha (->m real? void?) 101 | #:public (lambda (a) (void))] 102 | [end-alpha (->m void?) 103 | #:public (lambda () (void))] 104 | [erase (->m void?)] 105 | [flush (->m void?)] 106 | [get-alpha (->m real?)] 107 | [get-background (->m (is-a?/c color%))] 108 | [get-backing-scale (->m (>/c 0.0))] 109 | [get-brush (->m (is-a?/c brush%))] 110 | [get-char-height (->m (and/c real? (not/c negative?)))] 111 | [get-char-width (->m (and/c real? (not/c negative?)))] 112 | [get-clipping-region (->m (or/c (is-a?/c region%) #f))] 113 | [get-device-scale (->m (values (and/c real? (not/c negative?)) 114 | (and/c real? (not/c negative?))))] 115 | [get-font (->m (is-a?/c font%))] 116 | [get-gl-context (->m (or/c (is-a?/c gl-context<%>) #f))] 117 | [get-initial-matrix (->m (vector/c real? real? real? 118 | real? real? real?))] 119 | [get-origin (->m (values real? real?))] 120 | [get-pen (->m (is-a?/c pen%))] 121 | [get-rotation (->m real?)] 122 | [get-scale (->m (values real? real?))] 123 | [get-size (->m (values (and/c real? (not/c negative?)) 124 | (and/c real? (not/c negative?))))] 125 | [get-smoothing (->m (or/c 'unsmoothed 'smoothed 'aligned))] 126 | [get-text-background (->m (is-a?/c color%))] 127 | [get-text-extent (->*m (string?) 128 | ((or/c (is-a?/c font%) #f) 129 | any/c 130 | exact-nonnegative-integer?) 131 | (values 132 | (and/c real? (not/c negative?)) 133 | (and/c real? (not/c negative?)) 134 | (and/c real? (not/c negative?)) 135 | (and/c real? (not/c negative?))))] 136 | [get-text-foreground (->m (is-a?/c color%))] 137 | [get-text-mode (->m (or/c 'solid 'transparent))] 138 | [get-transformation (->m (vector/c (vector/c real? real? real? 139 | real? real? real?) 140 | real? real? real? real? real?))] 141 | [glyph-exists? (->m char? boolean?)] 142 | [ok? (->m boolean?)] 143 | [resume-flush (->m void?)] 144 | [rotate (->m real? void?)] 145 | [scale (->m real? real? void?)] 146 | [set-alignment-scale (->m (>/c 0.0) void?)] 147 | [set-alpha (->m real? void?)] 148 | [set-background (->m (or/c (is-a?/c color%) string?) void?)] 149 | [set-brush (case->m (-> (is-a?/c brush%) void?) 150 | (-> (or/c (is-a?/c color%) string?) 151 | brush-style/c 152 | void?))] 153 | [set-clipping-rect (->m real? real? 154 | (and/c real? (not/c negative?)) 155 | (and/c real? (not/c negative?)) 156 | void?)] 157 | [set-clipping-region (->m (or/c (is-a?/c region%) #f) void?)] 158 | [set-font (->m (is-a?/c font%) void?)] 159 | [set-initial-matrix (->m (vector/c real? real? real? 160 | real? real? real?) 161 | void?)] 162 | [set-origin (->m real? real? void?)] 163 | [set-pen (case->m (-> (is-a?/c pen%) void?) 164 | (-> (or/c (is-a?/c color%) string?) 165 | real? 166 | pen-style/c 167 | void?))] 168 | [set-rotation (->m real? void?)] 169 | [set-scale (->m real? real? void?)] 170 | [set-smoothing (->m (or/c 'unsmoothed 'smoothed 'aligned) void?)] 171 | [set-text-background (->m (or/c (is-a?/c color%) string?) void?)] 172 | [set-text-foreground (->m (or/c (is-a?/c color%) string?) void?)] 173 | [set-text-mode (->m (or/c 'solid 'transparent) void?)] 174 | [set-transformation (->m (vector/c (vector/c real? real? real? 175 | real? real? real?) 176 | real? real? real? real? real?) 177 | void?)] 178 | [start-doc (->m string? void?)] 179 | [start-page (->m void?)] 180 | [suspend-flush (->m void?)] 181 | [transform (->m (vector/c real? real? real? real? real? real?) 182 | void?)] 183 | [translate (->m real? real? void?)] 184 | [try-color (->m (is-a?/c color%) (is-a?/c color%) void?)])) 185 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/define.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base) 3 | ffi/unsafe) 4 | 5 | (provide define-definer 6 | define-private-definer 7 | define-enum 8 | define/provide) 9 | 10 | (define-syntax define-enum 11 | (syntax-rules () 12 | [(_ n) (begin)] 13 | [(_ n id . ids) (begin 14 | (define id n) 15 | (provide id) 16 | (define-enum (+ n 1) . ids))])) 17 | (define-syntax-rule (define/provide id val) 18 | (begin 19 | (define id val) 20 | (provide id))) 21 | 22 | (define-syntax-rule (skip id) (begin)) 23 | 24 | (define-syntax-rule (define-definer LIB ffi-lib) 25 | (define-definer* LIB ffi-lib #t)) 26 | (define-syntax-rule (define-private-definer LIB ffi-lib) 27 | (define-definer* LIB ffi-lib #f)) 28 | 29 | (define (make-not-found id) 30 | (lambda args 31 | (error id "implementation not found; arguments where ~e" args))) 32 | 33 | (define (trace id proc) 34 | proc 35 | #; 36 | (lambda args 37 | (printf "~s\n" id) 38 | (apply proc args))) 39 | 40 | (define-syntax (define-definer* stx) 41 | (syntax-case stx () 42 | [(_ LIB ffi-lib p?) 43 | (let ([make-id 44 | (lambda (tmpl) 45 | (datum->syntax #'LIB 46 | (string->symbol (format tmpl (syntax-e #'LIB))) 47 | #'LIB))]) 48 | (with-syntax ([define-LIB/private (make-id "define-~a/private")] 49 | [define-LIB (make-id "define-~a")] 50 | [PROVIDE (if (syntax-e #'p?) 51 | #'provide 52 | #'skip)]) 53 | #`(begin 54 | (define-syntax define-LIB/private 55 | (syntax-rules () 56 | [(_ id c-id type fail #:wrap wrapper) 57 | (define id (trace 'c-id (wrapper (get-ffi-obj 'c-id ffi-lib type fail))))] 58 | [(_ id c-id type fail) 59 | (define-LIB/private id c-id type fail #:wrap values)] 60 | [(_ id type fail #:wrap wrapper) 61 | (define-LIB/private id id type fail #:wrap wrapper)] 62 | [(_ id type fail) 63 | (define-LIB/private id id type fail #:wrap values)] 64 | [(_ id type #:wrap wrapper) 65 | (define-LIB/private id id type (lambda () (make-not-found 'id)) #:wrap wrapper)] 66 | [(_ id type) 67 | (define-LIB/private id id type (lambda () (make-not-found 'id)) #:wrap values)])) 68 | 69 | (define-syntax define-LIB 70 | (syntax-rules () 71 | [(_ id type default #:wrap wrapper) 72 | (begin 73 | (PROVIDE id) 74 | (define-LIB/private id id type (lambda () default) #:wrap wrapper))] 75 | [(_ id type #:wrap wrapper) 76 | (define-LIB id type (make-not-found 'id) #:wrap wrapper)] 77 | [(_ id type) 78 | (define-LIB id type (make-not-found 'id) #:wrap values)] 79 | [(_ id type default) 80 | (define-LIB id type default #:wrap values)])))))])) 81 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/fmod.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe) 3 | 4 | (provide fmod) 5 | (define fmod (get-ffi-obj 'fmod #f (_fun _double _double -> _double))) 6 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/font-dir.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/contract/base 4 | "lock.rkt" 5 | "font-syms.rkt") 6 | 7 | (provide font-name-directory<%> 8 | the-font-name-directory 9 | get-family-builtin-face) 10 | 11 | (define font-name-directory% 12 | (class object% 13 | 14 | (define table (make-hash)) 15 | (define reverse-table (make-hash)) 16 | (define ps-table (make-hash)) 17 | (define screen-table (make-hash)) 18 | 19 | (define/private (intern val) 20 | (atomically 21 | (hash-ref table val (lambda () 22 | (let ([n (add1 (hash-count table))]) 23 | (hash-set! table val n) 24 | (hash-set! reverse-table n val) 25 | n))))) 26 | 27 | (for-each (lambda (s) (intern s)) 28 | '(default decorative roman script 29 | swiss modern symbol system)) 30 | 31 | (define/public (find-family-default-font-id family) 32 | (intern family)) 33 | 34 | (define/public (find-or-create-font-id name family) 35 | (intern (cons name family))) 36 | 37 | (define/public (get-face-name id) 38 | (let ([v (atomically (hash-ref reverse-table id #f))]) 39 | (and v (pair? v) (car v)))) 40 | 41 | (define/public (get-family id) 42 | (let ([v (atomically (hash-ref reverse-table id #f))]) 43 | (or (and (pair? v) (cdr v)) 44 | (and (symbol? v) v) 45 | 'default))) 46 | 47 | (define/public (get-font-id name family) 48 | (atomically (hash-ref table (cons string family) 0))) 49 | 50 | (define/private (default-font s) 51 | (case s 52 | [(modern) (case (system-type) 53 | [(windows macosx) "Courier New"] 54 | [else "Monospace"])] 55 | [(roman) (case (system-type) 56 | [(windows) "Times New Roman"] 57 | [else "Serif"])] 58 | [(decorative swiss) (case (system-type) 59 | [(windows) "Arial"] 60 | [else "Helvetica"])] 61 | [(script) (case (system-type) 62 | [(macosx) "Apple Chancery, Italic"] 63 | [(windows) "Palatino Linotype, Italic"] 64 | [else "Chancery"])] 65 | [(symbol) "Symbol"] 66 | [else (case (system-type) 67 | [(windows) "Tahoma"] 68 | [(macosx) "Lucida Grande"] 69 | [else "Sans"])])) 70 | 71 | (define/public (get-post-script-name id w s) 72 | (let ([s (atomically 73 | (or (hash-ref ps-table (list id w s) #f) 74 | (hash-ref reverse-table id #f)))]) 75 | (cond 76 | [(pair? s) (car s)] 77 | [(symbol? s) (default-font s)] 78 | [else "Serif"]))) 79 | 80 | (define/public (get-screen-name id w s) 81 | (let ([s (atomically 82 | (or (hash-ref screen-table (list id w s) #f) 83 | (hash-ref reverse-table id #f)))]) 84 | (cond 85 | [(pair? s) (car s)] 86 | [(symbol? s) (default-font s)] 87 | [else "Serif"]))) 88 | 89 | (define/public (set-post-script-name id w s name) 90 | (atomically (hash-set! ps-table (list id w s) name))) 91 | 92 | (define/public (set-screen-name id w s name) 93 | (atomically (hash-set! screen-table (list id w s) name))) 94 | 95 | (super-new))) 96 | 97 | (define font-name-directory<%> 98 | (interface () 99 | [find-family-default-font-id (->m font-family/c exact-integer?)] 100 | [fint-or-create-font-id (->m string? font-family/c exact-integer?)] 101 | [get-face-name (->m exact-integer? (or/c string? #f))] 102 | [get-family (->m exact-integer? font-family/c)] 103 | [get-font-id (->m string? font-family/c exact-integer?)] 104 | [get-post-script-name 105 | (->m exact-integer? font-weight/c font-style/c (or/c string? #f))] 106 | [get-screen-name 107 | (->m exact-integer? font-weight/c font-style/c (or/c string? #f))] 108 | [set-post-script-name 109 | (->m exact-integer? font-weight/c font-style/c string? any)] 110 | [set-screen-name 111 | (->m exact-integer? font-weight/c font-style/c string? any)])) 112 | 113 | (define the-font-name-directory (new font-name-directory%)) 114 | 115 | (define (get-family-builtin-face family) 116 | (unless (memq family '(default decorative roman script swiss modern system symbol)) 117 | (raise-type-error 'get-family-builtin-face "family symbol" family)) 118 | (let ([id (send the-font-name-directory find-family-default-font-id family)]) 119 | (send the-font-name-directory get-screen-name id 'normal 'normal))) 120 | 121 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/font-syms.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; font utilities for contracts 4 | 5 | (require racket/contract/base 6 | racket/match) 7 | 8 | (provide family-symbol? style-symbol? weight-symbol? 9 | smoothing-symbol? hinting-symbol? 10 | font-family/c font-weight/c font-style/c 11 | font-smoothing/c font-hinting/c 12 | font-feature-settings/c) 13 | 14 | (define (family-symbol? s) 15 | (memq s '(default decorative roman script 16 | swiss modern symbol system))) 17 | 18 | (define (weight-symbol? s) 19 | (memq s '(thin ultralight light semilight book normal 20 | medium semibold bold ultrabold heavy ultraheavy))) 21 | 22 | (define (style-symbol? s) 23 | (memq s '(normal italic slant))) 24 | 25 | (define (smoothing-symbol? s) 26 | (memq s '(default smoothed unsmoothed partly-smoothed))) 27 | 28 | (define (hinting-symbol? s) 29 | (memq s '(aligned unaligned))) 30 | 31 | ;; TODO: eventually once all old checks are converted to 32 | ;; contracts, the above can be removed 33 | (define font-family/c (or/c 'default 'decorative 'roman 'script 'swiss 34 | 'modern 'symbol 'system)) 35 | 36 | (define font-weight/c (or/c (integer-in 100 1000) 37 | 'thin 'ultralight 'light 'semilight 'book 'normal 38 | 'medium 'semibold 'bold 'ultrabold 'heavy 'ultraheavy)) 39 | (define font-style/c (or/c 'normal 'italic 'slant)) 40 | (define font-smoothing/c (or/c 'default 'partly-smoothed 41 | 'smoothed 'unsmoothed)) 42 | (define font-hinting/c (or/c 'aligned 'unaligned)) 43 | 44 | ;; Note: The Pango documentation for `pango_attr_font_features_new` says that it 45 | ;; accepts OpenType font features as a string with “the syntax of the CSS 46 | ;; font-feature-settings property”. In turn, the CSS spec says that a tag string 47 | ;; must be exactly 4 characters in the “U+20–7E codepoint range”. 48 | ;; 49 | ;; However, in reality, Pango passes this string to HarfBuzz’s 50 | ;; `hb_feature_from_string` function, which does not implement CSS string 51 | ;; escapes. This means it’s impossible to correctly format a feature string for 52 | ;; a feature with a tag like ‘a'"b’ because there is no way to properly escape 53 | ;; both #\' and #\". 54 | ;; 55 | ;; However, in practice, all OpenType feature tags are strictly alphanumeric, 56 | ;; anyway. So we just disallow the " character, which avoids the problem. 57 | (define font-feature-tag/c (and/c string? #px"^[ !#-~]{4}$")) 58 | (define font-feature-settings/c (and/c hash-equal? 59 | hash-strong? 60 | (hash/c font-feature-tag/c 61 | exact-nonnegative-integer? 62 | #:immutable #t))) 63 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/gl-config.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | "syntax.rkt") 4 | 5 | (provide gl-config%) 6 | 7 | (defclass gl-config% object% 8 | (define hires-mode #f) 9 | (define/public (get-hires-mode) hires-mode) 10 | (define/public (set-hires-mode v) (set! hires-mode (and v #t))) 11 | 12 | (define legacy? #t) 13 | (define/public (get-legacy?) legacy?) 14 | (define/public (set-legacy? v) (set! legacy? (and v #t))) 15 | 16 | (define double-buffered? #t) 17 | (define/public (get-double-buffered) double-buffered?) 18 | (define/public (set-double-buffered v) (set! double-buffered? (and v #t))) 19 | 20 | (define stereo? #f) 21 | (define/public (get-stereo) stereo?) 22 | (define/public (set-stereo v) (set! stereo? (and v #t))) 23 | 24 | (define stencil-size 0) 25 | (define/public (get-stencil-size) stencil-size) 26 | (define/public (set-stencil-size s) 27 | (set! stencil-size s)) 28 | 29 | (define accum-size 0) 30 | (define/public (get-accum-size) accum-size) 31 | (define/public (set-accum-size s) 32 | (set! accum-size s)) 33 | 34 | (define depth-size 1) 35 | (define/public (get-depth-size) depth-size) 36 | (define/public (set-depth-size s) 37 | (set! depth-size s)) 38 | 39 | (define multisample-size 0) 40 | (define/public (get-multisample-size) multisample-size) 41 | (define/public (set-multisample-size s) 42 | (set! multisample-size s)) 43 | 44 | (define share-context #f) 45 | (define/public (get-share-context) share-context) 46 | (define/public (set-share-context s) 47 | (set! share-context s)) 48 | 49 | (define sync? #f) 50 | (define/public (get-sync-swap) sync?) 51 | (define/public (set-sync-swap on?) 52 | (set! sync? (and on? #t))) 53 | 54 | (super-new)) 55 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/gl-context.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/contract/base) 4 | 5 | (provide gl-context% 6 | gl-context<%> 7 | 8 | do-call-as-current 9 | do-swap-buffers 10 | 11 | get-current-gl-context) 12 | 13 | (define-local-member-name 14 | do-call-as-current 15 | do-swap-buffers) 16 | 17 | (define lock-ch (make-channel)) 18 | (define lock-holder-ch (make-channel)) 19 | (define (lock-manager) 20 | (define none '#(#f #f #f)) 21 | (let loop () 22 | (sync (handle-evt 23 | lock-ch 24 | (lambda (p) 25 | (let ([t (vector-ref p 0)] 26 | [ch (vector-ref p 2)]) 27 | (let waiting-loop () 28 | (sync (handle-evt 29 | (thread-dead-evt t) 30 | (lambda (v) (loop))) 31 | (handle-evt 32 | ch 33 | (lambda (v) (loop))) 34 | (handle-evt 35 | (channel-put-evt lock-holder-ch p) 36 | (lambda (v) (waiting-loop)))))))) 37 | (handle-evt 38 | (channel-put-evt lock-holder-ch none) 39 | (lambda (v) (loop)))))) 40 | (define manager-t (thread/suspend-to-kill lock-manager)) 41 | 42 | (define gl-context<%> 43 | (interface () 44 | [call-as-current (->*m [(-> any)] [evt? any/c] any)] 45 | [ok? (->m boolean?)] 46 | [swap-buffers (->m any)] 47 | [get-handle (->m any)])) 48 | 49 | (define current-gl-context (make-thread-cell #f)) 50 | (define (get-current-gl-context) (thread-cell-ref current-gl-context)) 51 | 52 | ;; Implemented by subclasses: 53 | (define gl-context% 54 | (class* object% (gl-context<%>) 55 | (define/private (with-gl-lock t alternate-evt enable-break?) 56 | (thread-resume manager-t (current-thread)) 57 | (define current (channel-get lock-holder-ch)) 58 | (if (and (eq? (vector-ref current 0) (current-thread)) 59 | (eq? (vector-ref current 1) this)) 60 | (t) 61 | ((if enable-break? sync/enable-break sync) 62 | (let ([ch (make-channel)]) 63 | (handle-evt (channel-put-evt lock-ch (vector (current-thread) this ch)) 64 | (lambda (val) 65 | (dynamic-wind 66 | (lambda () 67 | (thread-cell-set! current-gl-context this)) 68 | t 69 | (lambda () 70 | (thread-cell-set! current-gl-context #f) 71 | (channel-put ch #t)))))) 72 | alternate-evt))) 73 | 74 | (define/public (get-handle) 75 | #f) 76 | 77 | (define/public (call-as-current t [alternate-evt never-evt] [enable-breaks? #f]) 78 | (with-gl-lock 79 | (lambda () 80 | (do-call-as-current t)) 81 | alternate-evt 82 | enable-breaks?)) 83 | 84 | (define/public (swap-buffers) 85 | (with-gl-lock 86 | (lambda () 87 | (do-swap-buffers)) 88 | never-evt 89 | #f)) 90 | 91 | (define/public (ok?) #t) 92 | 93 | (define/public (do-call-as-current t) (t)) 94 | (define/public (do-swap-buffers t) (void)) 95 | 96 | (super-new))) 97 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/gradient.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | "syntax.rkt" 4 | "color.rkt") 5 | 6 | (provide linear-gradient% 7 | radial-gradient%) 8 | 9 | (define (check-reals name lst) 10 | (for ([x (in-list lst)]) 11 | (unless (real? x) 12 | (raise-type-error (init-name name) "real number" x)))) 13 | 14 | (define (check-radius name lst) 15 | (for ([x (in-list lst)]) 16 | (unless (and (real? x) (not (negative? x))) 17 | (raise-type-error (init-name name) "non-negative real number" x)))) 18 | 19 | (define (check-stops name stops) 20 | (unless (and (list? stops) 21 | (for/and ([x (in-list stops)]) 22 | (and (list? x) 23 | (= (length x) 2) 24 | (real? (car x)) 25 | (<= 0.0 (car x) 1.0) 26 | (is-a? (cadr x) color%)))) 27 | (raise-type-error (init-name name) 28 | "list of (list x c) where x is a real in [0,1] and c is a color%" 29 | stops))) 30 | 31 | (define linear-gradient% 32 | (class object% 33 | (init x0 y0 x1 y1 stops) 34 | (define _x0 x0) 35 | (define _y0 y0) 36 | (define _x1 x1) 37 | (define _y1 y1) 38 | (define _stops stops) 39 | 40 | (check-reals 'linear-gradient% (list x0 y0 x1 y1)) 41 | (check-stops 'linear-gradient% stops) 42 | 43 | (super-new) 44 | 45 | (define/public (get-line) (values _x0 _y0 _x1 _y1)) 46 | (define/public (get-stops) _stops))) 47 | 48 | (define radial-gradient% 49 | (class object% 50 | (init x0 y0 r0 x1 y1 r1 stops) 51 | (define _x0 x0) 52 | (define _y0 y0) 53 | (define _r0 r0) 54 | (define _x1 x1) 55 | (define _y1 y1) 56 | (define _r1 r1) 57 | (define _stops stops) 58 | 59 | (check-reals 'radial-gradient% (list _x0 _y0 _x1 _y1)) 60 | (check-radius 'radial-gradient% (list _r0 _r1)) 61 | (check-stops 'radial-gradient% stops) 62 | 63 | (super-new) 64 | 65 | (define/public (get-circles) (values _x0 _y0 _r0 _x1 _y1 _r1)) 66 | (define/public (get-stops) _stops))) 67 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/hold.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide with-holding) 4 | 5 | (define-syntax-rule (with-holding v expr) 6 | (let ([val v]) 7 | (begin0 8 | expr 9 | (done-with val)))) 10 | 11 | ;; Ensure no inline: 12 | (define done-with #f) 13 | (set! done-with void) 14 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/libs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe 3 | racket/runtime-path 4 | ffi/winapi 5 | setup/cross-system 6 | (for-syntax racket/base 7 | ffi/winapi 8 | setup/cross-system)) 9 | 10 | (provide define-runtime-lib 11 | win64? 12 | (for-syntax win64?)) 13 | 14 | (define-syntax define-runtime-lib 15 | ;; the ids macosx unix windows don't appear to be bound here, but I added win32 and win64 anyways 16 | (syntax-rules (macosx unix windows win32 win64 ffi-lib) 17 | [(_ lib-id 18 | [(unix) unix-lib] 19 | [(macosx) (ffi-lib mac-lib) ...] 20 | [(windows) (ffi-lib windows-lib) ...]) 21 | (begin 22 | (define-runtime-path-list libs 23 | #:runtime?-id runtime? 24 | (case (if runtime? (system-type) (cross-system-type)) 25 | [(macosx) '((so mac-lib) ...)] 26 | [(unix) null] 27 | [(windows) `((so windows-lib) ...)])) 28 | 29 | (define lib-id 30 | (if (null? libs) 31 | unix-lib 32 | (for/fold ([v #f]) ([lib (in-list libs)]) 33 | (ffi-lib lib)))))] 34 | [(_ lib-id 35 | [(unix) unix-lib] 36 | [(macosx) (ffi-lib mac-lib) ...] 37 | [(win32) (ffi-lib win32-lib) ...] 38 | [(win64) (ffi-lib win64-lib) ...]) 39 | (begin 40 | (define-runtime-path-list libs 41 | #:runtime?-id runtime? 42 | (case (if runtime? (system-type) (cross-system-type)) 43 | [(macosx) '((so mac-lib) ...)] 44 | [(unix) null] 45 | [(windows) 46 | (if win64? 47 | `((so win64-lib) ...) 48 | `((so win32-lib) ...))])) 49 | 50 | (define lib-id 51 | (if (null? libs) 52 | unix-lib 53 | (for/fold ([v #f]) ([lib (in-list libs)]) 54 | (ffi-lib lib)))))])) 55 | 56 | 57 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/local.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class) 3 | 4 | (provide (protect-out (all-defined-out))) 5 | 6 | (define-local-member-name 7 | ;; various 8 | adjust-lock 9 | 10 | ;; bitmap% 11 | get-cairo-surface 12 | get-cairo-target-surface 13 | get-cairo-alpha-surface 14 | get-cairo-device-scale 15 | release-bitmap-storage 16 | get-bitmap-gl-context 17 | drop-alpha-s 18 | draw-bitmap-to 19 | do-self-copy 20 | 21 | ;; bitmap-dc% 22 | internal-get-bitmap 23 | internal-set-bitmap 24 | 25 | ;; dc% 26 | in-cairo-context 27 | get-clipping-matrix 28 | reset-config 29 | internal-copy 30 | 31 | ;; region% 32 | install-region 33 | lock-region 34 | 35 | ;; font% and dc-backend<%> 36 | get-pango 37 | 38 | ;; font% 39 | get-ps-pango 40 | get-font-key 41 | 42 | ;; brush% 43 | get-surface-handle-info 44 | 45 | ;; dc-backend<%> 46 | get-cr 47 | release-cr 48 | release-unchanged-cr 49 | end-cr 50 | reset-cr 51 | flush-cr 52 | init-cr-matrix 53 | init-effective-matrix 54 | get-font-metrics-key 55 | install-color 56 | dc-adjust-smoothing 57 | dc-adjust-cap-shape 58 | get-hairline-width 59 | can-combine-text? 60 | can-mask-bitmap? 61 | reset-clip 62 | get-clear-operator) 63 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/lock.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe/atomic) 3 | (provide atomically) 4 | (define-syntax-rule 5 | (atomically e1 e2 ...) 6 | (begin (start-atomic) 7 | (begin0 (let () e1 e2 ...) 8 | (end-atomic)))) 9 | 10 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/lzw.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;;; Translated from Skippy for Common Lisp: 4 | ;;; 5 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; * Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; * Redistributions in binary form must reproduce the above 15 | ;;; copyright notice, this list of conditions and the following 16 | ;;; disclaimer in the documentation and/or other materials 17 | ;;; provided with the distribution. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 20 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 23 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 25 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 26 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 27 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 28 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 29 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | ;;; 31 | ;;;; Id: lzw.lisp,v 1.11 2007/01/03 22:01:10 xach Exp 32 | 33 | (provide lzw-decompress) 34 | 35 | (define (make-input-bitstream bstr) 36 | (let ([pos 0] 37 | [val 0] 38 | [bits 0] 39 | [limit (bytes-length bstr)]) 40 | (lambda (n) 41 | (let loop () 42 | (cond 43 | [(n . <= . bits) 44 | (begin0 45 | (bitwise-and val (sub1 (arithmetic-shift 1 n))) 46 | (set! val (arithmetic-shift val (- n))) 47 | (set! bits (- bits n)))] 48 | [(= pos limit) 49 | (add1 (arithmetic-shift 1 n))] 50 | [else 51 | (set! val (bitwise-ior (arithmetic-shift (bytes-ref bstr pos) 52 | bits) 53 | val)) 54 | (set! pos (add1 pos)) 55 | (set! bits (+ 8 bits)) 56 | (loop)]))))) 57 | 58 | (define (read-bits n bstream) 59 | (bstream n)) 60 | 61 | (define (lzw-decompress result-bstr code-size bstr) 62 | (let* ((entries (make-vector 4096 -1)) 63 | (preds (make-vector 4096 -1)) 64 | (clear-code (expt 2 code-size)) 65 | (end-of-input (+ clear-code 1)) 66 | (next-entry-index (+ clear-code 2)) 67 | (compression-size (add1 code-size)) 68 | (compression-threshold (* clear-code 2)) 69 | (just-emit? #f) 70 | (pos 0) 71 | (bitstream (make-input-bitstream bstr))) 72 | (for ([i (in-range clear-code)]) 73 | (vector-set! entries i i)) 74 | (letrec ([reset-table 75 | (lambda () 76 | (vector-fill! preds -1) 77 | (for ([i (in-range clear-code 4096)]) 78 | (vector-set! entries i -1)) 79 | (set! next-entry-index (+ clear-code 2)) 80 | (set! compression-size (add1 code-size)) 81 | (set! compression-threshold (* clear-code 2)) 82 | (set! just-emit? #f))] 83 | [root-value 84 | (lambda (code) 85 | (let loop ([code code]) 86 | (let ([pred (vector-ref preds code)]) 87 | (if (negative? pred) 88 | (vector-ref entries code) 89 | (loop pred)))))] 90 | [increase-compression-size! 91 | (lambda () 92 | (cond 93 | [(= compression-size 12) 94 | ;; 12 is the maximum compression size, so go into 95 | ;; "just emit" mode, which doesn't add new entries 96 | ;; until a reset 97 | (set! just-emit? #t)] 98 | [else 99 | (set! compression-size (add1 compression-size)) 100 | (set! compression-threshold (* compression-threshold 2))]))] 101 | [add-entry 102 | (lambda (entry pred) 103 | (when (>= pred next-entry-index) 104 | (error "Corrupt data in LZW stream")) 105 | (vector-set! preds next-entry-index pred) 106 | (vector-set! entries next-entry-index entry) 107 | (let ([result next-entry-index]) 108 | (set! next-entry-index (add1 next-entry-index)) 109 | (when (>= next-entry-index compression-threshold) 110 | (increase-compression-size!)) 111 | result))] 112 | [code-depth 113 | (lambda (code) 114 | (let loop ([depth 0] [code code]) 115 | (let ([pred (vector-ref preds code)]) 116 | (if (negative? pred) 117 | depth 118 | (loop (add1 depth) pred)))))] 119 | [output-code-string 120 | (lambda (code) 121 | (let ([j pos]) 122 | (let ([i (+ pos (code-depth code))]) 123 | (set! pos (add1 i)) 124 | (if (>= i (bytes-length result-bstr)) 125 | (log-warning "Too much input data for image, ignoring extra") 126 | (let loop ([code code] 127 | [i i]) 128 | ;; (printf "set ~a\n" (vector-ref entries code)) 129 | (bytes-set! result-bstr i (vector-ref entries code)) 130 | (when (i . > . j) 131 | (loop (vector-ref preds code) 132 | (sub1 i))))))))]) 133 | (let loop ([last-code -1]) 134 | (let ([code (read-bits compression-size bitstream)]) 135 | ;; (printf "~s: ~s ~s ~s\n" compression-size code clear-code end-of-input) 136 | (cond 137 | [(= code clear-code) 138 | (reset-table) 139 | (loop -1)] 140 | [(= code end-of-input) 141 | (void)] 142 | [(or just-emit? (= last-code -1)) 143 | (output-code-string code) 144 | (loop code)] 145 | [else 146 | (let ([entry (vector-ref entries code)]) 147 | (if (negative? entry) 148 | (let ([root (root-value last-code)]) 149 | (output-code-string (add-entry root last-code))) 150 | (let ([root (root-value code)]) 151 | (add-entry root last-code) 152 | (output-code-string code)))) 153 | (loop code)])))))) 154 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/page-dc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | "syntax.rkt") 4 | 5 | (provide doc+page-check-mixin 6 | multiple-pages-ok?) 7 | 8 | (define-local-member-name multiple-pages-ok?) 9 | 10 | (define-syntax check-page-active 11 | (syntax-rules () 12 | [(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)])) 13 | 14 | (define-syntax check-one-page-active 15 | (syntax-rules () 16 | [(_ check-page-status id simple ... (arg ... [opt ...])) 17 | (check-one-page-active 18 | check-page-status id 19 | simple ... 20 | (arg ...) 21 | (arg ... opt ...))] 22 | [(_ check-page-status id (arg ...) ...) 23 | (define/override id 24 | (case-lambda 25 | [(arg ...) (check-page-status 'id) (super id arg ...)] 26 | ...))])) 27 | 28 | (define (doc+page-check-mixin % class-name) 29 | (class % 30 | (inherit multiple-pages-ok?) 31 | 32 | (define status #f) 33 | (define did-one-page? #f) 34 | 35 | (define/override (start-doc s) 36 | (when status 37 | (raise-mismatch-error (method-name class-name 'start-doc) 38 | (case status 39 | [(done) 40 | "document has already been ended: "] 41 | [else 42 | "document has already been started: "]) 43 | this)) 44 | (set! status 'doc) 45 | (super start-doc s)) 46 | 47 | (define/override (end-doc) 48 | (unless (eq? status 'doc) 49 | (raise-mismatch-error (method-name class-name 'end-doc) 50 | (case status 51 | [(page) 52 | "current page has not been ended: "] 53 | [(done) 54 | "document is already ended: "] 55 | [(#f) 56 | "document is not started: "]) 57 | this)) 58 | (set! status 'done) 59 | (super end-doc)) 60 | 61 | (define/override (start-page) 62 | (unless (eq? status 'doc) 63 | (raise-mismatch-error (method-name class-name 'start-page) 64 | (if (eq? status 'page) 65 | "current page has not been ended: " 66 | "document is not started (use the `start-doc' method): ") 67 | this)) 68 | (when did-one-page? 69 | (unless (multiple-pages-ok?) 70 | (raise-mismatch-error (method-name class-name 'start-page) 71 | "cannot create multiple pages for encapsulated output: " 72 | this))) 73 | (set! status 'page) 74 | (set! did-one-page? #t) 75 | (super start-page)) 76 | 77 | (define/override (end-page) 78 | (unless (eq? status 'page) 79 | (raise-mismatch-error (method-name class-name 'end-page) 80 | "no page is currently started: " 81 | this)) 82 | (set! status 'doc) 83 | (super end-page)) 84 | 85 | (define/private (check-page-status the-method-name) 86 | (unless (eq? status 'page) 87 | (raise-mismatch-error (method-name class-name the-method-name) 88 | "no page is currently started (use `start-doc' and `start-page' before drawing): " 89 | this))) 90 | 91 | (check-page-active 92 | check-page-status 93 | (draw-bitmap source dest-x dest-y [style [color [mask]]]) 94 | (draw-bitmap-section source dest-x dest-y src-x src-y src-width src-height [style [color [mask]]]) 95 | (draw-polygon pts [x [y [fill]]]) 96 | (draw-lines pts [x [y]]) 97 | (draw-path path [x [y [fill]]]) 98 | (draw-ellipse x y w h) 99 | (draw-arc x y w h s e) 100 | (draw-text txt x y [combine? [offset [angle]]]) 101 | (draw-spline x1 y1 x2 y2 x3 y3) 102 | (draw-rounded-rectangle x y w h [r]) 103 | (draw-rectangle x y w h) 104 | (draw-point x y) 105 | (draw-line x1 y1 x2 y2) 106 | (clear) 107 | (erase)) 108 | 109 | (super-new))) 110 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/pen.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | ffi/unsafe/atomic 4 | "color.rkt" 5 | "syntax.rkt" 6 | "local.rkt" 7 | "bitmap.rkt") 8 | 9 | (provide pen% 10 | make-pen 11 | pen-list% the-pen-list 12 | pen-width? 13 | pen-style-symbol?) 14 | 15 | (define (pen-style-symbol? s) 16 | (memq s '(transparent solid xor hilite 17 | dot long-dash short-dash dot-dash 18 | xor-dot xor-long-dash xor-short-dash 19 | xor-dot-dash))) 20 | 21 | (define (pen-cap-symbol? s) 22 | (memq s '(round projecting butt))) 23 | 24 | (define (pen-join-symbol? s) 25 | (memq s '(round bevel miter))) 26 | 27 | (define (pen-width? v) 28 | (and (real? v) 29 | (>= v 0) 30 | (<= v 255))) 31 | 32 | (define black (send the-color-database find-color "black")) 33 | 34 | (define-local-member-name 35 | s-set-key 36 | set-immutable) 37 | 38 | (defclass pen% object% 39 | (define key #f) 40 | (define/public (s-set-key k) (set! key k)) 41 | 42 | (define immutable? #f) 43 | (define lock-count 0) 44 | (define stipple #f) 45 | 46 | (define color black) 47 | (properties #:check-immutable check-immutable 48 | [[pen-cap-symbol? cap] 'round] 49 | [[pen-join-symbol? join] 'round] 50 | [[pen-style-symbol? style] 'solid] 51 | [[pen-width? width] 0]) 52 | 53 | (init [(_color color) black] 54 | [(_width width) 0] 55 | [(_style style) 'solid] 56 | [(_cap cap) 'round] 57 | [(_join join) 'round] 58 | [(_stipple stipple) #f]) 59 | 60 | (set! color 61 | (cond 62 | [(string? _color) (or (send the-color-database find-color _color) black)] 63 | [(color . is-a? . color%) 64 | (color->immutable-color _color)] 65 | [else 66 | (raise-type-error (init-name 'pen%) 67 | "string or color%" 68 | _color)])) 69 | (set! width 70 | (if (pen-width? _width) 71 | _width 72 | (raise-type-error (init-name 'pen%) 73 | "real in [0, 255]" 74 | _width))) 75 | 76 | (set! style 77 | (if (pen-style-symbol? _style) 78 | _style 79 | (raise-type-error (init-name 'pen%) 80 | "pen style symbol" 81 | _style))) 82 | 83 | (set! cap 84 | (if (pen-cap-symbol? _cap) 85 | _cap 86 | (raise-type-error (init-name 'pen%) 87 | "pen cap symbol" 88 | _cap))) 89 | 90 | (set! join 91 | (if (pen-join-symbol? _join) 92 | _join 93 | (raise-type-error (init-name 'pen%) 94 | "pen join symbol" 95 | _join))) 96 | 97 | (when _stipple 98 | (unless (_stipple . is-a? . bitmap%) 99 | (raise-type-error (init-name 'pen%) 100 | "bitmap% or #f" 101 | _stipple))) 102 | 103 | (super-new) 104 | 105 | (when _stipple (set-stipple _stipple)) 106 | 107 | (define/public (set-immutable) (set! immutable? #t)) 108 | (define/public (is-immutable?) (or immutable? (positive? lock-count))) 109 | (define/public (adjust-lock v) (set! lock-count (+ lock-count v))) 110 | 111 | (define/private (check-immutable s) 112 | (when (or immutable? (positive? lock-count)) 113 | (error (method-name 'pen% s) "object is ~a" 114 | (if immutable? "immutable" "locked")))) 115 | 116 | (define/public (set-color . args) 117 | (check-immutable 'set-color) 118 | (case-args 119 | args 120 | [([color% _color]) 121 | (set! color (color->immutable-color _color))] 122 | [([string? _color]) 123 | (set! color (send the-color-database find-color _color))] 124 | [([byte? r] [byte? g] [byte? b]) 125 | (let ([c (make-object color% r g b)]) 126 | (send c set-immutable) 127 | (set! color c))] 128 | (method-name 'pen% 'set-color))) 129 | 130 | (define/public (get-color) color) 131 | 132 | (def/public (get-stipple) stipple) 133 | (define/public (set-stipple s) 134 | (check-immutable 'set-stipple) 135 | (set! stipple s))) 136 | 137 | ;; color width style cap join stipple -> pen% 138 | ;; produce an immutable pen% object 139 | (define (make-pen #:color [color black] 140 | #:width [width 0] 141 | #:style [style 'solid] 142 | #:cap [cap 'round] 143 | #:join [join 'round] 144 | #:stipple [stipple #f] 145 | #:immutable? [immutable? #t]) 146 | (or (and (not (or stipple (not immutable?))) 147 | (send the-pen-list find-or-create-pen color width style cap join)) 148 | (let () 149 | (define pen (make-object pen% color width style cap join stipple)) 150 | (when immutable? 151 | (send pen set-immutable)) 152 | pen))) 153 | 154 | ;; ---------------------------------------- 155 | 156 | (defclass pen-list% object% 157 | (define pens (make-weak-hash)) 158 | (super-new) 159 | (define/public (find-or-create-pen . args) 160 | (let-values ([(col w s c j) 161 | (case-args 162 | args 163 | [([color% _color] 164 | [pen-width? _width] 165 | [pen-style-symbol? _style] 166 | [pen-cap-symbol? [_cap 'round]] 167 | [pen-join-symbol? [_join 'round]]) 168 | (values (color->immutable-color _color) 169 | _width _style _cap _join)] 170 | [([string? _color] 171 | [pen-width? _width] 172 | [pen-style-symbol? _style] 173 | [pen-cap-symbol? [_cap 'round]] 174 | [pen-join-symbol? [_join 'round]]) 175 | (values (or (send the-color-database find-color _color) 176 | black) 177 | _width _style _cap _join)] 178 | (method-name 'find-or-create-pen 'pen-list%))]) 179 | (let ([key (vector (send col red) (send col green) (send col blue) 180 | (send col alpha) 181 | w s c j)]) 182 | (start-atomic) 183 | (begin0 184 | (let ([e (hash-ref pens key #f)]) 185 | (or (and e 186 | (ephemeron-value e)) 187 | (let* ([f (make-object pen% col w s c j)] 188 | [e (make-ephemeron key f)]) 189 | (send f set-immutable) 190 | (send f s-set-key key) 191 | (hash-set! pens key e) 192 | f))) 193 | (end-atomic)))))) 194 | 195 | (define the-pen-list (new pen-list%)) 196 | 197 | 198 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/point.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | "syntax.rkt") 4 | 5 | (provide point% point-x point-y 6 | list-of-pair-of-real?) 7 | 8 | (define-local-member-name x y) 9 | 10 | (define point% 11 | (class object% 12 | (init-field [x 0.0] 13 | [y 0.0]) 14 | (define/public (get-x) x) 15 | (define/public (get-y) y) 16 | (define/public (set-x v) (set! x (exact->inexact v))) 17 | (define/public (set-y v) (set! y (exact->inexact v))) 18 | (super-new))) 19 | 20 | (define point-x (class-field-accessor point% x)) 21 | (define point-y (class-field-accessor point% y)) 22 | 23 | (define (list-of-pair-of-real? p) 24 | (and (list? p) 25 | (andmap (lambda (p) (and (pair? p) 26 | (real? (car p)) 27 | (real? (cdr p)))) 28 | p))) 29 | 30 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/post-script-dc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/file 4 | racket/path 5 | racket/math 6 | "syntax.rkt" 7 | racket/gui/dynamic 8 | "../unsafe/cairo.rkt" 9 | "dc.rkt" 10 | "local.rkt" 11 | "ps-setup.rkt" 12 | "page-dc.rkt" 13 | "write-bytes.rkt") 14 | 15 | (provide post-script-dc% 16 | pdf-dc%) 17 | 18 | (define (make-dc-backend pdf?) 19 | (class default-dc-backend% 20 | (init [interactive #t] 21 | [parent #f] 22 | [use-paper-bbox #f] 23 | [as-eps #t] 24 | [(init-w width) #f] 25 | [(init-h height) #f] 26 | [output #f]) 27 | 28 | (let ([get-name (lambda () 29 | (init-name (if pdf? 'pdf-dc% 'post-script-dc%)))]) 30 | (unless (or (not init-w) 31 | (and (real? init-w) (not (negative? init-w)))) 32 | (raise-type-error (get-name) "nonnegative real or #f" init-w)) 33 | (unless (or (not init-h) 34 | (and (real? init-h) (not (negative? init-h)))) 35 | (raise-type-error (get-name) "nonnegative real or #f" init-h)) 36 | (unless (or (not output) 37 | (path-string? output) 38 | (output-port? output)) 39 | (raise-type-error (get-name) "path string, output port, or #f" output))) 40 | 41 | (define-values (s port close-port? writer width height landscape?) 42 | (let ([su (if interactive 43 | ((gui-dynamic-require 'get-ps-setup-from-user) #f parent) 44 | (current-ps-setup))]) 45 | (cond 46 | [su 47 | (unless (eq? su (current-ps-setup)) 48 | (send (current-ps-setup) copy-from su)) 49 | (let* ([pss (current-ps-setup)] 50 | [to-file? (eq? (send pss get-mode) 'file)] 51 | [get-file (lambda (fn) 52 | ((gui-dynamic-require 'put-file) 53 | (if pdf? 54 | "Save PDF As" 55 | "Save PostScript As") 56 | parent 57 | (and fn (path-only fn)) 58 | (and fn (file-name-from-path fn)) 59 | (if pdf? "pdf" "ps")))] 60 | [fn (if to-file? 61 | (or output 62 | (if interactive 63 | (get-file (send pss get-file)) 64 | (let ([fn (send pss get-file)]) 65 | (or fn (get-file #f))))) 66 | #f)]) 67 | (if (and to-file? 68 | (not fn)) 69 | (values #f #f #f #f #f #f #f) 70 | (let* ([paper (assoc (send pss get-paper-name) paper-sizes)] 71 | [w (ceiling 72 | (if (or (not init-w) use-paper-bbox) 73 | (cadr paper) 74 | init-w))] 75 | [h (ceiling 76 | (if (or (not init-h) use-paper-bbox) 77 | (caddr paper) 78 | init-h))] 79 | [landscape? (eq? (send pss get-orientation) 'landscape)] 80 | [file (if (output-port? fn) 81 | fn 82 | (open-output-file 83 | (or fn (make-temporary-file (if pdf? 84 | "draw~a.pdf" 85 | "draw~a.ps"))) 86 | #:exists 'truncate/replace))]) 87 | (let-values ([(w h) (if (and pdf? landscape?) 88 | (values h w) 89 | (values w h))] 90 | [(writer proc) (make-port-writer file)]) 91 | (values 92 | ((if pdf? 93 | cairo_pdf_surface_create_for_stream 94 | cairo_ps_surface_create_for_stream) 95 | proc 96 | w 97 | h) 98 | file 99 | (not (output-port? fn)) 100 | writer 101 | w 102 | h 103 | landscape?)))))] 104 | [else 105 | (values #f #f #f #f #f #f #f)]))) 106 | 107 | (define-values (margin-x margin-y) 108 | (if as-eps 109 | (values 0.0 0.0) 110 | (let ([xb (box 0)] [yb (box 0.0)]) 111 | (send (current-ps-setup) get-margin xb yb) 112 | (values (unbox xb) (unbox yb))))) 113 | (define-values (scale-x scale-y) 114 | (let ([xb (box 0)] [yb (box 0.0)]) 115 | (send (current-ps-setup) get-scaling xb yb) 116 | (values (unbox xb) (unbox yb)))) 117 | (define-values (trans-x trans-y) 118 | (if as-eps 119 | (values 0.0 0.0) 120 | (let ([xb (box 0)] [yb (box 0.0)]) 121 | (send (current-ps-setup) get-translation xb yb) 122 | (values (unbox xb) (unbox yb))))) 123 | 124 | (unless pdf? 125 | (when (and s as-eps) 126 | (cairo_ps_surface_set_eps s #t) 127 | ;; Cairo writes a %%BoundingBox that covers only the drawn points, 128 | ;; which arguably matches the EPS spec, but that isn't what we want. 129 | ;; Fortunately, Cairo will suppress its own %%BoundingBox if we 130 | ;; write one: 131 | (cairo_ps_surface_dsc_comment s (format "%%BoundingBox: ~a ~a ~a ~a" 0 0 width height))) 132 | (when (and s landscape?) 133 | (cairo_ps_surface_dsc_comment s "%%Orientation: Landscape"))) 134 | 135 | (define c (and s (cairo_create s))) 136 | 137 | (when s (cairo_surface_destroy s)) 138 | 139 | (define/override (ok?) (and c #t)) 140 | 141 | (define/override (get-cr) c) 142 | 143 | (def/override (get-size) 144 | (let ([w (exact->inexact (/ (- width margin-x margin-x) scale-x))] 145 | [h (exact->inexact (/ (- height margin-y margin-y) scale-y))]) 146 | (if (and (not pdf?) landscape?) 147 | (values h w) 148 | (values w h)))) 149 | 150 | (define/override (get-device-scale) 151 | (values scale-x scale-y)) 152 | 153 | (define/override (end-cr) 154 | (cairo_surface_finish s) 155 | (cairo_destroy c) 156 | (set! c #f) 157 | (set! s #f) 158 | (port-writer-wait writer) 159 | (set! writer #f) 160 | (when close-port? 161 | (close-output-port port)) 162 | (set! port #f)) 163 | 164 | (define/override (init-cr-matrix c) 165 | (cairo_translate c trans-x trans-y) 166 | (if (and landscape? (not pdf?)) 167 | (begin 168 | (cairo_translate c 0 height) 169 | (cairo_rotate c (/ pi -2)) 170 | (cairo_translate c margin-y margin-x) 171 | (cairo_scale c scale-y scale-x)) 172 | (begin 173 | (cairo_translate c margin-x margin-y) 174 | (cairo_scale c scale-x scale-y)))) 175 | 176 | (define/override (get-pango font) 177 | (send font get-ps-pango)) 178 | 179 | (define/override (get-font-metrics-key sx sy) 180 | (if (and (= sx 1.0) (= sy 1.0)) 181 | 2 182 | 0)) 183 | 184 | (define/override (can-combine-text? sz) 185 | #t) 186 | 187 | (define/override (can-mask-bitmap?) 188 | #f) 189 | 190 | (define/override (dc-adjust-cap-shape shape sx pw) shape) 191 | (define/override (get-hairline-width cx) (/ 1.0 (* cx 4))) 192 | 193 | (define is-eps? (and as-eps #t)) 194 | (define/public (multiple-pages-ok?) (not is-eps?)) 195 | 196 | (super-new) 197 | 198 | (when c (init-cr-matrix c)))) 199 | 200 | (define post-script-dc% (class (doc+page-check-mixin (dc-mixin (make-dc-backend #f)) 201 | 'post-script-dc%) 202 | (super-new))) 203 | (define pdf-dc% (class (doc+page-check-mixin (dc-mixin (make-dc-backend #t)) 204 | 'pdf-dc%) 205 | (super-new))) 206 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/ps-setup.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | "syntax.rkt") 4 | 5 | (provide ps-setup% 6 | current-ps-setup 7 | paper-sizes 8 | 9 | get-native 10 | get-native-copy 11 | set-native) 12 | 13 | (define-local-member-name 14 | get-native 15 | get-native-copy 16 | set-native 17 | get-all-numerics) 18 | 19 | (define paper-sizes 20 | '(("A4 210 x 297 mm" 595 842) 21 | ("A3 297 x 420 mm" 842 1190) 22 | ("Letter 8 1/2 x 11 in" 612 792) 23 | ("Legal 8 1/2 x 14 in" 612 1008))) 24 | 25 | (define (paper-name-string? s) 26 | (and (string? s) 27 | (assoc s paper-sizes))) 28 | 29 | (define ps-setup% 30 | (class object% 31 | (properties 32 | [[string? command] "lpr"] 33 | [[(make-or-false path-string?) file] #f] 34 | [[bool? level-2] #t] 35 | [[(symbol-in preview file printer) mode] 'file] 36 | [[(symbol-in portrait landscape) orientation] 'portrait] 37 | [[paper-name-string? paper-name] "Letter 8 1/2 x 11 in"] 38 | [[string? preview-command] "gv"]) 39 | 40 | (define editor-margin-x 20.0) 41 | (define editor-margin-y 20.0) 42 | (define margin-x 16.0) 43 | (define margin-y 16.0) 44 | (define scale-x 0.8) 45 | (define scale-y 0.8) 46 | (define trans-x 0.0) 47 | (define trans-y 0.0) 48 | 49 | (define native #f) 50 | (define native-copier #f) 51 | (define/public (get-native) native) 52 | (define/public (get-native-copy) 53 | (values (and native (native-copier native)) 54 | native-copier)) 55 | (define/public (set-native n copier) 56 | (set! native n) 57 | (set! native-copier copier)) 58 | 59 | (def/public (copy-from [ps-setup% source] 60 | [any? [filename? #f]]) 61 | (set! command (send source get-command)) 62 | (when filename? (set! file (send source get-file))) 63 | (set! level-2 (send source get-level-2)) 64 | (set! mode (send source get-mode)) 65 | (set! orientation (send source get-orientation)) 66 | (set! paper-name (send source get-paper-name)) 67 | (set! preview-command (send source get-preview-command)) 68 | (set!-values (native native-copier) (send source get-native-copy)) 69 | (set!-values (editor-margin-x editor-margin-y 70 | margin-x margin-y 71 | scale-x scale-y 72 | trans-x trans-y) 73 | (send source get-all-numerics))) 74 | 75 | (define/public (get-all-numerics) 76 | (values editor-margin-x editor-margin-y 77 | margin-x margin-y 78 | scale-x scale-y 79 | trans-x trans-y)) 80 | 81 | (def/public (get-editor-margin [(make-box nonnegative-real?) x] 82 | [(make-box nonnegative-real?) y]) 83 | (set-box! x editor-margin-x) 84 | (set-box! y editor-margin-y)) 85 | (def/public (set-editor-margin [nonnegative-real? x] 86 | [nonnegative-real? y]) 87 | (set! editor-margin-x x) 88 | (set! editor-margin-y y)) 89 | 90 | (def/public (get-margin [(make-box nonnegative-real?) x] 91 | [(make-box nonnegative-real?) y]) 92 | (set-box! x margin-x) 93 | (set-box! y margin-y)) 94 | (def/public (set-margin [nonnegative-real? x] 95 | [nonnegative-real? y]) 96 | (set! margin-x x) 97 | (set! margin-y y)) 98 | 99 | (def/public (get-scaling [(make-box nonnegative-real?) x] 100 | [(make-box nonnegative-real?) y]) 101 | (set-box! x scale-x) 102 | (set-box! y scale-y)) 103 | (def/public (set-scaling [nonnegative-real? x] 104 | [nonnegative-real? y]) 105 | (set! scale-x x) 106 | (set! scale-y y)) 107 | 108 | (def/public (get-translation [(make-box nonnegative-real?) x] 109 | [(make-box nonnegative-real?) y]) 110 | (set-box! x trans-x) 111 | (set-box! y trans-y)) 112 | (def/public (set-translation [nonnegative-real? x] 113 | [nonnegative-real? y]) 114 | (set! trans-x x) 115 | (set! trans-y y)) 116 | 117 | (super-new))) 118 | 119 | (define current-ps-setup (make-parameter (new ps-setup%))) 120 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/svg-dc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | "syntax.rkt" 4 | "../unsafe/cairo.rkt" 5 | "dc.rkt" 6 | "local.rkt" 7 | "page-dc.rkt" 8 | "write-bytes.rkt") 9 | 10 | (provide svg-dc%) 11 | 12 | (define dc-backend% 13 | (class default-dc-backend% 14 | (init [(init-w width)] 15 | [(init-h height)] 16 | [(init-output output)] 17 | [exists 'error]) 18 | 19 | (unless (and (real? init-w) (not (negative? init-w))) 20 | (raise-type-error (init-name 'svg-dc%) "nonnegative real or #f" init-w)) 21 | (unless (and (real? init-h) (not (negative? init-h))) 22 | (raise-type-error (init-name 'svg-dc%) "nonnegative real or #f" init-h)) 23 | (unless (or (output-port? init-output) 24 | (path-string? init-output)) 25 | (raise-type-error (init-name 'svg-dc%) "path string or output port" init-output)) 26 | (unless (memq exists '(error append update can-update 27 | replace truncate 28 | must-truncate truncate/replace)) 29 | (raise-type-error (init-name 'svg-dc%) 30 | "'error, 'append, 'update, 'can-update, 'replace, 'truncate, 'must-truncate, or 'truncate/replace" 31 | exists)) 32 | 33 | (define width init-w) 34 | (define height init-h) 35 | (define close-port? (path-string? init-output)) 36 | 37 | (define port 38 | (if (output-port? init-output) 39 | init-output 40 | (open-output-file init-output #:exists exists))) 41 | (define-values (s writer) 42 | (let-values ([(writer proc) (make-port-writer port)]) 43 | (values (cairo_svg_surface_create_for_stream 44 | proc 45 | width 46 | height) 47 | writer))) 48 | 49 | (define c (and s (cairo_create s))) 50 | (when s (cairo_surface_destroy s)) 51 | 52 | (define/override (ok?) (and c #t)) 53 | 54 | (define/override (get-cr) c) 55 | 56 | (def/override (get-size) 57 | (values width height)) 58 | 59 | (define/override (end-cr) 60 | (cairo_surface_finish s) 61 | (cairo_destroy c) 62 | (set! c #f) 63 | (set! s #f) 64 | (port-writer-wait writer) 65 | (set! writer #f) 66 | (when close-port? 67 | (close-output-port port)) 68 | (set! port #f)) 69 | 70 | (define/override (get-pango font) 71 | (send font get-pango)) 72 | 73 | (define/override (get-font-metrics-key sx sy) 74 | (if (and (= sx 1.0) (= sy 1.0)) 75 | 3 76 | 0)) 77 | 78 | (define/override (can-combine-text? sz) 79 | #t) 80 | 81 | (define/public (multiple-pages-ok?) #t) 82 | 83 | (super-new))) 84 | 85 | (define svg-dc% (class (doc+page-check-mixin (dc-mixin dc-backend%) 86 | 'svg-dc%) 87 | (super-new))) 88 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/transform.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide matrix-vector? 4 | transformation-vector? 5 | transformation-vector->immutable) 6 | 7 | (define (matrix-vector? m) 8 | (and (vector? m) 9 | (= 6 (vector-length m)) 10 | (for/and ([e (in-vector m)]) 11 | (real? e)))) 12 | 13 | (define (transformation-vector? v) 14 | (and (vector? v) 15 | (= 6 (vector-length v)) 16 | (matrix-vector? (vector-ref v 0)) 17 | (real? (vector-ref v 1)) 18 | (real? (vector-ref v 2)) 19 | (real? (vector-ref v 3)) 20 | (real? (vector-ref v 4)) 21 | (real? (vector-ref v 5)))) 22 | 23 | (define (transformation-vector->immutable v) 24 | (if (and (immutable? v) 25 | (immutable? (vector-ref v 0))) 26 | v 27 | (vector-immutable 28 | (vector->immutable-vector (vector-ref v 0)) 29 | (vector-ref v 1) 30 | (vector-ref v 2) 31 | (vector-ref v 3) 32 | (vector-ref v 4) 33 | (vector-ref v 5)))) 34 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe) 3 | 4 | (provide define-mz 5 | define-enum 6 | define/provide) 7 | 8 | (define-syntax-rule (define-mz id type) 9 | (define id (get-ffi-obj 'id #f type))) 10 | 11 | (define-syntax define-enum 12 | (syntax-rules () 13 | [(_ n) (begin)] 14 | [(_ n id . ids) (begin 15 | (define id n) 16 | (provide id) 17 | (define-enum (+ n 1) . ids))])) 18 | 19 | (define-syntax-rule (define/provide id val) 20 | (begin 21 | (define id val) 22 | (provide id))) 23 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/write-bytes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe 3 | "../unsafe/cairo.rkt") 4 | 5 | (provide make-port-writer 6 | port-writer-wait) 7 | 8 | (define (make-port-writer port) 9 | (let ([t (thread/suspend-to-kill 10 | (lambda () 11 | (let loop () 12 | (let ([msg (thread-receive)]) 13 | (when (bytes? msg) 14 | (write-bytes msg port) 15 | (loop))))))]) 16 | (values t 17 | (lambda (bytes len) 18 | (define bstr (make-bytes len)) 19 | (memcpy bstr bytes len) 20 | (thread-send t bstr void) 21 | CAIRO_STATUS_SUCCESS)))) 22 | 23 | (define (port-writer-wait t) 24 | (thread-resume t) 25 | (thread-send t eof void) 26 | (thread-wait t)) 27 | 28 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/private/xp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe 3 | ffi/winapi) 4 | 5 | ;; Unfortunately, we sometimes need to do something different 6 | ;; under Windows XP 7 | 8 | (provide xp?) 9 | 10 | (define xp? 11 | (and (eq? 'windows (system-type)) 12 | (let* ([GetVersion (get-ffi-obj 'GetVersion 13 | (ffi-lib "kernel32.dll") 14 | (_fun #:abi winapi -> _int32))]) 15 | (= 5 (bitwise-and #xFF (GetVersion)))))) 16 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/unsafe/brush.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../private/brush.rkt") 4 | (provide make-handle-brush) 5 | 6 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/unsafe/bstr.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe) 3 | 4 | (provide (protect-out scheme_make_sized_byte_string)) 5 | 6 | (define (scheme_make_sized_byte_string ptr len copy) 7 | (cond 8 | [(positive? copy) 9 | (define actual-len (if (= len -1) 10 | (if ptr 11 | (let loop ([i 0]) 12 | (cond 13 | [(zero? (ptr-ref ptr _byte i)) i] 14 | [else (loop (add1 i))])) 15 | 0) 16 | len)) 17 | (define bstr (make-bytes actual-len)) 18 | (memcpy bstr ptr actual-len) 19 | bstr] 20 | [else (make-sized-byte-string ptr len)])) 21 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/unsafe/cairo-lib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe 3 | ffi/unsafe/define 4 | ffi/unsafe/alloc 5 | setup/dirs 6 | "../private/libs.rkt" 7 | "../private/utils.rkt") 8 | 9 | (define-runtime-lib fontconfig-lib 10 | [(unix) (ffi-lib "libfontconfig" '("1" ""))] 11 | [(macosx) 12 | (ffi-lib "libpng16.16.dylib") 13 | (ffi-lib "libexpat.1.dylib") 14 | (ffi-lib "libuuid.1.dylib") 15 | (ffi-lib "libfreetype.6.dylib") 16 | (ffi-lib "libfontconfig.1.dylib")] 17 | [(windows) 18 | (ffi-lib "zlib1.dll") 19 | (ffi-lib "libiconv-2.dll") 20 | (ffi-lib "libintl-9.dll") 21 | (ffi-lib "libpng16-16.dll") 22 | (ffi-lib "libexpat-1.dll") 23 | (ffi-lib "libfreetype-6.dll") 24 | (ffi-lib "libfontconfig-1.dll")]) 25 | 26 | (define-runtime-lib cairo-lib 27 | [(unix) (ffi-lib "libcairo" '("2" ""))] 28 | [(macosx) 29 | (ffi-lib "libpixman-1.0.dylib") 30 | (ffi-lib "libcairo.2.dylib")] 31 | [(windows) 32 | (ffi-lib "libpixman-1-0.dll") 33 | (ffi-lib "libcairo-2.dll")]) 34 | 35 | ;; A Racket-specific patch to Fontconfig defines FcSetFallbackDirs(), 36 | ;; which lets us set default paths to point to a Racket-specific 37 | ;; directory. If FcSetFallbackDirs() isn't defined, then we want 38 | ;; the system-defined directories, anyway. 39 | (let ([FcSetFallbackDirs (get-ffi-obj 'FcSetFallbackDirs 40 | fontconfig-lib 41 | (_fun _path _path -> _void) 42 | (lambda () #f))] 43 | [FcSetConfigDir (get-ffi-obj 'FcSetConfigDir 44 | fontconfig-lib 45 | (_fun _path -> _void) 46 | (lambda () #f))]) 47 | (when (and FcSetFallbackDirs 48 | FcSetConfigDir) 49 | (define share-dir (find-share-dir)) 50 | (when share-dir 51 | (FcSetFallbackDirs (build-path share-dir "fonts") 52 | (build-path (find-system-path 'addon-dir) "font-cache")) 53 | (FcSetConfigDir (build-path share-dir "fonts"))))) 54 | 55 | (provide (protect-out cairo-lib)) 56 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/unsafe/callback.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe 3 | racket/port) 4 | 5 | (provide callback-atomic? 6 | 7 | sanitize-input-port 8 | sanitize-output-port 9 | flush-sanitized-output) 10 | 11 | ;; The Racket BC can handle concurrent callbacks in different Racket 12 | ;; threads, because it copies the C stack in and out to implement 13 | ;; threads. The Racket CS cannot do that, so callbacks have to be 14 | ;; atomic. At the same time, we need some atomic callbacks to be able 15 | ;; to escape with an exception. 16 | 17 | (define callback-atomic? (eq? 'chez-scheme (system-type 'vm))) 18 | 19 | ;; Atomicity implies that a callback cannot read from or write to an 20 | ;; arbitrary port, so we have to "sanitize" a port by adding an 21 | ;; intermediary. Unfortunately, this means that reading from a port 22 | ;; has to be eager. 23 | 24 | (define output-ports (make-weak-hasheq)) 25 | 26 | (define (sanitize-input-port i) 27 | (cond 28 | [callback-atomic? 29 | (define-values (p-in p-out) (make-pipe)) 30 | (copy-port i p-out) 31 | (close-output-port p-out) 32 | p-in] 33 | [else i])) 34 | 35 | (define (sanitize-output-port o #:key [key o]) 36 | (cond 37 | [callback-atomic? 38 | (define-values (p-in p-out) (make-pipe)) 39 | (hash-set! output-ports key 40 | (make-ephemeron key 41 | (lambda () 42 | (close-output-port p-out) 43 | (copy-port p-in o)))) 44 | p-out] 45 | [else o])) 46 | 47 | (define (flush-sanitized-output key) 48 | (define e (hash-ref output-ports key #f)) 49 | (define thunk (and e (ephemeron-value e))) 50 | (when thunk (thunk))) 51 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/unsafe/glib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe 3 | ffi/unsafe/define 4 | ffi/unsafe/vm 5 | "../private/libs.rkt") 6 | 7 | (provide (protect-out 8 | define-glib 9 | define-gmodule 10 | define-gobj)) 11 | 12 | (define-runtime-lib glib-lib 13 | [(unix) (ffi-lib "libglib-2.0" '("0" ""))] 14 | [(macosx) 15 | (ffi-lib "libintl.9.dylib") 16 | (ffi-lib "libglib-2.0.0.dylib")] 17 | [(windows) 18 | (ffi-lib "libiconv-2.dll") 19 | (ffi-lib "libintl-9.dll") 20 | (ffi-lib "libglib-2.0-0.dll")]) 21 | 22 | (define-runtime-lib gmodule-lib 23 | [(unix) (ffi-lib "libgmodule-2.0" '("0" ""))] 24 | [(macosx) 25 | (ffi-lib "libgthread-2.0.0.dylib") 26 | (ffi-lib "libgmodule-2.0.0.dylib")] 27 | [(windows) 28 | (ffi-lib "libgthread-2.0-0.dll") 29 | (ffi-lib "libgmodule-2.0-0.dll")]) 30 | 31 | (define-runtime-lib libffi-lib 32 | ;; needed by libgobject 33 | [(unix) 34 | ;; If an expected version is not available, then assume it's not 35 | ;; natipkg, and shared-library search when libgobject is loaded 36 | (ffi-lib "libffi" '("6" "7" "8" "") #:fail (lambda () #f))] 37 | [(macosx) 38 | (ffi-lib "libffi.6.dylib")] 39 | [(windows) 40 | (ffi-lib "libffi-6.dll")]) 41 | 42 | (define-runtime-lib gobj-lib 43 | [(unix) (ffi-lib "libgobject-2.0" '("0" ""))] 44 | [(macosx) 45 | (ffi-lib "libgobject-2.0.0.dylib")] 46 | [(windows) 47 | (ffi-lib "libgobject-2.0-0.dll")]) 48 | 49 | (define-ffi-definer define-glib glib-lib) 50 | (define-ffi-definer define-gmodule gmodule-lib) 51 | (define-ffi-definer define-gobj gobj-lib) 52 | 53 | ;; Route glib logging to Racket logging: 54 | (define-glib g_log_set_default_handler (_fun _fpointer _pointer -> _fpointer)) 55 | (case (system-type 'vm) 56 | [(racket) 57 | (define f (get-ffi-obj 'scheme_glib_log_message #f _fpointer (lambda () #f))) 58 | (when f 59 | (void (g_log_set_default_handler f #f)))] 60 | [(chez-scheme) 61 | (define f (vm-primitive 'glib-log-message)) 62 | (void (g_log_set_default_handler (cast f _uintptr _pointer) #f))]) 63 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/xbm.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide read-xbm) 4 | 5 | (define rx:define #rx#"#define[ \t]+[-A-Za-z0-9_]+[ \t]+([0-9]+)") 6 | (define rx:byte #rx#"0x([0-9a-fA-F][0-9a-fA-F])") 7 | 8 | (define (read-xbm in) 9 | (let/ec esc 10 | (let ([w (regexp-match rx:define in)] 11 | [h (regexp-match rx:define in)]) 12 | (if (and w h) 13 | (let ([w (string->number (bytes->string/latin-1 (cadr w)))] 14 | [h (string->number (bytes->string/latin-1 (cadr h)))]) 15 | (if (and (exact-integer? w) 16 | (exact-integer? h) 17 | (positive? w) 18 | (positive? h)) 19 | (values 20 | w 21 | h 22 | (list->vector 23 | (for/list ([i (in-range h)]) 24 | (list->bytes 25 | (for/list ([j (in-range (quotient (+ w 7) 8))]) 26 | (let ([m (regexp-match rx:byte in)]) 27 | (if m 28 | (string->number (bytes->string/latin-1 (cadr m)) 16) 29 | (esc #f #f #f)))))))) 30 | (values #f #f #f))) 31 | (values #f #f #f))))) 32 | -------------------------------------------------------------------------------- /draw-lib/racket/draw/xpm.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide read-xpm) 4 | 5 | (define rx:start ; maybe skip comments here? 6 | #px#"^\\s*static\\s+char\\s*\\*\\s*[^][\\s]+\\s*\\[\\s*\\]\\s*=\\s*\\{") 7 | 8 | (define rx:get-string ; skips spaces, comments, commas 9 | #rx#"^(?:[, \t\r\n]+|/\\*.*?\\*/)*\"([^\"\\]*)\"") 10 | 11 | (define rx:color-spec 12 | ;; look for a simple `c' color, only `None' or `#hhhhhh', skip an `s' one 13 | #px#"^(.)\\s*(?:s\\s*[^ ]+\\s*)?c\\s*(?i:(none)|#([0-9a-f]{6}))") 14 | 15 | (define (read-xpm in) 16 | (define (err why) (error 'read-xpm (format "~a: ~v" why in))) 17 | (define colors (make-hasheq)) ; byte -> RGBA as a 4-byte-string 18 | (define (get-string) 19 | (cond [(regexp-match rx:get-string in) => cadr] 20 | [else (err "insufficient strings")])) 21 | (define (bytes->int bs radix) 22 | (string->number (bytes->string/utf-8 bs) radix)) 23 | (define (read-color) 24 | (let ([s (regexp-match rx:color-spec (get-string))] 25 | [b (make-bytes 4 0)]) 26 | (unless (caddr s) ; matched "none" 27 | (let ([c (cadddr s)]) 28 | (bytes-set! b 0 (bytes->int (subbytes c 0 2) 16)) 29 | (bytes-set! b 1 (bytes->int (subbytes c 2 4) 16)) 30 | (bytes-set! b 2 (bytes->int (subbytes c 4 6) 16)) 31 | (bytes-set! b 3 #xFF))) 32 | (hash-set! colors (bytes-ref (cadr s) 0) b))) 33 | (define (read-meta) 34 | (define m 35 | (or (regexp-match 36 | #px"^\\s*([0-9]+)\\s*([0-9]+)\\s*([0-9]+)\\s*1(?:\\s|$)" 37 | (get-string)) 38 | (err "unrecognized format"))) 39 | (for ([i (in-range (bytes->int (cadddr m) 10))]) (read-color)) 40 | (values (bytes->int (cadr m) 10) (bytes->int (caddr m) 10))) 41 | (unless (equal? "/* XPM */" (read-line in 'any)) (err "not an XPM file")) 42 | (unless (regexp-match? rx:start in) (err "expected C prefix not found")) 43 | (let*-values ([(width height) (read-meta)] 44 | [(result) (make-vector height)] 45 | [(buflen) (* width 4)]) 46 | (for/list ([row (in-range height)]) 47 | (let ([line (get-string)] [buf (make-bytes buflen)]) 48 | (unless (= width (bytes-length line)) (err "malformed pixels data")) 49 | (for ([i (in-range width)]) 50 | (bytes-copy! buf (* 4 i) (hash-ref colors (bytes-ref line i)))) 51 | (vector-set! result row buf))) 52 | (values width height result))) 53 | -------------------------------------------------------------------------------- /draw-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base")) 6 | (define build-deps '("racket-index" 7 | "scheme-lib" 8 | "draw-lib" 9 | "racket-test" 10 | "sgl" 11 | "gui-lib" 12 | "rackunit-lib" 13 | "pconvert-lib" 14 | "compatibility-lib" 15 | "sandbox-lib")) 16 | (define update-implies '("draw-lib")) 17 | 18 | (define pkg-desc "tests for \"draw\"") 19 | 20 | (define pkg-authors '(mflatt)) 21 | 22 | (define license 23 | '(Apache-2.0 OR MIT)) 24 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/.gitignore: -------------------------------------------------------------------------------- 1 | /png-suite 2 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/bitmap-stress.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/draw 4 | racket/file) 5 | 6 | ;; Check memory-management in the bitmap/PNG/JPEG/etc. library by reading 7 | ;; and writing in many threads at the same time. 8 | 9 | (define (check src save-type [read-type 'unknown/alpha]) 10 | (printf "~s ~s\n" save-type read-type) 11 | (define ts 12 | (for/list ([i (in-range 1 #;40)]) 13 | (thread 14 | (lambda() 15 | (for ([i (in-range 10)]) 16 | (define bm (read-bitmap (collection-file-path src "icons"))) 17 | (define t (make-temporary-file)) 18 | (send bm save-file t save-type) 19 | (define bm2 (read-bitmap t read-type)) 20 | (define w (send bm get-width)) 21 | (define h (send bm get-width)) 22 | (define s1 (make-bytes (* w h 4))) 23 | (define s2 (make-bytes (* w h 4))) 24 | (send bm get-argb-pixels 0 0 w h s1) 25 | (send bm2 get-argb-pixels 0 0 w h s2) 26 | (case save-type 27 | [(jpeg) 28 | ;; JPEG is lossy, so use a fuzzy compare: 29 | (define diff (for/sum ([b1 (in-bytes s1)] 30 | [b2 (in-bytes s2)]) 31 | (- b2 b1))) 32 | (unless ((abs diff) . < . (* w h 1)) 33 | (error 'bitmap-stress "mismatch for ~s ~s: ~s ~s ~e" 34 | src save-type 35 | w h diff))] 36 | [else 37 | (unless (equal? s1 s2) 38 | (error 'bitmap-stress "mismatch for ~s ~s" src save-type))]) 39 | (delete-file t)))))) 40 | 41 | (for ([t (in-list ts)]) (sync t))) 42 | 43 | (check "PLT-206.png" 'png) 44 | (check "plt.jpg" 'jpeg) 45 | (check "htdp-icon.gif" 'png 'unknown) 46 | (check "help16x16.xpm" 'png 'unknown) 47 | (check "help16x16.xbm" 'png 'unknown) 48 | (check "help.bmp" 'png 'unknown) 49 | 50 | ;; Also check that we don't run out of C stack space due to error escapes 51 | (define (ones) 52 | (if (eq? 'racket (system-type 'vm)) 53 | ;; For the 'racket VM, we can further check that the port is read on demand 54 | (make-input-port 55 | 'ones 56 | (lambda (bstr) 57 | (bytes-set! bstr 0 1) 58 | 1) 59 | (lambda (bstr . args) 60 | (bytes-set! bstr 0 1) 61 | 1) 62 | void) 63 | ;; Assume other VMs read the poirt eagerly 64 | (open-input-bytes (bytes 1 1 1 1 1 1 1 1)))) 65 | 66 | (for ([i (in-range 25000)]) 67 | (when (zero? (modulo i 1000)) 68 | (printf "~s\n" i)) 69 | (with-handlers ([exn:fail? void]) 70 | (read-bitmap (ones) 'jpeg))) 71 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/blits.rkt: -------------------------------------------------------------------------------- 1 | #lang scheme/gui 2 | 3 | (define ok-frame (make-object frame% "Ok")) 4 | (define ok-panel #f) 5 | 6 | (define (try path mode color bg-color sx sy) 7 | (let ([bm (if (is-a? path bitmap%) 8 | path 9 | (make-object bitmap% path 'unknown/mask))]) 10 | (let ([w (inexact->exact (ceiling (* sx (send bm get-width))))] 11 | [h (inexact->exact (ceiling (* sy (send bm get-height))))]) 12 | (let* ([dest1 (make-object bitmap% w h)] 13 | [dest2 (make-object bitmap% w h)] 14 | [dc1 (make-object bitmap-dc% dest1)] 15 | [dc2 (make-object bitmap-dc% dest2)] 16 | [s1 (make-bytes (* w h 4))] 17 | [s2 (make-bytes (* w h 4))]) 18 | (send dc1 clear) 19 | (send dc2 clear) 20 | (send dc1 set-brush bg-color 'solid) 21 | (send dc1 draw-rectangle 0 0 w h) 22 | (send dc2 set-brush bg-color 'solid) 23 | (send dc2 draw-rectangle 0 0 w h) 24 | (send dc1 set-scale sx sy) 25 | (send dc2 set-scale sx sy) 26 | (send dc1 draw-bitmap bm 0 0 27 | mode color (send bm get-loaded-mask)) 28 | (send dc2 draw-bitmap bm 0 0 29 | mode color (send bm get-loaded-mask)) 30 | (send dc1 get-argb-pixels 0 0 w h s1) 31 | (send dc2 get-argb-pixels 0 0 w h s2) 32 | (send dc1 set-bitmap #f) 33 | (send dc2 set-bitmap #f) 34 | (if (bytes=? s1 s2) 35 | (make-object message% dest1 ok-panel) 36 | (let ([f (make-object frame% "Different!")]) 37 | (make-object message% dest1 f) 38 | (make-object message% dest2 f) 39 | (send f show #t))))))) 40 | 41 | (define (self-mask path) 42 | (let ([bm (make-object bitmap% path)]) 43 | (send bm set-loaded-mask bm) 44 | bm)) 45 | 46 | (define (plus-mask path mpath) 47 | (let ([bm (make-object bitmap% path)] 48 | [xmbm (make-object bitmap% mpath)]) 49 | (let* ([w (send bm get-width)] 50 | [h (send bm get-height)] 51 | [mbm (make-object bitmap% w h (= 1 (send xmbm get-depth)))] 52 | [dc (make-object bitmap-dc% mbm)]) 53 | (send dc clear) 54 | (send dc draw-bitmap-section xmbm 0 0 0 0 w h) 55 | (send dc set-bitmap #f) 56 | (send bm set-loaded-mask mbm) 57 | bm))) 58 | 59 | (define targets 60 | (list 61 | ;; (collection-file-path "clock.png" "frtime" "tool") 62 | ;; (self-mask (collection-file-path "clock.png" "frtime" "tool")) 63 | (collection-file-path "foot-up.png" "icons") 64 | (collection-file-path "mred.xbm" "icons") 65 | (self-mask (collection-file-path "mred.xbm" "icons")) 66 | (plus-mask (collection-file-path "mred.xbm" "icons") 67 | (collection-file-path "PLT-206.png" "icons")) 68 | ;; (plus-mask (collection-file-path "clock.png" "frtime" "tool") 69 | ;; (collection-file-path "mred.xbm" "icons")) 70 | (collection-file-path "htdp-icon.gif" "icons") 71 | )) 72 | 73 | (for-each 74 | (lambda (mode) 75 | (for-each (lambda (sx sy) 76 | (set! ok-panel (make-object horizontal-panel% ok-frame)) 77 | (for-each 78 | (lambda (fg) 79 | (for-each (lambda (target) 80 | (try target 81 | mode 82 | fg 83 | (make-object color% "green") 84 | sx sy)) 85 | targets)) 86 | (list (make-object color% "black") 87 | (make-object color% "red")))) 88 | '(1 3/2 1/2) 89 | '(1 1/2 3/2))) 90 | '(solid opaque xor)) 91 | 92 | (module+ main 93 | (send ok-frame show #t)) 94 | 95 | (module+ test 96 | (send ok-frame show #t) 97 | (send ok-frame show #f)) 98 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/bmp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/draw 4 | racket/port 5 | rackunit) 6 | 7 | (define (check-image path) 8 | (define (go [solid? #f] [solid-bmp? solid?] 9 | #:bg-color [bg-color #f]) 10 | (define bm0 (read-bitmap path (if solid? 'unknown 'unknown/alpha) 11 | #:save-data-from-file? #t)) 12 | 13 | (let () 14 | (define bport (open-output-bytes)) 15 | (call-with-input-file path 16 | (λ (port) (copy-port port bport))) 17 | (check-equal? (vector (if solid? 'unknown 'unknown/alpha) 18 | #f 19 | (get-output-bytes bport)) 20 | (send bm0 get-data-from-file))) 21 | 22 | (define w (send bm0 get-width)) 23 | (define h (send bm0 get-height)) 24 | 25 | (define bm 26 | (if bg-color 27 | (let ([bm (make-bitmap w h)]) 28 | (define dc (send bm make-dc)) 29 | (send dc set-background bg-color) 30 | (send dc clear) 31 | (send dc draw-bitmap bm0 0 0) 32 | bm) 33 | bm0)) 34 | 35 | (define-values (i o) (make-pipe)) 36 | (send bm0 save-file o 'bmp) 37 | (close-output-port o) 38 | 39 | (define bm2 (read-bitmap i (if solid-bmp? 'unknown 'unknown/alpha) bg-color)) 40 | 41 | (when (send bm0 is-color?) 42 | (when (equal? solid? solid-bmp?) 43 | (check-equal? (send bm has-alpha-channel?) 44 | (send bm2 has-alpha-channel?)))) 45 | 46 | (define bstr (make-bytes (* w h 4))) 47 | (send bm get-argb-pixels 0 0 w h bstr) 48 | 49 | (define bstr2 (make-bytes (* w h 4))) 50 | (send bm2 get-argb-pixels 0 0 w h bstr2) 51 | 52 | (unless (equal? bstr bstr2) 53 | (for ([c (in-bytes bstr)] 54 | [c2 (in-bytes bstr2)]) 55 | (check-equal? c c2)))) 56 | (go #f) 57 | (go #t) 58 | (go #t #f) 59 | (go #f #t #:bg-color (make-color 0 0 255))) 60 | 61 | (check-image (collection-file-path "PLT-206.png" "icons")) 62 | (check-image (collection-file-path "heart.png" "icons")) 63 | (check-image (collection-file-path "trumpet.xbm" "icons")) 64 | 65 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/clip-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/draw 3 | racket/class) 4 | 5 | ;; Check for a bug in Cairo that we've explicitly patched: 6 | 7 | (define dc (new bitmap-dc% [bitmap (make-object bitmap% 100 100)])) 8 | (define pp (send dc get-pen)) 9 | (let ([p (send dc get-pen)]) 10 | (send dc set-pen (send the-pen-list find-or-create-pen (send p get-color) 11 | 1 12 | 'dot 13 | (send p get-cap) 14 | (send p get-join)))) 15 | (define fill (new region% [dc dc])) 16 | (send fill set-ellipse 10 10 10 10) 17 | (send dc set-clipping-region fill) 18 | (send dc draw-rectangle 0 0 100 50) 19 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/color.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | 5 | ;;======================================================== 6 | ;; Requirements 7 | ;;======================================================== 8 | 9 | (require 10 | (only-in racket/class 11 | make-object) 12 | (only-in racket/draw/private/color 13 | color% 14 | color->immutable-color) 15 | (only-in rackunit 16 | check-equal? 17 | check-not-equal?)) 18 | 19 | ;;======================================================== 20 | ;; Definitions 21 | ;;======================================================== 22 | 23 | (define black (make-object color% 0 0 0)) 24 | (define other-black (make-object color% 0 0 0)) 25 | (define red (make-object color% 255 0 0)) 26 | (define green (make-object color% 0 255 0)) 27 | (define blue (make-object color% 0 0 255)) 28 | (define half-red (make-object color% 255 0 0 0.5)) 29 | (define immutable-red (color->immutable-color red)) 30 | 31 | ;;======================================================== 32 | ;; Equality tests 33 | ;;======================================================== 34 | 35 | (check-equal? black black 36 | "color should be equal to itself") 37 | 38 | (check-equal? black other-black 39 | "color should be equal to identical color") 40 | 41 | (check-not-equal? black red 42 | "colors with different red values should be unequal") 43 | 44 | (check-not-equal? black green 45 | "colors with different green values should be unequal") 46 | 47 | (check-not-equal? black blue 48 | "colors with different blue values should be unequal") 49 | 50 | (check-not-equal? red half-red 51 | "colors with different alpha values should be unequal") 52 | 53 | (check-equal? red immutable-red 54 | "mutable and immutable color should be equal when RGBa are equal") 55 | 56 | ;;======================================================== 57 | ;; Hash-code tests 58 | ;;======================================================== 59 | 60 | (check-equal? (equal-hash-code black) 61 | (equal-hash-code other-black) 62 | "hashes of identical colors should be equal") 63 | 64 | (check-not-equal? (equal-hash-code black) 65 | (equal-hash-code red) 66 | "colors with different red values should have different hashes") 67 | 68 | (check-not-equal? (equal-hash-code black) 69 | (equal-hash-code green) 70 | "colors with different green values should have different hashes") 71 | 72 | (check-not-equal? (equal-hash-code black) 73 | (equal-hash-code blue) 74 | "colors with different blue values should have different hashes") 75 | 76 | (check-not-equal? (equal-hash-code red) 77 | (equal-hash-code half-red) 78 | "colors with different alpha values should have different hashes") 79 | 80 | (check-equal? (equal-hash-code red) 81 | (equal-hash-code immutable-red) 82 | "mutable and immutable color should have equal hashes") 83 | 84 | ;;======================================================== 85 | ;; Secondary hash-code tests 86 | ;;======================================================== 87 | 88 | (check-equal? (equal-secondary-hash-code black) 89 | (equal-secondary-hash-code other-black) 90 | "secondary hashes of identical colors should be equal") 91 | 92 | (check-not-equal? (equal-secondary-hash-code black) 93 | (equal-secondary-hash-code red) 94 | "colors with different red values should have different secondary hashes") 95 | 96 | (check-not-equal? (equal-secondary-hash-code black) 97 | (equal-secondary-hash-code green) 98 | "colors with different green values should have different secondary hashes") 99 | 100 | (check-not-equal? (equal-secondary-hash-code black) 101 | (equal-secondary-hash-code blue) 102 | "colors with different blue values should have different secondary hashes") 103 | 104 | (check-not-equal? (equal-secondary-hash-code red) 105 | (equal-secondary-hash-code half-red) 106 | "colors with different alpha values should have different secondary hashes") 107 | 108 | (check-equal? (equal-secondary-hash-code red) 109 | (equal-secondary-hash-code immutable-red) 110 | "mutable and immutable color should have equal secondary hashes")) 111 | 112 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/font-maps.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require racket/draw) 3 | 4 | ;; Check for pollution of font metrics from differently 5 | ;; scaled contexts. 6 | 7 | (define font (make-font #:face "Times")) 8 | 9 | ;; Running `go` might affect the result of `go2` 10 | (define (go) 11 | (define bm (make-bitmap 1 1)) 12 | (send (send bm make-dc) get-text-extent 13 | "Extra regexp" 14 | font 15 | #t)) 16 | 17 | ;; `go2` is like `go`, but for a different scale 18 | (define (go2) 19 | (define bm2 (make-platform-bitmap 1 1)) 20 | (define dc (send bm2 make-dc)) 21 | (send dc scale 1.25 1.25) 22 | (send dc get-text-extent 23 | "Extra regexp" 24 | font 25 | #t)) 26 | 27 | ;; Running `go2` again in a separate place might produce 28 | ;; results unaffected by `go`: 29 | (define (go2/p) 30 | (place pch (place-channel-put pch (call-with-values go2 list)))) 31 | 32 | (module+ test 33 | (call-with-values go void) 34 | (define l1 (call-with-values go2 list)) 35 | (define l2 (sync (go2/p))) 36 | (unless (equal? l1 l2) 37 | (error 'different "~s ~s" l1 l2))) 38 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/font.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/draw 4 | racket/class 5 | rackunit) 6 | 7 | (test-case 8 | "make-font is generative without a #:font-list argument" 9 | (check-not-eq? (make-font) (make-font)) 10 | (check-not-eq? (make-font) (make-font #:font-list the-font-list))) 11 | 12 | (test-case 13 | "make-font caches fonts when given a #:font-list argument" 14 | (check-eq? (make-font #:font-list the-font-list) 15 | (make-font #:font-list the-font-list))) 16 | 17 | (test-case 18 | "make-font with different #:font-list arguments returns different fonts" 19 | (define other-font-list (new font-list%)) 20 | (check-not-eq? (make-font #:font-list the-font-list) 21 | (make-font #:font-list other-font-list))) 22 | 23 | (test-case 24 | "make-font caches fonts by default when current-font-list is set" 25 | (parameterize ([current-font-list the-font-list]) 26 | (check-eq? (make-font) (make-font)))) 27 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/gif.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require file/gif 3 | rackunit) 4 | 5 | (define g (gif-start (open-output-bytes) 10 10 0 #f)) 6 | (check-equal? #t (gif-stream? g)) 7 | (check-equal? #t (image-ready-gif-stream? g)) 8 | (check-equal? #t (image-or-control-ready-gif-stream? g)) 9 | (check-equal? #t (empty-gif-stream? g)) 10 | 11 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define test-timeouts 3 | (list (list "bitmap-stress.rkt" 180))) 4 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/jpeg.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/draw 4 | racket/port 5 | racket/file) 6 | 7 | ;; Try JPEG reading and writing through ports that require synchronization 8 | 9 | (define bstr (file->bytes (collection-file-path "wizard-image.jpg" "icons"))) 10 | 11 | (define-values (i o) (make-pipe 16)) 12 | 13 | (void (thread (lambda () 14 | (write-bytes bstr o) 15 | (close-output-port o)))) 16 | 17 | (define bm (read-bitmap i)) 18 | 19 | (define-values (i2 o2) (make-pipe 16)) 20 | (define o3 (open-output-bytes)) 21 | 22 | (define copy-t 23 | (thread (lambda () 24 | (copy-port i2 o3) 25 | (close-output-port o3)))) 26 | 27 | (void (send bm save-file o2 'jpeg)) 28 | (close-output-port o2) 29 | 30 | (thread-wait copy-t) 31 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/png.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | (require racket/list) 3 | 4 | (module test racket/base) ; no test 5 | 6 | (define png-suite (build-path (or (current-load-relative-directory) 7 | (current-directory)) 8 | "png-suite")) 9 | 10 | (unless (directory-exists? png-suite) 11 | (error 'png-test 12 | (string-append 13 | "The png-suite subdirectory appears to be missing. " 14 | "It should contain the PNG test files (including GIFs for comparisons)."))) 15 | 16 | (define l (map (lambda (f) (path->string (build-path png-suite f))) 17 | (sort (filter (lambda (x) (regexp-match #rx"^[^x].*[.]png$" x)) 18 | (directory-list png-suite)) 19 | pathgif f) 22 | (regexp-replace #rx"[.]png$" f ".gif")) 23 | 24 | (define f (make-object frame% "Tester")) 25 | (define name (new message% 26 | [label (car l)] 27 | [parent f] 28 | [stretchable-width #t])) 29 | (define no-mask-bm (let* ([bm (make-object bitmap% 32 32 1)] 30 | [dc (make-object bitmap-dc% bm)]) 31 | (send dc clear) 32 | (send dc draw-line 0 0 32 32) 33 | (send dc draw-line 0 32 32 0) 34 | (send dc set-bitmap #f) 35 | bm)) 36 | 37 | (define last-bm (make-object bitmap% (car l))) 38 | 39 | (define ppng (make-object horizontal-panel% f)) 40 | (define png (new message% 41 | [label last-bm] 42 | [parent ppng] 43 | [stretchable-width #t] 44 | [stretchable-height #t])) 45 | (define pngm (new message% 46 | [label no-mask-bm] 47 | [parent ppng] 48 | [stretchable-width #t] 49 | [stretchable-height #t])) 50 | (define png-canvas (new canvas% 51 | [parent ppng] 52 | [stretchable-width #t] 53 | [stretchable-height #t] 54 | [paint-callback (lambda (c dc) 55 | (send dc set-brush 56 | (send the-brush-list find-or-create-brush "GREEN" 'solid)) 57 | (send dc draw-rectangle -1 -1 500 500) 58 | (send dc draw-bitmap 59 | last-bm 0 0 60 | 'solid 61 | (send the-color-database find-color "BLACK") 62 | (send last-bm get-loaded-mask)))])) 63 | (define ppng-mono (make-object vertical-panel% ppng)) 64 | (define mono? (new message% 65 | [label "mono"] 66 | [parent ppng-mono])) 67 | (define mono-mask? (new message% 68 | [label "mono mask"] 69 | [parent ppng-mono])) 70 | (unless (= 1 (send last-bm get-depth)) 71 | (send mono? show #f)) 72 | (unless (and (send last-bm get-loaded-mask) 73 | (= 1 (send (send last-bm get-loaded-mask) get-depth))) 74 | (send mono-mask? show #f)) 75 | 76 | (define gif (new message% 77 | [label (make-object bitmap% (png->gif (car l)))] 78 | [parent f] 79 | [stretchable-width #t] 80 | [stretchable-height #t])) 81 | 82 | (define pld (make-object group-box-panel% "Save and Reload" f)) 83 | (new button% 84 | [label "Go"] 85 | [parent pld] 86 | [callback (lambda (b e) 87 | (if (send last-bm save-file "tmp.png" 'png) 88 | (let ([bm (make-object bitmap% "tmp.png" (get-mask-mode) (get-bg-color))]) 89 | (send ld-png set-label (if (send bm ok?) 90 | bm 91 | no-mask-bm)) 92 | (send ld-pngm set-label (or (send bm get-loaded-mask) 93 | no-mask-bm)) 94 | (send ld-mono? show (and (send bm ok?) 95 | (= 1 (send bm get-depth)))) 96 | (send ld-mono-mask? show (and (send bm get-loaded-mask) 97 | (= 1 (send (send bm get-loaded-mask) get-depth))))) 98 | (error "write failed!")))]) 99 | (define ppld (make-object horizontal-panel% pld)) 100 | (define ld-png (new message% 101 | [label no-mask-bm] 102 | [parent ppld] 103 | [stretchable-width #t] 104 | [stretchable-height #t])) 105 | (define ld-pngm (new message% 106 | [label no-mask-bm] 107 | [parent ppld] 108 | [stretchable-width #t] 109 | [stretchable-height #t])) 110 | (define ppld-mono (make-object vertical-panel% ppld)) 111 | (define ld-mono? (new message% 112 | [label "mono"] 113 | [parent ppld-mono])) 114 | (define ld-mono-mask? (new message% 115 | [label "mono mask"] 116 | [parent ppld-mono])) 117 | (send ld-mono? show #f) 118 | (send ld-mono-mask? show #f) 119 | 120 | (define mask (new choice% 121 | [label "Alpha"] 122 | [choices '("Auto" "Mask")] 123 | [parent f] 124 | [callback (lambda (c e) (refresh))])) 125 | (define bg (new choice% 126 | [label "Background"] 127 | [choices '("Default" "White" "Black" "Red")] 128 | [parent f] 129 | [callback (lambda (c e) (refresh))])) 130 | 131 | (define slider 132 | (new slider% 133 | [label #f] 134 | [parent f] 135 | [min-value 1] 136 | [max-value (length l)] 137 | [init-value 1] 138 | [callback (lambda (s e) (refresh))])) 139 | (let ([p (make-object horizontal-panel% f)]) 140 | (make-object button% "Prev" p (lambda (b e) 141 | (send slider set-value (max 1 (sub1 (send slider get-value)))) 142 | (refresh))) 143 | (make-object vertical-pane% p) 144 | (make-object button% "Next" p (lambda (b e) 145 | (send slider set-value (min (length l) (add1 (send slider get-value)))) 146 | (refresh)))) 147 | 148 | (define (refresh) 149 | (let ([n (list-ref l (sub1 (send slider get-value)))]) 150 | (send name set-label n) 151 | (let ([bm (make-object bitmap% n (get-mask-mode) (get-bg-color))]) 152 | (set! last-bm bm) 153 | (send png set-label bm) 154 | (send pngm set-label (or (send bm get-loaded-mask) 155 | no-mask-bm))) 156 | (send gif set-label (make-object bitmap% (png->gif n))) 157 | (send mono? show (= 1 (send last-bm get-depth))) 158 | (send mono-mask? show (and (send last-bm get-loaded-mask) 159 | (= 1 (send (send last-bm get-loaded-mask) get-depth)))) 160 | (send png-canvas refresh))) 161 | 162 | (define (get-mask-mode) 163 | (case (send mask get-selection) 164 | [(0) 'unknown] 165 | [(1) 'unknown/mask])) 166 | 167 | (define get-bg-color 168 | (let ([white (make-object color% 255 255 255)] 169 | [black (make-object color% 0 0 0)] 170 | [red (make-object color% 255 0 0)]) 171 | (lambda () 172 | (case (send bg get-selection) 173 | [(0) #f] 174 | [(1) white] 175 | [(2) black] 176 | [(3) red])))) 177 | 178 | (send f show #t) 179 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/record-dc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/draw 4 | (only-in racket/draw/private/record-dc 5 | record-dc-mixin 6 | get-recorded-command)) 7 | 8 | (define bm1 (make-bitmap 100 100)) 9 | (define bm2 (make-bitmap 100 100)) 10 | (define bm3 (make-bitmap 100 100)) 11 | 12 | (define dc1 (make-object bitmap-dc% bm1)) 13 | (define dc2 (make-object (record-dc-mixin bitmap-dc%) bm2)) 14 | (define dc3 (make-object bitmap-dc% bm3)) 15 | 16 | (define (config dc) 17 | (send dc set-origin 2 3) 18 | (send dc set-scale 1.1 0.9) 19 | (send dc set-rotation 0.1) 20 | (send dc set-initial-matrix '#(1.0 -0.1 0.1 1.0 1.0 2.0)) 21 | (send dc set-pen "red" 2 'solid) 22 | (send dc set-brush "blue" 'solid) 23 | (send dc set-font (make-font #:size 32)) 24 | (send dc set-smoothing 'smoothed) 25 | (send dc set-text-mode 'solid) 26 | (send dc set-alpha 0.8) 27 | (send dc set-clipping-rect 5 5 95 95)) 28 | 29 | (define (draw dc) 30 | (send dc draw-ellipse 2 2 100 100) 31 | (send dc draw-text "Hello" 10 10)) 32 | 33 | (define (get-bytes bm) 34 | (define w (send bm get-width)) 35 | (define h (send bm get-height)) 36 | (define bstr (make-bytes (* 4 w h))) 37 | (send bm get-argb-pixels 0 0 w h bstr) 38 | bstr) 39 | 40 | (config dc1) 41 | (draw dc1) 42 | 43 | (define pre-bytes (get-bytes bm1)) 44 | 45 | (config dc2) 46 | (send dc2 erase) 47 | (draw dc2) 48 | 49 | (define middle-bytes (get-bytes bm2)) 50 | 51 | (define cms (send dc2 get-recorded-command)) 52 | 53 | (void (cms dc3)) 54 | 55 | (define post-bytes (get-bytes bm3)) 56 | 57 | (unless (equal? pre-bytes middle-bytes) 58 | (error "middle != pre")) 59 | 60 | (unless (equal? pre-bytes post-bytes) 61 | (error "post != pre")) 62 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/scale-png.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/draw 4 | racket/gui/base 5 | racket/file) 6 | 7 | (define (do-scale-test make-orig-bitmap) 8 | (define bm (make-orig-bitmap 20 20)) 9 | (define dc (send bm make-dc)) 10 | 11 | (send dc draw-rectangle 0 0 19 19) 12 | 13 | (define fn (make-temporary-file)) 14 | (void (send bm save-file fn 'png #:unscaled? #t)) 15 | 16 | (define bm2 (read-bitmap fn)) 17 | (delete-file fn) 18 | 19 | (define bm3 (make-bitmap 20 20 #:backing-scale (send bm get-backing-scale))) 20 | (define dc3 (send bm3 make-dc)) 21 | 22 | (void (send dc3 draw-bitmap bm 0 0)) 23 | 24 | (define (s v) 25 | (inexact->exact (ceiling (* v (send bm3 get-backing-scale))))) 26 | 27 | (define bstr2 (make-bytes (* 4 (send bm2 get-width) (send bm2 get-height)))) 28 | (define bstr3 (make-bytes (* 4 (s (send bm3 get-width)) (s (send bm3 get-height))))) 29 | 30 | (send bm2 get-argb-pixels 0 0 (send bm2 get-width) (send bm2 get-height) bstr2 #:unscaled? #t) 31 | (send bm3 get-argb-pixels 0 0 (s (send bm3 get-width)) (s (send bm3 get-height)) bstr3 #:unscaled? #t) 32 | 33 | (unless (equal? bstr2 bstr3) 34 | (error "scaled-bitmap PNG problem" make-orig-bitmap))) 35 | 36 | (do-scale-test make-screen-bitmap) 37 | (do-scale-test (lambda (w h) (make-platform-bitmap w h #:backing-scale 2))) 38 | (do-scale-test (lambda (w h) (make-bitmap w h #:backing-scale 2))) 39 | -------------------------------------------------------------------------------- /draw-test/tests/racket/draw/unsafe-draw.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe 3 | racket/draw/unsafe/cairo-lib 4 | racket/draw/unsafe/brush) 5 | 6 | (provide surface-brush) 7 | 8 | (define cairo_image_surface_create 9 | (get-ffi-obj 'cairo_image_surface_create cairo-lib (_fun _int _int _int -> _pointer))) 10 | (define cairo_surface_destroy 11 | (get-ffi-obj 'cairo_surface_destroy cairo-lib (_fun _pointer -> _void))) 12 | (define cairo_create 13 | (get-ffi-obj 'cairo_create cairo-lib (_fun _pointer -> _pointer))) 14 | (define cairo_destroy 15 | (get-ffi-obj 'cairo_destroy cairo-lib (_fun _pointer -> _void))) 16 | 17 | (define cairo_set_source_rgba 18 | (get-ffi-obj 'cairo_set_source_rgba cairo-lib (_fun _pointer _double* _double* _double* _double* -> _void))) 19 | (define cairo_rectangle 20 | (get-ffi-obj 'cairo_rectangle cairo-lib (_fun _pointer _double* _double* _double* _double* -> _void))) 21 | (define cairo_fill 22 | (get-ffi-obj 'cairo_fill cairo-lib (_fun _pointer -> _void))) 23 | 24 | (define s (cairo_image_surface_create 0 20 30)) 25 | (define cr (cairo_create s)) 26 | (cairo_set_source_rgba cr 1.0 0.0 0.0 0.5) 27 | (cairo_rectangle cr 2 2 16 26) 28 | (cairo_fill cr) 29 | (cairo_set_source_rgba cr 0.0 0.0 0.0 1.0) 30 | (cairo_rectangle cr 9 9 2 2) 31 | (cairo_fill cr) 32 | (cairo_destroy cr) 33 | 34 | (define surface-brush (make-handle-brush s 20 30 '#(#(1 0 0 1 420 320) 0 0 1 1 0))) 35 | 36 | (cairo_surface_destroy s) 37 | -------------------------------------------------------------------------------- /draw/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("draw-lib" 6 | "draw-doc")) 7 | (define implies '("draw-lib" 8 | "draw-doc")) 9 | 10 | (define pkg-desc "Drawing libraries") 11 | 12 | (define pkg-authors '(mflatt)) 13 | 14 | (define license 15 | '(Apache-2.0 OR MIT)) 16 | --------------------------------------------------------------------------------