;;;;
;;;; demos-utils.stk    -- Definition of useful things for GTKlos demos
;;;;
;;;; Copyright © 2001-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 24-Jul-2001 16:19 (eg)
;;;;


;;;; Adapt the load-path.
(when-load-and-compile
 (let ((path (load-path)))
   (unless (member "../lib" path)
     (load-path `("../lib"  ,@path)))))

;; Suppress some compilation warnings
;; FIXME: canvas-item-xxxx should be inferred.
(%compile-time-define %gtk-set-property gtk-text-view-set-buffer
                      canvas-item-rotate canvas-item-remove
                      canvas-item-animate
                      canvas-item-stop-animation alpha)

(import (stklos gtklos))

;;;;
;;;; Utilities
;;;;

;; A rather bad approximation of where the demo source file lives
(define *demo-path* (list "."
                          (string-append (%library-prefix)
                                         "/share/stklos/"
                                         (version)
                                         "/demos")))

#|
;; *user-code* is set to #t if the file is loaded a second time
;; That means that this is the user which tries its code
;; All this stuff permits to provide a different interface to the demo:
;; Our code has a "Quit" and "See code" buttons, whereas user demo
;; has only a "Close" button
|#
(define *user-code* (getenv "indemo"))
(setenv! "indemo" "1")  ;; to avoid returning #f next time

(define (eval-current-buffer txt)
  ;; Save the current buffer in a file and load it
  (let ((tmp (create-temp-file)))
    (text-write-file txt tmp)
    (load tmp)
    (main #f)
    (remove-file tmp)))


(define (demo-see-code file)
  (let* ((win (make <vwindow>
                    #:title (format #f "Code of the ~S Demo" file)
                    #:expand #f #:fill #f))
         (tb  (make <toolbar> #:parent win #:toolbar-style 'both))
         (txt (make <text> #:width 1000 #:height 600)))
    (container-add! win txt #:expand #t #:fill #t)

    ;; Add the eval button
    (make <toolbar-button-item> #:parent tb
          #:icon-name "system-run"
          #:text "Eval" 
          #:command (lambda _
                      (eprintf "*** EXECUTING USER CODE ***\n")
                      (eval-current-buffer txt)))
    ;; Add the Close button
    (make <toolbar-button-item> #:parent tb
          #:icon-name "application-exit"
          #:text "Close"
          #:command (lambda _ (destroy win)))

    ;; Read the text of the demo (skipping the copyrigth)
    (let* ((fn   (find-path (string-append file ".stk") *demo-path*))
           (port (and fn (open-file fn "r"))))
      (unless port
        (error 'demo-see-code
               "Cannot open source file `~A.stk' for this demo" file))

      ;; Do the reading
      (do ((l (read-line port) (read-line port)))
          ((or (eof-object? l) (string=? l "")))
        'skipping-copyright)

      (set! (value txt) (port->string port)))))





;;;; ======================================================================
;;;;
;;;;
;;;;            < d e m o - w i n d o w >   W i d g e t
;;;;
;;;; This widget is a replacement of the window widget for GTklos
;;;; demonstrations, it extends this class by providing a button to quit the
;;;; demo ans see its code.
;;;;
;;;; ======================================================================

(define-class <demo-window> (<window>)
  ((message     #:init-form #f #:init-keyword #:message)
   (file        #:init-form #f #:init-keyword #:file)
   (content     #:init-form #f)))


(define-method internal-arrange-widget ((self <demo-window>) initargs)
  (next-method)
  (let ((box (make <vbox> #:parent self))
        (msg (slot-ref self 'message)))

    ;; Create the top message, adding some fontification to make things prettier
    (when msg
      (let* ((lines (string-split msg "\n"))
             (txt   (string-append "<big><b>" (car lines) "</b></big>\n\n<i>")))
        (for-each (lambda (s)
                    (set! txt (string-append txt s "\n")))
                  (cdr lines))
        (set! txt (string-append txt "</i>"))
        (make <label> #:parent box #:text txt #:justify 'center)))

    ;; Create the separator and the bottom buttons
    (let ((sep  (make <separator>))
          (hbox (make <hbox> #:padding 4 #:expand #t #:fill #t)))
      (container-add! box hbox #:padding 3  #:end #t)
      (container-add! box sep  #:padding 10 #:end #t)

      (if *user-code*
          ;; This is user code
          ;; Create just a "Close" button
          (make <button> #:text "Close" #:parent hbox
                #:command (lambda (w ev) (destroy self)))
          (begin
            ;; This is the original demo code.
            ;; Create a "Quit" and "See code" buttons
            (make <button> #:text " Quit " #:parent hbox
                  #:command (lambda(w ev) (exit 0)))
            (make <button> #:text "See code" #:parent hbox
                  #:command (lambda (w ev) (demo-see-code (slot-ref self 'file)))))))

    ;; Connect a signal to terminate application when the window is closed
    (event-connect self
                  "delete-event"
                  (lambda (w e)
                    (eprintf "Bye ...\n")
                    (exit 0)))

    ;; Create a container for demo specific subwidgets
    (let ((content (make <vbox>  #:expand #t #:fill #t)))
      ;; Set it to the content slot *after* creation (tested by container-add!)
      (apply container-add! box content initargs)
      (slot-set! self 'content content))))


(define-method container-add! ((self <demo-window>) w . args)
  (let ((container (slot-ref self 'content)))
    (if container
        ;; If a container exists, that is that the widget is initialized and
        ;; that we are filling it with subwidgets which are demo-specific
        (apply container-add! container w args)
        ;; nothing special
        (next-method))))

(provide "demos-utils")

#|

Usage example:
==============

(define w (make <demo-window> #:title "This is a demo" #:width 400
                #:file "T100"
                #:message "
A Title

and a message which explains what is the demo for.
The message itself can be on
several lines
"))

(define b1 (make <button> #:text "Button 1" #:parent w))
(define b2 (make <button> #:text "Button 2" #:parent w))

|#
