;; virtual.gwm --- Virtual Screen 
;;
;; Author: Anders Holst  (aho@sans.kth.se)  
;; Copyright (C) 1995  Anders Holst
;; Version: virtual-1.0
;; Last change: 25/10 1996
;;
;; This file is copyrighted under the same terms as the rest of GWM
;; (see the X Inc license for details). There is no warranty that it
;; works. 
;;
;; --------------------------------------------------------------------- 
;;
;; NOTE: To use this virtual screen in other profiles then the VTWM
;; profile, load "load-virtual.gwm" instead, which sets up the
;; necessary environment and loads the relevant files.
;; 
;; This code is inspired by and in large parts stolen from the vscreen
;; code my Emanuel Jay Berkenbilt, MIT.
;;
;; Differences from vscreen.gwm include:
;;  * The map looks neater, and the colors are highly customable.
;;  * It is updated automatically when the window configuration changes.
;;  * You can move the real screen or specific windows by clicking or
;;    dragging on the map.
;;
;; A good function to put into the window menu is '(virtual-toggle-nail)',
;; a function for the root-menu is '(virtual-toggle)', and something
;; to call from eg. an icon manager is '(virtual-make-window-visible)'.
;;
;; I hope that the variables below are self explanatory. However, the
;; variable 'virtual-fancy-colors' might need an explanation, via an
;; example:
;; 
;; (setq virtual-fancy-colors (list
;;   (list black (color-make "lightgray")) ; real screen border and background
;;   (list 'Emacs black (color-make "lightpink"))    ; emacs border and bg
;;   (list 'XTerm black (color-make "lightskyblue")) ; xterm border and bg
;;   (list t black white)))                ; all other windows
;;
 
(declare-screen-dependent
  virtual-modifiers 
  virtual-omit-nailed
  virtual-omit-list
  virtual-show-filled
  virtual-fancy-colors 
  virtual-xpos
  virtual-ypos
  virtual-pixsize
  virtual-background
  virtual-foreground
  virtual-title-font
  virtual-title-position
  virtual-horizontal-step
  virtual-vertical-step
  virtual-nailed-list
  virt-added-window
  virt-removed-window
  virt-pos
  virt-wind
  virt-pix
  )

;;
;;    USER CUSTOMIZABLE VARIABLES
;;    ---------------------------  
;;    Adjust these in your own profile
;;
(for screen (list-of-screens)
     (defaults-to
       show-virtual t                  ; Show the map of the virtual screen
       virtual-modifiers (together with-control with-alt) ; modifs for arrow keys
       virtual-omit-nailed t           ; if t, map shows only non-nailed windows
       virtual-omit-list ()            ; list of windows not shown in map
       virtual-show-filled t           ; windows not drawn transparent in map
       virtual-fancy-colors ()         ; list of (wind-class fg bg) specs.

       virtual-xpos 0                  ; original position of map
       virtual-ypos 0                    
       virtual-pixsize 160             ; size of the map
       virtual-background white        ; default background of the map
       virtual-foreground black        ; default window frame color on the map
       virtual-title-font ()           ; font of window titles in the map
       virtual-title-position ()       ; position of titles in the map, could be
                                       ; top, center, bottom, above, or below.
       
       virtual-horizontal-step (/ screen-width 2)  ; amount to move by keys
       virtual-vertical-step (/ screen-height 2)
       
       virtual-nailed-list '(Gwm)      ; initially nailed windows
       )
)

(for screen (list-of-screens)    ; Dont touch these
     (setq virt-pos (list 0 0))
     (setq virt-added-window ())
     (setq virt-removed-window ())
)

;; Note: Uses 'matches-list' from vtwm.gwm

(defun virtual-nailed ()
  ;; Determine whether the current window is nailed or not.
  (if (setq tmp (# 'nailed window-window))
    (not (= 'no tmp))
    (if (or (matches-list virtual-nailed-list)
            (and (= window-client-class 'Gwm)
                 (= window-name 'virtual)))
        (progn
          (virtual-nail)
          t)
        (progn
          (virtual-unnail)
          ()))))

(defun virtual-nail ()
  (## 'nailed window-window t))

(defun virtual-unnail ()
  (## 'nailed window-window 'no))

(defun virtual-toggle-nail ()
  (if (virtual-nailed)
      (virtual-unnail)
    (virtual-nail))
  (if virtual-omit-nailed
      (virtual-update)))

(defun virt-movable ()
  ;; Returns a list of movable windows
  (with (movable nil)
    (for wob (list-of-windows 'window)
         (if (not (virtual-nailed))
             (setq movable (+ movable (list window)))))
    movable))

(defun virtual-move-windows (deltax deltay)
  ;; Moves windows by deltax and deltay adjusting virt-pos 
  ;; appropriately
  (with (move-window-func (if (boundp 'move-window-orig) 
                              move-window-orig   ; to work with vtwm profile
                              move-window))
    (for wob (virt-movable)
         (move-window-func (+ window-x deltax) (+ window-y deltay))))
  (with (x (# 0 virt-pos) y (# 1 virt-pos))
	(setq virt-pos (list (+ x deltax) (+ y deltay))))
  (virtual-update))

(defun virtual-move-left ()
  (virtual-move-windows virtual-horizontal-step 0))

(defun virtual-move-right ()
  (virtual-move-windows (- virtual-horizontal-step) 0))

(defun virtual-move-up ()
  (virtual-move-windows 0 virtual-vertical-step))

(defun virtual-move-down ()
  (virtual-move-windows 0 (- virtual-vertical-step)))

(defun virtual-move-home ()
  (virtual-move-windows (- (# 0 virt-pos))
                        (- (# 1 virt-pos))))

(defun virtual-move-to (x y)
  (virtual-move-windows (- (+ x (# 0 virt-pos)))
                        (- (+ y (# 1 virt-pos)))))

(defun virtual-make-window-visible ()
  ;; Move the virtual screen to make the current window visible.
  (if (not (virtual-nailed))
      (with (dx 0 dy 0 
	     window-top window-y
             window-bot (+ window-y window-height)
             window-left window-x
             window-right (+ window-x window-width)
             screen-top 0
             screen-bot screen-height
             screen-left 0
             screen-right screen-width)
        (if (or (ge window-left screen-right)  ; Check that no part visible
                (le window-right screen-left)
                (ge window-top screen-bot)
                (le window-bot screen-top))
            (progn
              (if (ge window-right screen-right)
                  (setq dx (- (ceildiv (min (- window-right screen-right)
                                            (- window-left screen-left
                                               virtual-horizontal-step))
                                       virtual-horizontal-step))))
              (if (le window-left screen-left)
                  (setq dx (ceildiv (- screen-left window-left) 
                                    virtual-horizontal-step)))
              (if (ge window-bot screen-bot)
                  (setq dy (- (ceildiv (min (- window-bot screen-bot)
                                            (- window-top screen-top
                                               virtual-vertical-step))
                                       virtual-vertical-step))))
              (if (le window-top screen-top)
                  (setq dy (ceildiv (- screen-top window-top)
                                    virtual-vertical-step)))
              (setq dx (* dx virtual-horizontal-step))
              (setq dy (* dy virtual-vertical-step))
              (virtual-move-windows dx dy))))))

(defun virtual-placement (flag)
  (if flag
      (if (not (or window-was-on-screen
                   ;; window-starts-iconic
                   ;; window-is-transient-for
                   (not (= window-status 'window))))
          (if (and (not (virtual-nailed))
                   (not (= virt-pos '(0 0))))
              (move-window (+ window-x (# 0 virt-pos))
                           (+ window-y (# 1 virt-pos)))))))

(defun virtual-x (x)
  (- x (# 0 virt-pos)))

(defun virtual-y (y)
  (- y (# 1 virt-pos)))

(defun virt-drawable ()
  (and (not (= window virt-removed-window))
       (not (and virtual-omit-nailed
                 (virtual-nailed)))
       (not (matches-list virtual-omit-list))))

(defun virt-calc-params ()
  ;; Return a list that contains scale factor, x position of origin,
  ;; and y position of origin
  (with (minx 0
         miny 0
         maxx screen-width
         maxy screen-height
	      xcenter nil ycenter nil
	      range nil scale nil x0 nil y0 nil
	      low (list-of-windows 'window 'mapped))
        (if (not (wob-is-valid wob))
            (wob root-window))
	(for wob (if virt-added-window
                     (+ (list-of-windows 'window 'mapped)
                        (list virt-added-window))
                   (list-of-windows 'window 'mapped))
           (if (virt-drawable)
               (progn
                 (setq minx (min minx window-x))
                 (setq miny (min miny window-y))
                 (setq maxx (max maxx (+ window-x window-width)))
                 (setq maxy (max maxy (+ window-y window-height))))))
	
	(setq range (max (- maxy miny) (- maxx minx)))
	(setq xcenter (/ (+ minx maxx) 2))
	(setq ycenter (/ (+ miny maxy) 2))

	;; Our scale factor is a simple quotient, times ten. We divide
        ;; by .95 times the number of pixels to leave some inner border.
	;; To get the origin, figure out where 0,0 would be given that
	;; the center of the current screen should be in the center.

	(setq scale (/ (* 1000 range) (* 95 virtual-pixsize)))
	(setq x0 (/ virtual-pixsize 2))
	(setq y0 (/ virtual-pixsize 2))
	(setq x0 (- x0 (/ (* 10 xcenter) scale)))
	(setq y0 (- y0 (/ (* 10 ycenter) scale)))
	(list scale x0 y0)))

(defun virt-draw-text (pix left top wdt hgt name vfont pos)
  (with (font vfont
         label-vertical-margin 0
         label-horizontal-margin 0
         fh (height " ")
         yoff (- fh 2))
    (if pos
        (setq yoff (if (= (setq pos (atom pos)) 'top) (- fh 2)
                       (= pos 'center) (/ (+ hgt fh -6) 2)
                       (= pos 'bottom) (- hgt 1)
                       (= pos 'above) -2
                       (= pos 'below) (+ hgt fh -1)
                     (- fh 2))))
    (if (or (not pos) (= pos 'center) (= pos 'bottom) (= pos 'top))
        (while (and (> (width name) wdt) (> (length name) 0))
          (setq name (match "\\(.*\\).$" name 1))))
    (draw-text pix (+ 1 left) (+ yoff top) vfont name)))

(defun virt-draw-window (pix params border colf colb)
  (with (foreground colf
         background (or colb 0)
         mode (if colb 3 1)
         left (+ (/ (* 10 window-x) (# 0 params)) (# 1 params))
         top (+ (/ (* 10 window-y) (# 0 params)) (# 2 params))
         wdt (/ (* 10 window-width) (# 0 params))
         hgt (/ (* 10 window-height) (# 0 params)))
    (draw-rectangle pix left top wdt hgt border mode)
    (if (and virtual-title-font (not (= wob root-window)))
        (virt-draw-text pix left top wdt hgt window-name 
                        virtual-title-font virtual-title-position))))

(defun virt-get-color ()
  (with (res (if (= window root-window)
                 (with (ele (# 0 virtual-fancy-colors))
                   (if (and ele
                            (or (not (# 0 ele))
                                (= (type (# 0 ele)) 'number)))
                       ele))
               (matches-cond virtual-fancy-colors)))
    (if (not res)
        (list virtual-foreground 
              (if virtual-show-filled
                  virtual-background
                ()))
      (not (# 0 res))
        (list virtual-foreground
              (# 1 res))
        res)))

(defun virt-draw-windows (pix params)
  (with (wob root-window
         cols (virt-get-color))
    (virt-draw-window pix params 2 (# 0 cols) (# 1 cols)))
  (for wob (if virt-added-window
               (+ (list-of-windows 'window 'stacking-order 'mapped)
                  (list virt-added-window))
             (list-of-windows 'window 'stacking-order 'mapped))
       (if (virt-drawable)
           (with (cols (virt-get-color))
             (virt-draw-window pix params 1 (# 0 cols) (# 1 cols))))))

(defun virt-map-to-real (params relx rely)
  (with (absx (/ (* (- relx (# 1 params)) (# 0 params)) 10)
         absy (/ (* (- rely (# 2 params)) (# 0 params)) 10))
    (list absx absy)))

(defun virt-real-to-map (params realx realy)
  (with (mapx (+ (/ (* realx 10) (# 0 params)) (# 1 params))
         mapy (+ (/ (* realy 10) (# 0 params)) (# 2 params)))
    (list mapx mapy)))

(defun virtual-map-move-to ()
  (with (params (virt-calc-params)
         realpos (virt-map-to-real params
                                   (current-event-relative-x)
                                   (current-event-relative-y))
         hswdt virtual-horizontal-step
         hshgt virtual-vertical-step
         absx (- (# 0 realpos) (# 0 virt-pos) (/ screen-width 2))
         absy (- (# 1 realpos) (# 1 virt-pos) (/ screen-height 2))
         absx (if (< absx 0) 
                  (* hswdt (/ (- absx (/ hswdt 2)) hswdt))
                  (* hswdt (/ (+ absx (/ hswdt 2)) hswdt)))
         absy (if (< absy 0) 
                  (* hshgt (/ (- absy (/ hshgt 2)) hshgt))
                  (* hshgt (/ (+ absy (/ hshgt 2)) hshgt))))
    (virtual-move-to absx absy)))

(defun virtual-map-move-window ()
  (with (params (virt-calc-params)
         wob virt-wind
         mapleft (+ window-x wob-borderwidth
                    window-client-x window-client-borderwidth -1)
         maptop (+ window-y wob-borderwidth
                   window-client-y window-client-borderwidth -1)
         mapright (+ mapleft window-client-width)
         mapbottom (+ maptop window-client-height)
         mappos (current-mouse-position)
         bmask 7936
         init-button (bitwise-and bmask (# 2 mappos))
         realpos (virt-map-to-real params
                                   (- (# 0 mappos) mapleft)
                                   (- (# 1 mappos) maptop))
         wind (wob-at-coords (# 0 realpos) (# 1 realpos)))
    (virtual-update)
    (if (and wind
             (with (wob wind) (virt-drawable)))
        (with (wob wind
               initpos (virt-real-to-map params window-x window-y)    
               mouse-pos ()
               cursor (cursor-make 130))
          (virt-draw-window virt-pix params 2 virtual-foreground ())
          (refresh virt-wind)
          (process-events)
          (tag ret
               (grab-server root-window)
               (warp-pointer (+ (# 0 initpos) mapleft)
                             (+ (# 1 initpos) maptop)
                             root-window)
               (warp-pointer 0 0)   ; To get around bug in X11
               (while t
                 (: mouse-pos (current-mouse-position))
                 (if (not (= (bitwise-and bmask (# 2 mouse-pos)) init-button))
                     (exit ret
                           (ungrab-server root-window)))))
          (if (and (= (bitwise-and bmask (# 2 mouse-pos)) 0)
                   (not (and (= (# 0 mouse-pos) (+ (# 0 initpos) mapleft))
                             (= (# 1 mouse-pos) (+ (# 1 initpos) maptop))))
                   (> (# 0 mouse-pos) mapleft)
                   (< (# 0 mouse-pos) mapright)
                   (> (# 1 mouse-pos) maptop)
                   (< (# 1 mouse-pos) mapbottom))
              (with (newpos (virt-map-to-real params
                                              (- (# 0 mouse-pos) mapleft)
                                              (- (# 1 mouse-pos) maptop)))
                (move-window wind (# 0 newpos) (# 1 newpos))))
          (virtual-update)))))
            

(defun virtual-show ()
  (if (and (boundp 'virt-wind) virt-wind (wob-is-valid virt-wind))
      (with (wob virt-wind
             left (+ window-x wob-borderwidth
                     window-client-x window-client-borderwidth)
             top (+ window-y window-client-y
                    wob-borderwidth window-client-borderwidth))
        (setq virtual-xpos left)
        (setq virtual-ypos top)
        (delete-window)))
  (if show-virtual
      (with (params (virt-calc-params)
             vmenu ())
        (with (foreground virtual-background)
          (setq virt-pix (pixmap-make virtual-pixsize virtual-pixsize)))
        (virt-draw-windows virt-pix params)
        (setq vmenu
              (with (borderwidth 0
                     bar-max-width virtual-pixsize
                     fsm (fsm-make virtual-map-behavior))
                (menu-make (bar-make (plug-make virt-pix)))))
        (process-events)
        (with (reenter-on-opening ()
               xpos (if (< virtual-xpos 0) 
                        (- (+ screen-width virtual-xpos) virtual-pixsize)
                      virtual-xpos)
               ypos (if (< virtual-ypos 0) 
                        (- (+ screen-height virtual-ypos) virtual-pixsize)
                      virtual-ypos))
          (setq virt-wind
                (place-menu 'virtual vmenu xpos ypos))))
    (progn
      (unbind 'virt-wind)
      (unbind 'virt-pix))))

(defun virtual-toggle ()
  (: show-virtual (not show-virtual))
  (virtual-show))

(defun virtual-update ()
  (if (and show-virtual (boundp 'virt-pix) (boundp 'virt-wind))
      (with (params (virt-calc-params)
             bar-max-width virtual-pixsize)
        (with (background virtual-background)
	  (draw-rectangle virt-pix 0 0 virtual-pixsize virtual-pixsize 0 2))
        (virt-draw-windows virt-pix params)
        (refresh virt-wind))))

(defun virtual-add ()
  (if (and (not (= window-status 'icon))
           (not (= window-client-class 'Gwm)))
      (with (virt-added-window window)
        (virtual-update))))

(defun virtual-remove ()
  (if (and (not (= window-status 'icon))
           (not (= window-client-class 'Gwm)))
      (with (virt-removed-window window)
        (virtual-update))))

(if (not (boundp 'virtual-map-behavior))
(: virtual-map-behavior
   (state-make
    (on (button 1 any) (virtual-map-move-to))
    (on (buttonpress 2 any) (virtual-map-move-window))
    (on (button 3 any) (virtual-update))
    ))
)

(defun virtual-behavior ()
   (if virtual-modifiers
       (state-make
        (on (keypress "Left" virtual-modifiers)
            (virtual-move-left))
        (on (keypress "Right" virtual-modifiers)
            (virtual-move-right))
        (on (keypress "Up" virtual-modifiers)
            (virtual-move-up))
        (on (keypress "Down" virtual-modifiers)
            (virtual-move-down)))))

(defun virtual-grabs ()
   (if virtual-modifiers
       (list
        (key "Left" virtual-modifiers)
        (key "Right" virtual-modifiers)
        (key "Up" virtual-modifiers)
        (key "Down" virtual-modifiers)
        )))
	  
