Index: api/draw.wiki ================================================================== --- api/draw.wiki +++ api/draw.wiki @@ -30,11 +30,11 @@

(call-with-canvas [canvas icanvas?] [proc (-> icanvas? any)]) → any

Calls the given procedure with the given simple drawing canvas and ensures that the canvas is synchronized with the underlying control. -

(make-canvas-action [proc (-> icanvas? any)]) → (-> ihandle? any)

+

(make-canvas-action [proc (-> icanvas? real? real? any)]) → (-> ihandle? real? real? any)

Creates a procedure that is suitable as an action callback for a canvas control. The resulting procedure creates a fresh simple drawing canvas when it is first called and runs (call-with-canvas canvas proc) every time it is called. The result of the call to proc is also the result of @@ -85,9 +85,12 @@

(draw-text [canvas icanvas?] [text string?] [x integer?] [y integer?] [r integer?] [g integer?] [b integer?]) → void?

Draws the given string with its top left corner at the given coordinates using the given color. -

(draw-image [canvas icanvas?] [name (or/c symbol? string?)] [make-inactive? any/c] [x integer?] [y integer?]) → void?

+

(draw-image [canvas icanvas?] [name (or/c symbol? string?)] [inactive? any/c] [x integer?] [y integer?]) → void?

Draws the image identified by the given name with its top left corner at the given coordinates. + +If inactive? is true, the image is drawn in an inactive style, ie. +with a superimposed gray shadow. ADDED chicken/iup-draw.scm Index: chicken/iup-draw.scm ================================================================== --- /dev/null +++ chicken/iup-draw.scm @@ -0,0 +1,145 @@ +(require-library lolevel data-structures srfi-4 iup-base) + +(module iup-draw + (icanvas? + make-canvas call-with-canvas make-canvas-action + canvas-size + canvas-clip-rectangle-set! canvas-clip-reset! + canvas-flush + draw-parent-background + draw-line + draw-rectangle + draw-arc + draw-polygon + draw-text + draw-image) + (import + scheme chicken foreign + lolevel data-structures srfi-4 iup-base) + +;; {{{ Data types + +(foreign-declare + "#include \n" + "typedef struct _IdrawCanvas *IdrawCanvas;\n" + "IdrawCanvas *iupDrawCreateCanvas(Ihandle *ih);\n" + "void iupDrawKillCanvas(IdrawCanvas *dc);\n" + "void iupDrawFlush(IdrawCanvas *dc);\n" + "void iupDrawUpdateSize(IdrawCanvas *dc);\n" + "void iupDrawGetSize(IdrawCanvas *dc, int *w, int *h);\n" + "void iupDrawParentBackground(IdrawCanvas *dc);\n" + "void iupDrawLine(IdrawCanvas *dc, int x1, int y1, int x2, int y2, unsigned char r, unsigned char g, unsigned char b);\n" + "void iupDrawRectangle(IdrawCanvas *dc, int x1, int y1, int x2, int y2, unsigned char r, unsigned char g, unsigned char b, int filled);\n" + "void iupDrawArc(IdrawCanvas *dc, int x1, int y1, int x2, int y2, double a1, double a2, unsigned char r, unsigned char g, unsigned char b, int filled);\n" + "void iupDrawPolygon(IdrawCanvas *dc, int *points, int count, unsigned char r, unsigned char g, unsigned char b, int filled);\n" + "void iupDrawText(IdrawCanvas *dc, const char *text, int len, int x, int y, unsigned char r, unsigned char g, unsigned char b);\n" + "void iupDrawImage(IdrawCanvas *dc, const char *name, int make_inactive, int x, int y);\n" + "void iupDrawSetClipRect(IdrawCanvas *dc, int x1, int y1, int x2, int y2);\n" + "void iupDrawResetClip(IdrawCanvas *dc);\n") + +(include "iup-types.scm") + +(define *icanvas-tag* "IdrawCanvas") +(define icanvas? (cut tagged-pointer? <> *icanvas-tag*)) + +(define (icanvas->pointer nonnull?) + (if nonnull? + (lambda (handle) + (ensure icanvas? handle) + handle) + (lambda (handle) + (ensure (disjoin not icanvas?) handle) + handle))) + +(define (pointer->icanvas nonnull?) + (if nonnull? + (lambda (handle) + (ensure pointer? handle) + (tag-pointer handle *icanvas-tag*)) + (lambda (handle) + (and handle (tag-pointer handle *icanvas-tag*))))) + +(define-foreign-type icanvas (c-pointer "IdrawCanvas") + (icanvas->pointer #f) + (pointer->icanvas #f)) + +(define-foreign-type nonnull-icanvas (nonnull-c-pointer "IdrawCanvas") + (icanvas->pointer #t) + (pointer->icanvas #t)) + +;; }}} + +;; {{{ Canvas management + +(define make-canvas + (letrec ([make-canvas/raw (foreign-lambda nonnull-icanvas "iupDrawCreateCanvas" nonnull-ihandle)] + [canvas-kill! (foreign-lambda void "iupDrawKillCanvas" nonnull-icanvas)]) + (lambda (handle) + (set-finalizer! (make-canvas/raw handle) canvas-kill!)))) + +(define call-with-canvas + (letrec ([canvas-update-size! (foreign-lambda void "iupDrawUpdateSize" nonnull-icanvas)]) + (lambda (canvas proc) + (dynamic-wind + (cut canvas-update-size! canvas) + (cut proc canvas) + (cut canvas-flush canvas))))) + +(define (make-canvas-action proc) + (let ([canvas #f]) + (lambda (handle x y) + (unless canvas (set! canvas (make-canvas handle))) + (call-with-canvas canvas (cut proc <> x y))))) + +(define canvas-size + (letrec ([canvas-size/raw (foreign-lambda void "iupDrawGetSize" nonnull-icanvas (c-pointer int) (c-pointer int))]) + (lambda (canvas) + (let-location ([width int -1] [height int -1]) + (canvas-size/raw canvas (location width) (location height)) + (values + (and (not (negative? width)) width) + (and (not (negative? height)) height)))))) + +;; }}} + +;; {{{ Drawing functions + +(define canvas-clip-rectangle-set! + (foreign-lambda void "iupDrawSetClipRect" nonnull-icanvas int int int int)) + +(define canvas-clip-reset! + (foreign-lambda void "iupDrawResetClip" nonnull-icanvas)) + +(define canvas-flush + (foreign-lambda void "iupDrawFlush" nonnull-icanvas)) + +(define draw-parent-background + (foreign-lambda void "iupDrawParentBackground" nonnull-icanvas)) + +(define draw-line + (foreign-lambda void "iupDrawLine" nonnull-icanvas int int int int unsigned-byte unsigned-byte unsigned-byte)) + +(define draw-rectangle + (foreign-lambda void "iupDrawRectangle" nonnull-icanvas int int int int unsigned-byte unsigned-byte unsigned-byte bool)) + +(define draw-arc + (foreign-lambda void "iupDrawArc" nonnull-icanvas int int int int double double unsigned-byte unsigned-byte unsigned-byte bool)) + +(define draw-polygon + (letrec ([draw-polygon/raw (foreign-lambda void "iupDrawPolygon" nonnull-icanvas s32vector int unsigned-byte unsigned-byte unsigned-byte bool)]) + (lambda (canvas points r g b filled?) + (let ([count (s32vector-length points)]) + (ensure even? count) + (draw-polygon/raw canvas points (/ count 2) r g b filled?))))) + +(define draw-text + (letrec ([draw-text/raw (foreign-lambda void "iupDrawText" nonnull-icanvas nonnull-c-string int int int unsigned-byte unsigned-byte unsigned-byte)]) + (lambda (canvas text x y r g b) + (draw-text/raw canvas text (string-length text) x y r g b)))) + +(define draw-image + (foreign-lambda void "iupDrawImage" nonnull-icanvas iname/downcase bool int int)) + +;; }}} + +) Index: chicken/iup.setup ================================================================== --- chicken/iup.setup +++ chicken/iup.setup @@ -8,11 +8,11 @@ (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.0) + '((version 1.1.0) (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) @@ -19,11 +19,11 @@ (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.0) + '((version 1.1.0) (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) @@ -30,13 +30,24 @@ (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.0) + '((version 1.1.0) (static "iup-dialogs.o") (static-options "-liup"))) + + (compile -s -O2 -d1 "iup-draw.scm" -j iup-draw "-liup") + (compile -c -O2 -d1 "iup-draw.scm" -j iup-draw -unit iup-draw) + (compile -s -O2 -d0 "iup-draw.import.scm") + + (install-extension + 'iup-draw + '("iup-draw.so" "iup-draw.o" "iup-draw.import.so") + '((version 1.1.0) + (static "iup-draw.o") + (static-options "-liup"))) (if (find-library "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) @@ -43,11 +54,11 @@ (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.0) + '((version 1.1.0) (static "iup-glcanvas.o") (static-options "-liup -liupgl")))) (warning "IUP GLCanvas not found, bindings will not be compiled")) (if (find-library "iup_pplot" "IupPPlotOpen") @@ -57,11 +68,11 @@ (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.0) + '((version 1.1.0) (static "iup-pplot.o") (static-options "-liup -liup_pplot")))) (warning "IUP PPlot not found, bindings will not be compiled")) (compile -s -O2 -d1 "iup.scm" -j iup) @@ -69,11 +80,11 @@ (compile -s -O2 -d0 "iup.import.scm") (install-extension 'iup '("iup.so" "iup.o" "iup.import.so") - '((version 1.0.0) + '((version 1.1.0) (static "iup.o")))) (warning "IUP not found, bindings will not be compiled")) (compile -s -O2 -d1 "iup-dynamic.scm" -j iup-dynamic) (compile -c -O2 -d1 "iup-dynamic.scm" -j iup-dynamic -unit iup-dynamic) @@ -80,7 +91,7 @@ (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.0) + '((version 1.1.0) (static "iup-dynamic.o")))