(define (mdisplay . args)
  (for-each display args)
  (force-output (current-output-port)))

(define (:optional args default)
  (if (null? args)
      default
      (car args)))

(define (assq/false key alist)
  (let ((p (assq key alist)))
    (and p (cdr p))))

(define (flatten lists)
  (fold-right append
	      '()
	      lists))

(define (list-diff list1 list2)
  ;; returns every member in list2 that is not in list1
  (filter (lambda (e)
	    (not (member e list1)))
	  list2))

(define (floor* x)
  (let ((y (floor x)))
     (if (inexact? y)
         (inexact->exact y)
         y)))

;; *** cml utilities *************************************************

(define select* select)

(define (make-sync-point)
  (make-placeholder))

(define (sync-point-release sp)
  (placeholder-set! sp #t))

(define (sync-point-wait sp)
  (placeholder-value sp))

(define (spawn* id . fun)
  (let ((id (if (null? fun) "unnamed" id))
	(fun (if (null? fun) id (car fun))))
    (let ((sp (make-sync-point)))
      (spawn (lambda ()
	       (with-fatal-and-capturing-error-handler
		(lambda (condition continuation punt)
                  (display-continuation continuation)
		  (punt))
		(lambda ()
		  (let ((res (fun (lambda () (sync-point-release sp)))))
		    ;;(mdisplay "thread " id " returned: " res "\n")
		    res)
		  ))) id)
      (sync-point-wait sp))))

(define (with-lock lock thunk)
  (obtain-lock lock)
  (let ((r (thunk)))
    (release-lock lock)
    r))

(define (send-message+wait channel message)
  (let ((sp (make-sync-point)))
    (send channel (list 'wait sp message))
    (sync-point-wait sp)))

;; *** option utilities **********************************************

(define-record-type options :options
  (make-options dpy colormap option-alist value-alist type-alist default-alist)
  options?
  (dpy options:dpy)
  (colormap options:colormap)
  (option-alist options:option-alist set-options:option-alist!)
  (value-alist options:value-alist set-options:value-alist!)
  (type-alist options:type-alist set-options:type-alist!)
  (default-alist options:default-alist))

;; create new options structure out of existing (allocated) values
;; TODO: remember which options were specified and don't have to be
;; freed, and those that are allocated later.
;; TODO: the options are taken out of the spec, but that mustn't match
;; the given values
(define (build-options dpy colormap spec option-values)
  (make-options dpy colormap
		(options-spec-defaults spec)
		option-values ;; TODO check this alist
		(options-spec-types spec)
		(options-spec-defaults spec)))
  
(define (create-options dpy colormap spec options)
  (let ((option-alist (map (lambda (s)
			     (let* ((n (first s))
				    (op (assq n options)))
			       (cons n (if op (cdr op) (third s)))))
			   spec))
	(value-alist '())
	(type-alist (options-spec-types spec))
	(default-alist (options-spec-defaults spec)))
    (for-each (lambda (name.option name.type)
		(allocate-option dpy colormap (car name.option)
				 (cdr name.type) (cdr name.option)))
	      option-alist type-alist)
    (make-options dpy colormap option-alist value-alist type-alist
		  default-alist)))

(define (spec-defaults defaults spec)
  (map (lambda (s)
	 (let ((name (first s))
	       (type (second s))
	       (def1 (third s)))
	   (let ((def2 (assq name defaults)))
	     (list name type (if def2 (cdr def2) def1)))))
       spec))

;; if the colormap gets freed, then the colors don't have to
(define (free-options options free-colors?)
  (for-each (lambda (n.v)
	      (let* ((name (car n.v))
		     (value (cdr n.v))
		     (type (assq/false name (options:type-alist options))))
		(cond
		 ((eq? (option-type font) type)
		  (free-font (options:dpy options) value))
		 ((eq? (option-type color) type)
		  (free-colors (options:dpy options) (options:colormap options)
			       (list value) 0))
		 ((eq? (option-type colors) type)
		  (free-colors (options:dpy options) (options:colormap options)
			       value 0))
		 ((eq? (option-type cursor) type)
		  (free-cursor (options:dpy options) value)))))
	    (options:value-alist options)))

(define (get-option-value options name)
  (let ((p (assq name (options:value-alist options))))
    (if p
	(cdr p)
	(let ((op (assq name (options:option-alist options)))
	      (tp (assq name (options:type-alist options))))
	  (if (or (not op) (not tp))
	      (error "option not defined" name)
	      (let ((v (allocate-option (options:dpy options)
					(options:colormap options)
					name (cdr tp) (cdr op))))
		(set-options:value-alist! options
					  (cons (cons name v)
						(options:value-alist options)))
		v))))))

(define (get-option options name)
  (let ((vp (assq name (options:option-alist options))))
    (if (not vp)
	(error "option not defined" name)
	(cdr vp))))

(define (set-option! options name def)
  (set-options:option-alist! options
			     (cons (cons name def)
				   (filter (lambda (n.o)
					     (not (eq? (car n.o) name)))
					   (options:option-alist options))))
  (set-options:value-alist! options
			    (filter (lambda (n.v)
				      (not (eq? (car n.v) name)))
				    (options:value-alist options))))

(define (get-options options)
  (options:option-alist options))

(define (get-options-diff options)
  (list-diff (options:default-alist options)
	     (options:option-alist options)))

(define-enumerated-type option-type :option-type
  option-type? option-types option-type-name option-type-index
  (int number inexact exact string symbol font color colors
       boolean symbol-list keys keys-list sexp binding-list
       cursor))

(define-syntax define-options-spec
  (syntax-rules
   ()
   ((define-options-spec id (name type default) ...)
    (define id (list (list (quote name) (option-type type) default)
		     ...)))))

(define (options-spec-union spec1 spec2)
  (append spec1 spec2))

(define (options-spec-types spec)
  (map (lambda (s)
	 (cons (first s) (second s)))
       spec))

(define (options-spec-defaults spec)
  (map (lambda (s)
	 (cons (first s) (third s)))
       spec))

(define (allocate-option dpy colormap name type def)
  (let ((check (lambda (value pred)
		 (if (not (pred value))
		     (error "wrong type argument" value) ;; TODO: other error??
		     value))))
    (cond
     ((eq? type (option-type int)) (check def integer?))
     ((eq? type (option-type number)) (check def number?))
     ((eq? type (option-type inexact)) (check def inexact?))
     ((eq? type (option-type exact)) (check def inexact?))
     ((eq? type (option-type string)) (check def string?))
     ((eq? type (option-type symbol)) (check def symbol?))
     ((eq? type (option-type font))
      (check (load-query-font dpy def) (lambda (v) v)))
     ((eq? type (option-type color))
      (let ((c (alloc-named-color dpy colormap def)))
	(check (and c (color:pixel c)) (lambda (v) v))))
     ((eq? type (option-type colors))
      (and (check def list?)
	   (map (lambda (c) (allocate-option dpy colormap name
					     (option-type color) c))
		def)))
     ((eq? type (option-type boolean))
      (check def boolean?)) ;; maybe allow 'yes 'no ??
     ((eq? type (option-type symbol-list))
      (and (check def list?)
	   (map (lambda (s) (allocate-option dpy colormap name
					     (option-type symbol) s))
		def)))
     ((eq? type (option-type keys))
      (let ((keys (string->keys dpy def)))
	(check keys (lambda (x) x))))
     ((eq? type (option-type keys-list))
      (and (check def list?)
	   (map (lambda (s) (allocate-option dpy colormap name
					     (option-type keys) s))
		def)))
     ((eq? type (option-type sexp))
      def)
     ((eq? type (option-type binding-list))
      (and (check def list?)
	   (map (lambda (b)
		  (let ((k (allocate-option dpy colormap name
					    (option-type keys) (car b))))
		    (cons k (cdr b))))
		def)))
     ((eq? type (option-type cursor))
      (check (create-font-cursor dpy def) (lambda (x) x)))
     (else (error "option type not implemented" name type)))))

;; *** keys utilities ************************************************

(define-record-type key :key
  (make-key modifiers keycode)
  key?
  (modifiers key:modifiers)
  (keycode key:keycode))

(define (string->keys dpy s)
  (let* ((keys-s (split-space s))
	 (keys (map (lambda (s) (string->key dpy s)) keys-s)))
    (and (not (memq #f keys)) keys)))

(define (is-uppercase? keysym)
  (let ((low.up (convert-case keysym)))
    (not (equal? (car low.up) keysym))))

(define (string->key dpy s)
  (let* ((l (reverse (split-minus s)))
	 (mod-strings (reverse (cdr l)))
	 (key-string (car l))
	 (keysym (string->keysym key-string))
	 (keycode (keysym->keycode dpy keysym))
	 (modifiers (enum-set-union (if (is-uppercase? keysym)
					(state-set shift)
					(state-set))
				    (strings->modifiers mod-strings))))
    (and modifiers keycode
	 (make-key modifiers keycode))))

(define split-minus (infix-splitter (rx "-")))
(define split-space (infix-splitter (rx " ")))

(define (strings->modifiers str-list)
  (let ((l (map string->modifiers str-list)))
    (and (not (memq #f l))
	 (fold enum-set-union
	       (state-set)
	       l))))

(define (string->modifiers s)
  (cond
   ((equal? s "C") (state-set control))
   ((equal? s "M") (state-set mod1))
   ((equal? s "M1") (state-set mod1))
   ((equal? s "M2") (state-set mod2))
   ((equal? s "M3") (state-set mod3))
   ((equal? s "M4") (state-set mod4))
   ((equal? s "M5") (state-set mod5))
   ((equal? s "S") (state-set shift)) ;; needed?
   (else #f)))

;; *** xlib utilities ************************************************

(define (reparent-to-root dpy window)
  (let ((r (root-rectangle dpy window)))
    (reparent-window dpy window (window-root dpy window)
		     (rectangle:x r) (rectangle:y r))))

(define (window-path dpy window)
  (cons window
	(let ((p (window-parent dpy window)))
	  (if (zero? p)
	      '()
	      (window-path dpy p)))))

(define (window-viewable? dpy window)
  (and window
       (let ((attrs (get-window-attributes dpy window)))
         (and attrs
              (eq? (window-attribute:map-state attrs)
                   (map-state is-viewable))))))

(define (window-mapped? dpy window)
  (and window
       (let ((attrs (get-window-attributes dpy window)))
         (and attrs
              (not (eq? (window-attribute:map-state attrs)
                        (map-state is-unmapped)))))))

(define (window-focused? dpy window)
  (eq? (get-input-focus-window dpy) window))

(define (window-contains-focus? dpy window)
  (let ((fw (get-input-focus-window dpy)))
    (or (equal? fw window)
	(window-contains-window? dpy window fw))))

(define (window-contains-window? dpy window child)
  (let ((children (or (window-children dpy window) '())))
    (or (member child children)
	(any (lambda (c)
	       (window-contains-window? dpy c child))
	     children))))

(define (take-focus dpy window time)
  ;; implements the TAKE_FOCUS protocol
  (let* ((protocols (get-wm-protocols dpy window))
	 (wm-take-focus (intern-atom dpy "WM_TAKE_FOCUS" #f))
	 (wm-hints (get-wm-hints dpy window))
	 (t (and wm-hints (assq (wm-hint input?) wm-hints)))
	 (input? (if t (cdr t) #t)))
    (if (and input? (window-viewable? dpy window))
	(set-input-focus dpy window (revert-to parent) time))
    (if (and protocols wm-take-focus
	     (memq wm-take-focus protocols))
	(send-protocol-message dpy window wm-take-focus time))))

(define (send-protocol-message dpy window atom time)
  (send-event dpy window #f (event-mask)
	      (create-client-message-event
	       (event-type client-message) 0 #t dpy window
	       (make-property (intern-atom dpy "WM_PROTOCOLS" #f)
			      (property-format long)
			      (list atom time)))))

(define (delete-window dpy window time)
  (let* ((protocols (get-wm-protocols dpy window))
	 (wm-delete-window (intern-atom dpy "WM_DELETE_WINDOW" #f)))
    (if (and protocols (member wm-delete-window protocols))
	(send-protocol-message dpy window wm-delete-window time)
	(destroy-window dpy window))))

(define (move-resize-window* dpy window rect)
  (move-resize-window dpy window
		      (rectangle:x rect) (rectangle:y rect)
		      (rectangle:width rect) (rectangle:height rect)))

(define (root-rectangle dpy win)
  (let ((r (translate-coordinates dpy win (default-root-window dpy)
				  0 0)))
    (make-rectangle (if r (car r) 0) (if r (cadr r) 0)
		    (window-width dpy win) (window-height dpy win))))

(define (window-rectangle dpy win)
  (let ((wa (get-window-attributes dpy win)))
    (make-rectangle (window-attribute:x wa) (window-attribute:y wa)
		    (window-attribute:width wa) (window-attribute:height wa))))

(define (clip-rectangle dpy win)
  (make-rectangle 0 0 (window-width dpy win) (window-height dpy win)))

(define (draw-shadow-rectangle dpy win gc r lc dc)
  (let* ((x1 (rectangle:x r))
	 (y1 (rectangle:y r))
	 (x2 (- (+ x1 (rectangle:width r)) 1))
	 (y2 (- (+ y1 (rectangle:height r)) 1)))
    (set-gc-foreground! dpy gc lc)
    (draw-lines dpy win gc (list (cons x1 y2) (cons x1 y1) (cons x2 y1))
		(coord-mode origin))
    (set-gc-foreground! dpy gc dc)
    (draw-lines dpy win gc (list (cons x2 y1) (cons x2 y2) (cons x1 y2))
		(coord-mode origin))))

(define (fill-rectangle* dpy win gc rect)
  (fill-rectangle dpy win gc (rectangle:x rect) (rectangle:y rect)
		  (rectangle:width rect) (rectangle:height rect)))

(define (invalidate-window dpy win)
  (let ((wa (get-window-attributes dpy win)))
    (clear-area dpy win 0 0 (window-attribute:width wa)
		(window-attribute:height wa) #t)))

(define (text-center-pos rect font-struct str)
  (let* ((cs (text-extents font-struct str))
	 (tw (char-struct:width cs)))
    (cons (+ (rectangle:x rect) (floor* (/ (- (rectangle:width rect) tw) 2)))
	  (+ (rectangle:y rect)
	     (floor* (/ (rectangle:height rect) 2))
	     (font-struct:descent font-struct)))))

;; maximize-window moves and resizes the window fill as much space of
;; it's parent (or the window specified with the optional
;; argument). If there is a WM_NORMAL hint present for the window, and
;; the window has to be smaller than the parent, it is centered.

(define (maximize-window dpy window . maybe-parent)
  (let ((r (apply maximal-rect/hints dpy window maybe-parent)))
    (move-resize-window dpy window (rectangle:x r) (rectangle:y r)
			(rectangle:width r) (rectangle:height r))))

(define (maximal-rect/hints dpy window . maybe-parent)
  (let ((parent (:optional maybe-parent (window-parent dpy window))))
    (let ((max-width (window-width dpy parent))
          (max-height (window-height dpy parent)))
      (let ((w.h (maximal-size/hints dpy window max-width max-height)))
	(let ((width (car w.h))
	      (height (cdr w.h)))
	  (let ((x (quotient (- max-width width) 2))
		(y (quotient (- max-height height) 2)))
	    (make-rectangle x y width height)))))))

(define (maximal-size/hints dpy window max-width max-height)
  (let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader?
    (if hints
	(adjust-size/hints hints max-width max-height)
	(cons max-width max-height))))

(define (size-window dpy window default-size)
  (let ((size (desired-size/hints dpy window default-size)))
    (configure-window dpy window
                      (make-window-change-alist
                       (width (car size))
                       (height (cdr size))))))

(define (desired-size/hints dpy window default-size)
  (let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader?
    (if hints
	(let ((size (or (assq/false (size-hint us-size) hints)
			(assq/false (size-hint size) hints)
			default-size)))
	  (adjust-size/hints hints (car size) (cdr size)))
	default-size)))

(define (desired-position/hints dpy window default-position)
  (let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader?
    (if hints
	(or (assq/false (size-hint us-position) hints)
	    (assq/false (size-hint position) hints)
	    default-position)
	default-position)))

;; returns width/height pair that conform to the defined
;; aspects/resize-inc etc. in hints, and are as close as possible to
;; width/height (but never bigger).

(define (adjust-size/hints size-hints width height)
  (let ((min-size-hint (assq (size-hint min-size) size-hints))
        (max-size-hint (assq (size-hint max-size) size-hints))
        (resize-inc-hint (assq (size-hint resize-inc) size-hints))
        (aspect-hint (assq (size-hint aspect) size-hints))
        (base-size-hint (assq (size-hint base-size) size-hints)))

    ;; respect the desired maximal size ******************************
    (if max-size-hint
        (let ((max-width (car (cdr max-size-hint)))
              (max-height (cdr (cdr max-size-hint))))
          (if (> width max-width) (set! width max-width))
          (if (> height max-height) (set! height max-height))))

    ;; ignore the minimal size, but give a warning *******************
;     (let ((hint (or min-size-hint base-size-hint))) ;; according to ICCCM
;       (if hint
;         (let* ((min-size (cdr hint))
;                (min-width (car min-size))
;                (min-height (cdr min-size)))
;           (if (or (< width min-width)
;                   (< height min-height))
;               (debug-message 1 "% has to be smaller, than the desired minimal size %."
;                              window hint)))))

    ;; respect aspect ratios *****************************************
    (if aspect-hint
        (let* ((base-width (if base-size-hint
                               (car (cdr base-size-hint))
                               0))
               (base-height (if base-size-hint
                                (cdr (cdr base-size-hint))
                                0))
               (width* (- width base-width))
               (height* (- height base-height))

               (ratio (/ width* height*))
               (min-ratio (/ (car (car (cdr aspect-hint)))
                             (cdr (car (cdr aspect-hint)))))
               (max-ratio (/ (car (cdr (cdr aspect-hint)))
                             (cdr (cdr (cdr aspect-hint)))))
               (new-ratio ratio))
          (if (> ratio max-ratio)
              (set! new-ratio max-ratio)
              (if (< ratio min-ratio)
                  (set! new-ratio min-ratio)))
          (if (< new-ratio ratio)
              (set! width* (* height* new-ratio))
              (if (> new-ratio ratio)
                  (set! height* (/ width* new-ratio))))
          (set! width (+ width* base-width))
          (set! height (+ height* base-height))))

    ;; respect resize-incs *******************************************
    (if resize-inc-hint
        (let* ((width-inc (car (cdr resize-inc-hint)))
               (height-inc (cdr (cdr resize-inc-hint)))
               (base-size-hint (or base-size-hint min-size-hint))
               (base-width (if base-size-hint
                               (car (cdr base-size-hint))
                               0))
               (base-height (if base-size-hint
                               (cdr (cdr base-size-hint))
                               0)))
          (set! width
                (+ base-width (* width-inc (quotient (- width base-width)
                                                     width-inc))))
          (set! height
                (+ base-height (* height-inc (quotient (- height base-height)
                                                       height-inc))))))

    ;; result ********************************************************
    (cons (floor* width) (floor* height))))

(define (minimal-size/hints dpy window default-width default-height)
  (let ((hints (get-wm-normal-hints dpy window)) ;; or group-leader?
	(default-size (cons default-width default-height)))
    (if hints
	(or (assq/false (size-hint min-size) hints)
	    (assq/false (size-hint base-size) hints) ;; according to ICCCM
	    default-size)
	default-size)))

(define (point-in-rectangle? r x y)
  (and (>= x (rectangle:x r))
       (>= y (rectangle:y r))
       (< x (+ (rectangle:x r) (rectangle:width r)))
       (< y (+ (rectangle:y r) (rectangle:height r)))))

(define (rectangles-overlap? r1 r2)
  (let ((x1 (rectangle:x r2))
	(y1 (rectangle:y r2))
	(x2 (+ -1 (rectangle:x r2) (rectangle:width r2)))
	(y2 (+ -1 (rectangle:y r2) (rectangle:height r2))))
    (any (lambda (p)
	   (point-in-rectangle? r1 (car p) (cdr p)))
	 (list (cons x1 y1) (cons x1 y2) (cons x2 y1) (cons x2 y2)))))

(define-enumerated-type wm-state :wm-state
  wm-state? wm-states wm-state-name wm-state-index
  (withdrawn normal wm-state-2 iconic))

(define (integer->wm-state i)
  (vector-ref wm-states i))

(define (wm-state->integer s)
  (wm-state-index s))

(define (get-wm-state dpy window)
  (let* ((ws (intern-atom dpy "WM_STATE" #f))
	 (p (get-full-window-property dpy window ws #f ws)))
    (and p
	 (eq? (property-format long) (property:format p))
	 (eq? ws (property:type p))
	 (cons (integer->wm-state (first (property:data p)))
	       (second (property:data p))))))

(define (set-wm-state! dpy window state icon-window)
  (let* ((ws (intern-atom dpy "WM_STATE" #f))
	 (p (make-property ws (property-format long)
			   (list (wm-state->integer state) icon-window))))
    (change-property dpy window ws (change-property-mode replace) p)))

(define (window-level dpy win)
  (length (window-path dpy win)))

(define (with-prevent-events dpy window event-mask thunk)
  (let* ((before (window-attribute:your-event-mask
		  (get-window-attributes dpy window)))
	 (new (enum-set-intersection before
				     (enum-set-negation event-mask))))
    (dynamic-wind
     (lambda ()
       (display-select-input dpy window new))
     thunk
     (lambda ()
       (display-select-input dpy window before)))))

(define (all-window-colormaps dpy window)
  (let ((wins (cons window
		    (let* ((a (intern-atom dpy "WM_COLORMAP_WINDOWS" #f))
			   (t (intern-atom dpy "WINDOW" #f))
			   (p (get-full-window-property dpy window a #f t)))
		      (if (and p (property:data p))
			  (property:data p)
			  '())))))
    (map (lambda (win)
	   (window-attribute:colormap 
            (get-window-attributes dpy win)))
         (filter (lambda (x) x) wins))))

(define (install-colormaps dpy window)
  (for-each (lambda (c)
	      (install-colormap dpy c))
	    (all-window-colormaps dpy window)))

(define (uninstall-colormaps dpy window)
  (for-each (lambda (c)
	      (uninstall-colormap dpy c))
	    (all-window-colormaps dpy window)))

(define (send-configuration dpy window)
  (let ((r (root-rectangle dpy window)))
    (send-event dpy window #f (event-mask structure-notify)
		(create-configure-event
		 (event-type configure-notify) 0 #t dpy window window
		 (rectangle:x r) (rectangle:y r)
		 (rectangle:width r) (rectangle:height r)
		 0 none #f))))

;; timer

(define (now)
  (call-with-values time+ticks
		    (lambda (secs ticks)
		      (+ secs (/ ticks (ticks/sec))))))

(define (at-time-rv time)
  (let ((ch (make-channel)))
    (spawn (lambda ()
	     (let ((a (* 1000 (- time (now)))))
	       (if (> a 0)
		   (sleep a))
	       (send ch 'wake))))
    (receive-rv ch)))
;    (with-nack (lambda (nack)
;		 (choose (list (receive-rv ch)
;			       nack))))))

(define (after-time-rv time)
  (at-time-rv (+ (now) time)))