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

Contents of /gtk-cffi/examples/ex4.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sun Oct 7 12:02:11 2012 UTC (18 months, 2 weeks ago) by rklochkov
Branch: MAIN
Changes since 1.3: +60 -54 lines
Fixed examples. Changed cell properties for tree-column to be set as :attributes
Fixed double init in g-value.
1 (asdf:oos 'asdf:load-op :gtk-cffi)
2 ;(declaim (optimize speed))
3 (defpackage #:test
4 (:use #:common-lisp #:gtk-cffi #:g-object-cffi))
5 (in-package #:test)
6
7 (defun main ()
8 (gtk-init)
9 (let ((window (make-instance 'window :width 400 :height 280))
10 (hpane (make-instance 'h-paned)))
11
12 (setf (gsignal window :destroy) :gtk-main-quit)
13
14 (let ((v-box (make-instance 'v-box)))
15 (add window v-box)
16
17 (let ((title (make-instance 'label :text "Use of GtkHPaned")))
18 (setf (font title) "Times New Roman Italic 10"
19 (color title) "#0000ff")
20 (setf (size-request title) '(-1 40))
21 (pack v-box title :expand nil))
22
23 (pack v-box (make-instance
24 'label :text "Click on the options on the left pane.")
25 :expand nil)
26 (pack v-box (make-instance 'label) :expand nil)
27 (pack v-box hpane :fill t :expand t))
28
29 (let ((left-pane (make-instance 'frame))
30 (v-box (make-instance 'v-box)))
31 (setf (shadow-type left-pane) :in)
32 (add left-pane v-box)
33 (pack v-box (make-instance 'label :text "Options:"))
34 (pack v-box (create-link "Show All"))
35 (pack v-box (create-link "Qty > 10"))
36 (pack v-box (create-link "Price < $10"))
37 (pack hpane left-pane))
38
39
40 (let ((right-pane (make-instance 'frame))
41 (data '(("row 0" "item 42" 2 3.1)
42 ("row 1" "item 36" 20 6.21)
43 ("row 2" "item 21" 8 9.36)
44 ("row 3" "item 10" 11 12.4)
45 ("row 4" "item 7" 5 15.5)
46 ("row 5" "item 4" 17 18.6)
47 ("row 6" "item 3" 20 21.73))))
48
49 (setf data (append data data))
50 (setf data (append data data))
51 (setf data (append data data))
52
53 (setf (shadow-type right-pane) :in)
54 (pack hpane right-pane :pane-type 2 :resize t)
55 (format t "parent of ~a is ~a~%" right-pane
56 (property right-pane :parent))
57 (display-table right-pane data))
58
59 (show window :all t)
60 (gtk-main)))
61
62 (defvar *model*)
63 (defvar *modelfilter1*)
64 (defvar *modelfilter2*)
65 (defvar *view*)
66
67 (defun display-table (container data)
68
69 (setf *model*
70 (make-instance 'list-store :columns
71 '(:string :string :long :double
72 :boolean :boolean ; filters
73 :string ; color
74 :string ; third column
75 )))
76
77 (setf *modelfilter1*
78 (make-instance 'tree-model-filter :model *model*))
79 (setf (visible-column *modelfilter1*) 4)
80
81 (setf *modelfilter2*
82 (make-instance 'tree-model-filter :model *model*))
83 (setf (visible-column *modelfilter2*) 5)
84
85 (setf *view*
86 (make-instance 'tree-view :model *model*))
87
88 (let ((scrolled-win (make-instance 'scrolled-window)))
89 (setf (policy scrolled-win) '(:automatic :automatic))
90 (add container scrolled-win)
91 (add scrolled-win *view*))
92
93 (let ((field-header '("Row #" "Description" "Qty" "Price"))
94 (field-justification '(0.0 0.0 .5 1.0)))
95 (loop :for col :from 0 :below (length field-header) :do
96 (let ((cell-renderer (make-instance 'cell-renderer-text)))
97 (setf (property cell-renderer :xalign)
98 (float (nth col field-justification)))
99 (let ((column (make-instance 'tree-view-column
100 :title (nth col field-header)
101 :cell cell-renderer
102 :attributes
103 (list
104 "text" (if (= col 3) 7 col)
105 :cell-background 6))))
106 (setf (alignment column) (nth col field-justification))
107 (setf (sort-column-id column) col)
108
109 (let ((label (make-instance 'label
110 :text (nth col field-header))))
111 (setf (font label) "Arial Bold")
112 (setf (color label) "#0000FF")
113 (setf (widget column) label)
114 (show label))
115 (if (/= col 0) (setf (reorderable column) t))
116 (setf (cell-data-func column cell-renderer :data col)
117 (cffi:callback format-col))
118
119 (append-column *view* column)))))
120 (setf (gsignal *model* :rows-reordered) (cffi:callback reorder))
121
122 (loop :for row :below (length data) :do
123 (let ((values (nth row data)))
124 (setf values (append values
125 (list (> (third values) 10)
126 (< (fourth values) 10)
127 (if (= (mod row 2) 1)
128 "#dddddd" "#ffffff")
129 (format nil "$~,2f" (fourth values)))))
130 (append-values *model* values)))
131 (format t "Num rows: ~a~%" (iter-n-children *model* nil))
132 (let ((selection (selection *view*)))
133 ;(setf (mode selection) :multiple)
134 (format t "mode: ~a~%" (mode selection))
135 ;(format t "read mode: ~a~%" (gtk-cffi::gtk-tree-selection-get-mode selection))
136 (setf (gsignal selection :changed) (cffi:callback on-selection))
137 ;(format t "signals selection: ~a~%" (signals selection))
138 (format t "signals selection2: ~a~%" (gsignal selection :changed))
139 ;(setf (gsignal selection :changed) nil)
140 ;(format t "signals deleted: ~a~%" (gsignals selection))
141 ;(set-signal (get-selection *view*) :changed (cffi:callback on-selection))
142 ))
143
144 (defparameter *create-link-i* 0)
145 (defun create-link (str)
146 (let ((event-box (make-instance 'event-box))
147 (label (make-instance 'label
148 :text (format nil " ~a. ~a "
149 (setf *create-link-i*
150 (+ 1 *create-link-i*))
151 str))))
152 (setf (color label) "#0000ff")
153 (let ((h-box (make-instance 'h-box)))
154 (pack h-box label)
155 (pack h-box (make-instance 'label) :fill t :expand t)
156 (add event-box h-box)
157 (setf (gsignal event-box
158 :button-press-event
159 :data str)
160 (cffi:callback link-clicked))
161 event-box)))
162
163 (cffi:defcallback format-col
164 :void ((column pobject) (cell pobject)
165 (model pobject) (iter-ptr :pointer)
166 (col-num pdata))
167 (declare (ignore column))
168 ;;(declare (optimize speed))
169 ;;(format t
170 ;; "~A ~A ~A ~A ~A~%" column cell model iter col-num)
171 (let* ((iter (make-instance 'tree-iter :pointer iter-ptr))
172 ;; (row-num (cffi:mem-aref
173 ;; (gtk-cffi::gtk-tree-path-get-indices
174 ;; (gtk-cffi::gtk-tree-model-get-path
175 ;; model iter)) :int 0)))
176
177 ;;(row-num (parse-integer (gtk-cffi::iter-string model iter))))
178 (row-num (aref (iter->path model iter) 0)))
179 ;; (format t "~a ~a ~a~%" row-num col-num cell-ptr)
180
181 ;;(format t "~a ~a ~a ~a ~a~%" column cell model iter col-num)
182 ;; (let ((vals (get-values model iter
183 ;; 3 :double
184 ;; 2 :long)))
185 ;; (format t "~a ~a ~a~%" cell col-num vals)
186 (if (= col-num 3)
187 (setf (property cell :text)
188 (format nil "$~,2f"
189 (car (model-values model
190 :tree-iter iter
191 :column 3)))))
192 ;; (if (and (= col-num 2) (> (cadr vals) 10))
193 ;; (p-set cell :visible nil)
194 ;; (p-set cell :visible t)))
195 (setf (property cell :cell-background)
196 (if (= (mod row-num 2) 1) "#dddddd" "#ffffff"))
197 (setf (property cell :alignment) :left)))
198
199
200 ;; (defun reformat-rows (model)
201 ;; (tree-model-foreach
202 ;; *model*
203 ;; (flet ((set-color (model path iter data)
204 ;; (let ((row-num (get-index path)))
205 ;; (setf (model-values model iter 6)
206 ;; (list (if (= (mod row-num 2) 1)
207 ;; "#dddddd" "#ffffff"))))))
208 ;; (if (typep model 'list-store) #'set-color
209 ;; (lambda (m path iter data)
210 ;; (with-parent-path p model path
211 ;; (when p (set-color m p iter data))))))))
212
213 (defun reformat-rows (model)
214 (foreach
215 model
216 (lambda (model path iter data)
217 (declare (ignore data))
218 (let ((row-num (aref path 0)))
219 (setf (model-values model :tree-iter iter :column 6)
220 (list (if (= (mod row-num 2) 1)
221 "#dddddd" "#ffffff")))))))
222
223
224 (cffi:defcallback reorder :void ((model-ptr pobject))
225 (reformat-rows model-ptr))
226
227 (cffi:defcallback link-clicked
228 :boolean ((widget :pointer)
229 (event :pointer)
230 (str pdata))
231 (declare (ignore widget event))
232 (let ((model (cond
233 ((string= str "Show All") *model*)
234 ((string= str "Qty > 10") *modelfilter1*)
235 ((string= str "Price < $10")
236 *modelfilter2*))))
237 (format t "link clicked: ~a~%" str)
238 (when model
239 (setf (model *view*) model)
240 (reformat-rows model)
241 (setf (property *view* :headers-clickable)
242 (typep model 'list-store)))))
243
244
245 (cffi:defcallback on-selection
246 :void ((selection pobject)
247 (data-ptr :pointer))
248 (declare (ignore data-ptr))
249 (multiple-value-bind (tree-iter model) (selected selection)
250 (when tree-iter
251 (format
252 t "You have selected ~a~%"
253 (model-values model
254 :tree-iter tree-iter
255 :columns '(1 2 7))))))
256
257 (main)

  ViewVC Help
Powered by ViewVC 1.1.5