;; etheme-compile.scm --- Convert an Enlightenment theme into Gwm decorations
;;
;; Author: Anders Holst  (aho@sics.se) 
;; Copyright (C) 2002  Anders Holst
;;
;; --------------------------------------------------------------------- 
;;
;; These functions interpret an enlightenment theme and construct 
;; window decorations from that. 
;;
;; It is currently experimental and incomplete. It does not interpret all
;; aspects of the theme yet. The focus is on mimicing windows, and menus
;; and icons are also partially done, but desktop features and appearance
;; are not implemented yet.
;;
;; The best way of useage is to "compile" the Enlightenment theme into
;; scheme by '(etheme-compile "ThemeName" "destination-file")'. This
;; may take some minutes while compiling, but is much faster when
;; used. The resulting file can then be loaded into Gwm either by
;; using the "-f" flag, or from the "gwmrc.scm" file. The alternative
;; is to directly use (etheme-window "ThemeName") to construct a
;; decoration function for windows, (etheme-icon "ThemeName") for an
;; icon decoration, and (etheme-menu-context "ThemeName") to create a
;; menu style context, but this will take a long time every time.
;;

(defvar eth-load-path (if (file-exists? "/usr/share/e16/themes/") "/usr/share/e16/themes/" "/usr/share/enlightenment/themes/") "Path to enlightenment themes." 'string)

;; ---------------------------------------------------------------------

(require 'parse-file "parse")

(define eth-theme-name #f)

(define eth-global-list '())

(define eth-inner-behavior
  (make-behavior
   (on (resize-event)
       (modify-deco (deco-parent deco)
                    :width (+ (width deco) (get-property deco 'dwidth))
                    :height (+ (height deco) (get-property deco 'dheight))))
   (on (user-event 'shade)
       (hide-deco deco))
   (on (user-event 'unshade)
       (show-deco deco))))

(define (eth-iclass-inner-behavior bgfunc tfunc)
  (if tfunc
      (make-behavior
       (on (user-event 'focus-in)
           (set-property! deco 'active #t)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (user-event 'focus-out)
           (set-property! deco 'active #f)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (user-event 'press)
           (set-property! deco 'clicked #t)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (user-event 'release)
           (set-property! deco 'clicked #f)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (enter)
           (set-property! deco 'hilited #t)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (leave)
           (set-property! deco 'hilited #f)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (user-event 'shade)
           (if (get-property deco 'shade)
               (hide-deco deco)))
       (on (user-event 'unshade)
           (if (get-property deco 'shade)
               (show-deco deco)))
       (on (user-event 'nail)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (user-event 'unnail)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (resize-event)
           (bgfunc deco))
       (on (user-event 'name-change)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco))
       (on (opening)
           (bgfunc deco)
           (tfunc (or (get-property (top-deco deco) 'menu-title) (window-name deco)) deco)))
      (make-behavior
       (on (user-event 'focus-in)
           (set-property! deco 'active #t)
           (bgfunc deco))
       (on (user-event 'focus-out)
           (set-property! deco 'active #f)
           (bgfunc deco))
       (on (user-event 'press)
           (set-property! deco 'clicked #t)
           (bgfunc deco))
       (on (user-event 'release)
           (set-property! deco 'clicked #f)
           (bgfunc deco))
       (on (enter)
           (set-property! deco 'hilited #t)
           (bgfunc deco))
       (on (leave)
           (set-property! deco 'hilited #f)
           (bgfunc deco))
       (on (user-event 'shade)
           (if (get-property deco 'shade)
               (hide-deco deco)))
       (on (user-event 'unshade)
           (if (get-property deco 'shade)
               (show-deco deco)))
       (on (user-event 'nail)
           (bgfunc deco))
       (on (user-event 'unnail)
           (bgfunc deco))
       (on (resize-event)
           (bgfunc deco))
       (on (opening)
           (bgfunc deco)))))

(define (eth-make-event-arc evt act rel kb)
  (if kb
      (if rel
          (on-event evt
                    (lambda (d e)
                      (send-user-event 'press d))
                    (lambda (d e)
                      (send-user-event 'release d)
                      (act (if (deco-menu? d)
                               (get-property (inner-deco d) 'caller)
                               d)
                           e)))
          (on-event evt
                    (lambda (d e)
                      (send-user-event 'press d)
                      (act (if (deco-menu? d)
                               (get-property (inner-deco d) 'caller)
                               d)
                           e))
                    (lambda (d e)
                      (send-user-event 'release d))))
      (on-event evt act)))
                   
(define (eth-lookup-action atag glst)
  (let ((tag (if (list? atag) (car atag) atag))
        (args (if (list? atag) (cdr atag) '())))
    (cond ((eq? tag '__A_EXEC)
           (lambda (w e) (apply execute args)))
          ((eq? tag '__A_ALERT)
           (lambda (w e) (bell)))
          ((or (eq? tag '__A_MOVE) (eq? tag '__A_MOVE_CONSTRAINED))
           (lambda (w e) (user-move-window (top-deco w) e)))
          ((memq tag '(__A_RESIZE __A_RESIZE_H __A_RESIZE_V))
           (lambda (w e) (user-resize-window (top-deco w) e)))
          ((eq? tag '__A_RAISE)
           (lambda (w e) (raise-window (top-deco w))))
          ((eq? tag '__A_LOWER)
           (lambda (w e) (lower-window (top-deco w))))
          ((eq? tag '__A_EXIT)
           (lambda (w e) (end)))
          ((eq? tag '__A_SHOW_MENU)
           (let* ((mname (string-match "^named (.*)" (car args)))
                  (menu (if mname (eth-lookup-menu glst (match:substring mname 1)) #f)))
             (if menu
                 (lambda (w e)
                   (menu-pop menu w e))
                 (lambda (w e)
                   (if (deco-screen? w)
                       (menu-pop (root-pop) w e)
                       (menu-pop (window-pop) w e))))))
          ((eq? tag '__A_KILL)
           (lambda (w e) (delete-window (top-deco w))))
          ((eq? tag '__A_KILL_NASTY)
           (lambda (w e) (kill-window (top-deco w))))
          ((eq? tag '__A_STICK)
           (if (defined? 'virtual-toggle-nail)
               (lambda (w e) (virtual-toggle-nail (top-deco w)))
               (lambda (w e) #f)))
          ((eq? tag '__A_GOTO_DESK)
           (lambda (w e) #f))
          ((eq? tag '__A_ICONIFY)
           (lambda (w e) (toggle-iconify-window (top-deco w))))
          ((eq? tag '__A_SLIDEOUT)
           (let ((lst (eth-lookup-type glst '__SLIDEOUT (car args))))
             (eth-interpret-slideout lst glst)))
          ((eq? tag '__A_SHADE)
           (lambda (w e) (toggle-shade-window (top-deco w))))
          ((eq? tag '__A_ZOOM)
           (lambda (w e) (zoom-window (top-deco w))))
          ((eq? tag '__A_MAX_SIZE)
           (lambda (w e) (zoom-window-full (top-deco w))))
          ((eq? tag '__A_MAX_WIDTH)
           (lambda (w e) (zoom-window-horiz (top-deco w))))
          ((eq? tag '__A_MAX_HEIGHT)
           (lambda (w e) (zoom-window-vert (top-deco w))))
          ((eq? tag '__A_RAISE_LOWER)
           (lambda (w e) (raise-lower-window (top-deco w) e)))
          (#t
           (lambda (w e) #f)))))

(define (eth-interpret-aclass lst glst)
  (let ((arcs '())
        (evt #f)
        (but #f)
        (ky #f)
        (mod #f)
        (act #f)
        (fn #f)
        (md #f))
    (while (not (null? lst))
      (set! evt (or (eth-assoc-between '__EVENT lst (caar lst) '(__NEXT_ACTION)) evt))
      (set! but (eth-assoc-between '__BUTTON lst (caar lst) '(__NEXT_ACTION)))
      (set! ky (eth-assoc-between '__KEY lst (caar lst) '(__NEXT_ACTION)))
      (set! mod (eth-assoc-between '__MODIFIER_KEY lst (caar lst) '(__NEXT_ACTION)))
      (set! act (eth-assoc-between '__ACTION lst (caar lst) '(__NEXT_ACTION)))
      (set! fn (eth-lookup-action act glst))
      (set! md (cond ((not mod) any)
                     ((eq? mod '__NONE) alone)
                     ((eq? mod '__SHIFT) shift-mask)
                     ((eq? mod '__CTRL) control-mask)
                     ((eq? mod '__ALT) alt-mask)
                     ((eq? mod '__CTRL_ALT) (logior control-mask alt-mask))
                     ((eq? mod '__CTRL_SHIFT) (logior control-mask shift-mask))
                     ((eq? mod '__ALT_SHIFT) (logior alt-mask shift-mask))
                     ((eq? mod '__CTRL_ALT_SHIFT) (logior control-mask alt-mask shift-mask))
                     (#t any)))
      (cond ((or (eq? evt '__KEY_PRESS)
                 (eq? evt '__KEY_RELEASE))
             (set! arcs (cons (eth-make-event-arc (key (if ky (symbol->string ky) any) md)
                                                  fn (eq? evt '__KEY_RELEASE) #t)
                              arcs)))
            ((or (eq? evt '__MOUSE_PRESS)
                 (eq? evt '__MOUSE_RELEASE))
             (set! arcs (cons (eth-make-event-arc (button (or but any) md)
                                                  fn (eq? evt '__MOUSE_RELEASE) #t)
                              arcs)))
            ((eq? evt '__DOUBLE_CLICK)
             (set! arcs (cons (eth-make-event-arc (double-button (or but any) md)
                                                  fn #f #t)
                              arcs)))
            ((or (eq? evt '__MOUSE_ENTER)
                 (eq? evt '__MOUSE_LEAVE))
             (set! arcs (cons (eth-make-event-arc (if (eq? evt '__MOUSE_ENTER) (enter) (leave))
                                                  fn #f #f)
                              arcs))))
      (set! lst (cdr lst))
      (while (and (not (null? lst)) (not (eq? (caar lst) '__NEXT_ACTION)))
        (set! lst (cdr lst))))
    (apply make-behavior (reverse arcs))))

(define (eth-assoc tag lst)
  (if (string? tag)
      (set! tag (string->symbol tag)))
  (let ((a (assq tag lst)))
    (cond ((or (not a) (null? (cdr a)))
           #f)
          ((and (string? (cadr a))
                (> (length a) 2))
           (string->symbol (apply string-append
                                  (map (lambda (x)
                                         (if (symbol? x)
                                             (symbol->string x)
                                             x))
                                       (cdr a)))))
          ((= (length a) 2)
           (cadr a))
          (#t
           (cdr a))
)))
          
(define (eth-assoc-between tag lst from to)
  (while (not (or (null? lst) (eq? from (caar lst))))
    (set! lst (cdr lst)))
  (if (not (null? lst))
      (set! lst (cdr lst)))
  (while (not (or (null? lst) (eq? tag (caar lst)) (memq (caar lst) to)))
    (set! lst (cdr lst)))
  (if (and (not (null? lst))
           (eq? tag (caar lst)))
      (if (and (string? (cadar lst))
               (> (length (car lst)) 2))
          (string->symbol (apply string-append
                                 (map (lambda (x)
                                        (if (symbol? x)
                                            (symbol->string x)
                                            x))
                                      (cdar lst))))
          (if (= (length (car lst)) 2)
              (cadar lst)
              (cdar lst)))
      #f))

(define (eth-lookup-type lst type name)
  (if (symbol? name)
      (set! name (symbol->string name)))
  (while (and (not (null? lst))
              (or (not (eq? (caar lst) type))
                  (not name)
                  (not (equal? ((lambda (x)
                                  (if (symbol? x)
                                      (symbol->string x)
                                      x))
                                (eth-assoc '__NAME (cadar lst)))
                               name))))
    (set! lst (cdr lst)))
  (if (not (null? lst))
      (cadar lst)
      #f))

(define (eth-for-each-type lst type func)
  (while (not (null? lst))
    (if (eq? (caar lst) type)
        (func (cadar lst)))
    (set! lst (cdr lst))))

(define (eth-interpret-anchor proc abs br)
  (if (or proc abs)
      (list (if proc (/ proc 1024) 0.0)
            (if abs (if br (+ 1 abs) abs) 0)
            (if br 1.0 0.0))
      #f))

(define (eth-combine-anchor perc abs quad)
  (if (not (or perc abs))
      (cons #f #f)
      (let ((p1 (or (car quad) 0))
            (a1 (or (cadr quad) 0))
            (p2 (or (caddr quad) 0))
            (a2 (or (cadddr quad) -1))
            (d (or (car (cddddr quad)) 0)))
        (if (not (or (car quad) (cadr quad)))
            (begin
              (set! p1 p2)
              (set1 a1 (- a2 d -1))))
        (if (not (or (caddr quad) (cadddr quad)))
            (begin
              (set! p2 p1)
              (set1 a2 (+ a1 d -1))))
        (cons (inexact->integer (+ p1 (/ (* perc (- p2 p1)) 1024)))
              (inexact->integer (+ abs a1 (/ (* perc (- a2 a1)) 1024)))))))

(define (eth-make-title-deco tfunc lst)
  (let ((pos (/ (or (and lst (eth-assoc '__JUSTIFICATION lst)) 512) 1024))
        (orient (and lst (eth-assoc '__ORIENTATION lst))))
    (make-deco '()
               :anchor (cond ((eq? orient '__FONT_TO_DOWN)
                              (list (list 0.5 0 0.5) (list pos 0 pos)))
                             ((eq? orient '__FONT_TO_UP)
                              (list (list 0.5 0 0.5) (list (- 1.0 pos) 0 (- 1.0 pos))))
                             ((eq? orient '__FONT_TO_LEFT)
                              (list (list (- 1.0 pos) 0 (- 1.0 pos)) (list 0.5 0 0.5)))
                             (#t
                              (list (list pos 0 pos) (list 0.5 0 0.5))))
               :background (make-color 'transparent))))

(define (eth-interpret-borderpart lst glst sofar)
  (let ((iclass (eth-assoc '__ICLASS lst))
        (aclass (eth-assoc '__ACLASS lst))
        (tclass (eth-assoc '__TCLASS lst))
        (curname (eth-assoc '__CURSOR lst))
        (minw (or (eth-assoc '__MIN_WIDTH lst) 0))
        (maxw (or (eth-assoc '__MAX_WIDTH lst) 99999))
        (minh (or (eth-assoc '__MIN_HEIGHT lst) 0))
        (maxh (or (eth-assoc '__MAX_HEIGHT lst) 99999))
        (tl-orig (eth-assoc '__TOPLEFT_ORIGIN lst))
        (tl-xperc (eth-assoc '__TOPLEFT_X_PERCENTAGE lst))
        (tl-xabs (eth-assoc '__TOPLEFT_X_ABSOLUTE lst))
        (tl-yperc (eth-assoc '__TOPLEFT_Y_PERCENTAGE lst))
        (tl-yabs (eth-assoc '__TOPLEFT_Y_ABSOLUTE lst))
        (br-orig (eth-assoc '__BOTTOMRIGHT_ORIGIN lst))
        (br-xperc (eth-assoc '__BOTTOMRIGHT_X_PERCENTAGE lst))
        (br-xabs (eth-assoc '__BOTTOMRIGHT_X_ABSOLUTE lst))
        (br-yperc (eth-assoc '__BOTTOMRIGHT_Y_PERCENTAGE lst))
        (br-yabs (eth-assoc '__BOTTOMRIGHT_Y_ABSOLUTE lst))
        (shade (eq? (eth-assoc '__KEEP_WHEN_SHADED lst) '__OFF))
        (under (eq? (eth-assoc '__KEEP_ON_TOP lst) '__OFF)))
    (if (and (eq? minw maxw) (eq? tl-orig br-orig) (eq? tl-xperc br-xperc) tl-xabs br-xabs)
        (if (not (= minw (- br-xabs tl-xabs)))
            (let ((delta1 (quotient (- br-xabs tl-xabs minw) 2))
                  (delta2 (quotient (- br-xabs tl-xabs minw -1) 2)))
              (if (> delta1 0)
                  (begin
                    (set! tl-xabs (+ tl-xabs delta1))
                    (set! br-xabs (- br-xabs delta2)))
                  (begin
                    (set! br-xabs (- br-xabs delta1 delta2)))))))
    
    (if (and (= minh maxh) (eq? tl-orig br-orig) (eq? tl-yperc br-yperc) tl-yabs br-yabs)
        (if (not (= minh (- br-yabs tl-yabs)))
            (let ((delta1 (quotient (- br-yabs tl-yabs minh) 2))
                  (delta2 (quotient (- br-yabs tl-yabs minh -1) 2)))
              (if (> delta1 0)
                  (begin
                    (set! tl-yabs (+ tl-yabs delta1))
                    (set! br-yabs (- br-yabs delta2)))
                  (begin
                    (set! br-yabs (- br-yabs delta1 delta2)))))))
    (if (and tl-orig (not (= tl-orig -1)) (> (length (car sofar)) tl-orig))
        (let* ((tmp (list-ref (car sofar) tl-orig))
               (x (eth-combine-anchor tl-xperc tl-xabs (car tmp)))
               (y (eth-combine-anchor tl-yperc tl-yabs (cdr tmp))))
          (set! tl-xperc (car x))
          (set! tl-xabs (cdr x))
          (set! tl-yperc (car y))
          (set! tl-yabs (cdr y))))
    (if (and br-orig (not (= br-orig -1)) (> (length (car sofar)) br-orig))
        (let* ((tmp (list-ref (car sofar) br-orig))
               (x (eth-combine-anchor br-xperc br-xabs (car tmp)))
               (y (eth-combine-anchor br-yperc br-yabs (cdr tmp))))
          (set! br-xperc (car x))
          (set! br-xabs (cdr x))
          (set! br-yperc (car y))
          (set! br-yabs (cdr y))))
    (let ((tmp (cons (cons (list tl-xperc tl-xabs br-xperc br-xabs (and (eq? minw maxw) minw))
                           (list tl-yperc tl-yabs br-yperc br-yabs (and (eq? minh maxh) minh)))
                     '())))
      (if (not (cdr sofar))
          (begin
            (set-car! sofar tmp)
            (set-cdr! sofar tmp))
          (begin
            (set-cdr! (cdr sofar) tmp)
            (set-cdr! sofar tmp))))
    (let ((width (if (and minw maxw (= minw maxw)) minw #f))
          (height (if (and minh maxh (= minh maxh)) minh #f))
          (beh (if aclass (eth-interpret-aclass (or (eth-lookup-type glst '__ACLASS aclass) '()) glst) #f))
          (l-anchor (eth-interpret-anchor tl-xperc tl-xabs #f))
          (t-anchor (eth-interpret-anchor tl-yperc tl-yabs #f))
          (r-anchor (eth-interpret-anchor br-xperc br-xabs #t))
          (b-anchor (eth-interpret-anchor br-yperc br-yabs #t))
          (path (string-append eth-load-path (cadar glst) "/"))
          (cur (if curname (eth-interpret-cursor (or (eth-lookup-type glst '__CURSOR curname) '()) glst) #f))
          (iclasslst (eth-lookup-type glst '__ICLASS iclass))
          (tclasslst (eth-lookup-type glst '__TCLASS tclass)))
      (if (not (or l-anchor r-anchor))
          (set! l-anchor (list 0 0 0)))
      (if (not (or t-anchor b-anchor))
          (set! t-anchor (list 0 0 0)))
      (if width
          (if l-anchor
              (set! r-anchor (list (car l-anchor) (+ (cadr l-anchor) width) 1.0))
              (if r-anchor
                  (set! l-anchor (list (car r-anchor) (- (cadr r-anchor) width) 0.0)))))
      (if height
          (if t-anchor
              (set! b-anchor (list (car t-anchor) (+ (cadr t-anchor) height) 1.0))
              (if b-anchor 
                  (set! t-anchor (list (car b-anchor) (- (cadr b-anchor) height) 0.0)))))
      (lambda (w)
        (let* ((bgfunc (if iclasslst 
                           (eth-interpret-background-func iclasslst path)
                           (lambda (d) #f)))
               (tfunc (if tclasslst
                          (eth-interpret-text-func tclasslst glst)
                          #f))
               (behavior (if beh
                             (make-behavior
                              beh
                              (eth-iclass-inner-behavior bgfunc tfunc))
                             (eth-iclass-inner-behavior bgfunc tfunc)))
               (prop (list (cons 'active #f)
                           (cons 'hilited #f)
                           (cons 'clicked #f)
                           (cons 'shade shade)
                           (cons 'under under))))
          (make-deco (if tclass
                         (eth-make-title-deco tfunc tclasslst)
                         '())
                     :property prop
                     :width width
                     :height height
                     :cursor cur
                     :anchor (if (and l-anchor t-anchor r-anchor b-anchor) 
                                 (list l-anchor t-anchor r-anchor b-anchor)
                                 (list (or l-anchor r-anchor) (or t-anchor b-anchor)))
                     :behavior behavior))))))
  
(define (eth-insert-window w lst)
  (if (or (null? lst)
          (not (get-property (car lst) 'under)))
      (cons w lst)
      (cons (car lst) (eth-insert-window w (cdr lst)))))

(define (eth-interpret-border lst glst)
  (let ((left (eth-assoc '__BORDER_SIZE_LEFT lst))
        (right (eth-assoc '__BORDER_SIZE_RIGHT lst))
        (top (eth-assoc '__BORDER_SIZE_TOP lst))
        (bottom (eth-assoc '__BORDER_SIZE_BOTTOM lst))
        (parts '())
        (sofar (cons #f #f)))
    (set! left (or left 0))
    (set! right (or right 0))
    (set! top (or top 0))
    (set! bottom (or bottom 0))
    (eth-for-each-type lst '__BORDER_PART 
                       (lambda (l)
                         (set! parts (cons (eth-interpret-borderpart l glst sofar)
                                           parts))))
    (set! parts (reverse! parts))
    (lambda (w)
      (set-deco-anchor! w (list left top))
      (set-deco-behavior! w (if (deco-behavior w)
                                (make-behavior (deco-behavior w)
                                               eth-inner-behavior)
                                eth-inner-behavior))
      (set-property! w 'dwidth (+ left right))
      (set-property! w 'dheight (+ top bottom))
      (apply make-deco
             (append (eth-insert-window w (map (lambda (f) (f w)) parts))
                     (list :background (make-color 'transparent)
                           :width (+ left right (deco-width w) (* 2 (deco-borderwidth w)))
                           :height (+ top bottom (deco-height w) (* 2 (deco-borderwidth w)))
                           :behavior (make-behavior window-behavior
                                                    (on (closing)
                                                        (map (lambda (d) (if (deco-mapped? d) (delete-window d)))
                                                             (or (get-property deco 'slideouts) '()))
                                                        (run-hook window-closing deco)) ;; REMOVE THIS LINE AFTER BEHAVIOR FIX
                                                    std-window-behavior)
                           :property (list (cons 'shaded #f))))))))

(define (eth-interpret-menu-border lst glst)
  (let ((left (eth-assoc '__BORDER_SIZE_LEFT lst))
        (right (eth-assoc '__BORDER_SIZE_RIGHT lst))
        (top (eth-assoc '__BORDER_SIZE_TOP lst))
        (bottom (eth-assoc '__BORDER_SIZE_BOTTOM lst))
        (parts '())
        (sofar (cons #f #f)))
    (set! left (or left 0))
    (set! right (or right 0))
    (set! top (or top 0))
    (set! bottom (or bottom 0))
    (eth-for-each-type lst '__BORDER_PART 
                       (lambda (l)
                         (set! parts (cons (eth-interpret-borderpart l glst sofar)
                                           parts))))
    (set! parts (reverse! parts))
    (lambda (w)
      (set-deco-anchor! w (list left top))
      (set-property! w 'dwidth (+ left right))
      (set-property! w 'dheight (+ top bottom))
      (apply make-deco
             (append (eth-insert-window w (map (lambda (f) (f w)) parts))
                     (list :background (make-color 'transparent)
                           :width (+ left right (deco-width w) (* 2 (deco-borderwidth w)))
                           :height (+ top bottom (deco-height w) (* 2 (deco-borderwidth w)))
                           :behavior std-menu-behavior
                           :property (list (cons 'shaded #f))))))))

(define (eth-lookup-border name lst)
  (let ((blst (eth-lookup-type lst '__BORDER name)))
    (if blst
        (eth-interpret-border blst lst)
        #f)))

(define (eth-lookup-menu-border name lst)
  (let ((blst (eth-lookup-type lst '__BORDER name)))
    (if blst
        (eth-interpret-menu-border blst lst)
        #f)))

(define (eth-peek-menu-border-text name lst)
  (let ((blst (eth-lookup-type lst '__BORDER name)))
    (if blst
        (let ((hastext #f))
          (eth-for-each-type blst '__BORDER_PART 
                             (lambda (l)
                               (if (eth-assoc '__TCLASS l)
                                   (set! hastext #t))))
          hastext)
        #f)))

(define (eth-lookup-icon-pixmap cls lst)
  (if (string? cls)
      (set! cls (string->symbol cls)))
  (let ((res #f))
    (while (and (not res) (not (null? lst)))
      (if (and (eq? (caar lst) 'Class)
               (eq? (caddar lst) 'Icon)
               (equal? (cadar lst) cls))
        (set! res (car (cdddar lst))))
      (set! lst (cdr lst)))
    (if (and res (symbol? res))
        (set! res (symbol->string res)))
    (and res
         (string-append eth-load-path "../config/" res))))

(define (eth-lookup-icon iname lst)
  (let* ((path (string-append eth-load-path (cadar lst) "/"))
         (ilst (eth-lookup-type lst '__ICLASS iname)))
    (if ilst
        (lambda (win)
          (let* ((bgfunc (if ilst 
                             (eth-interpret-fixsize-background-func ilst path)
                             (lambda (d) #f)))
                 (behavior (make-behavior
                            (eth-wrap-button-actions icon-behavior
                                                     (lambda (d) (send-user-event 'press d))
                                                     (lambda (d) (send-user-event 'release d)))
                            (on (opening)
                                (bgfunc deco)
                                (run-hook icon-opening deco)) ;; REMOVE THIS ENTRY AFTER BEHAVIOR FIX
                            (eth-iclass-inner-behavior bgfunc #f)
                            std-icon-behavior))
                 (prop (list (cons 'active #f)
                             (cons 'hilited #f)
                             (cons 'clicked #f))))
            (make-deco '()
                       :behavior behavior
                       :property prop)))
        #f)))

(define (eth-parse-theme theme)
  (let ((themedir (string-append eth-load-path theme))
        (confdir (string-append eth-load-path "../config/"))
        (tmpfile "/tmp/ethemeborders.cfg")
        (tmpfile2 "/tmp/definitions")
        (f #f)
        (lst '()))
    (set! eth-theme-name theme)
    (system (simple-format #f "rm ~A; touch ~A; rm ~A; sed 's/#define __.*//' ~Adefinitions > ~A;"
                           tmpfile tmpfile tmpfile2 confdir tmpfile2))
    (system (simple-format #f "cd ~A; for a in *.cfg; do cpp -P -I/tmp -I. $a | tr ';' '\n' >> ~A; done;"
                           themedir tmpfile))
    (system (simple-format #f "cd ~A; for a in *.cfg; do cpp -P -I/tmp -I. $a | tr ';' '\n' >> ~A; done;"
                           confdir tmpfile))
    (set! f (open-file tmpfile "r"))
    (set! lst (parse-read-file f))
    (close-port f)
    (cons (list '__NAME theme)
          (car (parse-organize-list lst '__BGN '__END)))))

;--------------------------

(define (eth-make-index-selection-function vec)
  (letrec ((compfunc (lambda (from to dist)
                       (let ((td (+ from dist)))
                         (while (and (< (+ from dist) to)
                                     (eq? (vector-ref vec from)
                                          (vector-ref vec (+ from dist))))
                                (set! from (+ from 1))
                                (if (= from td)
                                    (begin
                                      (set! from (+ from dist))
                                      (set! td (+ td dist dist)))))
                         (if (< (+ from dist) to)
                             #f
                             #t))))
           (recfunc (lambda (tsts from to)
                      (cond ((null? tsts)
                             (let ((res (vector-ref vec from)))
                               (lambda (d) res)))
                            ((compfunc from to (quotient (- to from -1) 2))
                             (recfunc (cdr tsts) from (+ from (quotient (- to from -1) 2))))
                            (#t
                             (let ((tst (car tsts))
                                   (f1 (recfunc (cdr tsts) from (+ from (quotient (- to from -1) 2))))
                                   (f2 (recfunc (cdr tsts) (+ from (quotient (- to from -1) 2)) to)))
                               (lambda (d) (if (tst d) (f2 d) (f1 d)))))))))
    (if (defined? 'virtual-nailed)
        (recfunc (list (lambda (d) (and (deco-window? d)
                                        (if (and (deco-menu? d) (get-property (inner-deco d) 'caller))
                                            (virtual-nailed (top-deco (get-property (inner-deco d) 'caller)))
                                            (virtual-nailed (top-deco d)))))
                       (lambda (d) (get-property d 'active))
                       (lambda (d) (get-property d 'clicked))
                       (lambda (d) (get-property d 'hilited)))
                 0 12)
        (recfunc (list (lambda (d) (get-property d 'active))
                       (lambda (d) (get-property d 'clicked))
                       (lambda (d) (get-property d 'hilited)))
                 0 6)))) 

(define (eth-make-state-cache-list lst vec tags)
  (let* ((cl '())
         (nextind 0)
         (all '(__NORMAL __HILITED __CLICKED
                __NORMAL_ACTIVE __HILITED_ACTIVE __CLICKED_ACTIVE
                __NORMAL_STICKY __HILITED_STICKY __CLICKED_STICKY
                __NORMAL_ACTIVE_STICKY
                __HILITED_ACTIVE_STICKY __NORMAL_ACTIVE_HILITED
                __CLICKED_ACTIVE_STICKY __NORMAL_ACTIVE_CLICKED))
         (rfunc (lambda (tag ind)
                  (let* ((str (eth-assoc tag lst))
                         (key (if str 
                                  (cons str (map (lambda (tg)
                                                   (eth-assoc-between tg lst tag all))
                                                 tags))
                                  #f))
                         (pos (assoc-ref cl key)))
                    (cond (pos
                           (vector-set! vec ind pos))
                          (str
                           (set! cl (cons (cons key nextind) cl))
                           (vector-set! vec ind nextind)
                           (set! nextind (+ 1 nextind)))
                          (#t
                           (vector-set! vec ind #f))))))
         (dfunc (lambda (ind deflst)
                  (if (not (vector-ref vec ind))
                      (vector-set! vec ind
                                   (or (or-map (lambda (i)
                                                 (vector-ref vec i))
                                               deflst)
                                       0))))))
    (rfunc '__NORMAL 0)
    (rfunc '__HILITED 1)
    (rfunc '__CLICKED 2)
    (rfunc '__NORMAL_ACTIVE 3)
    (rfunc '__HILITED_ACTIVE 4)
    (rfunc '__CLICKED_ACTIVE 5)
    (rfunc '__NORMAL_STICKY 6)
    (rfunc '__HILITED_STICKY 7)
    (rfunc '__CLICKED_STICKY 8)
    (rfunc '__NORMAL_ACTIVE_STICKY 9)
    (rfunc '__HILITED_ACTIVE_STICKY 10)
    (if (not (vector-ref vec 10))
        (rfunc '__NORMAL_ACTIVE_HILITED 10))
    (rfunc '__CLICKED_ACTIVE_STICKY 11)
    (if (not (vector-ref vec 11))
        (rfunc '__NORMAL_ACTIVE_CLICKED 11))
    (dfunc 11 '(10 9 8 7 6 5 4 3 2 1 0))
    (dfunc 10 '(9 7 6 4 3 1 0))
    (dfunc 9 '(6 3 0))
    (dfunc 8 '(7 6 2 1 0))
    (dfunc 7 '(6 1 0))
    (dfunc 6 '(0))
    (dfunc 5 '(4 3 2 1 0))
    (dfunc 4 '(3 1 0))
    (dfunc 3 '(0))
    (dfunc 2 '(1 0))
    (dfunc 1 '(0))
    (dfunc 0 '())
    (map (lambda (c)
           (cons (car c) #f))
         (reverse! cl))))


(define (eth-interpret-background-func lst path)
  (let ((vec (make-vector 12 0))
        (w #f)
        (h #f)
        (c #f)
        (cl #f)
        (sfunc #f))
    (set! cl (eth-make-state-cache-list lst vec '(__EDGE_SCALING __FILLRULE)))
    (set! sfunc (eth-make-index-selection-function vec))
    (for-each (lambda (c)
                (set-car! (car c) (string-append path (caar c))))
              cl)
    (lambda (deco)
      (if (not (and (eq? w (width deco))
                    (eq? h (height deco))))
          (begin
            (for-each (lambda (c) (set-cdr! c #f)) cl)
            (set! w (width deco))
            (set! h (height deco))))
      (set! c (list-ref cl (sfunc deco)))
      (if (not (cdr c))
          (set-cdr! c (load-image (caar c)
                                  :width (if (memq (caddar c) '(__TILE __TILE_H)) #f w)
                                  :height (if (memq (caddar c) '(__TILE __TILE_V)) #f h)
                                  :borderwidth (cadar c))))
      (set-deco-background! deco (cdr c)))))

(define (eth-interpret-fixsize-background-func lst path)
  (let ((vec (make-vector 12 0))
        (w #f)
        (h #f)
        (c #f)
        (cl #f)
        (sfunc #f))
    (set! cl (eth-make-state-cache-list lst vec '(__EDGE_SCALING __FILLRULE)))
    (set! sfunc (eth-make-index-selection-function vec))
    (for-each (lambda (c)
                (set-car! (car c) (string-append path (caar c))))
              cl)
    (lambda (deco)
      (set! c (list-ref cl (sfunc deco)))
      (if (not (cdr c))
          (set-cdr! c (load-image (caar c))))
      (if (not (and w h))
          (begin
            (set! w (width (cdr c)))
            (set! h (height (cdr c)))
            (modify-deco deco :width w :height h)))
      (set-deco-background! deco (cdr c)))))

(define (eth-interpret-item-background-func lst plst path nobg)
  (let ((vec (and lst (make-vector 12 0)))
        (pvec (and nobg plst (make-vector 12 0)))
        (dim1 #f)
        (dim2 #f)
        (ind #f)
        (cl #f)
        (pcl #f)
        (sfunc #f)
        (psfunc #f))
    (set! cl (and lst (eth-make-state-cache-list lst vec '(__EDGE_SCALING __FILLRULE))))
    (set! pcl (and nobg plst (eth-make-state-cache-list plst pvec '(__EDGE_SCALING __FILLRULE))))
    (set! sfunc (and cl (eth-make-index-selection-function vec)))
    (set! psfunc (and pcl (eth-make-index-selection-function pvec)))
    (if cl
        (for-each (lambda (c)
                    (set-car! (car c) (string-append path (caar c))))
                  cl))
    (if pcl
        (for-each (lambda (c)
                    (set-car! (car c) (string-append path (caar c))))
                  pcl))
    (lambda (deco)
      (if (not (and (equal? dim1 (dimensions deco))
                    (equal? dim2 (cddr (dimensions (deco-parent deco))))))
          (begin
            (for-each (lambda (c) (set-cdr! c #f)) cl)
            (set! dim1 (dimensions deco))
            (set! dim2 (cddr (dimensions (deco-parent deco))))))
      (let* ((c #f)
             (normal (and (not (get-property deco 'hilited)) (not (get-property deco 'clicked))))
             (usep (or (and nobg plst) (not lst)))
             (use1 (and lst (or (not nobg) (eq? nobg 'overlay) (not plst) (not normal))))
             (useboth (and lst plst nobg)))
        (if use1
            (begin
              (set! c (list-ref cl (sfunc deco)))
              (if (not (cdr c))
                  (let ((im (load-image (caar c)
                                          :width (if (memq (caddar c) '(__TILE __TILE_H)) #f (caddr dim1))
                                          :height (if (memq (caddar c) '(__TILE __TILE_V)) #f (cadddr dim1))
                                          :borderwidth (cadar c))))
                    (if (memq (caddar c) '(__TILE __TILE_H __TILE_V))
                        (set-cdr! c (make-deco '() :background im))
                        (set-cdr! c im))))))
         (if useboth
            (if use1
                (if (= (deco-num-parts deco) 2)
                    (set-deco-part! deco 2 (cdr c))
                    (deco-add-part! deco 2 (cdr c)))
                (if (= (deco-num-parts deco) 2)
                    (deco-remove-part! deco 2))))
         (if usep
            (begin
              (set! c (list-ref pcl (psfunc deco)))
              (if (not (cdr c))
                  (set-cdr! c (cond ((eq? (caddar c) '__TILE)
                                     (eth-load-image-shifted (caar c) #f #f #f (car dim1) (cadr dim1)))
                                    ((eq? (caddar c) '__TILE_H)
                                     (eth-load-image-shifted (caar c) #f (cadr dim2) (cadar c) (car dim1) (cadr dim1)))
                                    ((eq? (caddar c) '__TILE_V)
                                     (eth-load-image-shifted (caar c) (car dim2) #f (cadar c) (car dim1) (cadr dim1)))
                                    (#t
                                     (load-image (caar c) 
                                                 :width (car dim2)
                                                 :height (cadr dim2)
                                                 :crop dim1
                                                 :borderwidth (cadar c))))))))
        (set-deco-background! deco (cdr c))))))
  
(define (eth-load-image-shifted name wdt hgt brd shiftx shifty)
  (if (or (not wdt) (not hgt))
      (let ((im (load-image name)))
        (if (not wdt) (set! wdt (width im)))
        (if (not hgt) (set! hgt (height im)))))
  (if (>= shiftx wdt)
      (set! shiftx (remainder shiftx wdt))
      (if (< shiftx 0)
          (set! shiftx (+ wdt -1 (remainder (- shiftx 1) wdt)))))
  (if (>= shifty hgt)
      (set! shifty (remainder shifty hgt))
      (if (< shifty 0)
          (set! shifty (+ hgt -1 (remainder (- shifty 1) hgt)))))
  (let* ((pix (make-pixmap wdt hgt))
         (im1 (and (> shiftx 0) (> shifty 0)
                   (load-image name :width wdt :height hgt :borderwidth brd
                               :crop (list (- shiftx wdt) (- shifty hgt) wdt hgt))))
         (im2 (and (> shifty 0)
                   (load-image name :width wdt :height hgt :borderwidth brd
                               :crop (list shiftx (- shifty hgt) wdt hgt))))
         (im3 (and (> shiftx 0)
                   (load-image name :width wdt :height hgt :borderwidth brd
                               :crop (list (- shiftx wdt) shifty wdt hgt))))
         (im4 (load-image name :width wdt :height hgt :borderwidth brd
                          :crop (list shiftx shifty wdt hgt))))
    (if im1 (draw-rectangle pix (- wdt shiftx) (- hgt shifty) shiftx shifty :background im1))
    (if im2 (draw-rectangle pix 0 (- hgt shifty) (- wdt shiftx) shifty :background im2))
    (if im3 (draw-rectangle pix (- wdt shiftx) 0 shiftx (- hgt shifty) :background im3))
    (draw-rectangle pix 0 0 (- wdt shiftx) (- hgt shifty) :background im4)
    pix))

(define (eth-make-color rgb)
  (cond ((or (not rgb) (equal? rgb '(0 0 0)))
         (make-color "black"))
        ((equal? rgb '(255 255 255))
         (make-color "white"))
        (#t
         (make-color (* (car rgb) 257) (* (cadr rgb) 257) (* (caddr rgb) 257)))))

(define (eth-interpret-font name glst)
  (if (symbol? name)
      (set! name (symbol->string name)))
  (if (and (not (string= name ""))
           (eq? (string-ref name 0) #\*))
      (let* ((flst (eth-assoc '__FONTS glst))
             (fn (and flst (eth-assoc (substring name 1) flst))))
        (if fn
            (set! name (if (symbol? fn) (symbol->string fn) fn)))))
  (if (and (null? (find-fonts name))
           (string-match "^[a-z]*/[0-9]*$" name))
      (set! name (string-append "*-" 
                                (if (string-match "bold" name) "bold-" "medium-")
                                (if (string-match "italic" name) "i-" "r-")
                                "*-*-*-*-*-*-*-"
                                (match:substring (string-match "/([0-9]*)" name) 1)
                                "0-iso8859*")))
  (if (null? (find-fonts name))
      (make-font "fixed")
      (make-font name)))

(define (eth-interpret-text-func lst glst)
  (if (not lst)
      (let ((txt "")
            (pix #f))
        (lambda (str deco)
          (if (not (and pix (string=? str txt)))
              (begin
                (set! txt str)
                (set! pix (make-label txt :foreground (make-color "black") :background (make-color 'transparent) :horizontal-margin 2))))
          (set-deco-part! (deco-part deco 1) 1 pix)))
      (let ((vec (make-vector 12 0))
            (txt "")
            (c #f)
            (cl #f)
            (sfunc #f)
            (pad (or (eth-assoc '__PADDING lst) '(0 0 0 0)))
            (orient (eth-assoc '__ORIENTATION lst))
            (angle 0)
            (behavior #f))
        (set! cl (eth-make-state-cache-list lst vec '(__FORGROUND_COLOR __BACKGROUND_COLOR __DRAWING_EFFECT)))
        (set! sfunc (eth-make-index-selection-function vec))
        (for-each (lambda (c)
                    (set-car! (car c) (eth-interpret-font (caar c) glst))
                    (set-car! (cdar c) (eth-make-color (cadar c)))
                    (set-car! (cddar c) (eth-make-color (caddar c))))
                  cl)
        (cond ((eq? orient '__FONT_TO_DOWN)
               (set! angle 90))
              ((eq? orient '__FONT_TO_UP)
               (set! angle -90))
              ((eq? orient '__FONT_TO_LEFT)
               (set! angle 180)))
        (lambda (str deco)
          (if (not (string=? str txt))
              (begin
                (for-each (lambda (c) (set-cdr! c #f)) cl)
                (set! txt str)))
          (set! c (list-ref cl (sfunc deco)))
          (if (not (cdr c))
              (set-cdr! c (let* ((dim (string-dimensions txt (caar c) :angle angle))
                                 (pix (make-pixmap (+ (car pad) (cadr pad) (car dim))
                                                   (+ (caddr pad) (cadddr pad) (cadr dim))
                                                   :background (make-color 'transparent)))
                                 (x (+ (car pad) (caddr dim)))
                                 (y (+ (caddr pad) (cadddr dim))))
                            (cond ((eq? (car (cdddar c)) '__EFFECT_SHADOW)
                                   (draw-text pix (+ 1 x) (+ 1 y) txt
                                              :font (caar c) :color (caddar c) :angle angle)
                                   (draw-text pix x y txt
                                              :font (caar c) :color (cadar c) :angle angle))
                                  ((eq? (car (cdddar c)) '__EFFECT_OUTLINE)
                                   (draw-text pix (+ x 1) y txt
                                              :font (caar c) :color (caddar c) :angle angle)
                                   (draw-text pix (- x 1) y txt
                                              :font (caar c) :color (caddar c) :angle angle)
                                   (draw-text pix x (+ y 1) txt
                                              :font (caar c) :color (caddar c) :angle angle)
                                   (draw-text pix x (- y 1) txt
                                              :font (caar c) :color (caddar c) :angle angle)
                                   (draw-text pix x y txt
                                              :font (caar c) :color (make-color 'transparent) :angle angle))
                                  (#t
                                   (draw-text pix x y txt
                                              :font (caar c) :color (cadar c) :angle angle)))
                            pix)))
          (set-deco-part! (deco-part deco 1) 1 (cdr c))))))

(define (eth-iclass-menu-behavior bgfunc tfunc label)
  (make-behavior
   (on (user-event 'inactive)
       (set-property! deco 'hilited #f)
       (set-property! deco 'clicked #f)
       (bgfunc deco)
       (tfunc label deco))
   (on (user-event 'active)
       (set-property! deco 'hilited #t)
       (set-property! deco 'clicked #f)
       (bgfunc deco)
       (tfunc label deco))
   (on (user-event 'pressed)
       (set-property! deco 'hilited #t)
       (set-property! deco 'clicked #t)
       (bgfunc deco)
       (tfunc label deco))))

(define (eth-interpret-menu-style lst glst)
  (let* ((path (string-append eth-load-path (cadar glst) "/"))
         (bgim (eth-assoc '__BG_ICLASS lst))
         (itemim (eth-assoc '__ITEM_ICLASS lst))
         (subim (eth-assoc '__SUBMENU_ICLASS lst))
         (noibg (memq (eth-assoc '__USE_ITEM_BACKGROUNDS lst) '(__OFF 0)))
         (tclass (eth-assoc '__TCLASS lst))
         (tlst (eth-lookup-type glst '__TCLASS tclass))
         (font (eth-interpret-font (eth-assoc '__NORMAL tlst) glst))
         (pos (/ (or (and tclass (eth-assoc '__JUSTIFICATION tlst)) 512) 1024))
         (bglst (eth-lookup-type glst '__ICLASS bgim))
         (itemlst (eth-lookup-type glst '__ICLASS itemim))
         (sublst (eth-lookup-type glst '__ICLASS subim))
         (bgpad (or (and bglst (eth-assoc '__PADDING bglst)) '(0 0 0 0)))
         (itempad (or (and itemlst (eth-assoc '__PADDING itemlst)) '(0 0 0 0)))
         (subpad (or (and sublst (eth-assoc '__PADDING sublst)) '(0 0 0 0)))
         (bord (eth-assoc '__BORDER lst))
         (bordfunc (if bord (eth-lookup-menu-border bord glst) identity))
         (m #f))
    (list :menu-func
          (lambda args
            (let ((bgfunc (if bglst
                              (eth-interpret-background-func bglst path)
                              (lambda (d) (set-deco-background! d (make-color "white")))))
                  (l (car bgpad))
                  (r (car bgpad))
                  (t (caddr bgpad))
                  (b (caddr bgpad))
                  (title #f))
              (if (and (not (null? args)) (deco? (car args)) (get-property (car args) 'label)
                       (eth-peek-menu-border-text bord glst))
                  (begin
                    (set! title (get-property (car args) 'label))
                    (set! args (cdr args))))
              (for-each (lambda (e)
                          (let ((w (or (get-property e 'eth-w) 0))
                                (h (or (get-property e 'eth-h) 0)))
                            (set-deco-anchor! e (list l b (list 1 (- (cadr bgpad)) 1) (list 0 (+ b h) 1)))
                            (set! b (+ b h))
                            (if (> w r)
                                (set! r w))))
                        args)
              (set! m (bordfunc
                       (apply make-deco
                              (append args
                                      (list :width (+ r (cadr bgpad))
                                            :height (+ b (cadddr bgpad))
                                            :behavior (make-behavior
                                                       (on (opening) (bgfunc deco))
                                                       ))))))
              (set-property! m 'menu-title (or title "Menu"))
              m))          :label-func
          (lambda (label)
            (let ((dim (string-dimensions label font))
                  (pad itempad)
                  (bfunc (lambda (d) #f))
                  (tfunc (eth-interpret-text-func tlst glst)))
              (make-deco (make-deco '()
                                    :background (make-color 'transparent)
                                    :anchor(list (list pos 0 pos) (list 0.5 0 0.5)))
                         :background (make-color 'transparent)
                         :property (list (cons 'eth-w (+ (car pad) (cadr pad) (car dim)))
                                         (cons 'eth-h (+ (caddr pad) (cadddr pad) (cadr dim)))
                                         (cons 'label label))
                         :behavior (make-behavior
                                    (eth-iclass-menu-behavior bfunc tfunc label)
                                    (on (opening) (tfunc label deco))
                                    std-menu-label-behavior))))
          :item-func
          (lambda (label action)
            (let ((dim (string-dimensions label font))
                  (pad (if (deco? action) subpad itempad))
                  (bfunc (if (and (deco? action) sublst)
                             (eth-interpret-item-background-func sublst bglst path (and noibg 'overlay))
                             (if (or itemlst bglst)
                                 (eth-interpret-item-background-func itemlst bglst path noibg)
                                 (lambda (d) (set-deco-background! d (make-color "white"))))))
                  (tfunc (eth-interpret-text-func tlst glst))
                  (menu (if (deco? action) action #f)))
              (make-deco (make-deco '()
                                    :background (make-color 'transparent)
                                    :anchor(list (list pos 0 pos) (list 0.5 0 0.5)))
                         :property (list (cons 'menu menu)
                                         (cons 'action (if menu #f action))
                                         (cons 'eth-w (+ (car pad) (cadr pad) (car dim)))
                                         (cons 'eth-h (+ (caddr pad) (cadddr pad) (cadr dim))))
                         :behavior (make-behavior
                                    (eth-iclass-menu-behavior bfunc tfunc label)
                                    (on (opening)
                                        (bfunc deco)
                                        (tfunc label deco))
                                    std-menu-item-behavior))))
          :separator-func
          (lambda ()
            (let ((h (quotient (cadr (font-dimensions font)) 2)))
              (make-deco :width 0
                         :height h
                         :background (make-color 'transparent)
                         :property (list (cons 'eth-w 0)
                                         (cons 'eth-h h)))))
          :font (lambda () (font-name font))
          :background (lambda () "white")
          :foreground (lambda () "black"))))

(define (eth-make-menu-context glst)
  (let ((ad (eth-lookup-type glst '__MENU_STYLE "DEFAULT"))
        (al (assoc '__MENU_STYLE glst)))
    (cond (ad
           (eth-interpret-menu-style ad glst))
          (al
           (eth-interpret-menu-style (cadr al) glst))
          (#t
           #f))))

(define eth-menu-cache '())

(define (eth-lookup-menu glst name)
  (let ((entry (assoc (cons glst name) eth-menu-cache)))
    (if (not entry)
        (let ((mlst (eth-lookup-type glst '__MENU name)))
          (set! entry (cons (cons glst name)
                            (and mlst (eth-interpret-menu mlst glst))))
          (set! eth-menu-cache (cons entry eth-menu-cache))))
    (cdr entry)))
         
(define (eth-interpret-menu lst glst)
  (let* ((stag (eth-assoc '__STYLE lst))
         (style (if stag (eth-lookup-type glst '__MENU_STYLE stag) #f))
         (mctx (if style
                   (eth-interpret-menu-style style glst)
                   default-menu-style))
         (items '())
         (menu #f))
    (while (not (null? lst))
      (cond ((eq? (caar lst) '__MENU_TITLE)
             (set! items (cons (cadar lst) items)))
            ((eq? (caar lst) '__MENU_ITEM)
             (let* ((a (eth-assoc-between '__MENU_ACTION lst '__MENU_ITEM '(__MENU_ITEM __SUMENU)))
                    (aa (if a (eth-lookup-action a glst) #f)))
               (if aa (set! items (cons (list (caddar lst)
                                              (lambda (d) (aa d #f)))
                                        items)))))
            ((eq? (caar lst) '__SUMENU)
             (let ((s (eth-lookup-type glst '__MENU (cadar lst))))
               (if s (set! items (cons (list (car (cdddar lst))
                                             (eth-interpret-menu s glst))
                                       items))))))
      (set! lst (cdr lst)))
    (apply construct-menu (cons mctx (reverse items)))))

(define (eth-wrap-button-actions beh pre post)
  (let ((bl (inspect-behavior beh)))
    (set! bl (map (lambda (ele)
                    (if (and (eq? (event-type (car ele)) 'Button)
                             (not (eventarc-behavior (cdr ele)))
                             (not (eventarc-steal-resend (cdr ele))))
                        (let ((event (eventarc-event (cdr ele)))
                              (action (eventarc-action (cdr ele))))
                          (on-event event
                                    (if (car action)
                                        (if pre
                                            (lambda (d e) (pre d) ((car action) d e))
                                            (car action))
                                        (if pre
                                            (lambda (d e) (pre d))
                                            (lambda (d e) #f)))
                                    (if (cdr action)
                                        (if post
                                            (lambda (d e) ((cdr action) d e) (post d))
                                            (cdr action))
                                        (if post
                                            (lambda (d e) (post d))
                                            (lambda (d e) #f)))))
                        (cdr ele)))
                  bl))
    (apply make-behavior bl)))

(define (eth-interpret-slideout-button lst glst)
  (let* ((path (string-append eth-load-path (cadar glst) "/"))
         (iclass (eth-assoc '__ICLASS lst))
         (aclass (eth-assoc '__ACLASS lst))
         (curname (eth-assoc '__CURSOR lst))
         (cur (if curname (eth-interpret-cursor (or (eth-lookup-type glst '__CURSOR curname) '()) glst) #f))
         (beh (if aclass (eth-interpret-aclass (or (eth-lookup-type glst '__ACLASS aclass) '()) glst) #f))
         (iclasslst (eth-lookup-type glst '__ICLASS iclass))
         (isz (eth-assoc '__USE_SIZE_OF_IMAGE lst)))
    (lambda ()
      (let* ((bgfunc (if iclasslst 
                         (eth-interpret-fixsize-background-func iclasslst path)
                         (lambda (d) #f)))
             (behavior (if beh
                           (make-behavior
                            (eth-wrap-button-actions beh #f
                                                     (lambda (d)
                                                       (if (deco-mapped? d)
                                                           (delete-window (top-deco d)))))
                            (eth-iclass-inner-behavior bgfunc #f))
                           (eth-iclass-inner-behavior bgfunc #f)))
             (prop (list (cons 'active #f)
                         (cons 'hilited #f)
                         (cons 'clicked #f))))
        (make-deco '()
                   :property prop
                   :cursor cur
                   :behavior behavior)))))

(define (eth-interpret-slideout lst glst)
  (let ((dir (eth-assoc '__SLIDE_DIRECTION lst))
        (buttons '()))
    (while (not (null? lst))
      (if (eq? (caar lst) '__BUTTON)
          (let ((blst (eth-lookup-type glst '__BUTTON (cadar lst))))
            (if blst
                (set! buttons (cons (eth-interpret-slideout-button blst glst)
                                    buttons)))))
      (set! lst (cdr lst)))
    (set! buttons (reverse! buttons))
    (lambda (d e)
      (let ((deco (get-property d 'slideout-deco)))
        (if (not deco)
            (begin
              (set! deco (apply make-deco
                                (append (map (lambda (f) (f)) buttons)
                                        (list :direction (if (memq dir '(__RIGHT __LEFT))
                                                             'horizontal
                                                             'vertical)
                                              :property (list (cons 'caller (top-deco d)))))))
              (set-property! d 'slideout-deco deco)
              (set-property! (top-deco d) 'slideouts
                             (cons deco (or (get-property (top-deco d) 'slideouts) '())))))
        (if (deco-mapped? deco)
            (delete-window deco)
            (let ((pos (cond ((eq? dir '__RIGHT)
                              (cons (+ (deco-x d) (deco-width d) (* (deco-borderwidth d) 2))
                                    (deco-y d)))
                             ((eq? dir '__LEFT)
                              (cons (- (deco-x d) (deco-width deco))
                                    (deco-y d)))
                             ((or (eq? dir '__TOP) (eq? dir '__UP))
                              (cons (deco-x d)
                                    (- (deco-y d) (deco-height deco))))
                             (#t
                              (cons (deco-x d)
                                    (+ (deco-y d) (deco-height d) (* (deco-borderwidth d) 2)))))))
              (place-menu deco (screen) (car pos) (cdr pos) :decoration (lambda (x) x))))))
    ))

(define (eth-interpret-cursor lst glst)
  (let ((path (string-append eth-load-path (cadar glst) "/"))
        (fg (or (eth-make-color (eth-assoc '__FG_COLOR lst)) (make-color "black")))
        (bg (or (eth-make-color (eth-assoc '__BG_COLOR lst)) (make-color "white")))
        (file (eth-assoc '__XBM_FILE lst))
        (id (eth-assoc '__NATIVE_ID lst)))
    (if file
        (make-cursor (string-append path file) (string-append path file ".mask") :foreground fg :background bg)
        (if id 
            (make-cursor id :foreground fg :background bg)
            #f))))

(define (eth-interpret-window-match lst glst subtag)
  (let ((ret (eth-assoc subtag lst))
        (funs '())
        (cf #f)
        (hwdone #f))
    (if ret
        (begin
          (set! lst (cdr lst))
          (while (not (null? lst))
                 (cond ((eq? (caar lst) '__HAS_NAME)
                        (let ((n (cadar lst)))
                          (set! funs (cons (lambda (w) (string=? (window-client-name w) (if (symbol? n) (symbol->string n) n)))
                                           funs))))
                       ((eq? (caar lst) '__HAS_TITLE)
                        (let ((n (cadar lst)))
                          (set! funs (cons (lambda (w) (string=? (window-name w) (if (symbol? n) (symbol->string n) n)))
                                           funs))))
                       ((eq? (caar lst) '__HAS_CLASS)
                        (let ((n (cadar lst)))
                          (set! funs (cons (lambda (w) (string=? (window-client-class w) (if (symbol? n) (symbol->string n) n)))
                                           funs))))
                       ((eq? (caar lst) '__IS_TRANSIENT)
                        (if (memq (cadar lst) '(__ON 1))
                            (set! funs (cons (lambda (w) (window-transient-for w)) funs))
                            (set! funs (cons (lambda (w) (not (window-transient-for w))) funs))))
                       ((eq? (caar lst) '__IS_SHAPED)
                        (if (memq (cadar lst) '(__ON 1))
                            (set! funs (cons (lambda (w) (window-client-shaped? w)) funs))
                            (set! funs (cons (lambda (w) (not (window-client-shaped? w))) funs))))
                       ((eq? (caar lst) '__IS_IN_WIDTH_RANGE)
                        (let ((r (cdar lst)))
                          (set! funs (cons (lambda (w)
                                             (and (>= (window-client-width w) (car r))
                                                  (<= (window-client-width w) (cadr r))))
                                           funs))))
                       ((eq? (caar lst) '__IS_IN_HEIGHT_RANGE)
                        (let ((r (cdar lst)))
                          (set! funs (cons (lambda (w)
                                             (and (>= (window-client-height w) (car r))
                                                  (<= (window-client-height w) (cadr r))))
                                           funs))))
                       ((and (not hwdone)
                             (or (eq? (caar lst) '__CANNOT_RESIZE_HORIZONTALLY)
                                 (eq? (caar lst) '__CANNOT_RESIZE_VERTICALLY)))
                        (set! hwdone #t)
                        (let ((fixw (eth-assoc '__CANNOT_RESIZE_HORIZONTALLY lst))
                              (fixh (eth-assoc '__CANNOT_RESIZE_VERTICALLY lst)))
                          (set! funs (cons (lambda (w)
                                             (let ((min (window-min-size w))
                                                   (max (window-max-size w)))
                                               (and (or (not fixw) 
                                                        (if (memq fixw '(__ON 1))
                                                            (= (car min) (car max))
                                                            (not (= (car min) (car max)))))
                                                    (or (not fixh)
                                                        (if (memq fixh '(__ON 1))
                                                            (= (cadr min) (cadr max))
                                                            (not (= (cadr min) (cadr max))))))))
                                           funs)))))
                 (set! lst (cdr lst)))
          (set! cf (cond ((= (length funs) 1) (car funs))
                         ((eq? funs '()) (lambda (w) #t))
                         (#t (lambda (w) (and-map (lambda (f) (f w)) funs)))))
          (cons cf ret))
        #f)))

(define (eth-make-window-func glst)
  (let ((res '())
        (def (eth-lookup-border 'DEFAULT glst)))
    (if def
        (set! res (list (cons (lambda (w) #t) def))))
    (eth-for-each-type glst '__MATCH_WINDOW
                       (lambda (l)
                         (let* ((m (eth-interpret-window-match l glst '__USE_BORDER))
                                (brd (if m (eth-lookup-border (cdr m) glst) #f)))
                           (if brd
                               (set! res (cons (cons (car m) brd)
                                               res))))))
    (lambda (w)
      (or-map (lambda (x)
                (if ((car x) w)
                    ((cdr x) w)
                    #f))
              res))))

(define (eth-default-icon-func glst)
  (lambda (win)
    (or (let ((iw (window-icon-window win)))
          (and iw
               (make-deco iw :background (make-color 'transparent) :behavior (make-behavior icon-behavior std-icon-behavior))))
        (let* ((file (eth-lookup-icon-pixmap (window-client-class win) glst))
               (pix (and file (load-image file))))
          (and pix (make-deco pix :background (make-color 'transparent) :behavior (make-behavior icon-behavior std-icon-behavior))))
        (simple-icon win))))

(define (eth-make-icon-func glst)
  (let ((res (list (cons (lambda (w) #t) (eth-default-icon-func glst)))))
    (eth-for-each-type glst '__MATCH_WINDOW
                       (lambda (l)
                         (let* ((m (eth-interpret-window-match l glst '__USE_ICON))
                                (icn (if m (eth-lookup-icon (cdr m) glst) #f)))
                           (if icn
                               (set! res (cons (cons (car m) icn)
                                               res))))))
    (lambda (w)
      (or-map (lambda (x)
                (if ((car x) w)
                    ((cdr x) w)
                    #f))
              res))))

;; ---------------------------------------------------------------------
;; Entry points

(define (etheme-window theme)
  (if (not (and (equal? theme eth-theme-name)
                (not (null? eth-global-list))))
      (set! eth-global-list (eth-parse-theme theme)))
  (eth-make-window-func eth-global-list))

(define (etheme-icon theme)
  (if (not (and (equal? theme eth-theme-name)
                (not (null? eth-global-list))))
      (set! eth-global-list (eth-parse-theme theme)))
  (eth-make-icon-func eth-global-list))

(define (etheme-menu-context theme)
  (if (not (and (equal? theme eth-theme-name)
                (not (null? eth-global-list))))
      (set! eth-global-list (eth-parse-theme theme)))
  (eth-make-menu-context eth-global-list))

(define (etheme-compile theme file)
  (let ((f (open-file file "w"))
        (lst (if (and (equal? theme eth-theme-name)
                      (not (null? eth-global-list)))
                 eth-global-list
                 (eth-parse-theme theme))))
    (simple-format f
                   ";; ~A --- Mimic the Enlightenment theme ~S
;;
;; This file was generated by etheme-compile.
;; It can either be used as a main profile (using the -f flag),
;; or loaded from the standard user profile (i.e. from gwmrc.scm).

(if (not (defined? 'gwm-loaded))
    (begin
      (define inhibit-gwmrc #t)
      (primitive-load-path \"gwm\"))
)

(require 'etheme-compile)
(require 'zoom-window \"zoom\")
(require 'virtual)

(if (defined? 'inhibit-gwmrc)
    (begin
      (require 'rooms)
      (require 'virtual-rooms)
      (require 'virtual-pan)
      (set! raise-on-resize #t)
      (set! raise-on-move #t)
      (set! virtual-rooms-xpos 5)
      (set! virtual-rooms-ypos 5)
      (set! virtual-fancy-colors '((#f #f \"lightgray\") (#t #f \"white\")))
      (set! virtual-background \"lightyellow\")
      (set! initial-rooms '(main other))
      (set! rooms-omit-list '(XLoad XClock XBiff Gwm))
      (set! virtual-horizontal-step (screen-width))
      (set! virtual-vertical-step (screen-height))
      (set! virtual-nailed-list '(XLoad XClock XBiff Gwm))
      (set! pan-on-enter #t)
      (set! pan-x-step virtual-horizontal-step)
      (set! pan-y-step virtual-vertical-step)
      (set! pan-delay 400)
      (set! pan-warp-wrapped #t)
      (define botrow-place (make-tiled-placement 5 -6 -1 -7 'horizontal))
      (set-icon-placement #t botrow-place)
))
    
(define eth-theme-name ~S)
(define eth-global-list '" (basename file) theme theme)
    (write lst f)
    (simple-format f ")

(define etheme-~A-window (eth-make-window-func eth-global-list))
(define etheme-~A-icon (eth-make-icon-func eth-global-list))
(define etheme-~A-menu-context (eth-make-menu-context eth-global-list))

(set-window #t etheme-~A-window)
(set-icon #t etheme-~A-icon)
(set! default-menu-style etheme-~A-menu-context)

(if (defined? 'inhibit-gwmrc)
    (begin
      (if (%search-load-path \"menurc\")
          (primitive-load-path \"menurc\")
          (primitive-load-path \"defaultmenurc\"))
      (undefine inhibit-gwmrc)))
"
                   theme theme theme theme theme theme)
    (close-port f)))

