/[gtk-cffi]/gtk-cffi/examples/ex3-flash-button.lisp
ViewVC logotype

Contents of /gtk-cffi/examples/ex3-flash-button.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Mon Apr 25 19:16:08 2011 UTC (2 years, 11 months ago) by rklochkov
Branch: slavsoft
CVS Tags: initial
Changes since 1.1: +0 -0 lines

Initial release
1 (asdf:oos 'asdf:load-op :gtk-cffi)
2
3 (defpackage #:test-ex3
4 (:use #:common-lisp #:gtk-cffi #:g-lib-cffi))
5 (in-package #:test-ex3)
6
7 (gtk-init)
8
9 (defvar window)
10 (defvar title)
11 (defvar button)
12 (defvar v-box)
13 (defvar h-box)
14
15 (setf window (make-instance 'window))
16
17 (setf (gsignal window :destroy) :gtk-main-quit
18 (size-request window) '(400 150))
19
20 (add window (setf v-box (make-instance 'v-box)))
21
22 (setf title (make-instance 'label :text "Create a Flashing Button - Part 1"))
23
24
25 (setf (font title) "Times New Roman Italic 10"
26 (color title) "#0000ff"
27 (size-request title) '(-1 60))
28
29 (pack v-box title)
30 (pack v-box (setf h-box (make-instance 'h-box)))
31
32 (setf button (make-instance 'button :label "Click Me!"))
33 (setf (size-request button) '(80 32)
34 (color button :bg) "#FFCC66")
35
36 (defvar *TIMEOUT*)
37
38 (pack h-box button :expand t)
39 (setf (gsignal button :clicked)
40 (lambda (widget)
41 (declare (ignore widget))
42 (format t "You have clicked Click Me!~%")
43 (format t "~a~%" *TIMEOUT*)
44 (timeout-remove *TIMEOUT*)
45 (format t "We here ~%")))
46
47 (realize window)
48
49 (defparameter *ORG-BG* (color window :bg))
50
51 (let (i)
52 (defun flash (button bgcolor)
53 (setf (color button :bg) (if i *ORG-BG* bgcolor))
54 (setf i (not i)) t))
55
56 (setf *TIMEOUT* (timeout-add 200 #'flash :data (list button "#FFCC66")))
57
58 (format t "Set ~a~%" *TIMEOUT*)
59
60 (show window :all t)
61 (gtk-main)
62
63

  ViewVC Help
Powered by ViewVC 1.1.5