/[gtk-cffi]/gtk-cffi/examples/ex2.lisp
ViewVC logotype

Contents of /gtk-cffi/examples/ex2.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-ex2
4 (:use #:common-lisp #:gtk-cffi #:cffi-object #:g-object-cffi))
5
6 (in-package :test-ex2)
7
8 (gtk-init)
9
10 (defparameter *apps* (make-hash-table :test 'equal))
11
12 (defparameter *mods* '(("main" (400 200))
13 ("sales" (600 400))
14 ("purchase" (400 100))
15 ("inventory" (720 640))
16 ("finance" (480 360))))
17
18 (cffi:defcallback clicked
19 :void ((widget :pointer) (activated-module gtk-string))
20 (declare (ignore widget))
21 (declare (ignorable widget))
22 (format t "button_clicked: ~a~%" activated-module)
23 (show (gethash activated-module *apps*) :all t)
24 (mapcar (lambda (module)
25 (unless (string= activated-module (car module))
26 (hide (gethash (car module) *apps*) :all t)))
27 *mods*)
28 (run (gethash activated-module *apps*)))
29
30
31 (cffi:defcallback on-delete :boolean ((widget :pointer)
32 (event :pointer)
33 (module gtk-string))
34 (declare (ignore widget))
35 (unless (string= module "main")
36 (hide (gethash module *apps*))
37 (show (gethash "main" *apps*) :all t)
38 (run (gethash "main" *apps*)) t))
39
40 (cffi:defcallback on-key :boolean ((widget :pointer)
41 (event :pointer)
42 (module gtk-string))
43 (declare (ignore widget))
44 (when (equal (gdk-cffi:parse-event event :keyval)
45 (gdk-cffi:key :f12))
46 (format t "~a~%" module)
47 (if (string= module "main")
48 (destroy (gethash "main" *apps*))
49 (progn
50 (hide (gethash module *apps*))
51 (show (gethash "main" *apps*) :all t)
52 (run (gethash "main" *apps*))))))
53
54
55
56
57 (defun show-buttons (v-box cur-module)
58 (let ((h-box (make-instance 'h-box)))
59 (pack v-box h-box)
60 (pack h-box (make-instance 'label) :fill t :expand t)
61 (mapcar (lambda (module)
62 (let ((button
63 (make-instance 'button
64 :label (string-capitalize (car module)))))
65 (setf (size-request button) '(80 32))
66 (when (string= (car module) cur-module)
67 (mapcar (lambda (x)
68 (setf (color button :bg x) "#95DDFF"))
69 '(:normal :active :prelight)))
70 (pack h-box button)
71 (pack h-box (make-instance 'label) :fill t :expand t)
72 (setf (gsignal button :clicked
73 :data (cffi:convert-to-foreign
74 (car module) 'gtk-string))
75 (cffi:callback clicked))))
76 *mods*)))
77
78
79
80 (defun setup-app (module)
81 (let ((dialog (make-instance 'dialog :title (car module) :flags :modal)))
82 (setf (win-position dialog) :center-always)
83 (setf (size-request dialog) (second module))
84 ;(setf (property dialog :content-area-border) 10)
85 (let ((top-area (v-box dialog)))
86 (flet ((print-out (str)
87 (pack top-area (make-instance 'label
88 :text str)
89 :fill t :expand t)))
90 (mapcar #'print-out
91 (if (string= (car module) "main")
92 '("this is main menu" "Press F12 to quit")
93 (cons (format nil
94 "This is ~a module"
95 (car module))
96 '("Press F12 to return to main menu"
97 "or just close the window")))))
98 (pack top-area
99 (make-instance 'label) :fill t :expand t)
100 (show-buttons top-area (car module)))
101 (setf (has-separator dialog) nil)
102 (setf (gsignal dialog :delete-event
103 :data (cffi:convert-to-foreign (car module) 'gtk-string))
104 (cffi:callback on-delete)
105 (gsignal dialog :key-press-event
106 :data (cffi:convert-to-foreign (car module) 'gtk-string))
107 (cffi:callback on-key))
108 dialog))
109
110
111
112
113 (mapcar (lambda (module)
114 (setf (gethash (car module) *apps*)
115 (setup-app module))) *mods*)
116
117 (let ((main-dialog (gethash "main" *apps*)))
118 ;(show main-dialog :all t)
119 (run main-dialog)
120 (format t "here end~%")
121 (destroy main-dialog))
122
123 ;(setf window (make-instance 'window))
124
125 ;(set-border-width window 6)
126
127 ;;(modify-bg window :normal "#B2D2DE")
128
129 ;(modify-bg-pixmap window :normal "/usr/share/pixmaps/gqview.png")
130
131 ;(cffi:defcfun "gtk_rc_parse_string" :void (str :gtk-string))
132
133 ;(gtk-rc-parse-string "style \"my-style\" {
134 ; bg_pixmap[NORMAL] = \"gqview.png\"
135 ;}")
136
137 ;(set-signal window "destroy" (cffi:foreign-symbol-pointer "gtk_main_quit"))
138
139 ;(setf v-box (make-instance 'v-box))
140
141 ;(setf label
142 ; (make-instance 'label :text "this is centered"))
143
144 ;(set-alignment label 0.5 0)
145
146 ;(pack v-box label :start)
147
148 ;(show-all window)
149

  ViewVC Help
Powered by ViewVC 1.1.5