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

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

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


  (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-proc create-combo-box (((l-str (:uniform-list <string>)))
					<gtk-combo-box>
					nonpure)
    (let ((combobox (gtk-combo-box-create-text)))
      (for-each1 (lambda (((str <string>)) <none> nonpure)
		   (append-text combobox str))
		 l-str)
      (set-active combobox 0)
      combobox))


  (define-simple-proc 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 (gtk-label-create 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) #f
	      0 0)
      (add-widget sizegroup combobox)
      (attach table combobox
	      1 2 i-row (+ i-row 1)
	      #f #f
	      0 0)))


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


  (define-simple-proc run-size-group-demo (((window-parent <gtk-window>))
				      <none> nonpure)
    (let* ((dialog (gtk-dialog-create "GtkSizeGroup" #t #t))
	   (vbox (gtk-vbox-create #f 5))
	   (sizegroup (gtk-size-group-create 'horizontal))
	   (frame1 (gtk-frame-create "Color options"))
	   (table1 (gtk-table-create 2 2 #f))
	   (frame2 (gtk-frame-create "Line options"))
	   (table2 (gtk-table-create 2 2 #f))
	   (checkbutton
	    (gtk-check-button-create-with-label "_Enable grouping")))
      (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
		  (gtk-stock-id 'close)
		  0)

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

      (pack-start (cast <gtk-vbox> (gtk-dialog-get-vbox 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-proc 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 (make <demo> str-name str-module-name str-desc "" ""
		       run-size-group-demo)))
      (demo-compute-source demo)
      demo)))
