(in-package :clim-clx)

;; This busy cursor could use some work, later.
;; I'm sick of messing around with it.

(defparameter *my-pixmap*
  '(" :::::::::::::  "
    " :###########:  "
    " :###########:  "
    "  :#:     :#:   "
    "  :#:     :#:   "
    "   :#:   :#:    "
    "   :#######:    "
    "    :#:::#:     "
    "     :#:#:      "
    "     :#:#:      "
    "    :#:#:#:     "
    "   :#::#::#:    "
    "   :#::#::#:    "
    "  :#::#:#::#:   "
    "  :#:#:::#:#:   "
    "  :#########:   "
    " :###########:  "
    " :::::::::::::  "))

(defparameter *my-bitmap*
  (make-array '(18 16) :element-type 'bit :initial-contents
              (mapcar (lambda (x) (map 'list (lambda (x) (if (eql x #\#) 1 0)) x))
                      *my-pixmap*)))

(defparameter *my-bitmap-mask*
  (make-array '(18 16) :element-type 'bit :initial-contents
              (mapcar (lambda (x) (map 'list (lambda (x) (if (eql x #\space) 0 1)) x))
                      *my-pixmap*)))


(defun my-cursor (port)
  (declare (optimize (debug 3)
		     (safety 3)))
  (let* ((display (clx-port-display port))
	 (screen (clx-port-screen port))
	 (image (xlib:create-image :width 16 :height 18 :depth 1 :data *my-bitmap*))
         (image-2 (xlib:create-image :width 16 :height 18 :depth 1 :data *my-bitmap-mask*))
	 (source (xlib:create-pixmap :width 16 :height 18 :depth 1
				     :drawable (xlib:screen-root screen)))
	 (mask   (xlib:create-pixmap :width 16 :height 18 :depth 1
				     :drawable (xlib:screen-root screen)))	 
	 (gc-1 (xlib:create-gcontext :drawable source :foreground 0 :background 1))
	 (gc-2 (xlib:create-gcontext :drawable mask :foreground 1 :background 0)))
    (unwind-protect
	(progn
	  (xlib:put-image source gc-1 image :x 0 :y 0 :width 16 :height 18 :bitmap-p T)
	  (xlib:put-image mask gc-2 image-2 :x 0 :y 0 :width 16 :height 18 :bitmap-p T)	  
	  (xlib:create-cursor :source source
			      :mask mask
			      :x 0 :y 0
			      :foreground (xlib:make-color :blue 1.0 :green 1.0 :red 1.0)
			      :background (xlib:make-color :blue 0.0 :green 0.0 :red 0.0)))
     (xlib:free-gcontext gc-1)
     (xlib:free-gcontext gc-2)
     (xlib:free-pixmap source)
     (xlib:free-pixmap mask))))
  

#+NIL
(defun my-cursor (port)
  (declare (optimize (debug 3)
		     (safety 3)))
  (let* ((display (clx-port-display port))
	 (screen (clx-port-screen port))
	 (font (xlib:open-font display "cursor")))
    (format *trace-output* "~&Made it this far! ;)~%")
    (xlib:create-glyph-cursor :source-font font
			      :source-char (char-code #\X)
			      :foreground (xlib:make-color :blue 1.0 :green 1.0 :red 1.0)
			      :background (xlib:make-color :blue 0.0 :green 0.0 :red 0.0))))

(defun set-busy-cursor (sheet busyp)
  (let* ((mirror (sheet-mirror sheet))
	 (cursor (my-cursor (port sheet))))
    (setf (xlib:window-cursor mirror) (if busyp cursor :none))
    (xlib:display-finish-output (xlib:drawable-display mirror))
    ))
   
(defclass frame-busy-cursor-mixin ()
  ((busy-timer-thread :initform nil :accessor frame-busy-timer-thread)
   (busy-cursor-state :initform nil :accessor frame-busy-cursor-state)))

(defclass climi::standard-application-frame (climi::application-frame clim-clx::frame-busy-cursor-mixin)
  ((climi::event-queue :initarg :frame-event-queue
		:accessor climi::frame-event-queue
		:documentation "The event queue that, by default, will be
  shared by all panes in the stream")
   (climi::documentation-state :accessor climi::frame-documentation-state
			:initform nil
			:documentation "Used to keep of track of what
  needs to be rendered in the pointer documentation frame.")))

(defvar *cond-lock*
  (clim-sys:make-lock))

(defvar *cond*
  (sb-thread::make-waitqueue))

(defvar *app-busy-p* nil)
(defvar *sleeping-p* nil)

(defun busy-timer-thread-func (frame)
  (loop
    (clim-sys:with-lock-held (*cond-lock*)
      (sb-thread:condition-wait *cond* *cond-lock*)
      (setf *sleeping-p* t))
    (sleep .1)
    (clim-sys:with-lock-held (*cond-lock*)
      (setf *sleeping-p* nil)
      (when *app-busy-p*
        (let ((sheet (frame-top-level-sheet frame)))
          (with-slots (busy-cursor-state) frame
            (set-busy-cursor sheet T)
            (setf busy-cursor-state T)))))))

(defun clear-busy-timeout ()
  (let* ((frame clim:*application-frame*)
	 (sheet (frame-top-level-sheet frame)))
    (with-slots (busy-cursor-state busy-timer-thread) frame
      (clim-sys:with-lock-held (*cond-lock*)
        (when busy-cursor-state
          (set-busy-cursor sheet nil)
          (setf busy-cursor-state nil))
        (setf *app-busy-p* nil)))))
      
(defun reset-busy-timeout ()
  (let* ((frame clim:*application-frame*))
    (with-slots (busy-cursor-state busy-timer-thread) frame
      (if (not busy-timer-thread)
          (setf busy-timer-thread
	        (clim-sys:make-process #'(lambda ()
					   (busy-timer-thread-func frame))
				       :name (format nil "Busy timer thread for ~W" frame))))
      (clim-sys:with-lock-held (*cond-lock*)
        (setf *app-busy-p* t)
        (unless *sleeping-p*
          (sb-thread:condition-notify *cond*))) )))
	

(defmethod climi::event-queue-read :around ((eq climi::standard-event-queue))
  (clear-busy-timeout)
  (prog1
      (call-next-method)
    (reset-busy-timeout)) )

(defmethod climi::event-queue-listen-or-wait :around ((eq climi::standard-event-queue) &key timeout)
  (clear-busy-timeout)
  (prog1
      (call-next-method)
    (reset-busy-timeout)) )

;; TODO:

#+nil(defmethod climi::event-queue-read-no-hang :around  ((eq standard-event-queue))  )
#+nil(defmethod climi::event-queue-read-with-timeout :around ((eq standard-event-queue))  )


#||
(trace clim-sys::enable-process)
(trace clim-sys::disable-process)
(trace clim-sys::make-process)
(trace clim-sys:restart-process)
||#

;;(trace clear-busy-timeout)
;;(trace reset-busy-timeout)

;;(trace set-busy-cursor)

#||
(trace climi::event-queue-listen)
(trace climi::event-queue-peek)
(trace climi::event-queue-peek-if)
(trace climi::event-queue-read)
(trace climi::event-queue-read-no-hang)
(trace climi::event-queue-read-with-timeout)
(trace climi::event-queue-listen-or-wait)
||#

(in-package :clim-demo)

(define-address-book-command com-busy ()
  (write-line "I am busy ..")
  (sleep 5)
  (write-line "hmm .."))