;; infinite-desktop.jl -- make the virtual desktop bigger than the physical
;; $Id: infinite-desktop.jl,v 1.33 2008/02/05 06:48:02 chrisb Exp $

;; Copyright (C) 2008 David T. McWherter <udmcwher@mcs.drexel.edu>

;; 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.infinite-desktop

	(export )

	(open rep
	      rep.system
	      sawfish.wm.misc
	      sawfish.wm.custom
	      sawfish.wm.commands.move-cursor
	      sawfish.wm.viewport
	      sawfish.wm.util.prompt
	      sawfish.wm.util.flippers
	      sawfish.wm.ext.edge-flip)

	(define-structure-alias infinite-desktop sawfish.wm.ext.infinite-desktop)

;;
;; Remove our hooks if they're already installed -
;; allows us to be imported multiple times safely.
;;

(define (infinite-desktop.remove a l)
  (cond ((not l) nil)
	((eq a (car l)) (infinite-desktop.remove a (cdr l)))
	(t (cons (car l) (infinite-desktop.remove a (cdr l))))))

(defgroup infinite-desktop "Infinite Desktop"
  :group workspace)

(defcustom infinite-desktop-p 1
  "Simulate an infinite desktop (Conflicts edge-flipping)."
  :group (workspace infinite-desktop)
  :after-set (lambda () (infinite-desktop.infinite-desktop))
  :type boolean)

(defcustom infinite-desktop.move-distance 64
  "Amount to move the workspace."
  :group (workspace infinite-desktop)
  :type number
  :range (1 . nil))

(defcustom infinite-desktop.move-cursor-distance 32
  "Amount to move the cursor after moving the workspace."
  :group (workspace infinite-desktop)
  :type number
  :range (1 . nil))

(defcustom infinite-desktop.stop-at-workspace-borders nil
  "Stop scrolling at workspace borders (Fixes warp-to-window bugs)."
  :group (workspace infinite-desktop)
  :type boolean )

(define (infinite-desktop.move-right)
  (let ((dist infinite-desktop.move-distance)
	(cdist infinite-desktop.move-cursor-distance)
	(maxx (* (screen-width) (1- (car viewport-dimensions)))))
    (if
	(and infinite-desktop.stop-at-workspace-borders
	     (> (+ dist viewport-x-offset) maxx))
	(setq dist (- maxx viewport-x-offset)))
    (set-viewport (+ viewport-x-offset dist) viewport-y-offset)
    (move-cursor (- (min dist cdist)) 0)))

(define (infinite-desktop.move-left)
  (let ((dist (- infinite-desktop.move-distance))
	(cdist (- infinite-desktop.move-cursor-distance))
	(minx 0))
    (if
	(and infinite-desktop.stop-at-workspace-borders
	     (< (+ viewport-x-offset dist) minx))
	(setq dist (- minx viewport-x-offset)))
    (set-viewport (+ viewport-x-offset dist) viewport-y-offset)
    (move-cursor (max dist cdist) 0)))

(define (infinite-desktop.move-top)
  (let ((dist (- infinite-desktop.move-distance))
	(cdist (- infinite-desktop.move-cursor-distance))
	(miny 0))
    (if
	(and infinite-desktop.stop-at-workspace-borders
	     (< (+ viewport-y-offset dist) miny))
	(setq dist (- miny viewport-y-offset)))
    (set-viewport viewport-x-offset (+ viewport-y-offset dist))
    (move-cursor 0 (max dist cdist))))

(define (infinite-desktop.move-bottom)
  (let ((dist infinite-desktop.move-distance)
	(cdist infinite-desktop.move-cursor-distance)
	(maxy (* (screen-height) (1- (cdr viewport-dimensions)))))
    (if
	(and infinite-desktop.stop-at-workspace-borders
	     (> (+ dist viewport-y-offset) maxy))
	(setq dist (- maxy viewport-y-offset)))
    (set-viewport viewport-x-offset (+ viewport-y-offset dist))
    (move-cursor 0 (- (min dist cdist)))))

(define (infinite-desktop.enter-flipper-hook w)
  (if infinite-desktop-p
      (cond ((eq w 'right) (infinite-desktop.move-right))
	    ((eq w 'left) (infinite-desktop.move-left))
	    ((eq w 'bottom) (infinite-desktop.move-bottom))
	    ((eq w 'top) (infinite-desktop.move-top))
	    (t (display-message "move-unknown")))))

(define (infinite-desktop.infinite-desktop)
  (if infinite-desktop-p
      (enable-flippers)))

(unless batch-mode
  (add-hook 'enter-flipper-hook infinite-desktop.enter-flipper-hook)))
