#|
This file of "demostuff", used by the demo scripts, loads Gtk
and defines gapp, window, box, button, text, xtext, and xlabel.
  gapp      Establishes a Gtk app.  Its arguments are the app name
            and the code to be executed in the app.
  window    Establishes a window.  Its arguments are the name of
            the window object, the name of the app the window is
            used in, the window title, and the default width and
            height of the window.
  box       Establishes a box to place Gtk objects in.  Its three
            arguments are, first, h or v, for whether the contents
            of the box are to be organized horizontally or
            vertically, second, what box to establish, and third,
            what object the box is to be placed in.
  button    Establishes a button.  Its arguments are, what button
            to establish, the initial label text on the button,
            the object the button is to be placed in, and the code
            to be executed when the button is pressed.
  mbutton   Is like button, except the button label text will be
            left-aligned instead of centered.  It's for use in a
            column of buttons, such as a menu, where it might look
            neater to not center the button labels.
  text      Establishes a text display object, which Gtk calls a
            label.  Its arguments are the name of the text object,
            the initial text, and what object to place the text
            object in.
  xtext     Is a function to display some text in a text object.
            Its arguments are what text object to display the text
            in, and what text to display.
  xlabel    Is a function to update a button label.  Its arguments
            are the button and the new text.
|#

(load-shared-object "libgtk-3.so.0")

; Gtk relies on being able to divide by zero.  To prevent it from
; being an error, the following line changes the floating point
; errors to just overflow and invalid, and not division-by-zero.
; This isn't needed in most programming languages, because most
; of them default to having it not be an error.
(sb-int:set-floating-point-modes :traps '(:overflow :invalid))


; Gtk function prototypes: each has a code, such as xx or vxs.  The
; first letter of the code is the return value type, and the rest are
; the argument types:
; v = void
; x = void*
; i = int
; l = long
; f = float
; d = double
; s = c-string
; y = vxx function
(loop as (gfunc xx) in
  '((gtk_application_window_new  xx)
    (gtk_window_set_title        vxs)
    (gtk_window_set_default_size vxii)
    (gtk_button_box_new          xi)
    (gtk_size_group_new          xi)
    (gtk_bin_get_child           xx)
    (gtk_label_set_xalign        vxf)
    (gtk_container_add           vxx)
    (gtk_label_new               xs)
    (gtk_label_set_text          vxs)
    (gtk_button_set_label        vxs)
    (gtk_button_get_label        sx)
    (gtk_button_new_with_label   xs)
    (gtk_widget_destroy          xx)
    (gtk_application_new         xsi)
    (g_application_run           ixix)
    (g_object_unref              vx)
    (gtk_widget_show_all         vx)
    (g_signal_connect_data       lxsyxxi))
  as types = (loop as x across (string xx)
                  collect (ecase (char-downcase x)
                               (#\v 'void)
                               (#\x '(* t))
                               (#\i 'int)
                               (#\l 'long)
                               (#\f 'float)
                               (#\d 'double)
                               (#\s 'c-string)
                               (#\y '(function void (* t) (* t)))))
  as rv = (car types)
  as args = (loop as argname in '(a b c d e f g h i j k l m)
                  as argtype in (cdr types)
                  collect (list argname argtype))
  do (eval `(define-alien-routine ,gfunc ,rv ,@args)))


; callbackname makes a callback name from an object name.
; The eval-when makes it usable during macro expansions.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun callbackname (object)
    (intern (concatenate 'string (symbol-name object) "-CALLBACK"))))

; window establishes a Gtk window object.
; The arguments are, what window object to establish, what
; application the window is used in, the window title, and
; the width and height of the window.
(defmacro window (awin app title wid ht)
  (eval `(defparameter ,awin nil))
  `(progn
     (setf ,awin (gtk_application_window_new ,app))
     (gtk_window_set_title ,awin ,title)
     (gtk_window_set_default_size ,awin ,wid ,ht)))

; box establishes a box object.  The arguments are, whether the box
; contents are organized horizontally or vertically (h or v), what
; box is to be established, and what object to place the box in.
(defmacro box (hv abox placement)
  (eval `(defparameter ,abox nil))
  (let ((horizvert (case hv (h 0) (v 1) (t (error
         "The first argument to box should be h or v, not ~a" hv)))))
    `(progn
       (setf ,abox (gtk_button_box_new ,horizvert))
       (gtk_container_add ,placement ,abox))))

; button establishes a Gtk button object.  The arguments are,
; the name of the button object, the text shown on the button,
; what object to place the button in, and the action of the
; button, which can be any sequence of code.
(defmacro button (abutton buttonlabel placement &body body)
  (eval `(defparameter ,abutton nil))
  (let ((cb (callbackname abutton)))
    (eval `(sb-alien::define-alien-callback
             ,cb void ((a (* t)) (b (* t)))
             (declare (ignore a b))
             ,@body))
    `(progn
       (setf ,abutton (gtk_button_new_with_label ,buttonlabel))
       (g_signal_connect_data ,abutton "clicked" ,cb nil nil 0)
       (gtk_container_add ,placement ,abutton))))

; mbutton is like button, except that the button label text will be
; left aligned instead of centered, to make it neater in a column of
; buttons, such as for a menu.
(defmacro mbutton (abutton buttonlabel placement &body body)
  `(progn
     (button ,abutton ,buttonlabel ,placement ,@body)
     (let ((thelabel (gtk_bin_get_child ,abutton)))
       (gtk_label_set_xalign thelabel 0.0))))

; text establishes a Gtk "label" object which is actually a text
; display object.  The arguments are, what text object to
; establish, the initial text to display, and what object to
; place this text object in.
(defmacro text (atext text0 placement)
  (eval `(defparameter ,atext nil))
  `(progn
     (setf ,atext (gtk_label_new ,text0))
     (gtk_container_add ,placement ,atext)))

; xtext changes the text in a text object.
(defun xtext (textobject newtext)
  (gtk_label_set_text textobject newtext))

; xlabel changes the text label on a button.
(defun xlabel (button newtext)
  (gtk_button_set_label button newtext))

; gapp establishes a Gtk application.  The arguments are,
; the name of the application object, and the code to be
; executed by the application.
(defmacro gapp (theapp &body body)
  (eval `(defparameter ,theapp nil))
  (let ((cb (callbackname theapp)))
    (eval `(sb-alien::define-alien-callback
             ,cb void ((a (* t)) (b (* t)))
             (declare (ignore a b))
             ,@body))
    `(progn
       (setf ,theapp (gtk_application_new nil 0))
       (g_signal_connect_data ,theapp "activate" ,cb nil nil 0))))

; End of the demostuff file, which gets loaded by each demo script.