/[mcclim]/mcclim/Doc/Guided-Tour/color-editor.lisp
ViewVC logotype

Contents of /mcclim/Doc/Guided-Tour/color-editor.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Mon Jan 30 16:14:01 2006 UTC (8 years, 2 months ago) by cfruhwirth
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-5, McCLIM-0-9-4, McCLIM-0-9-6, McCLIM-0-9-3, McCLIM-0-9-2, HEAD
Move docs/guided-tour to Doc/Guided-Tour.
Add line-breaks to guided-tour.tex.
1 cfruhwirth 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
2     (asdf:oos 'asdf:load-op :clim)
3     (asdf:oos 'asdf:load-op :clim-clx))
4    
5     (in-package :clim-user)
6    
7     (defun make-color-slider (id initval label)
8     (labelling (:label label)
9     (make-pane ':slider :id id :orientation :horizontal :value initval
10     :max-value 1 :min-value 0
11     :drag-callback #'color-slider-dragged
12     :value-changed-callback #'color-slider-value-changed)))
13    
14     (define-application-frame color-editor ()
15     (current-color-pane
16     drag-feedback-pane
17     (red :initform 0.0)
18     (green :initform 1.0)
19     (blue :initform 0.0))
20     (:pane (with-slots (drag-feedback-pane current-color-pane red green blue)
21     *application-frame*
22     (vertically ()
23     (setf current-color-pane
24     (make-pane 'application-pane :min-height 100 :max-height 100
25     :background (make-rgb-color red green blue)))
26     (horizontally (:min-height 200 :max-height 200)
27     (1/2 (make-color-slider 'red red "Red"))
28     (1/4 (make-color-slider 'green green "Green"))
29     (1/4 (make-color-slider 'blue blue "Blue")))
30     +fill+
31     (setf drag-feedback-pane
32     (make-pane 'application-pane :min-height 100 :max-height 100
33     :background (make-rgb-color red green blue))))))
34     (:menu-bar t))
35    
36     (defun color-slider-dragged (slider value)
37     (with-slots (drag-feedback-pane red green blue) *application-frame*
38     (setf (medium-background drag-feedback-pane)
39     (ecase (gadget-id slider)
40     (red (make-rgb-color value green blue))
41     (green (make-rgb-color red value blue))
42     (blue (make-rgb-color red green value))))
43     (redisplay-frame-pane *application-frame* drag-feedback-pane)))
44    
45     (defun color-slider-value-changed (slider new-value)
46     (with-slots (current-color-pane red green blue) *application-frame*
47     ;; The gadget-id symbols match the slot names in color-editor
48     (setf (slot-value *application-frame* (gadget-id slider)) new-value)
49     (setf (medium-background current-color-pane)
50     (make-rgb-color red green blue))
51     (redisplay-frame-pane *application-frame* current-color-pane)))
52    
53     (define-color-editor-command (com-quit :name "Quit" :menu t) ()
54     (frame-exit *application-frame*))

  ViewVC Help
Powered by ViewVC 1.1.5