Index: api/draw.wiki
==================================================================
--- api/draw.wiki
+++ api/draw.wiki
@@ -30,11 +30,11 @@
Calls the given procedure with the given simple drawing canvas and ensures that
the canvas is synchronized with the underlying control.
-
+
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 @@
Draws the given string with its top left corner at the given coordinates using
the given color.
-
+
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")))