
;; Copyright (C) 2016, 2021  Tommi Höynälänmaa

;; This file is part of Theme-D-Intr.

;; You can redistribute and/or modify this file under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation, either version 3 of the License, or (at your option) any
;; later version.

;; This file is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see https://www.gnu.org/licenses/.


(define-body (intr-gtk3-examples theme-d-intr-demo tree-store)

  (import (standard-library dynamic-list)
	  (standard-library goops-classes)
	  (standard-library list-utilities)
	  (standard-library string-utilities)
	  (intr-gtk3-examples theme-d-intr-demo _intr-imports)
	  (intr-gtk3-examples theme-d-intr-demo support))


  (define connect gtype-instance-signal-connect)
  
  (define dbg disp-and-flush)

  (define gtk-tree-model-get-iter1
    (prim-proc gtk-tree-model-get-iter1 (<object> <pointer>) <pointer> pure))


  (define january
    '(("New Years Day" #t #t #t #t #f #t)
      ("Presidential Inauguration" #f #t #f #t #f #f)
      ("Martin Luther King Jr. day" #f #t #f #t #f #f)))

  (define february
    '(("Presidents' Day" #f #t #f #t #f #f)
      ("Groundhog Day" #f #f #f #f #f #f)
      ("Valentine's Day" #f #f #f #f #t #t)))

  (define march
    '(("National Tree Planting Day" #f #f #f #f #f #f)
      ("St Patrick's Day" #f #f #f #f #f #t)))

  (define april
    '(("April Fools' Day" #f #f #f #f #f #t)
      ("Army Day" #f #f #f #f #f #f)
      ("Earth Day" #f #f #f #f #f #t)
      ("Administrative Professionals' Day" #f #f #f #f #f #f)))

  (define may
    '(("Nurses' Day" #f #f #f #f #f #f)
      ("National Day of Prayer" #f #f #f #f #f #f)
      ("Mothers' Day" #f #f #f #f #f #t)
      ("Armed Forces Day" #f #f #f #f #f #f)
      ("Memorial Day" #t #t #t #t #f #t)))

  (define june
    '(("June Fathers' Day" #f #f #f #f #f #t)
      ("Juneteenth (Liberation of Slaves)" #f #f #f #f #f #f)
      ("Flag Day" #f #t #f #t #f #f)))

  (define july
    '(("Parents' Day" #f #f #f #f #f #t)
      ("Independence Day" #f #t #f #t #f #f)))

  (define august
    '(("Air Force Day" #f #f #f #f #f #f)
      ("Coast Guard Day" #f #f #f #f #f #f)
      ("Friendship Day" #f #f #f #f #f #f)))

  (define september
    '(("Grandparents' Day" #f #f #f #f #f #t)
      ("Citizenship Day or Constitution Day" #f #f #f #f #f #f)
      ("Labor Day" #t #t #t #t #f #t)))

  (define october
    '(("National Children's Day" #f #f #f #f #f #f)
      ("Bosses' Day" #f #f #f #f #f #f)
      ("Sweetest Day" #f #f #f #f #f #f)
      ("Mother-in-Law's Day" #f #f #f #f #f #f)
      ("Navy Day" #f #f #f #f #f #f)
      ("Columbus Day" #f #t #f #t #f #f)
      ("Halloween" #f #f #f #f #f #t)))

  (define november
    '(("Marine Corps Day" #f #f #f #f #f #f)
      ("Veterans' Day" #t #t #t #t #f #t)
      ("Thanksgiving" #f #t #f #t #f #f)))

  (define december
    '(("Pearl Harbor Remembrance Day" #f #f #f #f #f #f)
      ("Christmas" #t #t #t #t #f #t)
      ("Kwanzaa" #f #f #f #f #f #f)))

  (define toplevel
    `(("January"   ,january)
      ("February"  ,february)
      ("March"     ,march)
      ("April"     ,april)
      ("May"       ,may)
      ("June"      ,june)
      ("July"      ,july)
      ("August"    ,august)
      ("September" ,september)
      ("October"   ,october)
      ("November"  ,november)
      ("December"  ,december)))


  (define holiday-name-column 0)
  (define alex-column    1)
  (define havoc-column   2)
  (define tim-column     3)
  (define owen-column    4)
  (define dave-column    5)
  (define visible-column 6)
  (define world-column   7)


  (define <row>
    (:tuple <string>
	    <boolean> <boolean> <boolean> <boolean> <boolean> <boolean>))

  
  (define <toplevel-row>
    (:tuple <string> (:uniform-list <row>)))


  (define-simple-method create-model (() <gtk-tree-store> nonpure)
    (let (
	  ;; create tree store
	  (model (gtk-tree-store-new
		  '(string boolean boolean boolean boolean boolean boolean
			   boolean))))
      (for-each1 
       (lambda (((m <toplevel-row>)) <none> nonpure)
      	 (let ((iter (gtk-tree-store-append model #f)))
      	   (set-value model iter holiday-name-column (car m))
	   (for-each1 (lambda (((c <integer>)) <none> nonpure)
	   		(set-value model iter c #f))
	   	      (list alex-column havoc-column tim-column owen-column 
	   		    dave-column visible-column world-column))
	   (for-each1
	    (lambda (((h <row>)) <none> nonpure)
	      (let ((iter (gtk-tree-store-append model iter)))
	   	(for-each 
	   	 (lambda (((c <object>) (i <integer>)) <none> nonpure)
	   	   (set-value model iter i c))
	   	 h (list holiday-name-column alex-column havoc-column
	   		 tim-column owen-column dave-column world-column))
	   	(set-value model iter visible-column #t)))
	    (car (cdr m)))))
       toplevel)
      model))


  (define-simple-method item-toggled
      (((treemodel <gtk-tree-model>) (pathstr <string>)
	(column <integer>)) <none> nonpure)
    (let* ((store (cast <gtk-tree-store> treemodel))
	   ;; get toggled iter
	   (iter (gtk-tree-model-get-iter1
		  treemodel
		  (gtk-tree-path-new-from-string pathstr)))
	   ;; get current value and invert
	   (toggle (equal? (gtk-tree-model-get-value treemodel iter column)
			   #f)))
      ;; set the new value
      (set-value store iter column toggle)))


  (define-simple-method connect-item-toggled
      (((treemodel <gtk-tree-model>)
	(renderer <gtk-cell-renderer>)
	(i-column <integer>))
       <none>
       nonpure)
    (connect renderer 'toggled
	     (lambda (((l-args (rest <object>))) <object> nonpure)
	       (let ((str-path (car (cdr (cast (:tuple <object> <string>)
					       l-args)))))
		 (item-toggled treemodel str-path i-column)
		 null))))


  (define-simple-method add-columns (((treeview <gtk-tree-view>)
				      (treemodel <gtk-tree-store>))
				     <none> nonpure)
    (let ((renderer1 (gtk-cell-renderer-text-new))
	  (column1 (gtk-tree-view-column-new))
	  (renderer2 (gtk-cell-renderer-toggle-new))
	  (column2 (gtk-tree-view-column-new))
	  (renderer3 (gtk-cell-renderer-toggle-new))
	  (column3 (gtk-tree-view-column-new))
	  (renderer4 (gtk-cell-renderer-toggle-new))
	  (column4 (gtk-tree-view-column-new))
	  (renderer5 (gtk-cell-renderer-toggle-new))
	  (column5 (gtk-tree-view-column-new))
	  (renderer6 (gtk-cell-renderer-toggle-new))
	  (column6 (gtk-tree-view-column-new)))

      ;; (gobject-set-property renderer1 'xalign 0)
      (set-title column1 "Holliday")
      (set-clickable column1 #t)
      (pack-start column1 renderer1 #f)
      (add-attribute column1 renderer1 "text" 0)
      (append-column treeview column1)

      ;; (gobject-set-property renderer2 'xalign 0)
      (set-title column2 "Alex")
      (set-sizing column2 'fixed)
      (set-fixed-width column2 50)
      (set-clickable column2 #t)
      (pack-start column2 renderer2 #f)
      (connect-item-toggled treemodel renderer2 alex-column)
      (add-attribute column2 renderer2 "active" alex-column)
      (add-attribute column2 renderer2 "visible" visible-column)
      (add-attribute column2 renderer2 "activatable" world-column)
      (append-column treeview column2)

      ;; (gobject-set-property renderer3 'xalign 0)
      (set-title column3 "Havoc")
      (set-sizing column3 'fixed)
      (set-fixed-width column3 50)
      (set-clickable column3 #t)
      (pack-start column3 renderer3 #f)
      (connect-item-toggled treemodel renderer3 havoc-column)
      (add-attribute column3 renderer3 "active" havoc-column)
      (add-attribute column3 renderer3 "visible" visible-column)
      (append-column treeview column3)

      ;; (gobject-set-property renderer4 'xalign 0)
      (set-title column4 "Tim")
      (set-sizing column4 'fixed)
      (set-fixed-width column4 50)
      (set-clickable column4 #t)
      (pack-start column4 renderer4 #f)
      (connect-item-toggled treemodel renderer4 tim-column)
      (add-attribute column4 renderer4 "active" tim-column)
      (add-attribute column4 renderer4 "visible" visible-column)
      (add-attribute column4 renderer4 "activatable" world-column)
      (append-column treeview column4)

      ;; (gobject-set-property renderer5 'xalign 0)
      (set-title column5 "Owen")
      (set-sizing column5 'fixed)
      (set-fixed-width column5 50)
      (set-clickable column5 #t)
      (pack-start column5 renderer5 #f)
      (connect-item-toggled treemodel renderer5 owen-column)
      (add-attribute column5 renderer5 "active" owen-column)
      (add-attribute column5 renderer5 "visible" visible-column)
      (append-column treeview column5)

      ;; (gobject-set-property renderer6 'xalign 0)
      (set-title column6 "Dave")
      (set-sizing column6 'fixed)
      (set-fixed-width column6 50)
      (set-clickable column6 #t)
      (pack-start column6 renderer6 #f)
      (connect-item-toggled treemodel renderer6 dave-column)
      (add-attribute column6 renderer6 "active" dave-column)
      (add-attribute column6 renderer6 "visible" visible-column)
      (append-column treeview column6)))


  (define-simple-method run-tree-store-demo (((window-parent <gtk-window>))
					     <none> nonpure)
    (let* ((window (cast <gtk-window> (gtk-window-new 'toplevel)))
	   (vbox (cast <gtk-box> (gtk-box-new 'vertical 8)))
	   (label
	    (cast <gtk-label>
		  (gtk-label-new
		   (string-append 
		    "This is the bug list (note: not based on real "
		    "data, it would be nice to have a nice ODBC "
		    "interface to bugzilla or so, though)."))))
	   (scrwin
	    (cast <gtk-scrolled-window> (gtk-scrolled-window-new #f #f)))
	   (model (create-model))
	   (treeview
	    (cast <gtk-tree-view> (gtk-tree-view-new-with-model model)))
	   (hbox (cast <gtk-box> (gtk-box-new 'horizontal 4)))
	   (label
	    (cast <gtk-label>
		  (gtk-label-new "Jonathan's Holiday Card Planning Sheet")))
	   (button1
	    (cast <gtk-button> (gtk-button-new-with-label "Add item")))
	   (button2
	    (cast <gtk-button> (gtk-button-new-with-label "Remove item"))))

      (set-title window "Card planning sheet")
      ;; (gobject-set-property window 'default-width 650)
      ;; (gobject-set-property window 'default-height 400)
      (set-size-request window 650 400)
      
      (set-border-width vbox 8)

      (set-policy scrwin 'automatic 'automatic)
      (set-shadow-type scrwin 'etched-in)

      (set-rules-hint treeview #t)

      (add window vbox)
      (pack-start vbox label #f #f 0)
      (pack-start vbox scrwin #t #t 0)
      (set-mode (get-selection treeview) 'multiple)
      (add-columns treeview model)
      (add scrwin treeview)

      (connect treeview 'realize
	       (lambda (((l-args (rest <object>))) <object> nonpure)
		 (gtk-tree-view-expand-all treeview)
		 null))

      (set-modal window #t)
      (set-transient-for window window-parent)

      (show-all window)))


  (define-simple-method get-tree-store-demo (() <demo> force-pure)
    (let* ((str-name "Tree View/Tree Store")
	   (str-module-name "tree-store")
	   (str-desc
	    (string-append
	     "The GtkTreeStore is used to store data in tree form, to be "
	     "used later on by a GtkTreeView to display it. This demo builds "
	     "a simple GtkTreeStore and displays it. If you're new to the "
	     "GtkTreeView widgets and associates, look into the GtkListStore "
	     "example first."))
	   (demo (make <demo> str-name str-module-name str-desc "" ""
		       run-tree-store-demo)))
      (demo-compute-source demo)
      demo)))
