File: make-theme.jl

package info (click to toggle)
sawfish 1%3A1.3.5.2-2
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 11,636 kB
  • ctags: 1,327
  • sloc: lisp: 22,765; ansic: 15,810; sh: 10,203; makefile: 675; perl: 19
file content (101 lines) | stat: -rw-r--r-- 3,136 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
;; make-theme.jl -- support for theme builder
;; $Id: make-theme.jl,v 1.8 2000/11/27 18:17:21 jsh Exp $

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

;; This file is part of sawmill.

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

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

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

(define-structure sawfish.wm.theming.make-theme

    (export make-theme)

    (open rep
	  rep.regexp
	  sawfish.wm.images
	  sawfish.wm.colors
	  sawfish.wm.fonts
	  sawfish.wm.gaol)

  (define-structure-alias make-theme sawfish.wm.theming.make-theme)

  (define (make-frames patterns-alist frame-alist)
    (let ((image-cache '()))
      
      (define (make-image file)
	(or (cdr (assoc file image-cache))
	    (let
		((img (gaol-eval `(make-image ',file))))
	      (setq image-cache (cons (cons file img) image-cache))
	      img)))

      (define (make-pattern def)
	(mapcar (lambda (elt)
		  (let ((state (car elt))
			(value (cdr elt)))
		    (cond ((stringp value)
			   (setq value (get-color value)))
			  ((and (consp value) (stringp (car value)))
			   (let
			       ((img (make-image (car value))))
			     (when img
			       (mapc (lambda (attr)
				       (cond
					((eq (car attr) 'tiled)
					 (image-put img 'tiled (cdr attr)))
					((eq (car attr) 'border)
					 (apply set-image-border
						img (cdr attr)))))
				     (cdr value)))
			     (setq value img))))
		    (cons state value))) def))

      (let ((loaded-patterns (mapcar (lambda (cell)
				       (cons (car cell)
					     (make-pattern (cdr cell))))
				     patterns-alist)))
	    
	(define (make-frame-part def)
	  (mapcar (lambda (cell)
		    (cons (car cell)
			  (cond ((and (eq (car cell) 'text)
				      (symbolp (cdr cell)))
				 (gaol-eval (cdr cell)))
				((and (memq (car cell)
					    '(foreground background))
				      (stringp (cdr cell)))
				 (if (string-match "^#" (cdr cell))
				     ;; color
				     (get-color (cdr cell))
				   (cdr (assoc (cdr cell) loaded-patterns))))
				((and (eq (car cell) 'font)
				      (stringp (cdr cell)))
				 (get-font (cdr cell)))
				(t
				 (cdr cell))))) def))

	(mapcar (lambda (cell)
		  (cons (car cell) (mapcar make-frame-part (cdr cell))))
		frame-alist))))
			      
  (define (make-theme patterns-alist frame-alist mapping-alist)
    (let ((real-frames (make-frames patterns-alist frame-alist)))
      (lambda (w type)
	(declare (unused w))
	(let ((frame-name (or (cdr (assq type mapping-alist)))))
	  (and frame-name (cdr (assoc frame-name real-frames)))))))

  (gaol-define 'make-theme make-theme))