Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv25663/scheme/xlib
Modified Files:
graphics.scm text.scm
Log Message:
+ graphic: changed representations of rectangles to lists (x y width height),
and points to pairs (x . y). Added some auxiliary functions for that.
+ text: made the format arguments optional, and default to '1-byte.
+ added comments.
Index: graphics.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/graphics.scm,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -r1.6 -r1.7
*** graphics.scm 2001/08/29 14:43:49 1.6
--- graphics.scm 2001/10/04 12:31:44 1.7
***************
*** 3,6 ****
--- 3,10 ----
;; 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 - 1. See XClearArea.
(define (clear-area window x y width height exposures?)
***************
*** 9,19 ****
x y width height exposures?))
-
(import-lambda-definition %clear-area (Xwindow Xdisplay x y width height
exposures?)
"scx_Clear_Area")
-
! ;; _____
(define (copy-area src-drawable gcontext src-x src-y width height dst-drawable
--- 13,22 ----
x y width height 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 src-y width height dst-drawable
***************
*** 29,35 ****
width height destXdrawable destx desty)
"scx_Copy_Area")
-
! ;; _____
(define (copy-plane src-drawable gcontext plane src-x src-y width height
--- 32,39 ----
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 src-y width height
***************
*** 43,67 ****
dst-x dst-y))
-
(import-lambda-definition %copy-plane (Xdisplay srcXdrawable Xgcontext plane
srcx srcy width height destXdrawable
destx desty)
"scx_Copy_Plane")
-
- ;; _____
! (define (draw-point drawable gcontext x y)
(%draw-point (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
! x y))
(import-lambda-definition %draw-point (Xdisplay Xdrawable Xgcontext x y)
"scx_Draw_Point")
- ;; _____
-
(define (draw-points drawable gcontext points relative?)
(%draw-point (display-Xdisplay (drawable-display drawable))
--- 47,72 ----
dst-x dst-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))
***************
*** 74,94 ****
relative)
"scx_Draw_Points")
-
! ;; _____
! (define (draw-line drawable gcontext x1 y1 x2 y2)
(%draw-line (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
! x1 y1 x2 y2))
(import-lambda-definition %draw-line (Xdisplay Xdrawable Xgcontext x1 y1 x2
y2)
"scx_Draw_Line")
-
! ;; _____
-
(define (draw-lines drawable gcontext points relative?)
(%draw-lines (display-Xdisplay (drawable-display drawable))
--- 79,104 ----
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))
***************
*** 100,108 ****
(import-lambda-definition %draw-lines (Xdisplay Xdrawable Xgcontext vec rel)
"scx_Draw_Lines")
-
- ;; _____
! ;; Note: points is a list which contains lists with 4
! ;; integers in Form: (x1, y1, x2, y2)
(define (draw-segments drawable gcontext points)
--- 110,118 ----
(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)
***************
*** 110,161 ****
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
! (list->vector points)))
(import-lambda-definition %draw-segments (Xdisplay Xdrawable Xgcontext vec)
"scx_Draw_Segments")
! (define (draw-rectangle drawable gcontext x y width height)
(%draw-rectangle (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
! x y width height))
! (import-lambda-definition %draw-rectangle (Xdisplay Xdrawable Xgcontext x y
! w h)
"scx_Draw_Rectangle")
- (define (fill-rectangle drawable gcontext x y width height)
- (%fill-rectangle (display-Xdisplay (drawable-display drawable))
- (drawable-Xobject drawable)
- (gcontext-Xgcontext gcontext)
- x y width height))
-
- (import-lambda-definition %fill-rectangle (Xdisplay Xdrawable Xgcontext x y
- w h)
- "scx_Fill_Rectangle")
-
-
(define (draw-rectangles drawable gcontext rectangles)
(%draw-rectangles (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
! (list->vector rectangles)))
! (import-lambda-definition %draw-rectangles (Xdisplay Xdrawable Xgcontext
! vec)
"scx_Draw_Rectangles")
(define (fill-rectangles drawable gcontext rectangles)
(%fill-rectangles (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
! (list->vector rectangles)))
! (import-lambda-definition %fill-rectangles (Xdisplay Xdrawable Xgcontext
! vec)
"scx_Fill_Rectangles")
(define (draw-arc drawable gcontext x y width height angle1 angle2)
--- 120,184 ----
(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 x y width height angle1 angle2)
***************
*** 198,201 ****
--- 221,228 ----
"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))
***************
*** 207,208 ****
--- 234,260 ----
vec relative shape)
"scx_Fill_Polygon")
+
+ ;; Now some auxiliary functions:
+
+ (define rectangle list)
+
+ (define (bounds x1 y1 x2 y2)
+ (rectangle x1 y2 (- x2 x1) (- y2 y1)))
+
+ ;; 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)))
+
\ No newline at end of file
Index: text.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/text.scm,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -r1.5 -r1.6
*** text.scm 2001/08/22 11:49:01 1.5
--- text.scm 2001/10/04 12:31:44 1.6
***************
*** 84,139 ****
! ; --- text-width returns the widht of the given 1- or 2-byte char-string,
! ; represented by a vector of integers.
- (define (text-width font text format)
- (%text-width (font-Xfontstruct font)
- (text->internal-text text format)
- (get-format-id format)))
-
(import-lambda-definition %text-width (Xfontstruct text format)
"scx_Text_Width")
-
- ; --- Each extents-...-functions returns a number.
-
- (define (extents-lbearing font text format)
- (extents-intern font text format 0))
-
-
- (define (extents-rbearing font text format)
- (extents-intern font text format 1))
-
-
- (define (extents-width font text format)
- (extents-intern font text format 2))
! (define (extents-ascent font text format)
! (extents-intern font text format 3))
-
- (define (extents-descent font text format)
- (extents-intern font text format 4))
-
-
- (define (extents-intern font text format which?)
- (%extents (font-Xfontstruct font)
- (text->internal-text text format)
- (get-format-id format)
- which?))
-
(import-lambda-definition %extents-text (Xfontstruct text format which)
"scx_Extents_Text")
! ; --- draw-image-text draws the text. text is a integer, character, string
! ; or symbol, or event a list of these types.
!
! (define (draw-image-text drawable gcontext x y text format)
! (%draw-image-text (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
! (gcontext-Xgcontext gcontext)
! x y
! (text->internal-text text format)
! (eq? format '2-byte)))
--- 84,133 ----
! ;; text-width returns the widht of the given 1-byte or 2-byte string,
! ;; represented by an integer, character, string or symbol, or event a
! ;; list of those types. the optional argument format is one of '1-byte
! ;; or '2-byte, which defaults to '1-byte. See XTextWidth.
!
! (define (text-width font text . format)
! (let ((format (if (null? format) '1-byte (car format))))
! (%text-width (font-Xfontstruct font)
! (text->internal-text text format)
! (get-format-id format))))
(import-lambda-definition %text-width (Xfontstruct text format)
"scx_Text_Width")
+ ; --- Each extents-...-function returns a number.
! (define (extents-intern id)
! (lambda (font text . format)
! (let ((format (if (null? format) '1-byte (car format))))
! (%extents (font-Xfontstruct font)
! (text->internal-text text format)
! (get-format-id format)
! id))))
!
! (define extents-lbearing (extents-intern 0))
! (define extents-rbearing (extents-intern 1))
! (define extents-width (extents-intern 2))
! (define extents-ascent (extents-intern 3))
! (define extents-descent (extents-intern 4))
(import-lambda-definition %extents-text (Xfontstruct text format which)
"scx_Extents_Text")
! ;; draw-image-text draws a text on the gcontext at the specified
! ;; position. text is an integer, character, string or symbol, or even
! ;; a list of these types. format is '1-byte or '2-byte. '1-byte is the
! ;; default value. See XDrawImageString.
!
! (define (draw-image-text drawable gcontext x y text . format)
! (let ((format (if (null? format) '1-byte (car format))))
! (%draw-image-text (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
! (gcontext-Xgcontext gcontext)
! x y
! (text->internal-text text format)
! (eq? format '2-byte))))
***************
*** 141,163 ****
x y text format)
"scx_Draw_Image_Text")
-
- ; --- text is a list of font-object and chars.
! (define (draw-poly-text drawable gcontext x y text format)
! (let ((text-spec
! (map (lambda (text-or-font)
! (cond
! ((font? text-or-font)
! (cons (font-Xfont text-or-font)
! 0))
! ((and (pair? text-or-font)
! (not (list? text-or-font)))
! (cons (if (font? (car text-or-font))
! (font-Xfont (car text-or-font))
! 'none)
! (cdr text-or-font)))
! (else (text->internal-text text-or-font
! format))))
! (separate-fonts text))))
(%draw-poly-text (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
--- 135,169 ----
x y text format)
"scx_Draw_Image_Text")
! ;; draw-poly-test is a more complex function for text drawing. text
! ;; has the following format:
! ;; <text> ::= <text-spec> | ( <text-spec>+ )
! ;; <text-spec> ::= <integer> | <char> | <string> | <symbol> | <font>
! ;; | (null . <delta>) | (<font> . <delta>)
! ;; <delta> ::= <integer>
! ;; so for example a text argument of
! ;; (list font-1 "Hello" (cons font-2 5) "World")
! ;; should draw Hello in font-1 and World in font-2 with a
! ;; character-spacing of 5.
! ;; the optional format argument is one of '1-byte or '2-byte and
! ;; defaults to '1-byte.
!
! (define (draw-poly-text drawable gcontext x y text . format)
! (let* ((format (if (null? format) '1-byte (car format)))
! (text-spec
! (map (lambda (text-or-font)
! (cond
! ((font? text-or-font)
! (cons (font-Xfont text-or-font)
! 0))
! ((and (pair? text-or-font)
! (not (list? text-or-font)))
! (cons (if (font? (car text-or-font))
! (font-Xfont (car text-or-font))
! 'none)
! (cdr text-or-font)))
! (else (text->internal-text text-or-font
! format))))
! (separate-fonts text))))
(%draw-poly-text (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
|