/[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 - (hide annotations)
Mon Apr 25 19:16:08 2011 UTC (2 years, 11 months ago) by rklochkov
Branch: MAIN
Branch point for: slavsoft
Initial revision
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     (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