
;; 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-gtk3-examples theme-d-intr-demo appwindow)

  (import (standard-library dynamic-list)
	  (standard-library object-string-conversion)
	  (standard-library goops-classes)
	  (standard-library string-utilities)
	  (standard-library list-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 gtk-stock-id symbol->string)

  
  (define-mutable gl-window (:maybe <gtk-window>) null)


  (define-mutable gl-init? <boolean> #t)


  ;; Should this be nonpure?
  (define gtk-message-dialog-new1
    (prim-proc gtk-message-dialog-new1
	       (<symbol> <string>) <gtk-widget> pure))


  (define gdk-event-get-changed-mask
    (prim-proc gdk-event-get-changed-mask (<object>)
	       (:union (:uniform-list <symbol>) <boolean>) pure))

  
  (define gdk-event-get-new-window-state
    (prim-proc gdk-event-get-new-window-state (<object>)
	       (:union (:uniform-list <symbol>) <boolean>) pure))


  (define-simple-method activate-action (((str-name <string>)) <none>
					 nonpure)
    (if (not gl-init?)
	(begin
	  ;; (assert (not (equal? gl-window null)))
	  ;; We make the dialog modal here.
	  (let ((dialog (gtk-message-dialog-new1
			 'close
			 (string-append
			  "You activated action: "
			  str-name))))
	    ;; (set-transient-for dialog (cast <gtk-window> gl-window))
	    (connect
	     dialog 'response
	     (lambda (((l-args (rest <object>))) <object> nonpure)
	       (destroy dialog)
	       null))
	    ;; Maybe we should call gtk-dialog-run.
	    (show dialog))))
    null)


  (define-simple-method toggle-action (((checkmenuitem <gtk-check-menu-item>)
					(str-name <string>)) <none>
					nonpure)
    (if (and
	 (not gl-init?)
	 (gtk-check-menu-item-get-active checkmenuitem))
	(begin
	  ;; (assert (not (equal? gl-window null)))
	  ;; We make the dialog modal here.
	  (let ((dialog (gtk-message-dialog-new1
			 'close
			 (string-append
			  "You toggled on action: "
			  str-name))))
	    ;; (set-transient-for dialog (cast <gtk-window> gl-window))
	    (connect
	     dialog 'response
	     (lambda (((l-args (rest <object>))) <object> nonpure)
	       (destroy dialog)
	       null))
	    ;; Maybe we should call gtk-dialog-run.
	    (show dialog))))
    null)

  
  (define-simple-method toggle-action2 (((checkmenuitem <gtk-check-menu-item>)
					 (str-name <string>)) <none>
					 nonpure)
    (if (not gl-init?)
	(begin
	  ;; (assert (not (equal? gl-window null)))
	  ;; We make the dialog modal here.
	  (let ((dialog (gtk-message-dialog-new1
			 'close
			 (string-append
			  "You toggled action "
			  str-name
			  (if (gtk-check-menu-item-get-active checkmenuitem)
			      " on."
			      " off.")))))
	    ;; (set-transient-for dialog (cast <gtk-window> gl-window))
	    (connect
	     dialog 'response
	     (lambda (((l-args (rest <object>))) <object> nonpure)
	       (destroy dialog)
	       null))
	    ;; Maybe we should call gtk-dialog-run.
	    (show dialog))))
    null)


  (define-simple-method connect-menu-item
      (((menuitem <gtk-widget>) (str-text <string>)) <none> nonpure)
    (connect
     menuitem 'activate
     (lambda (((l-args (rest <object>))) <object> nonpure)
       (activate-action str-text)
       null)))

  
  (define-simple-method connect-toggled
      (((checkmenuitem <gtk-widget>) (str-text <string>)) <none> nonpure)
    (connect
     checkmenuitem 'toggled
     (lambda (((l-args (rest <object>))) <object> nonpure)
       (toggle-action (cast <gtk-check-menu-item> checkmenuitem) str-text)
       null)))

  
  (define-simple-method make-file-menu (() <gtk-menu> nonpure)
    (let ((menu (cast <gtk-menu> (gtk-menu-new)))
	  (menuitem1 (gtk-menu-item-new-with-label "New"))
	  (menuitem2 (gtk-menu-item-new-with-label "Open"))
	  (menuitem3 (gtk-menu-item-new-with-label "Save"))
	  (menuitem4 (gtk-menu-item-new-with-label "Save As"))
	  (menuitem5 (gtk-separator-menu-item-new))
	  (menuitem6 (gtk-menu-item-new-with-label "Quit")))
      (gtk-menu-shell-insert menu menuitem1 0)
      (gtk-menu-shell-insert menu menuitem2 1)
      (gtk-menu-shell-insert menu menuitem3 2)
      (gtk-menu-shell-insert menu menuitem4 3)
      (gtk-menu-shell-insert menu menuitem5 4)
      (gtk-menu-shell-insert menu menuitem6 5)
      (connect-menu-item menuitem1 "New")
      (connect-menu-item menuitem2 "Open")
      (connect-menu-item menuitem3 "Save")
      (connect-menu-item menuitem4 "Save As")
      (connect-menu-item menuitem6 "Quit")
      menu))
  

  (define-simple-method make-radio-item-group
      (((l-labels (:uniform-list <string>)))
       (:uniform-list <gtk-radio-menu-item>) nonpure)
    (let ((i-count (length l-labels)))
      (let-mutable ((l-result (:uniform-list <gtk-radio-menu-item>) null))
	(do ((i <integer> 0 (+ i 1))) ((>= i i-count))
	  (let ((item
		 (cast <gtk-radio-menu-item>
		       (gtk-radio-menu-item-new-with-label
			#f (uniform-list-ref l-labels i)))))
	    (set! l-result (append l-result (list item)))))
	(let* ((l2 (cast (:nonempty-uniform-list <gtk-radio-menu-item>)
			 l-result))
	       (x-first (car l2)))
	  (iterate-list (x <gtk-radio-menu-item> (cdr l2))
	    (gtk-radio-menu-item-join-group x x-first)))
	l-result)))

  
  (define-simple-method make-color-menu (() <gtk-menu> nonpure)
    (let ((menu (cast <gtk-menu> (gtk-menu-new)))
	  (l-group (make-radio-item-group
		    (list "Red" "Green" "Blue"))))
      (gtk-menu-shell-insert menu (uniform-list-ref l-group 0) 0)
      (gtk-menu-shell-insert menu (uniform-list-ref l-group 1) 1)
      (gtk-menu-shell-insert menu (uniform-list-ref l-group 2) 2)
      (gtk-check-menu-item-set-active (uniform-list-ref l-group 0) #t)
      (connect-toggled (uniform-list-ref l-group 0) "Red")
      (connect-toggled (uniform-list-ref l-group 1) "Green")
      (connect-toggled (uniform-list-ref l-group 2) "Blue")
      menu))


  (define-simple-method make-shape-menu (() <gtk-menu> nonpure)
    (let ((menu (cast <gtk-menu> (gtk-menu-new)))
	  (l-group (make-radio-item-group
		    (list "Square" "Rectangle" "Oval"))))
      (gtk-menu-shell-insert menu (uniform-list-ref l-group 0) 0)
      (gtk-menu-shell-insert menu (uniform-list-ref l-group 1) 1)
      (gtk-menu-shell-insert menu (uniform-list-ref l-group 2) 2)
      (gtk-check-menu-item-set-active (uniform-list-ref l-group 0) #t)
      (connect-toggled (uniform-list-ref l-group 0) "Square")
      (connect-toggled (uniform-list-ref l-group 1) "Rectangle")
      (connect-toggled (uniform-list-ref l-group 2) "Oval")
      menu))


  (define-simple-method make-preferences-menu (() <gtk-menu> nonpure)
    (let ((menu (cast <gtk-menu> (gtk-menu-new)))
	  (menuitem1
	   (cast <gtk-menu-item> (gtk-menu-item-new-with-label "Color")))
	  (menuitem2
	   (cast <gtk-menu-item> (gtk-menu-item-new-with-label "Shape")))
	  (menuitem3 (gtk-check-menu-item-new-with-label "Bold"))
	  (menu-color (cast <gtk-menu> (make-color-menu)))
	  (menu-shape (cast <gtk-menu> (make-shape-menu))))
      (gtk-menu-shell-insert menu menuitem1 0)
      (gtk-menu-shell-insert menu menuitem2 1)
      (gtk-menu-shell-insert menu menuitem3 2)
      (gtk-menu-item-set-submenu menuitem1 menu-color)
      (gtk-menu-item-set-submenu menuitem2 menu-shape)
      (connect
       menuitem3 'toggled
       (lambda (((l-args (rest <object>))) <object> nonpure)
	 (toggle-action2 (cast <gtk-check-menu-item> menuitem3) "Bold")
	 null))
      menu))
  
  
  (define-simple-method make-help-menu (() <gtk-menu> nonpure)
    (let ((menu (cast <gtk-menu> (gtk-menu-new)))
	  (menuitem1 (gtk-menu-item-new-with-label "About")))
      (gtk-menu-shell-insert menu menuitem1 0)
      menu))


  (define-simple-method make-menu-bar (() <gtk-menu-bar> nonpure)
    (let ((menu-bar (cast <gtk-menu-bar> (gtk-menu-bar-new)))
	  (menuitem1
	   (cast <gtk-menu-item> (gtk-menu-item-new-with-label "File")))
	  (menuitem2
	   (cast <gtk-menu-item>
		 (gtk-menu-item-new-with-label "Preferences")))
	  (menuitem3
	   (cast <gtk-menu-item>
		 (gtk-menu-item-new-with-label "Help")))
	  (menu-file (make-file-menu))
	  (menu-preferences (make-preferences-menu))
	  (menu-help (make-help-menu)))
      (gtk-menu-shell-insert menu-bar menuitem1 0)
      (gtk-menu-shell-insert menu-bar menuitem2 1)
      (gtk-menu-shell-insert menu-bar menuitem3 2)
      (gtk-menu-item-set-submenu menuitem1 menu-file)
      (gtk-menu-item-set-submenu menuitem2 menu-preferences)
      (gtk-menu-item-set-submenu menuitem3 menu-help)
      ;; (connect menuitem1 'activate
      ;;  (lambda (((l-args (rest <object>))) <object> nonpure)
      ;; 	 (show-all menu-file)
      ;; 	 #f))
      menu-bar))


  (define-simple-method make-toolbar (() <gtk-toolbar> nonpure)
    (let* ((toolbar (cast <gtk-toolbar> (gtk-toolbar-new)))
  	   (image1 (gtk-image-new-from-icon-name
  		    "document-open"
  		    3))
  	   (image2 (gtk-image-new-from-icon-name
  		    "application-exit"
  		    3))
	   (toolitem1 (gtk-tool-button-new image1 "open"))
	   (toolitem2 (gtk-tool-button-new image2 "quit"))
	   (toolitem3 (gtk-separator-tool-item-new)))
      (gtk-toolbar-insert toolbar toolitem1 0)
      (gtk-toolbar-insert toolbar toolitem2 1)
      (gtk-toolbar-insert toolbar toolitem3 2)
      toolbar))
  
  
  (define-simple-method update-statusbar (((textbuffer <gtk-text-buffer>)
					   (statusbar <gtk-statusbar>))
					  <none>
					  nonpure)
    (let ((iter (get-iter-at-mark
		 textbuffer
		 (get-insert textbuffer))))
      (pop statusbar 0)
      (push
       statusbar
       0
       (string-append
	"Cursor at row "
	(integer->string (gtk-text-iter-get-line iter))
	" column "
	(integer->string (gtk-text-iter-get-line-offset iter))
	" - "
	(integer->string (get-char-count textbuffer))
	" chars in document"))))


  (define-simple-method update-resize-grip (((widget <gtk-widget>)
  					     (event <object>)
  					     (statusbar <gtk-statusbar>))
  					    <none>
  					    nonpure)
    (let* ((l-changed-mask0 (gdk-event-get-changed-mask event))
	   (l-changed-mask
	    (match-type l-changed-mask0
	      ((<boolean>) null)
	      ((l (:uniform-list <symbol>)) l)))
  	   (l-new-state0 (gdk-event-get-new-window-state event))
	   (l-new-state
	    (match-type l-new-state0
	      ((<boolean>) null)
	      ((l (:uniform-list <symbol>)) l))))
      (disp-and-flush "update-resize-grip")
      (disp-and-flush l-changed-mask)
      (disp-and-flush l-new-state)
      (if (and (not (member? 'maximized l-changed-mask))
  	       (not (member? 'fullscreen l-changed-mask))
	       (is-instance? gl-window <gtk-window>))
  	  (set-has-resize-grip
  	   (cast <gtk-window> gl-window)
  	   (not (or
  		 (member? 'maximized l-new-state)
  		 (member? 'fullscreen l-new-state)))))))


  (define-simple-method run-app-window-demo (((window-parent <gtk-window>))
					     <none> nonpure)
    (let* ((window (cast <gtk-window> (gtk-window-new 'toplevel)))
	   (table (cast <gtk-table> (gtk-table-new 1 4 #f)))
	   ;; (actiongroup (gtk-action-group-new "AppWindowActions"))
	   ;; (uimanager (gtk-ui-manager-new))
	   (scrwin
	    (cast <gtk-scrolled-window> (gtk-scrolled-window-new #f #f)))
	   (textbuffer (gtk-text-buffer-new #f))
	   (textview
	    (cast <gtk-text-view> (gtk-text-view-new-with-buffer textbuffer)))
	   (statusbar (cast <gtk-statusbar> (gtk-statusbar-new))))
      (set! gl-window window)
      (set-title window "Application Window")
      ;; (gobject-set-property window 'default-width 200)
      ;; (gobject-set-property window 'default-height 200)
      (set-size-request window 500 400)
      (set-policy scrwin 'automatic 'automatic)
      (set-shadow-type scrwin 'in)

      (add window table)
      ;; (add-actions actiongroup (get-entries))
      ;; (add-toggle-actions actiongroup (get-toggle-entries))
      ;; (add-radio-actions actiongroup
      ;; 			 (get-color-entries) gl-color-red
      ;; 			 activate-radio-action)
      ;; (add-radio-actions actiongroup
      ;; 			 (get-shape-entries) gl-shape-oval
      ;; 			 activate-radio-action)
      ;; (insert-action-group uimanager actiongroup 0)
      ;; (add-accel-group
      ;;  window (get-accel-group uimanager))
      ;; (add-ui-from-string uimanager gl-str-ui-info)

      (let ((menubar (make-menu-bar))
	    (toolbar (make-toolbar)))
	(show menubar)
	(attach table menubar
		0 1             0 1
		'(expand fill)  '()
		0               0)
	;; (set-tooltips toolbar #t)
	(show toolbar)
	(attach table toolbar
		0 1             1 2
		'(expand fill)  '()
		0               0))

      (attach table scrwin
	      0 1             2 3
	      '(expand fill)  '(expand fill)
	      0               0)
      (grab-focus textview)
      (add scrwin textview)
      (attach table statusbar
	      0 1             3 4
	      '(expand fill)  '()
	      0               0)

      (connect
       textbuffer 'changed
       (lambda (((l-args (rest <object>))) <object> nonpure)
	 (update-statusbar textbuffer statusbar)
	 #f))
      (connect
       textbuffer 'mark-set
       (lambda (((l-args (rest <object>))) <object> nonpure)
	 (update-statusbar textbuffer statusbar)
	 #f))
      (connect
       window 'window-state-event
       (lambda (((l-args (rest <object>))) <object> nonpure)
	 (let ((window1 (cast <gtk-window> (d-car l-args)))
	       (event (d-car (d-cdr l-args))))
	   (disp-and-flush "window-state-event")
	   (disp-and-flush event)
	   ;; (update-resize-grip window1 event statusbar)
	   #f)))
      (connect
       window 'delete-event
       (lambda (((l-args (rest <object>))) <object> nonpure)
	 (destroy window)
	 #f))

      (update-statusbar textbuffer statusbar)

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

      (set! gl-init? #f)
      (show-all window)))


  (define-simple-method get-app-window-demo (() <demo> force-pure)
    (let* ((str-name "Application Main Window")
	   (str-module-name "appwindow")
	   (str-desc
	    (string-append
	     "Demonstrates a typical application window, with menubar, "
	     "toolbar, and statusbar."))
	   (demo (make <demo> str-name str-module-name str-desc "" ""
		       run-app-window-demo)))
      (demo-compute-source demo)
      demo)))
