Copyright (C) 2010 Thomas Chust <chust@web.de>.  All rights reserved.

Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the Software),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.

<h1><tt>base</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/base))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-base)</code></td>
	</tr>
</table>

Basic CD library support. Initializes the CD library when loaded.

<h2>Data Types</h2>

<h3><a id="canvas_"><code><nowiki>(canvas? [v any/c]) → boolean?</nowiki></code></a></h3>

Check whether a value is a CD canvas.

<h3><a id="context_"><code><nowiki>(context? [v any/c]) → boolean?</nowiki></code></a></h3>

Check whether a value is a CD driver context.

<h3><a id="state_"><code><nowiki>(state? [v any/c]) → boolean?</nowiki></code></a></h3>

Check whether a value is a CD canvas state.

<h2>Canvas Management</h2>

<h3><a id="context-capabilities"><code><nowiki>(context-capabilities [context context?]) → (listof symbol?)</nowiki></code></a></h3>

Returns a list of flags describing the capabilities supported by the given
context.

The following flags may show up in the list:
  *  <code>'flush</code>
  *  <code>'clear</code>
  *  <code>'play</code>
  *  <code>'y-axis</code>
  *  <code>'clip-area</code>
  *  <code>'clip-polygon</code>
  *  <code>'region</code>
  *  <code>'rectangle</code>
  *  <code>'chord</code>
  *  <code>'image/rgb</code>
  *  <code>'image/rgba</code>
  *  <code>'image/map</code>
  *  <code>'get-image/rgb</code>
  *  <code>'image/server</code>
  *  <code>'background</code>
  *  <code>'background-opacity</code>
  *  <code>'write-mode</code>
  *  <code>'line-style</code>
  *  <code>'line-width</code>
  *  <code>'fprimtives</code>
  *  <code>'hatch</code>
  *  <code>'stipple</code>
  *  <code>'pattern</code>
  *  <code>'font</code>
  *  <code>'font-dimensions</code>
  *  <code>'text-size</code>
  *  <code>'text-orientation</code>
  *  <code>'palette</code>
  *  <code>'line-cap</code>
  *  <code>'line-join</code>
  *  <code>'path</code>
  *  <code>'bezier</code>

<h3><a id="use-context_"><code><nowiki>[use-context+ (parameter/c any)]</nowiki></code></a></h3>

A parameter determining whether calls to <code>[#make-canvas|make-canvas]</code>
should use extended variants of the passed context drivers.

Defaults to <code>#f</code>.

<h3><a id="make-canvas"><code><nowiki>(make-canvas [context context?] [data (or/c string? pointer?)]) → canvas?</nowiki></code></a></h3>

Creates a new canvas with the given driver context. The <code>data</code> is
context specific and is either a string describing the setup of the new canvas
or a pointer to some native data object.

<h3><a id="call-with-canvas"><code>
	<nowiki>(call-with-canvas [canvas canvas?] [proc (-> canvas? any)]) → any</nowiki><br>
	<nowiki>(call-with-canvas [context context?] [data (or/c string? pointer?)] [proc (-> canvas? any)]) → any</nowiki>
</code></a></h3>

Calls the given procedure with the given canvas and makes sure the canvas is
synchronized with external resources around the call.

If called in the three argument form, a fresh canvas is created using the given
context and is automatically destroyed upon return from the given procedure.

<h3><a id="canvas-context"><code><nowiki>(canvas-context [canvas canvas?]) → context?</nowiki></code></a></h3>

Retrieves the context from a given canvas.

<h3><a id="canvas-simulate_"><code><nowiki>(canvas-simulate! [canvas canvas?] [flags (listof symbol?)]) → (listof symbol?)</nowiki></code></a></h3>

Sets flags determining which operations should be simulated by the given canvas.
Returns the previous set of flags.

The following flags may show up in the list:
  *  <code>'line</code>
  *  <code>'rectangle</code>
  *  <code>'box</code>
  *  <code>'arc</code>
  *  <code>'sector</code>
  *  <code>'chord</code>
  *  <code>'polyline</code>
  *  <code>'polygon</code>
  *  <code>'text</code>
  *  <code>'all</code>
  *  <code>'lines</code>
  *  <code>'fills</code>

<h3><a id="canvas-attribute"><code><nowiki>(canvas-attribute [canvas canvas?] [name (or/c symbol? string?)]) → (or/c string? #f)</nowiki></code></a></h3>

Retrieves the value of a context specific canvas attribute.

<h3><a id="canvas-attribute-set_"><code>
	<nowiki>(canvas-attribute-set! [canvas canvas?] [name (or/c symbol? string?)] [value (or/c string? #f)]) → void?</nowiki><br>
	<nowiki>(set! (canvas-attribute [canvas canvas?] [name (or/c symbol? string?)]) [value (or/c string? #f)]) → void?</nowiki>
</code></a></h3>

Sets the value of a context specific canvas attribute.

<h3><a id="canvas-state"><code><nowiki>(canvas-state [canvas canvas?]) → state?</nowiki></code></a></h3>

Extracts a representation of the current state from a canvas.

<h3><a id="canvas-state-set_"><code>
	<nowiki>(canvas-state-set! [canvas canvas?] [state state?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-state [canvas canvas?]) [state state?]) → void?</nowiki>
</code></a></h3>

Restores the given state of a canvas.

<h3><a id="canvas-clear_"><code><nowiki>(canvas-clear! [canvas canvas?]) → void?</nowiki></code></a></h3>

Clears a canvas to the background color.

<h3><a id="canvas-flush"><code><nowiki>(canvas-flush [canvas canvas?]) → void?</nowiki></code></a></h3>

Flushes all pending drawing operations in a canvas to its backend.

<h2>Coordinate System</h2>

<h3><a id="canvas-size"><code><nowiki>(canvas-size [canvas canvas?]) → (values integer? integer? real? real?)</nowiki></code></a></h3>

Retrieves the width and height of the given canvas in pixels and millimeters.

<h3><a id="canvas-mm->px"><code><nowiki>(canvas-mm->px [canvas canvas?] [x/mm real?] [y/mm real?]) → (values integer? integer?)</nowiki></code></a></h3>

Converts a position given in millimeters into a pixel position in the given
canvas.

<h3><a id="canvas-px->mm"><code><nowiki>(canvas-px->mm [canvas canvas?] [x/px integer?] [y/px integer?]) → (values real? real?)</nowiki></code></a></h3>

Converts a position given in pixels into a physical position in the given
canvas.

<h3><a id="canvas-origin"><code><nowiki>(canvas-origin [canvas canvas?]) → (values integer? integer?)</nowiki></code></a></h3>

Retrieves the position of the canvas' origin.

<h3><a id="canvas-origin-set_"><code><nowiki>(canvas-origin-set! [canvas canvas?] [x integer?] [y integer?]) → void?</nowiki></code></a></h3>

Defines the position of the canvas' origin.

<h3><a id="canvas-transform"><code><nowiki>(canvas-transform [canvas canvas?]) → (or/c (-> real? real? (values integer? integer?)) #f)</nowiki></code></a></h3>

Retrieves the active coordinate transformation of the given canvas.

<h3><a id="canvas-transform-set_"><code>
	<nowiki>(canvas-transform-set! [canvas canvas?] [proc (or/c (-> real? real? (values integer? integer?)) #f)]) → void?</nowiki><br>
	<nowiki>(set! (canvas-transform [canvas canvas?]) [proc (or/c (-> real? real? (values integer? integer?)) #f)]) → void?</nowiki>
</code></a></h3>

Defines the active coordinate transformation for the given canvas. The given
procedure must represent a linear transformation.

<h3><a id="canvas-transform-compose_"><code><nowiki>(canvas-transform-compose! [canvas canvas?] [proc (-> real? real? (values integer? integer?))]) → void?</nowiki></code></a></h3>

Modifies the active coordinate transformation for the given canvas by
left-multiplication with the given transformation. The given procedure must
represent a linear transformation.

<h3><a id="canvas-transform-translate_"><code><nowiki>(canvas-transform-translate! [canvas canvas?] [dx real?] [dy real?]) → void?</nowiki></code></a></h3>

Modifies the active coordinate transformation for the given canvas applying
a translation.

<h3><a id="canvas-transform-scale!"><code><nowiki>(canvas-transform-scale! [canvas canvas?] [sx real?] [sy real?]) → void?</nowiki></code></a></h3>

Modifies the active coordinate transformation for the given canvas applying
a scaling.

<h3><a id="canvas-transform-rotate!"><code><nowiki>(canvas-transform-rotate! [canvas canvas?] [alpha real?]) → void?</nowiki></code></a></h3>

Modifies the active coordinate transformation for the given canvas applying
a rotation around the origin.

<h2>General Attributes</h2>

<h3><a id="canvas-foreground"><code><nowiki>(canvas-foreground [canvas canvas?]) → integer?</nowiki></code></a></h3>

Retrieves the foreground color of the given canvas.

<h3><a id="canvas-foreground-set_"><code>
	<nowiki>(canvas-foreground-set! [canvas canvas?] [color integer?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-foreground [canvas canvas?]) [color integer?]) → void?</nowiki>
</code></a></h3>

Sets the foreground color of the given canvas.

<h3><a id="canvas-background"><code><nowiki>(canvas-background [canvas canvas?]) → integer?</nowiki></code></a></h3>

Retrieves the background color of the given canvas.

<h3><a id="canvas-background-set_"><code>
	<nowiki>(canvas-background-set! [canvas canvas?] [color integer?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-background [canvas canvas?]) [color integer?]) → void?</nowiki>
</code></a></h3>

Sets the background color of the given canvas.

<h3><a id="canvas-write-mode"><code><nowiki>(canvas-write-mode [canvas canvas?]) → symbol?</nowiki></code></a></h3>

Retrieves the write mode of the given canvas.

The mode may be one of the following symbols:
  *  <code>'replace</code>
  *  <code>'xor</code>
  *  <code>'not-xor</code>

<h3><a id="canvas-write-mode-set_"><code>
	<nowiki>(canvas-write-mode-set! [canvas canvas?] [mode symbol?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-write-mode [canvas canvas?]) [mode symbol?]) → void?</nowiki>
</code></a></h3>

Sets the write mode of the given canvas.

<h2>Clipping</h2>

<h3><a id="canvas-clip-mode"><code><nowiki>(canvas-clip-mode [canvas canvas?]) → (or/c symbol? #f)</nowiki></code></a></h3>

Retrieves the clipping mode of the given canvas.

The mode may be one of the following values:
  *  <code>'area</code>
  *  <code>'polygon</code>
  *  <code>'region</code>
  *  <code>#f</code>

In fact, <code>#t</code> is never returned but may be used when setting the
clipping mode.

<h3><a id="canvas-clip-mode-set_"><code>
	<nowiki>(canvas-clip-mode-set! [canvas canvas?] [mode (or/c symbol? #f)]) → void?</nowiki><br>
	<nowiki>(set! (canvas-clip-mode [canvas canvas?]) [mode (or/c symbol? #f)]) → void?</nowiki>
</code></a></h3>

Sets the clipping mode of the given canvas.

<h3><a id="canvas-clip-area"><code><nowiki>(canvas-clip-area [canvas canvas?]) → (values real? real? real? real?)</nowiki></code></a></h3>

Retrieves the current rectangular clipping area of the given canvas.

<h3><a id="canvas-clip-area-set_"><code><nowiki>(canvas-clip-area-set! [canvas canvas?] [x0 double?] [x1 double?] [y0 double?] [y1 double?]) → void?</nowiki></code></a></h3>

Sets the current rectangular clipping area of the given canvas.

<h2>Racket Specifics</h2>

<h3><a id="_canvas"><code>
	<nowiki>[_canvas ctype?]</nowiki><br>
	<nowiki>[_canvas/null ctype?]</nowiki><br>
</code></a></h3>

Foreign type of CD canvasses, which may optionally be <code>NULL</code>.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h3><a id="_context"><code>
	<nowiki>[_context ctype?]</nowiki><br>
	<nowiki>[_context/null ctype?]</nowiki><br>
</code></a></h3>

Foreign type of CD contexts, which may optionally be <code>NULL</code>.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h3><a id="_state"><code>
	<nowiki>[_state ctype?]</nowiki><br>
	<nowiki>[_state/null ctype?]</nowiki><br>
</code></a></h3>

Foreign type of CD states, which may optionally be <code>NULL</code>.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h2>CHICKEN Specifics</h2>

The <tt>base</tt> module only exports checking type conversion functions
instead of foreign types since the latter cannot be exported. To define
the types <code>canvas</code>, <code>nonnull-canvas</code>,
<code>context</code>, <code>nonnull-context</code>, <code>state</code> and
<code>nonnull-state</code> in your own module, include the file
<tt>"canvas-draw-types.scm"</tt>.

<h3><a id="canvas-_pointer"><code><nowiki>((canvas->pointer [nonnull? any/c]) [canvas (or/c canvas? #f)]) → (or/c pointer? #f)</nowiki></code></a></h3>

Checking conversion from canvasses to pointers.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h3><a id="pointer-_canvas"><code><nowiki>((pointer->canvas [nonnull? any/c]) [canvas (or/c pointer? #f)]) → (or/c canvas? #f)</nowiki></code></a></h3>

Checking conversion from pointers to canvasses.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h3><a id="context-_pointer"><code><nowiki>((context->pointer [nonnull? any/c]) [context (or/c context? #f)]) → (or/c pointer? #f)</nowiki></code></a></h3>

Checking conversion from contexts to pointers.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h3><a id="pointer-_context"><code><nowiki>((pointer->context [nonnull? any/c]) [context (or/c pointer? #f)]) → (or/c context? #f)</nowiki></code></a></h3>

Checking conversion from pointers to contexts.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h3><a id="state-_pointer"><code><nowiki>((state->pointer [nonnull? any/c]) [state (or/c state? #f)]) → (or/c pointer? #f)</nowiki></code></a></h3>

Checking conversion from states to pointers.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h3><a id="pointer-_state"><code><nowiki>((pointer->state [nonnull? any/c]) [state (or/c pointer? #f)]) → (or/c state? #f)</nowiki></code></a></h3>

Checking conversion from pointers to states.

Not re-exported from the <tt>[./main.wiki|main]</tt> module.

<h1><tt>cgm</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/cgm))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-cgm)</code></td>
	</tr>
</table>

CGM context support.

<h2>Context Types</h2>

<h3><a id="context:cgm"><code><nowiki>[context:cgm context?]</nowiki></code></a></h3>

Context type for CGM files.

<h1><tt>client</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/client))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-client)</code></td>
	</tr>
</table>

Client context support.

<h2>Context Types</h2>

<h3><a id="context:image"><code><nowiki>[context:image context?]</nowiki></code></a></h3>

Context type for client side pixel buffers.

<h3><a id="context:double-buffer"><code><nowiki>[context:double-buffer context?]</nowiki></code></a></h3>

Context type for client side double buffers.

<h2>Auxiliary Functions<h2>

<h3><a id="canvas-image_rgb"><code><nowiki>(canvas-image/rgb [canvas canvas?] [x integer?] [y integer?] [width integer?] [height integer?]) → blob?</nowiki></code></a></h3>

Retrieve a region of the given canvas as an RGB image.

<h3><a id="canvas-image-put_rgb_"><code>
	<nowiki>(canvas-image-put/rgb! [canvas canvas?] [x integer?] [y integer?] [width integer?] [height integer?] [data blob?] #:width [dst-width integer? 0] #:height [dst-height integer? 0] #:x0 [src-x0 integer? 0] #:x1 [src-x1 integer? 0] #:y0 [src-y0 integer? 0] #:y1 [src-y1 integer? 0]) → void?</nowiki><br>
	<nowiki>(set! (canvas-image/rgb [canvas canvas?] [x integer?] [y integer?] [width integer?] [height integer?]) [data blob?]) → void?</nowiki>
</code></a></h3>

Replace a region of the given canvas with an RGB image.

<h3><a id="canvas-image-put_rgba_"><code><nowiki>(canvas-image-put/rgba! [canvas canvas?] [x integer?] [y integer?] [width integer?] [height integer?] [data blob?] #:width [dst-width integer? 0] #:height [dst-height integer? 0] #:x0 [src-x0 integer? 0] #:x1 [src-x1 integer? 0] #:y0 [src-y0 integer? 0] #:y1 [src-y1 integer? 0]) → void?</nowiki></code></a></h3>

Replace a region of the given canvas with an RGBA image.

<h1><tt>clipboard</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/clipboard))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-clipboard)</code></td>
	</tr>
</table>

Clipboard context support.

<h2>Context Types</h2>

<h3><a id="context:clipboard"><code><nowiki>[context:clipboard context?]</nowiki></code></a></h3>

Context type for the system clipboard.

<h1><tt>debug</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/debug))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-debug)</code></td>
	</tr>
</table>

Debug log context support.

<h2>Context Types</h2>

<h3><a id="context:debug"><code><nowiki>[context:debug context?]</nowiki></code></a></h3>

Context type for debug log files.

<h1><tt>dgn</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/dgn))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-dgn)</code></td>
	</tr>
</table>

DGN context support.

<h2>Context Types</h2>

<h3><a id="context:dgn"><code><nowiki>[context:dgn context?]</nowiki></code></a></h3>

Context type for DGN files.

<h1><tt>dxf</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/dxf))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-dxf)</code></td>
	</tr>
</table>

DXF context support.

<h2>Context Types</h2>

<h3><a id="context:dxf"><code><nowiki>[context:dxf context?]</nowiki></code></a></h3>

Context type for DXF files.

<h1><tt>emf</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/emf))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-emf)</code></td>
	</tr>
</table>

EMF context support.

<h2>Context Types</h2>

<h3><a id="context:emf"><code><nowiki>[context:emf context?]</nowiki></code></a></h3>

Context type for EMF files.

<h1><tt>gl</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/gl))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-gl)</code></td>
	</tr>
</table>

OpenGL context support.

<h2>Context Types</h2>

<h3><a id="context:gl"><code><nowiki>[context:gl context?]</nowiki></code></a></h3>

Context type for OpenGL rendering.

<h1><tt>iup</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/iup))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-iup)</code></td>
	</tr>
</table>

IUP context support.

<h2>Context Types</h2>

<h3><a id="context:iup"><code><nowiki>[context:iup context?]</nowiki></code></a></h3>

Context type for IUP canvas widgets.

<h2>Auxiliary Functions<h2>

<h3><a id="make-canvas-action"><code><nowiki>(make-canvas-action [proc (-> canvas-draw:canvas? integer? integer? any)]) → (-> iup:canvas? integer? integer? any)</nowiki></code></a></h3>

Creates an IUP canvas action callback from a function operating on a Canvas Draw
canvas.

<h1><tt>main</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw)</code></td>
	</tr>
</table>

This module re-exports most bindings from the <tt>[./base.wiki|base]</tt>,
<tt>[./play.wiki|play]</tt> and <tt>[./primitives.wiki|primitives]</tt> modules.

To create canvasses you also have to import bindings from at least one of the
context modules: <tt>[./iup.wiki|iup]</tt>, <tt>[./native.wiki|native]</tt>,
<tt>[./gl.wiki|gl]</tt>, <tt>[./clipboard.wiki|clipboard]</tt>,
<tt>[./printer.wiki|printer]</tt>, <tt>[./picture.wiki|picture]</tt>,
<tt>[./server.wiki|server]</tt>, <tt>[./client.wiki|client]</tt>,
<tt>[./pdf.wiki|pdf]</tt>, <tt>[./ps.wiki|ps]</tt>, <tt>[./svg.wiki|svg]</tt>,
<tt>[./metafile.wiki|metafile]</tt>, <tt>[./debug.wiki|debug]</tt>,
<tt>[./cgm.wiki|cgm]</tt>, <tt>[./dgn.wiki|dgn]</tt>, <tt>[./dxf.wiki|dxf]</tt>,
<tt>[./emf.wiki|emf]</tt>, <tt>[./wmf.wiki|wmf]</tt>.

The foreign types and conversion procedures defined in <tt>[./base.wiki|base]</tt>
are not re-exported.

<h1><tt>metafile</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/metafile))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-metafile)</code></td>
	</tr>
</table>

Canvas Draw metafile context support.

<h2>Context Types</h2>

<h3><a id="context:metafile"><code><nowiki>[context:metafile context?]</nowiki></code></a></h3>

Context type for MF files.

<h1><tt>native</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/native))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-native)</code></td>
	</tr>
</table>

Native context support. Initializes context+ support when loaded.

<h2>Context Types</h2>

<h3><a id="context:native"><code><nowiki>[context:native context?]</nowiki></code></a></h3>

Context type for native windows.

<h2>Auxiliary Functions<h2>

<h3><a id="screen-size"><code><nowiki>(screen-size) → (values integer? integer? real? real?)</nowiki></code></a></h3>

Determines the width and height of the whole screen in pixels and millimeters.

<h1><tt>pdf</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/pdf))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-pdf)</code></td>
	</tr>
</table>

PDF context support.

<h2>Context Types</h2>

<h3><a id="context:pdf"><code><nowiki>[context:pdf context?]</nowiki></code></a></h3>

Context type for PDF files.

<h1><tt>picture</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/picture))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-picture)</code></td>
	</tr>
</table>

Picture context support.

<h2>Context Types</h2>

<h3><a id="context:picture"><code><nowiki>[context:picture context?]</nowiki></code></a></h3>

Context type for in-memory pictures.

<h1><tt>play</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/play))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-play)</code></td>
	</tr>
</table>

Replay functionality.

<h2>Context Content Replay</h2>

<h3><a id="canvas-play_"><code><nowiki>(canvas-play! [canvas canvas?] [context context?] [x0 integer?] [x1 integer?] [y0 integer?] [y1 integer?] [data (or/c string? pointer?)]) → void?</nowiki></code></a></h3>

Replays the drawing contained in the context with the given data in the given
canvas.

<h1><tt>primitives</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/primitives))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-primitives)</code></td>
	</tr>
</table>

Drawing primitives.

<h2>Points</h2>

<h3><a id="canvas-pixel_"><code><nowiki>(canvas-pixel! [canvas canvas?] [x integer?] [y integer?] [color integer? (canvas-foreground canvas)]) → void?</nowiki></code></a></h3>

Draws a single pixel of the given color on the given canvas.

<h3><a id="canvas-mark!"><code><nowiki>(canvas-mark! [canvas canvas?] [x integer?] [y integer?]) → void?</nowiki></code></a></h3>

Draws a marker symbol on the given canvas.

<h3><a id="canvas-mark-type"><code><nowiki>(canvas-mark-type [canvas canvas?]) → symbol?</nowiki></code></a></h3>

Retrieves the current marker symbol type for the given canvas. Possible values
are

  *  <code>'+</code> or <code>'plus</code>
  *  <code>'*</code> or <code>'star</code>
  *  <code>'0</code> or <code>'circle</code>
  *  <code>'O</code> or <code>'hollow-circle</code>
  *  <code>'X</code> or <code>'x</code>
  *  <code>'box</code>
  *  <code>'hollow-box</code>
  *  <code>'diamond</code>
  *  <code>'hollow-diamond</code>

<h3><a id="canvas-mark-type-set_"><code>
	<nowiki>(canvas-mark-type-set! [canvas canvas?] [mark-type symbol?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-mark-type [canvas canvas?]) [mark-type symbol?]) → void?</nowiki>
</code></a></h3>

Sets the current marker symbol type for the given canvas.

<h3><a id="canvas-mark-size"><code><nowiki>(canvas-mark-size [canvas canvas?]) → integer?</nowiki></code></a></h3>

Retrieves the current marker symbol size for the given canvas.

<h3><a id="canvas-mark-size-set_"><code>
	<nowiki>(canvas-mark-size-set! [canvas canvas?] [size integer?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-mark-size [canvas canvas?]) [size integer?]) → void?</nowiki>
</code></a></h3>

Sets the current marker symbol size for the given canvas.

<h2>Lines</h2>

<h3><a id="canvas-line_"><code><nowiki>(canvas-line! [canvas canvas?] [x0 real?] [y0 real?] [x1 real?] [y1 real?]) → void?</nowiki></code></a></h3>

Draws a line on the given canvas.

<h3><a id="canvas-rectangle_"><code><nowiki>(canvas-rectangle! [canvas canvas?] [x0 real?] [x1 real?] [y0 real?] [y1 real?]) → void?</nowiki></code></a></h3>

Draws a hollow rectangle on the given canvas.

<h3><a id="canvas-arc_"><code><nowiki>(canvas-arc! [canvas canvas?] [x real?] [y real?] [width real?] [height real?] [alpha0 real?] [alpha1 real?]) → void?</nowiki></code></a></h3>

Draws a hollow ellipsis segment on the given canvas.

<h3><a id="canvas-line-style"><code><nowiki>(canvas-line-style [canvas canvas?]) → symbol?</nowiki></code></a></h3>

Retrieves the current line style of the given canvas. Possible values are

  *  <code>'continuous</code>
  *  <code>'dashed</code>
  *  <code>'dotted</code>
  *  <code>'dash-dotted</code>
  *  <code>'dash-dot-dotted</code>
  *  <code>'custom</code>

<h3><a id="canvas-line-style-set_"><code>
	<nowiki>(canvas-line-style-set! [canvas canvas?] [line-style (or/c symbol? list?)]) → symbol?</nowiki><br>
	<nowiki>(set! (canvas-line-style [canvas canvas?]) [line-style (or/c symbol? list?)]) → symbol?</nowiki>
</code></a></h3>

Sets the current line style of the given canvas and returns the previous value.

In addition to the possible return values of <code>[#canvas-line-style|canvas-line-style]</code>
a custom <code>line-style</code> can be fully specified using the form
<code><nowiki>(list 'custom [len integer?] ...)</nowiki></code>.

<h3><a id="canvas-line-width"><code><nowiki>(canvas-line-width [canvas canvas?]) → integer?</nowiki></code></a></h3>

Retrieves the current line width of the given canvas.

<h3><a id="canvas-line-width-set_"><code>
	<nowiki>(canvas-line-width-set! [canvas canvas?] [line-width integer?]) → integer?</nowiki><br>
	<nowiki>(set! (canvas-line-width [canvas canvas?]) [line-width integer?]) → integer?</nowiki>
</code></a></h3>

Sets the current line width of the given canvas and returns the previous value.

<h3><a id="canvas-line-join"><code><nowiki>(canvas-line-join [canvas canvas?]) → symbol?</nowiki></code></a></h3>

Retrieves the current line join style of the given canvas. Possible values are

  *  <code>'miter</code>
  *  <code>'bevel</code>
  *  <code>'round</code>

<h3><a id="canvas-line-join-set_"><code>
	<nowiki>(canvas-line-join-set! [canvas canvas?] [line-join symbol?]) → symbol?</nowiki><br>
	<nowiki>(set! (canvas-line-join [canvas canvas?]) [line-join symbol?]) → symbol?</nowiki>
</code></a></h3>

Sets the current line join style of the given canvas and returns the previous
value.

<h3><a id="canvas-line-cap"><code><nowiki>(canvas-line-cap [canvas canvas?]) → symbol?</nowiki></code></a></h3>

Retrieves the current line cap style of the given canvas.

  *  <code>'flat</code>
  *  <code>'square</code>
  *  <code>'round</code>

<h3><a id="canvas-line-cap-set_"><code>
	<nowiki>(canvas-line-cap-set! [canvas canvas?] [line-cap symbol?]) → symbol?</nowiki><br>
	<nowiki>(set! (canvas-line-cap [canvas canvas?]) [line-cap symbol?]) → symbol?</nowiki>
</code></a></h3>

Sets the current line cap style of the given canvas and returns the previous
value.

<h2>Filled Areas</h2>

<h3><a id="canvas-box_"><code><nowiki>(canvas-box! [canvas canvas?] [x0 real?] [x1 real?] [y0 real?] [y1 real?]) → void?</nowiki></code></a></h3>

Draws a filled rectangle on the given canvas.

<h3><a id="canvas-sector_"><code><nowiki>(canvas-sector! [canvas canvas?] [x real?] [y real?] [width real?] [height real?] [alpha0 real?] [alpha1 real?]) → void?</nowiki></code></a></h3>

Draws a filled ellipsis sector on the given canvas.

<h3><a id="canvas-chord_"><code><nowiki>(canvas-chord! [canvas canvas?] [x real?] [y real?] [width real?] [height real?] [alpha0 real?] [alpha1 real?]) → void?</nowiki></code></a></h3>

Draws a filled ellipsis arc on the given canvas.

<h3><a id="canvas-background-opacity"><code><nowiki>(canvas-background-opacity [canvas canvas?]) → symbol?</nowiki></code></a></h3>

Retrieves the current background opacity of the given canvas. Possible values
are

  *  <code>'transparent</code>
  *  <code>'opaque</code>

<h3><a id="canvas-background-opacity-set_"><code>
	<nowiki>(canvas-background-opacity-set! [canvas canvas?] [background-opacity symbol?]) → symbol?</nowiki><br>
	<nowiki>(set! (canvas-background-opacity-set! [canvas canvas?]) [background-opacity symbol?]) → symbol?</nowiki>
</code></a></h3>

Sets the current background opacity of the given canvas and returns the previous
value.

<h3><a id="canvas-fill-mode"><code><nowiki>(canvas-fill-mode [canvas canvas?]) → symbol?</nowiki></code></a></h3>

Retrieves the current polygon fill mode of the given canvas. Possible values are

  *  <code>'even-odd</code>
  *  <code>'winding</code>

<h3><a id="canvas-fill-mode-set_"><code>
	<nowiki>(canvas-fill-mode-set! [canvas canvas?] [fill-mode symbol?]) → symbol?</nowiki><br>
	<nowiki>(set! (canvas-fill-mode [canvas canvas?]) [fill-mode symbol?]) → symbol?</nowiki>
</code></a></h3>

Sets the current polygon fill mode of the given canvas and returns the previous
value.

<h3><a id="canvas-interior-style"><code><nowiki>(canvas-interior-style [canvas canvas?]) → (or/c symbol? list?)</nowiki></code></a></h3>

Retrieves the current interior style of the given canvas. Possible values are

  *  <code>'solid</code>
  *  <code>'(hatch horizontal)</code>
  *  <code>'(hatch vertical)</code>
  *  <code>'(hatch forward-diagonal)</code>
  *  <code>'(hatch backward-diagonal)</code>
  *  <code>'(hatch cross)</code>
  *  <code>'(hatch diagonal-cross)</code>
  *  <code><nowiki>(list 'stipple [width integer?] [height integer?] [data blob?])</nowiki></code>
  *  <code><nowiki>(list 'pattern/rgb [width integer?] [height integer?] [data blob?])</nowiki></code>
  *  <code><nowiki>(list 'pattern/rgba [width integer?] [height integer?] [data blob?])</nowiki></code>
  *  <code>#f</code>

<h3><a id="canvas-interior-style-set_"><code>
	<nowiki>(canvas-interior-style-set! [canvas canvas?] [interior-style (or/c symbol? list?)]) → void?</nowiki><br>
	<nowiki>(set! (canvas-interior-style [canvas canvas?]) [interior-style (or/c symbol? list?)]) → void?</nowiki>
</code></a></h3>

Sets the current interior style of the given canvas and returns the previous
value.

<h2>Text</h2>

<h3><a id="canvas-text_"><code><nowiki>(canvas-text! [canvas canvas?] [x real?] [y real?] [text string?]) → void?</nowiki></code></a></h3>

Draws a string of text on the given canvas.

<h3><a id="canvas-font"><code><nowiki>(canvas-font [canvas canvas?]) → string?</nowiki></code></a></h3>

Retrieves the current font of the given canvas.

<h3><a id="canvas-font-set_"><code>
	<nowiki>(canvas-font-set! [canvas canvas?] [font string?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-font [canvas canvas?]) [font string?]) → void?</nowiki>
</code></a></h3>

Sets the current font of the given canvas and returns the previous value.

<h3><a id="canvas-text-alignment"><code><nowiki>(canvas-text-alignment [canvas canvas?]) → symbol?</nowiki></code></a></h3>

Retrieves the current text alignment of the given canvas. Possible values are

  *  <code>'north</code>
  *  <code>'south</code>
  *  <code>'east</code>
  *  <code>'west</code>
  *  <code>'north-east</code>
  *  <code>'north-west</code>
  *  <code>'south-east</code>
  *  <code>'south-west</code>
  *  <code>'center</code>
  *  <code>'base-left</code>
  *  <code>'base-center</code>
  *  <code>'base-right</code>

<h3><a id="canvas-text-alignment-set_"><code>
	<nowiki>(canvas-text-alignment-set! [canvas canvas?] [text-alignment symbol?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-text-alignment [canvas canvas?]) [text-alignment symbol?]) → void?</nowiki>
</code></a></h3>

Sets the current text alignment of the given canvas and returns the previous
value.

<h3><a id="canvas-text-orientation"><code><nowiki>(canvas-text-orientation [canvas canvas?]) → real?</nowiki></code></a></h3>

Retrieves the current text orientation of the given canvas.

<h3><a id="canvas-text-orientation-set_"><code>
	<nowiki>(canvas-text-orientation-set! [canvas canvas?] [orientation real?]) → void?</nowiki><br>
	<nowiki>(set! (canvas-text-orientation [canvas canvas?]) [orientation real?]) → void?</nowiki>
</code></a></h3>

Sets the current text orientation of the given canvas and returns the previous
value.

<h3><a id="canvas-font-dimensions"><code><nowiki>(canvas-font-dimensions [canvas canvas?]) → (values integer? integer? integer? integer?)</nowiki></code></a></h3>

Returns the maximum width, height, ascent and descent of the current font
of the given canvas.

<h3><a id="canvas-text-size"><code><nowiki>(canvas-text-size [canvas canvas?] [text string?]) → (values integer? integer?)</nowiki></code></a></h3>

Computes the width and height of the given text when drawn on the given canvas.

<h3><a id="canvas-text-box"><code><nowiki>(canvas-text-box [canvas canvas?] [x integer?] [y integer?] [text string?]) → (values integer? integer? integer? integer?)</nowiki></code></a></h3>

Computes the bounding box of the given text when drawn on the given canvas.
Returns the minimum and maximum x and y coordinates.

<h2>Vertices</h2>

<h3><a id="call-with-canvas-in-mode"><code><nowiki>(call-with-canvas-in-mode [canvas canvas?] [mode symbol?] [proc (-> canvas? any)]) → any</nowiki></code></a></h3>

Calls <code>proc</code> with the given canvas and ready to receive vertex data
in the given mode. Returns whatever <code>proc</code> returns.

Possible modes are

  *  <code>'open-lines</code>
  *  <code>'closed-lines</code>
  *  <code>'fill</code>
  *  <code>'clip</code>
  *  <code>'bezier</code>
  *  <code>'region</code>
  *  <code>'path</code>

<h3><a id="canvas-path-set!"><code><nowiki>(canvas-path-set! [canvas canvas?] [path-action symbol?]) → void?</nowiki></code></a></h3>

Configures the action between sequences of vertex data sent to the given canvas.
Possible actions are

  *  <code>'new</code>
  *  <code>'move-to</code>
  *  <code>'line-to</code>
  *  <code>'arc</code>
  *  <code>'curve-to</code>
  *  <code>'close</code>
  *  <code>'fill</code>
  *  <code>'stroke</code>
  *  <code>'fill+stroke</code>
  *  <code>'clip</code>

<h3><a id="canvas-vertex!"><code><nowiki>(canvas-vertex! [canvas canvas?] [x real?] [y real?]) → void?</nowiki></code></a></h3>

Sends a vertex to the given canvas.

<h1><tt>printer</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/printer))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-printer)</code></td>
	</tr>
</table>

Printer context support.

<h2>Context Types</h2>

<h3><a id="context:printer"><code><nowiki>[context:printer context?]</nowiki></code></a></h3>

Context type for a system printer.

<h1><tt>ps</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/ps))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-ps)</code></td>
	</tr>
</table>

PostScript context support.

<h2>Context Types</h2>

<h3><a id="context:ps"><code><nowiki>[context:ps context?]</nowiki></code></a></h3>

Context type for PS files.

<h1><tt>server</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/server))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-server)</code></td>
	</tr>
</table>

Server context support.

<h2>Context Types</h2>

<h3><a id="context:image"><code><nowiki>[context:image context?]</nowiki></code></a></h3>

Context type for server side pixel buffers.

<h3><a id="context:double-buffer"><code><nowiki>[context:double-buffer context?]</nowiki></code></a></h3>

Context type for server side double buffers.

<h1><tt>svg</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/svg))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-svg)</code></td>
	</tr>
</table>

Scalable vector graphics context support.

<h2>Context Types</h2>

<h3><a id="context:svg"><code><nowiki>[context:svg context?]</nowiki></code></a></h3>

Context type for SVG files.

<h1><tt>wmf</tt> Module</h1>

<h2>Synopsis</h2>

<table>
	<tr>
		<th>Racket</th>
		<td><code>(require (planet murphy/canvas-draw:1:0/wmf))</code></td>
	</tr>
	<tr>
		<th>CHICKEN</th>
		<td><code>(require-extension canvas-draw-wmf)</code></td>
	</tr>
</table>

WMF context support.

<h2>Context Types</h2>

<h3><a id="context:wmf"><code><nowiki>[context:wmf context?]</nowiki></code></a></h3>

Context type for WMF files.

(require-library lolevel data-structures srfi-1 srfi-4 srfi-13)

(module canvas-draw-base
	(canvas? canvas->pointer pointer->canvas
	 context? context->pointer pointer->context
	 state? state->pointer pointer->state
	 context-capabilities
	 use-context+ make-canvas call-with-canvas
	 canvas-context
	 canvas-simulate!
	 canvas-attribute canvas-attribute-set!
	 canvas-state canvas-state-set!
	 canvas-clear! canvas-flush
	 canvas-size
	 canvas-mm->px canvas-px->mm
	 canvas-origin canvas-origin-set!
	 canvas-transform canvas-transform-set!
	 canvas-transform-compose!
	 canvas-transform-translate!
	 canvas-transform-scale!
	 canvas-transform-rotate!
	 canvas-foreground canvas-foreground-set!
	 canvas-background canvas-background-set!
	 canvas-write-mode canvas-write-mode-set!
	 canvas-clip-mode canvas-clip-mode-set!
	 canvas-clip-area canvas-clip-area-set!)
	(import
		scheme chicken foreign
		lolevel data-structures srfi-1 srfi-4 srfi-13)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n")

(define *canvas-tag* "cdCanvas")
(define canvas? (cut tagged-pointer? <> *canvas-tag*))

(define (canvas->pointer nonnull?)
	(if nonnull?
		(lambda (canvas)
			(ensure canvas? canvas)
			canvas)
		(lambda (canvas)
			(ensure (disjoin not canvas?) canvas)
			canvas)))

(define (pointer->canvas nonnull?)
	(if nonnull?
		(lambda (canvas)
			(tag-pointer canvas *canvas-tag*))
		(lambda (canvas)
			(and canvas (tag-pointer canvas *canvas-tag*)))))

(define *context-tag* "cdContext")
(define context? (cut tagged-pointer? <> *context-tag*))

(define (context->pointer nonnull?)
	(if nonnull?
		(lambda (context)
			(ensure context? context)
			context)
		(lambda (context)
			(ensure (disjoin not context?) context)
			context)))

(define (pointer->context nonnull?)
	(if nonnull?
		(lambda (context)
			(tag-pointer context *context-tag*))
		(lambda (context)
			(and context (tag-pointer context *context-tag*)))))

(define *state-tag* "cdState")
(define state? (cut tagged-pointer? <> *state-tag*))

(define (state->pointer nonnull?)
	(if nonnull?
		(lambda (state)
			(ensure state? state)
			state)
		(lambda (state)
			(ensure (disjoin not state?) state)
			state)))

(define (pointer->state nonnull?)
	(if nonnull?
		(lambda (state)
			(tag-pointer state *state-tag*))
		(lambda (state)
			(and state (tag-pointer state *state-tag*)))))

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Canvas management

(define context-capabilities
	(letrec ([context-capabilities/raw
			      (foreign-lambda int "cdContextCaps" nonnull-context)]
	         [capabilities
	          (list
	          	(cons
	          		'flush
	          		(foreign-value "CD_CAP_FLUSH" int))
	          	(cons
	          		'clear
	          		(foreign-value "CD_CAP_CLEAR" int))
	          	(cons
	          		'play
	          		(foreign-value "CD_CAP_PLAY" int))
	          	(cons
	          		'y-axis
	          		(foreign-value "CD_CAP_YAXIS" int))
	          	(cons
	          		'clip-area
	          		(foreign-value "CD_CAP_CLIPAREA" int))
	          	(cons
	          		'clip-polygon
	          		(foreign-value "CD_CAP_CLIPPOLY" int))
	          	(cons
	          		'region
	          		(foreign-value "CD_CAP_REGION" int))
	          	(cons
	          		'rectangle
	          		(foreign-value "CD_CAP_RECT" int))
	          	(cons
	          		'chord
	          		(foreign-value "CD_CAP_CHORD" int))
	          	(cons
	          		'image/rgb
	          		(foreign-value "CD_CAP_IMAGERGB" int))
	          	(cons
	          		'image/rgba
	          		(foreign-value "CD_CAP_IMAGERGBA" int))
	          	(cons
	          		'image/map
	          		(foreign-value "CD_CAP_IMAGEMAP" int))
	          	(cons
	          		'get-image/rgb
	          		(foreign-value "CD_CAP_GETIMAGERGB" int))
	          	(cons
	          		'image/server
	          		(foreign-value "CD_CAP_IMAGESRV" int))
	          	(cons
	          		'background
	          		(foreign-value "CD_CAP_BACKGROUND" int))
	          	(cons
	          		'background-opacity
	          		(foreign-value "CD_CAP_BACKOPACITY" int))
	          	(cons
	          		'write-mode
	          		(foreign-value "CD_CAP_WRITEMODE" int))
	          	(cons
	          		'line-style
	          		(foreign-value "CD_CAP_LINESTYLE" int))
	          	(cons
	          		'line-width
	          		(foreign-value "CD_CAP_LINEWITH" int))
	          	(cons
	          		'fprimtives
	          		(foreign-value "CD_CAP_FPRIMTIVES" int))
	          	(cons
	          		'hatch
	          		(foreign-value "CD_CAP_HATCH" int))
	          	(cons
	          		'stipple
	          		(foreign-value "CD_CAP_STIPPLE" int))
	          	(cons
	          		'pattern
	          		(foreign-value "CD_CAP_PATTERN" int))
	          	(cons
	          		'font
	          		(foreign-value "CD_CAP_FONT" int))
	          	(cons
	          		'font-dimensions
	          		(foreign-value "CD_CAP_FONTDIM" int))
	          	(cons
	          		'text-size
	          		(foreign-value "CD_CAP_TEXTSIZE" int))
	          	(cons
	          		'text-orientation
	          		(foreign-value "CD_CAP_TEXTORIENTATION" int))
	          	(cons
	          		'palette
	          		(foreign-value "CD_CAP_PALETTE" int))
	          	(cons
	          		'line-cap
	          		(foreign-value "CD_CAP_LINECAP" int))
	          	(cons
	          		'line-join
	          		(foreign-value "CD_CAP_LINEJOIN" int))
	          	(cons
	          		'path
	          		(foreign-value "CD_CAP_PATH" int))
	          	(cons
	          		'bezier
	          		(foreign-value "CD_CAP_BEZIER" int)))])
	  (lambda (context)
	  	(let ([capabilities/raw (context-capabilities/raw context)])
				(filter-map
					(lambda (info)
						(let ([mask (cdr info)])
							(and (= (bitwise-and mask capabilities/raw) mask) (car info))))
					capabilities)))))

(define use-context+
	(make-parameter #f))

(define make-canvas/ptr
	(foreign-lambda* canvas ([nonnull-context context] [bool plus] [c-pointer data])
		"cdUseContextPlus(plus);\n"
		"C_return(cdCreateCanvas(context, data));"))

(define make-canvas/string
	(foreign-lambda* canvas ([nonnull-context context] [bool plus] [c-string data])
		"cdUseContextPlus(plus);\n"
		"C_return(cdCreateCanvas(context, (void *)data));"))

(define canvas-kill!
	(foreign-lambda void "cdKillCanvas" nonnull-canvas))

(define canvas-activate!
	(foreign-lambda void "cdCanvasActivate" nonnull-canvas))

(define canvas-deactivate!
	(foreign-lambda void "cdCanvasDeactivate" nonnull-canvas))

(define (make-canvas context data)
	(let ([make-canvas/data (if (string? data) make-canvas/string make-canvas/ptr)])
		(cond
			[(make-canvas/data context (use-context+) data)
			 => (cut set-finalizer! <> canvas-kill!)]
			[else
			 (error 'make-canvas "failed to create canvas")])))

(define call-with-canvas
	(case-lambda
		[(canvas proc)
		 (dynamic-wind
		 	 (cut canvas-activate! canvas)
		 	 (cut proc canvas)
		 	 (cut canvas-deactivate! canvas))]
		[(context data proc)
		 (let* ([make-canvas/data (if (string? data) make-canvas/string make-canvas/ptr)]
		 		    [canvas (make-canvas/data context (use-context+) data)])
		 	 (unless canvas (error 'call-with-canvas "failed to create canvas"))
			 (dynamic-wind
			 	 (cut canvas-activate! canvas)
			 	 (cut proc canvas)
			 	 (lambda ()
			 	 	 (when canvas
						 (canvas-kill! canvas)
						 (set! canvas #f)))))]))

(define canvas-context
	(foreign-lambda nonnull-context "cdCanvasGetContext" nonnull-canvas))

(define canvas-simulate!
	(letrec ([canvas-simulate/raw!
	          (foreign-lambda int "cdCanvasSimulate" nonnull-canvas int)]
	         [flags
	          (list
	          	(cons
	          		'line
	          		(foreign-value "CD_SIM_LINE" int))
	          	(cons
	          		'rectangle
	          		(foreign-value "CD_SIM_RECT" int))
	          	(cons
	          		'box
	          		(foreign-value "CD_SIM_BOX" int))
	          	(cons
	          		'arc
	          		(foreign-value "CD_SIM_ARC" int))
	          	(cons
	          		'sector
	          		(foreign-value "CD_SIM_SECTOR" int))
	          	(cons
	          		'chord
	          		(foreign-value "CD_SIM_CHORD" int))
	          	(cons
	          		'polyline
	          		(foreign-value "CD_SIM_POLYLINE" int))
	          	(cons
	          		'polygon
	          		(foreign-value "CD_SIM_POLYGON" int))
	          	(cons
	          		'text
	          		(foreign-value "CD_SIM_TEXT" int))
	          	(cons
	          		'all
	          		(foreign-value "CD_SIM_ALL" int))
	          	(cons
	          		'lines
	          		(foreign-value "CD_SIM_LINES" int))
	          	(cons
	          		'fills
	          		(foreign-value "CD_SIM_FILLS" int)))])
	  (lambda (canvas flags-in)
	  	(let ([flags-out
	  	       (canvas-simulate/raw!
	  	       	 canvas
	  	       	 (fold
	  	       	 	 bitwise-ior 0
	  	       	 	 (map
	  	       	 	 	 (lambda (flag)
	  	       	 	 	 	 (cond
	  	       	 	 	 	 	 [(assq flag flags) => cdr]
	  	       	 	 	 	 	 [else (error 'canvas-simulate! "unknown flag" flag)]))
	  	       	 	 	 flags-in)))])
	  	  (filter-map
	  	  	(lambda (info)
	  	  		(let ([mask (cdr info)])
							(and (= (bitwise-and mask flags-out) mask) (car info))))
	  	  	flags)))))

(define (name->string name)
	(cond
		[(symbol? name)
		 (string-upcase (string-translate (symbol->string name) #\- #\_))]
		[else
		 name]))

(define canvas-attribute-set!
	(letrec ([canvas-attribute-set/raw! (foreign-lambda void "cdCanvasSetAttribute" nonnull-canvas nonnull-c-string c-string)])
		(lambda (canvas name value)
			(canvas-attribute-set/raw! canvas (name->string name) value))))

(define canvas-attribute
	(letrec ([canvas-attribute/raw (foreign-lambda c-string "cdCanvasGetAttribute" nonnull-canvas nonnull-c-string)])
		(getter-with-setter
			(lambda (canvas name)
				(canvas-attribute/raw canvas (name->string name)))
			canvas-attribute-set!)))

(define canvas-state-set!
	(foreign-lambda void "cdCanvasRestoreState" nonnull-canvas nonnull-state))

(define canvas-state
	(letrec ([save-state (foreign-lambda nonnull-state "cdCanvasSaveState" nonnull-canvas)]
	         [release-state! (foreign-lambda void "cdReleaseState" nonnull-state)])
		(getter-with-setter
			(lambda (canvas)
				(set-finalizer! (save-state canvas) release-state!))
			canvas-state-set!)))

(define canvas-clear!
	(foreign-lambda void "cdCanvasClear" nonnull-canvas))

(define canvas-flush
	(foreign-lambda void "cdCanvasFlush" nonnull-canvas))

;; }}}

;; {{{ Coordinate system

(define canvas-size
	(letrec ([canvas-size/raw (foreign-lambda void "cdCanvasGetSize" nonnull-canvas (c-pointer int) (c-pointer int) (c-pointer double) (c-pointer double))])
		(lambda (canvas)
			(let-location ([width/px int 0] [height/px int 0]
			               [width/mm double 0] [height/mm double 0])
			  (canvas-size/raw
			  	canvas
			  	(location width/px) (location height/px)
			  	(location width/mm) (location height/mm))
			  (values
			  	width/px height/px
			  	width/mm height/mm)))))

(define canvas-mm->px
	(letrec ([canvas-mm->px/raw (foreign-lambda void "cdCanvasMM2Pixel" nonnull-canvas double double (c-pointer int) (c-pointer int))])
		(lambda (canvas x/mm y/mm)
			(let-location ([x/px int 0] [y/px int 0])
				(canvas-mm->px/raw canvas x/mm y/mm (location x/px) (location y/px))
				(values x/px y/px)))))

(define canvas-px->mm
	(letrec ([canvas-mm->px/raw (foreign-lambda void "cdCanvasPixel2MM" nonnull-canvas int int (c-pointer double) (c-pointer double))])
		(lambda (canvas x/px y/px)
			(let-location ([x/mm double +nan.0] [y/mm double +nan.0])
				(canvas-mm->px/raw canvas x/px y/px (location x/mm) (location y/mm))
				(values x/mm y/mm)))))

(define canvas-origin-set!
	(foreign-lambda void "cdCanvasOrigin" nonnull-canvas int int))

(define canvas-origin
	(letrec ([canvas-origin/raw (foreign-lambda void "cdCanvasGetOrigin" nonnull-canvas (c-pointer int) (c-pointer int))])
		(lambda (canvas)
			(let-location ([x int 0] [y int 0])
				(canvas-origin/raw canvas (location x) (location y))
				(values x y)))))

(define (transform->f64vector proc)
	(let ([v (make-f64vector 6)])
		(let-values ([(dx dy) (proc 0 0)])
			(f64vector-set! v 4 dx)
			(f64vector-set! v 5 dy)
			(let-values ([(x y) (proc 1 0)])
				(f64vector-set! v 0 (- x dx))
				(f64vector-set! v 1 (- y dy)))
			(let-values ([(x y) (proc 0 1)])
				(f64vector-set! v 2 (- x dx))
				(f64vector-set! v 3 (- y dy))))
		v))

(define ((f64vector->transform v) x y)
	(values
		(+ (* (f64vector-ref v 0) x) (* (f64vector-ref v 2) y) (f64vector-ref v 4))
		(+ (* (f64vector-ref v 1) x) (* (f64vector-ref v 3) y) (f64vector-ref v 5))))

(define canvas-transform-set!
	(letrec ([canvas-transform-set/raw! (foreign-lambda void "cdCanvasTransform" nonnull-canvas f64vector)])
		(lambda (canvas proc)
			(canvas-transform-set/raw! canvas (and proc (transform->f64vector proc))))))

(define canvas-transform
	(letrec ([canvas-transform/raw
	          (foreign-lambda* bool ([nonnull-canvas canvas] [nonnull-f64vector v])
	          	"double *w = cdCanvasGetTransform(canvas);\n"
	          	"if (w) memcpy(v, w, 6 * sizeof(double));\n"
	          	"C_return(w);")])
		(getter-with-setter
			(lambda (canvas)
				(let ([v (make-f64vector 6)])
					(and (canvas-transform/raw canvas v) (f64vector->transform v))))
			canvas-transform-set!)))

(define canvas-transform-compose!
	(letrec ([canvas-transform-compose/raw! (foreign-lambda void "cdCanvasTransformMultiply" nonnull-canvas nonnull-f64vector)])
		(lambda (canvas proc)
			(canvas-transform-compose/raw! canvas (transform->f64vector proc)))))

(define canvas-transform-translate!
	(foreign-lambda void "cdCanvasTransformTranslate" nonnull-canvas double double))

(define canvas-transform-scale!
	(foreign-lambda void "cdCanvasTransformScale" nonnull-canvas double double))

(define canvas-transform-rotate!
	(foreign-lambda void "cdCanvasTransformRotate" nonnull-canvas double))

;; }}}

;; {{{ General attributes

(define canvas-foreground-set!
	(foreign-lambda void "cdCanvasSetForeground" nonnull-canvas unsigned-long))

(define canvas-foreground
	(getter-with-setter
		(foreign-lambda* unsigned-long ([nonnull-canvas canvas])
			"C_return(cdCanvasForeground(canvas, CD_QUERY));")
		canvas-foreground-set!))

(define canvas-background-set!
	(foreign-lambda void "cdCanvasSetBackground" nonnull-canvas unsigned-long))

(define canvas-background
	(getter-with-setter
		(foreign-lambda* unsigned-long ([nonnull-canvas canvas])
			"C_return(cdCanvasBackground(canvas, CD_QUERY));")
		canvas-background-set!))

(define-values (canvas-write-mode canvas-write-mode-set!)
	(letrec ([write-modes
	          (list
	          	(cons
	          		'replace
	          		(foreign-value "CD_REPLACE" int))
	          	(cons
	          		'xor
	          		(foreign-value "CD_XOR" int))
	          	(cons
	          		'not-xor
	          		(foreign-value "CD_NOT_XOR" int)))]
	         [canvas-write-mode-set/raw!
	          (foreign-lambda void "cdCanvasWriteMode" nonnull-canvas int)]
	         [canvas-write-mode-set!
	          (lambda (canvas write-mode)
	          	(canvas-write-mode-set/raw!
	          		canvas
	          		(cond
	          			[(assq write-mode write-modes) => cdr]
	          			[else (error 'canvas-write-mode-set! "unknown write mode" write-mode)])))]
	         [canvas-write-mode/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasWriteMode(canvas, CD_QUERY));")]
	         [canvas-write-mode
	          (lambda (canvas)
	          	(let ([write-mode (canvas-write-mode/raw canvas)])
	          		(cond
	          			[(rassoc write-mode write-modes) => car]
	          			[else (error 'canvas-write-mode "unknown write mode" write-mode)])))])
	  (values
	  	(getter-with-setter canvas-write-mode canvas-write-mode-set!)
	  	canvas-write-mode-set!)))

;; }}}

;; {{{ Clipping

(define-values (canvas-clip-mode canvas-clip-mode-set!)
	(letrec ([clip-modes
	          (list
	          	(cons
	          		'area
	          		(foreign-value "CD_CLIPAREA" int))
	          	(cons
	          		'polygon
	          		(foreign-value "CD_CLIPPOLYGON" int))
	          	(cons
	          		'region
	          		(foreign-value "CD_CLIPREGION" int))
	          	(cons
	          		#f
	          		(foreign-value "CD_CLIPOFF" int)))]
	         [canvas-clip-mode-set/raw!
	          (foreign-lambda void "cdCanvasClip" nonnull-canvas int)]
	         [canvas-clip-mode-set!
	          (lambda (canvas clip-mode)
	          	(canvas-clip-mode-set/raw!
	          		canvas
	          		(cond
	          			[(assq clip-mode clip-modes) => cdr]
	          			[else (error 'canvas-clip-mode-set! "unknown clip mode" clip-mode)])))]
	         [canvas-clip-mode/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasClip(canvas, CD_QUERY));")]
	         [canvas-clip-mode
	          (lambda (canvas)
	          	(let ([clip-mode (canvas-clip-mode/raw canvas)])
	          		(cond
	          			[(rassoc clip-mode clip-modes) => car]
	          			[else (error 'canvas-write-mode "unknown clip mode" clip-mode)])))])
	  (values
	  	(getter-with-setter canvas-clip-mode canvas-clip-mode-set!)
	  	canvas-clip-mode-set!)))

(define canvas-clip-area-set!
	(foreign-lambda void "cdfCanvasClipArea" nonnull-canvas double double double double))

(define canvas-clip-area
	(letrec ([canvas-clip-area/raw (foreign-lambda void "cdfCanvasGetClipArea" nonnull-canvas (c-pointer double) (c-pointer double) (c-pointer double) (c-pointer double))])
		(lambda (canvas)
			(let-location ([x0 double 0] [x1 double 0] [y0 double 0] [y1 double 0])
				(canvas-clip-area/raw canvas (location x0) (location x1) (location y0) (location y1))
				(values x0 x1 y0 y1)))))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-cgm
	(context:cgm)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdcgm.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:cgm
	(foreign-value "CD_CGM" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-client
	(context:image context:double-buffer
	 canvas-image/rgb canvas-image-put/rgb! canvas-image-put/rgba!)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdirgb.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:image
	(foreign-value "CD_IMAGERGB" nonnull-context))

(define context:double-buffer
	(foreign-value "CD_DBUFFERRGB" nonnull-context))

;; }}}

;; {{{ Auxiliary functions

(define canvas-image-put/rgb!
	(letrec ([canvas-image-set/rgb/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int dst_x] [int dst_y]
	                                 [int src_width] [int src_height] [nonnull-blob data]
	                                 [int dst_width] [int dst_height]
	                                 [int src_x0] [int src_x1] [int src_y0] [int src_y1])
	            "const int nchans = 3;\n"
	          	"unsigned char chans[nchans][src_width * src_height];\n"
	          	"int i;\n"
	          	"\n"
	          	"for (i = 0; i < nchans * src_width * src_height; ++i)\n"
	          	"	chans[i % nchans][i / nchans] = data[i];\n"
	          	"\n"
	          	"cdCanvasPutImageRectRGB(\n"
	          	"	canvas, src_width, src_height,\n"
	          	"	chans[0], chans[1], chans[2],\n"
	          	"	dst_x, dst_y, dst_width, dst_height,"
	          	"	src_x0, src_x1, src_y0, src_y1"
	          	");")])
	  (lambda (canvas dst-x dst-y src-width src-height data
	           #!key [width 0] [height 0] [x0 0] [x1 0] [y0 0] [y1 0])
	  	(unless (= (blob-size data) (* 3 src-width src-height))
	  		(error 'canvas-image-set/rgb! "bad image size" (blob-size data) (* 3 src-width src-height)))
	  	(canvas-image-set/rgb/raw!
	  		canvas dst-x dst-y src-width src-height data
	  		width height x0 x1 y0 y1))))

(define canvas-image-put/rgba!
	(letrec ([canvas-image-set/rgba/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int dst_x] [int dst_y]
	                                 [int src_width] [int src_height] [nonnull-blob data]
	                                 [int dst_width] [int dst_height]
	                                 [int src_x0] [int src_x1] [int src_y0] [int src_y1])
	            "const int nchans = 4;\n"
	          	"unsigned char chans[nchans][src_width * src_height];\n"
	          	"int i;\n"
	          	"\n"
	          	"for (i = 0; i < nchans * src_width * src_height; ++i)\n"
	          	"	chans[i % nchans][i / nchans] = data[i];\n"
	          	"\n"
	          	"cdCanvasPutImageRectRGBA(\n"
	          	"	canvas, src_width, src_height,\n"
	          	"	chans[0], chans[1], chans[2], chans[3],\n"
	          	"	dst_x, dst_y, dst_width, dst_height,"
	          	"	src_x0, src_x1, src_y0, src_y1"
	          	");")])
	  (lambda (canvas dst-x dst-y src-width src-height data
	           #!key [width 0] [height 0] [x0 0] [x1 0] [y0 0] [y1 0])
	  	(unless (= (blob-size data) (* 4 src-width src-height))
	  		(error 'canvas-image-set/rgba! "bad image size" (blob-size data) (* 4 src-width src-height)))
	  	(canvas-image-set/rgba/raw!
	  		canvas dst-x dst-y src-width src-height data
	  		width height x0 x1 y0 y1))))

(define canvas-image/rgb
	(getter-with-setter
		(letrec ([canvas-image/rgb/raw
							(foreign-lambda* void ([nonnull-canvas canvas] [int x] [int y]
							                       [int width] [int height]  [nonnull-blob data])
							  "const int nchans = 3;\n"
							  "unsigned char chans[nchans][width * height];\n"
							  "int i;\n"
							  "\n"
							  "cdCanvasGetImageRGB(\n"
							  "	canvas,\n"
							  "	chans[0], chans[1], chans[2],\n"
							  "	x, y, width, height\n"
							  ");\n"
							  "\n"
							  "for (i = 0; i < nchans * width * height; ++i)\n"
							  "	data[i] = chans[i % nchans][i / nchans];\n")])
			(lambda (canvas x y width height)
				(let ([data (make-blob (* 3 width height))])
					(canvas-image/rgb/raw canvas x y width height data)
					data)))
		canvas-image-put/rgb!))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-clipboard
	(context:clipboard)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdclipbd.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:clipboard
	(foreign-value "CD_CLIPBOARD" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-debug
	(context:debug)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cddebug.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:debug
	(foreign-value "CD_DEBUG" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-dgn
	(context:dgn)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cddgn.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:dgn
	(foreign-value "CD_DGN" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-dxf
	(context:dxf)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cddxf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:dxf
	(foreign-value "CD_DXF" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-emf
	(context:emf)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdemf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:emf
	(foreign-value "CD_EMF" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-gl
	(context:gl)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdgl.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:gl
	(foreign-value "CD_GL" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-iup
	(context:iup make-canvas-action)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdiup.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:iup
	(foreign-value "CD_IUP" nonnull-context))

;; }}}

;; {{{ Auxiliary functions

(define (make-canvas-action proc)
	(let ([canvas #f])
		(lambda (handle x y)
			(unless canvas (set! canvas (make-canvas context:iup handle)))
			(call-with-canvas canvas (cut proc <> x y)))))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-metafile
	(context:metafile)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdmf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:metafile
	(foreign-value "CD_METAFILE" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-native
	(context:native-window
	 screen-size)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdnative.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:native-window
	(foreign-value "CD_NATIVEWINDOW" nonnull-context))

;; }}}

;; {{{ Auxiliary functions

(define screen-size
	(letrec ([screen-size/raw (foreign-lambda void "cdGetScreenSize" (c-pointer int) (c-pointer int) (c-pointer double) (c-pointer double))])
		(lambda ()
			(let-location ([width/px int 0] [height/px int 0]
			               [width/mm double 0] [height/mm double 0])
			  (screen-size/raw
			  	(location width/px) (location height/px)
			  	(location width/mm) (location height/mm))
			  (values
			  	width/px height/px
			  	width/mm height/mm)))))

;; }}}

;; {{{ Library initialization

(foreign-code "cdInitContextPlus();")

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-pdf
	(context:pdf)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdpdf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:pdf
	(foreign-value "CD_PDF" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-picture
	(context:picture)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdpicture.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:picture
	(foreign-value "CD_PICTURE" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-play
	(canvas-play!)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context content playback

(define canvas-play/ptr!
	(foreign-lambda int "cdCanvasPlay" nonnull-canvas nonnull-context int int int int c-pointer))

(define canvas-play/string!
	(foreign-lambda int "cdCanvasPlay" nonnull-canvas nonnull-context int int int int c-string))

(define (canvas-play! canvas context x0 x1 y0 y1 data)
	(let ([canvas-play/data! (if (string? data) canvas-play/string! canvas-play/ptr!)])
		(unless (zero? (canvas-play/data! canvas context x0 x1 y0 y1 data))
			(error 'canvas-play! "failed to replay graphics"))))

;; }}}

)

(require-library data-structures srfi-4 canvas-draw-base)

(module canvas-draw-primitives
	(canvas-pixel!
	 canvas-mark!
	 canvas-mark-type canvas-mark-type-set!
	 canvas-mark-size canvas-mark-size-set!
	 canvas-line! canvas-rectangle! canvas-arc!
	 canvas-line-style canvas-line-style-set!
	 canvas-line-width canvas-line-width-set!
	 canvas-line-join canvas-line-join-set!
	 canvas-line-cap canvas-line-cap-set!
	 canvas-box! canvas-sector! canvas-chord!
	 canvas-background-opacity canvas-background-opacity-set!
	 canvas-fill-mode canvas-fill-mode-set!
	 canvas-interior-style canvas-interior-style-set!
	 canvas-text!
	 canvas-font canvas-font-set!
	 canvas-text-alignment canvas-text-alignment-set!
	 canvas-text-orientation canvas-text-orientation-set!
	 canvas-font-dimensions canvas-text-size canvas-text-box
	 call-with-canvas-in-mode canvas-path-set!
	 canvas-vertex!)
	(import scheme chicken foreign data-structures srfi-4 canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Point drawing functions

(define canvas-pixel!
	(letrec ([canvas-pixel/raw!
	          (foreign-lambda void "cdCanvasPixel" nonnull-canvas int int unsigned-long)])
	  (lambda (canvas x y #!optional [color (canvas-foreground canvas)])
	  	(canvas-pixel/raw! canvas x y color))))

(define canvas-mark!
	(foreign-lambda void "cdCanvasMark" nonnull-canvas int int))

(define-values (canvas-mark-type canvas-mark-type-set!)
	(letrec ([mark-types
	          (list
	          	(cons
	          		'+
	          		(foreign-value "CD_PLUS" int))
	          	(cons
	          		'plus
	          		(foreign-value "CD_PLUS" int))
	          	(cons
	          		'*
	          		(foreign-value "CD_STAR" int))
	          	(cons
	          		'star
	          		(foreign-value "CD_STAR" int))
	          	(cons
	          		'0
	          		(foreign-value "CD_CIRCLE" int))
	          	(cons
	          		'circle
	          		(foreign-value "CD_CIRCLE" int))
	          	(cons
	          		'O
	          		(foreign-value "CD_HOLLOW_CIRCLE" int))
	          	(cons
	          		'hollow-circle
	          		(foreign-value "CD_HOLLOW_CIRCLE" int))
	          	(cons
	          		'X
	          		(foreign-value "CD_X" int))
	          	(cons
	          		'x
	          		(foreign-value "CD_X" int))
	          	(cons
	          		'box
	          		(foreign-value "CD_BOX" int))
	          	(cons
	          		'hollow-box
	          		(foreign-value "CD_HOLLOW_BOX" int))
	          	(cons
	          		'diamond
	          		(foreign-value "CD_DIAMOND" int))
	          	(cons
	          		'hollow-diamond
	          		(foreign-value "CD_HOLLOW_DIAMOND" int)))]
	         [canvas-mark-type-set/raw!
	          (foreign-lambda void "cdCanvasMarkType" nonnull-canvas int)]
	         [canvas-mark-type-set!
	          (lambda (canvas mark-type)
							(canvas-mark-type-set/raw!
								canvas
								(cond
									[(assq mark-type mark-types) => cdr]
									[else (error 'canvas-mark-type-set! "unknown mark type" mark-type)])))]
	         [canvas-mark-type/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasMarkType(canvas, CD_QUERY));")]
	         [canvas-mark-type
	          (lambda (canvas)
	          	(let ([mark-type (canvas-mark-type/raw canvas)])
								(cond
									[(rassoc mark-type mark-types) => car]
									[else (error 'canvas-mark-type "unknown mark type" mark-type)])))])
	  (values
	  	(getter-with-setter canvas-mark-type canvas-mark-type-set!)
	  	canvas-mark-type-set!)))

(define canvas-mark-size-set!
	(foreign-lambda void "cdCanvasMarkSize" nonnull-canvas int))

(define canvas-mark-size
	(getter-with-setter
		(foreign-lambda* int ([nonnull-canvas canvas])
			"C_return(cdCanvasMarkSize(canvas, CD_QUERY));")
		canvas-mark-size-set!))

;; }}}

;; {{{ Line functions

(define canvas-line!
	(foreign-lambda void "cdfCanvasLine" nonnull-canvas double double double double))

(define canvas-rectangle!
	(foreign-lambda void "cdfCanvasRect" nonnull-canvas double double double double))

(define canvas-arc!
	(foreign-lambda void "cdfCanvasArc" nonnull-canvas double double double double double double))

(define-values (canvas-line-style canvas-line-style-set!)
	(letrec ([line-styles
	          (list
	          	(cons
	          		'continuous
	          		(foreign-value "CD_CONTINUOUS" int))
	          	(cons
	          		'dashed
	          		(foreign-value "CD_DASHED" int))
	          	(cons
	          		'dotted
	          		(foreign-value "CD_DOTTED" int))
	          	(cons
	          		'dash-dotted
	          		(foreign-value "CD_DASH_DOT" int))
	          	(cons
	          		'dash-dot-dotted
	          		(foreign-value "CD_DASH_DOT_DOT" int))
	          	(cons
	          		'custom
	          		(foreign-value "CD_CUSTOM" int)))]
	         [canvas-line-style-set/raw!
	          (foreign-lambda void "cdCanvasLineStyle" nonnull-canvas int)]
	         [canvas-line-style-dashes-set/raw!
	          (foreign-lambda void "cdCanvasLineStyleDashes" nonnull-canvas nonnull-s32vector int)]
	         [canvas-line-style-set!
	          (lambda (canvas line-style)
	          	(cond
	          		[(and (pair? line-style) (eq? (car line-style) 'custom))
	          		 (let ([dashes (list->s32vector (cdr line-style))])
	          		 	 (canvas-line-style-dashes-set/raw! canvas dashes (s32vector-length dashes))
	          		 	 (canvas-line-style-set/raw! canvas (cdr (assq 'custom line-styles))))]
	          		[else
	          		 (canvas-line-style-set/raw!
	          		 	 canvas
	          		 	 (cond
	          		 	 	 [(assq line-style line-styles) => cdr]
	          		 	 	 [else (error 'canvas-line-style-set! "unknown line style" line-style)]))]))]
	         [canvas-line-style/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasLineStyle(canvas, CD_QUERY));")]
	         [canvas-line-style
	          (lambda (canvas)
	          	(let ([line-style (canvas-line-style/raw canvas)])
	          		(cond
									[(rassoc line-style line-styles) => car]
									[else (error 'canvas-line-style "unknown line style" line-style)])))])
	  (values
	  	(getter-with-setter canvas-line-style canvas-line-style-set!)
	  	canvas-line-style-set!)))

(define canvas-line-width-set!
	(foreign-lambda int "cdCanvasLineWidth" nonnull-canvas int))

(define canvas-line-width
	(getter-with-setter
		(foreign-lambda* int ([nonnull-canvas canvas])
			"C_return(cdCanvasLineWidth(canvas, CD_QUERY));")
		canvas-line-width-set!))

(define-values (canvas-line-join canvas-line-join-set!)
	(letrec ([line-joins
	          (list
	          	(cons
	          		'miter
	          		(foreign-value "CD_MITER" int))
	          	(cons
	          		'bevel
	          		(foreign-value "CD_BEVEL" int))
	          	(cons
	          		'round
	          		(foreign-value "CD_ROUND" int)))]
	         [canvas-line-join-set/raw!
	          (foreign-lambda void "cdCanvasLineJoin" nonnull-canvas int)]
	         [canvas-line-join-set!
	          (lambda (canvas line-join)
							(canvas-line-join-set/raw!
								canvas
								(cond
									[(assq line-join line-joins) => cdr]
									[else (error 'canvas-line-join-set! "unknown line join" line-join)])))]
	         [canvas-line-join/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasLineJoin(canvas, CD_QUERY));")]
	         [canvas-line-join
	          (lambda (canvas)
	          	(let ([line-join (canvas-line-join/raw canvas)])
	          		(cond
									[(rassoc line-join line-joins) => car]
									[else (error 'canvas-line-join "unknown line join" line-join)])))])
		(values
			(getter-with-setter canvas-line-join canvas-line-join-set!)
			canvas-line-join-set!)))

(define-values (canvas-line-cap canvas-line-cap-set!)
	(letrec ([line-caps
	          (list
	          	(cons
	          		'flat
	          		(foreign-value "CD_CAPFLAT" int))
	          	(cons
	          		'square
	          		(foreign-value "CD_CAPSQUARE" int))
	          	(cons
	          		'round
	          		(foreign-value "CD_CAPROUND" int)))]
	         [canvas-line-cap-set/raw!
	          (foreign-lambda void "cdCanvasLineCap" nonnull-canvas int)]
	         [canvas-line-cap-set!
	          (lambda (canvas line-cap)
							(canvas-line-cap-set/raw!
								canvas
								(cond
									[(assq line-cap line-caps) => cdr]
									[else (error 'canvas-line-cap-set! "unknown line cap" line-cap)])))]
	         [canvas-line-cap/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasLineCap(canvas, CD_QUERY));")]
	         [canvas-line-cap
	          (lambda (canvas)
	          	(let ([line-cap (canvas-line-cap/raw canvas)])
								(cond
									[(rassoc line-cap line-caps) => car]
									[else (error 'canvas-line-cap "unknown line cap" line-cap)])))])
		(values
			(getter-with-setter canvas-line-cap canvas-line-cap-set!)
			canvas-line-cap-set!)))

;; }}}

;; {{{ Filled area functions

(define canvas-box!
	(foreign-lambda void "cdfCanvasBox" nonnull-canvas double double double double))

(define canvas-sector!
	(foreign-lambda void "cdfCanvasSector" nonnull-canvas double double double double double double))

(define canvas-chord!
	(foreign-lambda void "cdfCanvasChord" nonnull-canvas double double double double double double))

(define-values (canvas-background-opacity canvas-background-opacity-set!)
	(letrec ([opacities
	          (list
	          	(cons
	          		'opaque
	          		(foreign-value "CD_OPAQUE" int))
	          	(cons
	          		'transparent
	          		(foreign-value "CD_TRANSPARENT" int)))]
	         [canvas-background-opacity-set/raw!
	          (foreign-lambda void "cdCanvasBackOpacity" nonnull-canvas int)]
	         [canvas-background-opacity-set!
	          (lambda (canvas opacity)
							(canvas-background-opacity-set/raw!
								canvas
								(cond
									[(assq opacity opacities) => cdr]
									[else (error 'canvas-background-opacity-set! "unknown line cap" opacity)])))]
	         [canvas-background-opacity/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasBackOpacity(canvas, CD_QUERY));")]
	         [canvas-background-opacity
	          (lambda (canvas)
	          	(let ([opacity (canvas-background-opacity/raw canvas)])
	          		(cond
									[(rassoc opacity opacities) => car]
									[else (error 'canvas-background-opacity "unknown opacity" opacity)])))])
		(values
			(getter-with-setter canvas-background-opacity canvas-background-opacity-set!)
			canvas-background-opacity-set!)))

(define-values (canvas-fill-mode canvas-fill-mode-set!)
	(letrec ([fill-modes
	          (list
	          	(cons
	          		'even-odd
	          		(foreign-value "CD_EVENODD" int))
	          	(cons
	          		'winding
	          		(foreign-value "CD_WINDING" int)))]
	         [canvas-fill-mode-set/raw!
	          (foreign-lambda void "cdCanvasFillMode" nonnull-canvas int)]
	         [canvas-fill-mode-set!
	          (lambda (canvas fill-mode)
							(canvas-fill-mode-set/raw!
								canvas
								(cond
									[(assq fill-mode fill-modes) => cdr]
									[else (error 'canvas-fill-mode-set! "unknown fill mode" fill-mode)])))]
	         [canvas-fill-mode/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasFillMode(canvas, CD_QUERY));")]
	         [canvas-fill-mode
	          (lambda (canvas)
	          	(let ([fill-mode (canvas-fill-mode/raw canvas)])
								(cond
									[(rassoc fill-mode fill-modes) => car]
									[else (error 'canvas-fill-mode "unknown fill mode" fill-mode)])))])
		(values
			(getter-with-setter canvas-fill-mode canvas-fill-mode-set!)
			canvas-fill-mode-set!)))

(define-values (canvas-interior-style canvas-interior-style-set!)
	(letrec ([interior-styles
	          (list
	          	(cons
	          		'solid
	          		(foreign-value "CD_SOLID" int))
	          	(cons
	          		'hollow
	          		(foreign-value "CD_HOLLOW" int))
	          	(cons
	          		'hatch
	          		(foreign-value "CD_HATCH" int))
	          	(cons
	          		'stipple
	          		(foreign-value "CD_STIPPLE" int))
	          	(cons
	          		'pattern
	          		(foreign-value "CD_PATTERN" int)))]
	         [hatch-styles
	          (list
	          	(cons
	          		'horizontal
	          		(foreign-value "CD_HORIZONTAL" int))
	          	(cons
	          		'vertical
	          		(foreign-value "CD_VERTICAL" int))
	          	(cons
	          		'forward-diagonal
	          		(foreign-value "CD_FDIAGONAL" int))
	          	(cons
	          		'backward-diagonal
	          		(foreign-value "CD_BDIAGONAL" int))
	          	(cons
	          		'cross
	          		(foreign-value "CD_CROSS" int))
	          	(cons
	          		'diagonal-cross
	          		(foreign-value "CD_DIAGCROSS" int)))]
	         [canvas-hatch-style-set/raw!
	          (foreign-lambda int "cdCanvasHatch" nonnull-canvas int)]
	         [canvas-hatch-style/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasHatch(canvas, CD_QUERY));")]
	         [canvas-stipple-set/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
	          	"unsigned char mask[width * height];\n"
	          	"int i, j;\n"
	          	"\n"
	          	"for (j = 0; j < height; ++j) {\n"
	          	"	for (i = 0; i < width; ++i) {\n"
	          	"		const int ofs = (j * width) + i;\n"
	          	"		mask[ofs] = (data[ofs / 8] >> (ofs % 8)) & 1;\n"
	          	"	}\n"
	          	"}\n"
	          	"cdCanvasStipple(canvas, width, height, mask);\n")]
	         [canvas-stipple/raw
	          (foreign-lambda* void ([nonnull-canvas canvas] [(c-pointer int) pwidth] [(c-pointer int) pheight] [blob data])
	          	"unsigned char *mask = cdCanvasGetStipple(canvas, pwidth, pheight);\n"
	          	"\n"
	          	"if (data) {\n"
	          	"	int width = *pwidth, height = *pheight;\n"
	          	"	int i, j;\n"
	          	"	\n"
	          	"	for (j = 0; j < height; ++j) {\n"
	          	"		for (i = 0; i < width; ++i) {\n"
	          	"			const int ofs = (j * width) + i;\n"
	          	"			const int vofs = ofs / 8, bofs = ofs % 8;\n"
	          	"			const unsigned char bit = mask[ofs] & 1;\n"
	          	"			\n"
	          	"			if (bofs > 0)\n"
	          	"				data[vofs] |= bit << bofs;\n"
	          	"			else\n"
	          	"				data[vofs] = bit;\n"
	          	"		}\n"
	          	"	}\n"
	          	"}\n")]
	         [canvas-pattern-set/rgb/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
	          	"long color[width * height];\n"
	          	"int i, j;\n"
	          	"\n"
	          	"for (j = 0; j < height; ++j) {\n"
	          	"	for (i = 0; i < width; ++i, data += 3) {\n"
	          	"		color[(j * width) + i] =\n"
	          	"			(data[0] << 16) | (data[1] << 8) | (data[2]);\n"
	          	"	}\n"
	          	"}\n"
	          	"cdCanvasPattern(canvas, width, height, color);\n")]
	         [canvas-pattern-set/rgba/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
	          	"long color[width * height];\n"
	          	"int i, j;\n"
	          	"\n"
	          	"for (j = 0; j < height; ++j) {\n"
	          	"	for (i = 0; i < width; ++i, data += 4) {\n"
	          	"		color[(j * width) + i] =\n"
	          	"			((0xff - data[3]) << 24) | (data[0] << 16) | (data[1] << 8) | (data[2]);\n"
	          	"	}\n"
	          	"}\n"
	          	"cdCanvasPattern(canvas, width, height, color);\n")]
	         [canvas-pattern/rgba/raw
	          (foreign-lambda* void ([nonnull-canvas canvas] [(c-pointer int) pwidth] [(c-pointer int) pheight] [blob data])
	          	"long *color = cdCanvasGetPattern(canvas, pwidth, pheight);\n"
	          	"\n"
	          	"if (data) {\n"
	          	"	int width = *pwidth, height = *pheight;\n"
	          	"	int i, j;\n"
	          	"	\n"
	          	"	for (j = 0; j < height; ++j) {\n"
	          	"		for (i = 0; i < width; ++i, data += 4) {\n"
	          	"			long c = color[(j * width) + i];\n"
	          	"			data[3] = 0xff - ((c >> 24) & 0xff);\n"
	          	"			data[0] = (c >> 16) & 0xff;\n"
	          	"			data[1] = (c >> 8) & 0xff;\n"
	          	"			data[2] = c & 0xff;\n"
	          	"		}\n"
	          	"	}\n"
	          	"}\n")]
	         [canvas-interior-style-set/raw!
	          (foreign-lambda void "cdCanvasInteriorStyle" nonnull-canvas int)]
	         [canvas-interior-style-set!
	          (lambda (canvas interior-style)
							(case (and (pair? interior-style) (car interior-style))
								[(hatch)
								 (let ([hatch-style (cadr interior-style)])
									 (canvas-hatch-style-set/raw!
										 canvas
										 (cond
										 	 [(assq hatch-style hatch-styles) => cdr]
										 	 [else (error 'canvas-interior-style-set! "unknown hatch style" hatch-style)]))
									 (canvas-interior-style-set/raw! canvas (cdr (assq 'hatch interior-styles))))]
								[(stipple)
								 (let ([width (cadr interior-style)]
											 [height (caddr interior-style)]
											 [data (cadddr interior-style)])
									 (unless (= (blob-size data) (ceiling (/ (* width height) 8)))
										 (error 'canvas-interior-style-set! "bad stipple data length" (blob-size data) (ceiling (/ (* width height) 8))))
									 (canvas-stipple-set/raw! canvas width height data)
									 (canvas-interior-style-set/raw! canvas (cdr (assq 'stipple interior-styles))))]
								[(pattern/rgb)
								 (let ([width (cadr interior-style)]
											 [height (caddr interior-style)]
											 [data (cadddr interior-style)])
									 (unless (= (blob-size data) (* 3 width height))
										 (error 'canvas-interior-style-set! "bad pattern data length" (blob-size data) (* 3 width height)))
									 (canvas-pattern-set/rgb/raw! canvas width height data)
									 (canvas-interior-style-set/raw! canvas (cdr (assq 'pattern interior-styles))))]
								[(pattern/rgba)
								 (let ([width (cadr interior-style)]
											 [height (caddr interior-style)]
											 [data (cadddr interior-style)])
									 (unless (= (blob-size data) (* 4 width height))
										 (error 'canvas-interior-style-set! "bad pattern data length" (blob-size data) (* 4 width height)))
									 (canvas-pattern-set/rgba/raw! canvas width height data)
									 (canvas-interior-style-set/raw! canvas (cdr (assq 'pattern interior-styles))))]
								[else
								 (canvas-interior-style-set/raw!
									 canvas
									 (cond
									 	 [(assq interior-style interior-styles) => cdr]
									 	 [else (error 'canvas-interior-style-set! "unknown interior style" interior-style)]))]))]
	         [canvas-interior-style/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasInteriorStyle(canvas, CD_QUERY));")]
	         [canvas-interior-style
	          (lambda (canvas)
	          	(let* ([interior-style (canvas-interior-style/raw canvas)]
	          	       [interior-style
	          	       (cond
	          	       	 [(rassoc interior-style interior-styles) => car]
	          	       	 [else (error 'canvas-interior-style "unknown interior style" interior-style)])])
								(case interior-style
									[(hatch)
									 (let ([hatch-style (canvas-hatch-style/raw canvas)])
										 (list
											 'hatch
											 (cond
												 [(rassoc hatch-style hatch-styles) => car]
												 [else (error 'canvas-interior-style "unknown hatch style" hatch-style)])))]
									[(stipple)
									 (let-location ([width int 0] [height int 0])
									 	 (canvas-stipple/raw canvas (location width) (location height) #f)
										 (let ([data (make-blob (inexact->exact (ceiling (/ (* width height) 8))))])
											 (canvas-stipple/raw canvas (location width) (location height) data)
											 (list 'stipple width height data)))]
									[(pattern)
									 (let-location ([width int 0] [height int 0])
									 	 (canvas-pattern/rgba/raw canvas (location width) (location height) #f)
										 (let ([data (make-blob (* 4 width height))])
											 (canvas-pattern/rgba/raw canvas (location width) (location height) data)
											 (list 'pattern/rgba width height data)))]
									[else
									 interior-style])))])
		(values
			(getter-with-setter canvas-interior-style canvas-interior-style-set!)
			canvas-interior-style-set!)))

;; }}}

;; {{{ Text functions

(define canvas-text!
	(foreign-lambda void "cdfCanvasText" nonnull-canvas double double nonnull-c-string))

(define canvas-font-set!
	(foreign-lambda c-string "cdCanvasNativeFont" nonnull-canvas nonnull-c-string))

(define canvas-font
	(getter-with-setter
		(foreign-lambda* c-string ([nonnull-canvas canvas])
			"C_return(cdCanvasNativeFont(canvas, NULL));")
		canvas-font-set!))

(define-values (canvas-text-alignment canvas-text-alignment-set!)
	(letrec ([alignments
	          (list
	          	(cons
	          		'north
	          		(foreign-value "CD_NORTH" int))
	          	(cons
	          		'south
	          		(foreign-value "CD_SOUTH" int))
	          	(cons
	          		'east
	          		(foreign-value "CD_EAST" int))
	          	(cons
	          		'west
	          		(foreign-value "CD_WEST" int))
	          	(cons
	          		'north-east
	          		(foreign-value "CD_NORTH_EAST" int))
	          	(cons
	          		'north-west
	          		(foreign-value "CD_NORTH_WEST" int))
	          	(cons
	          		'south-east
	          		(foreign-value "CD_SOUTH_EAST" int))
	          	(cons
	          		'south-west
	          		(foreign-value "CD_SOUTH_WEST" int))
	          	(cons
	          		'center
	          		(foreign-value "CD_CENTER" int))
	          	(cons
	          		'base-left
	          		(foreign-value "CD_BASE_LEFT" int))
	          	(cons
	          		'base-center
	          		(foreign-value "CD_BASE_CENTER" int))
	          	(cons
	          		'base-right
	          		(foreign-value "CD_BASE_RIGHT" int)))]
	         [canvas-text-alignment-set/raw!
	          (foreign-lambda void "cdCanvasTextAlignment" nonnull-canvas int)]
	         [canvas-text-alignment-set!
	          (lambda (canvas alignment)
							(canvas-text-alignment-set/raw!
								canvas
								(cond
									[(assq alignment alignments) => cdr]
									[else (error 'canvas-text-alignment-set! "unknown alignment" alignment)])))]
	         [canvas-text-alignment/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasTextAlignment(canvas, CD_QUERY));")]
	         [canvas-text-alignment
	          (lambda (canvas)
	          	(let ([alignment (canvas-text-alignment/raw canvas)])
								(cond
									[(rassoc alignment alignments) => car]
									[else (error 'canvas-text-alignment "unknown alignment" alignment)])))])
		(values
			(getter-with-setter canvas-text-alignment canvas-text-alignment-set!)
			canvas-text-alignment-set!)))

(define canvas-text-orientation-set!
	(foreign-lambda void "cdCanvasTextOrientation" nonnull-canvas double))

(define canvas-text-orientation
	(getter-with-setter
		(foreign-lambda* double ([nonnull-canvas canvas])
			"C_return(cdCanvasTextOrientation(canvas, CD_QUERY));")
		canvas-text-orientation-set!))

(define canvas-font-dimensions
	(letrec ([canvas-font-dimensions/raw
	          (foreign-lambda void "cdCanvasGetFontDim" nonnull-canvas (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int))])
	  (lambda (canvas)
	  	(let-location ([max-width int 0]
	  	               [height int 0]
	  	               [ascent int 0]
	  	               [descent int 0])
	  	  (canvas-font-dimensions/raw canvas (location max-width) (location height) (location ascent) (location descent))
	  	  (values max-width height ascent descent)))))

(define canvas-text-size
	(letrec ([canvas-text-size/raw
	          (foreign-lambda void "cdCanvasGetTextSize" nonnull-canvas nonnull-c-string (c-pointer int) (c-pointer int))])
	  (lambda (canvas text)
	  	(let-location ([width int 0] [height int 0])
	  		(canvas-text-size/raw canvas text (location width) (location height))
	  		(values width height)))))

(define canvas-text-box
	(letrec ([canvas-text-box/raw
	          (foreign-lambda void "cdCanvasGetTextBox" nonnull-canvas int int nonnull-c-string (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int))])
	  (lambda (canvas x y text)
	  	(let-location ([x0 int 0] [x1 int 0]
	  	               [y0 int 0] [y1 int 0])
	  	  (canvas-text-box/raw canvas x y text (location x0) (location x1) (location y0) (location y1))
	  	  (values x0 x1 y0 y1)))))

;; }}}

;; {{{ Vertex functions

(define call-with-canvas-in-mode
	(letrec ([canvas-modes
	          (list
	          	(cons
	          		'open-lines
	          		(foreign-value "CD_OPEN_LINES" int))
	          	(cons
	          		'closed-lines
	          		(foreign-value "CD_CLOSED_LINES" int))
	          	(cons
	          		'fill
	          		(foreign-value "CD_FILL" int))
	          	(cons
	          		'clip
	          		(foreign-value "CD_CLIP" int))
	          	(cons
	          		'bezier
	          		(foreign-value "CD_BEZIER" int))
	          	(cons
	          		'region
	          		(foreign-value "CD_REGION" int))
	          	(cons
	          		'path
	          		(foreign-value "CD_PATH" int)))]
	         [canvas-begin
	          (foreign-lambda void "cdCanvasBegin" nonnull-canvas int)]
	         [canvas-end
	          (foreign-lambda void "cdCanvasEnd" nonnull-canvas)])
	  (lambda (canvas canvas-mode proc)
	  	(let ([canvas-mode
	  	       (cond
	  	       	 [(assq canvas-mode canvas-modes) => cdr]
	  	       	 [else (error 'with-canvas-mode "unknown canvas mode" canvas-mode)])])
				(dynamic-wind
					(cut canvas-begin canvas canvas-mode)
					(cut proc canvas)
					(cut canvas-end canvas))))))

(define canvas-path-set!
	(letrec ([path-actions
	          (list
	          	(cons
	          		'new
	          		(foreign-value "CD_PATH_NEW" int))
	          	(cons
	          		'move-to
	          		(foreign-value "CD_PATH_MOVETO" int))
	          	(cons
	          		'line-to
	          		(foreign-value "CD_PATH_LINETO" int))
	          	(cons
	          		'arc
	          		(foreign-value "CD_PATH_ARC" int))
	          	(cons
	          		'curve-to
	          		(foreign-value "CD_PATH_CURVETO" int))
	          	(cons
	          		'close
	          		(foreign-value "CD_PATH_CLOSE" int))
	          	(cons
	          		'fill
	          		(foreign-value "CD_PATH_FILL" int))
	          	(cons
	          		'stroke
	          		(foreign-value "CD_PATH_STROKE" int))
	          	(cons
	          		'fill+stroke
	          		(foreign-value "CD_PATH_FILLSTROKE" int))
	          	(cons
	          		'clip
	          		(foreign-value "CD_PATH_CLIP" int)))]
	         [canvas-path-set/raw!
	          (foreign-lambda void "cdCanvasPathSet" nonnull-canvas int)])
	  (lambda (canvas path-action)
	  	(canvas-path-set/raw!
	  		canvas
	  		(cond
	  			[(assq path-action path-actions) => cdr]
	  			[else (error 'canvas-path-set! "unknown path action" path-action)])))))

(define canvas-vertex!
	(foreign-lambda void "cdfCanvasVertex" nonnull-canvas double double))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-printer
	(context:printer)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdprint.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:printer
	(foreign-value "CD_PRINTER" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-ps
	(context:ps)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdps.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:ps
	(foreign-value "CD_PS" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-server
	(context:image context:double-buffer)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdimage.h>\n"
	"#include <cddbuf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:image
	(foreign-value "CD_IMAGE" nonnull-context))

(define context:double-buffer
	(foreign-value "CD_DBUFFER" nonnull-context))

;; }}}

)

(require-library canvas-draw-base)

(module canvas-draw-svg
	(context:svg)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdsvg.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:svg
	(foreign-value "CD_SVG" nonnull-context))

;; }}}

)

(define-foreign-type canvas (c-pointer "cdCanvas")
	(canvas->pointer #f)
	(pointer->canvas #f))

(define-foreign-type nonnull-canvas (nonnull-c-pointer "cdCanvas")
	(canvas->pointer #t)
	(pointer->canvas #t))

(define-foreign-type context (c-pointer "cdContext")
	(context->pointer #f)
	(pointer->context #f))

(define-foreign-type nonnull-context (nonnull-c-pointer "cdContext")
	(context->pointer #t)
	(pointer->context #t))

(define-foreign-type state (c-pointer "cdState")
	(state->pointer #f)
	(pointer->state #f))

(define-foreign-type nonnull-state (nonnull-c-pointer "cdState")
	(state->pointer #t)
	(pointer->state #t))

(require-library canvas-draw-base)

(module canvas-draw-wmf
	(context:wmf)
	(import scheme chicken foreign canvas-draw-base)

;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdwmf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:wmf
	(foreign-value "CD_WMF" nonnull-context))

;; }}}

)

((category graphics)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "Bindings to the CD graphics library")
 (documentation "http://www.chust.org/fossils/canvas-draw"))

(require-library
	canvas-draw-base canvas-draw-primitives canvas-draw-play)

(module canvas-draw
	()
	(import scheme chicken)
	(reexport
		(except canvas-draw-base
		        canvas->pointer pointer->canvas
		        context->pointer pointer->context
		        state->pointer pointer->state)
		canvas-draw-primitives
		canvas-draw-play))

(if (find-library "cd" "cdCreateCanvas")
	(begin
		(compile -s -O2 -d1 "canvas-draw-base.scm" -j canvas-draw-base "-lcd")
		(compile -c -O2 -d1 "canvas-draw-base.scm" -j canvas-draw-base -unit canvas-draw-base)
		(compile -s -O2 -d0 "canvas-draw-base.import.scm")
		
		(install-extension
		 'canvas-draw-base
		 '("canvas-draw-base.so" "canvas-draw-base.o" "canvas-draw-base.import.so" "canvas-draw-types.scm")
		 '((version 1.0.0)
			 (static "canvas-draw-base.o")
			 (static-options "-lcd")))
		
		(compile -s -O2 -d1 "canvas-draw-primitives.scm" -j canvas-draw-primitives "-lcd")
		(compile -c -O2 -d1 "canvas-draw-primitives.scm" -j canvas-draw-primitives -unit canvas-draw-primitives)
		(compile -s -O2 -d0 "canvas-draw-primitives.import.scm")
		
		(install-extension
		 'canvas-draw-primitives
		 '("canvas-draw-primitives.so" "canvas-draw-primitives.o" "canvas-draw-primitives.import.so" "canvas-draw-types.scm")
		 '((version 1.0.0)
			 (static "canvas-draw-primitives.o")
			 (static-options "-lcd")))
		
		(compile -s -O2 -d1 "canvas-draw-play.scm" -j canvas-draw-play "-lcd")
		(compile -c -O2 -d1 "canvas-draw-play.scm" -j canvas-draw-play -unit canvas-draw-play)
		(compile -s -O2 -d0 "canvas-draw-play.import.scm")
		
		(install-extension
		 'canvas-draw-play
		 '("canvas-draw-play.so" "canvas-draw-play.o" "canvas-draw-play.import.so" "canvas-draw-types.scm")
		 '((version 1.0.0)
			 (static "canvas-draw-play.o")
			 (static-options "-lcd")))
		
		(if (find-library "iupcd" "cdContextIup")
			(begin
				(compile -s -O2 -d1 "canvas-draw-iup.scm" -j canvas-draw-iup "-liupcd")
				(compile -c -O2 -d1 "canvas-draw-iup.scm" -j canvas-draw-iup -unit canvas-draw-iup)
				(compile -s -O2 -d0 "canvas-draw-iup.import.scm")
				
				(install-extension
				 'canvas-draw-iup
				 '("canvas-draw-iup.so" "canvas-draw-iup.o" "canvas-draw-iup.import.so")
				 '((version 1.0.0)
					 (static "canvas-draw-iup.o")
					 (static-options "-liupcd"))))
			(warning "CD IUP driver not found, some bindings cannot be compiled"))
		
		(cond
			[(find-library "cdx11" "cdContextNativeWindow")
			 (compile -s -O2 -d1 "canvas-draw-native.scm" -j canvas-draw-native "-lcdx11 -lcdcontextplus")
			 (compile -c -O2 -d1 "canvas-draw-native.scm" -j canvas-draw-native -unit canvas-draw-native)
			 (compile -s -O2 -d0 "canvas-draw-native.import.scm")
			 
			 (install-extension
				'canvas-draw-native
				'("canvas-draw-native.so" "canvas-draw-native.o" "canvas-draw-native.import.so")
				'((version 1.0.0)
					(static "canvas-draw-native.o")
					(static-options "-lcdx11 -lcdcontextplus")))]
			[(find-library "cd" "cdContextNativeWindow")
			 (compile -s -O2 -d1 "canvas-draw-native.scm" -j canvas-draw-native "-lcd -lcdcontextplus")
			 (compile -c -O2 -d1 "canvas-draw-native.scm" -j canvas-draw-native -unit canvas-draw-native)
			 (compile -s -O2 -d0 "canvas-draw-native.import.scm")
			 
			 (install-extension
				'canvas-draw-native
				'("canvas-draw-native.so" "canvas-draw-native.o" "canvas-draw-native.import.so")
				'((version 1.0.0)
					(static "canvas-draw-native.o")
					(static-options "-lcd -lcdcontextplus")))]
			[else
			 (warning "CD native window driver not found, some bindings cannot be compiled")])
		
		(if (find-library "cdgl" "cdContextGL")
			(begin
				(compile -s -O2 -d1 "canvas-draw-gl.scm" -j canvas-draw-gl "-lcdgl")
				(compile -c -O2 -d1 "canvas-draw-gl.scm" -j canvas-draw-gl -unit canvas-draw-gl)
				(compile -s -O2 -d0 "canvas-draw-gl.import.scm")
				
				(install-extension
				 'canvas-draw-gl
				 '("canvas-draw-gl.so" "canvas-draw-gl.o" "canvas-draw-gl.import.so")
				 '((version 1.0.0)
					 (static "canvas-draw-gl.o")
					 (static-options "-lcdgl"))))
			(warning "CD OpenGL driver not found, some bindings cannot be compiled"))
		
		(cond
			[(find-library "cdx11" "cdContextClipboard")
			 (compile -s -O2 -d1 "canvas-draw-clipboard.scm" -j canvas-draw-clipboard "-lcdx11")
			 (compile -c -O2 -d1 "canvas-draw-clipboard.scm" -j canvas-draw-clipboard -unit canvas-draw-clipboard)
			 (compile -s -O2 -d0 "canvas-draw-clipboard.import.scm")
			 
			 (install-extension
				'canvas-draw-clipboard
				'("canvas-draw-clipboard.so" "canvas-draw-clipboard.o" "canvas-draw-clipboard.import.so")
				'((version 1.0.0)
					(static "canvas-draw-clipboard.o")
					(static-options "-lcdx11")))]
			[(find-library "cd" "cdContextClipboard")
			 (compile -s -O2 -d1 "canvas-draw-clipboard.scm" -j canvas-draw-clipboard "-lcd")
			 (compile -c -O2 -d1 "canvas-draw-clipboard.scm" -j canvas-draw-clipboard -unit canvas-draw-clipboard)
			 (compile -s -O2 -d0 "canvas-draw-clipboard.import.scm")
			 
			 (install-extension
				'canvas-draw-clipboard
				'("canvas-draw-clipboard.so" "canvas-draw-clipboard.o" "canvas-draw-clipboard.import.so")
				'((version 1.0.0)
					(static "canvas-draw-clipboard.o")
					(static-options "-lcd")))]
			[else
			 (warning "CD clipboard driver not found, some bindings cannot be compiled")])
		
		(cond
			[(find-library "cdx11" "cdContextPrinter")
			 (compile -s -O2 -d1 "canvas-draw-printer.scm" -j canvas-draw-printer "-lcdx11")
			 (compile -c -O2 -d1 "canvas-draw-printer.scm" -j canvas-draw-printer -unit canvas-draw-printer)
			 (compile -s -O2 -d0 "canvas-draw-printer.import.scm")
			 
			 (install-extension
				'canvas-draw-printer
				'("canvas-draw-printer.so" "canvas-draw-printer.o" "canvas-draw-printer.import.so")
				'((version 1.0.0)
					(static "canvas-draw-printer.o")
					(static-options "-lcdx11")))]
			[(find-library "cd" "cdContextPrinter")
			 (compile -s -O2 -d1 "canvas-draw-printer.scm" -j canvas-draw-printer "-lcd")
			 (compile -c -O2 -d1 "canvas-draw-printer.scm" -j canvas-draw-printer -unit canvas-draw-printer)
			 (compile -s -O2 -d0 "canvas-draw-printer.import.scm")
			 
			 (install-extension
				'canvas-draw-printer
				'("canvas-draw-printer.so" "canvas-draw-printer.o" "canvas-draw-printer.import.so")
				'((version 1.0.0)
					(static "canvas-draw-printer.o")
					(static-options "-lcd")))]
			[else
			 (warning "CD printer driver not found, some bindings cannot be compiled")])
		
		(if (find-library "cd" "cdContextPicture")
			(begin
				(compile -s -O2 -d1 "canvas-draw-picture.scm" -j canvas-draw-picture "-lcd")
				(compile -c -O2 -d1 "canvas-draw-picture.scm" -j canvas-draw-picture -unit canvas-draw-picture)
				(compile -s -O2 -d0 "canvas-draw-picture.import.scm")
				
				(install-extension
				 'canvas-draw-picture
				 '("canvas-draw-picture.so" "canvas-draw-picture.o" "canvas-draw-picture.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-picture.o")
				   (static-options "-lcd"))))
			(warning "CD picture driver not found, some bindings cannot be compiled"))
		
		(cond
			[(find-library "cdx11" "cdContextImage")
			 (compile -s -O2 -d1 "canvas-draw-server.scm" -j canvas-draw-server "-lcdx11")
			 (compile -c -O2 -d1 "canvas-draw-server.scm" -j canvas-draw-server -unit canvas-draw-server)
			 (compile -s -O2 -d0 "canvas-draw-server.import.scm")
			 
			 (install-extension
				'canvas-draw-server
				'("canvas-draw-server.so" "canvas-draw-server.o" "canvas-draw-server.import.so")
				'((version 1.0.0)
					(static "canvas-draw-server.o")
					(static-options "-lcdx11")))]
			[(find-library "cd" "cdContextImage")
			 (compile -s -O2 -d1 "canvas-draw-server.scm" -j canvas-draw-server "-lcd")
			 (compile -c -O2 -d1 "canvas-draw-server.scm" -j canvas-draw-server -unit canvas-draw-server)
			 (compile -s -O2 -d0 "canvas-draw-server.import.scm")
			 
			 (install-extension
				'canvas-draw-server
				'("canvas-draw-server.so" "canvas-draw-server.o" "canvas-draw-server.import.so")
				'((version 1.0.0)
					(static "canvas-draw-server.o")
					(static-options "-lcd")))]
			[else
			 (warning "CD server image driver not found, some bindings cannot be compiled")])
		
		(if (find-library "cd" "cdContextImageRGB")
			(begin
				(compile -s -O2 -d1 "canvas-draw-client.scm" -j canvas-draw-client "-lcd")
				(compile -c -O2 -d1 "canvas-draw-client.scm" -j canvas-draw-client -unit canvas-draw-client)
				(compile -s -O2 -d0 "canvas-draw-client.import.scm")
				
				(install-extension
				 'canvas-draw-client
				 '("canvas-draw-client.so" "canvas-draw-client.o" "canvas-draw-client.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-client.o")
				   (static-options "-lcd"))))
			(warning "CD client image driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cdpdf" "cdContextPDF")
			(begin
				(compile -s -O2 -d1 "canvas-draw-pdf.scm" -j canvas-draw-pdf "-lcdpdf")
				(compile -c -O2 -d1 "canvas-draw-pdf.scm" -j canvas-draw-pdf -unit canvas-draw-pdf)
				(compile -s -O2 -d0 "canvas-draw-pdf.import.scm")
				
				(install-extension
				 'canvas-draw-pdf
				 '("canvas-draw-pdf.so" "canvas-draw-pdf.o" "canvas-draw-pdf.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-pdf.o")
				   (static-options "-lcdpdf"))))
			(warning "CD PDF driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextPS")
			(begin
				(compile -s -O2 -d1 "canvas-draw-ps.scm" -j canvas-draw-ps "-lcd")
				(compile -c -O2 -d1 "canvas-draw-ps.scm" -j canvas-draw-ps -unit canvas-draw-ps)
				(compile -s -O2 -d0 "canvas-draw-ps.import.scm")
				
				(install-extension
				 'canvas-draw-ps
				 '("canvas-draw-ps.so" "canvas-draw-ps.o" "canvas-draw-ps.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-ps.o")
				   (static-options "-lcd"))))
			(warning "CD PostScript driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextSVG")
			(begin
				(compile -s -O2 -d1 "canvas-draw-svg.scm" -j canvas-draw-svg "-lcd")
				(compile -c -O2 -d1 "canvas-draw-svg.scm" -j canvas-draw-svg -unit canvas-draw-svg)
				(compile -s -O2 -d0 "canvas-draw-svg.import.scm")
				
				(install-extension
				 'canvas-draw-svg
				 '("canvas-draw-svg.so" "canvas-draw-svg.o" "canvas-draw-svg.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-svg.o")
				   (static-options "-lcd"))))
			(warning "CD SVG driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextMetafile")
			(begin
				(compile -s -O2 -d1 "canvas-draw-metafile.scm" -j canvas-draw-metafile "-lcd")
				(compile -c -O2 -d1 "canvas-draw-metafile.scm" -j canvas-draw-metafile -unit canvas-draw-metafile)
				(compile -s -O2 -d0 "canvas-draw-metafile.import.scm")
				
				(install-extension
				 'canvas-draw-metafile
				 '("canvas-draw-metafile.so" "canvas-draw-metafile.o" "canvas-draw-metafile.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-metafile.o")
				   (static-options "-lcd"))))
			(warning "CD metafile driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextDebug")
			(begin
				(compile -s -O2 -d1 "canvas-draw-debug.scm" -j canvas-draw-debug "-lcd")
				(compile -c -O2 -d1 "canvas-draw-debug.scm" -j canvas-draw-debug -unit canvas-draw-debug)
				(compile -s -O2 -d0 "canvas-draw-debug.import.scm")
				
				(install-extension
				 'canvas-draw-debug
				 '("canvas-draw-debug.so" "canvas-draw-debug.o" "canvas-draw-debug.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-debug.o")
				   (static-options "-lcd"))))
			(warning "CD debug driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextCGM")
			(begin
				(compile -s -O2 -d1 "canvas-draw-cgm.scm" -j canvas-draw-cgm "-lcd")
				(compile -c -O2 -d1 "canvas-draw-cgm.scm" -j canvas-draw-cgm -unit canvas-draw-cgm)
				(compile -s -O2 -d0 "canvas-draw-cgm.import.scm")
				
				(install-extension
				 'canvas-draw-cgm
				 '("canvas-draw-cgm.so" "canvas-draw-cgm.o" "canvas-draw-cgm.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-cgm.o")
				   (static-options "-lcd"))))
			(warning "CD CGM driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextDGN")
			(begin
				(compile -s -O2 -d1 "canvas-draw-dgn.scm" -j canvas-draw-dgn "-lcd")
				(compile -c -O2 -d1 "canvas-draw-dgn.scm" -j canvas-draw-dgn -unit canvas-draw-dgn)
				(compile -s -O2 -d0 "canvas-draw-dgn.import.scm")
				
				(install-extension
				 'canvas-draw-dgn
				 '("canvas-draw-dgn.so" "canvas-draw-dgn.o" "canvas-draw-dgn.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-dgn.o")
				   (static-options "-lcd"))))
			(warning "CD DGN driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextDXF")
			(begin
				(compile -s -O2 -d1 "canvas-draw-dxf.scm" -j canvas-draw-dxf "-lcd")
				(compile -c -O2 -d1 "canvas-draw-dxf.scm" -j canvas-draw-dxf -unit canvas-draw-dxf)
				(compile -s -O2 -d0 "canvas-draw-dxf.import.scm")
				
				(install-extension
				 'canvas-draw-dxf
				 '("canvas-draw-dxf.so" "canvas-draw-dxf.o" "canvas-draw-dxf.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-dxf.o")
				   (static-options "-lcd"))))
			(warning "CD DXF driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextEMF")
			(begin
				(compile -s -O2 -d1 "canvas-draw-emf.scm" -j canvas-draw-emf "-lcd")
				(compile -c -O2 -d1 "canvas-draw-emf.scm" -j canvas-draw-emf -unit canvas-draw-emf)
				(compile -s -O2 -d0 "canvas-draw-emf.import.scm")
				
				(install-extension
				 'canvas-draw-emf
				 '("canvas-draw-emf.so" "canvas-draw-emf.o" "canvas-draw-emf.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-emf.o")
				   (static-options "-lcd"))))
			(warning "CD EMF driver not found, some bindings cannot be compiled"))
		
		(if (find-library "cd" "cdContextWMF")
			(begin
				(compile -s -O2 -d1 "canvas-draw-wmf.scm" -j canvas-draw-wmf "-lcd")
				(compile -c -O2 -d1 "canvas-draw-wmf.scm" -j canvas-draw-wmf -unit canvas-draw-wmf)
				(compile -s -O2 -d0 "canvas-draw-wmf.import.scm")
				
				(install-extension
				 'canvas-draw-wmf
				 '("canvas-draw-wmf.so" "canvas-draw-wmf.o" "canvas-draw-wmf.import.so")
				 '((version 1.0.0)
				   (static "canvas-draw-wmf.o")
				   (static-options "-lcd"))))
			(warning "CD WMF driver not found, some bindings cannot be compiled"))
		
		(compile -s -O2 -d1 "canvas-draw.scm" -j canvas-draw)
		(compile -c -O2 -d1 "canvas-draw.scm" -j canvas-draw -unit canvas-draw)
		(compile -s -O2 -d0 "canvas-draw.import.scm")
		
		(install-extension
		 'canvas-draw
		 '("canvas-draw.so" "canvas-draw.o" "canvas-draw.import.so")
		 '((version 1.0.0)
			 (static "canvas-draw.o"))))
	(error "CD not found, none of the bindings can be compiled"))

C Changed\swith-canvas-mode\sinto\scall-with-canvas-in-mode
D 2010-10-22T02:35:02
F LICENSE.txt 0f326ce34f5e3196925dcb3937b90d96971e17d6
F api/base.wiki 01dd0798b9c4453ce6282feeb5e1503cee26ae1c
F api/cgm.wiki 2b71cdedb4227aaf72723673a575641cd0d1a2c3
F api/client.wiki 239992612ebc61eeab4170181248f71be3e245a4
F api/clipboard.wiki 3cffe76749de3ef0e14b4223d470a595174c78f1
F api/debug.wiki e61598f3ec7b96a7e62c0b56f4b42040a4ed446d
F api/dgn.wiki d803d2e8b886fbc5563cf9186d04dd9d47ca2f44
F api/dxf.wiki 7456a1e3e96f7dbf39aec7cd99cb7b0fb6bef284
F api/emf.wiki f046287334295eff404a8e5b29d5054abf1afbca
F api/gl.wiki 0fb6b8938a4ee8ffd2e56d9761499d55afe35bef
F api/iup.wiki f2ac6fadac1035fa2ef8dbb829cf310c3dc7e578
F api/main.wiki f30493803812062cec5e65b89b376476b755d790
F api/metafile.wiki cc4eafd9d5f948afcddcc4b1c2caa5d731a7cc4a
F api/native.wiki 907ab1647b4a587464b836acefdd6f73b021117c
F api/pdf.wiki 17ab6eed22b52fab61a48b963f5c8e7831d40ff2
F api/picture.wiki 242f6b8a92d5b46ca1cbe14e3f10d9acf0fcb852
F api/play.wiki 06ca7a82a61fef85ace33c80d677822977232a88
F api/primitives.wiki 36cfca72a54c325c13954fa0e6e9152aac432a16
F api/printer.wiki 4f3bac13f70c5b43b4b08c4dcd1b6c2a0d94ebe0
F api/ps.wiki 534b9c33560d082cc8501e6c5899f409d4f26e80
F api/server.wiki 1fc6ea53d8526211e902e1a43b1f2f1a13e96710
F api/svg.wiki 3cffd2303f1e2c34468d16bcaae111d70bc95f38
F api/wmf.wiki 8976c2a3fbd25bb0ecf0008e19ae8ad7b79e4248
F chicken/canvas-draw-base.scm a398b8328d3370f893d185c7b4a4e3ec2c88ed63
F chicken/canvas-draw-cgm.scm a689b8a73f0ec69e6c134b6baa1cbcebc174d6bf
F chicken/canvas-draw-client.scm b7d557a7f82f5b22cba521bc83bc4c5d8618d720
F chicken/canvas-draw-clipboard.scm e0d6041291334a9530a5611840f93c4aed75418e
F chicken/canvas-draw-debug.scm d0e3d962720987a7ca47c6b269e8e23085186352
F chicken/canvas-draw-dgn.scm 561a4a7057f70a9bddcdb89b3b61ae5d7afee586
F chicken/canvas-draw-dxf.scm 461f2e8836d6f57d8c0755bbce572d6ce13b6150
F chicken/canvas-draw-emf.scm 057c88a2dd79d619bdaa350ce5a0e4ed349198f1
F chicken/canvas-draw-gl.scm b3ceb42ae9205318196aa218dd7c453d2815a190
F chicken/canvas-draw-iup.scm 9b1370885d4e6b704b76640180802dbbb64de2bb
F chicken/canvas-draw-metafile.scm dff4d2cf55f2f16907dcc954aff0a1d6d3eca440
F chicken/canvas-draw-native.scm 54e46d244fdec7ea2e53e685a7891d98090bf795
F chicken/canvas-draw-pdf.scm 2ecd6081ed3dc94062363a9fa6f5bbebe679f549
F chicken/canvas-draw-picture.scm 401583817f5579edc979ba5a27baccab5fec87b4
F chicken/canvas-draw-play.scm 1da93abfbca5dcacebac2d2d7ca04e92e566dca3
F chicken/canvas-draw-primitives.scm 188fe57c8d275ad747e64921281199c09cb47c01
F chicken/canvas-draw-printer.scm 663846f6249066674ff1afca289f68ab1e499dfb
F chicken/canvas-draw-ps.scm a5eb1aed85d1db9283f069cc59d02f6e4663b2ef
F chicken/canvas-draw-server.scm eb1228217e7d9f91e6cddc7993e9af2a8924102d
F chicken/canvas-draw-svg.scm d20d221b427dbf2098d342cf5e533e22ed807772
F chicken/canvas-draw-types.scm 63aba3e3b863e40c4b6ba08fd6892cce6fc71b1b
F chicken/canvas-draw-wmf.scm 840e4fc7fc554a20f25e3aa227cbee478c683e19
F chicken/canvas-draw.meta b9b1e49fadca38a134afe7c7ac8c36b39c693090
F chicken/canvas-draw.scm a2bd02e214c70ad6b978e5f84379582047956032
F chicken/canvas-draw.setup 901a63a1f85c529a15c0dbb6e0810c7f6d13c77d
F racket/base.rkt 90a071f77daa2e97eb1576112d98d411484c62b3
F racket/cgm.rkt 450ed8492b949db1d3338716d9c9ae509534c260
F racket/client.rkt 1a260d97ea8351f86874a0479dfbcdcb87257715
F racket/clipboard.rkt ea82433da2d8c221147bdd0764d71869ddbf51db
F racket/debug.rkt e12561359f155699f1f97a887609e534e2ee786a
F racket/dgn.rkt 0f7fe3de34d385ada742a1b06aa42e522cda7951
F racket/dxf.rkt 6c38a90ce75f2b18bc961fd96d8e333e36526736
F racket/emf.rkt daeb9e090c57f92481ecb8876fa7ccf686a9e3ef
F racket/gl.rkt b2f08fa5b6b063528c00f716006e19457f7945df
F racket/info.rkt 32fcbd61f85f5cdbe26978840aa76df25cabb8c0
F racket/iup.rkt cde98249f51821b0038afe248dc5c460101425c8
F racket/main.rkt 92e540e2fff6fba7b8d33465343259ceab7c3c6f
F racket/metafile.rkt 7c81a9e55c72ad608411ed1af54d42a9955761dc
F racket/native.rkt c102ec574f10efe8711167f1f2856e42e0d88dca
F racket/pdf.rkt 75e477e6d1a4d8d6ff583937a5c8299477f03937
F racket/picture.rkt 1d85f63ef04a9550045ece803c5ddc16887474c9
F racket/play.rkt 799196508db45b0bf23e1c8b4d7d316faa22b1b0
F racket/primitives.rkt ed1ac7e149327202a2533bbced8ecfd6163a1a63
F racket/printer.rkt 5a4515ba82414f18d45ccb4df530545eb5aec406
F racket/ps.rkt fc8e7865424b549146a89d991b554fb0c558fd57
F racket/server.rkt b01bbbfe5d1e59f2eefa0494a2a03590046ddada
F racket/svg.rkt 36d0f855de7190e184a5eef27db71f37b1eaf95c
F racket/wmf.rkt 52ea848f8b60748809e3d9ffad603ace915a5354
P acecf54f4fcf8950fbfce3e4df9d575e4623db76
R 6d34495bd98f29b23f00e3b02170c376
U murphy
Z 0ec981d3607579245a2d8668e79d0222

33bf93359307b97701634526a6b6212d9397e04e

#lang racket
(require
 srfi/2
 srfi/17
 srfi/26
 ffi/unsafe
 ffi/unsafe/cvector
 ffi/unsafe/alloc
 ffi/unsafe/atomic)

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Data types

(define-cpointer-type _canvas)

(define-cpointer-type _context)

(define-cpointer-type _state)

(provide
 _canvas _canvas/null canvas?
 _context _context/null context?
 _state _state/null state?)

;; }}}

;; {{{ Canvas management

(define _capability-mask
  (_bitmask
   '(flush              = #x00000001
     clear              = #x00000002
     play               = #x00000004
     y-axis             = #x00000008
     clip-area          = #x00000010
     clip-polygon       = #x00000020
     region             = #x00000040
     rectangle          = #x00000080
     chord              = #x00000100
     image/rgb          = #x00000200
     image/rgba         = #x00000400
     image/map          = #x00000800
     get-image/rgb      = #x00001000
     image/server       = #x00002000
     background         = #x00004000
     background-opacity = #x00008000
     write-mode         = #x00010000
     line-style         = #x00020000
     line-width         = #x00040000
     fprimitives        = #x00080000
     hatch              = #x00100000
     stipple            = #x00200000
     pattern            = #x00400000
     font               = #x00800000
     font-dimensions    = #x01000000
     text-size          = #x02000000
     text-orientation   = #x04000000
     palette            = #x08000000
     line-cap           = #x10000000
     line-join          = #x20000000
     path               = #x40000000
     bezier             = #x80000000)
   _int))

(define context-capabilities
  (get-ffi-obj
   "cdContextCaps" libcd
   (_fun [context : _context] -> [capabilities : _capability-mask])))

(define use-context+
  (make-parameter #f))

(define use-context+!
  (get-ffi-obj
   "cdUseContextPlus" libcd
   (_fun [plus? : _bool = (use-context+)] -> _void)))

(define make-canvas/ptr
  (get-ffi-obj
   "cdCreateCanvas" libcd
   (_fun [context : _context] [data : _pointer] -> [canvas : _canvas/null])))

(define make-canvas/string
  (get-ffi-obj
   "cdCreateCanvas" libcd
   (_fun [context : _context] [data : _string/utf-8] -> [canvas : _canvas/null])))

(define canvas-kill
  ((deallocator)
   (get-ffi-obj
    "cdKillCanvas" libcd
    (_fun [canvas : _canvas] -> _void))))

(define canvas-activate!
  (get-ffi-obj
   "cdCanvasActivate" libcd
   (_fun [canvas : _canvas] -> _void)))

(define canvas-deactivate!
  (get-ffi-obj
   "cdCanvasDeactivate" libcd
   (_fun [canvas : _canvas] -> _void)))

(define make-canvas
  ((allocator canvas-kill)
   (λ (context data)
     (let ([make-canvas/data (if (string? data) make-canvas/string make-canvas/ptr)])
       (use-context+!)
       (cond
         [(make-canvas/data context data) => values]
         [else (error 'make-canvas "failed to create canvas")])))))

(define call-with-canvas
  (case-lambda
    [(canvas proc)
     (dynamic-wind
      (cut canvas-activate! canvas)
      (cut proc canvas)
      (cut canvas-deactivate! canvas))]
    [(context data proc)
     (let* ([make-canvas/data
             (if (string? data) make-canvas/string make-canvas/ptr)]
            [canvas
             (call-as-atomic
              (λ ()
                (use-context+!)
                (make-canvas/data context data)))])
       (unless canvas (error 'call-with-canvas "failed to create canvas"))
       (dynamic-wind
        (cut canvas-activate! canvas)
        (cut proc canvas)
        (λ ()
          (when canvas
            (canvas-kill canvas)
            (set! canvas #f)))))]))

(define canvas-context
  (get-ffi-obj
   "cdCanvasGetContext" libcd
   (_fun [canvas : _canvas] -> [context : _context])))

(define _simulation-mask
  (_bitmask
   '(none      = #x0000
     line      = #x0001
     rectangle = #x0002
     box       = #x0004
     arc       = #x0008
     sector    = #x0010
     chord     = #x0020
     polyline  = #x0040
     polygon   = #x0080
     text      = #x0100
     all       = #xFFFF
     lines     = #x004B
     fills     = #x00B4)
   _int))

(define canvas-simulate!
  (get-ffi-obj
   "cdCanvasSimulate" libcd
   (_fun [canvas : _canvas] [simulate : _simulation-mask] -> [simulate : _simulation-mask])))

(define _name
  (make-ctype
   _string/utf-8
   (λ (name)
     (cond
       [(symbol? name)
        (string-upcase (regexp-replace* #rx"-" (symbol->string name) "_"))]
       [else
        name]))
   #f))

(define canvas-attribute-set!
  (get-ffi-obj
   "cdCanvasSetAttribute" libcd
   (_fun [canvas : _canvas] [name : _name] [value : _string/utf-8] -> _void)))

(define canvas-attribute
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasGetAttribute" libcd
    (_fun [canvas : _canvas] [name : _name] -> [value : _string/utf-8]))
   canvas-attribute-set!))

(define canvas-state-set!
  (get-ffi-obj
   "cdCanvasRestoreState" libcd
   (_fun [canvas : _canvas] [state : _state] -> _void)))

(define state-release
  ((deallocator)
   (get-ffi-obj
    "cdReleaseState" libcd
    (_fun [state : _state] -> _void))))

(define canvas-state
  (getter-with-setter
   ((allocator state-release)
    (get-ffi-obj
     "cdCanvasSaveState" libcd
     (_fun [canvas : _canvas] -> [state : _state])))
   canvas-state-set!))

(define canvas-clear!
  (get-ffi-obj
   "cdCanvasClear" libcd
   (_fun [canvas : _canvas] -> _void)))

(define canvas-flush
  (get-ffi-obj
   "cdCanvasFlush" libcd
   (_fun [canvas : _canvas] -> _void)))

(provide
 context-capabilities
 use-context+ make-canvas call-with-canvas
 canvas-context
 canvas-simulate!
 canvas-attribute canvas-attribute-set!
 canvas-state canvas-state-set!
 canvas-clear! canvas-flush)

;; }}}

;; {{{ Coordinate system

(define canvas-size
  (get-ffi-obj
   "cdCanvasGetSize" libcd
   (_fun [canvas : _canvas]
         [width/px : (_ptr o _int)] [height/px : (_ptr o _int)]
         [width/mm : (_ptr o _double)] [height/mm : (_ptr o _double)]
         -> _void
         -> (values
             width/px height/px
             width/mm height/mm))))

(define canvas-mm->px
  (get-ffi-obj
   "cdCanvasMM2Pixel" libcd
   (_fun [canvas : _canvas]
         [x/mm : _double*] [y/mm : _double*]
         [x/px : (_ptr o _int)] [y/px : (_ptr o _int)]
         -> _void
         -> (values x/px y/px))))

(define canvas-px->mm
  (get-ffi-obj
   "cdCanvasPixel2MM" libcd
   (_fun [canvas : _canvas]
         [x/px : _int] [y/px : _int]
         [x/mm : (_ptr o _double)] [y/mm : (_ptr o _double)]
         -> _void
         -> (values x/mm y/mm))))

(define canvas-origin-set!
  (get-ffi-obj
   "cdCanvasOrigin" libcd
   (_fun [canvas : _canvas] [x : _int] [y : _int] -> _void)))

(define canvas-origin
  (get-ffi-obj
   "cdCanvasGetOrigin" libcd
   (_fun [canvas : _canvas] [x : (_ptr o _int)] [y : (_ptr o _int)]
         -> _void
         -> (values x y))))

(define _transform
  (make-ctype
   _gcpointer
   (λ (proc)
     (and
      proc
      (let* ([v (make-cvector _double* 6)])
        (let-values ([(dx dy) (proc 0 0)])
          (cvector-set! v 4 dx)
          (cvector-set! v 5 dy)
          (let-values ([(x y) (proc 1 0)])
            (cvector-set! v 0 (- x dx))
            (cvector-set! v 1 (- y dy)))
          (let-values ([(x y) (proc 0 1)])
            (cvector-set! v 2 (- x dx))
            (cvector-set! v 3 (- y dy))))
        (cvector-ptr v))))
   (λ (v)
     (and-let* ([v (and v (make-cvector* v _double* 6))])
       (let ([sx0 (cvector-ref v 0)] [sx1 (cvector-ref v 1)]
             [sy0 (cvector-ref v 2)] [sy1 (cvector-ref v 3)]
             [dx (cvector-ref v 4)] [dy (cvector-ref v 5)])
         (λ (x y)
           (values
            (+ (* sx0 x) (* sy0 y) dx)
            (+ (* sx1 x) (* sy1 y) dy))))))))

(define canvas-transform-set!
  (get-ffi-obj
   "cdCanvasTransform" libcd
   (_fun [canvas : _canvas] [transform : _transform] -> _void)))

(define canvas-transform
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasGetTransform" libcd
    (_fun [canvas : _canvas] -> [transform : _transform]))
   canvas-transform-set!))

(define canvas-transform-compose!
  (get-ffi-obj
   "cdCanvasTransformMultiply" libcd
   (_fun [canvas : _canvas] [transform : _transform] -> _void)))

(define canvas-transform-translate!
  (get-ffi-obj
   "cdCanvasTransformTranslate" libcd
   (_fun [canvas : _canvas] [dx : _double*] [dy : _double*] -> _void)))

(define canvas-transform-scale!
  (get-ffi-obj
   "cdCanvasTransformScale" libcd
   (_fun [canvas : _canvas] [sx : _double*] [sy : _double*] -> _void)))

(define canvas-transform-rotate!
  (get-ffi-obj
   "cdCanvasTransformRotate" libcd
   (_fun [canvas : _canvas] [alpha : _double*] -> _void)))

(provide
 canvas-size
 canvas-mm->px canvas-px->mm
 canvas-origin canvas-origin-set!
 canvas-transform canvas-transform-set!
 canvas-transform-compose!
 canvas-transform-translate!
 canvas-transform-scale!
 canvas-transform-rotate!)

;; }}}

;; {{{ General attributes

(define canvas-foreground-set!
  (get-ffi-obj
   "cdCanvasSetForeground" libcd
   (_fun [canvas : _canvas] [color : _ulong] -> _void)))

(define canvas-foreground
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasForeground" libcd
    (_fun [canvas : _canvas] [query : _long = -1] -> [color : _ulong]))
   canvas-foreground-set!))

(define canvas-background-set!
  (get-ffi-obj
   "cdCanvasSetBackground" libcd
   (_fun [canvas : _canvas] [color : _ulong] -> _void)))

(define canvas-background
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasBackground" libcd
    (_fun [canvas : _canvas] [query : _long = -1] -> [color : _ulong]))
   canvas-background-set!))

(define _write-mode
  (_enum '(replace xor not-xor)))

(define canvas-write-mode-set!
  (get-ffi-obj
   "cdCanvasWriteMode" libcd
   (_fun [canvas : _canvas] [mode : _write-mode] -> _void)))

(define canvas-write-mode
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasWriteMode" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> [mode : _write-mode]))
   canvas-write-mode-set!))

(provide
 canvas-foreground canvas-foreground-set!
 canvas-background canvas-background-set!
 canvas-write-mode canvas-write-mode-set!)

;; }}}

;; {{{ Clipping

(define _clip-mode
  (_enum '(#f area polygon region)))

(define canvas-clip-mode-set!
  (get-ffi-obj
   "cdCanvasClip" libcd
   (_fun [canvas : _canvas] [mode : _clip-mode] -> _void)))

(define canvas-clip-mode
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasClip" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> [mode : _clip-mode]))
   canvas-clip-mode-set!))

(define canvas-clip-area-set!
  (get-ffi-obj
   "cdfCanvasClipArea" libcd
   (_fun [canvas : _canvas] [x0 : _double*] [x1 : _double*] [y0 : _double*] [y1 : _double*] -> _void)))

(define canvas-clip-area
  (get-ffi-obj
   "cdfCanvasGetClipArea" libcd
   (_fun [canvas : _canvas]
         [x0 : (_ptr o _double)] [x1 : (_ptr o _double)]
         [y0 : (_ptr o _double)] [y1 : (_ptr o _double)]
         -> _void
         -> (values x0 x1 y0 y1))))

(provide
 canvas-clip-mode canvas-clip-mode-set!
 canvas-clip-area canvas-clip-area-set!)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:cgm
  ((get-ffi-obj "cdContextCGM" libcd (_fun -> [context : _context]))))

(provide
 context:cgm)

;; }}}

#lang racket
(require
 srfi/17
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:image
  ((get-ffi-obj "cdContextImageRGB" libcd (_fun -> [context : _context]))))

(define context:double-buffer
  ((get-ffi-obj "cdContextDBufferRGB" libcd (_fun -> [context : _context]))))

(provide
 context:image context:double-buffer)

;; }}}

;; {{{ Auxiliary functions

(define (bytes-slice bstr n k slen)
  (let ([blen (bytes-length bstr)])
    (unless (= blen (* n slen))
      (error 'bytes-slice "data length mismatch (actual ~s, required ~s)" blen (* n slen)))
    (let ([slice (make-bytes slen)])
      (for ([bi (in-range k blen n)] [si (in-range slen)])
        (bytes-set! slice si (bytes-ref bstr bi)))
      slice)))

(define (bytes-mix slice0 . slice*)
  (let* ([n (add1 (length slice*))]
         [blen (* n (bytes-length slice0))]
         [bstr (make-bytes blen)])
    (for ([slice (in-cycle (in-value slice0) (in-list slice*))]
          [bi (in-range blen)] #:when #t [si (in-value (quotient bi n))])
      (bytes-set! bstr bi (bytes-ref slice si)))
    bstr))

(define canvas-image-put/rgb!
  (get-ffi-obj
   "cdCanvasPutImageRectRGB" libcd
   (_fun (canvas dst-x dst-y src-width src-height data
          #:width [dst-width 0] #:height [dst-height 0]
          #:x0 [src-x0 0] #:x1 [src-x1 0]
          #:y0 [src-y0 0] #:y1 [src-y1 0])
         :: [canvas : _canvas]
            [src-width : _int] [src-height : _int]
            [red : _bytes = (bytes-slice data 3 0 (* src-width src-height))]
            [green : _bytes = (bytes-slice data 3 1 (* src-width src-height))]
            [blue : _bytes = (bytes-slice data 3 2 (* src-width src-height))]
            [dst-x : _int] [dst-y : _int]
            [dst-width : _int] [dst-height : _int]
            [src-x0 : _int] [src-x1 : _int]
            [src-y0 : _int] [src-y1 : _int]
         -> _void)))

(define canvas-image-put/rgba!
  (get-ffi-obj
   "cdCanvasPutImageRectRGBA" libcd
   (_fun (canvas dst-x dst-y src-width src-height data
          #:width [dst-width 0] #:height [dst-height 0]
          #:x0 [src-x0 0] #:x1 [src-x1 0]
          #:y0 [src-y0 0] #:y1 [src-y1 0])
         :: [canvas : _canvas]
            [src-width : _int] [src-height : _int]
            [red : _bytes = (bytes-slice data 4 0 (* src-width src-height))]
            [green : _bytes = (bytes-slice data 4 1 (* src-width src-height))]
            [blue : _bytes = (bytes-slice data 4 2 (* src-width src-height))]
            [alpha : _bytes = (bytes-slice data 4 3 (* src-width src-height))]
            [dst-x : _int] [dst-y : _int]
            [dst-width : _int] [dst-height : _int]
            [src-x0 : _int] [src-x1 : _int]
            [src-y0 : _int] [src-y1 : _int]
         -> _void)))

(define canvas-image/rgb
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasGetImageRGB" libcd
    (_fun (canvas x y width height)
          :: [canvas : _canvas]
             [red : (_bytes o (* width height))]
             [green : (_bytes o (* width height))]
             [blue : (_bytes o (* width height))]
             [x : _int] [y : _int]
             [width : _int] [height : _int]
          -> _void
          -> (bytes-mix red green blue)))
   canvas-image-put/rgb!))

(provide
 canvas-image/rgb canvas-image-put/rgb! canvas-image-put/rgba!)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd-native
  (case (system-type 'os)
    [(unix macosx)
     (ffi-lib "libcdx11")]
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:clipboard
  ((get-ffi-obj "cdContextClipboard" libcd-native (_fun -> [context : _context]))))

(provide
 context:clipboard)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:debug
  ((get-ffi-obj "cdContextDebug" libcd (_fun -> [context : _context]))))

(provide
 context:debug)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:dgn
  ((get-ffi-obj "cdContextDGN" libcd (_fun -> [context : _context]))))

(provide
 context:dgn)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:dxf
  ((get-ffi-obj "cdContextDXF" libcd (_fun -> [context : _context]))))

(provide
 context:dxf)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:emf
  ((get-ffi-obj "cdContextEMF" libcd (_fun -> [context : _context]))))

(provide
 context:emf)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd-gl
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cdgl")]
    [else
     (ffi-lib "libcdgl")]))

;; {{{ Context types

(define context:gl
  ((get-ffi-obj "cdContextGL" libcd-gl (_fun -> [context : _context]))))

(provide
 context:gl)

;; }}}

#lang setup/infotab
(define name
  "Canvas Draw")
(define blurb
  '("Bindings to the CD graphics library"))
(define categories
  '(graphics))
(define repositories
  '("4.x"))
(define version
  "1.0")
(define release-notes
  '((dl
     (dt "1.0") (dd "Initial release"))))
(define primary-file
  "main.rkt")
(define homepage
  "http://www.chust.org/fossils/canvas-draw")

#lang racket
(require
 srfi/26
 ffi/unsafe
 "base.rkt")

(define libiup-cd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "iupcd")]
    [else
     (ffi-lib "libiupcd")]))

;; {{{ Context types

(define context:iup
  ((get-ffi-obj "cdContextCGM" libiup-cd (_fun -> [context : _context]))))

(provide
 context:iup)

;; }}}

;; {{{ Auxiliary functions

(define (make-canvas-action proc)
  (let ([canvas #f])
    (λ (handle x y)
      (unless canvas (set! canvas (make-canvas context:iup handle)))
      (call-with-canvas canvas (cut proc <> x y)))))

(provide
 make-canvas-action)

;; }}}

#lang racket/base
(require
 "base.rkt" "primitives.rkt" "play.rkt")

(provide
 (except-out (all-from-out "base.rkt")
             _canvas _canvas/null
             _context _context/null
             _state _state/null)
 (all-from-out "primitives.rkt")
 (all-from-out "play.rkt"))

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:metafile
  ((get-ffi-obj "cdContextMetafile" libcd (_fun -> [context : _context]))))

(provide
 context:metafile)

;; }}}

#lang racket
(require
 ffi/unsafe
 "base.rkt")

(define libcd-native
  (case (system-type 'os)
    [(unix macosx)
     (ffi-lib "libcdx11")]
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

(define libcd-context+
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cdcontextplus")]
    [else
     (ffi-lib "libcdcontextplus")]))

;; {{{ Context types

(define context:native-window
  ((get-ffi-obj "cdContextNativeWindow" libcd-native (_fun -> [context : _context]))))

(provide
 context:native-window)

;; }}}

;; {{{ Auxiliary functions

(define screen-size
  (get-ffi-obj
   "cdGetScreenSize" libcd-native
   (_fun [width/px : (_ptr o _int)] [height/px : (_ptr o _int)]
         [width/mm : (_ptr o _double)] [height/mm : (_ptr o _double)]
         -> _void
         -> (values
             width/px height/px
             width/mm height/mm))))

(provide
 screen-size)

;; }}}

;; {{{ Library initialization

((get-ffi-obj
  "cdInitContextPlus" libcd-context+
  (_fun -> _void)))

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd-pdf
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cdpdf")]
    [else
     (ffi-lib "libcdpdf")]))

;; {{{ Context types

(define context:pdf
  ((get-ffi-obj "cdContextPDF" libcd-pdf (_fun -> [context : _context]))))

(provide
 context:pdf)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:picture
  ((get-ffi-obj "cdContextPicture" libcd (_fun -> [context : _context]))))

(provide
 context:picture)

;; }}}

#lang racket
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context content playback

(define canvas-play/ptr!
  (get-ffi-obj
   "cdCanvasPlay" libcd
   (_fun [canvas : _canvas] [context : _context]
         [x0 : _int] [x1 : _int] [y0 : _int] [y1 : _int]
         [data : _pointer]
         -> [rc : _int])))

(define canvas-play/string!
  (get-ffi-obj
   "cdCanvasPlay" libcd
   (_fun [canvas : _canvas] [context : _context]
         [x0 : _int] [x1 : _int] [y0 : _int] [y1 : _int]
         [data : _string/utf-8]
         -> [rc : _int])))

(define (canvas-play! canvas context x0 x1 y0 y1 data)
  (let ([canvas-play/data! (if (string? data) canvas-play/string! canvas-play/ptr!)])
    (unless (zero? (canvas-play/data! canvas context x0 x1 y0 y1 data))
      (error 'canvas-play! "failed to replay graphics"))))

(provide
 canvas-play!)

;; }}}

#lang racket
(require
 srfi/17
 srfi/26
 ffi/unsafe
 ffi/unsafe/cvector
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Point drawing functions

(define canvas-pixel!
  (get-ffi-obj
   "cdCanvasPixel" libcd
   (_fun (canvas x y [color (canvas-foreground canvas)])
         :: [canvas : _canvas] [x : _int] [y : _int] [color : _ulong] -> _void)))

(define canvas-mark!
  (get-ffi-obj
   "cdCanvasMark" libcd
   (_fun [canvas : _canvas] [x : _int] [y : _int] -> _void)))

(define _mark-type
  (_enum
   '(+ = 0 plus = 0
     * = 1 star = 1
     0 = 2 circle = 2
     X = 3 x = 3
     box
     diamond
     O = 6 hollow-circle = 6
     hollow-box
     hollow-diamond)
   _fixint))

(define canvas-mark-type-set!
  (get-ffi-obj
   "cdCanvasMarkType" libcd
   (_fun [canvas : _canvas] [mark-type : _mark-type] -> _void)))

(define canvas-mark-type
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasMarkType" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> [mark-type : _mark-type]))
   canvas-mark-type-set!))

(define canvas-mark-size-set!
  (get-ffi-obj
   "cdCanvasMarkSize" libcd
   (_fun [canvas : _canvas] [size : _int] -> _void)))

(define canvas-mark-size
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasMarkSize" libcd
    (_fun [canvas : _canvas] [query : _int = -1] -> [size : _int]))
   canvas-mark-size-set!))

(provide
 canvas-pixel!
 canvas-mark!
 canvas-mark-type canvas-mark-type-set!
 canvas-mark-size canvas-mark-size-set!)

;; }}}

;; {{{ Line functions

(define canvas-line!
  (get-ffi-obj
   "cdfCanvasLine" libcd
   (_fun [canvas : _canvas] [x0 : _double*] [y0 : _double*] [x1 : _double*] [y1 : _double*] -> _void)))

(define canvas-rectangle!
  (get-ffi-obj
   "cdfCanvasRect" libcd
   (_fun [canvas : _canvas] [x0 : _double*] [x1 : _double*] [y0 : _double*] [y1 : _double*] -> _void)))

(define canvas-arc!
  (get-ffi-obj
   "cdfCanvasArc" libcd
   (_fun [canvas : _canvas]
         [x : _double*] [y : _double*] [width : _double*] [height : _double*]
         [alpha0 : _double*] [alpha1 : _double*]
         -> _void)))

(define _line-style
  (_enum
   '(continuous dashed dotted dash-dotted dash-dot-dotted custom)
   _fixint))

(define canvas-line-style-set!
  (letrec ([canvas-line-style-set/raw!
            (get-ffi-obj
             "cdCanvasLineStyle" libcd
             (_fun [canvas : _canvas] [line-style : _line-style] -> _void))]
           [canvas-line-style-dashes-set/raw!
            (get-ffi-obj
             "cdCanvasLineStyleDashes" libcd
             (_fun [canvas : _canvas] [dashes : _cvector] [len : _int = (cvector-length dashes)] -> _void))])
    (λ (canvas line-style)
      (match line-style
        [(list-rest 'custom dashes)
         (canvas-line-style-dashes-set/raw! canvas (list->cvector dashes _int))
         (canvas-line-style-set/raw! canvas 'dashes)]
        [_
         (canvas-line-style-set/raw! canvas line-style)]))))

(define canvas-line-style
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasLineStyle" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> [line-style : _line-style]))
   canvas-line-style-set!))

(define canvas-line-width-set!
  (get-ffi-obj
   "cdCanvasLineWidth" libcd
   (_fun [canvas : _canvas] [width : _int] -> _void)))

(define canvas-line-width
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasLineWidth" libcd
    (_fun [canvas : _canvas] [query : _int = -1] -> [width : _int]))
   canvas-line-width-set!))

(define _line-join
  (_enum
   '(miter bevel round)
   _fixint))

(define canvas-line-join-set!
  (get-ffi-obj
   "cdCanvasLineJoin" libcd
   (_fun [canvas : _canvas] [line-join : _line-join] -> _void)))

(define canvas-line-join
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasLineJoin" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> _void))
   canvas-line-join-set!))

(define _line-cap
  (_enum
   '(flat square round)
   _fixint))

(define canvas-line-cap-set!
  (get-ffi-obj
   "cdCanvasLineCap" libcd
   (_fun [canvas : _canvas] [line-cap : _line-cap] -> _void)))

(define canvas-line-cap
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasLineCap" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> [line-cap : _line-cap]))
   canvas-line-cap-set!))

(provide
 canvas-line! canvas-rectangle! canvas-arc!
 canvas-line-style canvas-line-style-set!
 canvas-line-width canvas-line-width-set!
 canvas-line-join canvas-line-join-set!
 canvas-line-cap canvas-line-cap-set!)

;; }}}

;; {{{ Filled area functions

(define canvas-box!
  (get-ffi-obj
   "cdfCanvasBox" libcd
   (_fun [canvas : _canvas] [x0 : _double*] [x1 : _double*] [y0 : _double*] [y1 : _double*] -> _void)))

(define canvas-sector!
  (get-ffi-obj
   "cdfCanvasSector" libcd
   (_fun [canvas : _canvas]
         [x : _double*] [y : _double*] [width : _double*] [height : _double*]
         [alpha0 : _double*] [alpha1 : _double*]
         -> _void)))

(define canvas-chord!
  (get-ffi-obj
   "cdfCanvasChord" libcd
   (_fun [canvas : _canvas]
         [x : _double*] [y : _double*] [width : _double*] [height : _double*]
         [alpha0 : _double*] [alpha1 : _double*]
         -> _void)))

(define _opacity
  (_enum
   '(opaque transparent)
   _fixint))

(define canvas-background-opacity-set!
  (get-ffi-obj
   "cdCanvasBackOpacity" libcd
   (_fun [canvas : _canvas] [opacity : _opacity] -> _void)))

(define canvas-background-opacity
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasBackOpacity" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> [opacity : _opacity]))
   canvas-background-opacity-set!))

(define _fill-mode
  (_enum
   '(even-odd winding)
   _fixint))

(define canvas-fill-mode-set!
  (get-ffi-obj
   "cdCanvasFillMode" libcd
   (_fun [canvas : _canvas] [fill-mode : _fill-mode] -> _void)))

(define canvas-fill-mode
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasFillMode" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> [fill-mode : _fill-mode]))
   canvas-fill-mode-set!))

(define _interior-style
  (_enum
   '(solid hatch stipple pattern #f)
   _fixint))

(define _hatch-style
  (_enum
   '(horizontal vertical forward-diagonal backward-diagonal cross diagonal-cross)
   _fixint))

(define canvas-interior-style-set!
  (letrec ([canvas-interior-style-set/raw!
            (get-ffi-obj
             "cdCanvasInteriorStyle" libcd
             (_fun [canvas : _canvas] [interior-style : _interior-style] -> _void))]
           [canvas-hatch-style-set/raw!
            (get-ffi-obj
             "cdCanvasHatch" libcd
             (_fun [canvas : _canvas] [hatch-style : _hatch-style] -> _void))]
           [canvas-stipple-set/raw!
            (get-ffi-obj
             "cdCanvasStipple" libcd
             (_fun [canvas : _canvas] [width : _int] [height : _int] [data* : _cvector] -> _void))]
           [canvas-pattern-set/raw!
            (get-ffi-obj
             "cdCanvasPattern" libcd
             (_fun [canvas : _canvas] [width : _int] [height : _int] [data* : _cvector] -> _void))])
    (λ (canvas interior-style)
      (match interior-style
        [(list 'hatch hatch-style)
         (canvas-hatch-style-set/raw! canvas hatch-style)
         (canvas-interior-style-set/raw! canvas 'hatch)]
        [(list 'stipple width height data)
         (let ([data* (make-cvector _ubyte (* width height))])
           (for* ([j (in-range height)] [i (in-range width)]
                  [ofs* (in-value (+ (* j width) i))]
                  [vofs (in-value (quotient ofs* 8))]
                  [bofs (in-value (remainder ofs* 8))])
             (cvector-set! data* ofs* (bitwise-bit-field (bytes-ref data vofs) bofs (add1 bofs))))
           (canvas-stipple-set/raw! canvas width height data*))
         (canvas-interior-style-set/raw! canvas 'stipple)]
        [(list 'pattern/rgb width height data)
         (let ([data* (make-cvector _ulong (* width height))])
           (for* ([j (in-range height)] [i (in-range width)]
                  [ofs* (in-value (+ (* j width) i))]
                  [ofs (in-value (* 3 ofs*))])
             (cvector-set! data* ofs*
               (bitwise-ior
                (arithmetic-shift (bytes-ref data ofs) 16)
                (arithmetic-shift (bytes-ref data (+ ofs 1)) 8)
                (bytes-ref data (+ ofs 2)))))
           (canvas-pattern-set/raw! canvas width height data*))
         (canvas-interior-style-set/raw! canvas 'pattern)]
        [(list 'pattern/rgba width height data)
         (let* ([data* (make-cvector _ulong (* width height))]
                [elt-set! (cut ptr-set! data* _long <> <>)])
           (for* ([j (in-range height)] [i (in-range width)]
                  [ofs* (in-value (+ (* j width) i))]
                  [ofs (in-value (* 4 ofs*))])
             (cvector-set! data* ofs*
               (bitwise-ior
                (arithmetic-shift (- #xff (bytes-ref data (+ ofs 3))) 24)
                (arithmetic-shift (bytes-ref data ofs) 16)
                (arithmetic-shift (bytes-ref data (+ ofs 1)) 8)
                (bytes-ref data (+ ofs 2)))))
           (canvas-pattern-set/raw! canvas width height data*))
         (canvas-interior-style-set/raw! canvas 'pattern)]
        [_
         (canvas-interior-style-set/raw! canvas interior-style)]))))

(define canvas-interior-style
  (getter-with-setter
   (letrec ([canvas-interior-style/raw
             (get-ffi-obj
              "cdCanvasInteriorStyle" libcd
              (_fun [canvas : _canvas] [query : _fixint = -1] -> [interior-style : _interior-style]))]
            [canvas-hatch-style/raw
             (get-ffi-obj
              "cdCanvasHatch" libcd
              (_fun [canvas : _canvas] [query : _fixint = -1] -> [hatch-style : _hatch-style]))]
            [canvas-stipple/raw
             (get-ffi-obj
              "cdCanvasGetStipple" libcd
              (_fun [canvas : _canvas] [width : (_ptr o _int)] [height : (_ptr o _int)]
                    -> [data : _gcpointer]
                    -> (values width height data)))]
            [canvas-pattern/raw
             (get-ffi-obj
              "cdCanvasGetPattern" libcd
              (_fun [canvas : _canvas] [width : (_ptr o _int)] [height : (_ptr o _int)]
                    -> [data : _gcpointer]
                    -> (values width height data)))])
     (λ (canvas)
       (let ([interior-style (canvas-interior-style/raw canvas)])
         (case interior-style
           [(hatch)
            (list 'hatch (canvas-hatch-style/raw canvas))]
           [(stipple)
            (let*-values ([(width height data*) (canvas-stipple/raw canvas)]
                          [(data*) (make-cvector* data* _ubyte (* width height))]
                          [(data) (make-bytes (ceiling (/ (* width height) 8)) 0)])
              (for* ([j (in-range height)] [i (in-range width)]
                     [ofs* (in-value (+ (* j width) i))]
                     [vofs (in-value (quotient ofs* 8))]
                     [bofs (in-value (remainder ofs* 8))])
                (bytes-set! data vofs
                  (bitwise-ior
                   (bytes-ref data vofs)
                   (arithmetic-shift (bitwise-and (cvector-ref data* ofs*) 1) bofs))))
              (list 'stipple width height data))]
           [(pattern)
            (let*-values ([(width height data*) (canvas-pattern/raw canvas)]
                          [(data*) (make-cvector* data* _ulong (* width height))]
                          [(data) (make-bytes (* 4 width height))])
              (for* ([j (in-range height)] [i (in-range width)]
                     [ofs* (in-value (+ (* j width) i))]
                     [ofs (in-value (* 4 ofs*))]
                     [col (in-value (cvector-ref data* ofs*))])
                (bytes-set! data ofs (bitwise-bit-field col 16 24))
                (bytes-set! data (+ ofs 1) (bitwise-bit-field col 8 16))
                (bytes-set! data (+ ofs 2) (bitwise-bit-field col 0 8))
                (bytes-set! data (+ ofs 3) (- #xff (bitwise-bit-field col 24 32))))
              (list 'pattern/rgba width height data))]
           [else
            interior-style]))))
   canvas-interior-style-set!))

(provide
 canvas-box! canvas-sector! canvas-chord!
 canvas-background-opacity canvas-background-opacity-set!
 canvas-fill-mode canvas-fill-mode-set!
 canvas-interior-style canvas-interior-style-set!)

;; }}}

;; {{{ Text functions

(define canvas-text!
  (get-ffi-obj
   "cdfCanvasText" libcd
   (_fun [canvas : _canvas] [x : _double*] [y : _double*] [text : _string/utf-8] -> _void)))

(define canvas-font-set!
  (get-ffi-obj
   "cdCanvasNativeFont" libcd
   (_fun [canvas : _canvas] [font : _string/utf-8] -> _void)))

(define canvas-font
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasNativeFont" libcd
    (_fun [canvas : _canvas] [query : _pointer = #f] -> [font : _string/utf-8]))
   canvas-font-set!))

(define _alignment
  (_enum
   '(north south east west north-east north-west south-east south-west center base-left base-center base-right)
   _fixint))

(define canvas-text-alignment-set!
  (get-ffi-obj
   "cdCanvasTextAlignment" libcd
   (_fun [canvas : _canvas] [alignment : _alignment] -> _void)))

(define canvas-text-alignment
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasTextAlignment" libcd
    (_fun [canvas : _canvas] [query : _fixint = -1] -> [alignment : _alignment]))
   canvas-text-alignment-set!))

(define canvas-text-orientation-set!
  (get-ffi-obj
   "cdCanvasTextOrientation" libcd
   (_fun [canvas : _canvas] [orientation : _double*] -> _void)))

(define canvas-text-orientation
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasTextOrientation" libcd
    (_fun [canvas : _canvas] [query : _double = -1.0] -> [orientation : _double]))
   canvas-text-orientation-set!))

(define canvas-font-dimensions
  (get-ffi-obj
   "cdCanvasGetFontDim" libcd
   (_fun [canvas : _canvas]
         [max-width : (_ptr o _int)] [height : (_ptr o _int)]
         [ascent : (_ptr o _int)] [descent : (_ptr o _int)]
         -> _void
         -> (values
             max-width height
             ascent descent))))

(define canvas-text-size
  (get-ffi-obj
   "cdCanvasGetTextSize" libcd
   (_fun [canvas : _canvas] [text : _string/utf-8]
         [width : (_ptr o _int)] [height : (_ptr o _int)]
         -> _void
         -> (values width height))))

(define canvas-text-box
  (get-ffi-obj
   "cdCanvasGetTextBox" libcd
   (_fun [canvas : _canvas] [x : _int] [y : _int] [text : _string/utf-8]
         [x0 : (_ptr o _int)] [x1 : (_ptr o _int)]
         [y0 : (_ptr o _int)] [y1 : (_ptr o _int)]
         -> _void
         -> (values x0 x1 y0 y1))))

(provide
 canvas-text!
 canvas-font canvas-font-set!
 canvas-text-alignment canvas-text-alignment-set!
 canvas-text-orientation canvas-text-orientation-set!
 canvas-font-dimensions canvas-text-size canvas-text-box)

;; }}}

;; {{{ Vertex functions

(define _canvas-mode
  (_enum
   '(fill open-lines closed-lines clip bezier region path)
   _fixint))

(define call-with-canvas-in-mode
  (letrec ([canvas-begin/raw
            (get-ffi-obj
             "cdCanvasBegin" libcd
             (_fun [canvas : _canvas] [canvas-mode : _canvas-mode] -> _void))]
           [canvas-end/raw
            (get-ffi-obj
             "cdCanvasEnd" libcd
             (_fun [canvas : _canvas] -> _void))])
    (λ (canvas canvas-mode proc)
      (dynamic-wind
       (cut canvas-begin/raw canvas canvas-mode)
       (cut proc canvas)
       (cut canvas-end/raw canvas)))))

(define _path-action
  (_enum
   '(new move-to line-to arc curve-to close fill stroke fill+stroke clip)
   _fixint))

(define canvas-path-set!
  (get-ffi-obj
   "cdCanvasPathSet" libcd
   (_fun [canvas : _canvas] [path-action : _path-action] -> _void)))

(define canvas-vertex!
  (get-ffi-obj
   "cdfCanvasVertex" libcd
   (_fun [canvas : _canvas] [x : _double*] [y : _double*] -> _void)))

(provide
 call-with-canvas-in-mode canvas-path-set!
 canvas-vertex!)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd-native
  (case (system-type 'os)
    [(unix macosx)
     (ffi-lib "libcdx11")]
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:printer
  ((get-ffi-obj "cdContextPrinter" libcd-native (_fun -> [context : _context]))))

(provide
 context:printer)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:ps
  ((get-ffi-obj "cdContextPS" libcd (_fun -> [context : _context]))))

(provide
 context:ps)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd-native
  (case (system-type 'os)
    [(unix macosx)
     (ffi-lib "libcdx11")]
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:image
  ((get-ffi-obj "cdContextImage" libcd-native (_fun -> [context : _context]))))

(define context:double-buffer
  ((get-ffi-obj "cdContextDBuffer" libcd-native (_fun -> [context : _context]))))

(provide
 context:image context:double-buffer)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:svg
  ((get-ffi-obj "cdContextSVG" libcd (_fun -> [context : _context]))))

(provide
 context:svg)

;; }}}

#lang racket/base
(require
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:wmf
  ((get-ffi-obj "cdContextWMF" libcd (_fun -> [context : _context]))))

(provide
 context:wmf)

;; }}}

# Makefile for ffcall

#### Start of system configuration section. ####

# Directories used by "make install":
prefix = C:/mylibs/iup
local_prefix = /usr/local
exec_prefix = ${prefix}
libdir = ${exec_prefix}/lib
includedir = ${prefix}/include
mandir = ${prefix}/man

# Programs used by "make":

# Makefile for avcall

#### Start of system configuration section. ####

HOST = i686-pc-mingw32
CPU = i386
OS = mingw32

# Directories used by "make":
srcdir = .

# Directories used by "make install":
prefix = C:/mylibs/iup
local_prefix = /usr/local
exec_prefix = ${prefix}
libdir = ${exec_prefix}/lib
includedir = ${prefix}/include
mandir = ${prefix}/man
datadir = ${prefix}/share
htmldir = $(datadir)/html

This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by configure, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ ./configure --prefix=C:/mylibs/iup --prefix=C:/mylibs/iup --cache-file=/dev/null --srcdir=.

## --------- ##
## Platform. ##
## --------- ##

hostname = hermes
uname -m = i686

PATH: /c/Program Files/Common Files/Microsoft Shared/Windows Live
PATH: /c/windows/SYSTEM32
PATH: /c/windows
PATH: /c/windows/SYSTEM32/WBEM
PATH: /c/windows/SYSTEM32/WINDOWSPOWERSHELL/V1.0/
PATH: /mingw/bin
PATH: /c/chicken/bin
PATH: /c/mylibs/iup
PATH: /c/Program Files/Windows Live/Shared


## ----------- ##
## Core tests. ##
## ----------- ##

configure:8036: gcc -o conftest.exe -g -O2   conftest.c  >&5
conftest.c: In function 'main':
conftest.c:28:34: warning: function called through a non-compatible type
conftest.c:28:34: note: if this code is reached, the program will abort
conftest.c:29:3: warning: incompatible implicit declaration of built-in function 'exit'
configure:8039: $? = 0
configure:8041: ./conftest.exe
configure:8044: $? = 29
configure: program exited with status 29
configure: failed program was:
| /* confdefs.h.  */
| 
| #define PACKAGE_NAME ""
| #define PACKAGE_TARNAME ""
| #define PACKAGE_VERSION ""
| #define PACKAGE_STRING ""

includedir='${prefix}/include'
infodir='${prefix}/info'
libdir='${exec_prefix}/lib'
libexecdir='${exec_prefix}/libexec'
localstatedir='${prefix}/var'
mandir='${prefix}/man'
oldincludedir='/usr/include'
prefix='C:/mylibs/iup'
program_transform_name='s,x,x,'
sbindir='${exec_prefix}/sbin'
sharedstatedir='${prefix}/com'
sysconfdir='${prefix}/etc'
target_alias=''

## ----------- ##

Configuration headers:
$config_headers

Report bugs to <bug-autoconf@gnu.org>."
ac_cs_version="\
config.status
configured by ./configure, generated by GNU Autoconf 2.59,
  with options \"'--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.'\"

Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=.
# If no file are specified by the user, then we need to provide default
# value.  By we need to know if files were specified by the user.

if $ac_cs_silent; then
  exec 6>/dev/null
  ac_configure_extra_args="$ac_configure_extra_args --silent"
fi

if $ac_cs_recheck; then
  echo "running /bin/sh ./configure " '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args " --no-create --no-recursion" >&6
  exec /bin/sh ./configure '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args --no-create --no-recursion
fi

for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.
  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;

s,@PATH_SEPARATOR@,:,;t t
s,@PACKAGE_NAME@,,;t t
s,@PACKAGE_TARNAME@,,;t t
s,@PACKAGE_VERSION@,,;t t
s,@PACKAGE_STRING@,,;t t
s,@PACKAGE_BUGREPORT@,,;t t
s,@exec_prefix@,${prefix},;t t
s,@prefix@,C:/mylibs/iup,;t t
s,@program_transform_name@,s,x,x,,;t t
s,@bindir@,${exec_prefix}/bin,;t t
s,@sbindir@,${exec_prefix}/sbin,;t t
s,@libexecdir@,${exec_prefix}/libexec,;t t
s,@datadir@,${prefix}/share,;t t
s,@sysconfdir@,${prefix}/etc,;t t
s,@sharedstatedir@,${prefix}/com,;t t

# Makefile for callback

#### Start of system configuration section. ####

HOST = i686-pc-mingw32
CPU = i386

# Directories used by "make":
srcdir = .

# Directories used by "make install":
prefix = C:/mylibs/iup
local_prefix = /usr/local
exec_prefix = ${prefix}
libdir = ${exec_prefix}/lib
includedir = ${prefix}/include
mandir = ${prefix}/man
datadir = ${prefix}/share
htmldir = $(datadir)/html

This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by configure, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ ./configure --prefix=C:/mylibs/iup --prefix=C:/mylibs/iup --cache-file=/dev/null --srcdir=.

## --------- ##
## Platform. ##
## --------- ##

hostname = hermes
uname -m = i686

PATH: /c/Program Files/Common Files/Microsoft Shared/Windows Live
PATH: /c/windows/SYSTEM32
PATH: /c/windows
PATH: /c/windows/SYSTEM32/WBEM
PATH: /c/windows/SYSTEM32/WINDOWSPOWERSHELL/V1.0/
PATH: /mingw/bin
PATH: /c/chicken/bin
PATH: /c/mylibs/iup
PATH: /c/Program Files/Windows Live/Shared


## ----------- ##
## Core tests. ##
## ----------- ##

  CONFIG_COMMANDS = 
  $ ./config.status 

on hermes

config.status:657: creating Makefile
configure:8840: configuring in vacall_r
configure:8957: running /bin/sh './configure' --prefix=C:/mylibs/iup  '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' --cache-file=/dev/null --srcdir=.
configure:8840: configuring in trampoline_r
configure:8957: running /bin/sh './configure' --prefix=C:/mylibs/iup  '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' --cache-file=/dev/null --srcdir=.

## ---------------- ##
## Cache variables. ##
## ---------------- ##

ac_cv_build=i686-pc-mingw32
ac_cv_build_alias=i686-pc-mingw32

includedir='${prefix}/include'
infodir='${prefix}/info'
libdir='${exec_prefix}/lib'
libexecdir='${exec_prefix}/libexec'
localstatedir='${prefix}/var'
mandir='${prefix}/man'
oldincludedir='/usr/include'
prefix='C:/mylibs/iup'
program_transform_name='s,x,x,'
sbindir='${exec_prefix}/sbin'
sharedstatedir='${prefix}/com'
subdirs=' vacall_r trampoline_r'
sysconfdir='${prefix}/etc'
target_alias=''

Configuration files:
$config_files

Report bugs to <bug-autoconf@gnu.org>."
ac_cs_version="\
config.status
configured by ./configure, generated by GNU Autoconf 2.59,
  with options \"'--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.'\"

Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=.
# If no file are specified by the user, then we need to provide default
# value.  By we need to know if files were specified by the user.

if $ac_cs_silent; then
  exec 6>/dev/null
  ac_configure_extra_args="$ac_configure_extra_args --silent"
fi

if $ac_cs_recheck; then
  echo "running /bin/sh ./configure " '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args " --no-create --no-recursion" >&6
  exec /bin/sh ./configure '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args --no-create --no-recursion
fi

for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.
  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;

s,@PATH_SEPARATOR@,:,;t t
s,@PACKAGE_NAME@,,;t t
s,@PACKAGE_TARNAME@,,;t t
s,@PACKAGE_VERSION@,,;t t
s,@PACKAGE_STRING@,,;t t
s,@PACKAGE_BUGREPORT@,,;t t
s,@exec_prefix@,${prefix},;t t
s,@prefix@,C:/mylibs/iup,;t t
s,@program_transform_name@,s,x,x,,;t t
s,@bindir@,${exec_prefix}/bin,;t t
s,@sbindir@,${exec_prefix}/sbin,;t t
s,@libexecdir@,${exec_prefix}/libexec,;t t
s,@datadir@,${prefix}/share,;t t
s,@sysconfdir@,${prefix}/etc,;t t
s,@sharedstatedir@,${prefix}/com,;t t

# Makefile for trampoline

#### Start of system configuration section. ####

HOST = i686-pc-mingw32
CPU = i386
OS = mingw32

# Directories used by "make":
srcdir = .

# Directories used by "make install":
prefix = C:/mylibs/iup
local_prefix = /usr/local
exec_prefix = ${prefix}
libdir = ${exec_prefix}/lib
includedir = ${prefix}/include
mandir = ${prefix}/man
datadir = ${prefix}/share
htmldir = $(datadir)/html

This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by configure, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ ./configure --prefix=C:/mylibs/iup --prefix=C:/mylibs/iup --cache-file=/dev/null --srcdir=. --cache-file=/dev/null --srcdir=.

## --------- ##
## Platform. ##
## --------- ##

hostname = hermes
uname -m = i686

PATH: /c/Program Files/Common Files/Microsoft Shared/Windows Live
PATH: /c/windows/SYSTEM32
PATH: /c/windows
PATH: /c/windows/SYSTEM32/WBEM
PATH: /c/windows/SYSTEM32/WINDOWSPOWERSHELL/V1.0/
PATH: /mingw/bin
PATH: /c/chicken/bin
PATH: /c/mylibs/iup
PATH: /c/Program Files/Windows Live/Shared


## ----------- ##
## Core tests. ##
## ----------- ##

configure:8355: $? = 0
configure:8358: test -s conftest.o
configure:8361: $? = 0
configure:8378: result: 
         extern int getpagesize (void);
configure:8540: checking for vm_allocate
configure:8562: gcc -o conftest.exe -g -O2   conftest.c  >&5
C:\Users\matt\AppData\Local\Temp\ccdI2c3e.o: In function `main':
c:\Users\matt\data\chicken-iup\ffcall\callback\trampoline_r/conftest.c:32: undefined reference to `vm_allocate'
c:\Users\matt\data\chicken-iup\ffcall\callback\trampoline_r/conftest.c:32: undefined reference to `task_self'
collect2: ld returned 1 exit status
configure:8568: $? = 1
configure: failed program was:
| /* confdefs.h.  */
| 
| #define PACKAGE_NAME ""
| #define PACKAGE_TARNAME ""

includedir='${prefix}/include'
infodir='${prefix}/info'
libdir='${exec_prefix}/lib'
libexecdir='${exec_prefix}/libexec'
localstatedir='${prefix}/var'
mandir='${prefix}/man'
oldincludedir='/usr/include'
prefix='C:/mylibs/iup'
program_transform_name='s,x,x,'
sbindir='${exec_prefix}/sbin'
sharedstatedir='${prefix}/com'
sysconfdir='${prefix}/etc'
target_alias=''

## ----------- ##

Configuration headers:
$config_headers

Report bugs to <bug-autoconf@gnu.org>."
ac_cs_version="\
config.status
configured by ./configure, generated by GNU Autoconf 2.59,
  with options \"'--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.'\"

Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=.
# If no file are specified by the user, then we need to provide default
# value.  By we need to know if files were specified by the user.

if $ac_cs_silent; then
  exec 6>/dev/null
  ac_configure_extra_args="$ac_configure_extra_args --silent"
fi

if $ac_cs_recheck; then
  echo "running /bin/sh ./configure " '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args " --no-create --no-recursion" >&6
  exec /bin/sh ./configure '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args --no-create --no-recursion
fi

for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.
  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;

s,@PATH_SEPARATOR@,:,;t t
s,@PACKAGE_NAME@,,;t t
s,@PACKAGE_TARNAME@,,;t t
s,@PACKAGE_VERSION@,,;t t
s,@PACKAGE_STRING@,,;t t
s,@PACKAGE_BUGREPORT@,,;t t
s,@exec_prefix@,${prefix},;t t
s,@prefix@,C:/mylibs/iup,;t t
s,@program_transform_name@,s,x,x,,;t t
s,@bindir@,${exec_prefix}/bin,;t t
s,@sbindir@,${exec_prefix}/sbin,;t t
s,@libexecdir@,${exec_prefix}/libexec,;t t
s,@datadir@,${prefix}/share,;t t
s,@sysconfdir@,${prefix}/etc,;t t
s,@sharedstatedir@,${prefix}/com,;t t

# Makefile for vacall

#### Start of system configuration section. ####

HOST = i686-pc-mingw32
CPU = i386
OS = mingw32

# Directories used by "make":
srcdir = .

# Directories used by "make install":
prefix = C:/mylibs/iup
local_prefix = /usr/local
exec_prefix = ${prefix}
libdir = ${exec_prefix}/lib
includedir = ${prefix}/include
mandir = ${prefix}/man
datadir = ${prefix}/share
htmldir = $(datadir)/html

This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by configure, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ ./configure --prefix=C:/mylibs/iup --prefix=C:/mylibs/iup --cache-file=/dev/null --srcdir=. --cache-file=/dev/null --srcdir=.

## --------- ##
## Platform. ##
## --------- ##

hostname = hermes
uname -m = i686

PATH: /c/Program Files/Common Files/Microsoft Shared/Windows Live
PATH: /c/windows/SYSTEM32
PATH: /c/windows
PATH: /c/windows/SYSTEM32/WBEM
PATH: /c/windows/SYSTEM32/WINDOWSPOWERSHELL/V1.0/
PATH: /mingw/bin
PATH: /c/chicken/bin
PATH: /c/mylibs/iup
PATH: /c/Program Files/Windows Live/Shared


## ----------- ##
## Core tests. ##
## ----------- ##

configure:8036: gcc -o conftest.exe -g -O2   conftest.c  >&5
conftest.c: In function 'main':
conftest.c:28:34: warning: function called through a non-compatible type
conftest.c:28:34: note: if this code is reached, the program will abort
conftest.c:29:3: warning: incompatible implicit declaration of built-in function 'exit'
configure:8039: $? = 0
configure:8041: ./conftest.exe
configure:8044: $? = 255
configure: program exited with status 255
configure: failed program was:
| /* confdefs.h.  */
| 
| #define PACKAGE_NAME ""
| #define PACKAGE_TARNAME ""
| #define PACKAGE_VERSION ""
| #define PACKAGE_STRING ""

includedir='${prefix}/include'
infodir='${prefix}/info'
libdir='${exec_prefix}/lib'
libexecdir='${exec_prefix}/libexec'
localstatedir='${prefix}/var'
mandir='${prefix}/man'
oldincludedir='/usr/include'
prefix='C:/mylibs/iup'
program_transform_name='s,x,x,'
sbindir='${exec_prefix}/sbin'
sharedstatedir='${prefix}/com'
sysconfdir='${prefix}/etc'
target_alias=''

## ----------- ##

Configuration headers:
$config_headers

Report bugs to <bug-autoconf@gnu.org>."
ac_cs_version="\
config.status
configured by ./configure, generated by GNU Autoconf 2.59,
  with options \"'--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.'\"

Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=.
# If no file are specified by the user, then we need to provide default
# value.  By we need to know if files were specified by the user.

if $ac_cs_silent; then
  exec 6>/dev/null
  ac_configure_extra_args="$ac_configure_extra_args --silent"
fi

if $ac_cs_recheck; then
  echo "running /bin/sh ./configure " '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args " --no-create --no-recursion" >&6
  exec /bin/sh ./configure '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args --no-create --no-recursion
fi

for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.
  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;

s,@PATH_SEPARATOR@,:,;t t
s,@PACKAGE_NAME@,,;t t
s,@PACKAGE_TARNAME@,,;t t
s,@PACKAGE_VERSION@,,;t t
s,@PACKAGE_STRING@,,;t t
s,@PACKAGE_BUGREPORT@,,;t t
s,@exec_prefix@,${prefix},;t t
s,@prefix@,C:/mylibs/iup,;t t
s,@program_transform_name@,s,x,x,,;t t
s,@bindir@,${exec_prefix}/bin,;t t
s,@sbindir@,${exec_prefix}/sbin,;t t
s,@libexecdir@,${exec_prefix}/libexec,;t t
s,@datadir@,${prefix}/share,;t t
s,@sysconfdir@,${prefix}/etc,;t t
s,@sharedstatedir@,${prefix}/com,;t t

This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by configure, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ ./configure --prefix=C:/mylibs/iup

## --------- ##
## Platform. ##
## --------- ##

hostname = hermes
uname -m = i686

PATH: /c/Program Files/Common Files/Microsoft Shared/Windows Live
PATH: /c/windows/SYSTEM32
PATH: /c/windows
PATH: /c/windows/SYSTEM32/WBEM
PATH: /c/windows/SYSTEM32/WINDOWSPOWERSHELL/V1.0/
PATH: /mingw/bin
PATH: /c/chicken/bin
PATH: /c/mylibs/iup
PATH: /c/Program Files/Windows Live/Shared


## ----------- ##
## Core tests. ##
## ----------- ##

  CONFIG_COMMANDS = 
  $ ./config.status 

on hermes

config.status:626: creating Makefile
configure:2219: configuring in avcall
configure:2336: running /bin/sh './configure' --prefix=C:/mylibs/iup  '--prefix=C:/mylibs/iup' --cache-file=/dev/null --srcdir=.
configure:2219: configuring in vacall
configure:2336: running /bin/sh './configure' --prefix=C:/mylibs/iup  '--prefix=C:/mylibs/iup' --cache-file=/dev/null --srcdir=.
configure:2219: configuring in trampoline
configure:2336: running /bin/sh './configure' --prefix=C:/mylibs/iup  '--prefix=C:/mylibs/iup' --cache-file=/dev/null --srcdir=.
configure:2219: configuring in callback
configure:2336: running /bin/sh './configure' --prefix=C:/mylibs/iup  '--prefix=C:/mylibs/iup' --cache-file=/dev/null --srcdir=.

## ---------------- ##
## Cache variables. ##
## ---------------- ##

ac_cv_env_build_alias_set=
ac_cv_env_build_alias_value=

includedir='${prefix}/include'
infodir='${prefix}/info'
libdir='${exec_prefix}/lib'
libexecdir='${exec_prefix}/libexec'
localstatedir='${prefix}/var'
mandir='${prefix}/man'
oldincludedir='/usr/include'
prefix='C:/mylibs/iup'
program_transform_name='s,x,x,'
sbindir='${exec_prefix}/sbin'
sharedstatedir='${prefix}/com'
subdirs=' avcall vacall trampoline callback'
sysconfdir='${prefix}/etc'
target_alias=''

Configuration files:
$config_files

Report bugs to <bug-autoconf@gnu.org>."
ac_cs_version="\
config.status
configured by ./configure, generated by GNU Autoconf 2.59,
  with options \"'--prefix=C:/mylibs/iup'\"

Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=.
# If no file are specified by the user, then we need to provide default
# value.  By we need to know if files were specified by the user.

if $ac_cs_silent; then
  exec 6>/dev/null
  ac_configure_extra_args="$ac_configure_extra_args --silent"
fi

if $ac_cs_recheck; then
  echo "running /bin/sh ./configure " '--prefix=C:/mylibs/iup' $ac_configure_extra_args " --no-create --no-recursion" >&6
  exec /bin/sh ./configure '--prefix=C:/mylibs/iup' $ac_configure_extra_args --no-create --no-recursion
fi

for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.
  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;

s,@PATH_SEPARATOR@,:,;t t
s,@PACKAGE_NAME@,,;t t
s,@PACKAGE_TARNAME@,,;t t
s,@PACKAGE_VERSION@,,;t t
s,@PACKAGE_STRING@,,;t t
s,@PACKAGE_BUGREPORT@,,;t t
s,@exec_prefix@,${prefix},;t t
s,@prefix@,C:/mylibs/iup,;t t
s,@program_transform_name@,s,x,x,,;t t
s,@bindir@,${exec_prefix}/bin,;t t
s,@sbindir@,${exec_prefix}/sbin,;t t
s,@libexecdir@,${exec_prefix}/libexec,;t t
s,@datadir@,${prefix}/share,;t t
s,@sysconfdir@,${prefix}/etc,;t t
s,@sharedstatedir@,${prefix}/com,;t t

# Makefile for trampoline

#### Start of system configuration section. ####

HOST = i686-pc-mingw32
CPU = i386
OS = mingw32

# Directories used by "make":
srcdir = .

# Directories used by "make install":
prefix = C:/mylibs/iup
local_prefix = /usr/local
exec_prefix = ${prefix}
libdir = ${exec_prefix}/lib
includedir = ${prefix}/include
mandir = ${prefix}/man
datadir = ${prefix}/share
htmldir = $(datadir)/html

This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by configure, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ ./configure --prefix=C:/mylibs/iup --prefix=C:/mylibs/iup --cache-file=/dev/null --srcdir=.

## --------- ##
## Platform. ##
## --------- ##

hostname = hermes
uname -m = i686

PATH: /c/Program Files/Common Files/Microsoft Shared/Windows Live
PATH: /c/windows/SYSTEM32
PATH: /c/windows
PATH: /c/windows/SYSTEM32/WBEM
PATH: /c/windows/SYSTEM32/WINDOWSPOWERSHELL/V1.0/
PATH: /mingw/bin
PATH: /c/chicken/bin
PATH: /c/mylibs/iup
PATH: /c/Program Files/Windows Live/Shared


## ----------- ##
## Core tests. ##
## ----------- ##

configure:3508: $? = 0
configure:3511: test -s conftest.o
configure:3514: $? = 0
configure:3531: result: 
         extern int getpagesize (void);
configure:3693: checking for vm_allocate
configure:3715: gcc -o conftest.exe -g -O2   conftest.c  >&5
C:\Users\matt\AppData\Local\Temp\cck3AH5m.o: In function `main':
c:\Users\matt\data\chicken-iup\ffcall\trampoline/conftest.c:29: undefined reference to `vm_allocate'
c:\Users\matt\data\chicken-iup\ffcall\trampoline/conftest.c:29: undefined reference to `task_self'
collect2: ld returned 1 exit status
configure:3721: $? = 1
configure: failed program was:
| /* confdefs.h.  */
| 
| #define PACKAGE_NAME ""
| #define PACKAGE_TARNAME ""

includedir='${prefix}/include'
infodir='${prefix}/info'
libdir='${exec_prefix}/lib'
libexecdir='${exec_prefix}/libexec'
localstatedir='${prefix}/var'
mandir='${prefix}/man'
oldincludedir='/usr/include'
prefix='C:/mylibs/iup'
program_transform_name='s,x,x,'
sbindir='${exec_prefix}/sbin'
sharedstatedir='${prefix}/com'
sysconfdir='${prefix}/etc'
target_alias=''

## ----------- ##

Configuration headers:
$config_headers

Report bugs to <bug-autoconf@gnu.org>."
ac_cs_version="\
config.status
configured by ./configure, generated by GNU Autoconf 2.59,
  with options \"'--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.'\"

Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=.
# If no file are specified by the user, then we need to provide default
# value.  By we need to know if files were specified by the user.

if $ac_cs_silent; then
  exec 6>/dev/null
  ac_configure_extra_args="$ac_configure_extra_args --silent"
fi

if $ac_cs_recheck; then
  echo "running /bin/sh ./configure " '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args " --no-create --no-recursion" >&6
  exec /bin/sh ./configure '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args --no-create --no-recursion
fi

for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.
  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;

s,@PATH_SEPARATOR@,:,;t t
s,@PACKAGE_NAME@,,;t t
s,@PACKAGE_TARNAME@,,;t t
s,@PACKAGE_VERSION@,,;t t
s,@PACKAGE_STRING@,,;t t
s,@PACKAGE_BUGREPORT@,,;t t
s,@exec_prefix@,${prefix},;t t
s,@prefix@,C:/mylibs/iup,;t t
s,@program_transform_name@,s,x,x,,;t t
s,@bindir@,${exec_prefix}/bin,;t t
s,@sbindir@,${exec_prefix}/sbin,;t t
s,@libexecdir@,${exec_prefix}/libexec,;t t
s,@datadir@,${prefix}/share,;t t
s,@sysconfdir@,${prefix}/etc,;t t
s,@sharedstatedir@,${prefix}/com,;t t

# Makefile for vacall

#### Start of system configuration section. ####

HOST = i686-pc-mingw32
CPU = i386
OS = mingw32

# Directories used by "make":
srcdir = .

# Directories used by "make install":
prefix = C:/mylibs/iup
local_prefix = /usr/local
exec_prefix = ${prefix}
libdir = ${exec_prefix}/lib
includedir = ${prefix}/include
mandir = ${prefix}/man
datadir = ${prefix}/share
htmldir = $(datadir)/html

This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by configure, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ ./configure --prefix=C:/mylibs/iup --prefix=C:/mylibs/iup --cache-file=/dev/null --srcdir=.

## --------- ##
## Platform. ##
## --------- ##

hostname = hermes
uname -m = i686

PATH: /c/Program Files/Common Files/Microsoft Shared/Windows Live
PATH: /c/windows/SYSTEM32
PATH: /c/windows
PATH: /c/windows/SYSTEM32/WBEM
PATH: /c/windows/SYSTEM32/WINDOWSPOWERSHELL/V1.0/
PATH: /mingw/bin
PATH: /c/chicken/bin
PATH: /c/mylibs/iup
PATH: /c/Program Files/Windows Live/Shared


## ----------- ##
## Core tests. ##
## ----------- ##

includedir='${prefix}/include'
infodir='${prefix}/info'
libdir='${exec_prefix}/lib'
libexecdir='${exec_prefix}/libexec'
localstatedir='${prefix}/var'
mandir='${prefix}/man'
oldincludedir='/usr/include'
prefix='C:/mylibs/iup'
program_transform_name='s,x,x,'
sbindir='${exec_prefix}/sbin'
sharedstatedir='${prefix}/com'
sysconfdir='${prefix}/etc'
target_alias=''

## ----------- ##

Configuration headers:
$config_headers

Report bugs to <bug-autoconf@gnu.org>."
ac_cs_version="\
config.status
configured by ./configure, generated by GNU Autoconf 2.59,
  with options \"'--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.'\"

Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=.
# If no file are specified by the user, then we need to provide default
# value.  By we need to know if files were specified by the user.

if $ac_cs_silent; then
  exec 6>/dev/null
  ac_configure_extra_args="$ac_configure_extra_args --silent"
fi

if $ac_cs_recheck; then
  echo "running /bin/sh ./configure " '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args " --no-create --no-recursion" >&6
  exec /bin/sh ./configure '--prefix=C:/mylibs/iup' '--cache-file=/dev/null' '--srcdir=.' $ac_configure_extra_args --no-create --no-recursion
fi

for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.
  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;

s,@PATH_SEPARATOR@,:,;t t
s,@PACKAGE_NAME@,,;t t
s,@PACKAGE_TARNAME@,,;t t
s,@PACKAGE_VERSION@,,;t t
s,@PACKAGE_STRING@,,;t t
s,@PACKAGE_BUGREPORT@,,;t t
s,@exec_prefix@,${prefix},;t t
s,@prefix@,C:/mylibs/iup,;t t
s,@program_transform_name@,s,x,x,,;t t
s,@bindir@,${exec_prefix}/bin,;t t
s,@sbindir@,${exec_prefix}/sbin,;t t
s,@libexecdir@,${exec_prefix}/libexec,;t t
s,@datadir@,${prefix}/share,;t t
s,@sysconfdir@,${prefix}/etc,;t t
s,@sharedstatedir@,${prefix}/com,;t t