308 lines
11 KiB
Scheme
308 lines
11 KiB
Scheme
;; 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 list)
|
|
|
|
(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)))
|
|
|