/[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.1.1.1 - (show annotations) (vendor branch)
Mon Apr 25 19:16:08 2011 UTC (2 years, 11 months ago) by rklochkov
Branch: slavsoft
CVS Tags: initial
Changes since 1.1: +0 -0 lines

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

  ViewVC Help
Powered by ViewVC 1.1.5