/[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.4 - (show annotations)
Sat Sep 10 16:26:10 2011 UTC (2 years, 7 months ago) by rklochkov
Branch: MAIN
Changes since 1.3: +2 -3 lines
Some refactoring. Now we can use (show #(1 2 3)) or (show '(1 2 3)) to lookup
through the sequence in GTK list view
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*))))
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 event))
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 (eq (gdk-cffi:parse-event event :keyval) :f12)
45 (format t "~a~%" module)
46 (if (string= module "main")
47 (destroy (gethash "main" *apps*))
48 (progn
49 (hide (gethash module *apps*))
50 (show (gethash "main" *apps*) :all t)
51 (run (gethash "main" *apps*))))))
52
53
54
55
56 (defun show-buttons (v-box cur-module)
57 (let ((h-box (make-instance 'h-box)))
58 (pack v-box h-box)
59 (pack h-box (make-instance 'label) :fill t :expand t)
60 (mapcar (lambda (module)
61 (let ((button
62 (make-instance 'button
63 :label (string-capitalize (car module)))))
64 (setf (size-request button) '(80 32))
65 (when (string= (car module) cur-module)
66 (mapcar (lambda (x)
67 (setf (color button :type :bg :state x) "#95DDFF"))
68 '(:normal :active :prelight)))
69 (pack h-box button)
70 (pack h-box (make-instance 'label) :fill t :expand t)
71 (setf (gsignal button :clicked
72 :data (cffi:convert-to-foreign
73 (car module) 'gtk-string))
74 (cffi:callback clicked))))
75 *mods*)))
76
77
78
79 (defun setup-app (module)
80 (let ((dialog (make-instance 'dialog :title (car module) :flags :modal)))
81 (setf (window-position dialog) :center-always)
82 (setf (size-request dialog) (second module))
83 ;(setf (property dialog :content-area-border) 10)
84 (let ((top-area (content-area dialog)))
85 (flet ((print-out (str)
86 (pack top-area (make-instance 'label
87 :text str)
88 :fill t :expand t)))
89 (mapcar #'print-out
90 (if (string= (car module) "main")
91 '("this is main menu" "Press F12 to quit")
92 (cons (format nil
93 "This is ~a module"
94 (car module))
95 '("Press F12 to return to main menu"
96 "or just close the window")))))
97 (pack top-area
98 (make-instance 'label) :fill t :expand t)
99 (show-buttons top-area (car module)))
100 ;(setf (has-separator dialog) nil)
101 (setf (gsignal dialog :delete-event
102 :data (cffi:convert-to-foreign (car module) 'gtk-string))
103 (cffi:callback on-delete)
104 (gsignal dialog :key-press-event
105 :data (cffi:convert-to-foreign (car module) 'gtk-string))
106 (cffi:callback on-key))
107 dialog))
108
109
110
111
112 (mapcar (lambda (module)
113 (setf (gethash (car module) *apps*)
114 (setup-app module))) *mods*)
115
116 (let ((main-dialog (gethash "main" *apps*)))
117 (show main-dialog :all t)
118 (run main-dialog)
119 (format t "here end~%")
120 (destroy main-dialog))
121
122 ;; Cleanup after dialog
123 (g-object-cffi::timeout-add :idle #'gtk-main-quit)
124 (gtk-main)
125
126 ;(setf window (make-instance 'window))
127
128 ;(set-border-width window 6)
129
130 ;;(modify-bg window :normal "#B2D2DE")
131
132 ;(modify-bg-pixmap window :normal "/usr/share/pixmaps/gqview.png")
133
134 ;(cffi:defcfun "gtk_rc_parse_string" :void (str :gtk-string))
135
136 ;(gtk-rc-parse-string "style \"my-style\" {
137 ; bg_pixmap[NORMAL] = \"gqview.png\"
138 ;}")
139
140 ;(set-signal window "destroy" (cffi:foreign-symbol-pointer "gtk_main_quit"))
141
142 ;(setf v-box (make-instance 'v-box))
143
144 ;(setf label
145 ; (make-instance 'label :text "this is centered"))
146
147 ;(set-alignment label 0.5 0)
148
149 ;(pack v-box label :start)
150
151 ;(show-all window)
152

  ViewVC Help
Powered by ViewVC 1.1.5