
;; 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-gtk4-examples theme-d-intr-demo panes)

  (import (standard-library string-utilities)
	  (intr-gtk4-examples theme-d-intr-demo _intr-imports)
	  (intr-gtk4-examples theme-d-intr-demo support))


  (define connect gtype-instance-signal-connect)


  (define dbg disp-and-flush)

  
  (define-simple-method toggle-resize (((widget-child <gtk-widget>)) <none>
				       nonpure)
    (let* ((paned (cast <gtk-paned> (gtk-widget-get-parent widget-child)))
	   (child1?
	    (equal-objects? widget-child (gtk-paned-get-start-child paned)))
	   (resize?
	    (if child1?
		(get-resize-start-child paned)
		(get-resize-end-child paned))))
      (if child1?
	  (set-resize-start-child paned (not resize?))
	  (set-resize-end-child paned (not resize?)))))


  (define-simple-method toggle-shrink (((widget-child <gtk-widget>)) <none>
				       nonpure)
    (let* ((paned (cast <gtk-paned> (gtk-widget-get-parent widget-child)))
	   (child1?
	    (equal-objects? widget-child (gtk-paned-get-start-child paned)))
	   (shrink?
	    (if child1?
		(get-shrink-start-child paned)
		(get-shrink-end-child paned))))
      (if child1?
	  (set-shrink-start-child paned (not shrink?))
	  (set-shrink-end-child paned (not shrink?)))))


  (define-simple-method create-pane-options
      (((paned <gtk-paned>) (str-frame-label <string>)
	(str-label1 <string>) (str-label2 <string>))
       <gtk-frame>
       nonpure)
    (dbg "*1*\n")
    (let ((frame (cast <gtk-frame> (gtk-frame-new str-frame-label)))
	  (grid (cast <gtk-grid> (gtk-grid-new))))
      (dbg "*2*\n")
      ;; (set-border-width frame 4)
      (set-column-homogeneous grid #t)
      (set-child frame grid)
      (let ((label (cast <gtk-label> (gtk-label-new str-label1)))
	    (checkbutton1
	     (cast <gtk-check-button>
		   (gtk-check-button-new-with-label "_Resize")))
	    (checkbutton2
	     (cast <gtk-check-button>
		   (gtk-check-button-new-with-label "_Shrink"))))
	(set-use-underline checkbutton1 #t)
	(set-use-underline checkbutton2 #t)
	(attach grid label 0 0 1 1)
	(attach grid checkbutton1 0 1 1 1)
	(connect
	 checkbutton1
	 'toggled
	 (lambda (((args (rest <object>))) <object> nonpure)
	   (toggle-resize (cast <gtk-widget> (get-start-child paned)))
	   null))
	(attach grid checkbutton2 0 2 1 1)
	(connect
	 checkbutton2
	 'toggled
	 (lambda (((args (rest <object>))) <object> nonpure)
	   (toggle-shrink (cast <gtk-widget> (get-start-child paned)))
	   null)))
      (let ((label (cast <gtk-label> (gtk-label-new str-label2)))
	    (checkbutton1
	     (cast <gtk-check-button>
		   (gtk-check-button-new-with-label "_Resize")))
	    (checkbutton2
	     (cast <gtk-check-button>
		   (gtk-check-button-new-with-label "_Shrink"))))
	(set-use-underline checkbutton1 #t)
	(set-use-underline checkbutton2 #t)
	(set-active checkbutton2 #t)
	(attach grid label 1 0 1 1)
	(attach grid checkbutton1 1 1 1 1)
	(connect
	 checkbutton1
	 'toggled
	 (lambda (((args (rest <object>))) <object> nonpure)
	   (toggle-resize (cast <gtk-widget> (get-end-child paned)))
	   null))
	(attach grid checkbutton2 1 2 1 1)
	(connect
	 checkbutton2
	 'toggled
	 (lambda (((args (rest <object>))) <object> nonpure)
	   (toggle-shrink (cast <gtk-widget> (get-end-child paned)))
	   null)))
      frame))


  (define-simple-method run-panes-demo (((window-parent <gtk-window>))
					<none> nonpure)
    (let* ((window (cast <gtk-window> (gtk-window-new)))
	   (vbox (cast <gtk-box> (gtk-box-new 'vertical 0)))
	   (vpaned (cast <gtk-paned> (gtk-paned-new 'vertical)))
	   (hpaned (cast <gtk-paned> (gtk-paned-new 'horizontal)))
	   ;; (frame1 (gtk-frame-create-alt "" 'in 60 60))
	   ;; (frame2 (gtk-frame-create-alt "" 'in 80 80))
	   ;; (frame3 (gtk-frame-create-alt "" 'in 60 80))
	   (frame1 (cast <gtk-frame> (gtk-frame-new "")))
	   (frame2 (cast <gtk-frame> (gtk-frame-new "")))
	   (frame3 (cast <gtk-frame> (gtk-frame-new "")))
	   (button
	    (cast <gtk-button> (gtk-button-new-with-label "_Hi there")))
	   (vpane-options (create-pane-options vpaned
					       "Vertical" "Top" "Bottom"))
	   (hpane-options (create-pane-options hpaned
					       "Horizontal" "Left" "Right")))
      (gtk-widget-set-size-request window 300 -1)
      (gtk-widget-set-size-request frame1 60 60)
      (gtk-widget-set-size-request frame2 80 80)
      (gtk-widget-set-size-request frame3 60 80)
      
      (set-title window "Panes")
      ;; (set-border-width window 0)
      ;; (set-border-width vpaned 5)
      (set-use-underline button #t)

      (set-child window vbox)
      (gtk-box-append vbox vpaned)
      (set-start-child vpaned hpaned)
      (set-start-child hpaned frame1)
      (set-child frame1 button)
      (set-end-child hpaned frame2)
      (set-end-child vpaned frame3)
      (gtk-box-append vbox hpane-options)
      (gtk-box-append vbox vpane-options)

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

      (show window)))


  (define-simple-method 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)))
