(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-image-context-count* 0 "window counter for autogenerating names")

(defun next-xlib-image-context-name ()
  "Return an autogenerated window name using *xlib-context-count*."
  (format nil "cl-cairo2 ~a" (incf *xlib-image-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))

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

;; synchronization after drawing

(defun send-message-to-signal-window (xlib-image-context message)
  "Send the desired message to the context window."
  (with-slots (pointer (display-pointer display) signal-window) xlib-image-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))
      (xflush display-pointer))))

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

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

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

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

(defun create-xlib-image-context (width height &key
				  (display-name nil) 
				  (window-name (next-xlib-image-context-name))
				  (background-color +white+))
  "Create a window mapped to an xlib-image-context, with given width,
height (non-resizable) and window-name on display-name.  If
background-color is not nil, the window will be painted with it."
  (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-image-context (make-instance 'xlib-image-context
					     :display display
					     :width width
					     :height height
					     :pixel-based-p t)))
      (labels (;; Repaint the xlib context with the image surface
	       ;; (previously set as source during initialization.
	       (refresh ()
		 (cairo_paint (xlib-context xlib-image-context)))
	       ;; The main event loop, started as a separate thread
	       ;; when initialization is complete.  The main thread is
	       ;; supposed to communicate with this one via X signals
	       ;; using an unmapped InputOnly window (see
	       ;; send-message-to-signal-window).
	       (event-loop ()
		 (with-slots (display (this-window window) signal-window
				      wm-delete-window graphics-context)
		     xlib-image-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))
			     ;; 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)))))))))))
		 ;; close down everything
		 (with-slots (display pixmap window signal-window pointer
				      xlib-context)
		     xlib-image-context
		   (xsynchronize display 1)
		   (let ((saved-pointer pointer))
		     (setf pointer nil) ; invalidate first so it can't be used
		     (cairo_destroy saved-pointer))
		   (cairo_destroy xlib-context)
		   ;; !! free xlib-context, surface
		   (xdestroywindow display window)
		   (xdestroywindow display signal-window)
		   (xclosedisplay display))))
	;; initialize
	(xsynchronize display 1)
	(let* ((screen (xdefaultscreen display))
	       (root (xdefaultrootwindow display))
	       (visual (xdefaultvisual display screen))
	       (whitepixel (xwhitepixel display screen)))
	  (with-slots (window signal-window thread wm-delete-window
			      pointer graphics-context xlib-context)
	      xlib-image-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 graphics-context
	    (setf graphics-context
		  (xcreategc display window 0 (null-pointer)))
	    ;; set size hints on window (most window managers will respect this)
	    (set-window-size-hints display window width width height height)
	    ;; 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)
	    ;; first we create an X11 surface and context on the window
	    (let ((xlib-surface (cairo_xlib_surface_create display window visual
							   width height)))
	      (setf xlib-context (cairo_create xlib-surface))
	      (cairo_surface_destroy xlib-surface))
	    ;; create cairo surface, then context, then set the
	    ;; surface as the source of the xlib-context
	    (let ((surface (cairo_image_surface_create :CAIRO_FORMAT_RGB24
						       width height)))
	      (setf pointer (cairo_create surface))
	      (cairo_set_source_surface xlib-context surface 0 0)
	      (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))))))
      ;; paint it if we are given a background color
      (when background-color
	(set-source-color background-color xlib-image-context)
	(paint xlib-image-context)
	(sync xlib-image-context))
      ;; return context
      xlib-image-context)))


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