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

(define-body (gnome-examples theme-d-gnome-demo panes)

  (import (gnome gtk)
	  (gnome gobject)
	  (standard-library string-utilities))


  (define-simple-proc toggle-resize (((widget-child <gtk-widget>)) <none>
				     nonpure)
    (let* ((paned (cast <gtk-paned> (gtk-widget-get-parent widget-child)))
	   (child1? (equal? widget-child (gtk-paned-get-child1 paned)))
	   (o-resize (make-gboolean #f))
	   (o-shrink (make-gboolean #f)))
      (child-get-property paned widget-child "resize" o-resize)
      (child-get-property paned widget-child "shrink" o-shrink)
      (remove paned widget-child)
      (if child1?
	  (pack1 paned widget-child
		 (not (cast <boolean> (gvalue->scm o-resize)))
		 (cast <boolean> (gvalue->scm o-shrink)))
	  (pack2 paned widget-child
		 (not (cast <boolean> (gvalue->scm o-resize)))
		 (cast <boolean> (gvalue->scm o-shrink))))))


  (define-simple-proc toggle-shrink (((widget-child <gtk-widget>)) <none>
				     nonpure)
    (let* ((paned (cast <gtk-paned> (get-parent widget-child)))
	   (child1? (equal? widget-child (get-child1 paned)))
	   (o-resize (make-gboolean #f))
	   (o-shrink (make-gboolean #f)))
      (child-get-property paned widget-child "resize" o-resize)
      (child-get-property paned widget-child "shrink" o-shrink)
      (remove paned widget-child)
      (if child1?
	  (pack1 paned widget-child
		 (cast <boolean> (gvalue->scm o-resize))
		 (not (cast <boolean> (gvalue->scm o-shrink))))
	  (pack2 paned widget-child
		 (cast <boolean> (gvalue->scm o-resize))
		 (not (cast <boolean> (gvalue->scm o-shrink)))))))


  (define-simple-proc create-pane-options
      (((paned <gtk-paned>) (str-frame-label <string>)
	(str-label1 <string>) (str-label2 <string>))
       <gtk-frame>
       nonpure)
    (let ((frame (gtk-frame-create str-frame-label))
	  (table (gtk-table-create 3 2 #t)))
      (set-border-width frame 4)
      (add frame table)
      (let ((label (gtk-label-create str-label1))
	    (checkbutton1 (gtk-check-button-create-with-label "_Resize"))
	    (checkbutton2 (gtk-check-button-create-with-label "_Shrink")))
	(set-use-underline checkbutton1 #t)
	(set-use-underline checkbutton2 #t)
	(attach-defaults table label 0 1 0 1)
	(attach-defaults table checkbutton1 0 1 1 2)
	(connect
	 checkbutton1
	 'toggled
	 (lambda (((args (rest <object>))) <object> nonpure)
	   (toggle-resize (get-child1 paned))
	   null))
	(attach-defaults table checkbutton2 0 1 2 3)
	(connect
	 checkbutton2
	 'toggled
	 (lambda (((args (rest <object>))) <object> nonpure)
	   (toggle-shrink (get-child1 paned))
	   null)))
      (let ((label (cast <gtk-label> (gtk-label-create str-label2)))
	    (checkbutton1 (gtk-check-button-create-with-label "_Resize"))
	    (checkbutton2 (gtk-check-button-create-with-label "_Shrink")))
	(set-use-underline checkbutton1 #t)
	(set-use-underline checkbutton2 #t)
	(set-active checkbutton2 #t)
	(attach-defaults table label 1 2 0 1)
	(attach-defaults table checkbutton1 1 2 1 2)
	(connect
	 checkbutton1
	 'toggled
	 (lambda (((args (rest <object>))) <object> nonpure)
	   (toggle-resize (get-child2 paned))
	   null))
	(attach-defaults table checkbutton2 1 2 2 3)
	(connect
	 checkbutton2
	 'toggled
	 (lambda (((args (rest <object>))) <object> nonpure)
	   (toggle-shrink (get-child2 paned))
	   null)))
      frame))


  (define-simple-proc run-panes-demo (((window-parent <gtk-window>))
				      <none> nonpure)
    (let* ((window (gtk-window-create 'toplevel))
	   (vbox (gtk-vbox-create #f 0))
	   (vpaned (gtk-vpaned-create))
	   (hpaned (gtk-hpaned-create))
	   (frame1 (gtk-frame-create-alt "" 'in 60 60))
	   (frame2 (gtk-frame-create-alt "" 'in 80 80))
	   (frame3 (gtk-frame-create-alt "" 'in 60 80))
	   (button (gtk-button-create-with-label "_Hi there"))
	   (vpane-options (create-pane-options vpaned
					       "Vertical" "Top" "Bottom"))
	   (hpane-options (create-pane-options hpaned
					       "Horizontal" "Left" "Right")))
      (set-title window "Panes")
      (set-border-width window 0)
      (set-border-width vpaned 5)
      (set-use-underline button #t)

      (add window vbox)
      (pack-start vbox vpaned #t #t 0)
      (add1 vpaned hpaned)
      (add1 hpaned frame1)
      (add frame1 button)
      (add2 hpaned frame2)
      (add2 vpaned frame3)
      (pack-start vbox hpane-options #f #f 0)
      (pack-start vbox vpane-options #f #f 0)

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

      (show-all window)))


  (define-simple-proc get-panes-demo (() <demo> force-pure)
    (let* ((str-name "Paned Widgets")
	   (str-module-name "panes")
	   (str-desc 
	    (string-append
	     "The GtkHPaned and GtkVPaned Widgets divide their content"
	     "area into two panes with a divider in between that the"
	     "user can adjust. A separate child is placed into each"
	     "pane."
	     "\n"
	     "There are a number of options that can be set for each pane."
	     "This test contains both a horizontal (HPaned) and a vertical"
	     "(VPaned) widget, and allows you to adjust the options for"
	     "each side of each widget."))
	   (demo (make <demo> str-name str-module-name str-desc "" ""
		       run-panes-demo)))
      (demo-compute-source demo)
      demo)))
