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

  ViewVC Help
Powered by ViewVC 1.1.5