#!/bin/sh
exec rep "$0" "$@"
!#

;; themer -- GUI for editing sawmill themes
;; $Id: themer.in,v 1.18 2001/09/02 17:11:44 jsh Exp $

;; Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>

;; This file is part of sawmill.

;; sawmill is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; sawmill is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with sawmill; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;; todo
;; * warn when unsaved changes would be lost
;; * allow all frame types to be previewed

;; for debugging
(setq backtrace-on-error '(bad-arg missing-arg void-value invalid-function))

(defvar version "__version__")
(defvar glade-file "__sawfishdir__/__version__/themer.glade")
(defvar locale-dir "__locale_dir__")

(when (and (not (get-command-line-option "--disable-nls"))
	   (file-directory-p locale-dir))
  (require 'rep.i18n.gettext)
  (bindtextdomain "sawfish" locale-dir)
  (textdomain "sawfish"))

;; load this after gettext
(require 'gui.gtk.gtk)
(require 'gui.gtk.libglade)

(require 'sawfish.client)


;; configuration

;; preferences
(defvar reload-themes-after-saving t)
(defvar filter-when-saving nil)

;; function to call for online help, set later
(defvar help-launcher nil)

(defvar preferences-attrs
  `((reload-themes-after-saving
     (boolean ,(_ "Reload themes in window manager after saving.")))
    (filter-when-saving
     (boolean ,(_ "Remove unused definitions when saving.")))))

;; list of all frame part classes
(defvar frame-part-classes '(title menu-button close-button iconify-button
			     maximize-button top-border left-border
			     right-border bottom-border top-left-corner
			     top-right-corner bottom-left-corner
			     bottom-right-corner))

;; possible attributes of each frame part, and their item spec
(defvar frame-part-attrs
  `((class (symbol ,@frame-part-classes))
    (left-edge (optional number))
    (right-edge (optional number))
    (top-edge (optional number))
    (bottom-edge (optional number))
    (width (optional (number 1)))
    (height (optional (number 1)))
    (background (or pattern color))
    (foreground (or pattern color))
    (font (optional font))
    (text (or (symbol window-name window-icon-name) string))
    (x-justify (or (symbol left right center) number))
    (y-justify (or (symbol top bottom center) number))
    (cursor (optional symbol))
    (removable boolean)
    (below-client boolean)))

;; item spec for pattern editing
(defvar pattern-type '(or color image))

;; the order of this is hardcoded into the .glade file..
(defvar pattern-attrs `(inactive focused highlighted
			inactive-highlighted clicked inactive-clicked))

;; frame part classes that may contain patterns
(defvar pattern-classes '(background foreground))

;; item spec for editing image properties
(defvar image-attrs
  `((border (optional (v-and (labelled ,(_ "[left]") number)
			     (labelled ,(_ "[right]") number)
			     (labelled ,(_ "[top]") number)
			     (labelled ,(_ "[bottom]") number))))
    (tiled boolean)))

;; list of all window types
(defvar window-types '(default transient shaped shaped-transient unframed))

;; stack `and' items horizontally by default
(defvar and-direction 'horizontal)


;; variables

(defvar current-filename nil)

;; object representing the widget hierarchy of the main window
(defvar xml (or (and (file-exists-p glade-file)
		     (glade-xml-new glade-file "top-level-window"))
		;; allow themer.in to run uninstalled to aid hacking
		(let
		    ((file (expand-file-name
			    "themer.glade"
			    (file-name-directory load-filename))))
		  (when (file-exists-p file)
		    (setq glade-file file)
		    (glade-xml-new glade-file "top-level-window")))
		(error "can't open file themer.glade")))

;; details data

(defvar theme-name-entry (glade-xml-get-widget xml "theme-name-entry"))
(defvar theme-dir-entry (glade-xml-get-widget xml "theme-dir-entry"))
(defvar theme-about-text (glade-xml-get-widget xml "theme-about-text"))

(defvar theme-name 'unnamed)

;; patterns widgets

(defvar patterns-name-entry (glade-xml-get-widget xml "patterns-name-entry"))
(defvar patterns-clist (glade-xml-get-widget xml "patterns-clist"))
(defvar patterns-table (glade-xml-get-widget xml "patterns-table"))

(defvar patterns-changed-hook nil)

;; patterns data

;; list of (STATE . ITEM)
(defvar patterns-item-alist nil)
(defvar patterns-selection nil)

;; (NAME NORMAL-NAME FOCUSED-NAME HIGH-NAME CLICKED-NAME)
(defvar patterns-alist nil)

;; frame widgets

(defvar frames-name-clist (glade-xml-get-widget xml "frames-name-clist"))
(defvar frames-frame (glade-xml-get-widget xml "frames-frame"))
(defvar frames-part-table-viewport
  (glade-xml-get-widget xml "frames-part-table-viewport"))
(defvar frames-part-clist (glade-xml-get-widget xml "frames-part-clist"))

;; frames data

;; list of (NAME . PARTS)
(defvar frames-alist nil)

(defvar frame-selection nil)
(defvar frame-part-selection nil)

;; list of (ATTR-NAME . ITEM)
(defvar frame-part-table-items nil)

;; mapping widgets

(defvar mapping-combo-hbox (glade-xml-get-widget xml "mapping-combo-hbox"))
(defvar mapping-from-combo (glade-xml-get-widget xml "mapping-from-combo"))
(defvar mapping-to-combo (glade-xml-get-widget xml "mapping-to-combo"))
(defvar mapping-clist (glade-xml-get-widget xml "mapping-clist"))

;; mapping data

;; list of (FRAME-TYPE . FRAME-NAME)
(defvar mapping-alist nil)

(defvar mapping-selection nil)

;; preview widgets

(defvar preview-window nil)

;; saved data

(defvar saved-variables
  '(patterns-alist frames-alist mapping-alist theme-name))


;; compatibility

(unless (boundp 'quotient)
  (setq quotient /))


;; macros

(defmacro save-entry-contents (entry #!rest forms)
  `(let
       ((__save_entry_text__ (gtk-entry-get-text ,entry)))
     (unwind-protect
	 (progn ,@forms)
       (gtk-entry-set-text ,entry __save_entry_text__))))

(defmacro with-clist-frozen (clist #!rest forms)
  `(progn
     (gtk-clist-freeze ,clist)
     (unwind-protect
	 (progn ,@forms)
       (gtk-clist-thaw ,clist))))


;; ``items'', encapsulated widgets

;; each item is a function taking a single argument, the operation to
;; perform on the item. Operations include:

;; 	(set VALUE)
;;	(clear)
;;	(get) => VALUE
;;	widget => GTK-WIDGET
;;	(validp ARG) => BOOL

;; functional operations return the function to perform the operation

;; current item types are:

;;	(symbol OPTIONS...)
;;	(string)
;;	(number [MIN [MAX]])
;;	(boolean)
;;	(color)
;;	(font)
;;	(pattern)
;;	(image)
;;	(or ITEMS...)
;;	(and ITEMS...)
;;	(v-and ITEMS...)
;;	(h-and ITEMS...)
;;	(labelled LABEL ITEM)
;;	(optional ITEM)

;; items without arguments may be specified by name, i.e. `string'
;; instead of `(string)'

;; create a new item of type defined by CELL, either a list (TYPE ARGS...)
;; or a single symbol TYPE. CALLBACK is a function to be called whenever
;; the item's value changes
(defun make-item (cell callback)
  (let*
      ((type (or (car cell) cell))
       (maker (get type 'item-maker)))
    (if maker
	(apply maker callback (cdr cell))
      (error "No item type %s" type))))

(defun set-item-enabled (item enabled)
  (set-widget-enabled (item 'widget) enabled))

(defun make-symbol-item (changed-callback #!rest options)
  (let
      ((widget (gtk-combo-new)))
    ;;(gtk-widget-set-usize (gtk-combo-entry widget) 50 -2)
    (gtk-signal-connect (gtk-combo-entry widget) "changed" changed-callback)
    (when options
      (gtk-combo-set-popdown-strings
       widget (cons "" (mapcar symbol-name options))))
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (gtk-entry-set-text (gtk-combo-entry widget)
				   (if x (symbol-name x) ""))))
	    ((eq op 'clear)
	     (lambda ()
	       (gtk-entry-set-text (gtk-combo-entry widget) "")))
	    ((eq op 'get)
	     (lambda ()
	       (string-to-symbol
		(gtk-entry-get-text (gtk-combo-entry widget)))))
	    ((eq op 'widget)
	     widget)
	    ((eq op 'validp)
	     symbolp)))))
(put 'symbol 'item-maker make-symbol-item)

(defun make-string-item (changed-callback)
  (let
      ((widget (gtk-entry-new)))
    (gtk-signal-connect widget "changed" changed-callback)
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (gtk-entry-set-text widget x)))
	    ((eq op 'clear)
	     (lambda ()
	       (gtk-entry-set-text widget "")))
	    ((eq op 'get)
	     (lambda ()
	       (let
		   ((text (gtk-entry-get-text widget)))
		 (if (string= text "")
		     nil
		   text))))
	    ((eq op 'widget)
	     widget)
	    ((eq op 'validp)
	     stringp)))))
(put 'string 'item-maker make-string-item)

(defun make-number-item (changed-callback #!optional minimum maximum)
  (let
      ((widget (gtk-spin-button-new (gtk-adjustment-new
				     0 (or minimum -65535)
				     (or maximum 65535)
				     1 16 0) 1 0)))
    (gtk-signal-connect widget "changed" changed-callback)
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (when (numberp x)
		 (gtk-spin-button-set-value widget x))))
	    ((eq op 'clear)
	     nop)
	    ((eq op 'get)
	     (lambda ()
	       (gtk-spin-button-get-value-as-int widget)))
	    ((eq op 'widget)
	     widget)
	    ((eq op 'validp)
	     numberp)))))
(put 'number 'item-maker make-number-item)

(defun make-boolean-item (changed-callback #!optional label)
  (let
      ((widget (if label
		   (gtk-check-button-new-with-label label)
		 (gtk-check-button-new))))
    (gtk-signal-connect widget "toggled" changed-callback)
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (gtk-toggle-button-set-state widget x)))
	    ((eq op 'clear)
	     (lambda ()
	       (gtk-toggle-button-set-state widget nil)))
	    ((eq op 'get)
	     (lambda ()
	       (gtk-toggle-button-active widget)))
	    ((eq op 'widget)
	     widget)
	    ((eq op 'validp)
	     (lambda () t))))))
(put 'boolean 'item-maker make-boolean-item)

(defun make-color-item (changed-callback)
  (let*
      ((value nil)
       (button (button-new-with-color value)))
    (gtk-signal-connect
     button "clicked"
     (lambda ()
       (let
	   ((colorsel (gtk-color-selection-dialog-new (_ "Select color"))))
	 (when value
	   (gtk-color-selection-set-color-interp
	    (gtk-color-selection-dialog-colorsel colorsel)
	    (gdk-color-parse-interp value)))
	 (gtk-signal-connect
	  (gtk-color-selection-dialog-ok-button colorsel) "clicked"
	  (lambda ()
	    (let
		((color (gtk-color-selection-get-color-interp
			 (gtk-color-selection-dialog-colorsel colorsel))))
	      (setq value (and color (format nil "#%04x%04x%04x"
					     (gdk-color-red color)
					     (gdk-color-green color)
					     (gdk-color-blue color))))
	      (set-button-color button value)
	      (changed-callback)
	      (gtk-widget-destroy colorsel))))
	 (gtk-signal-connect
	  (gtk-color-selection-dialog-cancel-button colorsel) "clicked"
	  (lambda ()
	    (gtk-widget-destroy colorsel)))
	 (gtk-signal-connect colorsel "delete_event"
			     (lambda ()
			       (gtk-widget-destroy colorsel)))
	 (gtk-widget-hide (gtk-color-selection-dialog-help-button colorsel))
	 (gtk-widget-show colorsel)
	 (gtk-grab-add colorsel))))
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (setq value x)
	       (set-button-color button value)))
	    ((eq op 'clear)
	     (lambda ()
	       (setq value nil)
	       (set-button-color button nil)))
	    ((eq op 'get)
	     (lambda () value))
	    ((eq op 'widget)
	     button)
	    ((eq op 'validp)
	     (lambda (x)
	       (and (stringp x) (string-match "^#" x))))))))
(put 'color 'item-maker make-color-item)

(defun make-font-item (changed-callback)
  (let*
      ((box (gtk-hbox-new nil 4))
       (entry (gtk-entry-new))
       (button (gtk-button-new-with-label (_ "Browse..."))))
    (gtk-box-pack-start box entry)
    (gtk-box-pack-start box button)
    (gtk-signal-connect entry "changed" changed-callback)
    (gtk-signal-connect
     button "clicked"
     (lambda ()
       (let
	   ((fontsel (gtk-font-selection-dialog-new (_ "Select font"))))
	 (gtk-font-selection-dialog-set-font-name
	  fontsel (gtk-entry-get-text entry))
	 (gtk-signal-connect
	  (gtk-font-selection-dialog-ok-button fontsel) "clicked"
	  (lambda ()
	    (gtk-entry-set-text
	     entry (gtk-font-selection-dialog-get-font-name fontsel))
	    (gtk-widget-destroy fontsel)))
	 (gtk-signal-connect
	  (gtk-font-selection-dialog-cancel-button fontsel) "clicked"
	  (lambda ()
	    (gtk-widget-destroy fontsel)))
	 (gtk-signal-connect fontsel "delete_event"
			     (lambda ()
			       (gtk-widget-destroy fontsel)))
	 (gtk-widget-show fontsel)
	 (gtk-grab-add fontsel))))
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (gtk-entry-set-text entry (and (stringp x) x))))
	    ((eq op 'clear)
	     (lambda ()
	       (gtk-entry-set-text entry "")))
	    ((eq op 'get)
	     (lambda ()
	       (let
		   ((text (gtk-entry-get-text entry)))
		 (and (stringp text) text))))
	    ((eq op 'widget)
	     box)
	    ((eq op 'validp)
	     (lambda (x)
	       (or (null x) (stringp x))))))))
(put 'font 'item-maker make-font-item)

(defun make-pattern-item (changed-callback)
  (let
      ((widget (gtk-combo-new)))
    (gtk-signal-connect (gtk-combo-entry widget) "changed" changed-callback)
    (add-hook 'patterns-changed-hook
	      (lambda ()
		(let
		    ((frame-part-selection nil))
		  (save-entry-contents (gtk-combo-entry widget)
		   (gtk-combo-set-popdown-strings
		    widget (cons "" (mapcar car patterns-alist)))))))
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (gtk-entry-set-text (gtk-combo-entry widget) x)))
	    ((eq op 'clear)
	     (lambda ()
	       (gtk-entry-set-text (gtk-combo-entry widget) "")))
	    ((eq op 'get)
	     (lambda ()
	       (let
		   ((string (gtk-entry-get-text (gtk-combo-entry widget))))
		 (and (assoc string patterns-alist) string))))
	    ((eq op 'widget)
	     widget)
	    ((eq op 'validp)
	     (lambda (x)
	       (and (stringp x) (assoc x patterns-alist))))))))
(put 'pattern 'item-maker make-pattern-item)

(defun make-image-item (changed-callback)
  (let
      ((widget (gtk-hbox-new nil 4))
       (button (gtk-button-new-with-label (_ "Browse...")))
       (p-button (gtk-button-new-with-label (_ "Properties...")))
       (entry (gtk-entry-new))
       properties)
    (gtk-box-pack-start widget entry t t)
    (gtk-box-pack-start widget button nil nil)
    (gtk-box-pack-start widget p-button nil nil)
    (gtk-signal-connect
     button "clicked"
     (lambda ()
       (let
	   ((filesel (gtk-file-selection-new (_ "Select Image"))))
	 (gtk-file-selection-set-filename filesel (gtk-entry-get-text entry))
	 (gtk-signal-connect
	  (gtk-file-selection-ok-button filesel)
	  "clicked"
	  (lambda ()
	    (let
		((file (gtk-file-selection-get-filename filesel)))
	      (gtk-widget-destroy filesel)
	      (gtk-entry-set-text entry file))))
	 (gtk-signal-connect
	  (gtk-file-selection-cancel-button filesel)
	  "clicked" (lambda ()
		      (gtk-widget-destroy filesel)))
	 (gtk-signal-connect filesel "delete_event"
			     (lambda ()
			       (gtk-widget-destroy filesel)))
	 (gtk-grab-add filesel)
	 (gtk-widget-show filesel))))
    (gtk-signal-connect
     p-button "clicked"
     (lambda ()
       (let*
	   ((props-xml (glade-xml-new glade-file "props-dialog"))
	    (window (glade-xml-get-widget props-xml "props-dialog"))
	    (vbox (glade-xml-get-widget props-xml "props-vbox"))
	    (table (gtk-table-new (length image-attrs) 2 nil))
	    (items (mapcar (lambda (cell)
			     (cons (car cell)
				   (make-item (nth 1 cell) nop))) image-attrs))
	    (on-props-ok
	     (lambda ()
	       (setq properties (mapcar (lambda (x)
					  (cons (car x) (((cdr x) 'get))))
					items))
	       (let
		   (tem)
		 (while (setq tem (rassq nil properties))
		   (setq properties (delq tem properties))))
	       (changed-callback)
	       (gtk-widget-destroy window)))
	    (on-props-cancel
	     (lambda ()
	       (gtk-widget-destroy window))))
	 (glade-xml-signal-connect props-xml "on-props-ok" on-props-ok)
	 (glade-xml-signal-connect props-xml "on-props-cancel" on-props-cancel)
	 (mapc (lambda (w)
		 (when (gtk-label-p w)
		   (gtk-container-remove vbox w)))
	       (gtk-container-children vbox))
	 (gtk-window-set-title window (_ "Image Properties"))
	 (gtk-box-pack-start vbox table t t)
	 (gtk-table-set-col-spacings table 4)
	 (gtk-table-set-row-spacings table 4)
	 (do ((i 0 (1+ i)))
	     ((>= i (length items)))
	   (((cdr (nth i items)) 'set)
	    (cdr (assq (car (nth i items)) properties)))
	   (gtk-table-attach-defaults
	    table (gtk-label-new (symbol-name (car (nth i items))))
	    0 1 i (1+ i))
	   (gtk-table-attach-defaults
	    table ((cdr (nth i items)) 'widget) 1 2 i (1+ i)))
	 (gtk-widget-show-all window)
	 (gtk-grab-add window))))
    (gtk-signal-connect entry "changed" changed-callback)
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (gtk-entry-set-text entry (car x))
	       (setq properties (cdr x))))
	    ((eq op 'clear)
	     (lambda ()
	       (gtk-entry-set-text entry "")
	       (setq properties nil)))
	    ((eq op 'get)
	     (lambda ()
	       (let
		   ((text (gtk-entry-get-text entry)))
		 (if (string= text "")
		     nil
		   (cons text properties)))))
	    ((eq op 'widget)
	     widget)
	    ((eq op 'validp)
	     (lambda (x)
	       (and (listp x) (stringp (nth 0 x)))))))))
(put 'image 'item-maker make-image-item)

(defun make-or-item (changed-callback #!rest items)
  (setq items (mapcar (lambda (x)
			(make-item x changed-callback)) items))
  (let*
      ((box (gtk-vbox-new nil 4))
       (hboxes (mapcar (lambda ()
			 (gtk-hbox-new nil 0)) items))
       (checks (mapcar (lambda ()
			 (gtk-check-button-new)) items))
       (enabled-item nil)
       (refresh-item
	(lambda ()
	  (let
	      ((i 0))
	    (mapc (lambda (x)
		    (set-item-enabled x (eq enabled-item x))
		    (gtk-toggle-button-set-state
		     (nth i checks) (eq enabled-item x))
		    (setq i (1+ i))) items))
	  (changed-callback)))
       (toggle-fun
	(lambda (index)
	  (when (or (eq (nth index items) enabled-item)
		    (gtk-toggle-button-active (nth index checks)))
	    (setq enabled-item (and (gtk-toggle-button-active
				     (nth index checks))
				    (nth index items))))
	  (refresh-item))))
    (do ((i 0 (1+ i)))
	((>= i (length items)))
      (gtk-signal-connect (nth i checks) "toggled" (lambda () (toggle-fun i)))
      (gtk-box-pack-start box (nth i hboxes))
      (gtk-box-pack-start (nth i hboxes) (nth i checks))
      (gtk-box-pack-start (nth i hboxes) ((nth i items) 'widget)))
    (refresh-item)
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (if (null x)
		   (setq enabled-item nil)
		 (if (and enabled-item ((enabled-item 'validp) x))
		     ;; set the enabled value if possible
		     ((enabled-item 'set) x)
		   ;; look for a matching type
		   (catch 'done
		     (do ((i 0 (1+ i)))
			 ((>= i (length items)))
		       (when (((nth i items) 'validp) x)
			 (setq enabled-item (nth i items))
			 ((enabled-item 'set) x)
			 (throw 'done t)))
		     (message (format nil (_ "No matching item for %S") x)))))
	       (refresh-item)))
	    ((eq op 'clear)
	     (lambda ()
	       (setq enabled-item nil)
	       (mapc (lambda (item)
		       ((item 'clear))) items)
	       (refresh-item)))
	    ((eq op 'get)
	     (lambda ()
	       (and enabled-item ((enabled-item 'get)))))
	    ((eq op 'widget)
	     box)
	    ((eq op 'validp)
	     (lambda (x)
	       (catch 'out
		 (do ((i 0 (1+ i)))
		     ((>= i (length items)))
		   (when (((nth i items) 'validp) x)
		     (throw 'out t))))))))))
(put 'or 'item-maker make-or-item)

(defun make-and-item (changed-callback #!rest items)
  (setq items (mapcar (lambda (x)
			(make-item x changed-callback)) items))
  (let
      ((box ((if (eq and-direction 'horizontal)
		 gtk-hbox-new
	       gtk-vbox-new) nil 4)))
    (do ((i 0 (1+ i)))
	((>= i (length items)))
      (gtk-box-pack-start box ((nth i items) 'widget)))
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (do ((i 0 (1+ i)))
		   ((>= i (length items)))
		 (((nth i items) 'set) (nth i x)))))
	    ((eq op 'clear)
	     (lambda ()
	       (mapc (lambda (x)
		       ((x 'clear))) items)))
	    ((eq op 'get)
	     (lambda ()
	       (mapcar (lambda (x)
			 ((x 'get))) items)))
	    ((eq op 'widget)
	     box)
	    ((eq op 'validp)
	     (lambda (x)
	       (cond ((null x))
		     ((or (not (listp x))
			  (/= (length x) (length items)))
		      nil)
		     (t
		      (catch 'out
			(do ((i 0 (1+ i)))
			    ((>= i (length items)))
			  (unless (((nth i items) 'validp) (nth i x))
			    (throw 'out nil)))
			t)))))))))
(put 'and 'item-maker make-and-item)

(put 'h-and 'item-maker (lambda (#!rest args)
			  (let
			      ((and-direction 'horizontal))
			    (apply make-and-item args))))
(put 'v-and 'item-maker (lambda (#!rest args)
			  (let
			      ((and-direction 'vertical))
			    (apply make-and-item args))))

(defun make-labelled-item (changed-callback label item)
  (let
      ((box (gtk-hbox-new nil 4)))
    (setq item (make-item item changed-callback))
    (gtk-box-pack-start box (item 'widget))
    (gtk-box-pack-start box (gtk-label-new label))
    (gtk-widget-show-all box)
    (lambda (op)
      (if (eq op 'widget)
	  box
	(item op)))))
(put 'labelled 'item-maker make-labelled-item)

(defun make-optional-item (changed-callback item)
  (let
      ((box (gtk-hbox-new nil 0))
       (check (gtk-check-button-new)))
    (setq item (make-item item changed-callback))
    (gtk-box-pack-start box check)
    (gtk-box-pack-start box (item 'widget))
    (gtk-signal-connect
     check "toggled"
     (lambda ()
       (set-widget-enabled (item 'widget) (gtk-toggle-button-active check))
       (changed-callback)))
    (gtk-toggle-button-set-state check nil)
    (set-widget-enabled (item 'widget) nil)
    (lambda (op)
      (cond ((eq op 'set)
	     (lambda (x)
	       (when x
		 ((item 'set) x))
	       (set-widget-enabled (item 'widget) x)
	       (gtk-toggle-button-set-state check x)))
	    ((eq op 'clear)
	     (lambda ()
	       ((item 'clear))
	       (set-widget-enabled (item 'widget) nil)
	       (gtk-toggle-button-set-state check nil)))
	    ((eq op 'get)
	     (lambda ()
	       (and (gtk-toggle-button-active check) ((item 'get)))))
	    ((eq op 'widget)
	     box)
	    ((eq op 'validp)
	     (lambda (x)
	       (or (null x) ((item 'validp) x))))))))
(put 'optional 'item-maker make-optional-item)


;; details

(defun update-theme-name ()
  (gtk-entry-set-text theme-name-entry (if theme-name
					   (symbol-name theme-name)
					 "")))

(defun on-theme-name-entry-changed ()
  (setq theme-name (string-to-symbol (gtk-entry-get-text theme-name-entry))))

(defun clear-readme-text ()
  (gtk-text-set-point theme-about-text 0)
  (gtk-text-forward-delete
   theme-about-text (gtk-text-get-length theme-about-text)))

(defun write-readme-file (dir)
  (let
      ((text (gtk-editable-get-chars
	      theme-about-text 0 (gtk-text-get-length theme-about-text)))
       (file (open-file (expand-file-name "README" dir) 'write)))
    (when file
      (unwind-protect
	  (write file text)
	(close-file file)))))

(defun read-readme-file (dir)
  (let*
      ((readme (expand-file-name "README" dir))
       (file (and (file-exists-p readme) (open-file readme 'read))))
    (when file
      (unwind-protect
	  (let
	      (line)
	    (clear-readme-text)
	    (while (setq line (read-line file))
	      (gtk-text-insert
	       theme-about-text nil nil nil line (length line))))
	(close-file file)))))


;; patterns

(defun patterns-format-pattern (pattern)
  (setq pattern (cdr pattern))
  (cond ((stringp pattern)
	 ;; color
	 pattern)
	((consp pattern)
	 ;; image
	 (file-name-nondirectory (car pattern)))
	(t
	 "")))

(defun patterns-format-list (lst)
  (apply vector (car lst)
	 (mapcar (lambda (attr)
		   (let
		       ((elt (assq attr (cdr lst))))
		     (if elt
			 (patterns-format-pattern elt)
		       "")))
		 pattern-attrs)))

(defun patterns-update-all ()
  (with-clist-frozen patterns-clist
    (mapc (lambda (cell)
	    ;; fix relative filenames in images
	    (mapc (lambda (elt)
		    ;; ELT is (STATE . VALUE)
		    (let
			((name (car (cdr elt))))
		      (when (and (stringp name)
				 (not (file-name-absolute-p name))
				 current-filename)
			(rplaca (cdr elt)
				(expand-file-name
				 ;; expand twice to ensure canonicism
				 (expand-file-name
				  name (file-name-directory
					current-filename))
				 (local-file-name default-directory))))))
		  (cdr cell))
	    (gtk-clist-append patterns-clist (patterns-format-list cell)))
	  patterns-alist)))

(defun on-patterns-add ()
  (let*
      ((name (make-new-name "pattern" (mapcar car patterns-alist)))
       (elt (list name)))
    (setq patterns-alist (nconc patterns-alist (list elt)))
    (gtk-clist-append patterns-clist (patterns-format-list elt))
    (gtk-clist-select-row patterns-clist (1- (length patterns-alist)) 0)
    (call-hook 'patterns-changed-hook)
    (message (format nil (_ "Added pattern `%s'") name))))

(defun on-patterns-copy ())

(defun on-patterns-delete ()
  (when patterns-selection
    (let
	((row patterns-selection))
      (setq patterns-selection nil)
      (setq patterns-alist (delq (nth row patterns-alist) patterns-alist))
      (call-hook 'patterns-changed-hook)
      (gtk-clist-remove patterns-clist row))))

(defun on-patterns-clist-select-row (widget row col)
  (declare (unused widget col))
  (unless (eq patterns-selection row)
    (let
	((cell (nth row patterns-alist)))
      (when cell
	(gtk-entry-set-text patterns-name-entry (car cell))
	(mapc (lambda (attr)
		(((cdr attr) 'set) (cdr (assq (car attr) (cdr cell)))))
	      patterns-item-alist)
	(set-widget-enabled patterns-table t)))
    (setq patterns-selection row)))

(defun on-patterns-clist-unselect-row ()
  (setq patterns-selection nil)
  (gtk-entry-set-text patterns-name-entry "")
  (mapc (lambda (attr)
	  (((cdr attr) 'clear)))
	patterns-item-alist)
  (set-widget-enabled patterns-table nil))

(defun on-patterns-entry-changed ()
  (patterns-update-alist)
  (call-hook 'patterns-changed-hook))

(defun patterns-update-alist ()
  (when patterns-selection
    (let
	((cell (nth patterns-selection patterns-alist))
	 (name (gtk-entry-get-text patterns-name-entry))
	 (values (mapcar (lambda (attr)
			   (cons (car attr) (((cdr attr) 'get))))
			 patterns-item-alist)))
      (gtk-clist-set-text patterns-clist patterns-selection 0 name)
      (do ((i 0 (1+ i)))
	  ((>= i (length values)))
	(gtk-clist-set-text patterns-clist patterns-selection (1+ i)
			    (patterns-format-pattern (nth i values))))
      (when (string= name "")
	(setq name nil))
      (let
	  (attrs)
	(mapc (lambda (attr)
		(when (cdr attr)
		  (setq attrs (cons attr attrs)))) values)
	(setq attrs (nreverse attrs))
	(rplaca cell name)
	(rplacd cell attrs)))))

(defun create-patterns-items ()
  (setq patterns-item-alist
	(mapcar (lambda (attr)
		  (cons attr (make-item pattern-type patterns-update-alist)))
		pattern-attrs))
  (do ((i 0 (1+ i)))
      ((>= i (length patterns-item-alist)))
    (gtk-table-attach-defaults patterns-table
			       ((cdr (nth i patterns-item-alist)) 'widget)
			       1 2 (1+ i) (+ i 2)))
  (gtk-widget-show-all patterns-table)
  patterns-table)


;; frames

(defmacro current-frame ()
  '(and frame-selection (nth frame-selection frames-alist)))

(defun frames-update-all ()
  (setq frame-selection nil)
  (setq frame-part-selection nil)
  (with-clist-frozen frames-name-clist
    (with-clist-frozen frames-part-clist
      (clist-delete-all frames-name-clist)
      (clist-delete-all frames-part-clist)
      (mapc (lambda (cell)
	      (gtk-clist-append frames-name-clist
				(vector (car cell)))) frames-alist))))

(defun on-frames-add ()
  (let
      ((name (string-dialog (_ "Frame name"))))
    (when (and name (not (assoc name frames-alist)))
      (setq frames-alist (nconc frames-alist (list (list name))))
      (gtk-clist-append frames-name-clist (vector name))
      (update-frame-names-clist)
      (call-hook 'frames-changed-hook)
      (message (format nil (_ "Added frame `%s'") name)))))

(defun on-frames-copy ()
  (when frame-selection
    (let
	((name (string-dialog (_ "Frame name")))
	 (src (cdr (nth frame-selection frames-alist))))
      (when (and name (not (assoc name frames-alist)))
	(setq frames-alist (nconc frames-alist
				  (list (cons name (copy-tree src)))))
	(gtk-clist-append frames-name-clist (vector name))
	(update-frame-names-clist)
	(call-hook 'frames-changed-hook)
	(message (format nil (_ "Added frame `%s'") name))))))

(defun on-frames-delete ()
  (when frame-selection
    (let
	((row frame-selection))
      (setq frame-selection nil)
      (setq frames-alist (delq (nth row frames-alist) frames-alist))
      (call-hook 'frames-changed-hook)
      (gtk-clist-remove frames-name-clist row))))

(defun on-frames-name-clist-select (w row col)
  (declare (unused w col))
  (unless (eq frame-selection row)
    (setq frame-selection row)
    (gtk-frame-set-label frames-frame (car (current-frame)))
    (with-clist-frozen frames-part-clist
      (clist-delete-all frames-part-clist)
      (mapc (lambda (part)
	      (gtk-clist-append frames-part-clist (frame-part-columns part)))
	    (cdr (current-frame))))
    (set-widget-enabled frames-frame t)))

(defun on-frames-name-clist-unselect ()
  (let*
      ((i (1- (length (cdr (current-frame))))))
    (setq frame-selection nil)
    (gtk-frame-set-label frames-frame "")
    (with-clist-frozen frames-part-clist
      (while (>= i 0)
	(gtk-clist-remove frames-part-clist i)
	(setq i (1- i))))
    (set-widget-enabled frames-frame nil)))

(defun update-frame-names-clist ()
  (let
      ((i 0))
    (with-clist-frozen frames-name-clist
      (mapc (lambda (frame)
	      (gtk-clist-set-text frames-name-clist i 0 (car frame))
	      (setq i (1+ i))) frames-alist))))

(defun frame-part-columns (part)
  (let
      ((class (assq 'class part))
       (rest (filter (lambda (x)
		       (not (eq (car x) 'class))) part)))
    (vector (if class
		(symbol-name (cdr class))
	      (_ "<none>"))
	    (if rest (format nil "%S" rest) "()"))))

(defun update-frame-part ()
  (when frame-part-selection
    (let*
	((part (nth frame-part-selection (cdr (current-frame))))
	 (vec (frame-part-columns part)))
      (gtk-clist-set-text
       frames-part-clist frame-part-selection 0 (aref vec 0))
      (gtk-clist-set-text
       frames-part-clist frame-part-selection 1 (aref vec 1)))))

(defun on-frames-part-clist-select (w row col)
  (declare (unused w col))
  (unless (eq frame-part-selection row)
    (setq frame-part-selection row)
    (update-frame-part-table)
    (set-widget-enabled frames-part-table-viewport t)))

(defun on-frames-part-clist-unselect ()
  (setq frame-part-selection nil)
  (clear-frame-part-table)
  (set-widget-enabled frames-part-table-viewport nil))

(defun on-frames-add-part ()
  (let
      ((frame (current-frame)))
    (when frame
      (let
	  ((part (list)))
	(rplacd frame (nconc (cdr frame) (list part)))
	(gtk-clist-append frames-part-clist (frame-part-columns part))
	(gtk-clist-select-row
	 frames-part-clist (1- (length (cdr frame))) 0)))))

(defun on-frames-delete-part ()
  (when frame-part-selection
    (let
	((frame (current-frame))
	 (row frame-part-selection))
      (setq frame-part-selection nil)
      (rplacd frame (delq (nth row (cdr frame)) (cdr frame)))
      (gtk-clist-remove frames-part-clist row))))

(defun update-frame-part-table ()
  (when (and frame-selection frame-part-selection)
    (let*
	((frame (current-frame))
	 (part (nth frame-part-selection (cdr frame))))
      (mapc (lambda (cell)
	      (let
		  ((item (cdr (assq (car cell) frame-part-table-items))))
		(when item
		  ((item 'set) (cdr cell))))) part))))

(defun clear-frame-part-table ()
  (mapc (lambda (cell)
	  (((cdr cell) 'clear))) frame-part-table-items))

(defun on-frame-part-attr-changed (item)
  (when item
    (let
	((attr (rassq item frame-part-table-items))
	 (frame (current-frame)))
      (when (and frame frame-part-selection)
	(let*
	    ((part (nth frame-part-selection (cdr frame)))
	     (cell (assq (car attr) part))
	     (value ((item 'get))))
	  (if value
	      (if cell
		  (rplacd cell ((item 'get)))
		(rplaca (nthcdr frame-part-selection (cdr frame))
			(cons (cons (car attr) ((item 'get))) part)))
	    (when cell
	      (rplaca (nthcdr frame-part-selection (cdr frame))
		      (delq cell part))))
	(update-frame-part))))))

(defun create-frame-part-table ()
  (let*
      ((table (gtk-table-new (length frame-part-attrs) 2 nil))
       (row 0))
    (gtk-table-set-row-spacings table 4)
    (gtk-table-set-col-spacings table 4)
    (setq frame-part-table-items nil)
    (mapc (lambda (attr)
	    (let
		((l-box (gtk-hbox-new nil 4))
		 (r-box (gtk-hbox-new nil 4))
		 item)
	      (setq item (make-item (nth 1 attr)
				    (lambda ()
				      (on-frame-part-attr-changed item))))
	      (setq frame-part-table-items (cons (cons (car attr) item)
						 frame-part-table-items))
	      (gtk-box-pack-end
	       l-box (gtk-label-new (symbol-name (car attr))))
	      (gtk-box-pack-start r-box (item 'widget) t t)
	      (gtk-table-attach-defaults table l-box 0 1 row (1+ row))
	      (gtk-table-attach-defaults table r-box 1 2 row (1+ row))
	      (setq row (1+ row))))
	  frame-part-attrs)
    (mapc (lambda (x)
	    (gtk-container-remove frames-part-table-viewport x))
	  (gtk-container-children frames-part-table-viewport))
    (gtk-container-add frames-part-table-viewport table)
    (gtk-paned-set-position
     (glade-xml-get-widget xml "frames-part-vpaned") 300)
    (gtk-widget-show-all table)
    table))


;; mappings

(defun mappings-update-all ()
  (with-clist-frozen mapping-clist
    (clist-delete-all mapping-clist)
    (mapc (lambda (cell)
	    (gtk-clist-append mapping-clist
			      (vector (symbol-name (car cell)) (cdr cell))))
	  mapping-alist)))

(defun on-mapping-add ()
  (let
      ((name (intern (make-new-name "type" (mapcar (lambda (x)
						     (symbol-name (car x)))
						   mapping-alist)))))
    (setq mapping-alist (nconc mapping-alist (list (cons name ""))))
    (gtk-clist-append mapping-clist (vector (symbol-name name) ""))
    (gtk-clist-select-row mapping-clist (1- (length mapping-alist)) 0)
    (call-hook 'mappings-changed-hook)
    (message (format nil (_ "Added frame type `%s'") name))))

(defun on-mapping-delete ()
  (when mapping-selection
    (let
	((row mapping-selection))
      (setq mapping-selection nil)
      (setq mapping-alist (delq (nth row mapping-alist) mapping-alist))
      (call-hook 'mappings-changed-hook)
      (gtk-clist-remove mapping-clist row))))

(defun on-mapping-from-changed ()
  (when mapping-selection
    (let
	((cell (nth mapping-selection mapping-alist))
	 (sym (string-to-symbol
	       (gtk-entry-get-text (gtk-combo-entry mapping-from-combo)))))
      (when sym
	(rplaca cell sym)
	(gtk-clist-set-text
	 mapping-clist mapping-selection 0 (symbol-name (car cell)))))))

(defun on-mapping-to-changed ()
  (when mapping-selection
    (let
	((cell (nth mapping-selection mapping-alist)))
      (rplacd cell (gtk-entry-get-text (gtk-combo-entry mapping-to-combo)))
      (gtk-clist-set-text mapping-clist mapping-selection 1 (cdr cell)))))

(defun on-mapping-clist-select (w row col)
  (declare (unused w col))
  (setq mapping-selection row)
  (set-widget-enabled mapping-combo-hbox t)
  (gtk-entry-set-text
   (gtk-combo-entry mapping-from-combo)
   (symbol-name (car (nth mapping-selection mapping-alist))))
  (gtk-entry-set-text
   (gtk-combo-entry mapping-to-combo)
   (cdr (nth mapping-selection mapping-alist))))

(defun on-mapping-clist-unselect ()
  (setq mapping-selection nil)
  (gtk-entry-set-text (gtk-combo-entry mapping-from-combo) "")
  (gtk-entry-set-text (gtk-combo-entry mapping-to-combo) "")
  (set-widget-enabled mapping-combo-hbox nil))

(defun mapping-update-combos ()
  (let
      ((mapping-selection nil))
    (save-entry-contents (gtk-combo-entry mapping-from-combo)
     (gtk-combo-set-popdown-strings
      mapping-from-combo (mapcar symbol-name window-types)))
    (save-entry-contents (gtk-combo-entry mapping-to-combo)
     (gtk-combo-set-popdown-strings
      mapping-to-combo (cons "" (mapcar car frames-alist))))))

(add-hook 'frames-changed-hook mapping-update-combos)


;; frame previews

(defun on-preview ()
  (condition-case data
      (progn
	(sawfish-eval
	 `(progn
	    (require 'sawfish.wm.theming.make-theme-preview)
	    (make-theme-preview ',patterns-alist
				',frames-alist
				',mapping-alist)))
	(unless preview-window
	  (let
	      ((preview-xml (or (glade-xml-new glade-file "preview-window")
				(error "something happened"))))
	    (glade-xml-signal-autoconnect preview-xml)
	    (setq preview-window (glade-xml-get-widget
				  preview-xml "preview-window")))))
    (remote-sawfish
     (message (format nil (_ "error while building frame: %S") data)))))


(defun on-preview-close ()
  (when preview-window
    (gtk-widget-destroy preview-window))
  (setq preview-window nil))


;; filtering used patterns/frames

(defun filter-unused-frames (frames mappings)
  (filter (lambda (x)
	    (rassoc (car x) mappings)) frames))

(defun filter-unused-patterns (old-patterns frames)
  (let
      (patterns tem)
    (mapc (lambda (frame)
	    (mapc (lambda (part)
		    (mapc (lambda (cell)
			    (when (and (memq (car cell) pattern-classes)
				       (setq tem (assoc (cdr cell)
							old-patterns))
				       (not (memq tem patterns)))
			      (setq patterns (cons tem patterns)))) part))
		  (cdr frame))) frames)
    patterns))


;; saving/loading

(defun print-list (lst indent)
  (let
      ((stream (make-string-output-stream))
       (leader (make-string indent ? )))
    (write stream ?\()
    (while (consp lst)
      (if (consp (car lst))
	  (write stream (print-list (car lst) (1+ indent)))
	(format stream "%S" (car lst)))
      (setq lst (cdr lst))
      (when (consp lst)
	(write stream ?\n)
	(write stream leader)))
    (when lst
      (format stream " . %S" lst))
    (write stream ?\))
    (get-output-stream-string stream)))

(defun update-all ()
  (update-theme-name)
  (patterns-update-all)
  (frames-update-all)
  (mappings-update-all))

(defun set-current-filename (file)
  (setq current-filename file)
  (gtk-entry-set-text theme-dir-entry (if file (file-name-directory file) "")))

(defun save-to-file (filename)
  (condition-case data
      (let
	  ((file (open-file filename 'write)))
	(when file
	  (unwind-protect
	      (progn
		(format file ";; theme file, written %s\n"
			(current-time-string))
		(write file ";; created by sawfish-themer -- DO NOT EDIT!\n\n")
		(write file "(require 'make-theme)\n\n")
		(write file "\(let\n    \(")
		(let
		    ((ptr saved-variables))
		  (while ptr
		    (let
			((value (symbol-value (car ptr))))
		      (if (consp value)
			  (format file "\(%s\n      '%s\)"
				  (car ptr) (print-list value 8))
			(format file "\(%s '%S\)" (car ptr) value)))
		    (setq ptr (cdr ptr))
		    (when ptr
		      (write file "\n\n     "))))
		(write file "\)\n\n")
		(format file "  \(add-frame-style\n   theme-name %S\)\n"
			`(make-theme patterns-alist frames-alist mapping-alist))
		(write file "  \(when \(boundp 'mark-frame-style-editable\)\n")
		(write file "    \(mark-frame-style-editable theme-name\)\)\)\n")
		(message (format nil (_ "Saved as `%s'") filename)))
	    (close-file file))))
    (file-error
     (message (format nil "%S" data)))))

(defun generate-patterns (patterns dir)
  (mapcar
   (lambda (pat)
     (cons (car pat)
	   (mapcar
	    (lambda (cell)
	      ;; CELL is (STATE . VALUE)
	      (let
		  ((elt (cdr cell)))
		(when (consp elt)
		  (let*
		      ((from (car elt))
		       (to (expand-file-name
			    (file-name-nondirectory from) dir)))
		    (or (file-exists-p from)
			(file-exists-p to)
			(error "No such image: %s" from))
		    (when (and (not (string= from to))
			       (or (not (file-exists-p to))
				   (time-later-p (file-modtime from)
						 (file-modtime to))))
		      (copy-file from to)
		      (message
		       (format nil "%s -> %s/%s" from to)))
		    (setq elt (cons (file-name-nondirectory to) (cdr elt)))
		    (setq cell (cons (car cell) elt))))
		cell))
	    (cdr pat))))
   patterns))

(defun generate-theme (dir)
  (when (and (file-exists-p dir) (not (file-directory-p dir)))
    (error "Not a directory: %s" dir))
  (unless (file-exists-p dir)
    (make-directory dir))
  (set-current-filename (expand-file-name "theme.jl" dir))
  (when filter-when-saving
    (setq frames-alist (filter-unused-frames frames-alist mapping-alist))
    (setq patterns-alist (filter-unused-patterns patterns-alist frames-alist)))
  (let
      ((patterns-alist (generate-patterns patterns-alist dir)))
    (save-to-file current-filename))
  (write-readme-file dir)
  (message (format nil (_ "Generated theme in directory `%s'") dir))
  (when reload-themes-after-saving
    (sawfish-eval-async `(reload-frame-style ',theme-name))))

(defun new-theme ()
  (with-clist-frozen patterns-clist
    (clist-delete-all patterns-clist))
  (with-clist-frozen frames-name-clist
    (clist-delete-all frames-name-clist))
  (with-clist-frozen mapping-clist
    (clist-delete-all mapping-clist))
  (mapc (lambda (sym)
	  (set sym nil)) saved-variables)
  (setq theme-name 'unnamed)
  (clear-readme-text)
  (update-all))

(defun load-from-file (filename)
  (new-theme)
  (let
      ((file (open-file filename 'read)))
    (when file
      (unwind-protect
	  (condition-case nil
	      (while t
		(let
		    ((form (read file)))
		  (when (eq (car form) 'let)
		    (mapc (lambda (cell)
			    (when (memq (nth 0 cell) saved-variables)
			      (set (nth 0 cell) (nth 1 (nth 1 cell)))))
			  (nth 1 form))
		    (message
		     (format nil (_ "Read theme from `%s'") filename)))))
	    (end-of-stream))
	(close-file file))
      (set-current-filename filename)
      (read-readme-file (file-name-directory filename))
      (update-all))))

(defun on-save ()
  (if current-filename
      (generate-theme (file-name-directory current-filename))
    (on-save-as)))

(defun on-save-as ()
  (let
      ((dir (file-dialog (_ "Theme Directory")
			  (and current-filename
			       (file-name-directory current-filename)))))
    (when dir
      (generate-theme dir))))

(defun do-open (file)
  (when (file-directory-p file)
    (if (file-exists-p (expand-file-name "theme.jl" file))
	(setq file (expand-file-name "theme.jl" file))
      (error "Can only load from directories with theme.jl files")))
  (condition-case data
      (progn
	(load-from-file file))
    (error
     (message (format nil "%S" data)))))

(defun on-open ()
  (let
      ((file (file-dialog (_ "Open") current-filename)))
    (when file
      (do-open file))))

(defun on-new-theme ()
  (set-current-filename nil)
  (new-theme))


;; Preferences

(defun save-preferences ()
  (unless (file-exists-p "~/.sawfish")
    (make-directory "~/.sawfish"))
  (let
      ((file (open-file "~/.sawfish/themer-prefs" 'write)))
    (when file
      (unwind-protect
	  (mapc (lambda (x)
		  (format file "(setq %s '%S)\n"
			  (car x) (symbol-value (car x))))
		preferences-attrs)
	(close-file file)))))

(defun load-preferences ()
  (and (file-exists-p "~/.sawfish/themer-prefs")
       (load "~/.sawfish/themer-prefs" t t t)))

(defun on-settings-preferences ()
  (let*
      ((props-xml (glade-xml-new glade-file "props-dialog"))
       (window (glade-xml-get-widget props-xml "props-dialog"))
       (vbox (glade-xml-get-widget props-xml "props-vbox"))
       (items (mapcar (lambda (cell)
			(cons (car cell)
			      (make-item (nth 1 cell) nop)))
		      preferences-attrs))
       (on-props-ok
	(lambda ()
	  (mapc (lambda (x)
		  (set (car x) (((cdr x) 'get)))) items)
	  (save-preferences)
	  (gtk-widget-destroy window)))
       (on-props-cancel
	(lambda ()
	  (gtk-widget-destroy window))))
    (glade-xml-signal-connect props-xml "on-props-ok" on-props-ok)
    (glade-xml-signal-connect props-xml "on-props-cancel" on-props-cancel)
    (gtk-container-border-width vbox 16)
    (gtk-window-set-title window (_ "Preferences"))
    (mapc (lambda (w)
	    (when (gtk-label-p w)
	      (gtk-container-remove vbox w)))
	  (gtk-container-children vbox))
    (mapc (lambda (x)
	    (((cdr x) 'set) (symbol-value (car x)))
	    (gtk-box-pack-start vbox ((cdr x) 'widget))) items)
    (gtk-widget-show-all window)
    (gtk-grab-add window)))


;; Online help

(defun gnome-help-launcher (node)
  (setq node (or (cdr (assq node '((frames . "Frame_Basics")
				   (classes . "Frame_Part_Classes")
				   (defs . "Frame_Part_Definition")
				   (themes . "Themes"))))
		 (error "No help for %s!" node)))
  (system (format nil "gnome-help-browser 'info:sawfish#%s' &" node))) 

(setq help-launcher gnome-help-launcher)

(defun on-help-window-frames ()
  (help-launcher 'frames))

(defun on-help-frame-classes ()
  (help-launcher 'classes))

(defun on-help-frame-part-definitions ()
  (help-launcher 'defs))

(defun on-help-themes ()
  (help-launcher 'themes))

(defun on-help-about ()
  (let*
      ((about-xml (or (glade-xml-new glade-file "about-dialog")
		      (error "Can't create about dialog")))
       (window (glade-xml-get-widget about-xml "about-dialog"))
       (label (glade-xml-get-widget about-xml "about-label"))
       (on-about-ok (lambda ()
		      (gtk-widget-destroy window))))
    (glade-xml-signal-connect about-xml "on-about-ok" on-about-ok)
    (gtk-label-set label (format nil "\
Sawfish Themer %s

Copyright (C) 2000 John Harper
<jsh@users.sourceforge.net>

This program allows window manager
themes for sawfish to be created
through a GUI.\n" version))
    (gtk-grab-add window)))


;; more menu actions

(defun on-quit ()
  (throw 'quit 0))


;; utilities

(defun copy-tree (tree)
  (let
      (out ptr tem)
    (while (consp tree)
      (setq tem (if (consp (car tree))
		    (copy-tree (car tree))
		  (car tree)))
      (if ptr
	  (progn
	    (rplacd ptr (cons tem nil))
	    (setq ptr (cdr ptr)))
	(setq out (cons tem nil))
	(setq ptr out))
      (setq tree (cdr tree)))
    (if ptr
	(progn
	  (rplacd ptr tree)
	  out)
      tree)))

(defun string-to-symbol (string)
  (condition-case nil
      (let
	  ((data (read-from-string string)))
	(and (symbolp data) data))
    (error)))

(defun make-new-name (stem lst)
  (let
      ((i 1))
    (while (member (format nil "%s%d" stem i) lst)
      (setq i (1+ i)))
    (format nil "%s%d" stem i)))

(defun string-dialog (title)
  (let*
      ((string-xml (or (glade-xml-new glade-file "string-dialog")
		       (error "Can't create string-dialog widget")))
       (window (glade-xml-get-widget string-xml "string-dialog"))
       (entry (glade-xml-get-widget string-xml "string-dialog-entry"))
       (label (glade-xml-get-widget string-xml "string-dialog-label"))
       (finished (lambda (x)
		  (throw 'string-dialog-out x)))
       (on-string-dialog-ok (lambda ()
			      (finished (gtk-entry-get-text entry))))
       (on-string-dialog-cancel (lambda ()
				  (finished nil))))

    (glade-xml-signal-connect string-xml "on-string-dialog-ok" on-string-dialog-ok)
    (glade-xml-signal-connect string-xml "on-string-dialog-cancel" on-string-dialog-cancel)
    (gtk-window-set-title window title)
    (gtk-label-set label title)
    (gtk-grab-add window)
    (unwind-protect
	(catch 'string-dialog-out
	  (recursive-edit))
      (gtk-widget-destroy window))))

(defun file-dialog (title #!optional start)
  (let
      ((filesel (gtk-file-selection-new title)))
    (when start
      (gtk-file-selection-set-filename filesel start))
    (gtk-signal-connect
     (gtk-file-selection-ok-button filesel)
     "clicked"
     (lambda ()
       (throw 'filesel-out (gtk-file-selection-get-filename filesel))))
    (gtk-signal-connect
     (gtk-file-selection-cancel-button filesel)
     "clicked" (lambda ()
		 (throw 'filesel-out nil)))
    (gtk-signal-connect filesel "delete_event" (lambda ()
						 (throw 'filesel-out nil)))
    (gtk-grab-add filesel)
    (gtk-widget-show filesel)
    (unwind-protect
	(catch 'filesel-out
	  (recursive-edit))
      (gtk-widget-destroy filesel))))

(let
    ((message-count 0)
     (message-text nil))

  (defun remove-message ()
    (let
	((statusbar (glade-xml-get-widget xml "statusbar")))
      (while (> message-count 0)
	(gtk-statusbar-pop statusbar 1)
	(setq message-count (1- message-count)))
      (setq message-text nil)))

  (defun message (string)
    (let
	((statusbar (glade-xml-get-widget xml "statusbar")))
      (remove-message)
      (gtk-statusbar-push statusbar 1 string)
      (setq message-count (1+ message-count))
      (setq message-text nil)))

  (defun append-message (string)
    (let
	((new (concat message-text string)))
      (remove-message)
      (message new)))

  (add-hook 'idle-hook remove-message))

(defun set-button-label (button text)
  (mapc (lambda (w)
	  (when (gtk-label-p w)
	    (gtk-label-set w text))) (gtk-container-children button)))

(defun clist-delete-all (clist)
  (while (> (gtk-clist-rows clist) 0)
    (gtk-clist-remove clist 0)))

(defun set-widget-enabled (w enabled)
  (gtk-widget-set-sensitive w enabled))


;; color previews

(defvar color-preview-width 28)
(defvar color-preview-height 16)

(defun set-preview-color (preview color)
  (let
      ((buf (make-string (* color-preview-width 3)))
       i)
    (setq i 0)
    (while (< i color-preview-width)
      (aset buf (* i 3) (quotient (gdk-color-red color) 256))
      (aset buf (1+ (* i 3)) (quotient (gdk-color-green color) 256))
      (aset buf (+ 2 (* i 3)) (quotient (gdk-color-blue color) 256))
      (setq i (1+ i)))
    (setq i 0)
    (while (< i color-preview-height)
      (gtk-preview-draw-row preview buf 0 i color-preview-width)
      (setq i (1+ i)))))

(defun button-new-with-color (color-name)
  (let
      ((button (gtk-button-new))
       (preview (gtk-preview-new 'color))
       (color (and color-name (gdk-color-parse-interp color-name))))
    (gtk-preview-size preview color-preview-width color-preview-height)
    (when color
      (set-preview-color preview color))
    ;;(gtk-container-border-width button box-border)
    (gtk-container-add button preview)
    button))

(defun set-button-color (button color-name)
  (let
      ((color (and color-name (gdk-color-parse-interp color-name))))
    (when color
      (mapc (lambda (w)
	      (when (gtk-preview-p w)
		(set-preview-color w color)
		(gtk-widget-draw-interp w)))
	    (gtk-container-children button)))))


;; wm communication

(defun sawfish-eval (form #!optional read-back)
  (sawfish-client-eval form (not read-back)))

(defun sawfish-eval-async (form)
  (sawfish-client-eval-async form))


;; entry point

(load-preferences)

(update-theme-name)

(create-patterns-items)
(on-patterns-clist-unselect-row)

(on-frames-name-clist-unselect)
(on-frames-part-clist-unselect)

(on-mapping-clist-unselect)
(mapping-update-combos)

(create-frame-part-table)
(gtk-clist-set-column-auto-resize frames-part-clist 1 t)

(glade-xml-signal-autoconnect xml)

(when (and command-line-args (file-exists-p (car command-line-args)))
  (do-open (car command-line-args))
  (setq command-line-args (cdr command-line-args)))

(setq interrupt-mode 'exit)
(recursive-edit)

;; Local variables:
;; major-mode: lisp-mode
;; End: