home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / utils.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  12KB  |  392 lines
  1. ; Various utilities used in standard profile
  2. ; ==========================================
  3.  
  4. ;;File: utils.gwm -- General-purpose WOOL utilities
  5. ;;Author: vincent@mirsa.inria.fr (Vincent BOUTHORS) -- Bull Research FRANCE
  6. ;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
  7. ;;Revision: 1.0 -- Feb 7 1989
  8. ;;State: Exp
  9. ;;GWM Version: 1.4
  10.  
  11. ;;=============================================================================
  12. ;;                    default
  13. ;;=============================================================================
  14. ; returns value of variable if set or evaluated provided value
  15.  
  16. (df default (variable value)
  17.     (if (boundp variable)
  18.     (eval variable)
  19.     (eval value)))
  20.  
  21. ; defvar defines variable if unbound
  22.  
  23. (df defvar (defvar:variable defvar:value)
  24.   (if (boundp defvar:variable) ()
  25.     (set defvar:variable (eval defvar:value))
  26. ))    
  27.  
  28. ; defaults-to
  29. ; set variable if was unset
  30.  
  31. (df defaults-to args
  32.     (with (i 0 l (length args))
  33.       (if (= (% l 2) 1)
  34.           (trigger-error "defaults-to must have an even number of args"))
  35.       (while (< i l)
  36.         (if (not (boundp (# i args)))
  37.           (set (# i args) (eval (# (+ 1 i) args))))
  38.         (setq i (+ i 2))))))
  39.  
  40. ; declare a list of variable as screen-dependent
  41.  
  42. (df declare-screen-dependent args
  43.     (for var args
  44.      (defname var screen.)))
  45.  
  46. ;; (default-if-nil v1 a1 v2 a2...)
  47. ;; sets vN to aN value if vN is nil
  48.  
  49. (df default-if-nil args
  50.   (with (i 0)
  51.     (while (# i args)
  52.       (if (not (eval (# i args)))
  53.     (set (# i args) (eval (# (+ 1 i) args))))
  54.       (setq i (+ 2 i))
  55. )))
  56.  
  57. ;;=============================================================================
  58. ;;                    autoload
  59. ;;=============================================================================
  60. ; specifies that calling this function (with no args!) will load the file
  61. ; and execute the supposedly redefined function
  62.  
  63. (df autoload (function filename)
  64.     (set function
  65.      (lambda () 
  66.          (setq autoload.tmp (eval function)) ; to prevent bug
  67.          (load filename)
  68.          (eval (list function)))))
  69.  
  70. ;;=============================================================================
  71. ;;                    print-window-info
  72. ;;=============================================================================
  73. ;; prints client info in a pop-up window at the center of the screen
  74.  
  75. (defaults-to
  76.   info.foreground black
  77.   info.background (color-make "moccasin")
  78.   info.borderwidth 1
  79. )
  80.  
  81.  
  82.  
  83. (de print-window-info ()
  84.     (with (fsm-but (fsm-make (state-make ; kill by clicking in it
  85.                   (on (button any alone) (delete-window))
  86.                   window-behavior
  87.                   standard-behavior
  88.                   ))
  89.            borderwidth info.borderwidth
  90.            background info.background
  91.            foreground info.foreground
  92.            fsm window-fsm 
  93.            direction vertical
  94.            label-horizontal-margin 4 label-vertical-margin 2
  95.            menu-min-width 30 menu-max-width 1000
  96.            win
  97.            (place-menu
  98.             "Client Info"
  99.             (menu-make
  100.              (bar-make
  101.               (with (fsm fsm-but)
  102.                 (plug-make
  103.                  (label-make (setq print-window-info.string
  104.                            (create-window-info)))))))
  105.             -1000 -1000        ; place it outside screen
  106.             ))
  107.       (with (wob win)        ; then center it when we know its size
  108.         (move-window 
  109.          (- (- (/ screen-width 2) (/ window-width 2)) wob-borderwidth)
  110.          (- (- (/ screen-height 2) (/ window-height 2)) wob-borderwidth)
  111.          )))
  112.     ;; output on stdout too
  113.     (print print-window-info.string "\n")
  114.     )
  115.  
  116. (defun create-window-info ()
  117.   (+ "Window: " (window-client-class) "."
  118.     (make-string-usable-for-resource-key
  119.       (window-client-name))
  120.     "."
  121.     (make-string-usable-for-resource-key (window-name))
  122.     "@" (window-machine-name) ": Geometry="
  123.     (itoa window-width) "x" (itoa window-height)
  124.     "+" (itoa window-x) "+" (itoa window-y)
  125. ))
  126.  
  127. ;;=============================================================================
  128. ;;                    WM misc utils
  129. ;;=============================================================================
  130. ; ensure window is contained in screen
  131.  
  132. (df place-window-in-screen ()
  133.     (: x (window-x))
  134.     (: y (window-y))
  135.     (: xe (+ x (window-width)))
  136.     (: ye (+ y (window-height)))
  137.     (if (< x 0) (move-window 0 y))
  138.     (if (< y 0) (move-window x 0))
  139.     (if (> xe screen-width) (move-window (- screen-width
  140.                         (window-width)) y))
  141.     (if (> ye screen-height) (move-window x (- screen-height
  142.                            (window-height))))))
  143.  
  144. ;;=============================================================================
  145. ;;                    wool misc utilities:
  146. ;;=============================================================================
  147.  
  148. ;; min/max
  149.          
  150. (de min (n1 n2) (if (< n1 n2) n1 n2))               
  151. (de max (n1 n2) (if (> n1 n2) n1 n2))
  152.  
  153. ; not equal: !=
  154.  
  155. (defun != (obj1 obj2)
  156.   (not (= obj1 obj2)))
  157.  
  158. ;; insert elt in list at pos pos (creates new list)
  159. ;; used mainly for inserting items in menus
  160.  
  161. (defunq insert-at (elt listname pos)
  162.   (with (listval (eval listname)
  163.          pos (eval pos))
  164.     (set listname
  165.      (+ (sublist 0 pos listval)
  166.         (list (eval elt))
  167.         (sublist pos (length listval) listval)))))
  168.  
  169. ;; the require/provide functions
  170.  
  171. (defun require packages
  172.   (for package packages
  173.     (if (not (boundp package)) (load package))
  174. ))
  175.  
  176. (defun provide packages
  177.   (for package packages
  178.     (if (not (boundp package)) (set package ()))
  179. ))
  180.  
  181. ;; string package
  182.  
  183. (defun make-string-usable-for-resource-key-non-nil (string)
  184.   (if (setq #tmp# (make-string-usable-for-resource-key string))
  185.     (if (= #tmp# "") "_" #tmp#)
  186.     'any
  187. ))
  188.  
  189. ;;=============================================================================
  190. ;;                    rwhitby@adl.austek.oz.au (Rod Whitby)
  191. ;;=============================================================================
  192. ; First a function that returns t if the window is at the top of the stack.
  193. ; (This is needed because windows that are partially off-screen are
  194. ; considered by X to be only partially visible, even if they are at the top 
  195. ; of the stack.)
  196.  
  197. (defun window-is-topmost (win)
  198.   (progn
  199.     (with (window-list (list-of-windows 'stacking-order))
  200.       (= win (# (- (length window-list) 1) window-list)))))
  201.  
  202. (defun window-is-bottommost (win)
  203.   (progn
  204.     (with (window-list (list-of-windows 'stacking-order))
  205.       (= win (# 0 window-list)))))
  206.  
  207. ;;=============================================================================
  208. ;;                    Jay Berkenbilt's match-windowspec function
  209. ;;=============================================================================
  210.  
  211. ;;
  212. ;; Returns t if the current window matches this windowspec
  213. ;; or nil otherwise
  214. ;; windowspec is a property list with 'client-class 'client-name 
  215. ;; and 'window-name as possible tags
  216. ;; As you see, windowspecs can themselves contain regular
  217. ;; expressions.  I could match all xterms set aside for buils with
  218. ;; the windowspec
  219. ;; (list 'client-class "XTerm" 'window-name ".*build")
  220. ;; for example.
  221.  
  222. (defun match-windowspec (windowspec)
  223.   (with (clientclass (# 'client-class windowspec)
  224.              clientname (# 'client-name windowspec)
  225.              windowname (# 'window-name windowspec))
  226.     (for a '(clientclass clientname windowname)
  227.          (if (= (eval a) nil)
  228.          (set a ".*")))
  229.     (if (and (match clientclass window-client-class)
  230.          (match clientname window-client-name)
  231.          (match windowname window-name))
  232.         t
  233.       nil)))
  234.  
  235. ;; qjb's utils
  236.  
  237. (defun ceildiv (x y)
  238.   ;; 
  239.   ;; Returns (ceiling (/ x y))
  240.   ;;
  241.   (/ (+ x (- y 1)) y))
  242.  
  243. (defun le (x y) 
  244.   (or (< x y) (= x y)))
  245.  
  246. (defun ge (x y) 
  247.   (or (> x y) (= x y)))
  248.  
  249. ;;=============================================================================
  250. ;;                    place-button
  251. ;;=============================================================================
  252. ;; places a button on the screen
  253. ;; parameters (evaluated):
  254. ;; 
  255. ;; name: text string
  256. ;; fore: color of text
  257. ;; 4 colors (can be strings or colors) from light to dark:
  258. ;; upper-left color, normal back, pressed back, lower right color
  259. ;; action is the code to be executed
  260. ;; in action, you can look at (current-event-code) and (current-event-modifier)
  261. ;; to know which button and which modifiers triggered you
  262.  
  263. (defun place-button (name fore lit norm press dark action)
  264.   (with (fsm-but (fsm-make (state-make    
  265.       (on-eval '(buttonrelease any any)
  266.         '(wob-tile (# 'normal wob))
  267.       )
  268.       (on-eval '(buttonpress any any)
  269.         (list 'progn
  270.           '(wob-tile (# 'pressed wob))
  271.           action
  272.       ))
  273.       ))
  274.       window-behavior standard-behavior
  275.       fsm window-fsm
  276.       fore-c (if (= (type fore) 'number) fore (color-make fore))
  277.       norm-c (if (= (type norm) 'number) norm (color-make norm))
  278.       press-c (if (= (type press) 'number) press (color-make press))
  279.       lit-c (if (= (type lit) 'number) lit (color-make lit))
  280.       dark-c (if (= (type dark) 'number) dark (color-make dark))
  281.       background norm-c
  282.       foreground fore-c
  283.       borderwidth 0
  284.       direction vertical
  285.       label-horizontal-margin 8 label-vertical-margin 6
  286.       menu-min-width 30 menu-max-width 1000
  287.       class-name "Gwm" client-name "button"
  288.       pix (if (= (type name) 'pixmap) name (label-make name))
  289.       background press-c
  290.       ppix (if (= (type name) 'pixmap) name (label-make name))
  291.       foreground lit-c
  292.       w (- (width pix) 1) h (- (height pix) 1)
  293.       w-1 (- w 1) h-1 (- h 1)
  294.       property (+ property (list 'normal pix 'pressed ppix
  295.       ))
  296.       win (place-menu
  297.     (if (= (type name) 'pixmap) "button" name)
  298.     (menu-make
  299.       (bar-make
  300.         (with (fsm fsm-but)
  301.           (draw-line pix 0 0 w 0)
  302.           (draw-line pix 1 1 w-1 1)
  303.           (draw-line pix 0 0 0 h)
  304.           (draw-line pix 1 1 1 h-1)
  305.           (draw-line ppix w h w 0)
  306.           (draw-line ppix w-1 h-1 w-1 1)
  307.           (draw-line ppix w h 0 h)
  308.           (draw-line ppix w-1 h-1 1 h-1)
  309.           (setq foreground dark-c)
  310.           (draw-line pix w h w 0)
  311.           (draw-line pix w-1 h-1 w-1 1)
  312.           (draw-line pix w h 0 h)
  313.           (draw-line pix w-1 h-1 1 h-1)
  314.           (draw-line ppix 0 0 w 0)
  315.           (draw-line ppix 1 1 w-1 1)
  316.           (draw-line ppix 0 0 0 h)
  317.           (draw-line ppix 1 1 1 h-1)
  318.           
  319.           (plug-make pix)
  320.     )))))
  321.     ()
  322. ))
  323.  
  324. ;; place-3d-button is a simplified version for use with colors using
  325. ;; the 1,2,3,4 shade system in rgb.txt.
  326. ;; these are:
  327.  
  328. (setq shaded-colors '(
  329. snow seashell AntiqueWhite bisque PeachPuff NavajoWhite
  330. LemonChiffon cornsilk ivory honeydew LavenderBlush MistyRose azure SlateBlue
  331. RoyalBlue blue DodgerBlue SteelBlue DeepSkyBlue SkyBlue LightSkyBlue SlateGray
  332. LightSteelBlue LightBlue LightCyan PaleTurquoise CadetBlue turquoise cyan
  333. DarkSlateGray aquamarine DarkSeaGreen SeaGreen PaleGreen SpringGreen green
  334. chartreuse OliveDrab DarkOliveGreen khaki LightGoldenrod LightYellow yellow
  335. gold goldenrod DarkGoldenrod RosyBrown IndianRed sienna burlywood wheat tan
  336. chocolate firebrick brown salmon LightSalmon orange DarkOrange coral tomato
  337. OrangeRed red DeepPink HotPink pink LightPink PaleVioletRed maroon VioletRed
  338. magenta orchid plum MediumOrchid DarkOrchid purple MediumPurple thistle
  339. ))
  340.  
  341. (defun place-3d-button (name pen color action)
  342.   (place-button name pen
  343.     (+ "" color "1")
  344.     (+ "" color "2")
  345.     (+ "" color "3")
  346.     (+ "" color "4")
  347.     action
  348. ))
  349.  
  350. (setq demo-button:color 0)
  351. (setq demo-button:startcol ())
  352.  
  353. (defun place-3d-demo-button (name pen color action)
  354.   (place-button name pen
  355.     (setq place-3d-demo-button.c1 (color-make (+ "" color "1")))
  356.     (setq place-3d-demo-button.c2 (color-make (+ "" color "2")))
  357.     (setq place-3d-demo-button.c3 (color-make (+ "" color "3")))
  358.     (setq place-3d-demo-button.c4 (color-make (+ "" color "4")))
  359.     action
  360. ))
  361. (defun demo-button ()
  362.   (setq demo-button:startcol (color-make "#123456789"))
  363.   (color-free demo-button:startcol)
  364.   (do-demo-button)    
  365. )
  366.  
  367. (defun do-demo-button ()
  368.   (place-3d-demo-button
  369.     (# demo-button:color shaded-colors)    ;name
  370.     black                ;pen ink
  371.     (# demo-button:color shaded-colors)    ;color
  372.     '(progn
  373.       (setq demo-button:curcolor (# demo-button:color shaded-colors))
  374.       (if (not (< place-3d-demo-button.c1 demo-button:startcol))
  375.     (color-free place-3d-demo-button.c1)
  376.       )
  377.       (if (not (< place-3d-demo-button.c2 demo-button:startcol))
  378.     (color-free place-3d-demo-button.c2)
  379.       )
  380.       (if (not (< place-3d-demo-button.c3 demo-button:startcol))
  381.     (color-free place-3d-demo-button.c3)
  382.       )
  383.       (if (not (< place-3d-demo-button.c4 demo-button:startcol))
  384.     (color-free place-3d-demo-button.c4      )
  385.       )
  386.       (setq demo-button:color (+ 1 demo-button:color))
  387.       (delete-window)        ;action
  388.       (if (# demo-button:color shaded-colors)
  389.     (do-demo-button)
  390.     ))
  391. ))
  392.