(require :clx)

(define-object *namespace-X11*
  (name "X11_" nil :immutable)
  (traits *traits-namespace* t :immutable))

(add-slot *lobby* '|X11_| *namespace-X11* nil :immutable)

(defmacro define-xtraits (basic-name &rest parents)
  (let*
      ((un (string-upcase basic-name))
       (traits-sym (intern (format nil "*TRAITS-~A*" un)))
       (proto-sym (intern (format nil "*PRIMITIVE-~A*" un)))
       (local-sym (%gensym))
       (parent-slots
	(if parents
	    (loop for parent in parents
	      collect `(,(intern (format nil "*TRAITS-~A*" (string-upcase parent)))
			t :immutable))
	  '((*traits-oddball* t :immutable)))))
    `(progn
(define-traits ,traits-sym ,basic-name
  ,@parent-slots)
(define-object ,proto-sym
  (traits ,traits-sym t :immutable))
(add-slot *namespace-X11* ',(intern basic-name) ,proto-sym nil :immutable)
(define-method print ((,local-sym ,traits-sym))
  (format nil "<~A>" ,basic-name))
)))

(define-xtraits "Display")
(define-xtraits "Screen")
(define-xtraits "Drawable")
(define-xtraits "Window" "Drawable")
(define-xtraits "Pixmap" "Drawable")
(define-xtraits "Cursor")
(define-xtraits "Color")
(define-xtraits "Context")

#+nil
(defmacro define-accessor (name arguments &body body)
  (let ((mut-args ()))
    `(progn
       (define-method (name arguments ,@body))
       (define-method (,(intern (concatenate 'string (string name) ":"))
		       arguments)
	 ,@body))))

;Display

(define-method "newForHost:device:protocol:" ((display *traits-display*)
					      (host *traits-string*)
					      (device *traits-integer*)
					      (protocol *traits-integer*))
  (xlib:open-display host :display device :protocol protocol))

(define-method "authorizationData" ((display *traits-display*))
  (xlib:display-authorization-data display))

(define-method "authorizationProtocol" ((display *traits-display*))
  (xlib:display-authorization-name display))

(define-method "bitmapFormat" ((display *traits-display*))
  (xlib:display-bitmap-format display))

(define-method "byteOrder" ((display *traits-display*))
  (if (eq (display-byte-order display) :lsbfirst) '|little| '|big|))

(define-method "number" ((display *traits-display*))
  (if (eq (xlib:display-byte-order display) :lsbfirst) '|little| '|big|))

(define-method "defaultHandler" ((display *traits-display*))
  (xlib:display-error-handler display))

(define-method "defaultHandler:" ((display *traits-display*)
				  (handler *traits-method*))
  (setf (xlib:display-error-handler display) handler))

(define-method "defaultHandler:" ((display *traits-display*)
				  (handler *traits-array*))
  (setf (xlib:display-error-handler display) handler))

(define-method "requestLength" ((display *traits-display*))
  (xlib:display-max-request-length display))

(define-method "screens" ((display *traits-display*))
  (coerce (xlib:display-roots display) 'vector))

(define-method "flush" ((display *traits-display*))
  (xlib:display-force-output display)
  *primitive-nil*)

(define-method "flushAndFinish" ((display *traits-display*))
  (xlib:display-finish-output display)
  *primitive-nil*)

(define-method "destroy" ((display *traits-display*))
  (xlib:close-display display)
  *primitive-nil*)

(define-method "displayNumber" ((display *traits-display*))
  (xlib:display-display display))

;Screen

(define-method "height" ((screen *traits-screen*))
  (xlib:screen-height screen))

(define-method "width" ((screen *traits-screen*))
  (xlib:screen-width screen))

(define-method "physicalHeight" ((screen *traits-screen*))
  (xlib:screen-height-in-millimeters screen))

(define-method "physicalWidth" ((screen *traits-screen*))
  (xlib:screen-width-in-millimeters screen))

(define-method "depth" ((screen *traits-screen*))
  (xlib:screen-depths screen))

(define-method "rootDepth" ((screen *traits-screen*))
  (xlib:screen-root-depth screen))

(define-method "rootWindow" ((screen *traits-screen*))
  (xlib:screen-root screen))

(define-method "blackPixel" ((screen *traits-screen*))
  (xlib:screen-black-pixel screen))

(define-method "whitePixel" ((screen *traits-screen*))
  (xlib:screen-white-pixel screen))

;Drawable

(define-method "display" ((drawable *traits-drawable*))
  (xlib:drawable-display drawable))

(define-method "root" ((drawable *traits-drawable*))
  (xlib:drawable-root drawable))

(define-method "rootAndNeighbors" ((drawable *traits-drawable*))
  (xlib:query-tree drawable :result-type 'vector))

(define-method "=" ((drawable1 *traits-drawable*)
		    (drawable2 *traits-drawable*))
  (bool-of (xlib:drawable-equal drawable1 drawable2)))

(define-method "id" ((drawable *traits-drawable*))
  (xlib:drawable-id drawable))

(define-method "depth" ((drawable *traits-drawable*))
  (xlib:drawable-depth drawable))

(define-method "width" ((drawable *traits-drawable*))
  (xlib:drawable-width drawable))

(define-method "height" ((drawable *traits-drawable*))
  (xlib:drawable-height drawable))

(define-method "x" ((drawable *traits-drawable*))
  (xlib:drawable-x drawable))

(define-method "y" ((drawable *traits-drawable*))
  (xlib:drawable-y drawable))

(define-method "width:" ((drawable *traits-drawable*) width)
  (setf (xlib:drawable-width drawable) width))

(define-method "height:" ((drawable *traits-drawable*) height)
  (setf (xlib:drawable-height drawable) height))

(define-method "x:" ((drawable *traits-drawable*) x)
  (setf (xlib:drawable-x drawable) x))

(define-method "y:" ((drawable *traits-drawable*) y)
  (setf (xlib:drawable-y drawable) y))

;Window

(define-method "newOn:x:y:width:height:" ((window *traits-window*)
					  (parent *traits-window*)
					  x y width height)
  (xlib:create-window :parent parent :x x :y y :width width :height height))

(define-method "newOn:x:y:width:height:background:" ((window *traits-window*)
					  (parent *traits-window*)
					  x y width height background)
  (xlib:create-window :parent parent :x x :y y :width width :height height :background background))

(define-method "reparentTo:x:y:" ((window *traits-window*)
				  (newparent *traits-window*) x y)
  (xlib:reparent-window window newparent x y))

(define-method "translateFrom:x:y:to:" ((source *traits-window*) x y
					(target *traits-window*))
  (xlib:translate-coordinates source x y target))

(define-method "primitiveDestroy" ((window *traits-window*))
  (xlib:destroy-window window))

(define-method "destroyChildren" ((window *traits-window*))
  (xlib:destroy-subwindows window))

(define-method "map" ((window *traits-window*))
  (xlib:map-window window))

(define-method "unmap" ((window *traits-window*))
  (xlib:unmap-window window))

(define-method "mapChildren" ((window *traits-window*))
  (xlib:map-subwindows window))

(define-method "unmapChildren" ((window *traits-window*))
  (xlib:unmap-subwindows window))

(define-method "display" ((window *traits-window*))
  (xlib:window-display window))

(define-method "=" ((window1 *traits-window*)
		    (window2 *traits-window*))
  (bool-of (xlib:window-equal window1 window2)))

(define-method "id" ((window *traits-window*))
  (xlib:window-id window))

(define-method "raise" ((window *traits-window*))
  (xlib:circulate-window-up window))

(define-method "lower" ((window *traits-window*))
  (xlib:circulate-window-down window))

;Pixmap

(define-method "newOn:width:height:depth:" ((pixmap *traits-pixmap*)
					    (drawable *traits-drawable*)
					    width height depth)
  (xlib:create-pixmap :width width :height height :depth depth
		      :drawable drawable))

(define-method "free" ((pixmap *traits-pixmap*))
  (xlib:free-pixmap pixmap))

(define-method "display" ((pixmap *traits-pixmap*))
  (xlib:pixmap-display pixmap))

(define-method "=" ((pixmap1 *traits-pixmap*)
		    (pixmap2 *traits-pixmap*))
  (bool-of (xlib:pixmap-equal pixmap1 pixmap2)))

(define-method "id" ((pixmap *traits-pixmap*))
  (xlib:pixmap-id pixmap))

;Context

(define-method "newContextWithBackground:foreground:" ((drawable *traits-drawable*)
							background foreground)
  (xlib:create-gcontext :drawable drawable :background background :foreground foreground))

(define-method "newContextWithBackground:foreground:font:" ((drawable *traits-drawable*)
							    background foreground
							    (font *traits-string*))
  (xlib:create-gcontext :drawable drawable :background background :foreground foreground :font font))

(define-method "=" ((context1 *traits-context*)
		    (context2 *traits-context*))
  (bool-of (xlib:gcontext-equal context1 context2)))

(define-method "destroy" ((context *traits-context*))
  (xlib:free-gcontext context))

;Drawing

(define-method "clear" ((window *traits-window*))
  (xlib:clear-area window))

(define-method "clearX:y:width:height:" ((window *traits-window*)
					 x y width height)
  (xlib:clear-area window :x x :y y :width width :height height))

(define-method "drawPointWithContext:x:y:" ((drawable *traits-drawable*)
					    (context *traits-context*)
					    x y)
  (xlib:draw-point drawable context x y)
  *primitive-nil*)

(define-method "drawLineWithContext:fromX:y:toX:y:" ((drawable *traits-drawable*)
						     (context *traits-context*)
						     x1 y1 x2 y2)
  (xlib:draw-line drawable context x1 y1 x2 y2)
  *primitive-nil*)

(define-method "drawPolylineWithContext:points:" ((drawable *traits-drawable*)
						     (context *traits-context*)
						     points)
  (xlib:draw-lines drawable context points)
  *primitive-nil*)

(define-method "drawFilledPolygonWithContext:points:" ((drawable *traits-drawable*)
						     (context *traits-context*)
						     points)
  (xlib:draw-lines drawable context points :fill-p t)
  *primitive-nil*)

(define-method "drawRectWithContext:x:y:width:height:" ((drawable *traits-drawable*)
							(context *traits-context*)
							x y width height)
  (xlib:draw-rectangle drawable context x y width height)
  *primitive-nil*)

(define-method "drawFilledRectWithContext:x:y:width:height:" ((drawable *traits-drawable*)
							(context *traits-context*)
							x y width height)
  (xlib:draw-rectangle drawable context x y width height 't)
  *primitive-nil*)

(define-method "draw:x:y:withContext:" ((drawable *traits-drawable*)
					(char *traits-character*) x y
					(context *traits-context*))
  (xlib:draw-glyph drawable context x y char)
  *primitive-nil*)

(define-method "draw:x:y:from:to:withContext:" ((drawable *traits-drawable*)
						(string *traits-string*) x y start end
						(context *traits-context*))
  (xlib:draw-glyphs drawable context x y string :start start :end end)
  *primitive-nil*)

(define-method "draw:x:y:withContext:" ((drawable *traits-drawable*)
					(string *traits-string*) x y
					(context *traits-context*))
  (xlib:draw-glyphs drawable context x y string)
  *primitive-nil*)

;Color

(define-method "r:g:b:" ((color *traits-color*) r g b)
  (xlib:make-color :red r :green g :blue b))

(define-method "red" ((color *traits-color*))
  (xlib:color-red color))

(define-method "green" ((color *traits-color*))
  (xlib:color-green color))

(define-method "blue" ((color *traits-color*))
  (xlib:color-blue color))

;Colormap

;Events

(define-method "waitForEventWithTimeout:" ((display *traits-display*)
					   (timeout *traits-integer*))
  (or (xlib:event-listen display timeout) *primitive-nil*))