
;; 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-proper-program (intr-gtk3-examples theme-d-intr-demo run-demo)

  (import (standard-library core)
	  (standard-library goops-classes)
	  (standard-library list-utilities)
	  (standard-library console-io)
	  (intr-gtk3-examples theme-d-intr-demo support)
	  (intr-gtk3-examples theme-d-intr-demo demo)
	  (intr-gtk3-examples theme-d-intr-demo dialog)
	  (intr-gtk3-examples theme-d-intr-demo panes)
	  (intr-gtk3-examples theme-d-intr-demo sizegroup)
	  (intr-gtk3-examples theme-d-intr-demo button-box)
	  (intr-gtk3-examples theme-d-intr-demo list-store)
	  (intr-gtk3-examples theme-d-intr-demo tree-store)
	  (intr-gtk3-examples theme-d-intr-demo appwindow)
	  (intr-gtk3-examples theme-d-intr-demo _intr-imports))

  (define-mutable gl-l-demos (:uniform-list <demo>) null)
  
  (define gtk-tree-selection-get-selected-iter
    (prim-proc gtk-tree-selection-get-selected-iter
	       (<gtk-tree-selection>) <pointer> nonpure))

  (define gtk-tree-model-get-iter1
    (prim-proc gtk-tree-model-get-iter1 (<object> <pointer>) <pointer> pure))
  
  (define dbg disp-and-flush)
  
  (define-simple-method make-tree-view (((l-demos (:uniform-list <demo>)))
					<gtk-tree-view>
					nonpure)
    (let* ((store (gtk-list-store-new '(int string)))
	   (treeview
	    (cast <gtk-tree-view> (gtk-tree-view-new-with-model store)))
	   (cellrenderer (gtk-cell-renderer-text-new))
	   (column (gtk-tree-view-column-new))
	   (widget-sel (gtk-tree-view-get-selection treeview))
	   (i-nr-demos (length l-demos)))
      (set-title column "Widget (double-click to show)")
      (pack-start column cellrenderer #t)
      (add-attribute column cellrenderer "text" 1)
      (append-column treeview column)
      (do ((i <integer> 0 (+ i 1))) ((>= i i-nr-demos))
	(let ((iter (gtk-list-store-append store))
	      (str-name (field-ref (uniform-list-ref l-demos i) 'str-name)))
	  (gtk-list-store-set-value store iter 0 i)
	  (gtk-list-store-set-value store iter 1 str-name)))
      (set-mode widget-sel 'single)
      (set-size-request treeview 200 -1)
      treeview))

  (define-simple-method make-scrolled-window (() <gtk-scrolled-window> nonpure)
    (let ((scrolled
	   (cast <gtk-scrolled-window> (gtk-scrolled-window-new #f #f))))
      (set-policy scrolled 'automatic 'automatic)
      scrolled))

  (define-simple-method make-text-view (((notebook <gtk-notebook>)
					 (s-wrap-mode <gtk-wrap-mode>)
					 (i-pixels <integer>)
					 (str-name <string>))
					<gtk-text-buffer>
					nonpure)
    (let* ((scrolled (make-scrolled-window))
	   (textbuffer (gtk-text-buffer-new #f))
	   (textview
	    (cast <gtk-text-view> (gtk-text-view-new-with-buffer textbuffer)))
	   (label (cast <gtk-label> (gtk-label-new str-name))))
      (set-editable textview #f)
      (set-cursor-visible textview #f)
      (set-wrap-mode textview s-wrap-mode)
      (set-pixels-above-lines textview i-pixels)
      (set-pixels-below-lines textview i-pixels)      
      (add scrolled textview)
      (append-page notebook scrolled label)
      (set-use-underline label #t)
      textbuffer))

  (define-simple-method clear-buffer (((textbuffer <gtk-text-buffer>)) <none>
				      nonpure)
    (let ((iter-start (gtk-text-buffer-get-start-iter textbuffer))
	  (iter-end (gtk-text-buffer-get-end-iter textbuffer)))
      (gtk-text-buffer-delete textbuffer iter-start iter-end)))

  (define-simple-method set-source-contents (((s-type <symbol>)
					      (tb <gtk-text-buffer>)
					      (str-contents <string>))
					     <none>
					     nonpure)
    (clear-buffer tb)
    (let* ((iter (get-start-iter tb))
	   (mark (create-mark tb "current" iter #t)))
      (insert tb iter str-contents)
      (let ((iter2 (get-iter-at-mark tb mark)))
       	(apply-tag-by-name tb
      			   (if (equal? s-type 'interface) "source1" "source2")
       			   iter2
      			   (gtk-text-buffer-get-end-iter tb)))))

  (define-simple-method set-demo (((demo <demo>)
				   (tb-info <gtk-text-buffer>)
				   (tb-interface <gtk-text-buffer>)
				   (tb-body <gtk-text-buffer>))
				  <none>
				  nonpure)
    (clear-buffer tb-info)
    (let ((str-name (field-ref demo 'str-name))
	  (str-desc (field-ref demo 'str-description))
	  (iter (gtk-text-buffer-get-iter-at-offset tb-info 0)))
      (insert tb-info iter str-name)
      (let ((iter-start (gtk-text-buffer-get-iter-at-offset tb-info 0)))
	(apply-tag-by-name tb-info "title" iter-start iter)
	(insert tb-info iter "\n")
	(insert tb-info iter str-desc)))
    (set-source-contents
     'interface tb-interface (field-ref demo 'str-interface))
    (set-source-contents
     'body tb-body (field-ref demo 'str-body)))

  (define-simple-method connect-row-activated
      (((treeview <gtk-tree-view>) (window-main <gtk-window>)) <none> nonpure)
    (gtype-instance-signal-connect
     treeview 'row-activated
     (lambda (((args (rest <object>)))
	      <object>
	      nonpure)
       (let* ((args1
	       (cast (:tuple <gtk-tree-view>
			     <gtk-tree-path>
			     <gtk-tree-view-column>)
		     args))
	      (treeview1 (tuple-ref args1 0))
	      (treepath (tuple-ref args1 1))
	      (treecolumn (tuple-ref args1 2))
	      (treemodel (get-model treeview1))
	      (iter (gtk-tree-model-get-iter1 treemodel treepath))
	      (demo
	       (uniform-list-ref gl-l-demos
				 (cast <integer>
				       (gtk-tree-model-get-value
					treemodel iter 0))))
	      (proc (field-ref demo 'proc-run)))
	 (proc window-main)
	 null))))

  (define-simple-method connect-changed
      (((treeview <gtk-tree-view>)
	(tb-info <gtk-text-buffer>)
	(tb-interface <gtk-text-buffer>)
	(tb-body <gtk-text-buffer>))
       <none> nonpure)
    (let ((selection (get-selection treeview)))
      (gtype-instance-signal-connect
       selection 'changed
       (lambda (((args (rest <object>))) <object> nonpure)
	 (let* ((selection (car (cast (:tuple <gtk-tree-selection>) args)))
		;; (pr (get-selected selection))
		;; (treemodel (car pr))
		;; (treeiter (cdr pr)))
		(treeiter (gtk-tree-selection-get-selected-iter selection))
		(treemodel (gtk-tree-view-get-model treeview)))
	   (set-demo
	    (uniform-list-ref gl-l-demos
			      (cast <integer>
				    (gtk-tree-model-get-value
				     treemodel treeiter 0)))
	    tb-info
	    tb-interface
	    tb-body)
	   null)))))

  (define-simple-method activate-my-app
      (((args (rest <object>))) <object> nonpure)
    (let* ((app (cast <gtk-application> (uniform-list-ref args 0)))
	   (window-main (cast <gtk-application-window>
			      (gtk-application-window-new app)))
	   (l-demos (list
		     (get-dialog-demo)
		     (get-panes-demo)
		     (get-size-group-demo)
		     (get-button-box-demo)
		     (get-list-store-demo)
		     (get-tree-store-demo)
		     (get-app-window-demo)))
	   (treeview (make-tree-view l-demos))
	   (notebook (cast <gtk-notebook> (gtk-notebook-new)))
	   (buffer-info (make-text-view notebook 'word 2 "_Info"))
	   (buffer-interface (make-text-view notebook 'none 0 "I_nterface"))
	   (buffer-body (make-text-view notebook 'none 0 "_Body"))
	   (hbox (cast <gtk-hbox> (gtk-hbox-new #f 0)))
	   (scrolled (make-scrolled-window))
	   (tag-table-info (gtk-text-buffer-get-tag-table buffer-info))
	   (tag-table-interface
	    (gtk-text-buffer-get-tag-table buffer-interface))
	   (tag-table-body (gtk-text-buffer-get-tag-table buffer-body))
	   (tag-info (gtk-text-tag-new "title"))
	   (tag-interface (gtk-text-tag-new "source1"))
	   (tag-body (gtk-text-tag-new "source2")))
      (set! gl-l-demos l-demos)
      ;; (create-tag buffer-info "title" 'font "Sans 18")
      ;; (create-tag buffer-interface "source"
      ;; 		  'font "Courier 12"
      ;; 		  'pixels-above-lines 0
      ;; 		  'pixels-below-lines 0)
      ;; (create-tag buffer-body "source"
      ;; 		  'font "Courier 12"
      ;; 		  'pixels-above-lines 0
      ;; 		  'pixels-below-lines 0)
      (slot-set0! tag-info 'font "Sans 18")
      (slot-set0! tag-interface 'font "Liberation Mono 10")
      ;; (slot-set0! tag-interface 'pixels-above-lines 0)
      ;; (slot-set0! tag-interface 'pixels-below-lines 0)
      (slot-set0! tag-body 'font "Liberation Mono 10")
      ;; (slot-set0! tag-body 'pixels-above-lines 0)
      ;; (slot-set0! tag-body 'pixels-below-lines 0)
      (gtk-text-tag-table-add tag-table-info tag-info)
      (gtk-text-tag-table-add tag-table-interface tag-interface)
      (gtk-text-tag-table-add tag-table-body tag-body)
      (set-default-size window-main 600 400)
      (set-size-request scrolled 200 -1)
      (add window-main hbox)
      (add scrolled treeview)
      (pack-start hbox scrolled #f #f 0)
      (pack-start hbox notebook #t #t 0)
      (gtype-instance-signal-connect window-main
				     'delete-event
				     (lambda (((args (rest <object>))) <object>
					      nonpure)
				       (g-application-quit app)
				       #f))
      (connect-row-activated treeview window-main)
      (connect-changed treeview
		       buffer-info
		       buffer-interface
		       buffer-body)
      ;; (emit (gtk-tree-view-get-selection treeview) 'changed null)
      (show-all window-main)
      null))
  
  (define-main-proc (() <none> nonpure)
    (let* ((str-app-name "org.tohoyn.theme-d-intr-demo")
	   (app (gtk-application-new str-app-name null)))
      (g-set-prgname str-app-name)
      (gtype-instance-signal-connect
       app 'activate activate-my-app)      
      (let ((status (g-application-run app null)))
	status))))
