;;; -*-Scheme-*-
;;;
;;; X11 interface

(require 'xlib.o)

;;; High level create window function with keyword arguments

(define-macro (make-window . attr)
  (let ((swa (make-vector (1+ (length set-window-attributes-slots)) ()))
	(parent #f) (x 0) (y 0) (width #f) (height #f) (border 2))
    (vector-set! swa 0 'set-window-attributes)
    (do ((a attr (cdr a))) ((null? a))
      (cond
       ((not (and (pair? (car a)) (= (length (car a)) 2)))
	(error 'make-window "bad argument ~s" (car a)))
       ((memq (caar a) '(parent x y width height border))
	(eval `(set! ,(caar a) (cadar a))))
       (else
	(let ((k (assq (caar a) set-window-attributes-slots)))
	  (if k
	      (eval `(vector-set! swa ,(cdr k) ,(cadar a)))
	      (error 'make-window "unknown attribute: ~s" (car a)))))))
    (if (not (and width height))
	(error 'make-window "you must specify both width and height"))
    (if (not parent)
	(error 'make-window "you must specify a parent window"))
    `(create-window ,parent ,x ,y ,width ,height ,border ,swa)))


;;; High level create gcontext with keyword arguments

(define-macro (make-gcontext . attr)
  (let ((gcv (make-vector (1+ (length gcontext-slots)) ()))
	(win #f))
    (vector-set! gcv 0 'gcontext)
    (do ((a attr (cdr a))) ((null? a))
      (cond
       ((not (and (pair? (car a)) (= (length (car a)) 2)))
	(error 'make-gcontext "bad argument ~s" (car a)))
       ((eq? (caar a) 'window)
	(set! win (cadar a)))
       (else
	(let ((k (assq (caar a) gcontext-slots)))
	  (if k
	      (eval `(vector-set! gcv ,(cdr k) ,(cadar a)))
	      (error 'make-gcontext "unknown attribute: ~s" (car a)))))))
    (if (not win)
	(error 'make-gcontext "you must specify a window"))
    `(create-gcontext ,win ,gcv)))


;;; Definition of the access and update functions for window attributes,
;;; geometry, gcontexts, etc.

(define-macro (define-functions definer type fun pref)
  (let ((slots (string->symbol (format #f "~s-slots" type))))
    `(for-each eval (map (lambda (s)
       (,definer ',type (1+ (length ,slots)) ,fun s ,pref)) ,slots))))

(define (define-accessor-with-cache type num-slots fun slot pref)
  (let ((name (string->symbol (format #f pref (car slot)))))
    `(define (,name object)
       (general-accessor object ',type ,fun ,(cdr slot)))))

(define (define-mutator-with-cache type num-slots fun slot pref)
  (let ((name (string->symbol (format #f pref (car slot)))))
    `(define (,name object val)
       (general-mutator object val ',type ,num-slots ,fun ,(cdr slot)))))

(define (define-accessor type num-slots fun slot pref)
  (let ((name (string->symbol (format #f pref (car slot)))))
    `(define (,name . args)
       (vector-ref (apply ,fun args) ,(cdr slot)))))


(define-functions define-accessor-with-cache
  get-window-attributes get-window-attributes "window-~s")

(define-functions define-mutator-with-cache
  set-window-attributes change-window-attributes "set-window-~s!")

(define-functions define-mutator-with-cache
  window-configuration configure-window "set-window-~s!")

(define-functions define-accessor-with-cache
  geometry get-geometry "drawable-~s")

(define-functions define-mutator-with-cache
  gcontext change-gcontext "set-gcontext-~s!")

(define-functions define-accessor-with-cache
  font-info font-info "font-~s")

(define-functions define-accessor
  char-info char-info "char-~s")

(define (min-char-info c) (char-info c 'min))
(define (max-char-info c) (char-info c 'max))

(define-functions define-accessor
  char-info min-char-info "min-char-~s")

(define-functions define-accessor
  char-info max-char-info "max-char-~s")

(define-functions define-accessor
  char-info text-extents "extents-~s")


;;; ``cache'' is an a-list of (drawable-or-gcontext-or-font . state) pairs,
;;; where state is a vector of buffers as listed below.  Each slot in
;;; a vector can be #f to indicate that the cache is empty.  The cache
;;; is manipulated by the ``with'' macro.

(define cache ())

(put 'set-window-attributes 'cache-slot 0)
(put 'get-window-attributes 'cache-slot 1)
(put 'window-configuration  'cache-slot 2)
(put 'geometry              'cache-slot 3)
(put 'gcontext              'cache-slot 4)
(put 'font-info             'cache-slot 5)


;;; List of buffers that are manipulated by mutator functions and must
;;; be flushed using the associated update function when a ``with'' is
;;; left (e.g., a set-window-attributes buffer is manipulated by
;;; set-window-FOO functions; the buffer is flushed by a call to
;;; (change-window-attributes WINDOW BUFFER)):

(define mutable-types '(set-window-attributes window-configuration gcontext))

(put 'set-window-attributes 'update-function change-window-attributes)
(put 'window-configuration  'update-function configure-window)
(put 'gcontext              'update-function change-gcontext)


;;; Some types of buffers in the cache are invalidated when other
;;; buffers are written to.  For instance, a get-window-attributes
;;; buffer for a window must be filled again when the window's
;;; set-window-attributes or window-configuration buffers have been
;;; written to.

(put 'get-window-attributes 'invalidated-by
     '(set-window-attributes window-configuration))
(put 'geometry              'invalidated-by
     '(set-window-attributes window-configuration))

;;; Within the scope of a ``with'', the first call to a OBJECT-FOO
;;; function causes the result of the corresponding Xlib function to
;;; be retained in the cache; subsequent calls just read from the cache.
;;; Similarly, calls to Xlib functions for set-OBJECT-FOO! functions are
;;; delayed until exit of the ``with'' body or until a OBJECT-FOO
;;; is called and the cached data for this accessor function has been
;;; invalidated by the call to the mutator function (see ``invalidated-by''
;;; property above).

(define-macro (with object . body)
  `(if (assq ,object cache)          ; if it's already in the cache, just
       (begin ,@body)                ;   execute the body.
       (dynamic-wind
	(lambda ()
	  (set! cache (cons (cons ,object (make-vector 6 #f)) cache)))
	(lambda ()
	  ,@body)
	(lambda ()
	  (for-each (lambda (x) (flush-cache (car cache) x)) mutable-types)
	  (set! cache (cdr cache))))))

;;; If a mutator function has been called on an entry in the cache
;;; of the given type, flush it by calling the right update function.

(define (flush-cache entry type)
  (let* ((slot (get type 'cache-slot))
	 (buf (vector-ref (cdr entry) slot)))
    (if buf
	(begin
	  ((get type 'update-function) (car entry) buf)
	  (vector-set! (cdr entry) slot #f)))))

;;; General accessor function (OBJECT-FOO).  See if the data in the
;;; cache have been invalidated.  If this is the case, or if the cache
;;; has not yet been filled, fill it.

(define (general-accessor object type fun slot)
  (let ((v) (entry (assq object cache)))
    (if entry
	(let ((cache-slot (get type 'cache-slot))
	      (inval (get type 'invalidated-by)))
	  (if inval
	      (let ((must-flush #f))
		(for-each
		 (lambda (x)
		   (if (vector-ref (cdr entry) (get x 'cache-slot))
		       (set! must-flush #t)))
		 inval)
		(if must-flush
		    (begin
		      (for-each (lambda (x) (flush-cache entry x)) inval)
		      (vector-set! (cdr entry) cache-slot #f)))))
	  (if (not (vector-ref (cdr entry) cache-slot))
	      (vector-set! (cdr entry) cache-slot (fun object)))
	  (set! v (vector-ref (cdr entry) cache-slot)))
	(set! v (fun object)))
    (vector-ref v slot)))


;;; General mutator function (set-OBJECT-FOO!).  If the cache is empty,
;;; put a new buffer of the given type and size into it.  Write VAL
;;; into the buffer.

(define (general-mutator object val type num-slots fun slot)
  (let ((entry (assq object cache)))
    (if entry
	(let ((cache-slot (get type 'cache-slot)))
	  (if (not (vector-ref (cdr entry) cache-slot))
	      (let ((v (make-vector num-slots ())))
		(vector-set! v 0 type)
		(vector-set! (cdr entry) cache-slot v)
		(vector-set! v slot val))
	      (vector-set! (vector-ref (cdr entry) cache-slot) slot val)))
	(let ((v (make-vector num-slots ())))
	  (vector-set! v 0 type)
	  (vector-set! v slot val)
	  (fun object v)))))