/[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.5 - (hide annotations)
Sat Dec 31 17:20:56 2011 UTC (2 years, 3 months ago) by rklochkov
Branch: MAIN
Changes since 1.4: +1 -1 lines
Moved addons to gtk-cffi-ext
1 rklochkov 1.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 rklochkov 1.3 (hide (gethash (car module) *apps*))))
27 rklochkov 1.1 *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 rklochkov 1.2 (declare (ignore widget event))
35 rklochkov 1.1 (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 rklochkov 1.5 (when (eq (gdk-cffi:parse-event event :keyval) (gdk-cffi:key :f12))
45 rklochkov 1.1 (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 rklochkov 1.4 (setf (color button :type :bg :state x) "#95DDFF"))
68 rklochkov 1.1 '(: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 rklochkov 1.3 (setf (window-position dialog) :center-always)
82 rklochkov 1.1 (setf (size-request dialog) (second module))
83     ;(setf (property dialog :content-area-border) 10)
84 rklochkov 1.3 (let ((top-area (content-area dialog)))
85 rklochkov 1.1 (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 rklochkov 1.3 ;(setf (has-separator dialog) nil)
101 rklochkov 1.1 (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 rklochkov 1.2 (show main-dialog :all t)
118 rklochkov 1.1 (run main-dialog)
119     (format t "here end~%")
120     (destroy main-dialog))
121    
122 rklochkov 1.2 ;; Cleanup after dialog
123     (g-object-cffi::timeout-add :idle #'gtk-main-quit)
124     (gtk-main)
125    
126 rklochkov 1.1 ;(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