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

  ViewVC Help
Powered by ViewVC 1.1.5