/[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 - (show 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 (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