#| sawfish.wm.ext.pager -- Code for communicating with C pager

   http://dapfy.bei.t-online.de/sawfish/pager/

   Copyright (C) 2002 Daniel Pfeiffer <occitan@esperanto.org>
   Copyright (C) 2000 Satyaki Das <satyaki@theforce.stanford.edu>
		      Ryan Lovett <ryan@ocf.Berkeley.EDU>
		      Andreas Buesching <crunchy@tzi.de>
		      Hakon Alstadheim

   This file is part of sawfish.

   sawfish 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.

   sawfish 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.

|#

(define-structure sawfish.wm.ext.pager

    (export pager
	    send-background-file

	    pager-change-depth
	    pager-goto
	    pager-move-window
	    pager-tooltip)

    (open rep
	  rep.io.files
	  rep.io.processes
	  rep.system
	  sawfish.wm.colors
	  sawfish.wm.custom
	  sawfish.wm.ext.tooltips
	  sawfish.wm.fonts
	  sawfish.wm.misc
	  sawfish.wm.stacking
	  sawfish.wm.util.window-order
	  sawfish.wm.viewport
	  sawfish.wm.windows
	  sawfish.wm.workspace)

;;; Customization code contributed by Ryan Lovett <ryan@ocf.Berkeley.EDU>
  (defgroup pager "Pager")

  ;; closures for out of scope call
  (let ((state (lambda () (send-windows)))
	(resize (lambda () (send-size t)))
	(color (lambda () (send-colors))))

    (defcustom pager-show-ignored-windows nil
      "Show ignored windows"
      :type boolean
      :group pager
      :after-set state)

    (defcustom pager-show-all-workspaces t
      "Show all workspaces"
      :type boolean
      :group pager
      :after-set resize)

    (defcustom pager-workspaces-per-column 1
      "The number of workspaces per column"
      :type number
      :range (1)
      :depends pager-show-all-workspaces
      :group pager
      :after-set resize)

    (defcustom pager-stickies-on-all-workspaces t
      "Show (workspace) sticky windows on all their workspaces"
      :type boolean
      :depends pager-show-all-workspaces
      :group pager
      :after-set state)

    (defcustom pager-stickies-on-all-viewports t
      "Show (viewport) sticky windows on all their viewports"
      :type boolean
      :group pager
      :after-set state)

    (defcustom pager-shrink-factor 32
      "Each length in the pager is this many times shorter than the original"
      :type number
      :group pager
      :after-set resize)

    (defcustom pager-focus t
      "Whether Button1 focuses the clicked window"
      :type boolean
      :group pager)

    (defcustom pager-warp-cursor nil
      "Whether Button1 warps the cursor to the clicked point"
      :type boolean
      :group pager)

    (defcustom pager-color-window (get-color "#8080d0")
      "Windows"
      :type color
      :group pager
      :after-set color)

    (defcustom pager-color-focus-window (get-color "#58a8ff")
      "Window with input focus"
      :type color
      :group pager
      :after-set color)

    (defcustom pager-color-window-border (get-color "#606060")
      "Window borders"
      :type color
      :group pager
      :after-set color)

    (defcustom pager-color-viewport (get-color "#f0f0f0")
      "Current viewport color"
      :type color
      :group pager
      :after-set color)

    (defcustom pager-background ""
      "Pager background, a XPM file"
      :type file-name
      :tooltip "Create this from a pager screenshot in a paint program."
      :group pager
      :after-set (lambda () (send-background-file)))

    (defcustom pager-color-background (get-color "#d8d8d8")
      "Pager background"
      :type color
      :group pager
      :after-set color)

    (defcustom pager-color-viewport-divider (get-color "#e8e8e8")
      "Lines separating viewports"
      :type color
      :group pager
      :after-set color)

    (defcustom pager-color-workspace-divider (get-color "#202020")
      "Lines separating workspaces"
      :type color
      :group pager
      :after-set color))


  (defcustom pager-tooltips-enabled t
    "Enable display of window labels"
    :type boolean
    :group pager)

  (defvar pager-executable
    (if (file-exists-p "~/.sawfish/pager")
	(concat (user-home-directory) "/.sawfish/pager")
      (concat sawfish-exec-directory "/pager")))

  ;; Remembers the number of workspaces...
  (define ws-limits)

  ;; Remembers the viewport dimensions...
  (define vp-rows)
  (define vp-columns)

  (define vp-width)
  (define vp-height)

  (define ws-width)
  (define ws-height)
  (define ws-list)

  (define pager-width)
  (define pager-height)

  (define process nil)
  (define hooks
    '((after-move-hook . send-window)
      (after-resize-hook . send-window)
      (after-restacking-hook . send-windows)
      (enter-workspace-hook . send-viewport)
      (destroy-notify-hook . send-windows)
      (focus-in-hook . send-focus)
      (focus-out-hook . send-focus)
      (map-notify-hook . send-windows)
      (unmap-notify-hook . send-windows)
      (viewport-moved-hook . send-viewport)
      (viewport-resized-hook . send-size)
      (window-moved-hook . send-window)
      (window-resized-hook . send-window)
      (window-state-change-hook . send-window)
      (workspace-state-change-hook . send-size)))

  (define cache)

;;; Internal utilities

  ;; This is just to scale the window co-ords and dimensions.
  (define-macro (scale val #!optional x up)
    (if x
	(if up
	    `(round (/ (* ,val (screen-width)) vp-width))
	  `(round (/ (* ,val vp-width) (screen-width))))
      (if up
	  `(round (/ (* ,val (screen-height)) vp-height))
	`(round (/ (* ,val vp-height) (screen-height))))))

  (define (get-window-info w)
    (if (or (not (window-id w))
	    (not (window-mapped-p w))
	    (window-get w 'iconified)
	    (get-x-property w '_NET_WM_STATE_SKIP_PAGER)
	    (unless pager-show-ignored-windows (window-get w 'ignored)))
	0
      (let* ((x (car (window-position w)))
	     (y (cdr (window-position w)))
	     (dim (window-frame-dimensions w))
	     (l1 (if pager-show-all-workspaces
		     (or (mapcar (lambda (ws)
				   (nth (- ws (car ws-limits)) ws-list))
				 (window-workspaces w))
			 (if (and pager-stickies-on-all-workspaces
				  (window-get w 'sticky))
			     ws-list
			   (list (nth (- current-workspace (car ws-limits)) ws-list))))
		   (list (car ws-list)))))
	(setq dim `(,(max 3 (scale (car dim) 'x)) ,(max 3 (scale (cdr dim)))))
	(if (and pager-stickies-on-all-viewports
		 (or (> vp-rows 1) (> vp-columns 1))
		 (window-get w 'sticky-viewport))
	    (let* ((vxo (mod viewport-x-offset (screen-width)))
		   (vyo (mod viewport-y-offset (screen-height)))
		   (j1 (- vp-rows (if (> vyo 0) 2 1)))
		   (wh `(,vp-width ,vp-height)))
	      (setq x (scale (+ x vxo) 'x)
		    y (scale (+ y vyo)))
	      (let loop ((l l1)
			 (i (- vp-columns (if (> vxo 0) 2 1)))
			 (j j1)
			 r)
		(cond ((< i 0)
		       r)
		      ((< j 0)
		       (loop l (1- i) j1 r))
		      (l
		       (loop (cdr l) i j
			     `((,(window-id w)
				,(+ x (* i vp-width) (caar l))
				,(+ y (* j vp-height) (cadar l))
				,dim
				,(+ (scale vxo 'x) (* i vp-width) (caar l))
				,(+ (scale vyo) (* j vp-height) (cadar l))
				,@wh)
			       ,@r)))
		      ((loop l1 i (1- j) r)))))
	  (setq x (scale (+ x viewport-x-offset) 'x)
		y (scale (+ y viewport-y-offset)))
	  (mapcar (lambda (ws)
		    `(,(window-id w)
		      ,(+ x (car ws))
		      ,(+ y (cadr ws))
		      ,dim
		      ,@ws))
		  l1)))))

;;; Functions that talk to the C program

  ;; do a bit of caching to save redundant commands
  (define-macro (send f #!rest args)
    `(when process
       (let ((s (format nil ,(concat f (if (stringp f) "\n" "%s\n")) ,@args))
	     (c (assq ,(char-downcase (if (stringp f) (aref f 0) f))
		      cache)))
	 (unless (equal (cdr c) s)
	   (write process (setcdr c s))))))

  ;; Tells the C program to change the colors
  (define (send-colors)
    (send ?c
	  (mapcar color-rgb
		  (list pager-color-background
			pager-color-viewport
			pager-color-window
			pager-color-focus-window
			pager-color-window-border
			pager-color-viewport-divider
			pager-color-workspace-divider))))

  (define (send-background-file #!optional file)
    "Tells the C program to change the pager-background from FILE."
    (if file (setq pager-background file))
    (send ?b pager-background))

  ;; Sends window-id of focussed window (or 0 if none is focussed)
  (define (send-focus #!rest args)
    (declare (unused args))
    (send "f%d"
	  (if (input-focus)
	      (window-id (input-focus))
	    0)))

  ;; calculates all kinds of sizes and tells the pager
  (define (send-size #!optional force init)
    (let* ((wsl (workspace-limits))
	   (n (- (cdr wsl) (car wsl))))
      (unless (and (not force)
		   (equal wsl ws-limits)
		   (eql (car viewport-dimensions) vp-columns)
		   (eql (cdr viewport-dimensions) vp-rows))
	(setq ws-limits wsl
	      vp-columns (car viewport-dimensions)
	      vp-rows (cdr viewport-dimensions)
	      vp-width (quotient (screen-width) pager-shrink-factor)
	      vp-height (quotient (screen-height) pager-shrink-factor)
	      ws-width (1+ (* vp-columns vp-width))
	      ws-height (1+ (* vp-rows vp-height))
	      pager-width (if pager-show-all-workspaces
			      (* ws-width
				 (ceiling (/ (1+ n) pager-workspaces-per-column)))
			    ws-width)
	      pager-height (if pager-show-all-workspaces
			       (* ws-height
				  (min (1+ n) pager-workspaces-per-column))
			     ws-height))
	(let ((ws-w `(,(1- ws-width) ,(1- ws-height))))
	  (let loop ((i n)
		     r)
	    (if (< i 0)
		(setq ws-list r)
	      (loop (1- i)
		    (if pager-show-all-workspaces
			`((,(+ 1 (quotient i pager-workspaces-per-column)
			       (* vp-columns vp-width
				  (quotient i pager-workspaces-per-column)))
			   ,(+ 1 (mod i pager-workspaces-per-column)
			       (* vp-rows vp-height
				  (mod i pager-workspaces-per-column)))
			   ,@ws-w)
			  ,@r)
		      `((1 1 ,@ws-w) ,@r))))))
	(send "s%d %d %d %d %d %d %d"
	      (if pager-show-all-workspaces 1 0)
	      vp-width vp-height
	      ws-width ws-height
	      pager-width pager-height))
      (or init (send-windows))))

  ;; Send the viewport that is in focus.
  (define (send-viewport #!rest args)
    (setq args (nth (- current-workspace (car ws-limits)) ws-list))
    (send "v%d %d %d %d"
	  (car args) (cadr args)
	  (scale viewport-x-offset 'x)
	  (scale viewport-y-offset))
    ;; should send only stickies instead, and only depending on options
    (send-windows))

  ;; When only the size or shading of a window changes send only the data
  ;; pertaining to that window.
  (define (send-window w #!rest args)
    (if (or (memq (caar args) '(sticky iconified))
	    (if pager-show-all-workspaces
		(cdr (window-workspaces w)))
	    (if pager-stickies-on-all-viewports
		(window-get w 'sticky-viewport))
	    (and pager-show-all-workspaces
		 pager-stickies-on-all-workspaces
		 (window-get w 'sticky)))
	(send-windows)
      (send ?w (get-window-info w))))

  ;; Tell the C program what to display.  For each window we send five
  ;; integers: window id, position and dimensions.
  (define (send-windows #!rest args)
    (declare (unused args))
    (send ?W
	  (mapcar get-window-info
		  (if pager-show-all-workspaces
		      (stacking-order)
		    (filter (lambda (w)
			      (let ((ws (window-workspaces w)))
				(or (null ws)
				    (member current-workspace ws))))
			    (stacking-order))))))



  (define (pager #!optional plug-to stop)
    "This function (re)starts the pager.
Optional PLUG-TO, if set, must be the numerical X id of the window to try
to plug in to.
Optional STOP, if non-nil, stops the pager instead."
    (when process
      (kill-process process)
      (setq process nil))
    (unless stop
      (setq process
	    (make-process () (lambda ()
			       (and process
				    (not (process-in-use-p process))
				    (setq process nil))))
	    cache
	    (mapcar list '(?w ?f ?v ?s ?c ?b)))
      (if plug-to
	  (set-process-args process (list (number->string plug-to))))
      (start-process process pager-executable)
      (send-colors)
      (send-background-file)
      (send-size t t)
      (send-viewport)
      (send-focus)
      (condition-case err-info
	(mapc (lambda (hook)
		(unless (in-hook-p (car hook) (symbol-value (cdr hook)))
		  (add-hook (car hook) (symbol-value (cdr hook)) t)))
	      hooks)
	(error
	 (format standard-error "pager: error adding hooks %s\n" err-info)))))

;;; Functions called from C program for 3 buttons and tooltips

  (define (pager-goto w x y)
    "Change to viewport and/or workspace where the user clicked on the pager."
    (let ((ws (if pager-show-all-workspaces
		  (+ (* pager-workspaces-per-column (quotient x ws-width))
		     (quotient y ws-height))
		current-workspace))
	  (x1 (scale (1- (mod x ws-width)) 'x 'up))
	  (y1 (scale (1- (mod y ws-height)) () 'up)))
      (setq x (quotient x1 (screen-width))
	    y (quotient y1 (screen-height)))
      (if (eql ws current-workspace)
	  (set-screen-viewport x y)
	(select-workspace-and-viewport ws x y))
      (if pager-warp-cursor
	  (warp-cursor (% x1 (screen-width))
		       (% y1 (screen-height))))
      (and pager-focus
	   (setq w (get-window-by-id w))
	   (set-input-focus w))))

  (define (pager-change-depth w)
    "Raise or lower the window clicked on in the pager."
    (if (setq w (get-window-by-id w))
	(raise-lower-window w)))

  (define-macro (bound lower var upper)
    `(setq ,var (if (< ,var ,lower)
		    ,lower
		  (if (> ,var ,upper)
		      ,upper
		    ,var))))

  (define (pager-move-window w x y width height mouse-x mouse-y)
    "Moves window with id ID to co-ordinates (X, Y) where (X, Y) is what the
pager thinks the position of the window is."
    (when (setq w (get-window-by-id w))
      (bound (- 4 width) x (- pager-width 4))
      (bound (- 4 height) y (- pager-height 4))
      (bound 1 mouse-x (1- pager-width))
      (bound 1 mouse-y (1- pager-height))
      (setq x (- (scale (- (% mouse-x ws-width) (- mouse-x x) 1) 'x 'up)
		 viewport-x-offset)
	    y (- (scale (- (% mouse-y ws-height) (- mouse-y y) 1) () 'up)
		 viewport-y-offset))
      (when (window-get w 'sticky-viewport)
	(setq x (% x (screen-width))
	      y (% y (screen-height))))
      (move-window-to w x y)
      (when pager-show-all-workspaces
	(let* ((ws (+ (* pager-workspaces-per-column (quotient mouse-x ws-width))
		      (quotient mouse-y ws-height)))
	       (cws (window-workspaces w))
	       (was-focused (eq (input-focus) w))
	       (orig-space (if (window-in-workspace-p w current-workspace)
			       current-workspace
			     (car cws)))
	       (new-space (workspace-id-from-logical ws)))
	  (and cws (null (cdr cws))
	       (not (eql ws (car cws)))
	       orig-space
	       (progn
		 (copy-window-to-workspace w orig-space new-space nil)
		 (if (eql orig-space current-workspace)
		     (delete-window-instance w))
		 (move-window-to-workspace w orig-space new-space was-focused)))))))

  (define (pager-tooltip #!optional id)
    "Show a tooltip for window ID, or remove it if no ID given."
    (when pager-tooltips-enabled
      (if (and id
	       (setq id (get-window-by-id id))
	       (setq id (window-name id)))
	  (let ((te tooltips-enabled)
		(tooltips-enabled t))
	    (display-tooltip-after-delay
	     (if te
		 (concat id "\n\n"
			 (_ "Button1-Click  select viewport (and optionally window)
Button2-Click  raise/lower window
Button3-Move   drag window"))
	       id)))
	(remove-tooltip)))))