
;; Copyright (C) 2016, 2021, 2024  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 sizegroup)

  (import (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 gl-l-color-options '("Red" "Green" "Blue"))

  (define gl-l-dash-options '("Solid" "Dashed" "Dotted"))

  (define gl-l-end-options '("Square" "Round" "Arrow"))


  (define-simple-method create-combo-box (((l-str (:uniform-list <string>)))
					  <gtk-combo-box-text>
					  nonpure)
    (let ((combobox (cast <gtk-combo-box-text> (gtk-combo-box-text-new))))
      (for-each1 (lambda (((str <string>)) <none> nonpure)
		   (append-text combobox str))
		 l-str)
      (set-active combobox 0)
      combobox))


  (define-simple-method add-row (((table <gtk-table>)
				  (i-row <integer>)
				  (sizegroup <gtk-size-group>)
				  (str-label <string>)
				  (l-str-options (:uniform-list <string>)))
				 <none>
				 nonpure)
    (let* ((combobox (create-combo-box l-str-options))
	   (label (cast <gtk-label> (gtk-label-new str-label))))
      ;; Attributes xalign and yalign for label are defined in the original
      ;; Scheme version of this module.
      (set-use-underline label #t)
      (set-mnemonic-widget label combobox)
      (attach table label
	      0 1 i-row (+ i-row 1)
	      '(fill expand) '()
	      0 0)
      (add-widget sizegroup combobox)
      (attach table combobox
	      1 2 i-row (+ i-row 1)
	      '() '()
	      0 0)))


  (define-simple-method toggle-grouping (((checkbutton <gtk-check-button>)
					  (sizegroup <gtk-size-group>))
					 <none>
					 nonpure)
    (gtk-size-group-set-mode sizegroup
			     (if (get-active checkbutton)
				 'horizontal
				 'none)))


  (define-simple-method run-size-group-demo (((window-parent <gtk-window>))
					     <none> nonpure)
    (let* ((dialog (cast <gtk-dialog> (gtk-dialog-new)))
	   (vbox (cast <gtk-box> (gtk-box-new 'vertical 5)))
	   (sizegroup (cast <gtk-size-group> (gtk-size-group-new 'horizontal)))
	   (frame1 (cast <gtk-frame> (gtk-frame-new "Color options")))
	   (table1 (cast <gtk-table> (gtk-table-new 2 2 #f)))
	   (frame2 (cast <gtk-frame> (gtk-frame-new "Line options")))
	   (table2 (cast <gtk-table> (gtk-table-new 2 2 #f)))
	   (checkbutton
	    (cast <gtk-check-button>
		  (gtk-check-button-new-with-label "_Enable grouping"))))
      (set-title dialog "GtkSizeGroup")
      (set-resizable dialog #f)
      (set-border-width vbox 5)
      (set-border-width table1 5)
      (set-row-spacings table1 5)
      (set-border-width table2 5)
      (set-row-spacings table2 5)
      (set-use-underline checkbutton #t)
      (set-active checkbutton #t)

      (add-button dialog
		  "Close"
		  0)

      (connect
       dialog 'response
       (lambda (((args (rest <object>))) <object> nonpure)
	 (destroy dialog)
	 #f))

      (pack-start (gtk-dialog-get-content-area dialog)
		  vbox #t #t 0)
      (pack-start vbox frame1 #t #t 0)
      (add frame1 table1)

      (add-row table1 0 sizegroup "_Foreground" gl-l-color-options)
      (add-row table1 1 sizegroup "_Background" gl-l-color-options)

      (pack-start vbox frame2 #f #f 0)
      (add frame2 table2)

      (add-row table2 0 sizegroup "_Dashing" gl-l-dash-options)
      (add-row table2 1 sizegroup "_Line ends" gl-l-end-options)

      (pack-start vbox checkbutton #f #f 0)

      (connect
       checkbutton
       'toggled
       (lambda (((args (rest <object>))) <object> nonpure)
	 (toggle-grouping checkbutton sizegroup)
	 null))

      (set-transient-for dialog window-parent)

      (show-all dialog)))


  (define-simple-method get-size-group-demo (() <demo> force-pure)
    (let* ((str-name "Size Groups")
	   (str-module-name "sizegroup")
	   (str-desc 
	    (string-append
	     "GtkSizeGroup provides a mechanism for grouping a number of "
	     "widgets together so they all request the same amount of space."
	     "This is typically useful when you want a column of widgets to "
	     "have the same size, but you can't use a GtkTable widget."
	     "\n"
	     "Note that size groups only affect the amount of space requested,"
	     "not the size that the widgets finally receive. If you want the"
	     "widgets in a GtkSizeGroup to actually be the same size, you need"
	     "to pack them in such a way that they get the size they request"
	     "and not more. For example, if you are packing your widgets"
	     "into a table, you would not include the GTK_FILL flag."))
	   (demo (create <demo> str-name str-module-name str-desc "" ""
		       run-size-group-demo)))
      (demo-compute-source demo)
      demo)))
