;; -*-theme-d-*-

;; Copyright (C) 2015, 2020, 2021, 2022, 2024 Tommi Höynälänmaa

;; This file is based on file gtk/examples/hello.scm in package
;; guile-gnome-platform 2.16.2.

;; 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-proper-program (intr-gtk4-examples custom-layout-example main)
  
  (import (standard-library core)
          (standard-library list-utilities)
          ;; (standard-library console-io)
          (intr-gtk4-examples custom-layout-example _intr-imports))
  
;   (define flush-all-ports
;     (prim-proc flush-all-ports () <none> nonpure))
  
;   (define-simple-method log1 (((x-message <object>)) <none> nonpure)
;     (console-display-line x-message)
;     (flush-all-ports))
  
  (define-simple-method transform1
      (((i-width <integer>) (i-child-width <integer>))
       (:alt-maybe <gsk-transform>)
       nonpure)
    (gsk-transform-translate #f
                             (graphene-point-init (graphene-point-alloc)
                                                  100.0
                                                  0.0)))
  
  (define-simple-proc custom-request-mode
      (((widget <gtk-widget>)) <gtk-size-request-mode> pure)
    'constant-size)

  (define-simple-proc custom-measure
      (((widget <gtk-widget>) (s-orientation <gtk-orientation>) (i-size <integer>))
       (:tuple <integer> <integer> <integer> <integer>) nonpure)
    ;; (log1 "custom-measure ENTER\n")
    (let ((widget-child
           (cast <gtk-widget> (gtk-frame-get-child (cast <gtk-frame> widget)))))
      (receive (minimum natural minimum-baseline natural-baseline)
               (measure widget-child s-orientation i-size)
               (begin
                ;; (log1 "custom-measure EXIT\n")
                (list minimum natural minimum-baseline natural-baseline)))))
  
  (define-simple-proc custom-allocate
      (((widget <gtk-widget>)
        (i-width <integer>)
        (i-height <integer>)
        (i-baseline <integer>))
       <none> nonpure)
    ;; (log1 "custom-allocate ENTER\n")
    (let ((child
           (cast <gtk-widget>
                 (gtk-frame-get-child (cast <gtk-frame> widget)))))
      (receive (child-width natural minimum-baseline natural-baseline)
               (measure child 'horizontal -1)
               (allocate child i-width i-height i-baseline
                         (transform1 i-width child-width)))
      ;; (log1 "custom-allocate EXIT\n")
      #f))
  
  (define-simple-method set-custom-layout-manager
      (((widget <gtk-widget>)) <none> nonpure)
    (set-layout-manager widget
                        (gtk-custom-layout-new custom-request-mode
                                               custom-measure
                                               custom-allocate)))
  
  (define-simple-method activate-my-app
      (((args (rest <object>))) <object> nonpure)
    (let* ((app (cast <gtk-application> (uniform-list-ref args 0)))
           (window (cast <gtk-window> (gtk-application-window-new app)))
           (frame (cast <gtk-frame> (gtk-frame-new "Frame")))
           (button (cast <gtk-button>
                         (gtk-button-new-with-label "Hello, World!"))))
      (set-custom-layout-manager frame)
      (slot-set! window 'width-request 400)
      (slot-set! window 'height-request 300)
      (gtk-window-set-child window frame)
      (gtk-frame-set-child frame button)
      (gtype-instance-signal-connect
       button 'clicked
       (lambda (((args (rest <object>))) <object> nonpure)
         (g-application-quit app)
         null))
      (gtk-window-present window)
      (gtk-widget-show button)
      #f))
  
  (define-main-proc (() <none> nonpure)
    (let* ((str-app-name "org.tohoyn.custom-layout-example")
           (app (gtk-application-new str-app-name null)))
      (g-set-prgname str-app-name)
      (gtype-instance-signal-connect
       app 'activate activate-my-app)
      (let ((status (run app null)))
        status))))
