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

(define-proper-program (gnome-examples theme-d-gnome-demo run-demo)

  (import (standard-library core)
	  (standard-library goops-classes)
	  (standard-library list-utilities)
	  (gnome gobject)
	  (gnome gtk)
	  (gnome-examples theme-d-gnome-demo support)
	  (gnome-examples theme-d-gnome-demo demo)
	  (gnome-examples theme-d-gnome-demo dialog)
	  (gnome-examples theme-d-gnome-demo panes)
	  (gnome-examples theme-d-gnome-demo sizegroup)
	  (gnome-examples theme-d-gnome-demo button-box)
	  (gnome-examples theme-d-gnome-demo list-store)
	  (gnome-examples theme-d-gnome-demo tree-store)
	  (gnome-examples theme-d-gnome-demo appwindow)
	  (standard-library console-io))


  (define-simple-proc make-tree-view (((l-demos (:uniform-list <demo>)))
				      <gtk-tree-view>
				      nonpure)
    (let* ((store (gtk-list-store-create
		   (list (get-raw-goops-class <gboxed-scm>)
			 (get-raw-goops-class <gchararray>))))
	   (treeview
	    (gtk-tree-view-create-with-model store))
	   (cellrenderer (gtk-cell-renderer-text-create))
	   (column (gtk-tree-view-column-create))
	   (widget-sel (gtk-tree-view-get-selection treeview)))
      (set-title column "Widget (double-click to show)")
      (pack-start column cellrenderer #t)
      (add-attribute column cellrenderer "text" 1)
      (append-column treeview column)
      (for-each1
       (lambda (((demo <demo>)) <none> nonpure)
	 (gtk-tree-or-list-store-set store (gtk-list-store-append store)
				     0 demo
				     1 (field-ref demo 'str-name)))
       l-demos)
      (set-mode widget-sel 'single)
      (set-size-request treeview 200 -1)
      treeview))

  (define-simple-proc make-scrolled-window (() <gtk-scrolled-window> nonpure)
    (let ((scrolled (gtk-scrolled-window-create #f #f)))
      (set-policy scrolled 'automatic 'automatic)
      scrolled))

  (define-simple-proc make-text-view (((notebook <gtk-notebook>)
				       (s-wrap-mode <symbol>)
				       (i-pixels <integer>)
				       (str-name <string>))
				      <gtk-text-buffer>
				      nonpure)
    (let* ((scrolled (make-scrolled-window))
	   (textbuffer (gtk-text-buffer-create #f))
	   (textview (gtk-text-view-create-with-buffer textbuffer))
	   (label (gtk-label-create 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-proc 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)))
      (delete textbuffer iter-start iter-end)))

  (define-simple-proc set-source-contents (((tb <gtk-text-buffer>)
					    (str-contents <string>))
					   <none>
					   nonpure)
    (clear-buffer tb)
    (let ((iter (get-iter-at-offset tb 0)))
      (insert tb iter str-contents)
      (let ((iter-start (get-iter-at-offset tb 0)))
	(apply-tag-by-name tb "source"
			   iter-start iter))))

  (define-simple-proc 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 tb-interface (field-ref demo 'str-interface))
    (set-source-contents tb-body (field-ref demo 'str-body)))

  (define-simple-proc connect-row-activated
      (((treeview <gtk-tree-view>) (window-main <gtk-window>)) <none> nonpure)
    (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-iter treemodel treepath))
	      (demo
	       (cast <demo> (gtk-tree-model-get-value treemodel iter 0)))
	      (proc (field-ref demo 'proc-run)))
	 (proc window-main)
	 null))))

  (define-simple-proc 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)))
      (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)))
	   (set-demo (cast <demo>
			   (gtk-tree-model-get-value treemodel treeiter 0))
		     tb-info
		     tb-interface
		     tb-body)
	   null)))))

  (define-simple-proc main (() <none> nonpure)
    (let* ((window-main (cast <gtk-window> (gtk-window-create 'toplevel)))
	   (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 (gtk-notebook-create))
	   (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 (gtk-hbox-create #f 0))
	   (scrolled (make-scrolled-window)))
      (create-tag buffer-info "title" 'font "Sans 18")
      (create-tag buffer-interface "source"
		  'font "Courier New 12"
		  'pixels-above-lines 0
		  'pixels-below-lines 0)
      (create-tag buffer-body "source"
		  'font "Courier New 12"
		  'pixels-above-lines 0
		  'pixels-below-lines 0)
      (set-default-size window-main 600 400)
      (add window-main hbox)
      (add scrolled treeview)
      (pack-start hbox scrolled #f #f 0)
      (pack-start hbox notebook #t #t 0)
      (connect window-main
	       'delete-event
	       (lambda (((args (rest <object>))) <object>
			nonpure)
		 (gtk-main-quit)
		 #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)
      (gtk-main))))
