ADDED canvas-draw/canvas-draw-base.scm Index: canvas-draw/canvas-draw-base.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-base.scm @@ -0,0 +1,524 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \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))))) + +;; }}} ADDED canvas-draw/canvas-draw-cgm.scm Index: canvas-draw/canvas-draw-cgm.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-cgm.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:cgm + (foreign-value "CD_CGM" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-client.scm Index: canvas-draw/canvas-draw-client.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-client.scm @@ -0,0 +1,102 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \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!)) + +;; }}} ADDED canvas-draw/canvas-draw-clipboard.scm Index: canvas-draw/canvas-draw-clipboard.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-clipboard.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:clipboard + (foreign-value "CD_CLIPBOARD" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-debug.scm Index: canvas-draw/canvas-draw-debug.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-debug.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:debug + (foreign-value "CD_DEBUG" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-dgn.scm Index: canvas-draw/canvas-draw-dgn.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-dgn.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:dgn + (foreign-value "CD_DGN" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-dxf.scm Index: canvas-draw/canvas-draw-dxf.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-dxf.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:dxf + (foreign-value "CD_DXF" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-emf.scm Index: canvas-draw/canvas-draw-emf.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-emf.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:emf + (foreign-value "CD_EMF" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-gl.scm Index: canvas-draw/canvas-draw-gl.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-gl.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:gl + (foreign-value "CD_GL" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-iup.scm Index: canvas-draw/canvas-draw-iup.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-iup.scm @@ -0,0 +1,33 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \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))))) + +(define (make-cells-draw-cb proc) + (let ([wrap (pointer->canvas #t)]) + (lambda (handle i j x-min x-max y-min y-max canvas) + (call-with-canvas (wrap canvas) (cut proc handle i j x-min x-max y-min y-max <>))))) + +;; }}} ADDED canvas-draw/canvas-draw-metafile.scm Index: canvas-draw/canvas-draw-metafile.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-metafile.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:metafile + (foreign-value "CD_METAFILE" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-native.scm Index: canvas-draw/canvas-draw-native.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-native.scm @@ -0,0 +1,40 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \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();") + +;; }}} ADDED canvas-draw/canvas-draw-pdf.scm Index: canvas-draw/canvas-draw-pdf.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-pdf.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:pdf + (foreign-value "CD_PDF" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-picture.scm Index: canvas-draw/canvas-draw-picture.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-picture.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:picture + (foreign-value "CD_PICTURE" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-play.scm Index: canvas-draw/canvas-draw-play.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-play.scm @@ -0,0 +1,25 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \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")))) + +;; }}} ADDED canvas-draw/canvas-draw-primitives.scm Index: canvas-draw/canvas-draw-primitives.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-primitives.scm @@ -0,0 +1,713 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \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)) + +;; }}} ADDED canvas-draw/canvas-draw-printer.scm Index: canvas-draw/canvas-draw-printer.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-printer.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:printer + (foreign-value "CD_PRINTER" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-ps.scm Index: canvas-draw/canvas-draw-ps.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-ps.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:ps + (foreign-value "CD_PS" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-server.scm Index: canvas-draw/canvas-draw-server.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-server.scm @@ -0,0 +1,22 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n" + "#include \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)) + +;; }}} ADDED canvas-draw/canvas-draw-svg.scm Index: canvas-draw/canvas-draw-svg.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-svg.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:svg + (foreign-value "CD_SVG" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw-types.scm Index: canvas-draw/canvas-draw-types.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-types.scm @@ -0,0 +1,23 @@ +(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)) ADDED canvas-draw/canvas-draw-wmf.scm Index: canvas-draw/canvas-draw-wmf.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw-wmf.scm @@ -0,0 +1,18 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "canvas-draw-types.scm") + +;; }}} + +;; {{{ Context types + +(define context:wmf + (foreign-value "CD_WMF" nonnull-context)) + +;; }}} ADDED canvas-draw/canvas-draw.meta Index: canvas-draw/canvas-draw.meta ================================================================== --- /dev/null +++ canvas-draw/canvas-draw.meta @@ -0,0 +1,6 @@ +((category graphics) + (license "BSD") + (author "Thomas Chust") + (synopsis "Bindings to the CD graphics library") + (doc-from-wiki) + (files "canvas-draw-native.scm" "canvas-draw-picture.scm" "canvas-draw-pdf.scm" "canvas-draw.meta" "canvas-draw-clipboard.scm" "canvas-draw-ps.scm" "canvas-draw-iup.scm" "canvas-draw-debug.scm" "canvas-draw-wmf.scm" "canvas-draw-cgm.scm" "canvas-draw-play.scm" "canvas-draw-dxf.scm" "canvas-draw-svg.scm" "canvas-draw-types.scm" "canvas-draw-emf.scm" "canvas-draw-metafile.scm" "canvas-draw-dgn.scm" "canvas-draw.scm" "canvas-draw-printer.scm" "canvas-draw-server.scm" "canvas-draw-gl.scm" "canvas-draw-primitives.scm" "canvas-draw.setup" "canvas-draw.release-info" "canvas-draw-base.scm" "canvas-draw-client.scm")) ADDED canvas-draw/canvas-draw.scm Index: canvas-draw/canvas-draw.scm ================================================================== --- /dev/null +++ canvas-draw/canvas-draw.scm @@ -0,0 +1,176 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +(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) + (include "canvas-draw-base.scm")) + +(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) + (include "canvas-draw-primitives.scm")) + +(module canvas-draw-play + (canvas-play!) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-play.scm")) + +(module canvas-draw-picture + (context:picture) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-picture.scm")) + +(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) + (include "canvas-draw-client.scm")) + +(module canvas-draw-ps + (context:ps) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-ps.scm")) + +(module canvas-draw-svg + (context:svg) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-svg.scm")) + +(module canvas-draw-metafile + (context:metafile) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-metafile.scm")) + +(module canvas-draw-cgm + (context:cgm) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-cgm.scm")) + +(module canvas-draw-dgn + (context:dgn) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-dgn.scm")) + +(module canvas-draw-dxf + (context:dxf) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-dxf.scm")) + +(module canvas-draw-emf + (context:emf) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-emf.scm")) + +(module canvas-draw-wmf + (context:wmf) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-wmf.scm")) + +(cond-expand + [disable-canvas-draw-iup] + [else + (module canvas-draw-iup + (context:iup make-canvas-action make-cells-draw-cb) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-iup.scm"))]) + +(cond-expand + [disable-canvas-draw-gl] + [else + (module canvas-draw-gl + (context:gl) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-gl.scm"))]) + +(cond-expand + [disable-canvas-draw-native] + [else + (module canvas-draw-native + (context:native-window + screen-size) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-native.scm")) + (module canvas-draw-server + (context:image context:double-buffer) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-server.scm")) + (module canvas-draw-clipboard + (context:clipboard) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-clipboard.scm")) + (module canvas-draw-printer + (context:printer) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-printer.scm"))]) + +(cond-expand + [disable-canvas-draw-pdf] + [else + (module canvas-draw-pdf + (context:pdf) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-pdf.scm"))]) + +(cond-expand + [enable-canvas-draw-debug + (module canvas-draw-debug + (context:debug) + (import scheme chicken foreign canvas-draw-base) + (include "canvas-draw-debug.scm"))] + [else]) + +(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)) ADDED canvas-draw/canvas-draw.setup Index: canvas-draw/canvas-draw.setup ================================================================== --- /dev/null +++ canvas-draw/canvas-draw.setup @@ -0,0 +1,144 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +(define modules + `(-j canvas-draw + -j canvas-draw-base -j canvas-draw-primitives -j canvas-draw-play + -j canvas-draw-picture -j canvas-draw-client + -j canvas-draw-ps -j canvas-draw-svg -j canvas-draw-metafile + -j canvas-draw-cgm -j canvas-draw-dgn -j canvas-draw-dxf + -j canvas-draw-emf -j canvas-draw-wmf + ,@(cond-expand + [disable-canvas-draw-iup + '()] + [else + '(-j canvas-draw-iup)]) + ,@(cond-expand + [disable-canvas-draw-gl + '()] + [else + '(-j canvas-draw-gl)]) + ,@(cond-expand + [disable-canvas-draw-native + '()] + [else + '(-j canvas-draw-native -j canvas-draw-server + -j canvas-draw-clipboard -j canvas-draw-printer)]) + ,@(cond-expand + [disable-canvas-draw-pdf + '()] + [else + '(-j canvas-draw-pdf)]) + ,@(cond-expand + [enable-canvas-draw-debug + '(-j canvas-draw-debug)] + [else + '()]))) + +(define import-libraries + `("canvas-draw.import.so" + "canvas-draw-base.import.so" "canvas-draw-primitives.import.so" "canvas-draw-play.import.so" + "canvas-draw-picture.import.so" "canvas-draw-client.import.so" + "canvas-draw-ps.import.so" "canvas-draw-svg.import.so" "canvas-draw-metafile.import.so" + "canvas-draw-cgm.import.so" "canvas-draw-dgn.import.so" "canvas-draw-dxf.import.so" + "canvas-draw-emf.import.so" "canvas-draw-wmf.import.so" + ,@(cond-expand + [disable-canvas-draw-iup + '()] + [else + '("canvas-draw-iup.import.so")]) + ,@(cond-expand + [disable-canvas-draw-gl + '()] + [else + '("canvas-draw-gl.import.so")]) + ,@(cond-expand + [disable-canvas-draw-native + '()] + [else + '("canvas-draw-native.import.so" "canvas-draw-server.import.so" + "canvas-draw-clipboard.import.so" "canvas-draw-printer.import.so")]) + ,@(cond-expand + [disable-canvas-draw-pdf + '()] + [else + '("canvas-draw-pdf.import.so")]) + ,@(cond-expand + [enable-canvas-draw-debug + '("canvas-draw-debug.import.so")] + [else + '()]))) + +(define native-libraries + `("-lcd" + ,@(cond-expand + [disable-canvas-draw-iup + '()] + [else + '("-liupcd")]) + ,@(cond-expand + [disable-canvas-draw-gl + '()] + [else + '("-lcdgl")]) + ,@(cond-expand + [disable-canvas-draw-native + '()] + [else + (append + (if (find-library "cdx11" "cdContextNativeWindow") + '("-lcdx11") '()) + (if (find-library "cdcontextplus" "cdInitContextPlus") + '("-lcdcontextplus") '()))]) + ,@(cond-expand + [disable-canvas-draw-pdf + '()] + [else + '("-lcdpdf")]))) + +(compile -s -O2 -d1 "canvas-draw.scm" ,@modules ,@native-libraries) +(compile -c -O2 -d1 "canvas-draw.scm" -unit canvas-draw) +(compile -s -O2 -d0 "canvas-draw.import.scm") +(compile -s -O2 -d0 "canvas-draw-base.import.scm") +(compile -s -O2 -d0 "canvas-draw-primitives.import.scm") +(compile -s -O2 -d0 "canvas-draw-play.import.scm") +(compile -s -O2 -d0 "canvas-draw-picture.import.scm") +(compile -s -O2 -d0 "canvas-draw-client.import.scm") +(compile -s -O2 -d0 "canvas-draw-ps.import.scm") +(compile -s -O2 -d0 "canvas-draw-svg.import.scm") +(compile -s -O2 -d0 "canvas-draw-metafile.import.scm") +(compile -s -O2 -d0 "canvas-draw-cgm.import.scm") +(compile -s -O2 -d0 "canvas-draw-dgn.import.scm") +(compile -s -O2 -d0 "canvas-draw-dxf.import.scm") +(compile -s -O2 -d0 "canvas-draw-emf.import.scm") +(compile -s -O2 -d0 "canvas-draw-wmf.import.scm") + +(cond-expand + [disable-canvas-draw-iup] + [else + (compile -s -O2 -d0 "canvas-draw-iup.import.scm")]) +(cond-expand + [disable-canvas-draw-gl] + [else + (compile -s -O2 -d0 "canvas-draw-gl.import.scm")]) +(cond-expand + [disable-canvas-draw-native] + [else + (compile -s -O2 -d0 "canvas-draw-native.import.scm") + (compile -s -O2 -d0 "canvas-draw-server.import.scm") + (compile -s -O2 -d0 "canvas-draw-clipboard.import.scm") + (compile -s -O2 -d0 "canvas-draw-printer.import.scm")]) +(cond-expand + [disable-canvas-draw-pdf] + [else + (compile -s -O2 -d0 "canvas-draw-pdf.import.scm")]) +(cond-expand + [enable-canvas-draw-debug + (compile -s -O2 -d0 "canvas-draw-debug.import.scm")] + [else]) + +(install-extension + 'canvas-draw + `("canvas-draw.so" "canvas-draw.o" "canvas-draw-types.scm" ,@import-libraries) + `((version 1.1.1) + (static "canvas-draw-base.o") + (static-options ,(string-intersperse native-libraries)))) Index: iup/iup-base.scm ================================================================== --- iup/iup-base.scm +++ iup/iup-base.scm @@ -1,43 +1,12 @@ -(require-library - lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex posix) - -(module iup-base - (ihandle->pointer pointer->ihandle ihandle-list->pointer-vector ihandle? - istatus->integer integer->istatus - iname->string string->iname - thread-watchdog iup-version load/led - attribute attribute-set! attribute-reset! - handle-name handle-name-set! handle-ref - main-loop main-loop-step main-loop-level main-loop-exit main-loop-flush - callback callback-set! - make-constructor-procedure optional-args - create destroy! map-peer! unmap-peer! - class-name class-type save-attributes! - parent parent-dialog sibling - child-add! child-remove! child-move! - child-ref child-pos child-count - :children children - refresh redraw - child-x/y->pos - show hide - dialog - fill hbox vbox zbox cbox sbox - radio normalizer split - image/palette image/rgb image/rgba image/file image-save - current-focus focus-next focus-previous - menu menu-item menu-separator - clipboard timer send-url) - (import - scheme chicken foreign - lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex - (only posix setenv)) +;; -*- mode: Scheme; tab-width: 2; -*- ;; ;; {{{ Data types (foreign-declare "#include \n" + "#include \n" "#include \n" "#include \n" "typedef struct Iclass_ Iclass;\n" "struct Ihandle_ { char sig[4]; Iclass *iclass; /* ... */ } ;\n" "extern char *iupClassCallbackGetFormat(Iclass *iclass, const char *name);\n") @@ -384,11 +353,11 @@ (cond [(or (not proc) (pointer? proc)) proc] [else (set-finalizer! (make-wrapper (cons sig proc)) wrapper-destroy!)])] [old (set/pointer! handle name new)]) - (registry-set! handle (cons new (remove! (cut pointer=? <> old) (registry handle))))))] + (registry-set! handle (cons new ((if old (cut remove! (cut pointer=? <> old) <>) identity) (registry handle))))))] [callback (lambda (handle name) (let ([proc (get/pointer handle name)]) (cond [(wrapper-data proc) => cdr] @@ -416,19 +385,19 @@ (lambda (handle) (registry-destroy/recursive! handle) (handle-destroy! handle)))) (define map-peer! - (letrec ([map-peer/raw! (foreign-lambda istatus "IupMap" nonnull-ihandle)]) + (letrec ([map-peer/raw! (foreign-safe-lambda istatus "IupMap" nonnull-ihandle)]) (lambda (handle) (let ([status (map-peer/raw! handle)]) (case status [(#t) (void)] [else (error 'map-peer! (format "failed to map peer (~s)" status) handle)]))))) (define unmap-peer! - (foreign-lambda void "IupUnmap" nonnull-ihandle)) + (foreign-safe-lambda void "IupUnmap" nonnull-ihandle)) (define class-name (foreign-lambda iname/downcase "IupGetClassName" nonnull-ihandle)) (define class-type @@ -445,23 +414,23 @@ (define sibling (foreign-lambda ihandle "IupGetBrother" nonnull-ihandle)) (define child-add! - (letrec ([append! (foreign-lambda ihandle "IupAppend" nonnull-ihandle nonnull-ihandle)] - [insert! (foreign-lambda ihandle "IupInsert" nonnull-ihandle nonnull-ihandle nonnull-ihandle)]) + (letrec ([append! (foreign-safe-lambda ihandle "IupAppend" nonnull-ihandle nonnull-ihandle)] + [insert! (foreign-safe-lambda ihandle "IupInsert" nonnull-ihandle nonnull-ihandle nonnull-ihandle)]) (lambda (child container #!optional [anchor #f]) (or (if anchor (insert! container anchor child) (append! container child)) (error 'child-add! "failed to add child" child container anchor))))) (define child-remove! - (foreign-lambda void "IupDetach" nonnull-ihandle)) + (foreign-safe-lambda void "IupDetach" nonnull-ihandle)) (define child-move! - (letrec ([move! (foreign-lambda istatus "IupReparent" nonnull-ihandle nonnull-ihandle ihandle)]) + (letrec ([move! (foreign-safe-lambda istatus "IupReparent" nonnull-ihandle nonnull-ihandle ihandle)]) (lambda (child parent #!optional ref-child) (let ([status (move! child parent ref-child)]) (case status [(#t) (void)] [else (error 'child-move! (format "failed to move child (~s)" status) child parent)]))))) @@ -677,15 +646,15 @@ ;; {{{ The library watchdog (define thread-watchdog (letrec ([open (foreign-lambda* istatus () "C_return(IupOpen(NULL, NULL));")] + [setlocale (foreign-lambda* void () "setlocale(LC_NUMERIC, \"C\");")] [open-imglib (foreign-lambda void "IupImageLibOpen")] [close (foreign-lambda void "IupClose")] [chicken-yield (foreign-value "&CHICKEN_yield" c-pointer)]) - (and-let* ([lang (or (getenv "LANG") "")] - [(let ([status (dynamic-wind (cut setenv "LANG" "C") open (cut setenv "LANG" lang))]) + (and-let* ([(let ([status (dynamic-wind void open setlocale)]) (case status [(#t) #t] [(ignore) #f] [else (error 'iup (format "failed to initialize library (~s)" status))]))] [(open-imglib)] @@ -699,7 +668,5 @@ (attribute-set! watchdog 'time 500) (attribute-set! watchdog 'run #t) watchdog))) ;; }}} - -) Index: iup/iup-controls.scm ================================================================== --- iup/iup-controls.scm +++ iup/iup-controls.scm @@ -1,20 +1,6 @@ -(require-library iup-base) - -(module iup-controls - (canvas - frame tabs - label button toggle - spin spinbox valuator - textbox listbox treebox - progress-bar - matrix cells - color-bar color-browser - dial) - (import - scheme chicken foreign - iup-base) +;; -*- mode: Scheme; tab-width: 2; -*- ;; ;; {{{ Data types (foreign-declare "#include \n" @@ -122,7 +108,5 @@ (case status [(#t ignore) (void)] [else (error 'iup "failed to initialize library (~s)" status)])) ;; }}} - -) Index: iup/iup-dialogs.scm ================================================================== --- iup/iup-dialogs.scm +++ iup/iup-dialogs.scm @@ -1,12 +1,6 @@ -(require-library iup-base) - -(module iup-dialogs - (file-dialog message-dialog color-dialog font-dialog) - (import - scheme chicken foreign - iup-base) +;; -*- mode: Scheme; tab-width: 2; -*- ;; ;; {{{ Data types (foreign-declare "#include \n") @@ -31,8 +25,15 @@ (define font-dialog (make-constructor-procedure (foreign-lambda nonnull-ihandle "IupFontDlg"))) -;; }}} +(define layout-dialog + (make-constructor-procedure + (foreign-lambda nonnull-ihandle "IupLayoutDialog" ihandle) + #:apply-args (optional-args [dialog #f]))) + +(define element-properties-dialog + (make-constructor-procedure + (foreign-lambda nonnull-ihandle "IupElementPropertiesDialog" nonnull-ihandle))) -) +;; }}} Index: iup/iup-dynamic.scm ================================================================== --- iup/iup-dynamic.scm +++ iup/iup-dynamic.scm @@ -1,5 +1,7 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + (module iup-dynamic (iup-available? iup-dynamic-require) (import scheme chicken) (define (iup-dynamic-require sym) Index: iup/iup-glcanvas.scm ================================================================== --- iup/iup-glcanvas.scm +++ iup/iup-glcanvas.scm @@ -1,14 +1,6 @@ -(require-library iup-base) - -(module iup-glcanvas - (glcanvas - call-with-glcanvas glcanvas-is-current? - glcanvas-palette-set! glcanvas-font-set!) - (import - scheme chicken foreign - iup-base) +;; -*- mode: Scheme; tab-width: 2; -*- ;; ;; {{{ Data types (foreign-declare "#include \n" @@ -58,7 +50,5 @@ ;; {{{ Library setup (foreign-code "IupGLCanvasOpen();") ;; }}} - -) Index: iup/iup-pplot.scm ================================================================== --- iup/iup-pplot.scm +++ iup/iup-pplot.scm @@ -1,15 +1,6 @@ -(require-library iup-base) - -(module iup-pplot - (pplot - call-with-pplot pplot-add! - pplot-x/y->pixel-x/y - pplot-paint-to) - (import - scheme chicken foreign - iup-base) +;; -*- mode: Scheme; tab-width: 2; -*- ;; ;; {{{ Data types (foreign-declare "#include \n" @@ -71,7 +62,5 @@ ;; {{{ Library setup (foreign-code "IupPPlotOpen();") ;; }}} - -) Index: iup/iup-types.scm ================================================================== --- iup/iup-types.scm +++ iup/iup-types.scm @@ -1,5 +1,7 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + (define-foreign-type ihandle (c-pointer "Ihandle") (ihandle->pointer #f) (pointer->ihandle #f)) (define-foreign-type ihandle-list nonnull-pointer-vector ADDED iup/iup-web.scm Index: iup/iup-web.scm ================================================================== --- /dev/null +++ iup/iup-web.scm @@ -0,0 +1,25 @@ +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +;; {{{ Data types + +(foreign-declare + "#include \n" + "#include \n") + +(include "iup-types.scm") + +;; }}} + +;; {{{ Web browser control + +(define web-browser + (make-constructor-procedure + (foreign-lambda nonnull-ihandle "IupWebBrowser"))) + +;; }}} + +;; {{{ Library setup + +(foreign-code "IupWebBrowserOpen();") + +;; }}} Index: iup/iup.meta ================================================================== --- iup/iup.meta +++ iup/iup.meta @@ -1,6 +1,7 @@ ((category ui) (license "BSD") (author "Thomas Chust") (synopsis "Bindings to the IUP GUI library") (doc-from-wiki) - (needs srfi-42)) + (needs srfi-42) + (files "iup-dialogs.scm" "iup.scm" "iup-glcanvas.scm" "iup-pplot.scm" "iup.meta" "iup-web.scm" "iup-dynamic.scm" "iup.setup" "iup.release-info" "iup-types.scm" "iup-base.scm" "iup-controls.scm")) Index: iup/iup.scm ================================================================== --- iup/iup.scm +++ iup/iup.scm @@ -1,13 +1,106 @@ -(require-library iup-base iup-controls iup-dialogs) +;; -*- mode: Scheme; tab-width: 2; -*- ;; + +(require-library + lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex posix) + +(module iup-base + (ihandle->pointer pointer->ihandle ihandle-list->pointer-vector ihandle? + istatus->integer integer->istatus + iname->string string->iname + thread-watchdog iup-version load/led + attribute attribute-set! attribute-reset! + handle-name handle-name-set! handle-ref + main-loop main-loop-step main-loop-level main-loop-exit main-loop-flush + callback callback-set! + make-constructor-procedure optional-args + create destroy! map-peer! unmap-peer! + class-name class-type save-attributes! + parent parent-dialog sibling + child-add! child-remove! child-move! + child-ref child-pos child-count + :children children + refresh redraw + child-x/y->pos + show hide + dialog + fill hbox vbox zbox cbox sbox + radio normalizer split + image/palette image/rgb image/rgba image/file image-save + current-focus focus-next focus-previous + menu menu-item menu-separator + clipboard timer send-url) + (import + scheme chicken foreign + lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex + (only posix setenv)) + (include "iup-base.scm")) + +(module iup-controls + (canvas + frame tabs + label button toggle + spin spinbox valuator + textbox listbox treebox + progress-bar + matrix cells + color-bar color-browser + dial) + (import + scheme chicken foreign + iup-base) + (include "iup-controls.scm")) + +(module iup-dialogs + (file-dialog message-dialog color-dialog font-dialog + layout-dialog element-properties-dialog) + (import + scheme chicken foreign + iup-base) + (include "iup-dialogs.scm")) + +(cond-expand + [disable-iup-glcanvas] + [else + (module iup-glcanvas + (glcanvas + call-with-glcanvas glcanvas-is-current? + glcanvas-palette-set! glcanvas-font-set!) + (import + scheme chicken foreign + iup-base) + (include "iup-glcanvas.scm"))]) + +(cond-expand + [disable-iup-pplot] + [else + (module iup-pplot + (pplot + call-with-pplot pplot-add! + pplot-x/y->pixel-x/y + pplot-paint-to) + (import + scheme chicken foreign + iup-base) + (include "iup-pplot.scm"))]) + +(cond-expand + [disable-iup-web] + [else + (module iup-web + (web-browser) + (import + scheme chicken foreign + iup-base) + (include "iup-web.scm"))]) (module iup () (import scheme chicken) (reexport (except iup-base - ihandle->pointer pointer->ihandle ihandle-list->blob + ihandle->pointer pointer->ihandle ihandle-list->pointer-vector istatus->integer integer->istatus iname->string string->iname make-constructor-procedure optional-args) iup-controls iup-dialogs)) Index: iup/iup.setup ================================================================== --- iup/iup.setup +++ iup/iup.setup @@ -1,100 +1,95 @@ ;; -*- mode: Scheme; tab-width: 2; -*- ;; -(cond-expand - [no-library-checks - (define-syntax check-libraries - (syntax-rules () - [(check-libraries [lib fun] ...) - #t]))] - [else - (define-syntax check-libraries - (syntax-rules () - [(check-libraries [lib fun] ...) - (and (find-library lib fun) ...)]))]) - -(if (check-libraries - ["callback" "alloc_trampoline_r"] - ["iup" "IupOpen"] - ["iupim" "IupLoadImage"] - ["iupimglib" "IupImageLibOpen"]) - (begin - (compile -s -O2 -d1 "iup-base.scm" -j iup-base "-lcallback -liup -liupim -liupimglib") - (compile -c -O2 -d1 "iup-base.scm" -j iup-base -unit iup-base) - (compile -s -O2 -d0 "iup-base.import.scm") - - (install-extension - 'iup-base - '("iup-base.so" "iup-base.o" "iup-base.import.so" "iup-types.scm") - '((version 1.0.2) - (static "iup-base.o") - (static-options "-lcallback -liup -liupim -liupimglib"))) - - (compile -s -O2 -d1 "iup-controls.scm" -j iup-controls "-liup -liupcontrols") - (compile -c -O2 -d1 "iup-controls.scm" -j iup-controls -unit iup-controls) - (compile -s -O2 -d0 "iup-controls.import.scm") - - (install-extension - 'iup-controls - '("iup-controls.so" "iup-controls.o" "iup-controls.import.so") - '((version 1.0.2) - (static "iup-controls.o") - (static-options "-liup -liupcontrols"))) - - (compile -s -O2 -d1 "iup-dialogs.scm" -j iup-dialogs "-liup") - (compile -c -O2 -d1 "iup-dialogs.scm" -j iup-dialogs -unit iup-dialogs) - (compile -s -O2 -d0 "iup-dialogs.import.scm") - - (install-extension - 'iup-dialogs - '("iup-dialogs.so" "iup-dialogs.o" "iup-dialogs.import.so") - '((version 1.0.2) - (static "iup-dialogs.o") - (static-options "-liup"))) - - (if (check-libraries ["iupgl" "IupGLCanvasOpen"]) - (begin - (compile -s -O2 -d1 "iup-glcanvas.scm" -j iup-glcanvas "-liup -liupgl") - (compile -c -O2 -d1 "iup-glcanvas.scm" -j iup-glcanvas -unit iup-glcanvas) - (compile -s -O2 -d0 "iup-glcanvas.import.scm") - - (install-extension - 'iup-glcanvas - '("iup-glcanvas.so" "iup-glcanvas.o" "iup-glcanvas.import.so") - '((version 1.0.2) - (static "iup-glcanvas.o") - (static-options "-liup -liupgl")))) - (warning "IUP GLCanvas not found, some bindings cannot be compiled")) - - (if (check-libraries ["iup_pplot" "IupPPlotOpen"]) - (begin - (compile -s -O2 -d1 "iup-pplot.scm" -j iup-pplot "-liup -liup_pplot") - (compile -c -O2 -d1 "iup-pplot.scm" -j iup-pplot -unit iup-pplot) - (compile -s -O2 -d0 "iup-pplot.import.scm") - - (install-extension - 'iup-pplot - '("iup-pplot.so" "iup-pplot.o" "iup-pplot.import.so") - '((version 1.0.2) - (static "iup-pplot.o") - (static-options "-liup -liup_pplot")))) - (warning "IUP PPlot not found, some bindings cannot be compiled")) - - (compile -s -O2 -d1 "iup.scm" -j iup) - (compile -c -O2 -d1 "iup.scm" -j iup -unit iup) - (compile -s -O2 -d0 "iup.import.scm") - - (install-extension - 'iup - '("iup.so" "iup.o" "iup.import.so") - '((version 1.0.2) - (static "iup.o")))) - (warning "IUP or ffcall not found, none of the bindings can be compiled")) + +(define modules + `(-j iup + -j iup-base -j iup-controls -j iup-dialogs + ,@(cond-expand + [disable-iup-glcanvas + '()] + [else + '(-j iup-glcanvas)]) + ,@(cond-expand + [disable-iup-pplot + '()] + [else + '(-j iup-pplot)]) + ,@(cond-expand + [disable-iup-web + '()] + [else + '(-j iup-web)]))) + +(define import-libraries + `("iup.import.so" + "iup-base.import.so" "iup-controls.import.so" "iup-dialogs.import.so" + ,@(cond-expand + [disable-iup-glcanvas + '()] + [else + '("iup-glcanvas.import.so")]) + ,@(cond-expand + [disable-iup-pplot + '()] + [else + '("iup-pplot.import.so")]) + ,@(cond-expand + [disable-iup-web + '()] + [else + '("iup-web.import.so")]))) + +(define native-libraries + `("-lcallback" + "-liup" "-liupim" "-liupimglib" "-liupcontrols" + ,@(cond-expand + [disable-iup-glcanvas + '()] + [else + '("-liupgl")]) + ,@(cond-expand + [disable-iup-pplot + '()] + [else + '("-liup_pplot")]) + ,@(cond-expand + [disable-iup-web + '()] + [else + '("-liupweb")]))) + +(compile -s -O2 -d1 "iup.scm" ,@modules ,@native-libraries) +(compile -c -O2 -d1 "iup.scm" -unit iup) +(compile -s -O2 -d0 "iup.import.scm") +(compile -s -O2 -d0 "iup-base.import.scm") +(compile -s -O2 -d0 "iup-controls.import.scm") +(compile -s -O2 -d0 "iup-dialogs.import.scm") + +(cond-expand + [disable-iup-glcanvas] + [else + (compile -s -O2 -d0 "iup-glcanvas.import.scm")]) +(cond-expand + [disable-iup-pplot] + [else + (compile -s -O2 -d0 "iup-pplot.import.scm")]) +(cond-expand + [disable-iup-web] + [else + (compile -s -O2 -d0 "iup-web.import.scm")]) + +(install-extension + 'iup + `("iup.so" "iup.o" "iup-types.scm" ,@import-libraries) + `((version 1.2.1) + (static "iup-base.o") + (static-options ,(string-intersperse native-libraries)))) (compile -s -O2 -d1 "iup-dynamic.scm" -j iup-dynamic) (compile -c -O2 -d1 "iup-dynamic.scm" -j iup-dynamic -unit iup-dynamic) (compile -s -O2 -d0 "iup-dynamic.import.scm") (install-extension 'iup-dynamic '("iup-dynamic.so" "iup-dynamic.o" "iup-dynamic.import.so") - '((version 1.0.2) + '((version 1.2.1) (static "iup-dynamic.o"))) DELETED iup/test.scm Index: iup/test.scm ================================================================== --- iup/test.scm +++ /dev/null @@ -1,2 +0,0 @@ -(let ([dlg (dialog #:title "Test" (button "Push me!" #:action print))]) - (show dlg #:modal? #t))