scx/scheme/xlib/graphics.scm

;; author -> Norbert Freudemann
;; creation date : 18/06/2001
;; last change   : 04/07/2001

;; clear-area paints a rectangular area in the specified window
;; according to the specified dimensions with the window's background
;; pixel or pixmap. If width/height is zero it is replaced by the
;; window's width/height - x/y. See XClearArea.

(define (clear-area window rect exposures?)
  (%clear-area (window-Xwindow window)
	       (display-Xdisplay (window-display window))
	       (rect-x rect) (rect-y rect)
	       (rect-width rect) (rect-height rect)
	       exposures?))

(import-lambda-definition %clear-area (Xwindow Xdisplay x y width height
				       exposures?)
  "scx_Clear_Area")

;; copy-area combines the specified rectangle of src with the
;; specified rectangle of dest. See XCopyArea.

(define (copy-area src-drawable gcontext src-x.y width height dst-drawable
		   dst-x.y)
  (%copy-area (display-Xdisplay (drawable-display src-drawable))
	      (drawable-Xobject src-drawable)
	      (gcontext-Xgcontext gcontext)
	      (car src-x.y) (cdr src-x.y) width height
	      (drawable-Xobject dst-drawable)
	      (car dst-x.y) (cdr dst-x.y)))

(import-lambda-definition %copy-area (Xdisplay srcXdrawable Xgcontext srcx srcy
				      width height destXdrawable destx desty)
  "scx_Copy_Area")

;; copy-plane uses a single bit plane of the specified source
;; rectangle combined with the specified GC to modify the specified
;; rectangle of dest. See XCopyPlane.

(define (copy-plane src-drawable gcontext plane src-x.y width height
		    dst-drawable dst-x.y)
  (%copy-plane (display-Xdisplay (drawable-display src-drawable))
	       (drawable-Xobject src-drawable)
	       (gcontext-Xgcontext gcontext)
	       plane
	       (car src-x.y) (cdr src-x.y) width height
	       (drawable-Xobject dst-drawable)
	       (car dst-x.y) (cdr dst-x.y)))

(import-lambda-definition %copy-plane (Xdisplay srcXdrawable Xgcontext plane
				       srcx srcy width height destXdrawable
				       destx desty)
  "scx_Copy_Plane")

;; draw-point uses the foreground pixel and function components of the
;; GC to draw a single point into the specified drawable. A point is
;; specified as a pair (x . y). See XDrawPoint.

(define (draw-point drawable gcontext x.y)
  (%draw-point (display-Xdisplay (drawable-display drawable))
	       (drawable-Xobject drawable)
	       (gcontext-Xgcontext gcontext)
	       (car x.y) (cdr x.y)))

(import-lambda-definition %draw-point (Xdisplay Xdrawable Xgcontext x y)
  "scx_Draw_Point")

;; draw-points draws multiple points the same way as draw-point
;; does. The points have to be specified as a list of pairs. See
;; XDrawPoints.

(define (draw-points drawable gcontext points relative?)
  (%draw-point (display-Xdisplay (drawable-display drawable))
	       (drawable-Xobject drawable)
	       (gcontext-Xgcontext gcontext)
	       (list->vector points)
	       relative?))

(import-lambda-definition %draw-points (Xdisplay Xdrawable Xgcontext vec
					relative)
  "scx_Draw_Points")			  

;; draw-line uses the components of the specified GC to draw a line
;; between the specified set of points (x1 . y1) and (x2 . y2). See
;; XDrawLine.

(define (draw-line drawable gcontext x-y-1 x-y-2)
  (%draw-line (display-Xdisplay (drawable-display drawable))
	      (drawable-Xobject drawable)
	      (gcontext-Xgcontext gcontext)
	      (car x-y-1) (cdr x-y-1)
	      (car x-y-2) (cdr x-y-2)))

(import-lambda-definition %draw-line (Xdisplay Xdrawable Xgcontext x1 y1 x2 y2)
  "scx_Draw_Line")

;; draw-lines uses the components of the specified GC to draw lines
;; between each pair of points (xi . yi) (xi+1 . yi+1) in the list
;; points. It draws the lines in the order given in the list. The
;; lines join correctly at all intermediate points, and if the first
;; and last points coincide, the first and last lines also join
;; correctly. See XDrawLines.

(define (draw-lines drawable gcontext points relative?)
  (%draw-lines (display-Xdisplay (drawable-display drawable))
	       (drawable-Xobject drawable)
	       (gcontext-Xgcontext gcontext)
	       (list->vector points)
	       relative?))

(import-lambda-definition %draw-lines (Xdisplay Xdrawable Xgcontext vec rel)
  "scx_Draw_Lines")

;; draw-segments function draws multiple, unconnected lines. The
;; points have to be specified as list of lists of 4 integers (x1 y1
;; x2 y2). Use points->segments to convert a list of points into a
;; list of segments. See XDraw Segements.

(define (draw-segments drawable gcontext points)
  (%draw-segments (display-Xdisplay (drawable-display drawable))
		  (drawable-Xobject drawable)
		  (gcontext-Xgcontext gcontext)
		  (list->vector (map list->vector points))))

(import-lambda-definition %draw-segments (Xdisplay Xdrawable Xgcontext vec)
  "scx_Draw_Segments")			 

;; draw-rectangle and draw-rectangles draw the outlines of the
;; specified rectangle or rectangles as if a five-point PolyLine
;; protocol request were specified for each rectangle. The rectangles
;; have to be specified as a list (x y width height). See
;; XDrawRectangle(s).

(define (draw-rectangle drawable gcontext rect)
  (%draw-rectangle (display-Xdisplay (drawable-display drawable))
		   (drawable-Xobject drawable)
		   (gcontext-Xgcontext gcontext)
		   (list->vector rect)))

(import-lambda-definition %draw-rectangle (Xdisplay Xdrawable Xgcontext rect)
  "scx_Draw_Rectangle")			  

(define (draw-rectangles drawable gcontext rectangles)
  (%draw-rectangles (display-Xdisplay (drawable-display drawable))
		    (drawable-Xobject drawable)
		    (gcontext-Xgcontext gcontext)
		    (list->vector (map list->vector rectangles))))

(import-lambda-definition %draw-rectangles (Xdisplay Xdrawable Xgcontext vec)
   "scx_Draw_Rectangles")

;; fill-rectangle and fill-rectangles fill the rectangle(s) outlined
;; with draw-rectangle(s). See XFillRectangle(s).

(define (fill-rectangle drawable gcontext rect)
  (%fill-rectangle (display-Xdisplay (drawable-display drawable))
		   (drawable-Xobject drawable)
		   (gcontext-Xgcontext gcontext)
		   (list->vector rect)))

(import-lambda-definition %fill-rectangle (Xdisplay Xdrawable Xgcontext rect)
  "scx_Fill_Rectangle")

(define (fill-rectangles drawable gcontext rectangles)
  (%fill-rectangles (display-Xdisplay (drawable-display drawable))
		    (drawable-Xobject drawable)
		    (gcontext-Xgcontext gcontext)
		    (list->vector (map list->vector rectangles))))

(import-lambda-definition %fill-rectangles (Xdisplay Xdrawable Xgcontext vec)
   "scx_Fill_Rectangles")

;; draw-arc(s) and fill-arc(s) draws a single/multiple circular or
;; elliptical arc(s). Each arc is specified by a rectangle and two
;; angles. The center of the circle or ellipse is the center of the
;; rectangle, and the major and minor axes are specified by the width
;; and height. Positive angles indicate counterclockwise motion, and
;; negative angles indicate clockwise motion. 
;; angle1 specifies the start of the arc relative to the three-o'clock
;; position from the center, in units of degrees * 64. angle2
;; specifies the path and extent of the arc relative to the start of
;; the arc, in units of degrees * 64. If the magnitude of angle2 is
;; greater than 360 degrees it is truncated to 360 degrees.

(define (draw-arc drawable gcontext rect angle1 angle2)
  (%draw-arc (display-Xdisplay (drawable-display drawable))
	     (drawable-Xobject drawable)
	     (gcontext-Xgcontext gcontext)
	     (rect-x rect) (rect-y rect)
	     (rect-width rect) (rect-height rect)
	     angle1 angle2))

(import-lambda-definition %draw-arc (Xdisplay Xdrawable Xgcontext x y
					      w h a1 a2)
   "scx_Draw_Arc")


(define (fill-arc drawable gcontext rect angle1 angle2)
  (%fill-arc (display-Xdisplay (drawable-display drawable))
	     (drawable-Xobject drawable)
	     (gcontext-Xgcontext gcontext)
	     (rect-x rect) (rect-y rect)
	     (rect-width rect) (rect-height rect)
	     angle1 angle2))

(import-lambda-definition %fill-arc (Xdisplay Xdrawable Xgcontext x y
					      w h a1 a2)
   "scx_Fill_Arc")

;; draw-arcs/fill-arcs: the arcs argument has to be a list of arcs,
;; where an arc is a list (rect angle1 angle2) - and rect a list of (x
;; y width height).

(define (draw-arcs drawable gcontext arcs)
  (%draw-arcs (display-Xdisplay (drawable-display drawable))
	      (drawable-Xobject drawable)
	      (gcontext-Xgcontext gcontext)
	      (list->vector arcs)))

(import-lambda-definition %draw-arcs (Xdisplay Xdrawable Xgcontext vec)
  "scx_Draw_Arcs")

(define (fill-arcs drawable gcontext arcs)
  (%fill-arcs (display-Xdisplay (drawable-display drawable))
	      (drawable-Xobject drawable)
	      (gcontext-Xgcontext gcontext)
	      (list->vector arcs)))

(import-lambda-definition %fill-arcs (Xdisplay Xdrawable Xgcontext vec)
  "scx_Fill_Arcs")

;; fill-polygon fills the region closed by the specified path. The
;; path is closed automatically if the last point in the list does not
;; coincide with the first point. See XFillPolygon.

(define (fill-polygon drawable gcontext points relative? shape)
  (%fill-polygon (display-Xdisplay (drawable-display drawable))
		 (drawable-Xobject drawable)
		 (gcontext-Xgcontext gcontext)
		 (list->vector points) relative?
		 (polygon-shape->integer shape)))

(define-enumerated-type polygon-shape :polygon-shape
  polygon-shape? polygon-shapes polygon-shape-name polygon-shape-index
  (complex non-convex convex))

(define (polygon-shape->integer v)
  (polygon-shape-index v))

(import-lambda-definition %fill-polygon (Xdisplay Xdrawable Xgcontext
						  vec relative shape)
  "scx_Fill_Polygon")

;; Now some auxiliary functions:

(define (rect x y w h)
  (list x y w h))

(define (rect? obj)
  (and (list? obj) (= 4 (length obj))))

(define rect-x car)
(define rect-y cadr)
(define rect-width caddr)
(define rect-height cadddr)

(define (set-rect-x! r x) (set-car! r x))
(define (set-rect-y! r y) (set-car! (cdr r) y))
(define (set-rect-width! r width) (set-car! (cddr r) width))
(define (set-rect-height! r height) (set-car! (cdddr r) height))

(define (bounds x1 y1 x2 y2)
  (rect x1 y1 (- x2 x1) (- y2 y1)))

(define (grow-rect r dw dh . maybe-centric?)
  (if (or (null? maybe-centric?) (not (car maybe-centric?)))
      (rect (rect-x r) (rect-y r)
	    (+ (rect-width r) dw)
	    (+ (rect-height r) dh))
      (rect (- (rect-x r) (quotient dw 2))
	    (- (rect-y r) (quotient dh 2))
	    (+ (rect-width r) dw)
	    (+ (rect-height r) dh))))

(define (move/resize-rect r dx dy dw dh)
  (rect (+ (rect-x r) dx)
	(+ (rect-y r) dy)
	(+ (rect-width r) dw)
	(+ (rect-height r) dh)))

;; converts '((x1 . y1) (x2 . y2) (x3 . y3) (x4 . y4)) -> '((x1 y1 x2
;; y2) (x3 y3 x4 y4))

(define (points->segments points)
  (cdr (fold-right (lambda (this rest)
		     (if (null? (car rest))
			 (cons (list (car this)
				     (cdr this))
			       (cdr rest))
			 (cons '()
			       (cons (cons (car this)
					   (cons (cdr this)
						 (car rest)))
				(cdr rest)))))
		   '(())
		   points)))