File: color-preview.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 (66 lines) | stat: -rw-r--r-- 2,289 bytes parent folder | download | duplicates (4)
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
#| nokogiri-color-preview.jl -- color previews

   $Id: color-preview.jl,v 1.4 2003/01/12 20:30:43 jsh Exp $

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

   This file is part of sawfish.

   sawfish 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.

   sawfish 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 sawfish; see the file COPYING.  If not, write to
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|#

(define-structure sawfish.gtk.color-preview

    (export button-new-with-color
	    set-button-color)

    (open rep
	  gui.gtk-2.gtk)

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

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

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

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