;;; x-umbrages.scm

;; Copyright (C) 2007, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Code:

(define-module (ttn-do zzz x-umbrages)
  #:export (n<-window-class
            n<-gx
            n<-event-mask
            n-from-enum
            n<-color-name
            string-split-on-null
            data
            connection atom-manager
            change-property!-proc
            set-icccm-properties!
            associate-font!
            drawing
            pixel-width-proc
            press-ESC-to-quit!)
  #:use-module ((srfi srfi-1) #:select (remove))
  #:use-module ((srfi srfi-13) #:select (substring/shared))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  whatever
                                                  FE fs))
  #:use-module ((ttn-do zzz x-protocol)
                #:prefix zx #:select (-connect
                                      -simple-io-manager
                                      -synchronous-request-proc
                                      -x
                                      -internal-data
                                      -event-type
                                      -event-data
                                      -disconnect))
  #:use-module ((ice-9 and-let-star) #:select (and-let*))
  #:use-module ((ttn-do mogrify) #:select (find-file-read-only
                                           editing-buffer)))

;; k

(define ENUMS (zx-internal-data 'ENUMS))

;; Return a procedure @var{p} that maps a symbol in the enum @var{name}
;; to an integer value (or @code{#f} if that symbol is not recognized).
;; Various @var{options} configure the procedure:
;;
;; @table @code
;; @item (omit @var{key}@dots{})
;; Omit the specified keys (symbols) from the lookup table.
;;
;; @item mask
;; Construct the lookup table taking the enum's values as bit positions
;; (e.g., for original value 3, the table holds 8, or @code{(ash 1 3)}).
;; Additionally, arrange for @var{p} to accept either a single symbol,
;; or a list of symbols, in which case the integer values are combined
;; with @code{logior}.
;; @end table
;;
(define (n-from-enum name . options)
  (let ((table (hash-ref ENUMS name))
        (ref (whatever)))
    (and=> (sloppy-assq 'omit options)
           (lambda (omit)
             (let ((sorry (cdr omit)))
               (set! options (delq! omit options))
               (set! table (remove (lambda (pair)
                                     (memq (car pair) sorry))
                                   table)))))
    (and (memq 'mask options)
         (set! table (map (lambda (pair)
                            (cons (car pair) (ash 1 (cdr pair))))
                          table)))
    ;; Perhaps this heuristic can be exposed as an option later.
    (set! ref (if (< 10 (length table))
                  (let ((h (make-hash-table 5)))
                    (FE (map car table)
                        (map cdr table)
                        (lambda (symbol number)
                          (hashq-set! h symbol number)))
                    (lambda (symbol)
                      (hashq-ref h symbol)))
                  (lambda (symbol)
                    (assq-ref table symbol))))
    (and (memq 'mask options)
         (let ((one ref))
           (set! options (delq! 'mask options))
           (set! ref (lambda (x)
                       (if (symbol? x)
                           (one x)
                           (apply logior (map one x)))))))
    (or (null? options) (error "unknown options:" options))
    ref))

(define n<-window-class (n-from-enum 'WindowClass))
(define n<-gx           (n-from-enum 'GX))
(define n<-event-mask   (n-from-enum 'EventMask 'mask '(omit NoEvent)))

;; Look up color @var{name} in the standard color database file
;; @file{/etc/X11/rgb.txt} and return its RGB value (integer), or
;; @code{#f} if @var{name} cannot be found.  If @var{name} is a list of
;; names, likewise return a list of values (some of which may be
;; @code{#f}).  Each @var{name} must match exactly; no case or other
;; conversion is done.  For example:
;;
;; @example
;; (n<-color-name "sky blue") @result{} 49151
;; (n<-color-name "SkyBlue") @result{} 49151
;; (n<-color-name "Sky Blue") @result{} #f
;; (n<-color-name '("red" "rad")) @result{} (13458524 #f)
;; @end example
;;
;; Optional arg @var{color-db-filename} specifies an alternative
;; database.  It should be a plain text file with lines of the form:
;; @example
;;  R  G  B     NAME
;; @end example
;; @noindent
;; where @var{r}, @var{g}, @var{b} are decimal integers in the range
;; 0 to 255, and fields are separated by at least one whitespace character.
;;
;;-args: (- 1 0)
;;
(define (n<-color-name name . color-db-filename)
  (editing-buffer (find-file-read-only (if (null? color-db-filename)
                                           "/etc/X11/rgb.txt"
                                           (car color-db-filename)))
    (let ((p (buffer-port)))
      (define (one name)
        (goto-char (point-min))
        (and (search-forward name #f #t)
             (let ((n 0))
               (beginning-of-line)
               (FE '(16 8 0) (lambda (shift)
                               (set! n (logior n (ash (read p) shift)))))
               n)))
      (if (pair? name)
          (map one name)
          (one name)))))

;; Return a list of new shared-substrings made by splitting @var{string}
;; on (and subsequently discarding the) @samp{#\nul} bytes.  Unlike
;; @code{string-tokenize}, however, this does not squash consecutive
;; @samp{#\nul} bytes; the resulting list may contain empty strings.
;; @xref{SRFI-13 Miscellaneous,,,guile}.
;;
(define (string-split-on-null string)
  (let* ((ls (accumulator))
         (len (string-length string)))
    (let loop ((beg 0))
      (or (<= len beg)
          (let ((end (or (string-index string #\nul beg) len)))
            (ls (substring/shared string beg end))
            (loop (1+ end)))))
    (ls)))

;; Return constant data table @var{name} (a symbol), one of:
;;
;; @table @code
;; @item icccm-size-hints-offsets
;; Alist with symbolic keys: @code{flags}, @code{min-width},
;; @code{min-height}, @code{max-width}, @code{max-height}, @code{width-inc},
;; @code{height-inc}, @code{min-aspect-x}, @code{min-aspect-y},
;; @code{max-aspect-x}, @code{max-aspect-y}, @code{base-width},
;; @code{base-height}, @code{gravity}.
;;
;; @item icccm-size-hints-flags-mask
;; Alist with symbolic keys: @code{min-size}, @code{max-size},
;; @code{resize-inc}, @code{aspect}, @code{base-size}, @code{gravity}.
;; The values are masks.
;; @end table
;;
;; If no such data table @var{name} exists, return @code{#f}.
;;
(define (data name)
  (case name
    ((icccm-size-hints-offsets)
     '((flags        . 0)
       (min-width    . 5)
       (min-height   . 6)
       (max-width    . 7)
       (max-height   . 8)
       (width-inc    . 9)
       (height-inc   . 10)
       (min-aspect-x . 11)
       (min-aspect-y . 12)
       (max-aspect-x . 13)
       (max-aspect-y . 14)
       (base-width   . 15)
       (base-height  . 16)
       (gravity      . 17)))
    ((icccm-size-hints-flags-mask)
     '((min-size   . 16)
       (max-size   . 32)
       (resize-inc . 64)
       (aspect     . 128)
       (base-size  . 256)
       (gravity    . 512)))
    (else #f)))

;; Return a procedure that handles a connection
;; to the server specified by the env var @code{DISPLAY}.
;; If @code{DISPLAY} is not set, signal error.
;; If connection fails, do @code{(exit #f)}.
;; The procedure takes a single keyword arg, one of:
;;
;; @table @code
;; @item #:fdes
;; Return the file descriptor of the connection.  This is intended for
;; testing with @code{select} rather than for direct i/o, which would
;; confuse things.  @xref{Ports and File Descriptors,,,guile}.
;;
;; @item #:setup
;; Return the ``setup'' part of the ``connection object'' as
;; returned by @code{-connect}, an alist.
;;
;; @item #:extensions
;; Return a list of available extension names (symbols).
;;
;; @item #:q
;; Return the proc returned by @code{-synchronous-request-proc},
;; configured to take @code{keyword-style} arguments.
;;
;; @item #:io
;; Return the proc returned by @code{-simple-io-manager},
;; likewise configured to take @code{keyword-style} arguments.
;;
;; @item #:xid-manager
;; Return a procedure @var{p} that manages XIDs and type-specific
;; resources for the connection.  @var{p} takes one arg, which
;; determines its behavior:
;;
;; @table @asis
;; @item @var{type} (symbol)
;; Return a newly allocated XID internally associated with @var{type}.
;; If no more XIDs are available, throw @code{no-more-xid} with the
;; connection's resource-id base and mask (both integers) as args.
;;
;; Valid types are: @code{colormap}, @code{cursor}, @code{font},
;; @code{gc}, @code{pixmap}, @code{window}.
;;
;; @item @var{xid} (integer)
;; Free the type-specific resources (if any) associated with @var{xid},
;; and make @var{xid} available for subsequent allocation.
;; @end table
;;
;; @item #:bye
;; Do a @code{-disconnect}, and @code{exit} with its return value.
;; @end table
;;
(define (connection)
  (or (getenv "DISPLAY")
      (error "env var DISPLAY not set"))
  (let* ((conn (or (zx-connect (getenv "DISPLAY"))
                   (exit #f)))
         (setup (vector-ref conn 1))
         (q (zx-synchronous-request-proc conn 'keyword-style))
         (io (zx-simple-io-manager conn 'keyword-style))
         (returned-imgr #f))

    (define (xid-manager)
      (let* ((base (zx-x 'resource-id-base setup))
             (mask (zx-x 'resource-id-mask setup))
             (max (+ base mask))
             (ht (make-hash-table 17))
             (cur (1+ base)))

        (define (alloc! type)
          (define (ok! xid)
            (hashq-set! ht xid type)
            xid)
          (if cur (let ((rv (ok! cur)))
                    (set! cur (1+ cur))
                    (and (zero? (logand cur mask))
                         (set! cur #f))
                    rv)
              ;; No more easy pickings; scan for holes.
              (let loop ((xid base))
                (cond ((< max xid)        (throw 'no-more-xid base mask))
                      ((hashq-ref ht xid) (loop (1+ xid)))
                      (else               (ok! xid))))))

        (define (free! xid)
          (case (hashq-ref ht xid)
            ((colormap) (q 'FreeColormap #:cmap xid))
            ;;((colors) (q 'FreeColors #:TODO TODO))
            ((cursor)   (q 'FreeCursor #:cursor xid))
            ((font)     (q 'CloseFont #:font xid))
            ((gc)       (q 'FreeGC #:gc xid))
            ((pixmap)   (q 'FreePixmap #:pixmap xid)))
          ;; Special case handling for the usage pattern alloc-use-free:
          ;; Bump back ‘cur’ to postpone need for scanning.
          (and cur (= (1- xid) cur)
               (set! cur xid))
          (hashq-set! ht xid #f))

        (lambda (x)
          ((cond ((symbol? x) alloc!)
                 ((integer? x) free!)
                 (else (error "not a symbol or integer:" x)))
           x))))

    ;; rv
    (lambda (x)
      (case x
        ((#:fdes) (fileno (vector-ref conn 0)))
        ((#:setup) setup)
        ((#:extensions) (vector-ref conn 2))
        ((#:q) q)
        ((#:io) io)
        ((#:xid-manager)
         ;; Make the rv one-shot; the idea is that clients who don't need
         ;; it don't have to pay for the internal state, but clients that
         ;; do need it only want one (per connection) and not a new one.
         (or returned-imgr (set! returned-imgr (xid-manager)))
         returned-imgr)
        ((#:bye) (let ((rv (zx-disconnect conn)))
                   (set! conn #f)
                   (set! q #f)
                   (set! io #f)
                   (exit rv)))))))

;; Return a procedure that handles numeric/symbolic atom conversion
;; (including caching) for @var{conn}, the object returned by
;; @code{connection}.  The procedure takes a keyword and an argument:
;;
;; @table @code
;; @item #:symbolic @var{atom}
;; Return the symbolic name associated with @var{atom}, an integer,
;; or @code{#f} if no such atom exists on the server.
;; @strong{NB}: A name may have embedded @samp{#\space} or other
;; non-@samp{#\nul} bytes.
;;
;; @item #:numeric @var{symbol}
;; @itemx #:numeric! @var{symbol}
;; Return the atom (non-zero integer) value associated with @var{symbol}.
;; The first form may return @code{#f} if no such atom is defined on the
;; server.  The second form will always return non-@code{#f}.
;;
;; @item #:intern! @var{symbols}
;; Intern @var{symbols} (list of symbols) as atoms in the server.  The
;; effect is the same as using @code{#:numeric!} on each individual
;; symbol, but the implementation is more efficient.
;; @end table
;;
(define (atom-manager conn)
  (let ((io (conn #:io))
        (q (conn #:q))
        (syms (make-hash-table 31))
        (nums (make-hash-table 11)))

    (define (symbolic atom)
      (or (hashq-ref syms atom)
          (and=> (zx-x 'name (q 'GetAtomName #:atom atom))
                 (lambda (string)
                   (hashq-set! syms atom (string->symbol string))))))

    (define (numeric symbol only-if-exists)
      (or (hashq-ref nums symbol)
          (and-let* ((n (zx-x 'atom (q 'InternAtom
                                       #:name (symbol->string symbol)
                                       #:only-if-exists only-if-exists)))
                     ((not (zero? n))))
            (hashq-set! nums symbol n))))

    (define (intern! list)
      (let ((cookies (map (lambda (symbol)
                            (io 'InternAtom
                                #:name (symbol->string symbol)
                                #:only-if-exists 0))
                          list)))
        (io #:flush!)
        (FE cookies io)))

    (lambda (x arg)
      (case x
        ((#:symbolic) (symbolic arg))
        ((#:numeric)  (numeric arg 1))
        ((#:numeric!) (numeric arg 0))
        ((#:intern!)  (intern! arg))))))

;; Return a procedure @var{p} that can change a property on a window via
;; @code{((@var{conn} #:io) 'ChangeProperty ...)}.  Procedure @var{p}
;; takes five arguments:
;;
;; @table @var
;; @item mode
;; A symbol @code{Append}, @code{Prepend} or @code{Replace},
;; or the numeric (integer) value of an @code{PropMode} enum.
;;
;; @item xwid
;; The xid of the window where the change is to occur.
;;
;; @item property
;; @itemx type
;; Symbols representing atoms, or numeric (integer) values.
;;
;; @item v
;; The value, either a string or a uniform vector with elements
;; of size 1, 2 or 4 bytes (aka format 8, 16, 32, respectively).
;; @end table
;;
(define (change-property!-proc conn)
  (let* ((n<-prop-mode (n-from-enum 'PropMode))
         (amgr (atom-manager conn))
         (io (conn #:io)))
    (define (numeric x)
      (if (symbol? x)
          (amgr #:numeric x)
          x))
    (lambda (mode xwid property type v)
      (io 'ChangeProperty
          #:mode (if (symbol? mode)
                     (n<-prop-mode mode)
                     mode)
          #:window xwid
          #:property (numeric property)
          #:type (numeric type)
          #:data v))))

;; Set @sc{icccm} properties (via @var{conn}) for window @var{xwid}.
;; @var{plist} consists of alternating symbols (representing property
;; names), and the values for these properties.  Valid properties
;; and their expected associated values are:
;;
;; @table @code
;; @item WM_NAME
;; @itemx WM_ICON_NAME
;; @itemx WM_CLIENT_MACHINE
;; A string.
;;
;; @item WM_NORMAL_HINTS
;; A sub-plist with possible keys:
;;
;; @table @code
;; @item min-size
;; @itemx max-size
;; @itemx resize-inc
;; @itemx base-size
;; A pair of non-negative integers.  For @code{resize-inc},
;; the integers should additionally be positive (non-zero).
;; The @sc{car} specifies the width, the @sc{cdr} the height.
;;
;; @item aspect
;; A pair of pairs of integers.  For the top-level pair, the @sc{car} is
;; the minimum aspect ratio, the @sc{cdr} the maximum aspect ratio.  For
;; each aspect ratio (pair), the @sc{car} specifies the x component, the
;; @sc{cdr} the y component.
;;
;; @item gravity
;; A symbol, one of: @code{BitForget}, @code{NorthWest}, @code{North},
;; @code{NorthEast}, @code{West}, @code{Center}, @code{East},
;; @code{SouthWest}, @code{South}, @code{SouthEast}, @code{Static}.
;; @end table
;;
;; @item WM_HINTS
;; A sub-plist with possible keys:
;;
;; @table @code
;; @item input
;; @itemx urgency
;; A boolean.
;;
;; @item initial-state
;; A symbol, one of: @code{withdrawn}, @code{normal}, @code{iconic}.
;;
;; @item icon-pixmap
;; @itemx icon-mask
;; A pixmap XID.
;;
;; @item icon-window
;; @itemx window-group
;; A window XID.
;;
;; @item icon-position
;; A pair of integers.  The @sc{car} specifies the x component, the
;; @sc{cdr} the y component.
;; @end table
;;
;; @item WM_CLASS
;; A pair of strings representing the
;; instance and class names, respectively.
;;
;; @item WM_TRANSIENT_FOR
;; A window XID (integer).
;;
;; @item WM_PROTOCOLS
;; An atom (symbolic or numeric) or a list of them.  Note that, unlike
;; the atoms used to represent properties (and internally, their types),
;; the value atoms are not automatically interned; that is the caller's
;; responsibility.
;;
;; @item WM_COLORMAP_WINDOWS
;; A window XID.
;; @end table
;;
;; For unrecognized keys or malformed values, signal ``bad property'',
;; ``bad size-hints key'', ``bad wm-hints key'', or other errors as
;; appropriate.
;;
(define (set-icccm-properties! conn xwid . plist)

  (define (size-hints . specs)
    (let ((offsets (data 'icccm-size-hints-offsets))
          (flags-mask (data 'icccm-size-hints-flags-mask))
          (uve (make-uniform-vector 18 1 0))
          (flags 0))
      (define (u! name value)
        (uniform-vector-set! uve (assq-ref offsets name) value))
      (define (pair! n0 n1 pair)
        (u! n0 (car pair))
        (u! n1 (cdr pair)))
      (let loop ((ls specs))
        (or (null? ls)
            (let ((k (car ls))
                  (v (cadr ls)))
              (set! flags (logior flags (or (assq-ref flags-mask k)
                                            (error "bad size-hints key:" k))))
              (case k
                ((min-size) (pair! 'min-width 'min-height v))
                ((max-size) (pair! 'max-width 'max-height v))
                ((resize-inc) (pair! 'width-inc 'height-inc v))
                ((aspect)
                 (pair! 'min-aspect-x 'min-aspect-y (car v))
                 (pair! 'max-aspect-x 'max-aspect-y (cdr v)))
                ((base-size) (pair! 'base-width 'base-height v))
                ((gravity)
                 (u! 'gravity ((n-from-enum 'Gravity '(omit WinUnmap)) v))))
              (loop (cddr ls)))))
      (u! 'flags flags)
      uve))

  (define (wm-hints . specs)
    ;; These can be moved to ‘data’ later if there is interest.
    (let ((+wm-hints-members+ '(flags input initial-state
                                      icon-pixmap icon-window
                                      icon-x icon-y icon-mask
                                      window-group))
          (+wm-hints-flag-masks+ '((input . 1)
                                   (initial-state . 2)
                                   (icon-pixmap . 4)
                                   (icon-window . 8)
                                   (icon-position . 16)
                                   (icon-mask . 32)
                                   (window-group . 64)
                                   ;; OBSOLETE: (message . 128)
                                   (urgency . 256)))
          (uve (make-uniform-vector 9 -1 0))
          (flags 0))
      (define (u! name value)
        (uniform-vector-set! uve (list-index +wm-hints-members+ name) value))
      (define (pair! n0 n1 pair)
        (u! n0 (car pair))
        (u! n1 (cdr pair)))
      (let loop ((ls specs))
        (or (null? ls)
            (let* ((k (car ls))
                   (v (cadr ls))
                   (kmask (or (assq-ref +wm-hints-flag-masks+ k)
                              (error "bad wm-hints key:" k))))
              (set! flags (logior flags kmask))
              (case k
                ((input) (u! k (if v 1 0)))
                ((initial-state)
                 (u! k (list-index '(withdrawn normal withdrawn iconic) v)))
                ((icon-pixmap icon-window icon-mask window-group)
                 (u! k v))
                ((icon-position) (pair! 'icon-x 'icon-y v))
                ((urgency) (or v (set! flags (logxor flags kmask)))))
              (loop (cddr ls)))))
      (u! 'flags flags)
      uve))

  (define (class-str<-pair pair)
    (fs "~A~A~A~A" (car pair) #\nul (cdr pair) #\nul))

  (define (ensure-uve-1 x)
    (if (pair? x)
        (list->uniform-vector 1 x)
        (make-uniform-vector 1 1 x)))

  (let ((amgr (atom-manager conn))
        (ch! (change-property!-proc conn))
        (types '((WM_NAME             . STRING)
                 (WM_ICON_NAME        . STRING)
                 (WM_NORMAL_HINTS     . WM_SIZE_HINTS)
                 (WM_HINTS            . WM_HINTS)
                 (WM_CLASS            . STRING)
                 (WM_TRANSIENT_FOR    . WINDOW)
                 (WM_PROTOCOLS        . ATOM)
                 (WM_COLORMAP_WINDOWS . WINDOW)
                 (WM_CLIENT_MACHINE   . STRING))))

    (define (atoms-uve x)
      (ensure-uve-1
       (map (lambda (one)
              (if (symbol? one)
                  (amgr #:numeric one)
                  one))
            (if (pair? x)
                x
                (list x)))))

    ;; Make sure properties and types are interned.
    (amgr #:intern! (append! (map car types) (map cdr types)))
    (let loop ((ls plist))
      (if (pair? ls)
          (let ((property (car ls))
                (value (cadr ls)))
            (ch! 'Replace xwid property (or (assq-ref types property)
                                            (error "bad property:" property))
                 (case property
                   ((WM_NORMAL_HINTS)     (apply size-hints value))
                   ((WM_HINTS)            (apply wm-hints   value))
                   ((WM_CLASS)            (class-str<-pair  value))
                   ((WM_PROTOCOLS)        (atoms-uve        value))
                   ((WM_COLORMAP_WINDOWS) (ensure-uve-1     value))
                   (else                                    value)))
            (loop (cddr ls)))
          ((conn #:io) #:flush!)))))

;; Associate (via @var{conn}) font @var{xfid} with drawable @var{did}
;; and graphic context @var{gcid}.  This means that @var{xfid} will
;; be used for subsequent text drawing operations.
;;
(define (associate-font! conn did gcid xfid)
  ((conn #:io) 'PolyText8               ; ‘PolyText16’ also works
   #:drawable did #:gc gcid
   #:items (apply string
                  (map integer->char
                       (list 255
                             (logand #xff (ash xfid -24))
                             (logand #xff (ash xfid -16))
                             (logand #xff (ash xfid  -8))
                             (logand #xff (ash xfid   0)))))))

;; Return a procedure that handles drawing manipulations for
;; @code{conn}, the object returned by @code{connection}.
;; The procedure takes a keyword arg followed by zero or more data args.
;; The keyword and data should be one of:
;;
;; @table @code
;; @item #:screen-w
;; @itemx #:screen-h
;; Return the ``screen width'' or ``screen height'', respectively.
;;
;; @item #:root-wid
;; Return the ID of the root window.
;;
;; @item #:open-font @var{name}
;; Open the font @var{name} (a string).  If successful, return
;; information on the font as an alist, with additional key @code{xfid}
;; whose value is the font id, an integer.  If @var{name} cannot be
;; opened, return an alist that includes key @code{%error-name},
;; suitable for passing to an error handler.
;;
;; @item #:create-gc @var{did} @var{plist}
;; Create a new graphics context on drawable @var{did} (an integer),
;; with the ``value-list'' specified by @var{plist}.  Return the
;; graphics context id, an integer.
;;
;; @item #:create-window @var{keyword-args}@dots{}
;; @itemx #:create-pixmap @var{keyword-args}@dots{}
;; @itemx #:create-cursor @var{keyword-args}@dots{}
;; Create a new window, pixmap or cursor, respectively, configured with
;; @var{keyword-args}, a series of alternating keywords and values.
;; Return the id (integer) of the window, pixmap or cursor, respectively.
;;
;; @item #:create-glyph-cursor @var{sfont} @var{mfont} @var{keyword-args}@dots{}
;; Create a new cursor based on the source and mask fonts @var{sfont}
;; and @var{mfont} (both font XIDs).  Return the id (integer) of the cursor.
;; Note that unlike @code{#create-cursor}, which uses the X protocol request
;; @code{CreateCursor}, this uses @code{CreateGlyphCursor} instead.
;;
;; @item #:drop @var{xid}@dots{}
;; For each @var{xid}, free the type-specific resources (if any)
;; associated with @var{xid}, and make @var{xid} available for
;; subsequent allocation.
;; @end table
;;
(define (drawing conn)
  (let* ((q        (conn #:q))
         (io       (conn #:io))
         (setup    (conn #:setup))
         (xid-mgr  (conn #:xid-manager))
         (screen   (zx-x '(roots 0)        setup))
         (screen-w (zx-x 'width-in-pixels  screen))
         (screen-h (zx-x 'height-in-pixels screen))
         (root-wid (zx-x 'root             screen)))

    (define (open-font name)
      (let* ((xfid (xid-mgr 'font))
             (info (begin (io 'OpenFont #:fid xfid #:name name)
                          (q 'QueryFont #:font xfid))))
        (case (caar info)
          ((%error-name) (xid-mgr xfid) info)
          (else `((xfid . ,xfid) ,@info)))))

    (define (create-gc did plist)
      (let ((cid (xid-mgr 'gc)))
        (q 'CreateGC
           #:drawable did
           #:cid cid
           #:value-list plist)
        cid))

    (define (create-window . plist)
      (let ((wid (xid-mgr 'window)))
        (apply q 'CreateWindow #:wid wid plist)
        wid))

    (define (create-pixmap . plist)
      (let ((pid (xid-mgr 'pixmap)))
        (apply q 'CreatePixmap #:pid pid plist)
        pid))

    (define (create-cursor . plist)
      (let ((cid (xid-mgr 'cursor)))
        (apply q 'CreateCursor #:cid cid plist)
        cid))

    (define (create-glyph-cursor sfont mfont . plist)
      (let ((cid (xid-mgr 'cursor)))
        (apply q 'CreateGlyphCursor #:cid cid
               #:source-font sfont
               #:mask-font mfont
               plist)
        cid))

    (lambda (x . args)
      (case x
        ((#:screen-w) screen-w)
        ((#:screen-h) screen-h)
        ((#:root-wid) root-wid)
        ((#:open-font) (open-font (car args)))
        ((#:create-gc) (create-gc (car args) (cadr args)))
        ((#:create-window) (apply create-window args))
        ((#:create-pixmap) (apply create-pixmap args))
        ((#:create-cursor) (apply create-cursor args))
        ((#:create-glyph-cursor) (apply create-glyph-cursor args))
        ((#:drop) (FE args xid-mgr))))))

;; Return a procedure that calculates the pixel-width of a
;; string based on @var{font-info} (an alist).  For example:
;;
;; @example
;; (define CONN (connection))
;; (define DMGR (drawing CONN))
;; (define FONT-INFO (DMGR #:open-font "10x20"))
;; (define pixel-width (pixel-width-proc FONT-INFO))
;;
;; (pixel-width "hello world") @result{} 110
;; @end example
;;
(define (pixel-width-proc font-info)
  (define (fi: x)
    (zx-x x font-info))
  (or
   ;; monospace
   (let ((maxw (fi: '(max-bounds character-width))))
     (and (= maxw (fi: '(min-bounds character-width)))
          ;; rv
          (lambda (s)
            (* maxw (string-length s)))))
   ;; variable
   (let* ((c-info (fi: 'char-infos))
          (char-widths (make-uniform-vector (vector-length c-info) #\nul)))
     (array-index-map!
      char-widths (lambda (i)
                    (zx-x (list i 'character-width) c-info)))
     ;; rv
     (lambda (s)
       (apply + (map (lambda (c)
                       (uniform-vector-ref char-widths (char->integer c)))
                     (string->list s)))))))

;; @emph{WARNING: HIGHLY EXPERIMENTAL!}
;;
;; Arrange to do @code{(@var{conn} #:bye)} if the @kbd{ESC} key is
;; pressed.  Normally, other events are ignored.  Optional second arg
;; @var{meh}, however, is a procedure to be passed those events, instead
;; (each in the form of an alist).
;;
;; This uses @code{((@var{conn} #:io) #:set-external-event-queue! ...)}
;; internally.
;;
;;-args: (- 1 0)
;;
(define (press-ESC-to-quit! conn . meh)
  ((conn #:io) #:set-external-event-queue!
   (lambda (ev)
     (and (eq? (zx-event-type ev) 'KeyPress)
          (= 9 (assq-ref (zx-event-data ev) 'detail))
          (conn #:bye))
     (or (null? meh)
         ((car meh) ev)))))

;;; x-umbrages.scm ends here