x11: Fix x-graphics/draw-lines, /draw-points, /fill-polygon.

Extend these to accept points as lists or vectors of numbers as well
as flovecs.

diff --git a/doc/ref-manual/graphics.texi b/doc/ref-manual/graphics.texi
index 48b0e07b70548717384b9a38e27da211a0394dbd..c41c0f36724fbb1dd1733ac88b7b747b1dc656b9 100644 (file)
--- a/doc/ref-manual/graphics.texi
+++ b/doc/ref-manual/graphics.texi
@@ -715,6 +715,22 @@ at virtual coordinates (3,5):
 
 @end defop
 
+@defop operation x-graphics-device fill-polygon points
+@findex fill-polygon
+Draws a filled polygon using the current foreground color.
+@var{Points} is a list or vector of numbers
+in the order x1 y1 x2 y2 @dots{} xn yn.
+For example,
+
+@example
+(graphics-operation device 'fill-polygon #(0 0 0 1 1 0))
+@end example
+
+@noindent
+draws a solid triangular region between the points (0, 0), (0, 1) and
+(1, 0).
+@end defop
+
 @defop operation x-graphics-device draw-circle x y radius
 @defopx operation x-graphics-device fill-circle x y radius
 @cindex drawing arcs and circles, graphics

diff --git a/src/x11/debian/copyright b/src/x11/debian/copyright
index 6485dff6c215dc1de2e6859ba6a232ad406a6109..6cfc66a5f11d4f9223e4885df78d286202c91cf6 100644 (file)
--- a/src/x11/debian/copyright
+++ b/src/x11/debian/copyright
@@ -5,11 +5,12 @@ Source: http://birchwood-abbey.net/~matt/Scheme/
 Files: *
 Copyright:
 Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015,
-    2016, 2017, 2018, 2019, 2020 Matthew Birkholz
+    2016, 2017, 2018, 2019, 2020, 2021, 2022 Matthew Birkholz
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
     2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
-    2017, 2018, 2019, 2020 Massachusetts Institute of Technology
+    2017, 2018, 2019, 2020, 2021, 2022 Massachusetts Institute of
+    Technology
 License: GPL-2+
  This package is an X11 plugin for MIT/GNU Scheme Pucked,
  an experimental version of MIT/GNU Scheme.

diff --git a/src/x11/x11-device.scm b/src/x11/x11-device.scm
index d9a73532f893294177a9d1f450844c9a9282f303..f39330750f8ad545dfe96507aebd573ffd401078 100644 (file)
--- a/src/x11/x11-device.scm
+++ b/src/x11/x11-device.scm
@@ -477,7 +477,9 @@ USA.
                        (->flonum y-end)))
 
 (define (x-graphics/draw-lines device xv yv)
-  (x-graphics-draw-lines (x-graphics-device/xw device) xv yv))
+  (x-graphics-draw-lines (x-graphics-device/xw device)
+                        (->flovec xv)
+                        (->flovec yv)))
 
 (define (x-graphics/draw-point device x y)
   (x-graphics-draw-point (x-graphics-device/xw device)
@@ -485,7 +487,9 @@ USA.
                         (->flonum y)))
 
 (define (x-graphics/draw-points device xv yv)
-  (x-graphics-draw-points (x-graphics-device/xw device) xv yv))
+  (x-graphics-draw-points (x-graphics-device/xw device)
+                         (->flovec xv)
+                         (->flovec yv)))
 
 (define (x-graphics/draw-text device x y string)
   (x-graphics-draw-string (x-graphics-device/xw device)
@@ -610,9 +614,9 @@ USA.
                       360.
                       #t))
 
-(define (x-graphics/fill-polygon device point-vector)
+(define (x-graphics/fill-polygon device points)
   (x-graphics-fill-polygon (x-graphics-device/xw device)
-                          (vector-map ->flonum point-vector)))
+                          (->flovec points)))
 
 (define (x-graphics/copy-area device source-x-left source-y-top width height
                              destination-x-left destination-y-top)
@@ -631,6 +635,32 @@ USA.
 
 (define (x-graphics/window-id device)
   (x-window-id (x-graphics-device/xw device)))
+
+(define (->flovec object)
+  (cond ((flo:flonum? object)
+        object)
+       ((vector-of-type? object number?)
+        (let* ((n (vector-length object))
+               (v (flo:vector-cons n)))
+          (let loop ((i 0))
+            (if (fix:< i n)
+                (begin
+                  (flo:vector-set! v i (->flonum (vector-ref object i)))
+                  (loop (fix:+ i 1)))))
+          v))
+       ((list-of-type?->length object number?)
+        => (lambda (n)
+             (let ((v (flo:vector-cons n)))
+               (let loop ((i 0)
+                          (lst object))
+                 (if (pair? lst)
+                     (begin
+                       (flo:vector-set! v i (->flonum (car lst)))
+                       (loop (fix:+ i 1) (cdr lst)))))
+               v)))
+       (else (error:wrong-type-argument object
+                                        "list/vector of numbers"
+                                        '->flovec))))
 \f
 ;;;; Event-Handling Operations
 

diff --git a/src/x11/x11-graphics.scm b/src/x11/x11-graphics.scm
index 3d0b3623414c3a1c493c15de3deced0a3e5b291b..230615fc6d05977b61d1a553ff3a88f95de42f16 100644 (file)
--- a/src/x11/x11-graphics.scm
+++ b/src/x11/x11-graphics.scm
@@ -139,7 +139,7 @@ USA.
 
 (define (x-graphics-draw-points window x-vector y-vector)
   (let* ((n-points (flo:vector-length x-vector))
-        (points (malloc (* n-points (C-sizeof "XPoint")))))
+        (points (malloc (* n-points (C-sizeof "XPoint")) '|XPoint|)))
     (if (not (= n-points (flo:vector-length y-vector)))
        (error:bad-range-argument y-vector 'x-graphics-draw-points))
     (C-call "x_graphics_draw_points" window x-vector y-vector n-points points)
@@ -147,7 +147,7 @@ USA.
 
 (define (x-graphics-draw-lines window x-vector y-vector)
   (let* ((n-points (flo:vector-length x-vector))
-        (points (malloc (* n-points (C-sizeof "XPoint")))))
+        (points (malloc (* n-points (C-sizeof "XPoint")) '|XPoint|)))
     (if (not (= n-points (flo:vector-length y-vector)))
        (error:bad-range-argument y-vector 'x-graphics-draw-lines))
     (C-call "x_graphics_draw_lines" window x-vector y-vector n-points points)
@@ -179,7 +179,7 @@ USA.
   (let ((length (flo:vector-length vector)))
     (if (not (even? length))
        (error:bad-range-argument vector 'x-graphics-fill-polygon))
-    (let ((points (malloc (* (/ length 2) (C-sizeof "XPoint")))))
+    (let ((points (malloc (* (/ length 2) (C-sizeof "XPoint")) '|XPoint|)))
       (C-call "x_graphics_fill_polygon" window vector length points)
       (free points))))
 

diff --git a/src/x11/x11-test.scm b/src/x11/x11-test.scm
index 899ae976d6a298a5d33152f976d1f57b12ff2f49..576e036d62a81bc939a7f67c7f5b003cc5d02177 100644 (file)
--- a/src/x11/x11-test.scm
+++ b/src/x11/x11-test.scm
@@ -68,7 +68,9 @@ USA.
   (graphics-draw-line dev -.5 -.5 .5 .5)
   (graphics-move-cursor dev -.5 .5)
   (graphics-drag-cursor dev .5 -.5)
-  (x-graphics/draw-arc dev 0. 0. .5 .3 300. 300. #f))
+  (x-graphics/draw-arc dev 0. 0. .5 .3 300. 300. #f)
+  (x-graphics/fill-polygon dev #( 0 0.    0 .25  1/4 0))
+  (x-graphics/fill-polygon dev '(.0 0  -1/8 .0   0 -.125)))
 
 (define (test-properties xd window-id)
   (display "Getting/putting properties...\n")

diff --git a/src/x11/x11.pkg b/src/x11/x11.pkg
index d28aafc4553105a66fc1c16aad0e919208320fae..1f69c87e8309c92a87fc258ee77f4111ce063f31 100644 (file)
--- a/src/x11/x11.pkg
+++ b/src/x11/x11.pkg
@@ -231,6 +231,7 @@ USA.
          x-graphics/draw-text
          x-graphics/enable-keyboard-focus
          x-graphics/fill-circle
+         x-graphics/fill-polygon
          x-graphics/flush
          x-graphics/font-structure
          x-graphics/get-colormap