home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / twm-titled-win.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  7KB  |  257 lines
  1. ; Twm Style Window Frame (hacked up from simple-ed-win.gwm)
  2. ; ===========================================================================
  3.  
  4. ; This file is derived from the simple-ed-win.gwm distributed with gwm 1.4.1.30
  5. ; The original file was written by Colas Nahaboo, BULL Research, France.
  6. ;
  7. ; Modifications  [Dec 1989] for twm emulation by Arup Mukherjee 
  8. ; (arup@grasp.cis.upenn.edu)
  9. ;
  10. ; Within the restrictions of the GWM copyright, you may do whatever you
  11. ; want with this code. It would be nice, however, if my name were to remain 
  12. ; in it somewhere.
  13.  
  14. (df twm-titled-win-setup ()
  15.     
  16.     (if (= 0 gwm-quiet)
  17.     (? screen))
  18.  
  19.     (if (not (boundp 'twm-borderwidth)) (: twm-borderwidth 2))
  20.  
  21.     (setq icon-pixmap 
  22.       (pixmap-make title-background
  23.                (+ bitmaps-dir "iconify.xbm")
  24.                title-foreground))
  25.  
  26.     (setq resize-pixmap 
  27.       (pixmap-make title-background
  28.                (+ bitmaps-dir "resize.xbm")
  29.                title-foreground))
  30.  
  31.     (setq hilite-pixmap
  32.       (pixmap-make title-background
  33.                (+ bitmaps-dir "hilite.xbm") 
  34.                title-foreground))
  35.     (setq no-hilite-pixmap
  36.       (with (foreground title-background)
  37.         (pixmap-make 20 20))))
  38.  
  39.  
  40. (: iconify-fsm 
  41.    (fsm-make 
  42.     (: original-state (state-make 
  43.                (on (buttonpress 2 any)
  44.                (with (pos-x (current-event-x)
  45.                     pos-y (current-event-y))
  46.                  (iconify-window)
  47.                  (if (not show-icon-mgr)
  48.                      (progn
  49.                        (move-window pos-x pos-y)
  50.                        (move-window)
  51.                        (raise-window))))
  52.                iconify-state)
  53.                (on (buttonpress any any) 
  54.                (progn (iconify-window)
  55.                   (raise-window))
  56.                original-state)))
  57.                  
  58.     (: iconify-state (state-make
  59.               (on (buttonpress 2 any) (move-window))
  60.               (on (buttonpress any any) 
  61.               (iconify-window) original-state)))))
  62.  
  63. (: icon-plug '(with (borderwidth 0 background white 
  64.                borderpixel white fsm  iconify-fsm)
  65.     (plug-make icon-pixmap)))
  66.  
  67. (: resize-fsm 
  68.    (fsm-make
  69.     (: only-state (state-make 
  70.            (on (buttonpress any any) (resize-window))))))
  71.  
  72. (: resize-plug '(with (borderwidth 0 background title-background
  73.                    fsm resize-fsm)
  74.               (plug-make resize-pixmap)))
  75.                
  76.  
  77. (: edit-fsm  
  78.     (fsm-make 
  79.     (: sed.edit-fsm.normal 
  80.        (state-make
  81.            (on (double-button any any) 
  82.            (progn
  83.              (set-focus wob)
  84.              (wob-background black)
  85.              (with (foreground white)
  86.                    (wob-tile 
  87.                    (active-label-make
  88.                        (# 'title wob) name-font))))
  89.            sed.edit-fsm.editable)
  90.            (on (button any (together with-alt with-control))
  91.            (progn
  92.              (set-focus wob)
  93.              (wob-background black)
  94.              (with (foreground white label-vertical-margin 1)
  95.                    (wob-tile 
  96.                    (active-label-make
  97.                        (# 'title wob) name-font))))
  98.            sed.edit-fsm.editable)
  99.            (on (user-event 'name-change)
  100.            (progn
  101.              (## 'title wob (: s window-name))
  102.              (with (foreground title-foreground
  103.                        label-vertical-margin 1)
  104.                    (wob-tile (active-label-make s name-font)))
  105.              (send-user-event 'get-s (window-icon))
  106.                        (if show-icon-mgr
  107.                  (send-user-event 'icon-mgr-rethink icon-mgr-wob))
  108.            ))
  109.            standard-title-behavior  
  110.        ))
  111.     (: sed.edit-fsm.editable
  112.        (state-make
  113.            (on (keypress (key-make "Return") any)
  114.            (sed.edit-fsm.de-edit)
  115.            sed.edit-fsm.normal)
  116.            (on (double-button any any)
  117.            (sed.edit-fsm.de-edit)
  118.            sed.edit-fsm.normal)
  119.            (on (keypress "BackSpace" any)
  120.            (progn
  121.              (## 'title wob
  122.                 (: s (match "\\(.*\\)."
  123.                         (# 'title wob) 1)))
  124.              (with (foreground title-foreground 
  125.                        label-vertical-margin 1)
  126.                (wob-tile (active-label-make s name-font)))
  127.              (send-user-event 'get-s (window-icon))
  128.              ))
  129.            (on (keypress "Delete" any)
  130.            (progn
  131.              (## 'title wob (: s ""))
  132.              (with (foreground title-foreground
  133.                        label-vertical-margin 1)
  134.                    (wob-tile (active-label-make s name-font)))
  135.              (send-user-event 'get-s (window-icon))
  136.            ))
  137.            (on (keypress any any)
  138.            (progn
  139.              (## 'title wob
  140.                  (: s (+ (# 'title wob) (last-key))))
  141.              (with (foreground title-foreground
  142.                        label-vertical-margin 1)
  143.                    (wob-tile (active-label-make s name-font)))
  144.              (send-user-event 'get-s (window-icon))
  145.            ))
  146.            (on (user-event 'name-change) 
  147.            (progn
  148.              (## 'title wob (: s window-name))
  149.              (with (foreground title-foreground
  150.                        label-vertical-margin 1)
  151.                    (wob-tile (active-label-make s name-font)))
  152.              (if show-icon-mgr
  153.                  (send-user-event 'icon-mgr-rethink icon-mgr-wob))
  154.            ))
  155.            (on focus-out
  156.            (wob-tile (label-make (# 'title wob) name-font))
  157.            sed.edit-fsm.normal)
  158.            standard-title-behavior
  159.        ))
  160.     ))))
  161.     
  162. (de sed.edit-fsm.de-edit ()
  163.     (with (foreground title-foreground 
  164.               background title-background
  165.               font name-font
  166.               label-horizontal-margin 6
  167.               label-vertical-margin 1
  168.               borderwidth 0)
  169.       (wob-tile (label-make (# 'title wob) name-font))
  170.       (window-name (# 'title wob))
  171.       (set-focus)
  172.       (process-events)
  173.       (if show-icon-mgr
  174.           (send-user-event 'icon-mgr-rethink icon-mgr-wob)))
  175. )
  176.  
  177. (: titlebar-fsm 
  178.     (fsm-make
  179.     (state-make
  180.         (on (user-event 'focus-in)
  181.           (wob-tile hilite-pixmap))
  182.         (on (user-event 'focus-out) 
  183.           (wob-tile  no-hilite-pixmap))
  184.         standard-title-behavior)))
  185.     
  186. (: editable-plug '(with ( borderwidth 1 
  187.                       background title-background 
  188.                       foreground title-foreground
  189.                       font name-font
  190.                       property (list 'title window-name)
  191.                       fsm edit-fsm)
  192.             (with (borderwidth 0 
  193.                        label-horizontal-margin 6
  194.                        label-vertical-margin 1)
  195.                   (plug-make (label-make window-name)))))
  196.  
  197. (: space '(with (foreground title-background borderwidth 0)
  198.         (plug-make (pixmap-make 5 16))))
  199.         
  200.     
  201. (: titlebar 
  202.            '(with 
  203.         (borderwidth 2
  204.                  background title-background
  205.                  fsm titlebar-fsm 
  206.                  plug-separator 0
  207.                  borderpixel title-background
  208.                  bar-min-width 1 bar-max-width 30)
  209.         (bar-make 
  210.          icon-plug space editable-plug space () space resize-plug))))
  211.  
  212. (: sed-window-fsm
  213.     (fsm-make
  214.     (state-make
  215.         (on focus-in
  216.         (progn
  217.               (if autoraise (raise-window))
  218.               (send-user-event 'focus-in)
  219.               (wob-borderpixel hilite-color)))
  220.         (on focus-out
  221.         (progn (send-user-event 'focus-out)
  222.                (wob-borderpixel border-foreground)))
  223.         (if (and (boundp 'emacs-mouse-loaded) emacs-mouse-loaded)
  224.         (state-make 
  225.             (on (button 1 with-control) (emacs-click 1))
  226.             (on (button 2 with-control) (emacs-click 2))
  227.             (on (buttonpress 3 with-control) (pop-menu emacs-pop))))
  228.         window-behavior
  229.     )))
  230.  
  231.  
  232. (setq twm-titled-win.result 
  233.       '(with (inner-borderwidth 1 fsm sed-window-fsm 
  234.             borderwidth twm-borderwidth
  235.             borderpixel border-foreground
  236.             grabs (+ grabs 
  237.                  (if (and (boundp 'emacs-mouse-loaded) 
  238.                       emacs-mouse-loaded)
  239.                  (list (button any with-control)))))
  240.                  (window-make titlebar () () () ())))
  241.  
  242. ; (: twm-titled-win.data result)
  243. ; (df twm-titled-win () twm-titled-win.data)
  244.  
  245. (if (not (= screen. (namespace-of 'twm-titled-win.data)))
  246.       (defname 'twm-titled-win.data screen.))
  247.  
  248.  
  249. ;    (defname-in-screen-to () twm-titled-win.data twm-titled-win))
  250.     
  251. (df twm-titled-win () (if (boundp 'twm-titled-win.data) twm-titled-win.data
  252.               (progn
  253.                 (twm-titled-win-setup)
  254.                 (: twm-titled-win.data
  255.                    (eval twm-titled-win.result)))))
  256.  
  257.