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

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

  (import (standard-library dynamic-list)
	  (standard-library object-string-conversion)
	  (standard-library goops-classes)
	  (standard-library string-utilities)
	  (gnome gtk)
	  (gnome gdk)
	  (gnome gobject))
  
 
  (define-mutable gl-window (:maybe <gtk-window>) null)


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

  
  (define-simple-proc activate-action (((l-args (rest <object>))) <object>
				       nonpure)
    (if (not gl-init?)
	(begin
	  (assert (not (equal? gl-window null)))
	  (let* ((action (cast <gtk-action> (d-car l-args)))
		 (str-name (gtk-action-get-name action))
		 ;; We make the dialog modal here.
		 (dialog (%gtk-message-dialog-create
			  (cast <gtk-window> gl-window)
			  (list 'modal 'destroy-with-parent)
		 	  'info
		 	  'close
		 	  (string-append
		 	   "You activated action: \""
		 	   str-name
		 	   "\" of type \""
		 	   (field-ref (class-of 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-proc activate-radio-action (((l-args (rest <object>))) <object>
					     nonpure)
    (assert (not (equal? gl-window null)))
    (let* ((action (cast <gtk-action> (d-car l-args)))
	   (o-current (d-car (d-cdr l-args)))
	   (action-current (cast <gtk-radio-action> o-current))
	   (str-name (gtk-action-get-name action))
	   (i-current-value (get-current-value action-current))
	   ;; We make the dialog modal here.
	   (dialog (%gtk-message-dialog-create
		    (cast <gtk-window> gl-window)
		    (list 'modal 'destroy-with-parent)
		    'info
		    'close
		    (string-append
		     "You activated radio action: \""
		     (gtk-action-get-name action-current)
		     "\" of type  \""
		     ;; Should we have action-current instead of action
		     ;; here?
		     (field-ref (class-of action) 'str-name)
		     ".\nCurrent value: "
		     (integer->string i-current-value)))))
;;      (set-transient-for dialog (cast <gtk-window> gl-window))
      (connect
       dialog 'response
       (lambda (((l-args (rest <object>))) <object> nonpure)
	 (destroy dialog)
	 null))
      (show dialog)
      null))


  (define-simple-proc get-entries (() <list> pure)
    (cast <list>
	  (d-list
	   (d-list
	    "FileMenu"  #f "_File")                    ; name, stock id, label
	   (d-list
	    "PreferencesMenu" #f "_Preferences")       ; name, stock id, label
	   (d-list
	    "ColorMenu" #f "_Color")                   ; name, stock id, label
	   (d-list
	    "ShapeMenu" #f "_Shape")                   ; name, stock id, label
	   (d-list
	    "HelpMenu"  #f "_Help")                    ; name, stock id, label
	   (d-list
	    "New"       (gtk-stock-id 'new) "_New"     ; name, stock id, label
	    "<control>N"                               ; accelerator
	    "Create a new file"                        ; tooltip
	    activate-action)
	   (d-list
	    "Open"      (gtk-stock-id 'open) "_Open"   ; name, stock id, label
	    "<control>O"                               ; accelerator
	    "Open a file"                              ; tooltip
	    activate-action)
	   (d-list
	    "Save"      (gtk-stock-id 'save) "_Save"   ; name, stock id, label
	    "<control>S"                               ; accelerator     
	    "Save current file"                        ; tooltip
	    activate-action)
	   (d-list
	    "SaveAs"    (gtk-stock-id 'save) "Save _As..."
					; name, stock id, label
	    #f                                         ; accelerator     
	    "Save to a file"                           ; tooltip
	    activate-action)
	   (d-list
	    "Quit"      (gtk-stock-id 'quit) "_Quit"   ; name, stock id, label
	    "<control>Q"                               ; accelerator     
	    "Quit"                                     ; tooltip
	    activate-action)
	   (d-list
	    "About"     #f "_About"                    ; name, stock id, label
	    "<control>A"                               ; accelerator     
	    "About"                                    ; tooltip  
	    activate-action)
	   (d-list
	    "Logo"      "demo-gtk-logo" #f             ; name, stock id, label
	    #f                                         ; accelerator     
	    "GTK+"                                     ; tooltip
	    activate-action))))


  (define-simple-proc get-toggle-entries (() <list> pure)
    (cast <list>
	  (d-list
	   (d-list
	    "Bold" (gtk-stock-id 'bold) "_Bold"  ; name, stock id, label
	    "<control>B"                         ; accelerator
	    "Bold"                               ; tooltip
	    activate-action
	    #t)                                  ; is_active
	   )))


  (define gl-color-red   0)
  (define gl-color-green 1)
  (define gl-color-blue  2)

  
  (define-simple-proc get-color-entries (() <list> pure)
    (cast <list>
	  (d-list
	   (d-list "Red" #f "_Red"       ; name, stock id, label
		   "<control>R"          ; accelerator
		   "Blood" gl-color-red)   ; tooltip, value
	   (d-list "Green" #f "_Green"   ; name, stock id, label 
		   "<control>G"          ; label, accelerator      
		   "Grass" gl-color-green) ; tooltip, value 
	   (d-list "Blue" #f "_Blue"     ; name, stock id, label 
		   "<control>B"          ; label, accelerator      
		   "Sky" gl-color-blue)    ; tooltip, value 
	   )))


  (define gl-shape-square    0)
  (define gl-shape-rectangle 1)
  (define gl-shape-oval      2)

  (define-simple-proc get-shape-entries (() <list> pure)
    (cast <list>
	  (d-list
	   (d-list
	    "Square"    #f "_Square"        ; name, stock id, label
	    "<control>S"                    ; accelerator     
	    "Square"    gl-shape-square)    ; tooltip, value
	   (d-list
	    "Rectangle" #f "_Rectangle"     ; name, stock id, label
	    "<control>R"                    ; accelerator     
	    "Rectangle" gl-shape-rectangle) ; tooltip, value
	   (d-list
	    "Oval"      #f "_Oval"          ; name, stock id, label
	    "<control>O"                    ; accelerator     
	    "Egg"       gl-shape-oval)      ; tooltip, value  
	   )))
  

  (define gl-str-ui-info "
<ui>
  <menubar name='MenuBar'>
    <menu action='FileMenu'>
      <menuitem action='New'/>
      <menuitem action='Open'/>
      <menuitem action='Save'/>
      <menuitem action='SaveAs'/>
      <separator/>
      <menuitem action='Quit'/>
    </menu>
    <menu action='PreferencesMenu'>
      <menu action='ColorMenu'>
	   <menuitem action='Red'/>
	   <menuitem action='Green'/>
	   <menuitem action='Blue'/>
      </menu>
      <menu action='ShapeMenu'>
       <menuitem action='Square'/>
       <menuitem action='Rectangle'/>
       <menuitem action='Oval'/>
      </menu>
      <menuitem action='Bold'/>
    </menu>
    <menu action='HelpMenu'>
      <menuitem action='About'/>
    </menu>
  </menubar>
  <toolbar  name='ToolBar'>
    <toolitem action='Open'/>
    <toolitem action='Quit'/>
    <separator action='Sep1'/>
    <toolitem action='Logo'/>
  </toolbar>
</ui>
  ")


  (define-simple-proc 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 (get-line iter))
	" column "
	(integer->string (get-line-offset iter))
	" - "
	(integer->string (get-char-count textbuffer))
	" chars in document"))))


  (define-simple-proc update-resize-grip (((widget <gtk-widget>)
					   (event <gdk-event>)
					   (statusbar <gtk-statusbar>))
					  <none>
					  nonpure)
    (let ((l-changed-mask (gdk-event-window-state:changed-mask event))
	  (l-new-state (gdk-event-window-state:new-window-state event)))
      (if (and (not (member? 'maximized l-changed-mask))
	       (not (member? 'fullscreen l-changed-mask)))
	  (set-has-resize-grip
	   statusbar
	   (not (or
		 (member? 'maximized l-new-state)
		 (member? 'fullscreen l-new-state)))))))


  (define-simple-proc run-app-window-demo (((window-parent <gtk-window>))
					   <none> nonpure)
    (let* ((window (gtk-window-create 'toplevel))
	   (table (gtk-table-create 1 4 #f))
	   (actiongroup (gtk-action-group-create "AppWindowActions"))
	   (uimanager (gtk-ui-manager-create))
	   (scrwin (gtk-scrolled-window-create #f #f))
	   (textbuffer (gtk-text-buffer-create #f))
	   (textview (gtk-text-view-create-with-buffer textbuffer))
	   (statusbar (gtk-statusbar-create)))
      (set! gl-window window)
      (set-title window "Application Window")
      (gobject-set-property window 'default-width 200)
      (gobject-set-property window 'default-height 200)
      (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 (cast <gtk-menu-bar>
			   (get-widget uimanager "/MenuBar")))
	    (toolbar (cast <gtk-toolbar>
			   (get-widget uimanager "/ToolBar"))))
	(show menubar)
	(attach table menubar
		0 1             0 1
		'(expand fill)  0
		0               0)
	(set-tooltips toolbar #t)
	(show toolbar)
	(attach table toolbar
		0 1             1 2
		'(expand fill)  0
		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               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 (cast <gdk-event> (d-car (d-cdr l-args)))))
	   (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-proc 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)))
