;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; -*-

;; CLX utilities

;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 2909
;;;			       AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

;;; Created 04/09/87 14:30:41 by LaMott G. OREN

(in-package :xlib)

(export '(display-root
	  display-black
	  display-white
	  report-events
	  describe-window
	  describe-gc
	  degree
	  radian
	  display-refresh
	  root-tree
	  window-tree))

(defun display-root (display) (screen-root (display-default-screen display)))
(defun display-black (display) (screen-black-pixel (display-default-screen display)))
(defun display-white (display) (screen-white-pixel (display-default-screen display)))

(defun report-events (display)
  (loop
    (unless
      (process-event display :handler #'(lambda (&rest args) (print args)) :discard-p t :timeout 0.001)
      (return nil))))

(defun describe-window (window)
  (macrolet ((da (attribute &key (transform 'progn) (format "~s"))
	       (let ((func (intern (concatenate 'string (string 'window-)
						(string attribute)) 'xlib)))
		 `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))
	     (dg (attribute &key (transform 'progn) (format "~s"))
	       (let ((func (intern (concatenate 'string (string 'drawable-)
						(string attribute)) 'xlib)))
		 `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))))
    (with-state (window)
      (when (window-p window)
	(da visual :format "#x~x")
	(da class)
	(da gravity)
	(da bit-gravity)
	(da backing-store)
	(da backing-planes :format "#x~x")
	(da backing-pixel)
	(da save-under)
	(da colormap)
	(da colormap-installed-p)
	(da map-state)
	(da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
	(da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
	(da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
	(da override-redirect)
	)
      (dg root)
      (dg depth)
      (dg x)
      (dg y)
      (dg width)
      (dg height)
      (dg border-width)

      )))
      
(defun describe-gc (gc)
  (macrolet ((dgc (name &key (transform 'progn) (format "~s"))
	       (let ((func (intern (concatenate 'string (string 'gcontext-)
						(string name)) 'xlib)))
		 `(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc)))))))
    (dgc function)
    (dgc plane-mask)
    (dgc foreground)
    (dgc background)
    (dgc line-width)
    (dgc line-style)
    (dgc cap-style)
    (dgc join-style)
    (dgc fill-style)
    (dgc fill-rule)
    (dgc tile)
    (dgc stipple)
    (dgc ts-x)
    (dgc ts-y)
    (dgc font) ;; See below
    (dgc subwindow-mode)
    (dgc exposures)
    (dgc clip-x)
    (dgc clip-y)
;;    (dgc clip-ordering)
    (dgc clip-mask)
    (dgc dash-offset)
    (dgc dashes)
    (dgc arc-mode)
    ))

(defun degree (degrees)
  (* degrees (/ pi 180)))

(defun radian (radians)
  (round (* radians (/ 180 pi))))

(defun display-refresh (host)
  ;; Useful for when the system writes to the screen (sometimes scrolling!)
  (let ((display (open-display host)))
    (unwind-protect
	(let ((screen (display-default-screen display)))
	  (let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on
				    :width (screen-width screen) :height (screen-height screen)
				    :background (screen-black-pixel screen))))
	    (map-window win)
	    (display-finish-output display)
	    (unmap-window win)
	    (destroy-window win)
	    (display-finish-output display)))
      (close-display display))))

(defun root-tree (host)
  (let ((display (open-display host)))
    (unwind-protect
	(window-tree (screen-root (display-default-screen display)))
      (close-display display)))
  (values))

(defun window-tree (window &optional (depth 0))
  ;; Print the window tree and properties starting from WINDOW
  ;; Returns a list of windows in the order that they are printed.
  (declare (arglist window)
	   (type window window)
	   (values (list window)))
  (let ((props (mapcar #'(lambda (prop)
			   (multiple-value-bind (data type format)
			       (get-property window prop)
			     (case type
			       (:string (setq data (coerce data 'string))))
			     (list prop format type data)))
		       (list-properties window)))
	(result (list window)))
    (with-state (window)
      (format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window)
	      (drawable-x window) (drawable-y window)
	      (drawable-width window) (drawable-height window)
	      (window-map-state window)))
    (dolist (prop props)
      (format t "~%~v@t~{~s ~}" (+ depth 2) prop))
    (dolist (w (query-tree window))
      (setq result (nconc result (window-tree w (+ depth 2)))))
    result))