sawfish-themes 0.13 / usr / share / sawfish / themes / Derivative / theme.jl

#| Klarth sawfish theme, written in -*-lisp-*-

Copyright (C) 2001-2002 Kenny Graunke

This program 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 of the
License, or (at your option) any later version.

This program 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 this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

$Id: theme.jl,v 1.7 2001/08/21 19:44:46 kenny Exp $

Authors: Kenny Graunke <kenny@whitecape.org>

|#

(require 'gradient)
(require 'rep.data.tables)		;need hash tables for icon cache
(require 'sawfish.wm.util.recolor-image)
(require 'sawfish.wm.util.gtkrc)

(defgroup Derivative "Derivative Theme"
          :group appearance)

(defvar Derivative:button-themes
  '((default
      ((iconify-button maximize-button) . (close-button)))
    (limit
      ((close-button) . (shade-button iconify-button maximize-button)))
    (platinum
     ((close-button) . (maximize-button shade-button)))
    (macos-x
     ((close-button iconify-button maximize-button)))
    (windows
     ((menu-button) . (iconify-button maximize-button close-button)))
    (next
     ((iconify-button) . (close-button)))))

(defcustom Derivative:button-theme 'default
           "Display title buttons to mimic: \\w"
  ;; XXX it would be better if the choices were extracted from
  ;; XXX the above alist somehow
           :type (choice (default "Default")
			 (limit "Limit")
                         (platinum "Mac OS 8/9")
                         (macos-x "Mac OS X")
                         (windows "MS Windows")
                         (next "NeXTSTEP"))
           :group (appearance Derivative)
           :after-set (lambda () (reframe-all)))
;; FIXME: Why is this a lambda? Can't it just be reframe-all?
;; ...because reframe-all is defined below. no other reason. :-)
;; I suppose I could fix this, if I really wanted to

;; maps WINDOW -> BUTTON-LIST
(define button-table (make-weak-table eq-hash eq))

;; new frame part classes (thanks to Greg Merchan)
(def-frame-class mover-grip ()
  (bind-keys mover-grip-keymap "Button1-Move" 'move-window-interactively))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;; Derivative Image & Color Functions

;; klarth-image-height : image -> Int:0-Inf
(define (klarth-image-height img)
  (cdr (image-dimensions img)))

;; klarth-image-width : image -> Int:0-Inf
(define (klarth-image-width img)
  (car (image-dimensions img)))

(define transparent-image (make-image "transparent-image.png"))
;; klarth-make-transparent-sized-image : Int Int -> image
(define (klarth-make-transparent-sized-image width height)
  (scale-image transparent-image width height))

;; klarth-rgb-to-hsv : (list num num num [num]) -> (list num num num)
(define (klarth-rgb-to-hsv rgb)
  (let* ((r (divide (nth 0 rgb) 255.))
         (g (divide (nth 1 rgb) 255.))
         (b (divide (nth 2 rgb) 255.))
         (maxim (max r g b))
	 (delta (- maxim (min r g b))))
    
    (cond
     ((= max 0) (list 0 0 maxim))
     ((= delta 0) (list -1 0 maxim))
     (t (list (let ((h (* 60 (cond
			      ((= r maxim) (divide (- g b) delta))
			      ((= g maxim) (+ 2 (divide (- b r) delta)))
			      (t (+ 4 (divide (- r g) delta)))))))
		(if (< h 0) (+ h 360) h))
	      (divide delta maxim) maxim)))))

;; klarth-hsv-to-rgb : (list num num num) -> (list num num num)
(define (klarth-hsv-to-rgb hsv)
  (let ((h (divide (nth 0 hsv) 60.)) (s (nth 1 hsv)) (v (nth 2 hsv)))
    (if (= s 0) (mapcar (lambda (n) (klarth-round (* 255 n))) (list v v v))
      (let* ((i (floor h))
	     (f (- h i))
	     (p (* v (- 1 s)))
	     (q (* v (- 1 (* s f))))
	     (t (* v (- 1 (* s (- 1 f))))))
	(mapcar (lambda (n) (klarth-round (* 255 n)))
		(cond
		 ((= i 0) (list v t p))
		 ((= i 1) (list q v p))
		 ((= i 2) (list p v t))
		 ((= i 3) (list p q v))
		 ((= i 4) (list t p v))
		 (t (list v p q))))))))

;; klarth-value-composite-image-on-color : img color -> img
(define (klarth-value-composite-image-on-color img color)
  (let* ((w (klarth-image-width img))
	 (h (klarth-image-height img))
	 (crgb (klarth-color-rgb color))
	 (chsv (klarth-rgb-to-hsv crgb))
	 (ch (nth 0 chsv))
	 (cs (nth 1 chsv))
	 (cv (nth 2 chsv))
	 (out (make-sized-image w h color)))
    (do ((y 0 (1+ y)))
        ((> y (1- h)) y)
      (do ((x 0 (1+ x)))
          ((> x (1- w)) x)
        (unless (= (nth 3 (image-ref img x y)) 0)
	  (let* ((orgb (image-ref img x y))
		 (ohsv (klarth-rgb-to-hsv orgb))
		 (aval (divide (nth 3 orgb) 255))
		 (avg (lambda (n)
			(+ (* (- 1 aval) (nth n chsv))
			   (* aval (nth n ohsv))))))
	    (image-set out x y (append (klarth-hsv-to-rgb
					(list (nth 0 chsv) (nth 1 chsv)
					      (avg 2)))
				       (list 255)))))))
    out))

;; klarth-vn-composite-to-bg image image color -> image
(define (klarth-vn-composite-to-bg vimg nimg col)
  (klarth-composite-images
   (klarth-value-composite-image-on-color vimg col) nimg 0 0))

;; klarth-composite-images : image image x y -> image
;; Composites the second image on top of the first one starting at (x,y)
;; (the origin being at the upper left corner of the first image), returns it
(define (klarth-composite-images bottom top x y)
  (define tmp (copy-image bottom))
  (composite-images tmp top x y)
  tmp)

;; klarth-color-rgb : color -> '(Int:0-255 Int:0-255 Int:0-255 Int:0-255)
(define (klarth-color-rgb color)
  (mapcar (lambda (x) (klarth-round (divide x 257.))) (color-rgb color)))

;;;; Colors

;; klarth-modify-color : string Int -> string
(define (klarth-modify-color cstr change)
  (define (modify-single rgorb ch)
    (max 0 (min 65535 (round (* rgorb ch)))))
  (let* ((rgb (color-rgb (get-color cstr)))
         (r (nth 0 rgb))
         (g (nth 1 rgb))
         (b (nth 2 rgb)))
    (color-name (get-color-rgb (modify-single r change)
			       (modify-single g change)
			       (modify-single b change)))))

;; klarth-get-gtk-color : num {gtkrc-foreground/background} string -> string
(define (klarth-get-gtk-color num gtkcols default)
  (if (colorp (nth num gtkcols)) (color-name (nth num gtkcols)) default))

;; klarth-gtk-bg-color : symbol -> string
(define (klarth-gtk-bg-color state)
  (cond
   ((eq state 'selected) (klarth-get-gtk-color 3 gtkrc-background "black"))
   ((eq state 'normal) (klarth-get-gtk-color 0 gtkrc-background "grey50"))))

;; klarth-gtk-fg-color : symbol -> string
(define (klarth-gtk-fg-color state)
  (cond
   ((eq state 'selected) (klarth-get-gtk-color 3 gtkrc-foreground "white"))
   ((eq state 'normal) (klarth-get-gtk-color 0 gtkrc-foreground "black"))))

(define klarth-focused-bg-color nil)
(define klarth-focused-bg-light-color nil)
(define klarth-focused-bg-dark-color nil)
(define klarth-unfocused-bg-color nil)
(define klarth-focused-fg-color nil)
(define klarth-unfocused-fg-color nil)
(define klarth-focused-border-color nil)
(define klarth-unfocused-border-color nil)

(define (klarth-update-colors)
  (setq klarth-focused-bg-color (klarth-gtk-bg-color 'selected))
  (setq klarth-focused-bg-light-color
	(klarth-modify-color klarth-focused-bg-color 135/100))
  (setq klarth-focused-bg-dark-color
	(klarth-modify-color klarth-focused-bg-color 45/100))
  (setq klarth-unfocused-bg-color (klarth-gtk-bg-color 'normal))
  
  (setq klarth-focused-fg-color (klarth-gtk-fg-color 'selected))
  (setq klarth-unfocused-fg-color (klarth-gtk-fg-color 'normal))
  
  ;; FIXME: do darken/lighten based on color (and if black), ok?
  (setq klarth-focused-border-color (get-color "black"))
  (setq klarth-unfocused-border-color (get-color "grey15")))
;; Initialize them.
(klarth-update-colors)

(define (klarth-bg-colors)
  (list klarth-unfocused-bg-color klarth-focused-bg-color))
(define (klarth-fg-colors)
  (list klarth-unfocused-fg-color klarth-focused-fg-color))
(define (klarth-border-colors)
  (list klarth-unfocused-border-color klarth-focused-border-color))
(define (klarth-light-bevel-colors)
  (list klarth-unfocused-bg-color klarth-focused-bg-light-color))
(define (klarth-dark-bevel-colors)
  (list klarth-unfocused-bg-color klarth-focused-bg-dark-color))

;; klarth-scale-image-to-height : image Int:0-Inf -> image
;; Returns the image scaled to the height but preserving the same aspect ratio.
(define (klarth-scale-image-to-height img height)
  (let* ((original-height (klarth-image-height img))
         (original-width (klarth-image-width img))
         (ratio (divide original-width original-height)))
    (scale-image img (round (* ratio height)) height)))

(define klarth-generic-window-icon (make-image "apple-red.png"))

;; klarth-window-icon: window -> image
;; Returns a scaled version of the window icon or a generic image if the window
;; doesn't have an icon.
(define (klarth-window-icon w)
  (let* ((wicon (window-icon-image w)))
    (klarth-scale-image-to-height (if wicon wicon klarth-generic-window-icon)
                                  (- (klarth-em klarth-titlearea-height) 4))))

;; klarth-greyscale-image : image -> image
;; Returns a greyscale version of an image.
(define (klarth-greyscale-image img)
  (let* ((tmp (copy-image img)))
    (image-map (lambda (pixval)
                 (let* ((r (nth 0 pixval))
                        (g (nth 1 pixval))
                        (b (nth 2 pixval))
                        (a (nth 3 pixval))
                        (avg (/ (+ r g b) 3)))
                   (list avg avg avg a)))
               tmp)
    tmp))

;; FIXME: Yes, I've stupidly added alpha-mod here, which doesn't belong
;; klarth-recolor-to : image string num -> image
(define (klarth-recolor-to img col alpha-mod)
  (let* ((tmp (copy-image img))
         (crgb (color-rgb (get-color col)))
         (cr (nth 0 crgb))
         (cg (nth 1 crgb))
         (cb (nth 2 crgb))
         (recolorer (lambda (pixval)
                      (let* ((r (nth 0 pixval))
                             (g (nth 1 pixval))
                             (b (nth 2 pixval))
                             (a (nth 3 pixval)))
                        (if (> a 0)
                            (list cr cg cb (klarth-round (* a alpha-mod)))
			    (list r g b (klarth-round (* a alpha-mod))))))))
    (image-map recolorer tmp)
    tmp))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;; Derivative Geometry Computations

;; klarth-window-width : window -> Int:0-Inf
(define (klarth-window-width w)
  (car (window-dimensions w)))

;; klarth-window-height : window -> Int:0-Inf
(define (klarth-window-height w)
  (cdr (window-dimensions w)))

;; klarth-titlebar-center : window -> Int
(define (klarth-titlebar-center w)
  (/ (klarth-window-width w) 2))

;; these are specified in EM!
(define klarth-titlearea-height 1.2)
(define klarth-resizer-height 0.5)
(define klarth-corner-width 1.8)

(define (klarth-corner-pwidth w)
  (min (klarth-em 1.8) (/ (klarth-window-width w) 3)))

;; klarth-left-buttonbox-width : window -> Int
(define (klarth-left-buttonbox-width w)
  (let ((nbuttons (length (car (table-ref button-table w)))))
    (+ 1 (* nbuttons klarth-titlearea-height) nbuttons)))

;; We SETQ values later, as we add buttons. :-/
(define klarth-left-buttons-width 0)
(define klarth-right-buttons-width 0)

;; klarth-titletext-x-justify : window -> Int
(define (klarth-titletext-x-justify w)
  (+ (klarth-image-width (klarth-window-icon w))
     klarth-left-buttons-width (klarth-em 0.3)))

;; klarth-titletext : window -> string
(define (klarth-titletext w)
  (let* ((tt (window-name w))
	 (ttw (text-width tt))
	 (av (- (klarth-window-width w)
;	       (* 2 (max 2 (klarth-em 0.3))) ;; FIXME_42: defined const this.
	       ; ^^^ unnecessary? I think it may be included in point already,
	       ; and hence already in k-l/r-b-w
;	       klarth-left-buttons-width
;	       why bother? just use the x-justify. :-D
		(klarth-titletext-x-justify w)
		klarth-right-buttons-width)))
    ;; FIXME
    (if () ;(> ttw av) 
	(concat (substring tt 0 (- (length tt)
				   (max 0 (/ (- ttw av (text-width "..."))
					     (klarth-em 0.2)))))
		"...")
        tt)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;; Derivative Utility Functions

;; klarth-window-maximized-both-p : window -> boolean
(define (klarth-window-maximized-both-p w)
  (and (window-maximized-horizontally-p w) (window-maximized-vertically-p w)))

;; klarth-window-resizable-p : window -> boolean
(define (klarth-window-resizable-p w)
  (let* ((size-hints (window-size-hints w))
	 (max-width-item (assoc 'max-width size-hints))
	 (min-width-item (assoc 'min-width size-hints)))
    (not (and max-width-item min-width-item
	      (= (cdr max-width-item) (cdr min-width-item))))))

;; klarth-round : number -> integer
(define (klarth-round x)
  (inexact->exact (round x)))

;; klarth-em : number -> integer
(define (klarth-em n)
  (klarth-round (* n (font-height default-font))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;; The Messy Stuff

;; bgparts & such

;; I wish I didn't have to keep all this around, but I have no choice.
;; sawfish removes the theme directory from the image path later, so when
;; I need to refresh the images due to a gtk+ theme change, they have to be
;; around.
(define close-v (make-image "close-v.png"))
(define close-n (make-image "close-n.png"))
(define min-v (make-image "min-v.png"))
(define min-n (make-image "min-n.png"))
(define max-v (make-image "max-v.png"))
(define max-n (make-image "max-n.png"))
(define umax-v (make-image "umax-v.png"))
(define umax-n (make-image "umax-n.png"))
(define shade-v (make-image "shade-v.png"))
(define shade-n (make-image "shade-n.png"))
(define menu-v (make-image "menu-v.png"))
(define menu-n (make-image "menu-n.png"))

;; make-button-bgpart : string string -> bgpart
(define (make-button-bgpart nimg vimg)
;  (let ((khei (- (klarth-em klarth-titlearea-height) 4)))
    (list (klarth-vn-composite-to-bg
	   (klarth-recolor-to vimg klarth-unfocused-fg-color 0.5)
	   (klarth-recolor-to nimg klarth-unfocused-fg-color 0.3)
	   ;; FIXME: and just chop the blasted alpha channel in half, don't
	   ;; do all this weighting stuff!
	   ;; FIXME: only recolor-to once, save resources...
	   ;; can't recolor-to the VN, because it has no alpha
	   ;(klarth-scale-image-to-height vimg khei)
	   ;(klarth-scale-image-to-height nimg khei)
	   (get-color klarth-unfocused-bg-color))
	  (klarth-vn-composite-to-bg
	   vimg nimg
	   ;(klarth-scale-image-to-height vimg khei)
	   ;(klarth-scale-image-to-height nimg khei)
	   (get-color klarth-focused-bg-color))
	  (klarth-composite-images
	   (klarth-composite-images
	    (make-sized-image (klarth-image-width nimg)
			      (klarth-image-height nimg)
			      (get-color klarth-focused-bg-color))
	    vimg 0 0) nimg 0 0)
));)

;	  (klarth-vn-composite-to-bg
;	   (klarth-composite-images vimg vimg 0 0) nimg
;	   ;(klarth-scale-image-to-height vimg khei)
;	   ;(klarth-scale-image-to-height nimg khei)
;	   (get-color klarth-focused-bg-color))

;(klarth-vn-composite-to-bg
;      (klarth-scale-image-to-height vimg khei)
;      (klarth-scale-image-to-height nimg khei)
;      (get-color klarth-focused-bg-color))

(define close-bgpart nil)
(define minimize-bgpart nil)
(define maximize-bgpart nil)
(define unmaximize-bgpart nil)
(define shade-bgpart nil)
(define menu-bgpart nil)

(define (klarth-update-bgparts)
  (setq close-bgpart      (make-button-bgpart close-n close-v))
  (setq minimize-bgpart   (make-button-bgpart min-n min-v))
  (setq maximize-bgpart   (make-button-bgpart max-n max-v))
  (setq unmaximize-bgpart (make-button-bgpart umax-n umax-v))
  (setq shade-bgpart      (make-button-bgpart shade-n shade-v))
  (setq menu-bgpart       (make-button-bgpart min-n min-v)))
(klarth-update-bgparts)

;; window icons

(define icon-table (make-weak-table eq-hash eq))

;; frames
(define common-frame-parts
  `(((background . ,klarth-border-colors)
     (left-edge . -1)
     (top-edge . ,(lambda () (- -2 (klarth-em klarth-titlearea-height))))

     (right-edge . -1)
     (height . ,(lambda () (+ 2 (klarth-em klarth-titlearea-height))))
     (class . title))

    ((background . ,klarth-bg-colors)
     (foreground . ,klarth-fg-colors)
     (left-edge . 0)
     (right-edge . 0)
     (top-edge . ,(lambda () (- -1 (klarth-em klarth-titlearea-height))))
     (height . ,(lambda () (klarth-em klarth-titlearea-height)))
;     (text . ,(lambda (w) (klarth-titletext w)))
     (text . ,window-name)
     (x-justify . ,klarth-titletext-x-justify)
     (y-justify . center)
     (class . title))

    ((background . ,(lambda (w)
		      (let* ((wicon (klarth-window-icon w)))
			(list (klarth-composite-images
			       (make-sized-image
				(klarth-image-width wicon)
				(klarth-image-height wicon)
				(get-color klarth-unfocused-bg-color))
			       (klarth-greyscale-image wicon) 0 0)
			      (klarth-composite-images
			       (make-sized-image
				(klarth-image-width wicon)
				(klarth-image-height wicon)
				(get-color klarth-focused-bg-color))
			       wicon 0 0)))))
     (left-edge . ,(lambda () klarth-left-buttons-width))
     (top-edge . ,(lambda () (- 1 (klarth-em klarth-titlearea-height))))
     (class . title))

    ;; bevels

    ((background . ,klarth-light-bevel-colors)
     (left-edge . 0)
     (right-edge . 0)
     (top-edge . ,(lambda () (- -1 (klarth-em klarth-titlearea-height))))
     (height . 1)
     (class . title))
    ((background . ,klarth-light-bevel-colors)
     (left-edge . 0)
     (top-edge . ,(lambda () (- -1 (klarth-em klarth-titlearea-height))))
     (height . ,(lambda () (klarth-em klarth-titlearea-height)))
     (width . 1)
     (class . title))
    ((background . ,klarth-dark-bevel-colors)
     (left-edge . 1)
     (right-edge . 0)
     (top-edge . -2)
     (height . 1)
     (class . title))
    ((background . ,klarth-dark-bevel-colors)
     (right-edge . 0)
     (top-edge . ,(lambda () (- 0 (klarth-em klarth-titlearea-height))))
     (height . ,(lambda () (- (klarth-em klarth-titlearea-height) 1)))
     (width . 1)
     (class . title))
    ))

(define shaped-frame
  `(,@common-frame-parts
    ((background . ,klarth-border-colors)
     (top-edge . ,(lambda () (- 0 (klarth-em klarth-titlearea-height))))
     (right-edge . -2)
     (height . ,(lambda () (klarth-em klarth-titlearea-height)))
     (width . 2)
     (class . mover-grip))
    
    ((background . ,klarth-border-colors)
     (top-edge . 0)
     (left-edge . 2)
     (right-edge . -2)
     (height . 1)
     (class . mover-grip))
    ))

(define non-resizable-frame
  `(,@common-frame-parts

    ((background . ,klarth-border-colors)
     (top-edge . 0)
     (bottom-edge . 0)
     (left-edge . -1)
     (width . 1)
     (class . mover-grip))

    ((background . ,klarth-border-colors)
     (top-edge . ,(lambda () (- 0 (klarth-em klarth-titlearea-height))))
     (bottom-edge . 0)
     (right-edge . -2)
     (width . 2)
     (class . mover-grip))

    ((background . ,klarth-border-colors)
     (bottom-edge . -1)
     (left-edge . -1)
     (right-edge . -2)
     (height . 1)
     (class . mover-grip))

    ((background . ,klarth-border-colors)
     (bottom-edge . -2)
     (left-edge . 2)
     (right-edge . -2)
     (height . 1)
     (class . mover-grip))
    ))

(define resizable-frame
  `(,@non-resizable-frame
    ((background . ,klarth-border-colors)
     (left-edge . ,klarth-corner-pwidth)
     (right-edge . ,klarth-corner-pwidth)
     (bottom-edge . ,(lambda () (- -1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (+ (klarth-em klarth-resizer-height) 1)))
     (class . bottom-border))

    ((background . ,klarth-bg-colors)
     (left-edge . ,klarth-corner-pwidth)
     (right-edge . ,klarth-corner-pwidth)
     (bottom-edge . ,(lambda () (- 1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (- (klarth-em klarth-resizer-height) 2)))
     (class . bottom-border))

    ((background . ,klarth-light-bevel-colors)
     (left-edge . ,(lambda (w) (+ 1 (klarth-corner-pwidth w))))
     (right-edge . ,(lambda (w) (+ 1 (klarth-corner-pwidth w))))
     (bottom-edge . -2)
     (height . 1)
     (class . bottom-border))

    ((background . ,(lambda () (list klarth-unfocused-border-color
		      klarth-focused-bg-light-color)))
     (left-edge . ,klarth-corner-pwidth)
;     (left-edge . ,(lambda () (klarth-em klarth-corner-width)))
     (bottom-edge . ,(lambda () (- 1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (- (klarth-em klarth-resizer-height) 2)))
     (width . 1)
     (class . bottom-border))

    ((background . ,(lambda () (list klarth-unfocused-border-color
		      klarth-focused-bg-dark-color)))
;     (right-edge . ,(lambda () (klarth-em klarth-corner-width)))
     (right-edge . ,klarth-corner-pwidth)
     (bottom-edge . ,(lambda () (- 1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (- (klarth-em klarth-resizer-height) 2)))
     (width . 1)
     (class . bottom-border))

    ;; FIXME
    ((background . ,(lambda () (list klarth-unfocused-border-color
		      klarth-focused-bg-light-color)))
     (right-edge . ,klarth-corner-pwidth)
;     (right-edge . ,(lambda () (klarth-em klarth-corner-width)))
     (bottom-edge . -2)
     (height . 1)
     (width . 1)
     (class . bottom-border))

    ((background . ,klarth-border-colors)
     (right-edge . -2)
     (bottom-edge . ,(lambda () (- -1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (+ (klarth-em klarth-resizer-height) 1)))
;     (width . ,(lambda () (+ (klarth-em klarth-corner-width) 2)))
     (width . ,(lambda (w) (+ 2 (klarth-corner-pwidth w))))
     (class . bottom-right-corner))

    ((background . ,klarth-bg-colors)
     (right-edge . 0)
     (bottom-edge . ,(lambda () (- 1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (- (klarth-em klarth-resizer-height) 2)))
     (width . ,klarth-corner-pwidth)
;     (width . ,(lambda () (klarth-em klarth-corner-width)))
     (class . bottom-right-corner))

    ((background . ,klarth-light-bevel-colors)
     (right-edge . 0)
     (bottom-edge . -2)
     (height . 1)
     (width . ,klarth-corner-pwidth)
;     (width . ,(lambda () (klarth-em klarth-corner-width)))
     (class . bottom-right-corner))

    ((background . ,klarth-light-bevel-colors)
     (right-edge . ,(lambda (w) (- (klarth-corner-pwidth w) 1)))
     (bottom-edge . ,(lambda () (- 1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (- (klarth-em klarth-resizer-height) 2)))
     (width . 1)
     (class . bottom-right-corner))

    ((background . ,klarth-border-colors)
     (left-edge . -1)
     (bottom-edge . ,(lambda () (- 0 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (klarth-em klarth-resizer-height)))
     (width . ,(lambda (w) (+ 1 (klarth-corner-pwidth w))))
     (class . bottom-left-corner))

    ((background . ,klarth-border-colors)
     (left-edge . 2)
     (bottom-edge . ,(lambda () (- -1 (klarth-em klarth-resizer-height))))
     (height . 1)
     (width . ,(lambda (w) (- (klarth-corner-pwidth w) 2)))
     (class . bottom-left-corner))

    ((background . ,klarth-bg-colors)
     (left-edge . 0)
     (bottom-edge . ,(lambda () (- 1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (- (klarth-em klarth-resizer-height) 2)))
     (width . ,klarth-corner-pwidth)
     (class . bottom-left-corner))

    ((background . ,klarth-light-bevel-colors)
     (left-edge . 0)
     (bottom-edge . -2)
     (height . 1)
     (width . ,klarth-corner-pwidth)
     (class . bottom-left-corner))

    ((background . ,klarth-dark-bevel-colors)
     (left-edge . ,(lambda (w) (- (klarth-corner-pwidth w) 1)))
     (bottom-edge . ,(lambda () (- 1 (klarth-em klarth-resizer-height))))
     (height . ,(lambda () (- (klarth-em klarth-resizer-height) 3)))
     (width . 1)
     (class . bottom-left-corner))
    ))

;; packing buttons

(define button-map
  `((iconify-button . (,(image-dimensions min-v) ,(lambda () minimize-bgpart)))
    (maximize-button . (,(image-dimensions max-v)
			,(lambda (w) (if (window-maximized-p w)
					 unmaximize-bgpart maximize-bgpart))))
    (close-button . (,(image-dimensions close-v) ,(lambda () close-bgpart)))
    (menu-button . (,(image-dimensions menu-v) ,(lambda () menu-bgpart)))
;; This works, but requires window-get to not be gaol'ed - arggh
;    (shade-button . ,(lambda (w)
;		       (if (window-get w 'shaded) shade-bgpart unshade-bgpart)))
    (shade-button . (,(image-dimensions shade-v) ,(lambda () shade-bgpart)))
    ))

;; klarth-remove-unnecessary-buttons : (something like vvv) -> 
;; '((close-button) maximize-button iconify-button)
(define (klarth-remove-unnecessary-buttons dual-buttons w)
  ;; FIXME: can't let* lambda here, since it won't be able to call itself
  (define (helper buttons)
    ;; this is just a '(foo bar), so it's empty or a symbol (button name).
    (cond
     ((null buttons) ())
     ((not (eq (car buttons) 'maximize-button))
      (cons (car buttons) (helper (cdr buttons))))
     ((klarth-window-resizable-p w)
      (cons 'maximize-button (helper (cdr buttons))))
     (t (helper (cdr buttons)))))
  (cons (helper (car dual-buttons)) (helper (cdr dual-buttons))))
  
(define (button-theme w)
  (klarth-remove-unnecessary-buttons
   (car (cdr (or (assq Derivative:button-theme Derivative:button-themes)
		 (assq 'default Derivative:button-themes)))) w))

(define (make-buttons spec colored edge resizable)
  (define (make-button class height bg point)
    `((background . ,bg)
      (,edge . ,point)
      (top-edge . ,(lambda () (+ (/ (- (klarth-em klarth-titlearea-height)
				       height) 2)
				 (- 0 (klarth-em klarth-titlearea-height)))))
      (class . ,class)))

  (do ((rest spec (cdr rest))
       (point (max 2 (klarth-em 0.3)) ;; FIXME_42: make this a defined const
	      (+ point (max 1 (klarth-em 0.3))
		 (car (cadr (assq (car rest) button-map)))))
       (out '() (cons (make-button (car rest)
;    (shade-button . (,(image-dimensions shade-v) ,(lambda () shade-bgpart))) 				   
				   (cdr (cadr (assq (car rest) button-map)))
				   (car (cddr (assq (car rest) button-map)))
				   point)
		      out)))
      ((null rest) (if (eq edge 'left-edge)
		       (setq klarth-left-buttons-width point)
		       (setq klarth-right-buttons-width point))
     out)))


;; misc stuff

(define (reframe-all)
  (klarth-update-colors)
  (klarth-update-bgparts)
  (reframe-windows-with-style 'Derivative))
(gtkrc-call-after-changed reframe-all)

(define (make-frame w frame buttons)
  (let ((resizable (klarth-window-resizable-p w)))
    (table-set button-table w buttons)
    (append frame
	    (make-buttons (car buttons) t 'left-edge resizable)
	    (make-buttons (reverse (cdr buttons)) () 'right-edge resizable))))

(define (get-frame w type)  
  (make-frame w (if (or (eq type 'default) (eq type 'transient))
		    (if (klarth-window-resizable-p w)
			resizable-frame
		        non-resizable-frame)
		  shaped-frame)
	      (button-theme w)))

;; register the theme
(add-frame-style 'Derivative get-frame)

;; recalibrate frames when the window-name changes
(call-after-property-changed 'WM_NAME rebuild-frame)