path: root/progs/lib/X11/xlibclx.scm

;;; xlibclx.scm -- Lisp support for Haskell/CLX interface

;; general

(define-syntax (nth-value n form)
  (cond ((eqv? n 0)
	 `(values ,form))
	((number? n)
	 (let ((temps  '()))
	   (dotimes (i n)
	     (declare (ignorable i))
	     (push (gensym) temps))
	   `(multiple-value-bind ,(reverse temps) ,form
	      (declare (ignore ,@(reverse (cdr temps))))
	      ,(car temps))))
	(else
	 `(lisp:nth ,n (lisp:multiple-value-list ,form)))
	))


(define-local-syntax (keywordify string)
  `(lisp:intern ,string (lisp:find-package "KEYWORD")))

(define-local-syntax (xlibify string)
  `(lisp:intern ,string (lisp:find-package "XLIB")))



;;; This is stuff to support slots that consist of a keyword/value
;;; pair.  Note that the value is always unboxed.

(define-syntax (make-keyword key value)
  `(cons ,key ,value))

(define-syntax (is-keyword? x key)
  `(eq? (car ,x) ,key))

(define-syntax (keyword-key x) `(car ,x))
(define-syntax (keyword-val x) `(cdr ,x))

(define-syntax (define-keyword-constructor name)
  (let* ((name-str (symbol->string name))
	 (key      (keywordify name-str))
	 (is-name  (string->symbol (string-append "IS-" name-str)))
	 (mk-name  (string->symbol (string-append "MK-" name-str))))
    `(begin
       (define (,mk-name x) (make-keyword ,key x))
       (define (,is-name x) (is-keyword? x ,key)))
    ))

(define-syntax (define-event-slot-finder slot)
  (let* ((slot-str (symbol->string slot))
	 (slot-key (keywordify slot-str))
	 (fun      (string->symbol (string-append "X-EVENT-" slot-str))))
    `(define (,fun event) (lookup-event-slot (cdr event) ,slot-key))))    
    
(define (lookup-event-slot event key)
  (if (null? event)
      (error "non-existent event slot: ~A" key)
      (if (eq? key (car event))
	  (cadr event)
	  (lookup-event-slot (cddr event) key))))


(define-syntax (define-attribute-setter entity attribute)
  (let* ((entity-attr (string-append (symbol->string entity)
				     "-"
				     (symbol->string attribute)))
	 (fun-name    (string->symbol (string-append "X-SET-" entity-attr)))
	 (xfun-name   (xlibify entity-attr)))
    `(define (,fun-name ,entity ,attribute)
       (setf (,xfun-name ,entity) ,attribute))))

(define-syntax (make-h-tuple . args)
  (let ((nargs (map (lambda (arg) `(box ,arg)) args)))
    `(make-tuple ,@nargs)))

;; type XError

(define (cons-xerror x)
  (declare (ignore x))
  (error "can't construct XError"))

(define (x-error-string c)
  (make-haskell-string (format '#f "~A" c)))


;;; The forces here are necessary because the thing being funcalled
;;; returns a data structure of type (IO a), and we need to do
;;; an  IO a -> a transformation.

#+lucid
(define (x-handle-error handler body)
  (lisp:catch 'x-error-handle
	      (lcl:handler-bind ((lisp:error (mk-handler handler)))
				(force (funcall body (box 'state))))))

#+(or cmu allegro lispworks)
(define (x-handle-error handler body)
  (lisp:catch 'x-error-handle
	      (lisp:handler-bind ((lisp:error (mk-handler handler)))
				 (force (funcall body (box 'state))))))

#+akcl
(define (x-handle-error handler body)
  (error "AKCL does not support HANDLER-BIND!"))

(define (mk-handler handler)
  (lambda (c) 
    (lisp:throw 'x-error-handle 
		(force (funcall handler 
				(box c)
				(box 'state))))))

;; for type XMaybe

(define (not-null? x) (not (null? x)))


;; For Bitmap, Pixarray, KeysymTable

(define (array2->haskell-list a)
  (let* ((dims    (lisp:array-dimensions a))
	 (i1max   (car dims))
	 (i2max   (cadr dims)))
    (declare (type fixnum i1max i2max))
    (do ((i1     (the fixnum (1- i1max)) (the fixnum (1- i1)))
	 (outer  '()))
	((< i1 0) outer)
	(declare (type fixnum i1))
	(setf outer
	      (cons
	        (box
		  (do ((i2    (the fixnum (1- i2max)) (the fixnum (1- i2)))
		       (inner '()))
		      ((< i2 0) inner)
		      (declare (type fixnum i2))
		      (setf inner
			    (cons (box (lisp:aref a i1 i2))
				  (box inner)))))
		(box outer))))
    ))


;; Bitmap

(define (mk-bitmap ll)
  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
    (lisp:make-array `(,(length l) , (length (car l))) 
		     :element-type 'lisp:bit
		     :initial-contents l)))

(define (sel-bitmap l)
  (array2->haskell-list l))


;; XKeysymTable

(define (mk-keysym-table ll)
  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
    (lisp:make-array `(,(length l) , (length (car l))) 
		     :element-type 'xlib:card32
		     :initial-contents l)))

(define (sel-keysym-table l)
  (array2->haskell-list l))

;; XPixarray

(define (mk-pixarray ll)
  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
    (let* ((max-num  (find-max l))
	   (pix-type (cond ((<= max-num 1) 'lisp:bit)
			   ((<= max-num 15) '(lisp:unsigned-byte 4))
			   ((<= max-num 255) 'xlib:card8)
			   ((<= max-num 65535) 'xlib:card16)
			   (else 'xlib:card32))))
      (declare (type integer max-num))
      (lisp:make-array `(,(length l) , (length (car l)))
		       :element-type pix-type
		       :initial-contents l))))

(define (find-max l)
  (let ((max  0))
    (dolist (ll l)
      (dolist (lll ll)
	(when (> (the integer lll) (the integer max))
	  (setf max lll))))
    max))

(define (sel-pixarray l)
  (array2->haskell-list l))




;;; Can't use mumble vector primitives on arrays of specialized types!

(define (array1->haskell-list a)
  (declare (type lisp:vector a))
  (let ((imax  (lisp:length a)))
    (declare (type fixnum imax))
    (do ((i      (the fixnum (1- imax)) (the fixnum (1- i)))
	 (result '()))
	((< i 0) result)
	(declare (type fixnum i))
	(setf result
	      (cons (box (lisp:aref a i))
		    (box result))))))

;; BitVec

(define (mk-bitvec ll)
  (let ((l (haskell-list->list/identity ll)))
    (lisp:make-array `(,(length l)) :element-type 'lisp:bit
		     :initial-contents l)))

(define (sel-bitvec l)
  (array1->haskell-list l))

;; ByteVec

(define (mk-bytevec ll)
  (let ((l (haskell-list->list/identity ll)))
    (lisp:make-array `(,(length l)) :element-type 'xlib:card8
		     :initial-contents l)))

(define (sel-bytevec l)
  (array1->haskell-list l))


;; XAtom
(define (mk-atom name)
  (keywordify (haskell-string->string name)))

(define (sel-atom atom)
  (make-haskell-string (symbol->string atom)))

;; XProperty
;;; watch out for name conflict with :property keyword stuff
(define (mk-xproperty d ty f) (list (haskell-list->list/identity d) ty f))
(define (sel-xproperty-data p) (list->haskell-list/identity (car p)))
(define (sel-xproperty-type p) (cadr p))
(define (sel-xproperty-format p) (caddr p))

(define (mk-event type slots)
  (cons type (slots->keywords (haskell-list->list/identity slots))))

(define (sel-event-type event) (car event))

(define (sel-event-slots event) 
  (list->haskell-list/identity (keywords->slots (car event) (cdr event) event)))

;; XEventSlot

(define-keyword-constructor window)
(define-keyword-constructor event-window)
(define-keyword-constructor code)
(define-keyword-constructor pos)
(define-keyword-constructor state)
(define-keyword-constructor time)
(define-keyword-constructor root)
(define-keyword-constructor root-pos)
(define-keyword-constructor child)
(define-keyword-constructor same-screen-p)
(define-keyword-constructor hint-p)
(define-keyword-constructor mode)
(define-keyword-constructor kind)
(define-keyword-constructor focus-p)
(define-keyword-constructor keymap)
(define-keyword-constructor request)
(define-keyword-constructor start)
(define-keyword-constructor count)
(define-keyword-constructor rect)
(define-keyword-constructor drawable)
(define-keyword-constructor graph-fun)
(define-keyword-constructor place)
(define-keyword-constructor border-width)
(define-keyword-constructor above-sibling)
(define-keyword-constructor override-redirect-p)
(define-keyword-constructor parent)
(define-keyword-constructor configure-p)
(define-keyword-constructor visibility)
(define-keyword-constructor new-p)
(define-keyword-constructor installed-p)
(define-keyword-constructor stack-mode)
(define-keyword-constructor value-mask)
(define-keyword-constructor size)
(define-keyword-constructor message)
(define-keyword-constructor property-state)
(define-keyword-constructor atom)
(define-keyword-constructor selection)
(define-keyword-constructor target)
(define-keyword-constructor property)
(define-keyword-constructor requestor)

(define-event-slot-finder window)
(define-event-slot-finder event-window)
(define-event-slot-finder code)
(define-event-slot-finder x)
(define-event-slot-finder y)
(define-event-slot-finder state)
(define-event-slot-finder time)
(define-event-slot-finder root)
(define-event-slot-finder root-x)
(define-event-slot-finder root-y)
(define-event-slot-finder child)
(define-event-slot-finder same-screen-p)
(define-event-slot-finder hint-p)
(define-event-slot-finder mode)
(define-event-slot-finder kind)
(define-event-slot-finder focus-p)
(define-event-slot-finder keymap)
(define-event-slot-finder request)
(define-event-slot-finder start)
(define-event-slot-finder count)
(define-event-slot-finder width)
(define-event-slot-finder height)
(define-event-slot-finder drawable)
(define-event-slot-finder major)
(define-event-slot-finder minor)
(define-event-slot-finder place)
(define-event-slot-finder border-width)
(define-event-slot-finder above-sibling)
(define-event-slot-finder override-redirect-p)
(define-event-slot-finder parent)
(define-event-slot-finder configure-p)
(define-event-slot-finder new-p)
(define-event-slot-finder installed-p)
(define-event-slot-finder stack-mode)
(define-event-slot-finder value-mask)
(define-event-slot-finder data)
(define-event-slot-finder type)
(define-event-slot-finder format)
(define-event-slot-finder atom)
(define-event-slot-finder selection)
(define-event-slot-finder target)
(define-event-slot-finder property)
(define-event-slot-finder requestor)

(define (x-event-pos event) (mk-xpoint (x-event-x event) (x-event-y event)))

(define (x-event-root-pos event) 
  (mk-xpoint (x-event-root-x event) (x-event-root-y event)))

(define (x-event-size event) 
  (mk-xsize (x-event-width event) (x-event-height event)))

(define (x-event-rect event) 
  (mk-xrect (x-event-x event) (x-event-y event)
	    (x-event-width event) (x-event-height event)))

(define (x-event-graph-fun event)
  (cons (x-event-major event) (x-event-minor event)))

(define (x-event-message event)
  (list (sequence->list (x-event-data event))
	(x-event-type event)
	(x-event-format event)))


;; XEventMask

(define (x-make-event-mask keys)
  (apply (function xlib:make-event-mask) (haskell-list->list/identity keys)))

(define (x-event-mask-key-list mask)
  (list->haskell-list/identity (xlib:make-event-keys mask)))

;; XStateMask

(define (x-make-state-mask keys)
  (apply (function xlib:make-state-mask) (haskell-list->list/identity keys)))

(define (x-state-mask-key-list mask)
  (list->haskell-list/identity (xlib:make-state-keys mask)))


(define-keyword-constructor background)
(define-keyword-constructor foreground)
(define-keyword-constructor event-mask)
(define-keyword-constructor depth)
(define-keyword-constructor border-width)
(define-keyword-constructor class)
(define-keyword-constructor visual)
(define-keyword-constructor border)
(define-keyword-constructor backing-store)
(define-keyword-constructor backing-planes)
(define-keyword-constructor backing-pixel)
(define-keyword-constructor save-under)
(define-keyword-constructor do-not-propagate-mask)
(define-keyword-constructor override-redirect)
(define-keyword-constructor colormap)
(define-keyword-constructor cursor)

(define-keyword-constructor arc-mode)
(define-keyword-constructor cap-style)
(define-keyword-constructor clip-mask)
(define-keyword-constructor clip-origin)
(define-keyword-constructor dash-offset)
(define-keyword-constructor dashes)
(define-keyword-constructor exposures)
(define-keyword-constructor fill-rule)
(define-keyword-constructor fill-style)
(define-keyword-constructor font)
(define-keyword-constructor function)
(define-keyword-constructor join-style)
(define-keyword-constructor line-style)
(define-keyword-constructor line-width)
(define-keyword-constructor plane-mask)
(define-keyword-constructor stipple)
(define-keyword-constructor subwindow-mode)
(define-keyword-constructor tile)
(define-keyword-constructor tile-origin)

(define-keyword-constructor bit-lsb-first-p)
(define-keyword-constructor bits-per-pixel)
(define-keyword-constructor blue-mask)
(define-keyword-constructor byte-lsb-first-p)
(define-keyword-constructor bytes-per-line)
(define-keyword-constructor data)
(define-keyword-constructor format)
(define-keyword-constructor green-mask)
(define-keyword-constructor size)
(define-keyword-constructor name)
(define-keyword-constructor red-mask)
(define-keyword-constructor hot-spot)


(define-keyword-constructor owner-p)
(define-keyword-constructor sync-pointer-p)
(define-keyword-constructor sync-keyboard-p)
(define-keyword-constructor confine-to)


;; XClipMask

(define (not-pixmap-and-list-p x) 
  (and (pair? x) (not (xlib:pixmap-p x))))
(define (mk-clip-mask-rects rects) 
  (rects->point-seq (haskell-list->list/identity rects)))
(define (sel-clip-mask-rects point-seq) 
  (list->haskell-list/identity (point-seq->rects point-seq)))

;; XPoint

(define (mk-xpoint x y) (cons x y))
(define (xpoint-x x) (car x))
(define (xpoint-y x) (cdr x))

;; XSize

(define (mk-xsize x y) (cons x y))
(define (xsize-w x) (car x))
(define (xsize-h x) (cdr x))

;; XRect
(define (mk-xrect x y w h) (vector x y w h))
(define (xrect-x x) (vector-ref x 0))
(define (xrect-y x) (vector-ref x 1))
(define (xrect-w x) (vector-ref x 2))
(define (xrect-h x) (vector-ref x 3))

;; XArc

(define (mk-xarc x y w h a1 a2) (vector x y w h a1 a2))

(define (xarc-x x) (vector-ref x 0))
(define (xarc-y x) (vector-ref x 1))
(define (xarc-w x) (vector-ref x 2))
(define (xarc-h x) (vector-ref x 3))
(define (xarc-a1 x) (vector-ref x 4))
(define (xarc-a2 x) (vector-ref x 5))

;; BitmapFormat

(define (mk-bitmap-format u p l) 
  (xlib::make-bitmap-format :unit u :pad p :lsb-first-p l))

;; PixmapFormat

(define (mk-pixmap-format u p l) 
  (xlib::make-pixmap-format :depth u :bits-per-pixel p :scanline-pad l))

;; XVisualInfo

(define (mk-xvisual-info id cl rm gm bm bs es) 
  (xlib::make-visual-info :id id :class cl :red-mask rm :green-mask gm 
			  :blue-mask bm :bits-per-rgb bs :colormap-entries es))

;; XFillContent

(define (is-fill-pixel x) (not (or (xlib:pixmap-p x) (symbol? x))))

;; XBackingStore

;; XImageData

(define (bitmap-list-p x) (pair? x))
(define (pixarray-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 2)))
(define (bytevec-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 1)))

;; XColor
(define (mk-color r g b) 
  (xlib:make-color :red r :green g :blue b))


(define (x-print x)
  (print x))

(define (x-set-event-mask-key mask key-sym) 
  (lisp:logior mask (xlib:make-event-mask key-sym)))

(define (x-clear-event-mask-key mask key-sym) 
  (lisp:logand mask (lisp:lognot (xlib:make-event-mask key-sym))))


(define (x-test-event-mask-key mask key-sym)
  (if (eqv? 0 (lisp:logand mask (xlib:make-event-mask key-sym))) '#f '#t))

(define (x-set-state-mask-key mask key-sym) 
  (lisp:logior mask (xlib:make-state-mask key-sym)))

(define (x-clear-state-mask-key mask key-sym) 
  (lisp:logand mask (lisp:lognot (xlib:make-state-mask key-sym))))

(define (x-test-state-mask-key mask key-sym)
  (if (eqv? 0 (lisp:logand mask (xlib:make-state-mask key-sym))) '#f '#t))


;;; Display is a string of the format name:d.s
;;; ignore s; if d is omitted, default it to zero.

(define (x-open-display display)
  (let* ((end    (string-length display))
	 (colon  (or (string-position #\: display 0 end) end))
	 (dot    (or (string-position #\. display colon end) end)))
    (declare (type fixnum end colon dot))
    (xlib:open-display
      (substring display 0 colon)
      :display (if (eqv? colon dot)
		   0
		   (string->number (substring display (1+ colon) dot))))))

(define (x-set-display-error-handler display error-fun)
  (declare (ignore display error-fun))
  (error "not implemented"))

(define (x-set-display-after-function display after-fun)
  (declare (ignore display after-fun))
  (error "not implemented"))

(define (x-screen-depths screen)
  (let ((depths (xlib:screen-depths screen)))
    (map (lambda (l) (make-h-tuple (car l) (list->haskell-list/identity (cdr l))))
	 depths)))

(define (x-screen-size screen)
  (mk-xsize (xlib:screen-width screen) (xlib:screen-height screen)))

(define (x-screen-mmsize screen)
  (mk-xsize (xlib:screen-width-in-millimeters screen) 
	    (xlib:screen-height-in-millimeters screen)))

(define (x-create-window parent rect attrs)
  (apply (function XLIB:CREATE-WINDOW)
	 `(:parent ,parent :x ,(xrect-x rect) :y ,(xrect-y rect)
	   :width ,(xrect-w rect) :height ,(xrect-h rect)
	   ,@(attrs->keywords attrs))))

(define-attribute-setter drawable border-width)

(define (x-drawable-size drawable)
  (mk-xsize (xlib:drawable-width drawable) (xlib:drawable-height drawable)))

(define (x-drawable-resize drawable size)
  (setf (xlib:drawable-width drawable) (xsize-w size))
  (setf (xlib:drawable-height drawable) (xsize-h size)))

(define (x-window-pos window)
  (mk-xpoint (xlib:drawable-x window) (xlib:drawable-y window)))

(define (x-window-move window point)
  (setf (xlib:drawable-x window) (xpoint-x point))
  (setf (xlib:drawable-y window) (xpoint-y point)))

(define-attribute-setter window background)
(define-attribute-setter window backing-pixel)
(define-attribute-setter window backing-planes)
(define-attribute-setter window backing-store)
(define-attribute-setter window bit-gravity)
(define-attribute-setter window border)
(define-attribute-setter window colormap)

(define (x-set-window-cursor window cursor)
  (let ((val (if (null? cursor) :none cursor)))
    (setf (xlib:window-cursor window) val)))

(define-attribute-setter window do-not-propagate-mask)
(define-attribute-setter window event-mask)
(define-attribute-setter window gravity)
(define-attribute-setter window override-redirect)
(define-attribute-setter window priority)
(define-attribute-setter window save-under)

(define (x-query-tree window)
  (multiple-value-bind (children parent root)
		       (xlib:query-tree window)
     (make-h-tuple (list->haskell-list/identity children) parent root)))

(define (x-reparent-window window parent point)
  (xlib:reparent-window window parent (xpoint-x point) (xpoint-y point)))

(define (x-translate-coordinates source point dest)
  (xlib:translate-coordinates source (xpoint-x point) (xpoint-y point) dest))

(define (x-create-pixmap size depth drawable)
  (xlib:create-pixmap :width (xsize-w size)
		      :height (xsize-h size)
		      :depth depth
		      :drawable drawable))

(define (x-create-gcontext drawable attrs)
  (apply (function XLIB:CREATE-GCONTEXT)
	 `(:drawable ,drawable ,@(attrs->keywords attrs))))

(define (x-update-gcontext gcontext attrs)
  (do ((keys (attrs->keywords attrs) (cddr keys)))
      ((null? keys))
    (x-update-gcontext-attr gcontext (car keys) (cadr keys))))

(define (x-update-gcontext-attr gcontext key attr)
  (case key
    (:arc-mode (setf (xlib:gcontext-arc-mode gcontext) attr))
    (:background (setf (xlib:gcontext-background gcontext) attr))
    (:cap-style (setf (xlib:gcontext-cap-style gcontext) attr))
    (:fill-style (setf (xlib:gcontext-fill-style gcontext) attr))
    (:clip-mask (setf (xlib:gcontext-clip-mask gcontext) attr))
    (:clip-x (setf (xlib:gcontext-clip-x gcontext) attr))
    (:clip-y (setf (xlib:gcontext-clip-y gcontext) attr))
    (:dash-offset (setf (xlib:gcontext-dash-offset gcontext) attr))
    (:dashes (setf (xlib:gcontext-dashes gcontext) attr))
    (:exposures (setf (xlib:gcontext-exposures gcontext) attr))
    (:fill-rule (setf (xlib:gcontext-fill-rule gcontext) attr))
    (:font (setf (xlib:gcontext-font gcontext) attr))
    (:foreground (setf (xlib:gcontext-foreground gcontext) attr))
;    (:function (setf (xlib:gcontext-function gcontext) attr))
    (:join-style (setf (xlib:gcontext-join-style gcontext) attr))
    (:line-style (setf (xlib:gcontext-line-style gcontext) attr))
;    (:line-width (setf (xlib:gcontext-line-width gcontext) attr))
;    (:plane-mask (setf (xlib:gcontext-plane-mask gcontext) attr))
;    (:stipple (setf (xlib:gcontext-stipple gcontext) attr))
    (:subwindow-mode (setf (xlib:gcontext-subwindow-mode gcontext) attr))
;    (:tile (setf (xlib:gcontext-tile gcontext) attr))
;    (:ts-x (setf (xlib:gcontext-ts-x gcontext) attr))
;    (:ts-y (setf (xlib:gcontext-ts-y gcontext) attr))
    (else (format '#t "Graphics context attribute ~A is not settable.~%"
		  key))))

(define (x-query-best-stipple dsize drawable)
  (multiple-value-bind (w h) 
        (xlib:query-best-stipple (xsize-w dsize) (xsize-h dsize) drawable)
     (mk-xsize w h)))

(define (x-query-best-tile dsize drawable)
  (multiple-value-bind (w h) 
        (xlib:query-best-tile (xsize-w dsize) (xsize-h dsize) drawable)
     (mk-xsize w h)))

(define (x-clear-area window rect exposures-p)
  (xlib:clear-area window 
		   :x (xrect-x rect)
		   :y (xrect-y rect)
		   :width (xrect-w rect)
		   :height (xrect-h rect)
		   :exposures-p exposures-p))

(define (x-copy-area src gcontext rect dest point)
  (xlib:copy-area src 
		  gcontext 
		  (xrect-x rect) (xrect-y rect) 
		  (xrect-w rect) (xrect-h rect) 
		  dest 
		  (xpoint-x point) (xpoint-y point)))

(define (x-copy-plane src gcontext plane rect dest point)
  (xlib:copy-plane src 
		   gcontext 
		   plane 
		   (xrect-x rect) (xrect-y rect) 
		   (xrect-w rect) (xrect-h rect) 
		   dest 
		   (xpoint-x point) (xpoint-y point)))

(define (x-draw-point drawable gcontext point)
  (xlib:draw-point drawable gcontext (xpoint-x point) (xpoint-y point)))

(define (x-draw-points drawable gcontext points)
  (xlib:draw-points drawable gcontext (points->point-seq points)))

(define (points->point-seq points)
  (if (null? points)
      '()
      (let ((point (car points)))
	(lisp:list* (xpoint-x point)
		    (xpoint-y point)
		    (points->point-seq (cdr points))))))

(define (segments->point-seq segments)
  (if (null? segments)
      '()
      (let* ((first-pair (car segments))
	     (point-1 (force (tuple-select 2 0 first-pair)))
	     (point-2 (force (tuple-select 2 1 first-pair))))
	(lisp:list* (xpoint-x point-1)
		    (xpoint-y point-1) 
		    (xpoint-x point-2)
		    (xpoint-y point-2) 
		    (segments->point-seq (cdr segments))))))

(define (rects->point-seq rects)
  (if (null? rects)
      '()
      (let ((rect (car rects)))
	(lisp:list* (xrect-x rect)
		    (xrect-y rect)
		    (xrect-w rect)
		    (xrect-h rect)
		    (rects->point-seq (cdr rects))))))

(define (point-seq->rects point-seq)
  (if (null? point-seq)
      '()
      (cons (mk-xrect (car point-seq) (cadr point-seq) 
		      (caddr point-seq) (cadddr point-seq))
	    (point-seq->rects (cddddr point-seq)))))

(define (arcs->point-seq arcs)
  (if (null? arcs)
      '()
      (let ((arc (car arcs)))
	(lisp:list* (xarc-x arc)
		    (xarc-y arc)
		    (xarc-w arc)
		    (xarc-h arc)
		    (xarc-a1 arc)
		    (xarc-a2 arc)
		    (arcs->point-seq (cdr arcs))))))

(define (x-draw-line drawable gcontext point-1 point-2)
  (xlib:draw-line drawable gcontext (xpoint-x point-1) (xpoint-y point-1)
		  (xpoint-x point-2) (xpoint-y point-2)))

(define (x-draw-lines drawable gcontext points fill-p)
  (xlib:draw-lines drawable gcontext 
		   (points->point-seq points) :fill-p fill-p))

(define (x-draw-segments drawable gcontext segments)
  (xlib:draw-segments drawable gcontext (segments->point-seq segments)))

(define (x-draw-rectangle drawable gcontext rect fill-p)
  (xlib:draw-rectangle drawable gcontext
		       (xrect-x rect) (xrect-y rect) 
		       (xrect-w rect) (xrect-h rect)
		       fill-p))

(define (x-draw-rectangles drawable gcontext rects fill-p)
  (xlib:draw-rectangles drawable gcontext
			(rects->point-seq rects)
			fill-p))

(define (x-draw-arc drawable gcontext arc fill-p)
  (xlib:draw-arc drawable gcontext
		 (xarc-x arc) (xarc-y arc) 
		 (xarc-w arc) (xarc-h arc)
		 (xarc-a1 arc) (xarc-a2 arc)
		 fill-p))

(define (x-draw-arcs drawable gcontext arcs fill-p)
  (xlib:draw-arcs drawable gcontext
		  (arcs->point-seq arcs)
		  fill-p))

(define (x-draw-glyph drawable gcontext point element)
  (nth-value 1
	     (xlib:draw-glyph drawable gcontext (xpoint-x point) 
			      (xpoint-y point) element)))

(define (x-draw-glyphs drawable gcontext point element)
  (nth-value 1 (xlib:draw-glyphs drawable gcontext (xpoint-x point) 
				 (xpoint-y point) element)))

(define (x-draw-image-glyph drawable gcontext point element)
  (nth-value 1 (xlib:draw-image-glyph drawable gcontext (xpoint-x point) 
				      (xpoint-y point) element)))

(define (x-draw-image-glyphs drawable gcontext point element)
  (nth-value 1 (xlib:draw-image-glyphs drawable gcontext (xpoint-x point) 
				       (xpoint-y point) element)))

(define (x-image-size image)
  (mk-xsize (xlib:image-width image) (xlib:image-height image)))

(define (x-image-name image)
  (let ((lisp-name (xlib:image-name image)))
    (cond ((null? lisp-name) "")
	  ((symbol? lisp-name) (symbol->string lisp-name))
	  (else lisp-name))))
    
(define-attribute-setter image name)

(define (x-image-hot-spot image)
  (mk-xpoint (xlib:image-x-hot image) (xlib:image-y-hot image)))

(define (x-set-image-hot-spot image point)
  (setf (xlib:image-x-hot image) (xpoint-x point))
  (setf (xlib:image-y-hot image) (xpoint-y point)))

(define-attribute-setter image xy-bitmap-list)
(define-attribute-setter image z-bits-per-pixel)
(define-attribute-setter image z-pixarray)

(define (x-create-image attrs)
  (apply (function xlib:create-image) (attrs->keywords attrs)))

(define (x-copy-image image rect type)
  (xlib:copy-image image :x (xrect-x rect) :y (xrect-y rect)
		   :width (xrect-w rect) :height (xrect-h rect)
		   :result-type type))

(define (x-get-image drawable rect pmask format type)
  (xlib:get-image drawable :x (xrect-x rect) :y (xrect-y rect)
		  :width (xrect-w rect) :height (xrect-h rect)
		  :plane-mask pmask :format format :result-type type))

(define (x-put-image drawable gcontext image point rect)
  (xlib:put-image drawable gcontext image 
		  :src-x (xpoint-x point) :src-y (xpoint-y point)
		  :x (xrect-x rect) :y (xrect-y rect)
		  :width (xrect-w rect) :height (xrect-h rect)))

(define (x-get-raw-image drawable rect pmask format)
  (xlib:get-raw-image drawable 
		      :x (xrect-x rect) :y (xrect-y rect) 
		      :width (xrect-w rect) :height (xrect-h rect)
		      :plane-mask pmask :format format))

(define (x-put-raw-image drawable gcontext data depth rect left-pad format)
  (xlib:put-raw-image drawable gcontext data
		      :depth depth 
		      :x (xrect-x rect) :y (xrect-y rect) 
		      :width (xrect-w rect) :height (xrect-h rect)
		      :left-pad left-pad :format format))

(define (x-font-name font)
  (let ((lisp-name (xlib:font-name font)))
    (cond ((null? lisp-name) "")
	  ((symbol? lisp-name) (symbol->string lisp-name))
	  (else lisp-name))))

(define (x-alloc-color colormap color)
  (multiple-value-bind (pixel screen-color exact-color)
       (xlib:alloc-color colormap color)
     (make-h-tuple pixel screen-color exact-color)))

(define (x-alloc-color-cells colormap colors planes contiguous-p)
  (multiple-value-bind (pixels mask)
       (xlib:alloc-color-cells colormap colors :planes planes 
			       :contiguous-p contiguous-p)
     (make-h-tuple (list->haskell-list/identity pixels) (list->haskell-list/identity mask))))

(define (x-alloc-color-planes colormap colors reds greens blues contiguous-p)
  (multiple-value-bind (pixels red-mask green-mask blue-mask)
       (xlib:alloc-color-planes colormap colors :reds reds :greens greens
				:blues blues :contiguous-p contiguous-p)
     (make-h-tuple (list->haskell-list/identity pixels) 
		   red-mask
		   green-mask
		   blue-mask)))

(define (x-lookup-color colormap name)
  (multiple-value-bind (screen-color exact-color)
      (xlib:lookup-color colormap name)
    (make-h-tuple screen-color exact-color)))

(define (unzip l)
  (if (null? l)
      '()
      (let ((h (car l)))
	(lisp:list* (force (tuple-select 2 0 h))
		    (force (tuple-select 2 1 h))
		    (unzip (cdr l))))))

(define (x-store-colors colormap pixel-colors)
  (xlib:store-colors colormap (unzip pixel-colors)))

(define (x-create-cursor source mask point foreground background)
  (apply (function xlib:create-cursor)
	 `(:source ,source
	   ,@(if mask `(:mask ,mask) '())
	   :x ,(xpoint-x point) :y ,(xpoint-y point)
	   :foreground ,foreground :background ,background)))

(define (x-create-glyph-cursor src mask foreground background)
  (apply (function xlib:create-glyph-cursor)
	 `(:source-font ,(force (tuple-select 2 0 src))
	   :source-char ,(integer->char (force (tuple-select 2 1 src)))
	   ,@(if mask 
		 `(:mask-font ,(force (tuple-select 2 0 mask))
		 :mask-char ,(integer->char (force (tuple-select 2 1 mask))))
		 '())
	   :foreground ,foreground :background ,background)))

(define (x-query-best-cursor size display)
  (multiple-value-bind (w h)
      (xlib:query-best-cursor (xsize-w size) (xsize-h size) display)
    (mk-xsize w h)))

(define (x-change-property window property content)
  (xlib:change-property window property 
			(car content) (cadr content) 
			(caddr content)))

(define (x-get-property window property)
  (lisp:multiple-value-bind (data type format) 
			    (xlib:get-property window property)
	 (list (sequence->list data) type format)))

(define (x-convert-selection selection type requestor property time)
  (apply (function xlib:convert-selection)
	 `(,selection ,type ,requestor ,property ,@(if time `(,time) '()))))

(define (x-set-selection-owner display selection time owner)
  (if time
      (setf (xlib:selection-owner display selection time) owner)
      (setf (xlib:selection-owner display selection) owner)))

(define (sequence->list seq)
  (if (list? seq) seq
      (do ((i (1- (lisp:length seq)) (1- i))
	   (res '() (cons (lisp:elt seq i) res)))
	  ((< i 0) res))))

(define *this-event* '())

(define (translate-event lisp:&rest event-slots lisp:&key event-key 
			 lisp:&allow-other-keys)
  (setf *this-event* (cons event-key event-slots))
  '#t)


(define (x-get-event display)
  (xlib:process-event display :handler #'translate-event :force-output-p '#t)
  *this-event*)

(define (x-queue-event display event append-p)
  (apply (function xlib:queue-event)
	 `(,display ,(car event) ,@(cdr event) :append-p ,append-p)))

(define (x-event-listen display)
  (let ((res (xlib:event-listen display)))
    (if (null? res) 0 res)))

(define (x-send-event window event mask)
  (apply (function xlib:send-event)
	 `(,window ,(car event) ,mask ,@(cdr event))))

(define (x-global-pointer-position display)
  (multiple-value-bind (x y) (xlib:global-pointer-position display)
    (mk-xpoint x y)))

(define (x-pointer-position window)
  (multiple-value-bind (x y same) (xlib:pointer-position window)
    (if same (mk-xpoint x y) '())))

(define (x-motion-events window start stop)
  (do ((npos '() (cons (mk-xpoint (car pos) (cadr pos)) npos))
       (pos (xlib:motion-events window :start start :stop stop) 
	    (cdddr pos)))
      ((null? pos) (nreverse npos))))

(define (x-warp-pointer dest-win point)
  (xlib:warp-pointer dest-win (xpoint-x point) (xpoint-y point)))

(define (x-set-input-focus display focus revert-to time)
  (apply (function xlib:set-input-focus)
	 `(,display ,focus ,revert-to ,@(if time `(,time) '()))))

(define (x-input-focus display)
  (multiple-value-bind (focus revert-to) (xlib:input-focus display)
    (make-h-tuple focus revert-to)))

(define (x-grab-pointer window event-mask attrs time)
  (apply (function xlib:grab-pointer)
	 `(,window ,event-mask
           ,@(attrs->keywords attrs)
	   ,@(if time `(:time ,time) '()))))

(define (x-ungrab-pointer display time)
  (if time
      (xlib:ungrab-pointer display :time time)
      (xlib:ungrab-pointer display)))
      
(define (x-change-active-pointer-grab display event-mask attrs time)
  (apply (function xlib:change-active-pointer-grab)
	 `(,display ,event-mask
           ,@(attrs->keywords attrs)
	   ,@(if time `(,time) '()))))

(define (x-grab-button window button event-mask state-mask attrs)
  (apply (function xlib:grab-button)
	 `(,window ,button ,event-mask :modifiers ,state-mask
	   ,@(attrs->keywords attrs))))

(define (x-ungrab-button window button modifiers)
  (xlib:ungrab-button window button :modifiers modifiers))

(define (x-grab-keyboard window attrs time)
  (apply (function xlib:grab-keyboard)
	 `(,window ,@(attrs->keywords attrs)
	   ,@(if time `(:time ,time) '()))))

(define (x-ungrab-keyboard display time)
  (if time
      (xlib:ungrab-keyboard display :time time)
      (xlib:ungrab-keyboard display)))
      
(define (x-grab-key window key state-mask attrs)
  (apply (function xlib:grab-key)
	 `(,window ,key :modifiers ,state-mask ,@(attrs->keywords attrs))))

(define (x-ungrab-key window key modifiers)
  (xlib:ungrab-button window key :modifiers modifiers))

(define (x-set-pointer-acceleration display val)
  (xlib:change-pointer-control display :acceleration val))

(define (x-set-pointer-threshold display val)
  (xlib:change-pointer-control display :threshold val))

(define (x-pointer-acceleration display)
  (lisp:coerce (nth-value 0 (xlib:pointer-control display)) 
	       'lisp:single-float))

(define (x-pointer-threshold display)
  (lisp:coerce (nth-value 1 (xlib:pointer-control display)) 
	       'lisp:single-float))

(define-attribute-setter pointer mapping)

(define (x-set-keyboard-key-click-percent display v)
  (xlib:change-keyboard-control display :key-click-percent v))

(define (x-set-keyboard-bell-percent display v)
  (xlib:change-keyboard-control display :bell-percent v))

(define (x-set-keyboard-bell-pitch display v)
  (xlib:change-keyboard-control display :bell-pitch v))

(define (x-set-keyboard-bell-duration display v)
  (xlib:change-keyboard-control display :bell-duration v))


;;; Yes, leds are really counted from 1 rather than 0.

(define (x-set-keyboard-led display v)
  (declare (type integer v))
  (do ((led 1 (1+ led))
       (vv v (lisp:ash vv -1)))
      ((> led 32))
      (declare (type fixnum led) (type integer vv))
      (xlib:change-keyboard-control display
        :led led
	:led-mode (if (lisp:logand vv 1) :on :off))))

(define (x-set-keyboard-auto-repeat-mode display v)
  (do ((key 0 (1+ key)))
      ((>= key (lisp:length v)))
      (declare (type fixnum key))
      (xlib:change-keyboard-control display
        :key key
	:auto-repeat-mode (if (eqv? (the fixnum (lisp:aref v key)) 1) :on :off)
	)))

(define (x-keyboard-key-click-percent display)
  (nth-value 0 (xlib:keyboard-control display)))

(define (x-keyboard-bell-percent display)
  (nth-value 1 (xlib:keyboard-control display)))

(define (x-keyboard-bell-pitch display)
  (nth-value 2 (xlib:keyboard-control display)))

(define (x-keyboard-bell-duration display)
  (nth-value 3 (xlib:keyboard-control display)))

(define (x-keyboard-led display)
  (nth-value 4 (xlib:keyboard-control display)))

(define (x-keyboard-auto-repeat-mode display)
  (nth-value 6 (xlib:keyboard-control display)))

(define (x-modifier-mapping display)
  (lisp:multiple-value-list (xlib:modifier-mapping display)))

(define (x-set-modifier-mapping display l)
  (let ((l1 (cddddr l)))
    (xlib:set-modifier-mapping display 
			       :shift (car l)
			       :lock (cadr l)
			       :control (caddr l)
			       :mod1 (cadddr l)
			       :mod2 (car l1)
			       :mod3 (cadr l1)
			       :mod4 (caddr l1)
			       :mod5 (cadddr l1))))

(define (x-keysym-character display keysym state)
  (let ((res (xlib:keysym->character display keysym state)))
    (if (char? res) (char->integer res) '())))

(define (x-keycode-character display keycode state)
  (let ((res (xlib:keycode->character display keycode state)))
    (if (char? res) (char->integer res) '())))

(define-attribute-setter close-down mode)

(define-attribute-setter access control)

(define (x-screen-saver display)
  (lisp:multiple-value-list (xlib:screen-saver display)))

(define (x-set-screen-saver display ss)
  (xlib:set-screen-saver display (car ss) (cadr ss) (caddr ss) (cadddr ss)))

(define (slots->keywords slots)
  (if (null slots) '()
      `(,@(slot->keyword (car slots)) ,@(slots->keywords (cdr slots)))))

(define (slot->keyword slot)
  (let* ((tag (keyword-key slot))
	 (val (keyword-val slot)))
    (case tag
      (:pos `(:x ,(xpoint-x val) :y ,(xpoint-y val)))
      (:root-pos `(:root-x ,(xpoint-x val) :root-y ,(xpoint-y val)))
      (:size `(:width ,(xsize-w val) :height ,(xsize-h val)))
      (:rect `(:x ,(xrect-x val) :y ,(xrect-y val)
	       :width ,(xrect-w val) :height ,(xrect-h val)))
      (:graph-fun `(:major ,(car val) :minor ,(cdr val)))
      (:visibility `(:state ,val))
      (:property-state `(:state ,val))
      (:message `(:data ,(car val) :type ,(cadr val) :format ,(caddr val)))
      (else `(,tag ,val)))))

(define (keywords->slots type keywords event)
  (let* ((slots (keywords->slots1 type keywords))
	 (has-root-xy (memq type '(:key-press :key-release :button-press 
					      :button-release :motion-notify 
					      :enter-notify :leave-notify)))
	 (has-xy (or has-root-xy 
		     (memq type '(:gravity-notify :reparent-notify))))
	 (has-graph-fun (memq type '(:graphics-exposure :no-exposure)))
	 (has-rect (memq type '(:exposure :graphics-exposure 
					  :configure-notify
					  :create-notify :configure-request)))
	 (has-size (memq type '(:resize-request)))
	 (has-message (memq type '(:client-message))))
    (when has-xy
      (push (make-keyword :pos (x-event-pos event)) slots))
    (when has-root-xy
      (push (make-keyword :root-pos (x-event-root-pos event))	slots))
    (when has-graph-fun
      (push (make-keyword :graph-fun (x-event-graph-fun event)) slots))
    (when has-rect
      (push (make-keyword :rect (x-event-rect event))	slots))
    (when has-size
      (push (make-keyword :size (x-event-size event))	slots))
    (when has-message
      (push (make-keyword :message (x-event-message event)) slots))
    slots))
      
(define (keywords->slots1 type keywords)
  (if (null? keywords)
      '()
      (if (memq (car keywords) 
		'(:x :y :width :height :root-x :root-y 
		     :major :minor :type :data :format))
	  (keywords->slots1 type (cddr keywords))
	  (cons (keyword->slot type (car keywords) (cadr keywords))
		(keywords->slots1 type (cddr keywords))))))

(define (keyword->slot type slot val)
  (if (eq? slot :state)
      (case type
	(:property-state (make-keyword :property-state val))
	(:visibility (make-keyword :visibility val))
	(else (make-keyword :state val)))
      (make-keyword slot val)))
		 
(define (attrs->keywords attrs)
  (if (null attrs)
      '()
      (nconc (attr->keyword (car attrs))
	     (attrs->keywords (cdr attrs)))))

(define (attr->keyword attr)
  (let* ((tag (keyword-key attr))
	 (val (keyword-val attr)))
    (case tag
      (:clip-origin `(:clip-x ,(xpoint-x val) :clip-y ,(xpoint-y val)))
      (:dashes `(,tag ,(haskell-list->list/identity val)))
      (:tile-origin `(:ts-x ,(xpoint-x val) :ts-y ,(xpoint-y val)))
      (:size `(:width ,(xsize-w val) :height ,(xsize-h val)))
      (:name `(:name ,(haskell-string->string val)))
      (:hot-spot `(:x-hot ,(xpoint-x val) :y-hot ,(xpoint-y val)))
      (else `(,tag ,val)))))

(define (x-mutable-array-create inits)
  (list->vector inits))

(define (x-mutable-array-lookup a i)
  (vector-ref a i))

(define (x-mutable-array-update a i x)
  (setf (vector-ref a i) x))

(define (x-mutable-array-length a)
  (vector-length a))

(define (get-time-zone)
  (nth-value 8 (lisp:get-decoded-time)))

(define (decode-time time zone)
  (multiple-value-bind (sec min hour date mon year week ds-p)
		       (if zone
			   (lisp:decode-universal-time time zone)
			   (lisp:decode-universal-time time))   
    (make-h-tuple
      (list->haskell-list/identity (list sec min hour date mon year week))
      ds-p)))

(define (encode-time time zone)
  (apply (function lisp:encode-universal-time)
	 (if (null? zone) time (append time (list zone)))))

(define (get-run-time)
  (/ (lisp:coerce (lisp:get-internal-run-time) 'lisp:single-float)
     (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float)))

(define (get-elapsed-time)
  (/ (lisp:coerce (lisp:get-internal-real-time) 'lisp:single-float)
     (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float)))

(define (prim.thenio---1 x fn)
  (lambda (state)
    (declare (ignore state))
    (let ((res (funcall x (box 'state))))
      (format '#t "~A~%" res)
      (funcall fn res (box 'state)))))

(define-attribute-setter wm name)
(define-attribute-setter wm icon-name)