1;; Copyright (C) 2004 Patrick Bernaud
2;; GNU General Public License version 2 or later. No warrantee.
3
4(define-module (demos tree-store)
5  :use-module (oop goops)
6  :use-module (gnome gobject)
7  :use-module (gnome gtk))
8
9
10(define january
11  '(("New Years Day" #t #t #t #t #f #t)
12    ("Presidential Inauguration" #f #t #f #t #f #f)
13    ("Martin Luther King Jr. day" #f #t #f #t #f #f)))
14
15(define february
16  '(("Presidents' Day" #f #t #f #t #f #f)
17    ("Groundhog Day" #f #f #f #f #f #f)
18    ("Valentine's Day" #f #f #f #f #t #t)))
19
20(define march
21  '(("National Tree Planting Day" #f #f #f #f #f #f)
22    ("St Patrick's Day" #f #f #f #f #f #t)))
23
24(define april
25  '(("April Fools' Day" #f #f #f #f #f #t)
26    ("Army Day" #f #f #f #f #f #f)
27    ("Earth Day" #f #f #f #f #f #t)
28    ("Administrative Professionals' Day" #f #f #f #f #f #f)))
29
30(define may
31  '(("Nurses' Day" #f #f #f #f #f #f)
32    ("National Day of Prayer" #f #f #f #f #f #f)
33    ("Mothers' Day" #f #f #f #f #f #t)
34    ("Armed Forces Day" #f #f #f #f #f #f)
35    ("Memorial Day" #t #t #t #t #f #t)))
36
37(define june
38  '(("June Fathers' Day" #f #f #f #f #f #t)
39    ("Juneteenth (Liberation of Slaves)" #f #f #f #f #f #f)
40    ("Flag Day" #f #t #f #t #f #f)))
41
42(define july
43  '(("Parents' Day" #f #f #f #f #f #t)
44    ("Independence Day" #f #t #f #t #f #f)))
45
46(define august
47  '(("Air Force Day" #f #f #f #f #f #f)
48    ("Coast Guard Day" #f #f #f #f #f #f)
49    ("Friendship Day" #f #f #f #f #f #f)))
50
51(define september
52  '(("Grandparents' Day" #f #f #f #f #f #t)
53    ("Citizenship Day or Constitution Day" #f #f #f #f #f #f)
54    ("Labor Day" #t #t #t #t #f #t)))
55
56(define october
57  '(("National Children's Day" #f #f #f #f #f #f)
58    ("Bosses' Day" #f #f #f #f #f #f)
59    ("Sweetest Day" #f #f #f #f #f #f)
60    ("Mother-in-Law's Day" #f #f #f #f #f #f)
61    ("Navy Day" #f #f #f #f #f #f)
62    ("Columbus Day" #f #t #f #t #f #f)
63    ("Halloween" #f #f #f #f #f #t)))
64
65(define november
66  '(("Marine Corps Day" #f #f #f #f #f #f)
67    ("Veterans' Day" #t #t #t #t #f #t)
68    ("Thanksgiving" #f #t #f #t #f #f)))
69
70(define december
71  '(("Pearl Harbor Remembrance Day" #f #f #f #f #f #f)
72    ("Christmas" #t #t #t #t #f #t)
73    ("Kwanzaa" #f #f #f #f #f #f)))
74
75(define toplevel
76  `(("January"   ,january)
77    ("February"  ,february)
78    ("March"     ,march)
79    ("April"     ,april)
80    ("May"       ,may)
81    ("June"      ,june)
82    ("July"      ,july)
83    ("August"    ,august)
84    ("September" ,september)
85    ("October"   ,october)
86    ("November"  ,november)
87    ("December"  ,december)))
88
89
90(define holiday-name-column 0)
91(define alex-column    1)
92(define havoc-column   2)
93(define tim-column     3)
94(define owen-column    4)
95(define dave-column    5)
96(define visible-column 6)
97(define world-column   7)
98
99
100(define (create-model)
101  (let (
102	; create tree store
103	(model (gtk-tree-store-new (list <gchararray>
104					 <gboolean>
105					 <gboolean>
106					 <gboolean>
107					 <gboolean>
108					 <gboolean>
109					 <gboolean>
110					 <gboolean>))))
111    (for-each
112     (lambda (m)
113       (let ((iter (append model (make <gtk-tree-iter>))))
114	 (set-value model iter holiday-name-column (car m))
115	 (for-each (lambda (c)
116		     (set-value model iter c #f))
117		   (list alex-column havoc-column tim-column owen-column
118			 dave-column visible-column world-column))
119	 (for-each
120	  (lambda (h)
121	    (let ((iter (append model iter)))
122	      (for-each
123	       (lambda (c i)
124		 (set-value model iter i c))
125	       h (list holiday-name-column alex-column havoc-column
126		       tim-column owen-column dave-column world-column))
127	      (set-value model iter visible-column #t)))
128	  (cadr m))))
129     toplevel)
130
131    model))
132
133(define (item-toggled treemodel pathstr column)
134  (let* (
135	 ;; get toggled iter
136	 (iter   (get-iter treemodel pathstr))
137	 ;; get current value and invert
138	 (toggle (not (get-value treemodel iter column))))
139    ;; set the new value
140    (set-value treemodel iter column toggle)))
141
142(define (add-columns treeview)
143  (let ((model (get-model treeview))
144	;; column for holiday names
145	(renderer1 (make <gtk-cell-renderer-text>
146		     :xalign 0))
147	(column1   (make <gtk-tree-view-column>
148		     :title "Holliday"
149		     ;; set this column to a fixed sizing (of 50 pixels)
150		     :clickable #t))
151	;; alex column
152	(renderer2 (make <gtk-cell-renderer-toggle>
153		     :xalign 0))
154	(column2   (make <gtk-tree-view-column>
155		     :title "Alex"
156		     :sizing 'fixed
157		     :fixed-width 50
158		     :clickable #t))
159	;; havoc column
160	(renderer3 (make <gtk-cell-renderer-toggle>
161		     :xalign 0))
162	(column3   (make <gtk-tree-view-column>
163		     :title "Havoc"
164		     :sizing 'fixed
165		     :fixed-width 50
166		     :clickable #t))
167	;; tim column
168	(renderer4 (make <gtk-cell-renderer-toggle>
169		     :xalign 0))
170	(column4   (make <gtk-tree-view-column>
171		     :title "Tim"
172		     :sizing 'fixed
173		     :fixed-width 50
174		     :clickable #t))
175	;; owen column
176	(renderer5 (make <gtk-cell-renderer-toggle>
177		     :xalign 0))
178	(column5   (make <gtk-tree-view-column>
179		     :title "Owen"
180		     :sizing 'fixed
181		     :fixed-width 50
182		     :clickable #t))
183	;; dave column
184	(renderer6 (make <gtk-cell-renderer-toggle>
185		     :xalign 0))
186	(column6   (make <gtk-tree-view-column>
187		     :title "Dave"
188		     :sizing 'fixed
189		     :fixed-width 50
190		     :clickable #t)))
191    (pack-start column1 renderer1 #f)
192    (add-attribute column1 renderer1 "text" 0)
193    (append-column treeview column1)
194
195    (pack-start column2 renderer2 #f)
196    (connect renderer2 'toggled (lambda (w p)
197				  (item-toggled model p alex-column)))
198    (add-attribute column2 renderer2 "active"      alex-column)
199    (add-attribute column2 renderer2 "visible"     visible-column)
200    (add-attribute column2 renderer2 "activatable" world-column)
201    (append-column treeview column2)
202
203    (connect renderer3 'toggled (lambda (w p)
204				  (item-toggled model p havoc-column)))
205    (pack-start column3 renderer3 #f)
206    (add-attribute column3 renderer3 "active"      havoc-column)
207    (add-attribute column3 renderer3 "visible"     visible-column)
208    (append-column treeview column3)
209
210    (connect renderer4 'toggled (lambda (w p)
211				  (item-toggled model p tim-column)))
212    (pack-start column4 renderer4 #f)
213    (add-attribute column4 renderer4 "active"      tim-column)
214    (add-attribute column4 renderer4 "visible"     visible-column)
215    (add-attribute column4 renderer4 "activatable" world-column)
216    (append-column treeview column4)
217
218    (connect renderer5 'toggled (lambda (w p)
219				  (item-toggled model p owen-column)))
220    (pack-start column5 renderer5 #f)
221    (add-attribute column5 renderer5 "active"      owen-column)
222    (add-attribute column5 renderer5 "visible"     visible-column)
223    (append-column treeview column5)
224
225    (connect renderer6 'toggled (lambda (w p)
226				  (item-toggled model p dave-column)))
227    (pack-start column6 renderer6 #f)
228    (add-attribute column6 renderer6 "active"      dave-column)
229    (add-attribute column6 renderer6 "visible"     visible-column)
230    (append-column treeview column6)))
231
232(define (main)
233  (let* (
234	 ;; create window, etc
235	 (window   (make <gtk-window>
236		     :type 'toplevel :title "Card planning sheet"
237		     :default-width 650 :default-height 400))
238	 (vbox     (make <gtk-vbox>
239		     :homogeneous #f :spacing 8 :border-width 8))
240	 (sw       (make <gtk-scrolled-window>
241		     :hscrollbar-policy 'automatic
242		     :vscrollbar-policy 'automatic
243		     :shadow-type 'etched-in))
244	 ;; create tree model
245	 (model    (create-model))
246	 ;; create tree view
247	 (treeview (make <gtk-tree-view>
248		     :model model :rules-hint #t))
249	 ;; some buttons
250	 (hbox     (make <gtk-hbox> :homogeneous #t :spacing 4))
251	 (button1  (make <gtk-button> :label "Add item"))
252	 (button2  (make <gtk-button> :label "Remove item")))
253    (add window vbox)
254
255    (pack-start vbox
256		(make <gtk-label>
257		  :label "Jonathan's Holiday Card Planning Sheet")
258		#f #f 0)
259
260    (pack-start vbox sw #t #t 0)
261
262    (set-mode (get-selection treeview) 'multiple)
263
264    (add-columns treeview)
265
266    (add sw treeview)
267
268    ;; expand all rows after the treeview widget has been realized
269    (connect treeview 'realize (lambda (w)
270				 (gtk-tree-view-expand-all treeview)))
271
272    (show-all window)))
273
274
275(define name "Tree View/Tree Store")
276(define description
277  (string-append
278   "The GtkTreeStore is used to store data in tree form, to be "
279   "used later on by a GtkTreeView to display it. This demo builds "
280   "a simple GtkTreeStore and displays it. If you're new to the "
281   "GtkTreeView widgets and associates, look into the GtkListStore "
282   "example first."))
283
284