scx/scheme/libs/xft.scm

(define-record-type xft-pattern :xft-pattern
  (really-make-xft-pattern c-pointer)
  xft-pattern?
  (c-pointer xft-pattern-c-pointer))

(define-exported-binding "xft-pattern" :xft-pattern)

(define-record-type xft-font :xft-font
  (make-xft-font x-pointer)
  xft-font?
  (x-pointer xft-font-x-pointer))

(define-exported-binding "xft-font" :xft-font)

(define-record-type xft-draw :xft-draw
  (make-xft-draw c-pointer)
  xft-draw?
  (c-pointer xft-draw-c-pointer))

(define-exported-binding "xft-draw" :xft-draw)

(define-record-type xft-color :xft-color
  (make-xft-color c-pointer display visual colormap)
  xft-color?
  (c-pointer xft-color-c-pointer)
  (display xft-color-display set-xft-color-display!)
  (visual xft-color-visual set-xft-color-visual!)
  (colormap xft-color-colormap set-xft-color-colormap!))

(define-exported-binding "xft-color" :xft-color)

(define-record-type xft-objectset :xft-objectset
  (make-xft-objectset c-pointer)
  xft-objectset?
  (c-pointer xft-objectset-c-pointer))

(define-exported-binding "xft-objectset" :xft-objectset)

(define-record-type xft-fontset :xft-fontset
  (really-make-xft-fontset c-pointer patterns)
  xft-fontset?
  (c-pointer xft-fontset-c-pointer)
  (patterns xft-fontset-patterns set-xft-fontset-patterns!))

(define-exported-binding "xft-fontset" :xft-fontset)

(define-syntax lookup-shared-valued
  (syntax-rules ()
    ((lookup-shared-valued str)
     (shared-binding-ref
      (lookup-imported-binding str)))))
 
(define-finite-type xft-pattern-object :xft-pattern-object
  (id)
  xft-pattern-object?
  xft-pattern-object-elements
  xft-pattern-object-name
  xft-pattern-object-index
  (id xft-pattern-object-id)
  ((family	(lookup-shared-valued "scx-xft-pattern-family"))
   (style	(lookup-shared-valued "scx-xft-pattern-style"))
   (slant	(lookup-shared-valued "scx-xft-pattern-slant"))
   (weight	(lookup-shared-valued "scx-xft-pattern-weight"))
   (size	(lookup-shared-valued "scx-xft-pattern-size"))
   (pixel-size	(lookup-shared-valued "scx-xft-pattern-pixel-size"))
   (encoding	(lookup-shared-valued "scx-xft-pattern-encoding"))
   (spacing	(lookup-shared-valued "scx-xft-pattern-spacing"))
   (foundry	(lookup-shared-valued "scx-xft-pattern-foundry"))
   (core	(lookup-shared-valued "scx-xft-pattern-core"))
   (antialias	(lookup-shared-valued "scx-xft-pattern-antialias"))
   (xlfd	(lookup-shared-valued "scx-xft-pattern-xlfd"))
   (file	(lookup-shared-valued "scx-xft-pattern-file"))
   (index	(lookup-shared-valued "scx-xft-pattern-index"))
   (rasterizer	(lookup-shared-valued "scx-xft-pattern-rasterizer"))
   (outline	(lookup-shared-valued "scx-xft-pattern-outline"))
   (scalable	(lookup-shared-valued "scx-xft-pattern-scalable"))
   (rgba	(lookup-shared-valued "scx-xft-pattern-rgba"))
   (scale	(lookup-shared-valued "scx-xft-pattern-scale"))
   (render	(lookup-shared-valued "scx-xft-pattern-render"))
   (minspace	(lookup-shared-valued "scx-xft-pattern-minspace"))
   (dpi		(lookup-shared-valued "scx-xft-pattern-dpi"))
   (char-width	(lookup-shared-valued "scx-xft-pattern-char-width"))
   (char-height (lookup-shared-valued "scx-xft-pattern-char-height"))))

(define-finite-type xft-weight :xft-weight
  (id)
  xft-weight?
  xft-weight-elements
  xft-weight-name
  xft-weight-index
  (id xft-weight-id)
  ((light	(lookup-shared-valued "scx-xft-weight-light"))
   (medium	(lookup-shared-valued "scx-xft-weight-medium"))
   (demibold	(lookup-shared-valued "scx-xft-weight-demibold"))
   (bold	(lookup-shared-valued "scx-xft-weight-bold"))
   (black	(lookup-shared-valued "scx-xft-weight-black"))))

(define-finite-type xft-slant :xft-slant
  (id)
  xft-slant?
  xft-slant-elements
  xft-slant-name
  xft-slant-index
  (id xft-slant-id)
  ((roman	(lookup-shared-valued "scx-xft-slant-roman"))
   (italic	(lookup-shared-valued "scx-xft-slant-italic"))
   (oblique	(lookup-shared-valued "scx-xft-slant-oblique"))))

(define-finite-type xft-spacing :xft-spacing
  (id)
  xft-spacing?
  xft-spacing-elements
  xft-spacing-name
  xft-spacing-index
  (id xft-spacing-id)
  ((proportional	(lookup-shared-valued "scx-xft-spacing-proportional"))
   (mono		(lookup-shared-valued "scx-xft-spacing-mono"))
   (charcell		(lookup-shared-valued "scx-xft-spacing-charcell"))))

(define-finite-type xft-rgba :xft-rgba
  (id)
  xft-rgba?
  xft-rgba-elements
  xft-rgba-name
  xft-rgba-index
  (id xft-rgba-id)
  ((none	(lookup-shared-valued "scx-xft-rgba-none"))
   (rgb		(lookup-shared-valued "scx-xft-rgba-rgb"))
   (bgr		(lookup-shared-valued "scx-xft-rgba-bgr"))
   (vrgb	(lookup-shared-valued "scx-xft-rgba-vrgb"))
   (vbgr	(lookup-shared-valued "scx-xft-rgba-vbgr"))))

(define (make-finite-type-alist elements id-proc)
  (map (lambda (e) 
	 (cons (id-proc e) e))
       (vector->list elements)))
       
(define xft-weight-id->xft-weight
  (let ((alist 
	 (make-finite-type-alist xft-weight-elements xft-weight-id)))
    (lambda (id)
      (cond 
       ((assoc id alist) => cdr)
       (else 
	(error "scx: internal error. Could not map weight id to finite type"))))))

(define xft-slant-id->xft-slant
  (let ((alist 
	 (make-finite-type-alist xft-slant-elements xft-slant-id)))
    (lambda (id)
      (cond
       ((assoc id alist) => cdr)
       (else
	(error "scx: internal error. Could not map slant id to finite type"))))))

(define xft-spacing-id->xft-spacing
  (let ((alist 
	 (make-finite-type-alist xft-spacing-elements xft-spacing-id)))
    (lambda (id)
      (cond
       ((assoc id alist) => cdr)
       (else
	(error "scx: internal error. Could not map spacing id to finite type"))))))

(define xft-rgba-id->xft-rgba
  (let ((alist
	 (make-finite-type-alist xft-rgba-elements xft-rgba-id)))
    (lambda (id)
      (cond
       ((assoc id alist) => cdr)
       (else
	(error "scx: internal error. Could not map rgba id to finite type"))))))

;;; add finalizers

(define (make-xft-pattern)
  (let ((xft-pattern (scx-xft-pattern-create)))
    (add-finalizer! xft-pattern scx-xft-pattern-destroy)
    xft-pattern))

(define (scx-xft-pattern-duplicate xft-pattern)
  (let ((copy (scx-xft-pattern-duplicate-internal xft-pattern)))
    (add-finalizer! copy scx-xft-pattern-destroy)
    copy))

(define (scx-xft-pattern-get pattern object id)
  (let ((object-id (xft-pattern-object-id object)))
    (call-with-values
     (lambda ()
       (apply values 
	      (scx-xft-pattern-get-internal pattern object-id id)))
     (lambda (code value)
       (values code
	       (cond
		((not (scx-xft-result-match? code))
		 #f)
		((equal? object (xft-pattern-object weight))
		 (xft-weight-id->xft-weight value))
		((equal? object (xft-pattern-object slant))
		 (xft-slant-id->xft-slant value))
		((equal? object (xft-pattern-object spacing))
		 (xft-spacing-id->xft-spacing value))
		((equal? object (xft-pattern-object rgba))
		 (xft-rgba-id->xft-rgba value))
		(else value)))))))
	   
(define (scx-xft-pattern-add pattern object value append?)
  (let* ((object-id (xft-pattern-object-id object))
	 (call (lambda (value)
		 (scx-xft-pattern-add-internal 
		  pattern object-id value append?))))
    (cond
     ((equal? object (xft-pattern-object weight))
      (call (xft-weight-id value)))
     ((equal? object (xft-pattern-object slant))
      (call (xft-slant-id value)))
     ((equal? object (xft-pattern-object spacing))
      (call (xft-spacing-id value)))
     ((equal? object (xft-pattern-object rgba))
      (call (xft-rgba-id value)))
     (else (call value)))))

(define (scx-xft-font-match display screen xft-pattern)
  (call-with-values
   (lambda ()
     (let ((screen-number (screen:number screen)))
       (scx-xft-font-match-internal display screen-number xft-pattern)))
   (lambda (result xft-pattern)
     (add-finalizer! xft-pattern scx-xft-pattern-destroy)
     (values result xft-pattern))))

(define (scx-xft-font-open-pattern display xft-pattern)
  (let ((xft-font (scx-xft-font-open-pattern-internal display xft-pattern)))
    (add-finalizer! xft-font scx-xft-font-close)
    xft-font))

(define (scx-xft-font-open-name display screen name)
  (let* ((screen-number (screen:number screen))
	 (xft-font (scx-xft-font-open-name-internal display screen-number name)))
    (add-finalizer! xft-font scx-xft-font-close)
    xft-font))

(define (scx-xft-font-open-xlfd display screen name)
  (let* ((screen-numer (screen:number screen))
	 (xft-font (scx-xft-font-open-xlfd-internal display screen-numer name)))
    (add-finalizer! xft-font scx-xft-font-close)
    xft-font))

(define (scx-xft-draw-create display drawable visual colormap)
  (let ((xft-draw (scx-xft-draw-create-internal display drawable visual colormap)))
    (add-finalizer! xft-draw scx-xft-draw-destroy)
    xft-draw))

(define (scx-xft-draw-create-bitmap display drawable)
  (let ((xft-draw (scx-xft-draw-create-bitmap-internal display drawable)))
    (add-finalizer! xft-draw scx-xft-draw-destroy)
    xft-draw))

(define (make-xft-objectset)
  (let ((xft-objectset (scx-xft-objectset-create)))
    (add-finalizer! xft-objectset scx-xft-objectset-destroy)
    xft-objectset))

(define (scx-xft-objectset-add xft-objectset xft-pattern-object)
  (scx-xft-objectset-add-internal 
   xft-objectset (xft-pattern-object-id xft-pattern-object)))

(define (scx-xft-draw-display xft-draw)
  (let ((display (scx-xft-draw-display-internal xft-draw)))
    (if display
	display
	(error "XftDrawDisplay() unavailable in this version of Xft"))))

(define (scx-xft-draw-drawable xft-draw)
  (let ((drawable (scx-xft-draw-drawable-internal xft-draw)))
    (if drawable
	drawable
	(error "XftDrawDrawable() unavailable in this version of Xft"))))

(define (scx-xft-draw-colormap xft-draw)
  (let ((colormap (scx-xft-draw-colormap-internal xft-draw)))
    (if colormap
	colormap
	(error "XftDrawColormap() unavailable in this version of Xft"))))

(define (scx-xft-draw-visual xft-draw)
  (let ((visual (scx-xft-draw-visual-internal xft-draw)))
    (if visual
	visual
	(error "XftDrawVisual() unavailable in this version of Xft"))))

(define (scx-xft-list-fonts-pattern-objects display screen xft-pattern xft-objectset)
  (let* ((screen-number (screen:number screen))
	 (fontset (scx-xft-list-fonts-pattern-objects-internal
		   display screen-number xft-pattern xft-objectset)))
    (add-finalizer! fontset scx-xft-fontset-destroy)
    fontset))

(define (make-xft-fontset)
  (let ((fontset (scx-xft-fontset-create)))
    (set-xft-fontset-patterns! fontset '())
    (add-finalizer! fontset scx-xft-fontset-create)
    fontset))

(define (scx-xft-fontset-add xft-fontset xft-pattern)
  (set-xft-fontset-patterns! 
   xft-fontset (lset-adjoin eq? xft-pattern (xft-fontset-patterns xft-fontset)))
  (scx-xft-fontset-add-internal xft-fontset xft-pattern))

(define (scx-xft-color-alloc-name display visual colormap name)
  (call-with-values
   (lambda ()
     (apply values
	    (scx-xft-color-alloc-name-internal display visual colormap name)))
   (lambda (success? xft-color)
     (if success?
	 (begin
	   (set-xft-color-display! xft-color display)
	   (set-xft-color-visual! xft-color visual)
	   (set-xft-color-colormap! xft-color colormap)
	   (add-finalizer! xft-color xft-color-finalizer)
	   xft-color)
	 ;;; FIXME: raise error
	 #f))))

(define (scx-xft-color-alloc-value display visual colormap xrendercolor)
  (call-with-values
   (lambda () 
     (apply values
	    (scx-xft-color-alloc-value-internal display visual colormap xrendercolor)))
   (lambda (success? xft-color)
     (set-xft-color-display! xft-color display)
     (set-xft-color-visual! xft-color visual)
     (set-xft-color-colormap! xft-color colormap)
     (add-finalizer! xft-color xft-color-finalizer)
     xft-color)))

(define (xft-color-finalizer xft-color)
  (scx-xft-color-free (xft-color-display xft-color)
		      (xft-color-visual xft-color)
		      (xft-color-colormap xft-color)
		      xft-color))

;;; import values from C code
(define scx-xft-version-major
  (shared-binding-ref
   (lookup-imported-binding "scx-xft-version-major")))

(define scx-xft-version-minor
  (shared-binding-ref
   (lookup-imported-binding "scx-xft-version-minor")))

(define scx-xft-result-match?
  (let ((code (shared-binding-ref
	       (lookup-imported-binding "scx-xft-result-match"))))
    (lambda (value)
      (equal? value code))))

(define scx-xft-result-no-match?
  (let ((code (shared-binding-ref
	       (lookup-imported-binding "scx-xft-result-no-match"))))
    (lambda (value)
      (equal? value code))))

(define scx-xft-result-type-mismatch?
  (let ((code (shared-binding-ref
	       (lookup-imported-binding "scx-xft-result-type-mismatch"))))
    (lambda (value)
      (equal? value code))))

(define scx-xft-result-no-id?
  (let ((code (shared-binding-ref
	       (lookup-imported-binding "scx-xft-result-no-id"))))
    (lambda (value)
      (equal? value code))))

;;; import functions from C code

(import-lambda-definition scx-xft-pattern-create 
			  ()
			  "scx_XftPatternCreate")

(import-lambda-definition scx-xft-pattern-destroy
			  ()
			  "scx_XftPatternDestroy")

(import-lambda-definition scx-xft-pattern-duplicate-internal
			  (xft-pattern)
			  "scx_XftPatternDuplicate")

(import-lambda-definition scx-xft-pattern-get-internal
			  (xft-pattern object id)
			  "scx_XftPatternGet")

(import-lambda-definition scx-xft-pattern-add-internal
			  (xft-pattern object value append?)
			  "scx_XftPatternAdd")

(import-lambda-definition scx-xft-font-match-internal
			  (display screen-number xft-pattern)
			  "scx_XftFontMatch")

(import-lambda-definition scx-xft-font-open-pattern-internal
			  (display xft-pattern)
			  "scx_XftFontOpenPattern")

(import-lambda-definition scx-xft-font-open-name-internal
			  (display screen-number name)
			  "scx_XftFontOpenName")

(import-lambda-definition scx-xft-font-open-xlfd-internal
			  (display screen-number xlfd-name)
			  "scx_XftFontOpenXlfd")

(import-lambda-definition scx-xft-font-close
			  (display xft-font)
			  "scx_XftFontClose")

(import-lambda-definition scx-xft-draw-create-internal
			  (display drawable visual colormap)
			  "scx_XftDrawCreate")

(import-lambda-definition scx-xft-draw-create-bitmap-internal
			  (display drawable)
			  "scx_XftDrawCreateBitmap")

(import-lambda-definition scx-xft-draw-change
			  (xft-draw drawable)
			  "scx_XftDrawChange")

(import-lambda-definition scx-xft-draw-display-internal
			  (xft-draw)
			  "scx_XftDrawDisplay")

(import-lambda-definition scx-xft-draw-drawable-internal
			  (xft-draw)
			  "scx_XftDrawDrawable")

(import-lambda-definition scx-xft-draw-colormap-internal
			  (xft-draw)
			  "scx_XftDrawColormap")

(import-lambda-definition scx-xft-draw-visual-internal
			  (xft-draw)
			  "scx_XftDrawVisual")

(import-lambda-definition scx-xft-draw-destroy
			  (xft-draw)
			  "scx_XftDrawDestroy")

(import-lambda-definition scx-xft-text-extents-8bit
			  (display xft-font string)
			  "scx_XftTextExtents8")

(import-lambda-definition scx-xft-draw-string-8bit
			  (xft-draw xft-color xft-font x y string)
			  "scx_XftDrawString8")

(import-lambda-definition scx-xft-draw-rect
			  (xft-draw xft-color x y w h)
			  "scx_XftDrawRect")

(import-lambda-definition scx-xft-draw-set-clip
			  (xft-draw region)
			  "scx_XftDrawSetClip")

(import-lambda-definition scx-xft-objectset-create
			  ()
			  "scx_XftObjectSetCreate")

(import-lambda-definition scx-xft-objectset-destroy
			  (xft-objectset)
			  "scx_XftObjectSetDestroy")

(import-lambda-definition scx-xft-objectset-add-internal
			  (xft-objectset object)
			  "scx_XftObjectSetAdd")

(import-lambda-definition scx-xft-list-fonts-pattern-objects-internal
			  (display screen-number xft-pattern xft-objectset)
			  "scx_XftListFontsPatternObjects")

(import-lambda-definition scx-xft-fontset-create
			  ()
			  "scx_XftFontSetCreate")

(import-lambda-definition scx-xft-fontset-destroy
			  (xft-fontset)
			  "scx_XftFontSetDestroy")

(import-lambda-definition scx-xft-fontset-add-internal
			  (xft-fontset xft-pattern)
			  "scx_XftFontSetAdd")

(import-lambda-definition scx-xft-color-alloc-name-internal
			  (display visual colormap name)
			  "scx_XftColorAllocName")

(import-lambda-definition scx-xft-color-alloc-value-internal
			  (display visual colormap xrendercolor)
			  "scx_XftColorAllocValue")

(import-lambda-definition scx-xft-color-free
			  (display visual colormap xft-color)
			  "scx_XftColorFree")

(import-lambda-definition scx-xft-pattern-print
			  (xft-pattern)
			  "scx_XftPatternPrint")

(import-lambda-definition scx-xft-fontset-print
			  (xft-fontset)
			  "scx_XftFontSetPrint")

(import-lambda-definition scx-xft-default-has-render?
			  (display)
			  "scx_XftDefaultHasRender")