Celestin Apprentice 2/Apprentice-Release2.iso/Tools/Languages/MacHaskell 2.2/progs/lib/X11/xlibclx.scm

Text File | 1994-09-27 | 38.9 KB | 1,227 lines | [TEXT/CCL2]

;;; 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)))


;; 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)