;;; $Id: flux.scm,v 1.164 2006/11/22 01:50:09 dsmith Exp $
;;; flux.scm
;;; Copyright (C) 1998, 1999, 2000 Greg J. Badros, Sam Steingold, and Maciej Stachowiak
;;;
;;; This are functions used by various sample .scwmrc, but not necessarily
;;; stabilized even as well as the other files in scheme/*.scm
;;; Expect the semantics of these functions to change, and don't
;;; be surprised if some even completely disappear (as we figure out a better
;;; way to do things)



(define-module (app scwm flux)
  :use-module (ice-9 regex)
  :use-module (app scwm base)
  :use-module (app scwm stylist)
  :use-module (app scwm face)
  :use-module (app scwm animation)
  :use-module (app scwm animated-iconify)
  :use-module (app scwm animated-edge-moves)
  :use-module (app scwm time-convert)
  :use-module (app scwm defoption)
  :use-module (app scwm wininfo)
  :use-module (app scwm winlist)
  :use-module (app scwm message-window)
  :use-module (app scwm window-configuration)
  :use-module (app scwm winops)
  :use-module (app scwm flash-window)
  :use-module (app scwm listops)
  :use-module (app scwm file)
  :use-module (app scwm scwmxtest)
  :use-module (app scwm stringops)
  :use-module (app scwm group)
  :use-module (app scwm reflection)
  :use-module (app scwm path-cache)
  :use-module (app scwm window-selection)
  :use-module (app scwm nonants)
  :use-module (app scwm optargs)
  :use-module (app scwm tile)
  :use-module (app scwm highlight-current-window)
  :use-module (app scwm xprop-extras))

(if (> guile-version 1.3)
    (use-modules (ice-9 popen)))

(use-scwm-modules base stylist animation animated-iconify)


(define-public user-init-file (string-append (user-home) "/.scwmrc"))

;; The #t arguments should perhaps instead be a closure
;; returning whether an opaque move/resize is desired

(define*-public (wiggle-window #:optional (win (get-window)))
  "Animatedly window shade and then unshade WIN.
Just a toy--- perhaps could be useful to call attention to a window."
  (interactive)
  (shade-window win #t) (unshade-window win #t))

(define-public (system-info-string)
  "Return a string with various system information.
Use `show-system-info' to display it in a window."
  (let ((vv (X-version-information)) (dd (X-display-information)))
    (apply
     to-string "Guile verion:\t\t" (version)
     (if libguile-config-stamp
	 (string-append "\nLibguile timestamp:\t" (libguile-config-stamp))
	 "")
     "\nSCWM version:\t\t" (scwm-version)
     "\nFrom repository date:\t" (scwm-version-date)
     "\nRestarted:\t\t" (bool->string (restarted?))
     "\nDisplay Size:\t\t" (size->string (display-size))
     "\nDesk Size:\t\t" (size->string (desk-size))
     "\nViewport Position:\t" (size->string (viewport-position))
     "\nPointer:\t\t" (size->string (pointer-position))
     "\nCurrent Desk:\t\t" (number->string (current-desk))
     "\nX vendor:\t\t" (caddr vv) "; version: " (number->string (car vv)) "."
     (number->string (cadr vv)) "; release: " (number->string (cadddr vv))
     "\nX Display:\n\tResolution:\t" (size->string dd) "\n\tColor:\t\t"
     (list-ref dd 4) " (depth: " (number->string (caddr dd))
     "; bits per RGB: " (number->string (cadddr dd)) ")\nimage-load-path:\n"
     (map (lambda (st) (string-append "\t" st "\n")) image-load-path))))

;; CRW:FIXME:: This should be merged with make-context-menu in
;; std-menus.scm

;; I (CRW) changed "vi" to "emacs" below.  If anybody feels strongly
;; that the default should be "vi", at least make it "xterm -e vi"
;; instead of just "vi".
(define-public (make-file-menu file . rest)
  "Return a menu-object for viewing or editing FILE.
REST is a list of other menu-items to include in the returned menu."
  (menu (append! (list (menuitem "View" #:action (show-file file))
		       (menuitem "Edit" #:action
				 (string-append (or (getenv "EDITOR") "emacs")
						" " file)))
		 rest)))

(define-public (quotify-single-quotes str)
  "Return a string that has single quote characters backslashified."
  (regexp-substitute/global #f "'" str 'pre "'\"'\"'" 'post))

;;; GJB:FIXME:: do not use xmessage-- use guile-gtk
(define-public (message . str)
  "Display the string arguments STR in a message window.
Requires the program `xmessage'."
  (execute (string-append "echo -e \\'"
			  (quotify-single-quotes (apply string-append str))
			   "\\'| xmessage -file - -default okay -nearmouse")))

(define-public (show-mesg . str)
  "Return a lambda to display the string arguments STR in a message window.
See also `message'."
  (lambda* () "" (interactive) (apply message str)))

(define-public (show-file filename)
  "Return a lambda to display the contents of filename in a window."
  (exe (string-append "xmessage -default okay -nearmouse -file " filename)))

(define-public (show-com com)
  "Return a lambda to show the stdout generated by the COM shell pipeline."
  (exe (string-append com "| xmessage -file - -default okay -nearmouse")))

(define*-public (window-info #:optional (win (get-window)))
  "Display information about WIN in a message window."
  (interactive)
  (message
   "Window ID:\t\t" (number->string (window-id win))
   "\nWindow Frame ID:\t" (number->string (window-frame-id win))
   "\nTitle:\t\t\t\"" (window-title win) "\""
   "\nVirtual Position:\t\t" (size->string (window-position win))
   "\nViewport Position:\t\t" (size->string (window-viewport-position win))
   "\nSize:\t\t\t" (size->string (window-frame-size win))
   "\nDesk:\t\t\t" (number->string (window-desk win)) "\nClass:\t\t\t\""
   (window-class win) "\"\nResource:\t\t\"" (window-resource win)
   "\"\nBorder Normal:\t\t" (bool->string (border-normal? win))
   "\nFocus:\t\t\t" (window-focus-style win)
   "\nDeletable:\t\t" (bool->string (window-deletable? win))
   "\nIconified:\t\t" (bool->string (iconified-window? win))
   "\nKept On Top:\t\t" (bool->string (kept-on-top? win))
   "\nTransient:\t\t" (bool->string (transient? win))
   "\nRaised:\t\t\t" (bool->string (raised? win))
   "\nShaded:\t\t\t" (bool->string (shaded-window? win))
   "\nShaped:\t\t\t" (bool->string (window-shaped? win))
   "\nIcon Shaped:\t\t" (bool->string (window-icon-shaped? win))
   "\nSticky Icon:\t\t" (bool->string (icon-sticky? win))
   "\nSticky:\t\t\t" (bool->string (sticky-window? win))
   "\nTitle Bar Shown:\t" (bool->string (titlebar-shown? win))))

(define*-public (show-system-info)
  "Display the `system-info-string' system details in a window."
  (interactive)
  (message (system-info-string)))

(define (first-word s)
  "Return the first word of S (up to but not including first space char)."
  (let ((i (string-index s #\space))
	(j (string-index s #\tab))
	(l (string-length s)))
    (let ((k (if (< (or i j l) (or j i l)) i j)))
      (if k (substring s 0 k) s))))
;;(first-word "foo bar") => "foo"
;;(first-word "foo	bar") => "foo"
;;(first-word "foobar") => "foo"

(define-public (start-program-in-xterm program title resource-name)
  "Return a string to be the arguments to xterm for starting PROGRAM in it.
TITLE is the desired title, and RESOURCE-NAME is the desired Xrdb resource
property."
  (string-append program " -T" title " -name " resource-name))

(define*-public (start-xlogo)
  "Start an XLogo window."
  (interactive)
  (execute "xlogo"))

(define-public (make-menuitems-from-menu-information-list menu-info-list)
  "Return a list of menu-items from a list of detailed programs list.
The format is subject to change.  See sample.scwmrc/gjb.scwmrc for
example usage."
  (cons menu-separator
	(filter-map (lambda (elem)
		      (let ((title (car elem))
			    (mini-icon (cadr elem))
			    (icon (caddr elem))
			    (exename (cadddr elem)))
			(if (cached-program-exists? (first-word exename))
			    (menuitem
			     title #:action exename #:image-left
			     (if mini-icon
				 (string-append "mini-" mini-icon ".xpm") #f)
			     ;; #:icon (if icon (string-append icon ".xpm") #f)
			     )
			    #f)))
	     menu-info-list)))

(define-public (select-window-group)
  "Prompt for multiple windows and return the list of selected windows.
Returns the list of windows in selection order.  Windows are highlighted
(see `flash-window') as they are selected.  The returned list can be used
to un-highlight the windows:
 (let ((winlist (select-window-group)))
   (for-each (lambda (w) (unflash-window w)) winlist))"
  (do ((w #f)
       (wlist '())
       (cwin-selected 0)
       (w #f)
       (done #f))
      (done
       (reverse wlist))
    (set! w (select-window-interactively
	     (string-append "select #" (number->string cwin-selected))))
    (if w
	(if (memq w wlist)
	    (begin
	      ;; remove w from wlist
	      (set! wlist (list-without-elem wlist w))
	      (unflash-window w)
	      (set! cwin-selected (- cwin-selected 1)))
	    (begin
	      (set! wlist (cons w wlist))
	      (flash-window w #:unflash-delay #f)
	      (set! cwin-selected (+ cwin-selected 1))))
	(set! done #t))))
;; (define wg (select-window-group))
;; (object-properties (select-window-interactively))
;; (for-each (lambda (w) (unflash-window w)) (list-all-windows))
;; (unflash-window)
;; (flash-window-on)



;; From S.Senda -- Aug 3, 1998
;;;;;;;; rlogin menu making from .rhosts file ;;;;;;;;;

(define-public (make-rhosts-menu)
  "Returns a menu which lets you rlogin to each host mentioned in your .rhosts"
  (false-if-exception
   (let* ((rhostfn (string-append (user-home) "/.rhosts"))
	  (termprog "xterm")
	  (p (open-input-file rhostfn))
	  (ret '())
	  (ap (lambda (a)
		(set! ret (append ret (list a)))))
	  (mm (lambda (h u)
		(menuitem h #:action
			  (lambda () (execute
				      (string-append termprog " -e rlogin "
						     h " -l " u))))))
      )
    (ap (menuitem ".rhosts" #f))
    (ap menu-separator)
    (do ((l (read-line p 'trim) (read-line p 'trim)))
	((eof-object? l) ret)
      (cond ((string-match "([^ \t]+)[ \t]+([^ \t]+)" l)
	     => (lambda (m)
		  (ap (mm (match:substring m 1)   ; machine name
			  (match:substring m 2))) ; user name
		  ))))
    (ap menu-separator)
    (ap (menuitem "reread .rhosts file" #:action
	    (lambda () (set! rhosts-menu (make-rhosts-menu)))))
    (menu ret)
)))

;; sds: users should call this function themselves
;;(define-public rhosts-menu (make-rhosts-menu))

(define*-public (close-all-xlogo-windows)
  "Close each window with class == XLogo.
Greg uses XLogo windows as a sample window, so this
is useful for clearing the xlogos away when there get to
be more than desired."
  (interactive)
  (for-each (lambda (w) (close-window w))
	    (list-windows #:only
			  (lambda (w)
			    (string=? (window-class w) "XLogo")))))

;; Inspired by Julian Satchell's version of this --10/09/98 gjb
(define-public (use-change-desk-commands vector-of-commands)
  "Execute one of the VECTOR-OF-COMMANDS shell commands when the desk changes.
The 0th element of the vector is used for changes to desk 0,
the first element for changes to desk 1, etc.  Changes to desks which are
\"off the end\" of the vector do nothing."
  (add-hook! change-desk-hook
	     (lambda (new old)
	       ;; (display n) (newline) ;; for debugging
	       (if (< new (vector-length vector-of-commands))
		   (system (vector-ref vector-of-commands new)))
	       )))

(define (extreme1 pred lst)
  (if (null? (cdr lst))
      (car lst)
      (let ((ex (extreme pred (cdr lst))))
	(if (pred (car lst) ex)
	    (car lst)
	    ex))))

(define-public (extreme pred lst)
  "Find extreme value e of PRED in LST.
If PRED defines a semi-ordering, `(PRED e x)' will hold for all members x
of LST not equal to e. E.g. `(extreme < ...)' returns the lowest number."
  (if (null? lst)
      '()
      (extreme1 pred lst)))

(define*-public (take-screenshot
		 #:optional (template (string-append
				       (user-home)
				       "/screenshot%y%m%d%H%M%S.xwd")))
  "Take a snapshot of the whole screen.
The screenshot will be saved in xwd format in the filename constructed from
TEMPLATE. %-escapes in TEMPLATE will be replaced by time-elements, according
to strftime rules. TEMPLATE defaults to the file \"screenshot%y%m%d%H%M%S.xwd\"
in the user's home directory."
  (execute (string-append "xwd -root >"
			  (strftime template (localtime (current-time))))))


;;; palm pilot stuff
;;; requires pilot-link's pilot-clip program

;; (system "ssh-add </dev/null &")
;;(define pilot-clip-binary "pilot-clip")
(define pilot-clip-binary "remote-pilot-clip")  ;; this does ssh HOST-WITH-CRADLE pilot-clip "$@"

(define-public (put-string-in-palm-clipboard str)
  (let ((port (open-output-pipe (string-append pilot-clip-binary " -s &"))))
    (display str port)
    (close-port port)))

(define-public (X-cut-buffer->palm-clipboard)
  (put-string-in-palm-clipboard (X-cut-buffer-string)))

;;(put-string-in-palm-clipboard "testing\nto\nsee\nif this\nworks")
;; (X-cut-buffer->palm-clipboard)

;; This is not such a hot idea-- scwm can hang!
;; (define-public (get-string-from-palm-clipboard)
;;   (let* ((port (open-input-pipe (string-append pilot-clip-binary " -g")))
;; 	    (str (read-line port)))
;;     (close-port port)
;;     str))
;;
;; (get-string-from-palm-clipboard)

(define*-public (delete-multiple-windows-interactively)
  "Delete multiple windows as they are interactively clicked on."
  (interactive)
  (select-multiple-windows-interactively #f delete-window))

;; ((help-mesg "move-to"))

(define-public (move-nonsticky-windows-relative x y)
  "Move all windows right X, down Y pixels.
See `move-window-relative.'"
  (for-each (lambda (w) (move-window-relative x y w))
	    (list-windows #:only (win-not?? sticky-window?))))

(defmacro-public @ args
  `(lambda (sym)
     (variable-ref (module-variable (resolve-module ',args) sym))))

(define*-public (show-X-properties #:optional (win (get-window)))
  "Displays the X properties of WIN in a message window.
WIN is a window object, an X window id, or 'root-window."
  (interactive)
  (message (X-properties->string win)))

;; (get-window-nonant (select-viewport-position))

(define-public (bind-wheel-mouse-prior-next matching-proc)
  (bind-mouse 'window 4
	      (lambda ()
		(if (matching-proc (window-with-pointer))
		    (send-key-press-prior)
		    (begin
		      (xtest-fake-button-event 4 #t)
		      (xtest-fake-button-event 4 #f 10)))))
  (bind-mouse 'window 5
	      (lambda ()
		(if (matching-proc (window-with-pointer))
		    (send-key-press-next)
		    (begin
		      (xtest-fake-button-event 5 #t)
		      (xtest-fake-button-event 5 #f 10))))))

;; (bind-wheel-mouse-prior-next (class-match?? "AcroRead"))

(define*-public (send-key-press-up)
  "Send a synthetic \"Up\" keypress."
  (interactive)
  (send-key "Up"))
(define*-public (send-key-press-down)
  "Send a synthetic \"Down\" keypress."
  (interactive)
  (send-key "Down"))
(define*-public (send-key-press-prior)
  "Send a synthetic \"Prior\" keypress."
  (interactive)
  (send-key "Prior"))
(define*-public (send-key-press-next)
  "Send a synthetic \"Next\" keypress."
  (interactive)
  (send-key "Next"))


(define-public (float->integer x)
  (inexact->exact x))

;;; make-X-geometry is modified
;;; from Faré Rideau's scwm-functions file --09/20/99 gjb
(define*-public (make-X-geometry #:key (x-size #f) (y-size #f) (x-offset #f) (y-offset #f))
  (if (not (or
	    (and x-size y-size)
	    (and x-offset y-offset)))
      (error "bad option list for make-X-geometry\n")
      (string-append
       (if (and x-size y-size)
	   (string-append (number->string x-size) "x" (number->string y-size))
	   "")
       (if (and x-offset y-offset)
	   (string-append (if (>= x-offset 0) "+" "")
			  (number->string x-offset) 
			  (if (>= y-offset 0) "+" "")
			  (number->string y-offset))
	   ""))))

;; (make-X-geometry #:x-size 50 #:y-size 20 #:x-offset 10 #:y-offset -20)

(define*-public (interactive-move-rubberband #:optional (win (get-window)))
  "Move interactively, using the rubberband (unless constraint solver is active."
  (interactive)
  (interactive-move (get-window) #f))

(define*-public (interactive-resize-rubberband #:optional (win (get-window)))
  "Resize interactively, using the rubberband (unless constraint solver is active."
  (interactive)
  (interactive-resize (get-window) #f))

(define-public (config-request-animate win icon? x y width height)
  "A procedure for `X-ConfigureRequest-hook' to do window configuration animatedly.
Use `add-hook!' to attach this to `X-ConfigureRequest-hook'."
  (if (and (not icon?) win)
      (begin
	(if (or width height)
	    (animated-resize-window width height win (vpx->vx x) (vpy->vy y))
	    (animated-move-window (vpx->vx x) (vpy->vy) win))
	(set! configure-request-handled #t))))

(define*-public (focus-window-with-pointer)
  "Set the focus to be the window containing the pointer."
  (interactive)
  (focus-window (window-with-pointer)))

(defmacro menuitem-for-exec (name pixmap . body)
  (if (cached-program-exists? name)
      `(list ,name #:action (lambda () (execute ,name) ,@body)
	     #:image-left ,pixmap)))

;; (resize-xdvi-full-page-100%)
(define*-public (resize-xdvi-full-page-100% #:optional (win (get-window)))
  "Resize an Xdvi window to be full-page, 100%.
Then you must use various mouse bindings to pan the page around."
  (interactive)
  (if (string-match "^Xdvi" (window-title win))
      (resize-window 5180 6625 win)
      (display-message-briefly "Not an Xdvi window")))

(define*-public (eval-expression-interactively)
  "Prompt for an expression and evaluate it interactively."
  (interactive)
  (prompt-string
   "Expression:"
   (lambda (val)
     (let ((answer (eval-string val)))
       (display-message-briefly
	(string-append 
	 "Answer: "
	 (with-output-to-string 
	   (lambda () (write answer)))))))))