;; std-func.gwm --- Standard functions used by most GWM profiles
;;
;; --------------------------------------------------------------------- 
;; 
;; Note from Anders Holst (aho@sans.kth.se):
;; This file is not really written by me, I just cut it out from
;; ".profile.gwm" since its functions are used by most profiles, and
;; its a pity to duplicate. I use it for the VTWM profile.
;; 


;;=============================================================================
;;                    X resource management for the standard profile
;;=============================================================================
;;

(defun std-resource-get args
  (with (resource-class (# 0 args) resource-name (# 1 args) Name () Class ())
    (: Name (+ -screen-name '.
	window-client-class '.
	(make-string-usable-for-resource-key-non-nil window-client-name) '.
	(make-string-usable-for-resource-key-non-nil window-name) '.
	screen-type '.
	window-machine-name '.
	(if resource-name resource-name resource-class)
    ))
    (: Class (+ "S.any.any.any.any.any.any" resource-class))
    (resource-get Name Class)
))

;; puts resource:
;; (std-resource-put resource-name
;;                   [screen-type] clientclass[name[windnowname[machine]]]]
;;                   value)

(defun std-resource-put (Resource args)
  (with (Client-desc () Value () Screen () Name ())
    (if (= 3 (length args))
      (progn
	(: Client-desc (# 1 args))
	(: Value (# 2 args))
	(: Screen (# 0 args))
      )
      (progn
	(: Client-desc (# 0 args))
	(: Value (# 1 args))
    ))
    (: Name (std-resource-expand Client-desc Screen Resource))
;;    (? "resource-put " Name " " Value "\n")
    (resource-put Name Value)
))

;; expands class[.name[.wname[.machine]]] visual Resource
;; into ScreenNumber.class.name.wname.visual.machine.Resource

(defun std-resource-expand (desc visual resource)
  (if (match "[*]" desc)
    (+ -screen-name
      (if (match "^[*]" desc) () '.)
      desc
      (if (match "[*]$" desc) () '.)
      resource)
    (with (tmp (match
	  "^\\([^.]*\\)[.]*\\([^.]*\\)[.]*\\([^.]*\\)[.]*\\([^.]*\\)$"
	  desc 1 2 3 4
      ))
      (make-resource-string -screen-name (# 0 tmp) (# 1 tmp) (# 2 tmp)
	visual (# 3 tmp) 'any resource
))))

;; appends list elements with '.', collapsing consecutive void (or any) 
;; elements into *

(defun make-resource-string l
  (with (star () first t l2 
      (mapfor elt l
	(if (or (= "any" elt) (not elt))
	  (if star
	    ""
	    (progn
	      (setq star t)
	      "*"
	    )
	  )
	  (progn
	    (setq star ())
	    (if first (progn (setq first ()) elt)
	    (+ "." elt)
    )))))
    (eval (+ '(+) l2))
))
  

;(trace-func std-resource-put)

;; customisation of decos by context
;; (customize deco screen application context...)

(defun customize-usage (string)
  (? "USAGE: (customize deco screen application context...),\n"
    "error was: " string "\n"
    (exit customize)
))

(defunq customize args
  (tag customize
    (with (Deco (# 0 args)
	Screen (# 1 args)
	Application (# 2 args)
	Context (if (and (=  4 (length args)) (= 'list (type (# 3 args))))
	  (# 3 args)
	  (sublist 3 (length args) args)
	)
	l (length Context)
	i 1
      )
      (while (< i l)
	(## i Context (eval (# i Context)))
	(setq i (+ 2 i))
      )
      (std-resource-put Deco (list Screen Application Context))
)))
  
;; recursively evaluates till we obtain a context

(defun get-context (name)
  (do-get-context name 0)
)

(defun do-get-context (name level)
  (if (> level max-autoload-evaluation) name
    (progn
      (setq name
	(if (# (type name) string-types)
	  (progn			; atoms:
	    (if (= 'string (type name))
	      (: name (atom name)))	; string->atom to test if defined
	    (if (boundp name)
	      (eval name)		; defined: eval
	      (progn
		(load name)		; undefined, load and returns itself
		name
	  )))
	  (# (type name) func-types)	; function: called without args
	  (eval (list name))
	  (= (type name) 'list)
	  (if (= (% (length name) 2) 0) ; if even list, its a context
	    name
	    (= 1 (length name))		; if one element, return it
	    (# 0 name)
	    (eval name)			; if odd list, eval
	  )
	  (eval name)			; others: eval
      ))
      (if (or (not name)
	  (and (= (type name) 'list)(= (% (length name) 2) 0)))
	name
	(do-get-context name (+ 1 level)
)))))



;;=============================================================================
;;                    user-callable resource settings
;;=============================================================================

(defname '-screen-name screen.)
(for screen (list-of-screens)
  (: -screen-name (+ "S" (itoa screen)))
  (std-resource-put 'GwmWindow (list screen-type ()))
  (std-resource-put 'GwmIconWindow (list screen-type ()))
  (std-resource-put 'GwmIconPixmap (list screen-type ()))
  (std-resource-put 'GwmPlacement (list screen-type ()))
  (std-resource-put 'GwmIconPlacement (list screen-type ()))
)

(: string-types '(string t atom t pointer t active t))
(: func-types '(expr t fexpr t subr t fsubr t))

(setq max-autoload-evaluation 10)

;(defun autoload-description (name)
;  (with (level 0) 
;    (do-autoload-description name level)
;))

;; recursively evaluates or load description to obtain a wl_client

(defun do-autoload-description (name level)
  (if (> level max-autoload-evaluation) name
    (progn
      (setq name
	(if (# (type name) string-types)
	  (progn			; atoms:
	    (if (= 'string (type name))
	      (: name (atom name)))	; string->atom to test if defined
	    (if (boundp name)
	      (eval name)		; defined: eval
	      (progn
		(load name)		; undefined, load and returns itself
		name
	  )))
	  (# (type name) func-types)	; function: called without args
	  (eval (list name))
	  (eval name)			; others: evalb
      ))
      (if (= 'client (type name)) name
	(do-autoload-description name (+ 1 level)
))))))

(defun autoload-description (name)
  (do-autoload-description name 0)
)

(defunq set-window args (std-resource-put 'GwmWindow args))

(defunq set-icon-window args (std-resource-put 'GwmIconWindow args))

(defunq set-icon args
  (## (- (length args) 1) args (expand-pixmap (# (- (length args) 1) args)))
  (std-resource-put 'GwmIconPixmap args)
)

(defun expand-pixmap (obj)
    (if (and obj (# (type obj) string-types))
	(pixmap-make obj)
	(eval obj)))	

(defunq set-placement args (std-resource-put 'GwmPlacement args))

(defunq set-icon-placement args (std-resource-put 'GwmIconPlacement args))


; per-screen data setting
; =======================

(defunq defname-in-screen-to args
    (with (value (eval (# 0 args))
		 vars (sublist 1 (length args) args))
	  (for var vars
	       (defname var screen. value))))

(defunq set-color (name value)
  (if (not (= screen. (namespace-of name)))
    (progn
      (defname name screen.)
      (for screen (list-of-screens)
	(set name (color-make value)))
)))

(defunq set-pixmap args
  (with (name (# 0 args)
      pixmap-make-call (# 0 args 'pixmap-make))
    (if (not (= screen. (namespace-of name)))
      (progn
	(defname name screen.)
	(for screen (list-of-screens)
	  (set name (eval pixmap-make-call)))
))))