;; merlin/pile.jl -- a bad pile

;; version -0.3.1

;; Copyright (C) 2002 merlin <merlin@merlin.org>

;; http://merlin.org/sawfish/

;; This is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with sawfish; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;;;;;;;;;;;;;;;;;;;;
;; HERE BE DRAGONS ;;
;;;;;;;;;;;;;;;;;;;;;

;; This software requires a patch to be applied to the Sawfish source to
;; add some additional XLib bindings.

;; Please see x.c.patch.

;;;;;;;;;;;;;;;;;;
;; INSTALLATION ;;
;;;;;;;;;;;;;;;;;;

;; Create a directory ~/.sawfish/lisp/merlin and then put this file there:
;;   mkdir -p ~/.sawfish/lisp/merlin
;;   mv pile.jl ~/.sawfish/lisp/merlin

;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl.

;; You're probably best off unpacking the entire merlin.tgz archive.

;; Then add to your .sawfishrc:
;;   (require 'merlin.pile)
;;   (defpile pile)
;;   ; `pile' is the name of the pile; you can choose any name you
;;   ; want, and have multiple piles.

;; Then restart sawfish. A pile should appear.

;; Go to Customize->Sawlets->Pile
;;      - Here you can customize the behaviour of the pile.

;; Next, go to Customize->Matched Windows
;;      - Here you must add a matched window setting for any fish that you
;;        want captured to have Place mode pile.

;; Now, restart your apps. Hopefully they'll be in the pile.

;; You can create multiple piles and can configure them programatically
;; at creation if you want..

;;;;;;;;;;;;;;;;;;
;; HERE BE BUGS ;;
;;;;;;;;;;;;;;;;;;

;; This is PRE-ALPHA INCOMPLETE SOFTWARE!

;; this is a bit hacky!

;; todo: should I tell windows they've moved??

;; see fishbowl

;; beos-window-menu is hardwired in, which may not be cool

;;;;

(define-structure merlin.pile
  (export
   defpile
   pile-p
   popup-pile-menu
   pile-window-menu)

  (open
   rep
   rep.regexp
   rep.system
   rep.io.timers
   sawfish.wm.colors
   sawfish.wm.commands
   sawfish.wm.events
   sawfish.wm.fonts
   sawfish.wm.frames
   sawfish.wm.menus
   sawfish.wm.placement
   sawfish.wm.misc
   sawfish.wm.stacking
   sawfish.wm.windows
   sawfish.wm.ext.beos-window-menu
   sawfish.wm.util.display-window
   sawfish.wm.util.x
   merlin.sawlet
   merlin.util
   merlin.x-util)

  ;;

  (define (pile-p sawlet)
    (memq sawlet piles))

  (define (dimensions pile)
    (if (sawlet-active pile)
	(window-dimensions (sawlet-frame pile))
      (cons 64 64)))

  (define piles nil)

  (define (start pile)
    (setq piles (nconc piles (list pile)))
    (mapc
      (lambda (window)
        (when (eq pile (window-get window 'place-mode))
          (after-add-window-eye window)))
      (managed-windows)))
        
  (define (mapchattelry thunk pile)
    (let*
        ((chattelry (sawlet-get pile 'merlin.pile:chattelry)))
      (mapc
        (lambda (chattel)
          (thunk chattel))
        chattelry)))

  (define (stop pile)
    (let*
        ((base (window-position (sawlet-frame pile))))
      (setq piles (delq pile piles))
      (mapchattelry 
        (lambda (chattel)
;;         (x-reparent-window (car chattel) nil base) -- doesn't work anymore
           (x-map-request (car chattel)))
        pile)
      (sawlet-put pile 'merlin.pile:chattelry nil)))

  (define (capture pile)
    (let*
        ((window (select-window)))
      (when (and window (not (eq window (sawlet-frame pile))))
        (window-put window 'place-mode pile)
        (after-add-window-eye window))))

  (define (eject pile id)
    (let*
        ((base (window-position (sawlet-frame pile))))
      (mapchattelry
        (lambda (chattel)
          (when (eq id (car chattel))
            (sawlet-put pile 'suspend t)
;;          (x-reparent-window id nil base) -- doesn't work anymore?
            (x-map-request id)
            (sawlet-put pile 'suspend nil))) 
        pile)
      (sawlet-put pile 'merlin.pile:chattelry
        (delete-if (lambda (chattel) (eq id (car chattel))) (sawlet-get pile 'merlin.pile:chattelry)))
      (sawlet-reconfigure pile)))

  (define (raise pile id)
    (let (match) ; this is awful; move to front of list
      (mapchattelry
        (lambda (chattel)
          (when (eq id (car chattel)) (setq match chattel)))
        pile)
      (sawlet-put pile 'merlin.pile:chattelry
        (cons match (delete-if (lambda (chattel) (eq id (car chattel))) (sawlet-get pile 'merlin.pile:chattelry)))))
    ;; raising is not necessary if I move the others off..
    ;; (x-configure-window id `((stack-mode . top-if)))
    (replace pile)) ;; awful

  (define (constrain value hints axis) ;; TODO: min-aspect / max-aspect
    (let
	((minn (or (cdr (assq (intern (format nil "min-%s" axis)) hints)) 1))
	 (maxx (or (cdr (assq (intern (format nil "max-%s" axis)) hints)) 10000))
	 (base (or (cdr (assq (intern (format nil "base-%s" axis)) hints)) 0))
	 (inc (or (cdr (assq (intern (format nil "%s-inc" axis)) hints)) 1)))
      (max minn (min maxx (+ base (* inc (quotient (- value base) inc)))))))

  (define (replace pile)
    (let
        ((root (sawlet-get pile 'root))
         (chattel (car (sawlet-get pile 'merlin.pile:chattelry)))
         (dim (cons- (dimensions pile) 10)) ; for demo purposes
         (x 0) (y 0))
      (x-set-wm-name root
        (if chattel
            (format nil "%s - %s" pile 
              (aref (x-get-text-property (car chattel) 'WM_NAME) 0))
          "pile"))
      (mapchattelry
        (lambda (chattel)
	  (let
	      ((width (constrain (car dim) (nth 2 chattel) 'width))
	       (height (constrain (cdr dim) (nth 2 chattel) 'height)))
	    (x-configure-window
	     (car chattel) `((x . ,x) (y . ,y) (width . ,width) (height . ,height))))
          (setq x (car dim) y (cdr dim)))
        pile)))

  ; TODO: now that I have x-get-window-properties I could query the size hints
  ; during replace, rather than storing them here..
  ; TODO: would it be better to do this in add-window-hook? Wouldn't get framed
  ; before it is deframed...
  (define (after-add-window-eye window)
    (let*
        ((pile (window-get window 'place-mode)))
      (when (and (memq pile piles) (not (sawlet-get pile 'suspend)))
        (let*
            ((id (window-id window))
             (dim (window-dimensions window))
             (chattelry (sawlet-get pile 'merlin.pile:chattelry))
	     (hints (window-size-hints window)))
          (x-change-window-attributes id `((override-redirect . ,t)))
          (x-map-notify id) ; this removes it from window-manager
          (x-change-window-attributes id `((override-redirect . ,nil)))
          (x-configure-window id `((border-width . 0)))
          (x-reparent-window id (sawlet-get pile 'window) (cons 0 0))
          (sawlet-put pile 'merlin.pile:chattelry (cons (list id dim hints) chattelry))
          (sawlet-reconfigure pile)
          (x-x-map-window id)))))

  (add-hook 'after-add-window-hook after-add-window-eye)

  ;;

  (define (abbreviate name #!optional len)
    (unless len (setq len 20))
    (if (> (length name) len)
        (concat (substring name 0 len) "...")
      name))

  (define (make-pile-menu pile thunk)
    (let ((chattelry (sawlet-get pile 'merlin.pile:chattelry)))
      (mapcar
       (lambda (chattel)
	 (list (abbreviate (aref (x-get-text-property (car chattel) 'WM_NAME) 0))
	       (lambda () (thunk chattel))
	       (cons 'check (and (eq chattel (car chattelry))))
	       (cons 'group (sawlet-symbol pile 'window-menu))))
       chattelry)))

  (define (popup-pile-menu window)
    (let*
        ((pile (sawlet-from-frame window)))
      (when (memq pile piles)
        (popup-menu 
          `((,(_ "_Capture") ,(lambda () (capture pile)))
            (,(_ "_Raise") .
              ,(make-pile-menu pile (lambda (chattel) (raise pile (car chattel)))))
            (,(_ "_Eject") .
              ,(make-pile-menu pile (lambda (chattel) (eject pile (car chattel))))))))))

  (define-command 'popup-pile-menu popup-pile-menu #:spec "%W")

  ;;

;; ignore attempts by piled windows to move/resize themselves
  (define (configure-request-handler pile event)
;    (let
;        ((id (cdr (assq 'window event)))
;         (width (cdr (assq 'width event)))
;         (height (cdr (assq 'height event)))
;         (chattelry (sawlet-get pile 'merlin.pile:chattelry)))
;      (mapc
;        (lambda (chattel)
;          (when (and (equal id (car chattel)))
;            (rplaca (cdr chattel) (cons width height))
;            (sawlet-reconfigure pile))) chattelry))
    t)

  (define (destroy-notify-handler pile event)
    (let*
        ((id (cdr (assq 'window event)))
         (chattelry (sawlet-get pile 'merlin.pile:chattelry)))
      (sawlet-put pile 'merlin.pile:chattelry
        (delete-if (lambda (chattel) (eq id (car chattel))) chattelry))
      (sawlet-reconfigure pile))
    nil)

  (define (expose-handler pile event)
    (x-clear-window (sawlet-get pile 'window))
    nil)

  (define (button-press-handler pile event)
    (popup-pile-menu (sawlet-frame pile))
    nil)

  (define (pre pile)
    (define-placement-mode pile (lambda (window))))

  (define (pile-window-menu pile)
    (or (make-pile-menu pile (lambda (chattel)
          (raise pile (car chattel))
	  (display-window (sawlet-frame pile))))
      (list (list "<empty>" (lambda () (display-window (sawlet-frame pile)))))))

  (eval-in ; make the window-menu display pile contents
   `(progn
      (require 'merlin.pile)
      (require 'merlin.sawlet)
      (define (make-item w)
	(fluid-set windows-left (delq w (fluid windows-left)))
	(if (pile-p (sawlet-from-frame w))
	    (cons (make-label w) (lambda () (pile-window-menu (sawlet-from-frame w))))
	  (list (make-label w)
		(lambda ()
		  (when (windowp w)
		    (display-window w)))
		(cons 'check (and (eq (input-focus) w)))
		'(group . beos-window-menu)))))
   'sawfish.wm.ext.beos-window-menu)

  (defmacro defpile (pile . keys)
    `(progn
      (require 'merlin.sawlet)
      ,(append
        `(defsawlet ,pile
        :pre ,pre)
        keys ; allow override
        `(:start ,start
        :stop ,stop
        :post-configure ,replace
	:wm-size-hints ,(lambda () (cons nil nil))
        :dimensions ,dimensions
        :expose-handler ,expose-handler
        :button-press-handler ,button-press-handler
        :destroy-notify-handler ,destroy-notify-handler
        :configure-request-handler ,configure-request-handler
        :font ,nil
        :foreground ,nil
        :background ,(get-color-rgb 0 0 0)
	:matcher-actions '((place-mode . ,place-window-mode) (frame-type . normal)
          (never-focus . #f) (sticky . #f) (sticky-viewport . #f) (window-list-skip . #f) (skip-tasklist . #f))
        )))))