paulownia.ros.in

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(asdf:initialize-source-registry
 '(:source-registry
   (:directory "@PAULOWNIA_ASDF_DIR@")
   :inherit-configuration))
(setf asdf:*central-registry*
      (append (list (merge-pathnames "@PAULOWNIA_ASDF_DIR@/base/"))
	      asdf:*central-registry*))
(ql:quickload :paulownia)

(in-package :paulownia)
(export '(*display*))

(defvar *display* nil
  "The display for the X server")

(defparameter *mods*    '(:mod-1))
(defparameter *move*    1)
(defparameter *resize*  3)
(defparameter *lower*   4)
(defparameter *raise*   5)
(defparameter *display* nil)            ; set this to an integer to do testing with xnest

(defun paulownia ()
  (let* ((screen (first (xlib:display-roots *display*)))
	 (root (xlib:screen-root screen)))
    (dolist (button (list *move* *resize* *lower* *raise*))
      (xlib:grab-button root button '(:button-press) :modifiers *mods*))

    (unwind-protect
	 (let (last-button last-x last-y)
	   (do () (nil)                  ; infinite loop
            (xlib:event-case (*display* :discard-p t)
             (:button-press (code child)
              (cond ((= code *raise*)
                     (xlib:circulate-window-up root))
                    ((= code *lower*)
                     (xlib:circulate-window-down root))
                    ((or (= code *move*)
                         (= code *resize*))
                     (when child        ; do nothing if we're not over a window
                       (setf last-button code)
                       (xlib:grab-pointer child '(:pointer-motion :button-release))
                       (let ((lst (multiple-value-list (xlib:query-pointer root))))
                         (setf last-x (sixth   lst)
                               last-y (seventh lst)))))))
             (:motion-notify
              (event-window root-x root-y)
              (cond ((= last-button *move*)
                       (setf (xlib:drawable-x event-window) root-x
                             (xlib:drawable-y event-window) root-y))
                      ((= last-button *resize*)
                       (setf (xlib:drawable-width event-window)
                             (max 1 (- root-x (xlib:drawable-x event-window)))
                             (xlib:drawable-height event-window)
                             (max 1 (- root-y (xlib:drawable-y event-window)))))))
             (:button-release ()
              (xlib:ungrab-pointer *display*)))))
      (xlib:close-display *display*))
    )
  )

(defun main (&rest argv)
  (declare (ignorable argv))
  "Start the window manager, this is the \"main\" of the program"
  ;; Setup variables that need a global state for pauwlonia to run
  ;; Setup the data directory for logging/modules
  (setf *data-dir*
	(make-pathname :directory (append (pathname-directory (user-homedir-pathname))
					  (list ".paulownia.d"))))
  ;; Setup the load-path for modules
  ;; (init-load-path (merge-pathnames *data-dir* "modules/"))

  ;; Start the top level loop.  We have to follow the standard unix
  ;; interfaces and respond to events when we're suspended
  ;; (hup-process)
  (let ((display-str (car argv)))
    (when (null display-str)
      (setf display-str (uiop:getenv "DISPLAY")))
    (format t "Opening display: ~a ~%" display-str)
    (loop
     (let ((ret (catch :top-level
		  (multiple-value-bind (host display screen protocol) (parse-display-string display-str)

		    (declare (ignore screen))
		    (setf *display* (xlib:open-display host :display display :protocol protocol)
			  (xlib:display-error-handler *display*) 'error-handler)
		    (paulownia)))))
       (setf *last-unhandled-error* nil)
       (cond ((and (consp ret)
		   (typep (first ret) 'condition))
	      (format t "~&Caught '~a' at the top level. Please report this.~%~a"
		      (first ret) (second ret))
	      (setf *last-unhandled-error* ret))
	     ;; we need to jump out of the event loop in order to hup
	     ;; the process because otherwise we get errors.
	     ((eq ret :hup-process)
	      (apply 'execv (first (list argv)) (list argv)))
	     ((eq ret :restart))
	     (t
	      (run-hook *quit-hook*)
	      ;; the number is the unix return code
	      (return-from main 0))))))
  )