;; custom-menu.gwm --- User-friendlier package customizations
;;
;; Author: Anders Holst  (aho@sans.kth.se)  
;; Copyright (C) 1996  Anders Holst
;; Last change: 23/3 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 implements a way for other packages to provide easy
;; customization via menus, without spending too much effort on it
;; themselves.
;;
;;
;; The main function is '(custom-menu <MENU-DESCRIPTION>)'.
;;
;; In the simplest case its argument is a list of strings and variables,
;; and it constructs a menu where the user can edit the values of the
;; given variables. Typically the first element in the list should be
;; the name of the menu, but any strings in the list show up as labels.
;;
;; The list can also contain other "menu descriptions" as elements.
;; They will turn up as buttons leading to these "sub-menus". Note that
;; then the first element in each sub-menu description *must* be
;; the name of it (and not a variable or a sub-description).
;;
;; Actually, the first element in each menu-description can also be a
;; list where the first element is the name of it and the rest an
;; association list. Currently the only supported field in this
;; association list is 'hook', which should be some code to run whenever
;; the value of a variable is changed in the menu.
;;
;; To start edit a value in the menu, you click in the corresponding
;; field. If the variable 'custom-immediate-change' is non-nil, the
;; variable is assigned to the new value as soon you finish editing.
;; There is also a special construct, to allow more complex values. If
;; the field starts with a comma (,) the following expression is
;; evaluated before the assignment.
;; 
;; But that's all there is to it really.
;;
;; The rest of the code in this file is to provide a simple way
;; for packages to install their customizable variables in a global
;; custom-menu hierarchy, and to maintain the user's variable settings
;; between GWM sessions.
;;
;;
;; There are two functions intended to be used by the package developer:
;;   (custom-install-symbols <PACKAGE-NAME> <SYMBOL-LIST>)
;;   (custom-install-hook <PACKAGE-NAME> <HOOK-CODE>)
;;
;; The <PACKAGE-NAME> is either a string, or a list of strings serving
;; as a "path" through the menu hierarchy. <SYMBOL-LIST> is the list of
;; all customizable variables in the package. <HOOK-CODE> is a piece of
;; code (quoted) to run whenever any of the customizable variables
;; have changed. It is of course not necessary to provide such a hook,
;; but it is very nice to have one.
;;
;; Another thing to consider for the package developer is to make the
;; variables suitable for customization in this way. Colors and fonts
;; should *not* be stored as numbers but as the strings used when
;; creating them. The contents of variables should preferably not be
;; very long lists, since these are hard to edit. If values are cached
;; there should be some way of updating the cache when the values have
;; changed, and if values are not cached the package should not assume
;; that the contents of variables will remain the same during the whole
;; session.
;;
;;
;; There are three functions intended for the GWM user:
;;   (custom-global-menu)
;;   (custom-load-preferences)
;;   (custom-save-preferences)
;;
;; '(custom-global-menu)' brings you into the top of the custom-menu
;; hierarchy. It is most suitably called from the root menu.
;;
;; The function '(custom-load-preferences)' can be called either when
;; loading the profile, or from the 'screen-opening' hook and 
;; '(custom-save-preferences)' can be called from the 'screen-closing'
;; hook. They try to maintain a file ".customize.gwm" where the
;; variables the user have changed through the custom menus are saved.
;;

(declare-screen-dependent
    custom-font
    custom-symbol-font
    custom-value-font
    custom-value-font-slant
    custom-background
    custom-foreground
    custom-button-background
    custom-value-background
    custom-value-frame
    custom-immediate-feedback
    custom-immediate-change
    custom-keep-comma-string
    custom-preference-file
    custom-global-preferences
    custom-preferences-changed
    custom-global-menu-descr
)

;;
;;    USER CUSTOMIZABLE VARIABLES
;;    ---------------------------  
;;    Adjust these in your own profile
;;
(with (wob wob)
  (for screen (list-of-screens)
     (defaults-to
       custom-font "6x13bold"
       custom-symbol-font "6x13"
       custom-value-font "6x13"
       custom-value-font-slant 0
       custom-foreground "black"
       custom-background "lightcyan"
       custom-button-background "white"
       custom-value-background "white"
       custom-value-frame t
       custom-immediate-feedback t
       custom-immediate-change t
       custom-keep-comma-string t
)))

(with (wob wob)
  (for screen (list-of-screens)
    (setq custom-global-preferences ())
    (setq custom-preferences-changed ())
    (setq custom-global-menu-descr '("Customizations"))
))

(with (tmp (getenv "GWM_CUSTOM_FILE"))
  (if (= tmp "")
      (setq custom-preference-file "./.customize.gwm")
    (match "/" tmp)
      (setq custom-preference-file tmp)
    (setq custom-preference-file (+ "./" tmp))))

(if (not (boundp 'edit-plug-make))
    (load "edit-plug"))

(defun custom-print-to-string (val)
  (if (member (type val) '(subr fsubr expr fexpr))
      "<PROC>"
    (= (type val) 'string)
      (+ "\"" val "\"")
    (= (type val) 'list)
      (with (parts (mapfor ele val (custom-print-to-string ele))
             len (length parts)
             res (list-make (+ (* len 2) 1))
             i 0 j 1)
        (## 0 res "(")
        (while (< i len)
          (## j res (# i parts))
          (## (+ j 1) res " ")
          (setq i (+ i 1))
          (setq j (+ j 2)))
        (## (max 1 (- j 1)) res ")")
        (apply + res))
      (with-output-to-string (? val))))

(defun custom-read-from-string (_str_)
  (with (_res_ ()
         _bad_ t)
    (error-occurred 
     (if (match "^," _str_)
         (execute-string (+ "(setq _bad_ (error-occurred (setq _res_ "
                            (match "^.\\(.*\\)$" _str_ 1)
                            ")))"))
       (execute-string (+ "(setq _bad_ (error-occurred (setq _res_ (quote "
                          _str_
                          "))))"))))
    (if _bad_
        ()
      (list _res_))))
  
(defun custom-substitute-in-string (from to str)
  (with (res ()
         mlst ()
         head str)
    (while (> (length (setq mlst (match (+ "\\(.*\\)\\(" from "\\)\\(.*\\)")
                                        head 1 2 3)))
              0)
      (setq res (+ (list to (# 2 mlst)) res))
      (setq head (# 0 mlst)))
    (eval (+ '(+) (list head) res))))

;; Specialized normal state, how to start editing.
(: custom-edit-normal-state
      (state-make
	(on (button any any)
            (progn
              (send-user-event 'edit-plug-start wob)
              (edit-plug-xposition (current-event-relative-x))))
	edit-plug-normal-state
    ))

;; Specialized active state, when to stop or abort editing.
(: custom-edit-active-state
      (state-make
	(on focus-out
	    (send-user-event 'edit-plug-done wob))
	edit-plug-active-state
    ))

;; Things to do when starting editing.
(defun custom-start-edit ()
    (set-focus wob)
    (process-events))  ; To let the focus change take effect before the
                       ; fsm enters the active state. Otherwise the fsm
                       ; may immediately leave the active state again,
                       ; due to some spurious focus-out event.

;; Things to do when editing is done.
(defun custom-end-edit ()
  (with (menuwob (custom-top-parent)
         immch (# 'immch menuwob)
         sym (# 'symbol wob)
         str (edit-plug-get)
         comma (and custom-keep-comma-string (match "^," str))
         res (custom-read-from-string str))
    (if res
        (if (not (equal (# 2 sym) (if comma str res)))
            (progn
              (if (not (# 3 sym))
                  (## 3 sym (or (# 2 sym) t)))
              (## 2 sym (if comma str res))
              (if immch
                  (progn
                    (set (# 0 sym) (# 0 res))
                    (## 4 sym t)
                    (eval (# 'hook wob))))
              (if (and (not comma) custom-immediate-feedback)
                  (edit-plug-change (custom-print-to-string (# 0 res))))))
      (if custom-immediate-feedback
          (edit-plug-change (if (# 2 sym)
                                (if (= (type (# 2 sym)) 'string)
                                    (# 2 sym)
                                  (custom-print-to-string (# 0 (# 2 sym))))
                              ""))))))

(defun custom-abort-edit ()
    ())

(defun custom-plug-separator (size)
  (with (fsm ()
         foreground background)
    (plug-make (pixmap-make size 1))))

(defun custom-symbol-plug (label)
  (with (fsm ()
         font (if (= (type custom-symbol-font) 'number)
                  custom-symbol-font
                (font-make custom-symbol-font))
         label-horizontal-margin 2
         label-vertical-margin 2)
    (plug-make (label-make label))))

(defun custom-label-plug (label)
  (with (fsm ()
         font (if (= (type custom-font) 'number)
                  custom-font
                (font-make custom-font))
         label-horizontal-margin 2
         label-vertical-margin 2)
    (plug-make (label-make label))))

(defun custom-value-plug (item)
  (with (font (if (= (type custom-value-font) 'number)
                  custom-value-font
                (font-make custom-value-font))
         font-slant (or custom-value-font-slant 0)
         label-horizontal-margin 4
         label-vertical-margin 1
         edit-plug-start-hook '(custom-start-edit)
         edit-plug-done-hook '(custom-end-edit)
         edit-plug-abort-hook '(custom-abort-edit)
         edit-plug-normal-state custom-edit-normal-state
         edit-plug-active-state custom-edit-active-state
         property (+ (list 'symbol item 'hook hook) property))
    (with (borderwidth (if custom-value-frame 1 0)
           borderpixel foreground)
      (bar-make 
        (with (borderwidth 0)
          (bar-make
            (with (borderwidth 1
                   background (if custom-value-background
                                  (if (= (type custom-value-background)
                                         'number)
                                      custom-value-background
                                    (color-make custom-value-background))
                                background)
                   borderpixel background
                   active-borderpixel foreground)
              (edit-plug-make (if (# 2 item)
                                (if (= (type (# 2 item)) 'string)
                                    (# 2 item)
                                  (custom-print-to-string (# 0 (# 2 item))))
                                "")))))))))

(defun custom-button-plug (label action)
  (with (font (if (= (type custom-font) 'number)
                  custom-font
                (font-make custom-font))
         outer-background background
         background (if custom-button-background
                        (if (= (type custom-button-background) 'number)
                            custom-button-background
                          (color-make custom-button-background))
                      background)
         label-horizontal-margin 5
         label-vertical-margin 3
         pix (label-make label)
         dim (dimensions pix))
    (draw-rectangle pix 2 2 (- (# 2 dim) 4) (- (# 3 dim) 4) 2 1)
    (with (foreground outer-background)
      (draw-line pix 0 0 0 1)
      (draw-line pix 1 0 1 0)
      (draw-line pix 0 (- (# 3 dim) 2) 0 (- (# 3 dim) 1))
      (draw-line pix 1 (- (# 3 dim) 1) 1 (- (# 3 dim) 1))
      (draw-line pix (- (# 2 dim) 1) 0 (- (# 2 dim) 1) 1)
      (draw-line pix (- (# 2 dim) 2) 0 (- (# 2 dim) 2) 0)
      (draw-line pix (- (# 2 dim) 1) (- (# 3 dim) 2)
                     (- (# 2 dim) 1) (- (# 3 dim) 1))
      (draw-line pix (- (# 2 dim) 2) (- (# 3 dim) 1)
                     (- (# 2 dim) 2) (- (# 3 dim) 1)))
    (draw-line pix 2 2 2 2)
    (draw-line pix (- (# 2 dim) 3) 2 (- (# 2 dim) 3) 2)
    (draw-line pix 2 (- (# 3 dim) 3) 2 (- (# 3 dim) 3))
    (draw-line pix (- (# 2 dim) 3) (- (# 3 dim) 3)
                   (- (# 2 dim) 3) (- (# 3 dim) 3))
    (with (fsm (fsm-make (state-make (on-eval '(button any any) action))))
      (plug-make pix))))

(defun custom-top-parent ()
  (with (wob wob
         par wob-parent)
    (while (not (= par window))
      (setq wob wob-parent)
      (setq par wob-parent))
    wob))

(defun custom-done ()
  (with (menuwob (custom-top-parent)
         descr (# 'descr menuwob)
         hook (# 'hook menuwob)
         change ()
         res ())
    (set-focus)
    (process-events)
    (for sym descr
      (if (and (# 0 sym) (# 2 sym) (# 3 sym) (not (# 4 sym)))
          (if (= (type (# 2 sym)) 'string)
              (if (setq res (custom-read-from-string (# 2 sym)))
                  (progn 
                    (set (# 0 sym) (# 0 res))
                    (setq change t)))
            (progn
              (set (# 0 sym) (# 0 (# 2 sym)))
              (setq change t)))))
    (if change
        (with (custom-refresh-menu ())
          (eval hook)))
    (for sym descr
      (if (and (# 0 sym) (# 2 sym) (# 3 sym))
          (custom-put-preference (# 0 sym) (# 2 sym))))
    (if (window-is-valid window)
        (delete-window window))))

(defun custom-cancel ()
  (with (menuwob (custom-top-parent)
         descr (# 'descr menuwob)
         hook (# 'hook menuwob)
         change ()
         res ())
    (set-focus)
    (process-events)
    (for sym descr
      (if (and (# 0 sym) (# 3 sym) (# 4 sym))
          (if (= (# 3 sym) t)
              (unbind (# 0 sym))
            (= (type (# 3 sym)) 'string)
              (if (setq res (custom-read-from-string (# 3 sym)))
                  (progn 
                    (set (# 0 sym) (# 0 res))
                    (setq change t)))
            (progn
              (set (# 0 sym) (# 0 (# 3 sym)))
              (setq change t)))))
    (if change
        (with (custom-refresh-menu ())
          (eval hook)))
    (delete-window window)))

(defun custom-construct-menu (descr)
  (with (fsm ()
         bordertile ()
         bar-max-width 3000
         bar-min-width 0
         background (if (= (type custom-background) 'number)
                        custom-background
                      (color-make custom-background))
         foreground (if (= (type custom-foreground) 'number)
                        custom-foreground
                      (color-make custom-foreground))
         borderpixel background
         borderwidth 1
         direction vertical
         align-column 0
         bar-list ()
         hook (if (not (# 0 (# 0 descr))) (# 'hook (# 2 (# 0 descr)))))
    (with (m 0 sz ())
      (for ele descr
        (if (# 0 ele)
            (with (font (if (= (type custom-symbol-font) 'number)
                            custom-symbol-font
                          (font-make custom-symbol-font)))
              (setq sz (# 2 (dimensions (+ (# 0 ele)))))
              (## 1 ele sz)
              (setq m (max m sz)))))
      (setq align-column (+ m 2)))
    (setq bar-list 
          (mapfor ele descr
            (if (# 0 ele)
                (bar-make 
                  (custom-plug-separator 5)
                  (custom-symbol-plug (# 0 ele))
                  (custom-plug-separator (- align-column (# 1 ele)))
                  (custom-value-plug ele)
                  (custom-plug-separator 10))
              (= (type (# 1 ele)) 'list)
                (bar-make  
                  (custom-plug-separator 10)
                  (custom-button-plug (if (= (type (# 0 (# 1 ele))) 'string)
                                          (# 0 (# 1 ele))
                                        (# 0 (# 0 (# 1 ele))))
                                      (list 'custom-menu
                                            (list 'quote (# 1 ele))
                                            '(+ window-x 15)
                                            '(+ window-y 15))))
              (= (type (# 1 ele)) 'string)
                (bar-make
                  (custom-plug-separator 10)
                  (custom-label-plug (# 1 ele))))))
    (setq bar-list (+ bar-list
                      (list (bar-make 
                             (custom-plug-separator 10)
                             (custom-button-plug "Done" '(custom-done))
                             (custom-plug-separator 15)
                             (custom-button-plug "Cancel" '(custom-cancel))
                             (custom-plug-separator 10)))))
    (with (property (+ (list 'descr descr
                             'hook hook
                             'immch custom-immediate-change) property)
           borderpixel foreground)
      (apply menu-make bar-list))))

(defun custom-menu _args_
  (with (descr (mapfor _cele_ (# 0 _args_)
                 (if (not (member (type _cele_) '(string list)))
                     (list _cele_ ()
                           (or (with (res (custom-get-preference _cele_))
                                 (if (and res (= (type res) 'string)) res ()))
                               (if (boundp _cele_) (list (eval _cele_)) ()))
                           () ())
                   (list () _cele_)))
         xpos (if (= (type (# 1 _args_)) 'number) (# 1 _args_))
         ypos (if (= (type (# 2 _args_)) 'number) (# 2 _args_))
         mn ())
    (if (and (not (# 0 (# 0 descr)))
             (= (type (# 1 (# 0 descr))) 'list)
             (= (type (# 0 (# 1 (# 0 descr)))) 'string))
        (## 0 descr (list ()
                          (# 0 (# 1 (# 0 descr)))
                          (sublist 1 (length (# 1 (# 0 descr)))
                                   (# 1 (# 0 descr))))))
    (setq mn (custom-construct-menu descr))
    (if mn
        (with (reenter-on-opening ()
               dim (dimensions mn)
               x (max 10 (/ (- screen-width (# 2 dim)) 3))
               y (max 10 (/ (- screen-height (# 3 dim)) 3)))
          (if (and xpos ypos)
              (place-menu 'custom mn xpos ypos)
            (place-menu 'custom mn x y))))))

(defun custom-refresh-menu ()
  (with (menuwob (custom-top-parent)
         descr (# 'descr menuwob)
         hook (# 'hook menuwob)
         immch (# 'immch menuwob)
         xpos (+ window-x window-client-x
                 (with (wob window) wob-borderwidth)
                 (with (wob menuwob) (- wob-borderwidth))
                 window-client-borderwidth)
         ypos (+ window-y window-client-y
                 (with (wob window) wob-borderwidth)
                 (with (wob menuwob) (- wob-borderwidth))
                 window-client-borderwidth)
         mn ())
    (if (not (= immch custom-immediate-change))
        (for sym descr
          (if (and (# 0 sym) (# 4 sym))
              (## 4 sym ()))))
    (setq mn (custom-construct-menu descr))
    (if mn
        (with (reenter-on-opening ())
          (delete-window window)
          (place-menu 'custom mn xpos ypos)))))

(defun custom-save-file (file lst)
  (with-output-to-file (+ file ":")
    (? "(setq tmp '(\n")
    (with (i 0)
      (while (< i (length lst))
        (? (custom-print-to-string (# i lst)) " "
           (custom-print-to-string 
            (if (= (type (# (+ i 1) lst)) 'string)
                (custom-substitute-in-string "\"" "\\\""
                                             (# (+ i 1) lst))
              (# (+ i 1) lst)))
           "\n")
        (setq i (+ i 2))))
    (? "))\n"))
  (! "sh" "-c" (+ "mv " file " " file "~ ; mv " file ": " file " ;"))
)

(defun custom-read-file (file)
  (with (tmp 'magicatom)
    (error-occurred
      (load file))
    (if (= tmp 'magicatom)
        ()
      tmp)))

(defun custom-put-preference (var val)
  (if (member var custom-global-preferences)
      (## var custom-global-preferences val)
    (setq custom-global-preferences
          (+ custom-global-preferences
             (list var val))))
  (setq custom-preferences-changed t))

(defun custom-get-preference (var)
  (# var custom-global-preferences))

(defun custom-apply-preferences (prefs)
  (with (len (length prefs)
         i 0
         res ())
    (while (< i len)
      (if (= (type (# (+ i 1) prefs)) 'string)
          (if (setq res (custom-read-from-string (# (+ i 1) prefs)))
              (set (# i prefs) (# 0 res)))
        (set (# i prefs) (# 0 (# (+ i 1) prefs))))
      (setq i (+ i 2)))))

(defun custom-save-preferences ()
  (if custom-preferences-changed
      (custom-save-file custom-preference-file custom-global-preferences))
  (setq custom-preferences-changed ()))

(defun custom-load-preferences ()
  (setq custom-global-preferences (custom-read-file custom-preference-file))
  (custom-apply-preferences custom-global-preferences)
  (setq custom-preferences-changed ()))

(defun custom-insert-symbols (lst syms)
  (with (len (length lst)
         i (- len 1)
         syms (copy syms)
         s1 ()
         s2 ())
    (while (and (> i 0) (= (type (# i lst)) 'list))
      (setq i (- i 1)))
    (setq s1 (sublist 0 (+ i 1) lst))
    (setq s2 (sublist (+ i 1) len lst))
    (setq i (- (length syms) 1))
    (while (> i -1)
      (if (member (# i syms) s1)
          (delete-nth i syms))
      (setq i (- i 1)))
    (+ s1 syms s2)))

(defun custom-insert-hook (head hook)
  (if (not (= (type head) 'list))
      (list head 'hook hook)
    (not (member 'hook head))
      (+ head (list 'hook hook))
      (with (oh (# 'hook head))
        (## 'hook head
            (if (not oh)
                hook
              (and (= (type oh) 'list) (= (# 0 oh) 'progn))
                (+ oh (list hook))
                (list 'progn oh hook))))))

(defun custom-find-name (lst name)
  (with (len (length lst)
         i 1)
    (while (and (< i len)
                (not (and (= (type (# i lst)) 'list)
                          (or (and (= (type (# 0 (# i lst))) 'string)
                                   (= (# 0 (# i lst)) name))
                              (and (= (type (# 0 (# i lst))) 'list)
                                   (= (type (# 0 (# 0 (# i lst)))) 'string)
                                   (= (# 0 (# 0 (# i lst))) name))))))
      (setq i (+ i 1)))
    (if (< i len)
        i
      ())))

(defun custom-install-symbols (name syms)
  (if (not name)
      (setq custom-global-menu-descr
            (custom-insert-symbols custom-global-menu-descr syms))
    (with (name (if (not (= (type name) 'list)) (list name) name)
           len (length name)
           i 0
           lst1 ()
           pos1 ()
           lst custom-global-menu-descr
           pos ())
      (while (< i len)
        (setq pos (custom-find-name lst (# i name)))
        (if (not pos)
            (progn
              (if pos1
                  (## pos1 lst1 (setq lst (+ lst (list (list (# i name))))))
                (setq lst (setq custom-global-menu-descr
                                (+ custom-global-menu-descr
                                   (list (list (# i name)))))))
              (setq pos (- (length lst) 1))))
        (setq pos1 pos)
        (setq lst1 lst)
        (setq lst (# pos1 lst1))
        (setq i (+ i 1)))
      (## pos1 lst1 (custom-insert-symbols lst syms)))))

(defun custom-install-hook (name hook)
  (if (not name)
      (## 0 custom-global-menu-descr
          (custom-insert-hook (# 0 custom-global-menu-descr) hook))
    (with (name (if (not (= (type name) 'list)) (list name) name)
           len (length name)
           i 0
           lst1 ()
           pos1 ()
           lst custom-global-menu-descr
           pos ())
      (while (< i len)
        (setq pos (custom-find-name lst (# i name)))
        (if (not pos)
            (progn
              (if pos1
                  (## pos1 lst1 (setq lst (+ lst (list (list (# i name))))))
                (setq lst (setq custom-global-menu-descr
                                (+ custom-global-menu-descr
                                   (list (list (# i name)))))))
              (setq pos (- (length lst) 1))))
        (setq pos1 pos)
        (setq lst1 lst)
        (setq lst (# pos1 lst1))
        (setq i (+ i 1)))
      (## 0 lst (custom-insert-hook (# 0 lst) hook)))))

(defun custom-global-menu ()
  (custom-menu custom-global-menu-descr))


;; Now, let this package install itself
(custom-install-symbols "custom-menu"
  '(custom-font
    custom-symbol-font
    custom-value-font
    custom-value-font-slant
    custom-foreground
    custom-background
    custom-button-background
    custom-value-background
    custom-value-frame
    custom-immediate-feedback
    custom-immediate-change
    custom-keep-comma-string)
)

(custom-install-hook "custom-menu" '(custom-refresh-menu))