Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv21687/scheme/xlib
Added Files:
region-type.scm region.scm
Log Message:
+ added support for regions.
--- NEW FILE ---
(define-record-type region :region
(really-make-region tag Xregion)
region?
(tag region-tag region-set-tag!)
(Xregion region-Xregion region-set-Xregion!))
(define (make-region Xregion finalize?)
(let ((maybe-region (region-list-find Xregion)))
(if maybe-region
maybe-region
(let ((region (really-make-region #f Xregion)))
(if finalize?
(add-finalizer! region destroy-region)
(add-finalizer! region region-list-delete!))
(region-list-set! Xregion region)
region))))
(define (destroy-region region)
(%destroy-region (region-Xregion region))
(region-list-delete! region))
(import-lambda-definition %destroy-region (Xregion)
"scx_Destroy_Region")
;; All region records need to be saved in a weak-list, to have only one record
;; for the same XLib region
(define *weak-region-list* (make-integer-table))
(define (region-list-find Xregion)
(let ((r (table-ref *weak-region-list* Xregion)))
(if r
(weak-pointer-ref r)
r)))
(define (region-list-set! Xregion region)
(let ((p (make-weak-pointer region)))
(table-set! *weak-region-list* Xregion p)))
(define (region-list-delete! region)
(table-set! *weak-region-list*
(region-Xregion region) #f))
--- NEW FILE ---
;; create-region creates a new empty region. See XCreateRegion.
(define (create-region)
(make-region (%create-region) #t))
(import-lambda-definition %create-region ()
"scx_Create_Region")
;; clip-box returns the smalles rectangle enclosing the specified
;; region. The resulting rectangle is a list of four elements: x, y,
;; width and height. See XClipBox.
(define (clip-box region)
(vector->list (%clip-box (region-Xregion region))))
(import-lambda-definition %clip-box (Xregion)
"scx_Clip_Box")
;; region-empty? returns true if the region is empty. See XEmptyRegion
(define (region-empty? region)
(%region-empty? (region-Xregion region)))
(import-lambda-definition %region-empty? (Xregion)
"scx_Region_Empty")
;; region-equal? returns true if the two regions have the same offset,
;; size, and shape. See XEqualRegion.
(define (region-equal? r1 r2)
(%region-equal? (region-Xregion r1)
(region-Xregion r2)))
(import-lambda-definition %region-equal? (Xr1 Xr2)
"scx_Region_Equal")
;; point-in-region? function returns true if the point (x, y) is
;; contained in the region r. See XPointInRegion.
(define (point-in-region? region x y)
(%point-in-region? (region-Xregion region)
x y))
(import-lambda-definition %point-in-region? (Xregion x y)
"scx_Point_In_Region")
;; rectangle-in-region? returns 'in if the rectangle is entirely in
;; the specified region, #f if the rectangle is entirely out of the
;; specified region, and 'part if the rectangle is partially in the
;; specified region. rectangle is a list '(x y width height). See
;; XRectInRegion.
(define (rectangle-in-region? region rectangle)
(case (%rectanlge-in-region? (region-Xregion region)
(car rectangle) (cadr rectangle)
(caddr rectangle) (cadddr rectangle))
((0) #f)
((1) 'in)
((2) 'part)))
(import-lambda-definition %rectangle-in-region? (Xregion x y w h)
"scx_Rect_In_Region")
;; intersect-region returns the intersection of two regions. See
;; XIntersectRegion.
(define (intersect-region r1 r2)
(make-region (%intersect-region (region-Xregion r1)
(region-Xregion r1))
#t))
(import-lambda-definition %intersect-region (Xr1 Xr2)
"scx_Intersect_Region")
;; union-region returns the union of two regions. See XUnionRegion.
(define (union-region r1 r2)
(make-region (%union-region (region-Xregion r1)
(region-Xregion r1))
#t))
(import-lambda-definition %union-region (Xr1 Xr2)
"scx_Union_Region")
;; union-rectangle-with-region returns the union of the specified
;; rectangle and the specified region. The rectangle is a list (x y
;; width height) See XUnionRectWithRegion.
(define (union-rectangle-with-region rectangle region)
(make-region (%union-rectangle-with-region
(car rectangle) (cadr rectangle)
(caddr rectangle) (cadddr rectangle)
(region-Xregion region))
#t))
(import-lambda-definition %union-rectangle-with-region (x y w h Xregion)
"scx_Union_Rect_With_Region")
;; subtract-region subtracts r2 from r1 and returns the resulting
;; region. See XSubtractRegion.
(define (subtract-region r1 r2)
(make-region (%subtract-region (region-Xregion r1)
(region-Xregion r2))
#t))
(import-lambda-definition %subtract-region (Xr1 Xr2)
"scx_Subtract_Region")
;; xor-region calculates the difference between the union and
;; intersection of two regions and returns the resulting region. See
;; XXorRegion.
(define (xor-region r1 r2)
(make-region (%xor-region (region-Xregion r1)
(region-Xregion r2))
#t))
(import-lambda-definition %xor-region (Xr1 Xr2)
"scx_Xor_Region")
;; offset-region! moves the specified region by a dx and dy. See
;; XOffsetRegion.
(define (offset-region! region dx dy)
(%offset-region! (region-Xregion region)
dx dy))
(import-lambda-definition %offset-region (Xregion dx dy)
"scx_Offset_Region")
;; shrink-region! reduces the specified region by specified
;; amount. Positive values shrink the size of the region, and negative
;; values expand the region.
(define (shrink-region! region dx dy)
(%shrink-region! (region-Xregion region)
dx dy))
(import-lambda-definition %shrink-region! (Xregion dx dy)
"scx_Shrink_Region")
;; polygon-region returns a region for the polygon defines by
;; points. points has to a list of pairs (x . y). For an explanation
;; of fill-rule see create-gcontext. See XPolygonRegion.
(define (polygon-region points fill-rule)
(make-region (%polygon-region (list->vector points)
fill-rule)
#t))
(import-lambda-definition %polygon-region (points fillrule)
"scx_Polygon_Region")
;; set-region sets the clip-mask in the GC to the specified region.
;; The region is specified relative to the drawable's origin. The
;; resulting GC clip origin is implementation-dependent. Once it is
;; set in the GC, the region can be destroyed. See XSetRegion.
(define (set-region gcontext region)
(%set-region (display-Xdisplay (gcontext-display gcontext))
(gcontext-Xgcontext gcontext)
(region-Xregion region)))
(import-lambda-definition %set-region (Xdisplay Xgontext Xregion)
"scx_Set_Region")
;;** Additional functions to support the more "scheme-like" functions
;;** above
;; copy-region! mutates to-region so that it is identical to
;; from-region. In fact this function uses XUnionRegion to create an
;; identical region. See "region.c".
(define (copy-region! from-region to-region)
(%copy-region (region-Xregion from-region)
(region-Xregion to-region)))
(import-lambda-definition %copy-region (Xfrom Xto)
"scx_Copy_Region")
;; duplicate-region returns a new region that is identical to the
;; specified one.
(define (duplicate-region region)
(let ((r (create-region)))
(copy-region! region r)
r))
;; offset-region returns a new region that is identical to the
;; specified one except that it is moved by dx and dy. See
;; offset-region!.
(define (offset-region region dx dy)
(let ((r (duplicate-region region)))
(offset-region! r dx dy)
r))
;; shrink-region returns a new region that is identical to the
;; specified one except that it is shrunk by dx and dy. See
;; shrink-region!.
(define (shrink-region region dx dy)
(let ((r (duplicate-region region)))
(shrink-region! r dx dy)
r))
|