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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Sun Jul 29 15:13:59 2012 UTC (20 months, 2 weeks ago) by rklochkov
Branch: MAIN
Changes since 1.6: +9 -5 lines
Fixed memory leaks
1 (proclaim '(optimize debug))
2 (asdf:oos 'asdf:load-op :gtk-cffi)
3 (defpackage #:ex7
4 (:use #:common-lisp #:gtk-cffi #:g-object-cffi))
5 (in-package #:ex7)
6
7 (defvar *window*)
8 (defvar *cell-pix*)
9
10 (defun main ()
11 (declare (optimize debug safety))
12 (gtk-init)
13 ;; (rc-parse-string "style \"my\" {
14 ;; GtkTreeView::even-row-color = \"#E7EDF6\"
15 ;; GtkTreeView::odd-row-color = \"#FBFBFB\"
16 ;; }
17 ;; widget \"*\" style \"my\"")
18
19 (let ((window (make-instance 'window :width 400 :height 280)))
20 (setf (gsignal window :destroy) :gtk-main-quit)
21 (setf *window* window)
22
23 (let ((v-box (make-instance 'v-box))
24 (data '(("01-01-08" "Some event")
25 ("10-02-08" "Another event withe very long description.
26 Description of this event. And this description is very long")
27 ("15-02-08" "Чуть-чуть напишем по-русски"))))
28 (add window v-box)
29
30 (let ((title (make-instance 'label :text "Use of GtkCellEditable")))
31 (setf (font title) "Times New Roman Italic 12"
32 (color title) "#0000ff"
33 (color title :type :bg) "#ff0000")
34 ;(setf (size-request title) '(-1 40))
35 (pack v-box title))
36
37 (let* ((model (make-instance 'list-store :columns
38 '(:string :string)))
39 (frame (make-instance 'frame))
40 (view (make-instance 'tree-view :model model)))
41 (setf (color view :state :selected) "#ff0000")
42 (pack v-box frame :pack-fill nil :expand t)
43 (pack v-box (make-instance 'label) :pack-fill t :expand t)
44 (add frame view)
45 (let ((field-header '("Date" "Event")))
46 (loop :for col :from 0 :below (length field-header) :do
47 (let* ((cell-renderer (make-instance 'cell-renderer-text))
48 (column (make-instance 'tree-view-column
49 :title (nth col field-header);""
50 :cell cell-renderer
51 :text col)))
52 (let ((label (make-instance 'label
53 :text (nth col field-header))))
54 (setf (font label) "Arial")
55 ;(setf (color label) "#666666")
56 (setf (widget column) label) (show label))
57
58 (when (= col 1)
59 (setf (property cell-renderer :editable) t)
60 (setf *cell-pix* (make-instance 'cell-renderer-pixbuf))
61 (pack column *cell-pix*)
62 (setf (property *cell-pix* :pixbuf)
63 (make-instance 'gdk-cffi:pixbuf
64 :file "list.png")))
65
66 (setf (gsignal cell-renderer :edited)
67 (let ((%col col))
68 (lambda (cell path new-text)
69 (declare (ignore cell))
70 (format t "path: ~a new-text:~a~%" path new-text)
71 (path->iter model path)
72 (setf (model-values model :col %col)
73 (list new-text)))))
74
75 (append-column view column))))
76
77 (setf
78 (gsignal view :button-press-event)
79 (lambda (view event)
80 (when (and (eq (gdk-cffi:get-slot event :type) :button-press)
81 (= (the integer (gdk-cffi:get-slot event :button)) 1))
82 (on-click view
83 (path-at-pos view
84 (round (gdk-cffi:get-slot event :x))
85 (round (gdk-cffi:get-slot event :y))))))
86 (gsignal view :cursor-changed)
87 (lambda (view)
88 (set-bold view (second (get-cursor view)))))
89
90 (setf (property view :enable-grid-lines) :both
91 (property view :rules-hint) t)
92 (loop :for row :below (length data) :do
93 (let ((values (nth row data)))
94 (append-values model values)))))
95 (show window :all t)
96 (gtk-main)))
97
98 (defun set-bold (view column)
99 (format t "set ~A~%" column)
100 (loop :for col :in (columns view)
101 :for i :from 0 :to (length (columns view))
102 :do (progn
103 (setf (font (widget col))
104 (if (equal col column)
105 "Arial Bold" "Arial"))
106 (when (equal (column view i) column)
107 (setf (search-column view) i)))))
108
109 (defun on-click (view path-list)
110 (format t "on-click: ~a~%" path-list)
111 (when path-list
112 (destructuring-bind (path column x y) path-list
113 (declare (ignore y))
114 (let ((cell (get-cell-at column x)))
115 (format t "cell: ~A~%" cell)
116 (when (equal cell *cell-pix*)
117 (let ((dialog (make-instance 'dialog :title "Edit text"
118 :parent *window*
119 :buttons '((:gtk-ok :ok)
120 (:gtk-cancel :cancel)))))
121 (let ((text-view (make-instance 'text-view))
122 (iter (path->iter (model view) path)))
123 (setf (text (buffer text-view))
124 (car (model-values (model view) :columns '(1)
125 :tree-iter iter)))
126 (let ((top-area (content-area dialog)))
127 (pack top-area text-view :pack-fill t :expand t)
128 (show text-view))
129 (setf (position-type dialog) :center-on-parent)
130
131 ;(pack top-area text-view :fill t :expand t))
132 (run dialog)
133 (setf (model-values (model view) :columns '(1) :tree-iter iter)
134 (list (text (buffer text-view))))
135 (destroy dialog))))))))
136
137 (main)
138
139
140

  ViewVC Help
Powered by ViewVC 1.1.5