trying to CLOS-wrap CLX

clx-clos.lisp

#| -*- mode:lisp -*-
   CLOS wrapper for CLX
|#

(eval-when (:compile-toplevel :load-toplevel :execute) 
  (require :quicklisp)
  (quicklisp:quickload '("clx" "uiop")))

(defpackage #:clx-clos
  (:documentation "")
  (:shadowing-import-from #:xlib #:create-image)
  (:use #:common-lisp #:xlib #:uiop)
  (:nicknames #:closx)
;; (:export #:demo)
  )

(in-package #:closx)

;;; SBCL treats constant redefinition as error
;; (defmacro defconst (name value &optional doc)
;;   `(defconstant ,name (if (boundp ',name)
;; 			  (symbol-value ',name)
;; 			  ,value)
;;      ,@(when doc (list doc))))

;(declaim (optimize (speed 3) (space 0) (debug 0)))

(defun get-current-display-number ()
  (let ((env-display (uiop:getenv "DISPLAY")))
    (if (and (stringp env-display)
	     (> (length env-display) 1)
	     (find #\: env-display))
	(parse-integer
	 (subseq env-display
		 (1+ (position #\: env-display))
		 (let ((dot-screen (position #\. env-display)))
		   (when dot-screen dot-screen))))
	0)))

(defclass closx-screen ()
  ((display :type display)
   (screen :type screen)
   (screen-width :type (unsigned-byte 16))
   (screen-height :type (unsigned-byte 16))
   (root-window :type window)
   (black-pixel :type pixel
		:accessor root-black
		:initform #x000000)
   (white-pixel :type pixel
		:accessor root-white
		:initform #xFFFFFF)
   ;;; windows is a list-tree of subwindows of root window
   (windows :type list ;; FIXIT: should be list of window
	    :initform '())
   (font :type font)))

(defmethod initialize-instance :after ((closx-screen closx-screen)
				       &key (host "") display-number)
  (with-slots (display screen screen-width screen-height root-window
	       black-pixel white-pixel windows font)
      closx-screen
    (setf display (open-display host :display (when (not display-number)
						(get-current-display-number)))
	  screen (display-default-screen display)
	  black-pixel (screen-black-pixel screen)
	  white-pixel (screen-white-pixel screen)
	  screen-width (screen-width screen)
	  screen-height (screen-height screen)
	  root-window (screen-root screen)
	  font (open-font display "-dec-terminal-medium-r-normal--14-140-75-75-c-80-iso8859-1"))))

(defmethod close-screen ((closx-screen closx-screen))
  (close-font (slot-value closx-screen 'font)))

(defclass closx-window ()
  ((closx-screen :type closx-screen
	     :initarg :screen)
   (window :type window)
   (parent-window :type window
		  :initarg :parent-window)
   (window-width :type (unsigned-byte 16)
		 :initarg :window-width
		 :initform 128)
   (window-height :type (unsigned-byte 16)
		  :initarg :window-height
		  :initform 128)
   (window-x :type (unsigned-byte 16)
	     :initarg :x-position
	     :initform 1)
   (window-y :type (unsigned-byte 16)
	     :initarg :y-position
	     :initform 1)
   (colormap :type colormap)
   (gcontext :type gcontext)))

(defmethod initialize-instance :after ((closx-window closx-window) &key)
  (with-slots (closx-screen window window-width window-height window-x window-y parent-window colormap gcontext)
      closx-window
    (when (not (boundp 'closx-screen))
      (setf closx-screen (make-instance 'closx-screen)))
    (with-slots (screen screen-width screen-height root-window black-pixel white-pixel display font)
	closx-screen
      (when (not (boundp 'parent-window))
	(setf parent-window root-window))
      (setf window-width
	    (typecase window-width
	      (null screen-width) ; REMINDER: order means
	      (integer window-width)
	      (ratio (round (* screen-width window-width)))
	      (symbol (case window-width
			((or full fullscreen max) screen-width)
			(half (truncate screen-width 2))
			(phi (truncate screen-width 1.618034f0))))
	      (t (error (format nil "Unsupported type of width: ~(~A~)"
				(type-of window-width))))))
      (setf window-height
	    (typecase window-height
	      (null screen-height) ; REMINDER: order means
	      (integer window-height)
	      (ratio (round (* screen-height window-height)))
	      (symbol (case window-height
			((or full fullscreen max) screen-height)
			(half (truncate screen-height 2))
			(golden (truncate screen-height 1.618034f0))))
	      (t (error (format nil "Unsupported type of height: ~(~A~)"
				(type-of window-height))))))
      (setf window-x 1 ;; (truncate (- screen-width window-width) 2)
	    )
      (setf window-y 1;; (truncate (- screen-height window-height) 2)
	    )
      ;; (when (not (boundp 'colormap)
      ;; 		 (setf colormap (create-colormap depth24 main-window))
      (setf window
	    (create-window :parent parent-window
			   :x window-x
			   :y window-y
			   :width window-width
			   :height window-height
			   :border-width 0
			   :event-mask (make-event-mask :exposure
							:pointer-motion
							:button-press
							:key-press
							:leave-window)
			   :background white-pixel
			   :colormap (screen-default-colormap screen)
					;		       :border white-pixel
			   :bit-gravity :center
					;:override-redirect :on
			   ))
      (set-wm-properties window
			 :name ""
			 :icon-name ""
			 :resource-name ""
			 :resource-class ""
			 :user-specified-position-p t
			 :user-specified-size-p t
			 :x window-x
			 :y window-y
			 :width window-width :height window-height
			 :min-width window-width :min-height window-height
			 :max-width window-width :max-height window-height
			 :input :on
			 :initial-state :normal)
      (setf gcontext (create-gcontext :drawable window ;; drawable is window or pixmap
				      :background black-pixel
				      :foreground white-pixel
				      :font font))
      (when (not (window-colormap-installed-p window))
	(install-colormap (window-colormap window)))
      ;; (map-window window)
      ;; (display-finish-output display)
      )))

(defmethod close-window ((closx-window closx-window))
  (with-slots (gcontext window display closx-screen) closx-window
    (free-gcontext gcontext)
    (unmap-window window) ; excessive: since destroy-window does it
    (destroy-subwindows window) ; excessive: since destroy-window does it
    (destroy-window window)
    (close-screen closx-screen)))

(defmacro with-x ((window-symbol) &body body)
  `(unwind-protect
	(let ((,window-symbol (make-instance 'closx-window)))
	  ,@body)
     (close-window ,window-symbol)))

;; (defmethod initialize-instance :after ((instance x-client)
;; 				       &key (host "" host-p)
;; 					 (display 0 display-p))
;;   (with-slots (host display screens)
;;       instance
;;     (when host-p (setf (slot-value instance 'host) host))
;;     (when (not display-p)
;;       (setf (slot-value instance 'display)
;; 			(if (not (or host-p display-p))
;; 			    (open-default-display) ; todo: check it
;; 			    (open-display host :display display))))
;;     ;; (setf (slot-value instance 'screens
;;     ;; 		      (list (make-instance 'closx-screen :display display))))
;;     ))

;; (defmethod add-screen ((instance x-client) screen)
;;   (push screen (slot-value instance 'screens)))

;; (defmethod close-client ((instance x-client))
;;   (close-display (slot-value instance 'display)))


;; (defmacro with-x ())