/[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 - (hide annotations)
Sun Oct 7 12:02:11 2012 UTC (18 months, 1 week 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 rklochkov 1.1 (asdf:oos 'asdf:load-op :gtk-cffi)
2 rklochkov 1.2 ;(declaim (optimize speed))
3 rklochkov 1.1 (defpackage #:test
4 rklochkov 1.2 (:use #:common-lisp #:gtk-cffi #:g-object-cffi))
5 rklochkov 1.1 (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 rklochkov 1.3
12 rklochkov 1.1 (setf (gsignal window :destroy) :gtk-main-quit)
13 rklochkov 1.3
14 rklochkov 1.1 (let ((v-box (make-instance 'v-box)))
15     (add window v-box)
16 rklochkov 1.3
17 rklochkov 1.1 (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 rklochkov 1.2 (pack v-box title :expand nil))
22 rklochkov 1.3
23 rklochkov 1.1 (pack v-box (make-instance
24 rklochkov 1.3 'label :text "Click on the options on the left pane.")
25 rklochkov 1.2 :expand nil)
26     (pack v-box (make-instance 'label) :expand nil)
27 rklochkov 1.1 (pack v-box hpane :fill t :expand t))
28 rklochkov 1.3
29 rklochkov 1.1 (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 rklochkov 1.3
39    
40 rklochkov 1.1 (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 rklochkov 1.3
49 rklochkov 1.1 (setf data (append data data))
50     (setf data (append data data))
51     (setf data (append data data))
52 rklochkov 1.3
53 rklochkov 1.1 (setf (shadow-type right-pane) :in)
54 rklochkov 1.2 (pack hpane right-pane :pane-type 2 :resize t)
55 rklochkov 1.1 (format t "parent of ~a is ~a~%" right-pane
56     (property right-pane :parent))
57     (display-table right-pane data))
58 rklochkov 1.3
59 rklochkov 1.1 (show window :all t)
60     (gtk-main)))
61    
62 rklochkov 1.2 (defvar *model*)
63     (defvar *modelfilter1*)
64     (defvar *modelfilter2*)
65     (defvar *view*)
66    
67 rklochkov 1.1 (defun display-table (container data)
68    
69 rklochkov 1.2 (setf *model*
70 rklochkov 1.1 (make-instance 'list-store :columns
71     '(:string :string :long :double
72     :boolean :boolean ; filters
73     :string ; color
74     :string ; third column
75     )))
76    
77 rklochkov 1.2 (setf *modelfilter1*
78 rklochkov 1.1 (make-instance 'tree-model-filter :model *model*))
79     (setf (visible-column *modelfilter1*) 4)
80    
81 rklochkov 1.2 (setf *modelfilter2*
82 rklochkov 1.1 (make-instance 'tree-model-filter :model *model*))
83     (setf (visible-column *modelfilter2*) 5)
84    
85 rklochkov 1.2 (setf *view*
86 rklochkov 1.1 (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 rklochkov 1.4 (field-justification '(0.0 0.0 .5 1.0)))
95 rklochkov 1.1 (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 rklochkov 1.4 :attributes
103     (list
104     "text" (if (= col 3) 7 col)
105     :cell-background 6))))
106 rklochkov 1.1 (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 rklochkov 1.3 (setf (cell-data-func column cell-renderer :data col)
117 rklochkov 1.2 (cffi:callback format-col))
118 rklochkov 1.1
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 rklochkov 1.2 (append-values *model* values)))
131 rklochkov 1.4 (format t "Num rows: ~a~%" (iter-n-children *model* nil))
132     (let ((selection (selection *view*)))
133     ;(setf (mode selection) :multiple)
134 rklochkov 1.1 (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 rklochkov 1.2 ;(format t "signals deleted: ~a~%" (gsignals selection))
141 rklochkov 1.1 ;(set-signal (get-selection *view*) :changed (cffi:callback on-selection))
142     ))
143    
144 rklochkov 1.2 (defparameter *create-link-i* 0)
145 rklochkov 1.1 (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 rklochkov 1.4 :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 rklochkov 1.1
177 rklochkov 1.4 ;;(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 rklochkov 1.1
181 rklochkov 1.4 ;;(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 rklochkov 1.1
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 rklochkov 1.4 (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 rklochkov 1.1
223    
224 rklochkov 1.2 (cffi:defcallback reorder :void ((model-ptr pobject))
225     (reformat-rows model-ptr))
226 rklochkov 1.1
227     (cffi:defcallback link-clicked
228 rklochkov 1.2 :boolean ((widget :pointer)
229     (event :pointer)
230     (str pdata))
231 rklochkov 1.4 (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 rklochkov 1.2 (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 rklochkov 1.1
245     (cffi:defcallback on-selection
246 rklochkov 1.4 :void ((selection pobject)
247 rklochkov 1.2 (data-ptr :pointer))
248 rklochkov 1.4 (declare (ignore data-ptr))
249     (multiple-value-bind (tree-iter model) (selected selection)
250     (when tree-iter
251 rklochkov 1.2 (format
252     t "You have selected ~a~%"
253 rklochkov 1.4 (model-values model
254     :tree-iter tree-iter
255 rklochkov 1.2 :columns '(1 2 7))))))
256 rklochkov 1.1
257 rklochkov 1.2 (main)

  ViewVC Help
Powered by ViewVC 1.1.5