(in-package :cl-cairo2)

;; constants for communicating with the signal window
(defconstant +destroy-message+ 4072)	; just some random constant
(defconstant +refresh-message+ 2495)	; ditto

(defvar *xlib-context-count* 0 "window counter for autogenerating names")

(defun next-xlib-context-name ()
  "Return an autogenerated window name using *xlib-context-count*."
  (format nil "cl-cairo2 ~a" (incf *xlib-context-count*)))

;; code to make threads, please extend with your own Lisp if needed
;; testing is welcome, I only tested cmucl and sbcl
(defun start-thread (function name)
  #+allegro (mp:process-run-function name function)
  #+armedbear (ext:make-thread function :name name)
  #+cmu (mp:make-process function :name name)
  #+lispworks (mp:process-run-function name nil function)
  #+openmcl (ccl:process-run-function name function)
  #+sbcl (sb-thread:make-thread function :name name))

;; we create this definition manually, SWIG just messes things up
(defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) cairo_surface_t
  (display display)
  (drawable drawable)
  (visual visual)
  (width :int)
  (height :int))

;; The class for an x11 context.  Each context has a separate display
;; queue, window and an event loop in a separate thread.  Once the
;; event loop is started, communication with the thread is done via
;; X11 ClientNotify events (see wacky constants above).

(defclass xlib-context (context)
  ((display :initarg :display)
   (wm-delete-window)
   (window)
   (signal-window)
   (pixmap)
   (graphics-context)
   (thread)
   (sync-counter :initform 0 :accessor sync-counter)))

(defun refresh-xlib-context (xlib-context)
  "Copy the contents of the pixmap to the window.  This function is
meant for internal use in the cl-cairo2 package."
  (with-slots (display width height window pixmap graphics-context) xlib-context
    (xcopyarea display pixmap window graphics-context
	       0 0 width height 0 0)
    (xsync display 1)))

(defun create-xlib-context (width height &key
			    (display-name nil) 
			    (window-name (next-xlib-context-name)))
  (let ((display (xopendisplay (if display-name display-name (null-pointer)))))
    (when (null-pointer-p display)
      (error "couldn't open display ~a" display-name))
    (let ((xlib-context (make-instance 'xlib-context
				       :display display
				       :width width
				       :height height)))
      (flet ((event-loop ()
	       (with-slots (display (this-window window) signal-window
				    pixmap
				    wm-delete-window graphics-context)
		   xlib-context
		 (let ((wm-protocols (xinternatom display "WM_PROTOCOLS" 1)))
		   (with-foreign-object (xev :long 24)
		     (do ((got-close-signal nil))
			 (got-close-signal)
		       ;; get next event
		       (xnextevent display xev)
		       ;; decipher structure, at least partially
		       (with-foreign-slots ((type window serial) xev xanyevent)
			 ;; action based on event type
			 (cond
			   ;; expose events
			   ((and (= type 12) (= window this-window))
			    (refresh-xlib-context xlib-context))
			   ;; clientnotify event
			   ((= type 33)
			    (with-foreign-slots ((message-type data0) xev 
						 xclientmessageevent)
			      (cond
				((or (and (= window signal-window)
					  (= data0 +destroy-message+))
				     (and (= window this-window)
					  (= message-type wm-protocols)
					  (= data0 wm-delete-window)))
				 (setf got-close-signal t))
				((and (= window signal-window)
				      (= data0 +refresh-message+))
				 (refresh-xlib-context xlib-context)))))))))))
	       ;; close down everything
	       (with-slots (display pixmap window signal-window pointer)
		   xlib-context
		 (xsynchronize display 1)
		 (let ((saved-pointer pointer))
		   (setf pointer nil) ; invalidate first so it can't be used
;;		   (cairo_destroy saved-pointer)
		   )
		 (xfreepixmap display pixmap)
		 (xdestroywindow display window)
  		 (xdestroywindow display signal-window)
  		 (xclosedisplay display))))
	;; initialize
	(xsynchronize display 1)
	(let* ((screen (xdefaultscreen display))
	       (root (xdefaultrootwindow display))
	       (visual (xdefaultvisual display screen))
	       (depth (xdefaultdepth display screen))
	       (whitepixel (xwhitepixel display screen)))
	  (with-slots (window pixmap signal-window thread wm-delete-window
			      pointer graphics-context) xlib-context
	    ;; create signal window and window
	    (setf window
		  (create-window display root width height 'inputoutput visual 
				 whitepixel 
				 (logior exposuremask
					 structurenotifymask)
				 t))
	    (setf signal-window
		  (create-window display root 1 1 'inputonly visual
				 whitepixel 0 nil))
	    ;; create pixmap
	    (setf pixmap
		  (xcreatepixmap display window width height depth))
	    ;; create graphics-context
	    (setf graphics-context
		  (xcreategc display pixmap 0 (null-pointer)))
	    ;; set size hints on window (most window managers will respect this)
	    (let ((hints (xallocsizehints)))
	      (with-foreign-slots ((flags x y min-width min-height
					  max-width max-height)
				   hints
				   xsizehints)
		;; we only set the first four values because old WM's might
		;; get confused if we don't, they should be ignored
		(setf flags (logior pminsize pmaxsize)
		      x 0
		      y 0
		      (foreign-slot-value hints 'xsizehints 'width) width
		      (foreign-slot-value hints 'xsizehints 'height) height
		      min-width width
		      max-width width
		      min-height height
		      max-height height)
		(xsetwmnormalhints display window hints)
		(xfree hints)))
	    ;; intern atom for window closing, set protocol on window
	    (setf wm-delete-window 
		  (xinternatom display "WM_DELETE_WINDOW" 1))
	    (with-foreign-object (prot 'xatom)
	      (setf (mem-aref prot 'xatom) wm-delete-window)
	      (xsetwmprotocols display window prot 1))
	    ;; store name
	    (xstorename display window window-name)
	    ;; create cairo context
	    (let ((surface (cairo_xlib_surface_create display pixmap visual
						      width height)))
	      (setf pointer (cairo_create surface))
	      ;; !!! error checking
	      (cairo_surface_destroy surface))
	    ;; map window
	    (xmapwindow display window)
	    ;; end of synchronizing
	    (xsynchronize display 0)
	    ;; start thread
	    (setf thread
		  (start-thread
		   #'event-loop
		   (format nil "thread for display ~a" display-name))))))
      ;; return context
      xlib-context)))


(defun send-message-to-signal-window (xlib-context message)
  "Send the desired message to the context window."
  (with-slots (pointer (display-pointer display) signal-window) xlib-context
    (unless pointer
      (warn "context is not active, can't send message to window")
      (return-from send-message-to-signal-window))
    (with-foreign-object (xev :long 24)
      (with-foreign-slots 
	  ((type display window message-type format data0) 
	   xev xclientmessageevent)
	(setf type 33)			; clientnotify
	(setf display display-pointer)
	(setf window signal-window)
	(setf message-type 0)
	(setf format 32)
	(setf data0 message)
	(xsendevent display-pointer signal-window 0 0 xev))
      (xsync display-pointer 1))))

(defmethod destroy ((object xlib-context))
  (send-message-to-signal-window object +destroy-message+))

(defmethod sync ((object xlib-context))
  (when (zerop (sync-counter object))
    (send-message-to-signal-window object +refresh-message+)))

(defmethod sync-lock ((object xlib-context))
  (incf (sync-counter object)))

(defmethod sync-unlock ((object xlib-context))
  (with-slots (sync-counter) object
    (when (plusp sync-counter)
      (decf sync-counter)))
  (sync object))

(defmethod sync-reset ((object xlib-context))
  (setf (sync-counter object) 0)
  (sync object))