;; fvwm-icon.gwm --- FVWM style icons.
;;
;; Author: Anders Holst  (aho@sans.kth.se)  
;; Copyright (C) 1996  Anders Holst
;; Last change: 26/2 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. 
;;
;; ---------------------------------------------------------------------
;;
;; This file defines FVWM style icons that goes with the FVWM style
;; windows in "fvwm-window.gwm".
;;
;; You can set 'fvwm-pixmap-path' to point where the "real" fvwm keeps
;; its icon files, just to make them look more similar.
;; 

(declare-screen-dependent
    fvwm-icon-action
    fvwm-icon-assoc-list
    fvwm-pixmap-path
)

;;
;;    USER CUSTOMIZABLE VARIABLES
;;    ---------------------------  
;;    Adjust these in your own profile
;;
(with (wob wob)
  (for screen (list-of-screens)
     (defaults-to
       fvwm-icon-action '(iconify-window)
           ; Action to execute when pressing the icon title.
           ; Can also be a list of ( <button-spec> <action>
           ; [<action-type>] ) specifications.
       fvwm-pixmap-path '("/usr/X11R6/include/X11/pixmaps/")
           ; Where it is likely to find some good icon pixmaps.
       fvwm-icon-assoc-list '(Emacs "emacs")
           ; Mapping between window-client-class and icon file name when
           ; the simple window-client-name heuristic does not work.
       ; Also, the variable 'fvwm-window-styles' from "fvwm-window.gwm"
       ; can contain these additional properties: icon-color,
       ; active-icon-color, icon-title-color, active-icon-title-color,
       ; icon-action, icon-outer-border.
)))


(require 'fvwm-window)

; THE ICON :
; ==========


(defun fvwm-inner-iconbar ()
  (with (
         fsm (fsm-make (state-make fvwm-title-behavior 
                                   (fvwm-button-behavior fvwm-icon-action 'release)))
         lseam (fvwm-title-seam-pixmap (# 0 color-scheme) title-width)
         rseam (fvwm-title-seam-pixmap (# 2 color-scheme) title-width)
         alseam (fvwm-title-seam-pixmap (# 0 active-color-scheme) title-width)
         arseam (fvwm-title-seam-pixmap (# 2 active-color-scheme) title-width)
         lredo '(fvwm-title-seam-pixmap 
                 (# (if pressed 2 0)
                    (if active active-color-scheme color-scheme)) title-width)
         rredo '(fvwm-title-seam-pixmap
                 (# (if pressed 0 2)
                    (if active active-color-scheme color-scheme)) title-width)
         redo-expr '(if pressed 
                        (with (active-color-scheme
                               (list (# 2 active-color-scheme)
                                     (# 1 active-color-scheme)
                                     (# 0 active-color-scheme)))
                          (fvwm-hbar-tile title-width active 'title))
                      (fvwm-hbar-tile title-width active 'title))
         tile (with (active () pressed ()) (eval redo-expr))
         atile (with (active t pressed ()) (eval redo-expr))
         ptile (with (active t pressed t) (eval redo-expr))
         property (list 'pixmap tile
                        'activepixmap atile
                        'pressedpixmap ptile
                        'redo-expr redo-expr)
         bar-min-width title-width
         bar-max-width bar-min-width
         plug-separator 4
         )
    (bar-make
     (with (property (list 'pixmap lseam 'activepixmap alseam
                           'pressedpixmap arseam 'redo-expr lredo))
       (plug-make lseam))
     (fvwm-title-plug '(if (= window-icon-name "icon") window-name window-icon-name))
     (with (property (list 'pixmap rseam 'activepixmap arseam
                           'pressedpixmap alseam 'redo-expr rredo))
       (plug-make rseam))
     )))

(defun fvwm-iconbar (outer-border)
  (with (menu ()
         tile ()
         fsm (fsm-make fvwm-frame-behavior)
         plug-separator 0
         cursor fvwm-frame-cursor
         borderwidth 0
         bar-min-width 0
         bar-max-width 1000
         lseam-expr '(fvwm-title-seam-pixmap 
                      (# 0 (if active active-color-scheme color-scheme))
                      (+ title-width 2))
         rseam-expr '(fvwm-title-seam-pixmap
                      (# 2 (if active active-color-scheme color-scheme))
                      (+ title-width 2))
         lseam (with (active ()) (eval lseam-expr))
         alseam (with (active t) (eval lseam-expr))
         rseam (with (active ()) (eval rseam-expr))
         arseam (with (active t) (eval rseam-expr))
         lseam-prop (list 'pixmap lseam 'activepixmap alseam
                          'redo-expr lseam-expr)
         rseam-prop (list 'pixmap rseam 'activepixmap arseam
                          'redo-expr rseam-expr)
         redo-expr '(fvwm-hbar-tile (+ title-width 2) active ())
         tile (with (active ()) (eval redo-expr))
         atile (with (active t) (eval redo-expr))
         property (list 'pixmap tile 'activepixmap atile
                        'redo-expr redo-expr)
         bar-min-width (+ title-width 2)
         bar-max-width bar-min-width
         params1 (+
                  (with (property lseam-prop)
                    (list (plug-make lseam)))
                  (with (bar-max-width 10000)
                    (list (bar-make () (fvwm-inner-iconbar) ())))
                  (with (property rseam-prop)
                    (list (plug-make rseam)))))
    (with (borderwidth outer-border)
      (eval (+ '(bar-make) params1)))))

;; Test if file exists. This is an  ugly hack. Pure luck if it works.
(defun check-pixmap-file (file)
  (with (res t)
    (error-occurred
      (if (load file)
          (setq res t)
        (setq res ())))
    res))

(defun load-pixmap-in-path (file path)
  (if (match "^/" file)
      (if (check-pixmap-file file)
          (pixmap-load file))
    (with (i 0
           len (length path))
      (while (and (< i len) (not (check-pixmap-file (+ (# i path) file))))
        (setq i (+ i 1)))
      (if (< i len)
          (pixmap-load (+ (# i path) file))))))

(setq fvwm-icon-pixmap-behavior
   (state-make
	(on (user-event 'focus-in)
            (wob-tile (# 'activepixmap wob-property)))
        (on (user-event 'focus-out)
            (wob-tile (# 'pixmap wob-property)))
        (on (user-event 're-color)
            (with (background (# 1 active-color-scheme)
                   foreground (# 3 active-color-scheme)
                   apm (window-icon-pixmap)
                   background (# 1 color-scheme)
                   foreground (# 3 color-scheme)
                   npm (window-icon-pixmap))
              (wob-tile (if (eq (wob-tile) (# 'activepixmap wob-property))
                            apm npm))
              (## 'pixmap wob npm)
              (## 'activepixmap wob apm)
              (## 'bg wob (# 1 color-scheme))
              (## 'abg wob (# 1 active-color-scheme))
              (## 'fg wob (# 3 color-scheme))
              (## 'afg wob (# 3 active-color-scheme))))
        (on (user-event 'icon-pixmap-change)
            (with (background (# 'abg wob-property)
                   foreground (# 'afg wob-property)
                   apm (window-icon-pixmap)
                   background (# 'bg wob-property)
                   foreground (# 'fg wob-property)
                   npm (window-icon-pixmap))
              (wob-tile (if (eq (wob-tile) (# 'activepixmap wob-property))
                            apm npm))
              (## 'pixmap wob npm)
              (## 'activepixmap wob apm)))))

(defun fvwm-iconcenter ()
  (or (with (fsm ())
        (window-icon-window))
      (with (borderwidth 0
             background (# 1 active-color-scheme)
             foreground (# 3 active-color-scheme)
             apm (window-icon-pixmap)
             background (# 1 color-scheme)
             foreground (# 3 color-scheme)
             npm (window-icon-pixmap)
             fsm (fsm-make fvwm-icon-pixmap-behavior)
             property (list 'pixmap npm
                            'activepixmap apm
                            'bg (# 1 color-scheme)
                            'abg (# 1 active-color-scheme)
                            'fg (# 3 color-scheme)
                            'afg (# 3 active-color-scheme)))
        (if npm (plug-make npm)))
      (with (fsm ()
             file (+ (or (# (atom window-client-class) fvwm-icon-assoc-list)
                         window-client-name) ".xpm")
             pmap (load-pixmap-in-path file fvwm-pixmap-path))
        (if pmap (plug-make pmap)))))

(setq fvwm-icon-behavior
   (state-make
        (on focus-out (send-user-event 'focus-out window))
        (on focus-in (send-user-event 'focus-in window))
        (on leave-window-not-from-grab (send-user-event 'focus-out window))
        (on enter-window (send-user-event 'focus-in window))
        (on (user-event 'update-color)
            (with (props (matches-cond-all fvwm-window-styles)
                   cols (fvwm-get-icon-colors (matches-cond fvwm-color-styles) props)
                   title-width (# 'title-width window)
                   color-scheme (make-color-scheme (# 0 cols) (# 2 cols))
                   active-color-scheme (make-color-scheme (# 1 cols) (# 3 cols)))
              (send-user-event 'pre-color window)
              (send-user-event 're-color window)))
        (on name-change 
            (progn
              (send-user-event 'name-change)
              (if (boundp 'update-placements)
                  (update-placements))
              (if (boundp 'icon-mgr-update)
                  (icon-mgr-update))))
	(on (property-change "WM_ICON_NAME")
            (progn
              (if (window-icon?)
                  (send-user-event 'name-change window-icon))
              (if (boundp 'update-placements)
                  (update-placements))
              (if (boundp 'icon-mgr-update)
                  (icon-mgr-update))))
        (on window-icon-pixmap-change
            (send-user-event 'icon-pixmap-change window-icon))
        )
)

(defun fvwm-get-icon-colors (styles props)
  (with (col (or (fvwm-get-style props 'icon-color 
                                 (fvwm-get-style props 'color ()))
                 (# 0 styles)
                 fvwm-color)
         acol (or (fvwm-get-style props 'active-icon-color
                                  (fvwm-get-style props 'active-color
                                                  (or (# 1 styles)
                                                      fvwm-active-color)))
                  col)
         tcol (or (fvwm-get-style props 'icon-title-color 
                                  (fvwm-get-style props 'title-color ()))
                  (# 2 styles)
                  fvwm-title-color
                  "black")
         atcol (or (fvwm-get-style props 'active-icon-title-color
                                   (fvwm-get-style props 'active-title-color
                                                   (or (# 3 styles)
                                                       fvwm-active-title-color)))
                   tcol))
    (list col acol tcol atcol)))

(defun fvwm-icon ()
  (with (fsm (fsm-make (state-make icon-behavior fvwm-icon-behavior standard-behavior))
         cursor fvwm-frame-cursor
         props (matches-cond-all fvwm-window-styles)
         cols (fvwm-get-icon-colors (matches-cond fvwm-color-styles) props)
         title-font (fvwm-get-style props 'title-font fvwm-title-font)
         fonthgt (with (font title-font
                        label-vertical-margin 0
                        label-horizontal-margin 0)
                   (# 3 (dimensions " ")))
         title-width (or (fvwm-get-style props 'title-width fvwm-title-width)
                         (+ 4 fonthgt))
         fvwm-icon-action (fvwm-get-style props 'icon-action fvwm-icon-action)
         outer-border (fvwm-get-style props 'icon-outer-border 
                                      (fvwm-get-style props 'outer-border
                                                      fvwm-outer-border))
         color-scheme (make-color-scheme (# 0 cols) (# 2 cols))
         active-color-scheme (make-color-scheme (# 1 cols) (# 3 cols))
         borderwidth 0
         inner-borderwidth 0
         borderpixel black
         property (list 'title-width title-width)
         center (fvwm-iconcenter)
         label (fvwm-iconbar (if outer-border
                                 (if (= (type outer-border) 'number)
                                     outer-border 1) 0)))
     (if center
         (with (tile t)
           (window-make ()
                        (with (fsm ()) (bar-make ()))
                        (with (fsm ()) (bar-make ()))
                        (with (fsm ()) (bar-make () (bar-make label) ()))
                        center))
       (window-make () () () label ()))))