#include <gtk/gtk.h>

int main (int argc, char *argv[])
{
  GtkWidget *window;

  gtk_init (&argc, &argv);

  window = gtk_window_new (GTK_WINDOW_TOPLEVEL);

  g_signal_connect (window, "destroy", G_CALLBACK (gtk_main_quit), NULL);

  gtk_widget_show (window);

  gtk_main ();

  return 0;
}
    

;;;; Example Simple Window (2021-5-12)
;;;;
;;;; This example shows a very simple window. The program creates a 200 x 200
;;;; pixel window. In this case the window has the default title "sbcl". The
;;;; window can be sized and moved.

(in-package :gtk-example)

(defun example-window-simple ()
  (within-main-loop
    (let (;; Create a toplevel window.
          (window (gtk-window-new :toplevel)))
      ;; Signal handler for the window to handle the signal "destroy".
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Show the window.
      (gtk-widget-show-all window))))

    

;;;; Example Getting Started (2021-5-13)

(in-package :gtk-example)

(defun example-getting-started ()
  (within-main-loop
    (let (;; Create a toplevel window with a title and a default width.
          (window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Getting started"
                                 :default-width 250)))
      ;; Signal handler for the window to handle the signal "destroy".
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Show the window.
      (gtk-widget-show-all window))))

    

#include <gtk/gtk.h>

/* This is a callback function. The data arguments are ignored
 * in this example. More on callbacks below. */
static void hello( GtkWidget *widget, gpointer data )
{
    g_print ("Hello World\n");
}

static gboolean delete_event( GtkWidget *widget,
                              GdkEvent  *event,
                              gpointer   data )
{
    /* If you return FALSE in the "delete-event" signal handler,
     * GTK will emit the "destroy" signal. Returning TRUE means
     * you don't want the window to be destroyed.
     * This is useful for popping up 'are you sure you want to quit?'
     * type dialogs. */

    g_print ("delete event occurred\n");

    /* Change TRUE to FALSE and the main window will be destroyed with
     * a "delete-event". */

    return TRUE;
}

/* Another callback */
static void destroy( GtkWidget *widget, gpointer data )
{
    gtk_main_quit ();
}

int main( int argc, char *argv[] )
{
    /* GtkWidget is the storage type for widgets */
    GtkWidget *window;
    GtkWidget *button;

    /* This is called in all GTK applications. Arguments are parsed
     * from the command line and are returned to the application. */
    gtk_init (&argc, &argv);

    /* create a new window */
    window = gtk_window_new (GTK_WINDOW_TOPLEVEL);

    /* When the window is given the "delete-event" signal (this is given
     * by the window manager, usually by the "close" option, or on the
     * titlebar), we ask it to call the delete_event () function
     * as defined above. The data passed to the callback
     * function is NULL and is ignored in the callback function. */
    g_signal_connect (window, "delete-event",
		      G_CALLBACK (delete_event), NULL);

    /* Here we connect the "destroy" event to a signal handler.
     * This event occurs when we call gtk_widget_destroy() on the window,
     * or if we return FALSE in the "delete-event" callback. */
    g_signal_connect (window, "destroy",
		      G_CALLBACK (destroy), NULL);

    /* Sets the border width of the window. */
    gtk_container_set_border_width (GTK_CONTAINER (window), 10);

    /* Creates a new button with the label "Hello World". */
    button = gtk_button_new_with_label ("Hello World");

    /* When the button receives the "clicked" signal, it will call the
     * function hello() passing it NULL as its argument.  The hello()
     * function is defined above. */
    g_signal_connect (button, "clicked",
		      G_CALLBACK (hello), NULL);

    /* This will cause the window to be destroyed by calling
     * gtk_widget_destroy(window) when "clicked".  Again, the destroy
     * signal could come from here, or the window manager. */
    g_signal_connect_swapped (button, "clicked",
			      G_CALLBACK (gtk_widget_destroy),
                              window);

    /* This packs the button into the window (a gtk container). */
    gtk_container_add (GTK_CONTAINER (window), button);

    /* The final step is to display this newly created widget. */
    gtk_widget_show (button);

    /* and the window */
    gtk_widget_show (window);

    /* All GTK applications must have a gtk_main(). Control ends here
     * and waits for an event to occur (like a key press or
     * mouse event). */
    gtk_main ();

    return 0;
}
    

;;;; Example Hello World (2021-5-13)

(in-package :gtk-example)

(defun example-hello-world ()
  (within-main-loop
    (let (;; Create a toplevel window, set a border width.
          (window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Hello World"
                                 :default-width 250
                                 :border-width 12))
          ;; Create a button with a label.
          (button (make-instance 'gtk-button
                                 :label "Hello World")))
      ;; Signal handler for the button to handle the signal "clicked".
      (g-signal-connect button "clicked"
                        (lambda (widget)
                          (declare (ignore widget))
                          (format t "Hello world.~%")
                          (gtk-widget-destroy window)))
      ;; Signal handler for the window to handle the signal "destroy".
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Signal handler for the window to handle the signal "delete-event".
      (g-signal-connect window "delete-event"
                        (lambda (widget event)
                          (declare (ignore widget event))
                          (format t "Delete Event Occured.~%")
                          +gdk-event-stop+))
      ;; Put the button into the window.
      (gtk-container-add window button)
      ;; Show the window and the button.
      (gtk-widget-show-all window))))

    

#include <gtk/gtk.h>

/* Our new improved callback.  The data passed to this function
 * is printed to stdout. */
static void callback( GtkWidget *widget, gpointer data )
{
    g_print ("Hello again - %s was pressed\n", (gchar *) data);
}

/* another callback */
static gboolean delete_event( GtkWidget *widget,
                              GdkEvent  *event,
                              gpointer   data )
{
    gtk_main_quit ();
    return FALSE;
}

int main( int argc, char *argv[] )
{
    /* GtkWidget is the storage type for widgets */
    GtkWidget *window;
    GtkWidget *button;
    GtkWidget *box1;

    /* This is called in all GTK applications. Arguments are parsed
     * from the command line and are returned to the application. */
    gtk_init (&argc, &argv);

    /* Create a new window */
    window = gtk_window_new (GTK_WINDOW_TOPLEVEL);

    /* This is a new call, which just sets the title of our
     * new window to "Hello Buttons!" */
    gtk_window_set_title (GTK_WINDOW (window), "Hello Buttons!");

    /* Here we just set a handler for delete_event that immediately
     * exits GTK. */
    g_signal_connect (window, "delete-event",
		      G_CALLBACK (delete_event), NULL);

    /* Sets the border width of the window. */
    gtk_container_set_border_width (GTK_CONTAINER (window), 10);

    /* We create a box to pack widgets into.  This is described in detail
     * in the "packing" section. The box is not really visible, it
     * is just used as a tool to arrange widgets. */
    box1 = gtk_hbox_new (FALSE, 0);

    /* Put the box into the main window. */
    gtk_container_add (GTK_CONTAINER (window), box1);

    /* Creates a new button with the label "Button 1". */
    button = gtk_button_new_with_label ("Button 1");

    /* Now when the button is clicked, we call the "callback" function
     * with a pointer to "button 1" as its argument */
    g_signal_connect (button, "clicked",
		      G_CALLBACK (callback), (gpointer) "button 1");

    /* Instead of gtk_container_add, we pack this button into the invisible
     * box, which has been packed into the window. */
    gtk_box_pack_start (GTK_BOX(box1), button, TRUE, TRUE, 0);

    /* Always remember this step, this tells GTK that our preparation for
     * this button is complete, and it can now be displayed. */
    gtk_widget_show (button);

    /* Do these same steps again to create a second button */
    button = gtk_button_new_with_label ("Button 2");

    /* Call the same callback function with a different argument,
     * passing a pointer to "button 2" instead. */
    g_signal_connect (button, "clicked",
		      G_CALLBACK (callback), (gpointer) "button 2");

    gtk_box_pack_start(GTK_BOX (box1), button, TRUE, TRUE, 0);

    /* The order in which we show the buttons is not really important, but I
     * recommend showing the window last, so it all pops up at once. */
    gtk_widget_show (button);

    gtk_widget_show (box1);

    gtk_widget_show (window);

    /* Rest in gtk_main and wait for the fun to begin! */
    gtk_main ();

    return 0;
}
    

;;;; Example Upgraded Hello World (2021-5-13)

(in-package :gtk-example)

(defun example-hello-world-upgraded ()
  (within-main-loop
    (let ((window (gtk-window-new :toplevel))
          (box (gtk-box-new :horizontal 6))
          (button  nil))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (setf (gtk-window-title window) "Hello Buttons")
      (setf (gtk-window-default-size window) '(250 75))
      (setf (gtk-container-border-width window) 12)
      (setf button (gtk-button-new-with-label "Button 1"))
      (g-signal-connect button "clicked"
                        (lambda (widget)
                          (declare (ignore widget))
                          (format t "Button 1 pressed.~%")))
      (gtk-box-pack-start box button :expand t :fill t :padding 0)
      (setf button (gtk-button-new-with-label "Button 2"))
      (g-signal-connect button "clicked"
                        (lambda (widget)
                          (declare (ignore widget))
                          (format t "Button 2 pressed.~%")))
      (gtk-box-pack-start box button :expand t :fill t :padding 0)
      (gtk-container-add window box)
      (gtk-widget-show-all window))))

    

;;;; Example Upgraded Hello World (2021-5-13)
;;;;
;;;; A second, more Lisp like implementation.

(in-package :gtk-example)

(defun example-hello-world-upgraded-2 ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Hello Buttons"
                                 :default-width 250
                                 :default-height 75
                                 :border-width 12))
          (box (make-instance 'gtk-box
                              :orientation :horizontal
                              :spacing 6)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (let ((button (gtk-button-new-with-label "Button 1")))
        (g-signal-connect button "clicked"
                          (lambda (widget)
                            (declare (ignore widget))
                            (format t "Button 1 pressed.~%")))
        (gtk-box-pack-start box button))
      (let ((button (gtk-button-new-with-label "Button 2")))
        (g-signal-connect button "clicked"
                          (lambda (widget)
                            (declare (ignore widget))
                            (format t "Button 2 pressed.~%")))
        (gtk-box-pack-start box button))
      (gtk-container-add window box)
      (gtk-widget-show-all window))))

    

;;;; Example Drawing in response to input (2021-5-13)

(in-package :gtk-example)

(defun example-drawing-area-input ()
  (within-main-loop
    (let ((surface nil)
          (window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Drawing"))
          (area (make-instance 'gtk-drawing-area
                               :width-request 320
                               :height-request 240)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Signals used to handle the backing surface
      (g-signal-connect area "draw"
         (lambda (widget cr)
           (declare (ignore widget))
           (let ((cr (pointer cr)))
             (cairo-set-source-surface cr surface 0.0 0.0)
             (cairo-paint cr)
             (cairo-destroy cr)
             +gdk-event-propagate+)))
      (g-signal-connect area "configure-event"
         (lambda (widget event)
           (declare (ignore event))
           (when surface
             (cairo-surface-destroy surface))
           (setf surface
                 (gdk-window-create-similar-surface
                                 (gtk-widget-window widget)
                                 :color
                                 (gtk-widget-allocated-width widget)
                                 (gtk-widget-allocated-height widget)))
           ;; Clear surface
           (let ((cr (cairo-create surface)))
             (cairo-set-source-rgb cr 1.0 1.0 1.0)
             (cairo-paint cr)
             (cairo-destroy cr))
           (format t "leave event 'configure-event'~%")
           +gdk-event-stop+))
      ;; Event signals
      (g-signal-connect area "motion-notify-event"
         (lambda (widget event)
           (format t "MOTION-NOTIFY-EVENT ~A~%" event)
           (when (member :button1-mask (gdk-event-motion-state event))
             (let ((cr (cairo-create surface))
                   (x (gdk-event-motion-x event))
                   (y (gdk-event-motion-y event)))
               (cairo-rectangle cr (- x 3.0) (- y 3.0) 6.0 6.0)
               (cairo-fill cr)
               (cairo-destroy cr)
               (gtk-widget-queue-draw-area widget
                                           (truncate (- x 3.0))
                                           (truncate (- y 3.0))
                                           6
                                           6)))
           ;; We have handled the event, stop processing
           +gdk-event-stop+))
      (g-signal-connect area "button-press-event"
         (lambda (widget event)
           (format t "BUTTON-PRESS-EVENT ~A~%" event)
           (if (= 1 (gdk-event-button-button event))
               (let ((cr (cairo-create surface))
                     (x (gdk-event-button-x event))
                     (y (gdk-event-button-y event)))
                 (cairo-rectangle cr (- x 3.0) (- y 3.0) 6.0 6.0)
                 (cairo-fill cr)
                 (cairo-destroy cr)
                 (gtk-widget-queue-draw-area widget
                                             (truncate (- x 3.0))
                                             (truncate (- y 3.0))
                                             6
                                             6))
               ;; Clear surface
               (let ((cr (cairo-create surface)))
                 (cairo-set-source-rgb cr 1.0 1.0 1.0)
                 (cairo-paint cr)
                 (cairo-destroy cr)
                 (gtk-widget-queue-draw widget)))))
      (gtk-widget-add-events area
                             '(:button-press-mask
                               :pointer-motion-mask))
      (gtk-container-add window area)
      (gtk-widget-show-all window))))

    

;;;; Example Simple Box (2021-5-15)
;;;;
;;;; The example shows three buttons with colored labels. The red button
;;;; shows the start position in the box, the green button the end position,
;;;; and the yellow button is a center widget.
;;;;
;;;; In addition, this example demonstrate how to use CSS style information to
;;;; change the appearance of a widget.

(in-package :gtk-example)

(defparameter +css-button+
"button {
   padding: 3px; }
 button > label {
   color: black;
   background-color: yellow; }
 button:first-child > label {
   background-color: red; }
 button:last-child > label {
   background-color : green; }")

(defun apply-css-to-widget (provider widget)
  (gtk-style-context-add-provider (gtk-widget-style-context widget)
                                  provider
                                  +gtk-style-provider-priority-application+)
  (when (g-type-is-a (g-type-from-instance widget) "GtkContainer")
    (gtk-container-forall widget
                          (lambda (widget)
                            (apply-css-to-widget provider widget)))))

(defun example-box-simple ()
  (within-main-loop
    (let (;; Create a toplevel window
          (window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Simple Box"
                                 :border-width 12))
          ;; Create a box
          (box (make-instance 'gtk-box
                              :orientation :horizontal
                              :homogeneous nil
                              :spacing 0
                              :halign :fill
                              :valign :center
                              :width-request 480))
          (provider (make-instance 'gtk-css-provider)))

      ;; Signal handler for the window to handle the signal "destroy".
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))

      ;; Add Start button
      (let ((button (make-instance 'gtk-button
                                   :label "START")))
        (setf (gtk-widget-width-request (gtk-bin-child button)) 120)
        (setf (gtk-widget-height-request (gtk-bin-child button)) 120)
        (gtk-box-pack-start box button :expand nil))
      ;; Add Center button
      (let ((button (make-instance 'gtk-button
                                   :label "CENTER")))
        (setf (gtk-widget-width-request (gtk-bin-child button)) 80)
        (setf (gtk-box-center-widget box) button))
      ;; Add End button
      (let ((button (make-instance 'gtk-button
                                   :label "END")))
        (setf (gtk-widget-width-request (gtk-bin-child button)) 60)
        (gtk-box-pack-end box button :expand nil))

      ;; Add the box to the window.
      (gtk-container-add window box)
      ;; Load CSS from data into the provider
      (gtk-css-provider-load-from-data provider +css-button+)
      ;; Apply CSS to the widgets
      (apply-css-to-widget provider box)
      ;; Show the window.
      (gtk-widget-show-all window))))

    

;;;; Example Box Packing (2021-5-14)

(in-package :gtk-example)

(defun make-box (homogeneous spacing expand fill padding)
  (let ((box (make-instance 'gtk-box
                            :orientation :horizontal
                            :homogeneous homogeneous
                            :spacing spacing)))
    (gtk-box-pack-start box
                        (gtk-button-new-with-label "gtk-box-pack")
                        :expand expand
                        :fill fill
                        :padding padding)
    (gtk-box-pack-start box
                        (gtk-button-new-with-label "box")
                        :expand expand
                        :fill fill
                        :padding padding)
    (gtk-box-pack-start box
                        (gtk-button-new-with-label "child")
                        :expand expand
                        :fill fill
                        :padding padding)
    (gtk-box-pack-start box
                        (if expand
                            (gtk-button-new-with-label "T")
                            (gtk-button-new-with-label "NIL"))
                        :expand expand
                        :fill fill
                        :padding padding)
    (gtk-box-pack-start box
                        (if fill
                            (gtk-button-new-with-label "T")
                            (gtk-button-new-with-label "NIL"))
                        :expand expand
                        :fill fill
                        :padding padding)
    box))

(defun example-box-packing (&optional (spacing 6) (padding 0))
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :title "Example Box Packing"
                                 :type :toplevel
                                 :border-width 12))
          (vbox (make-instance 'gtk-box
                               :orientation :vertical
                               :spacing 12)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Non-homogenous boxes
      (gtk-box-pack-start vbox
                          (make-instance 'gtk-label
                                         :use-markup t
                                         :label "<b>Non-homogeneous boxes</b>"
                                         :xalign 0)
                          :expand nil)
      (gtk-box-pack-start vbox
                          (make-box nil spacing nil nil padding)
                          :expand nil)
      (gtk-box-pack-start vbox
                          (make-box nil spacing t nil padding)
                          :expand nil)
      (gtk-box-pack-start vbox
                          (make-box nil spacing t t padding)
                          :expand nil)
      ;; Homogeneous boxes
      (gtk-box-pack-start vbox
                          (make-instance 'gtk-label
                                         :use-markup t
                                         :label "<b>Homogeneous boxes</b>"
                                         :xalign 0)
                          :expand nil)
      (gtk-box-pack-start vbox
                          (make-box t spacing t nil padding)
                          :expand nil)
      (gtk-box-pack-start vbox
                          (make-box t spacing t t padding)
                          :expand nil)
      (gtk-container-add window vbox)
      (gtk-widget-show-all window))))

    

;;;; Example Simple Grid (2021-5-15)

(in-package :gtk-example)

(defun example-grid-simple ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Simple Grid"
                                 :border-width 12
                                 :default-width 320))
          (grid (make-instance 'gtk-grid
                               :column-homogeneous t
                               :column-spacing 6
                               :row-homogeneous t
                               :row-spacing 6))
          (button1 (make-instance 'gtk-button
                                  :label "Button 1"))
          (button2 (make-instance 'gtk-button
                                  :label "Button 2"))
          (button3 (make-instance 'gtk-button
                                  :label "Button 3")))

      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))

      (gtk-grid-attach grid button1 0 0 1 1)
      (gtk-grid-attach grid button2 1 0 1 1)
      (gtk-grid-attach grid button3 0 1 2 1)

      (gtk-container-add window grid)
      (gtk-widget-show-all window))))

    

;;;; Example Grid Spacing (2021-5-18)

(in-package :gtk-example)

(defun example-grid-spacing ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Grid Spacing"
                                 :border-width 12
                                 :default-width 320))
          (grid (make-instance 'gtk-grid
                               :column-homogeneous t
                               :column-spacing 6
                               :row-homogeneous t
                               :row-spacing 6))
          (button1 (make-instance 'gtk-toggle-button
                                  :label "More Row Spacing"))
          (button2 (make-instance 'gtk-toggle-button
                                  :label "More Col Spacing"))
          (button3 (make-instance 'gtk-button
                                  :label "Button 3")))

      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))

      (g-signal-connect button1 "toggled"
         (lambda (widget)
           (if (gtk-toggle-button-active widget)
               (progn
                 (setf (gtk-grid-row-spacing grid) 24)
                 (setf (gtk-button-label widget) "Less Row Spacing"))
               (progn
                 (setf (gtk-grid-row-spacing grid) 6)
                 (setf (gtk-button-label widget) "More Row Spacing")))))
      (g-signal-connect button2 "toggled"
         (lambda (widget)
           (if (gtk-toggle-button-active widget)
               (progn
                 (setf (gtk-grid-column-spacing grid) 24)
                 (setf (gtk-button-label widget) "Less Col Spacing"))
               (progn
                 (setf (gtk-grid-column-spacing grid) 6)
                 (setf (gtk-button-label widget) "More Col Spacing")))))

      (gtk-grid-attach grid button1 0 0 1 1)
      (gtk-grid-attach grid button2 1 0 1 1)
      (gtk-grid-attach grid button3 0 1 2 1)

      (gtk-container-add window grid)
      (gtk-widget-show-all window))))

    

;;;; Example Simple Button (2021-5-19)

(in-package :gtk-example)

(defun image-label-box (filename text)
  (let ((box (make-instance 'gtk-box
                            :orientation :horizontal
                            :border-width 3))
        (label (make-instance 'gtk-label
                              :hexpand nil
                              :margin-left 6
                              :label text))
        (image (gtk-image-new-from-file filename)))
    (gtk-box-pack-start box image :expand nil :fill nil :padding 3)
    (gtk-box-pack-start box label :expand nil :fill nil :padding 3)
    box))

(defun example-button-image ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :title "Example Button"
                                 :type :toplevel
                                 :default-width 240
                                 :default-height 120))
          (button (make-instance 'gtk-button
                                 :halign :center
                                 :valign :center))
          (box (image-label-box (sys-path "save.png") "Save to File")))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-container-add button box)
      (gtk-container-add window button)
      (gtk-widget-show-all window))))

    

;;;; Example More Buttons (2021-5-19)

(in-package :gtk-example)

(defun example-button-more ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :title "Example More Buttons"
                                 :type :toplevel
                                 :default-width 300
                                 :default-height 180
                                 :border-width 12))
          (grid (make-instance 'gtk-grid
                               :halign :center
                               :valign :center
                               :column-spacing 9
                               :row-spacing 9)))

      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))

      ;; These are the standard functions to create a button
      (gtk-grid-attach grid
                       (gtk-button-new-with-label "Label")
                       0 0 1 1)
      (gtk-grid-attach grid
                       (gtk-button-new-with-mnemonic "_Mnemonic")
                       0 1 1 1)
      (gtk-grid-attach grid
                       (gtk-button-new-from-icon-name "gtk-apply" :button)
                       0 2 1 1)

      ;; Create some buttons with make-instance
      (gtk-grid-attach grid
                       (make-instance 'gtk-button
                                      :image-position :left
                                      :always-show-image t
                                      :image
                                      (make-instance 'gtk-image
                                                     :icon-name "gtk-edit")
                                      :label "Bearbeiten")
                       1 0 1 1)
      (gtk-grid-attach grid
                       (make-instance 'gtk-button
                                      :image-position :top
                                      :always-show-image t
                                      :image
                                      (make-instance 'gtk-image
                                                     :icon-name "gtk-cut")
                                      :label "Ausschneiden")
                       1 1 1 1)
      (gtk-grid-attach grid
                       (make-instance 'gtk-button
                                      :image-position :bottom
                                      :always-show-image t
                                      :image
                                      (make-instance 'gtk-image
                                                     :icon-name "gtk-cancel")
                                      :label "Abbrechen")
                       1 2 1 1)

      (gtk-container-add window grid)
      (gtk-widget-show-all window))))

    

;;;; Link button (2021-5-20)

(in-package :gtk-example)

(defun example-link-button ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Link Button"
                                 :default-width 280
                                 :border-width 18))
          (grid (make-instance 'gtk-grid
                               :orientation :vertical
                               :row-spacing 6
                               :column-homogeneous t)))
      (g-signal-connect window "destroy"
                               (lambda (widget)
                                 (declare (ignore widget))
                                 (leave-gtk-main)))
      (gtk-container-add grid
                         (make-instance 'gtk-label
                                        :use-markup t
                                        :label
                                        "<b>Link Button with url</b>"))
      (gtk-container-add grid
                         (gtk-link-button-new "http://www.gtk.org/"))
      (gtk-container-add grid
                         (make-instance 'gtk-label
                                        :margin-top 12
                                        :use-markup t
                                        :label
                                        "<b>Link Button with Label</b>"))
      (gtk-container-add grid
                         (gtk-link-button-new-with-label "http://www.gtk.org/"
                                                         "Project WebSite"))
      (gtk-container-add window grid)
      (gtk-widget-show-all window))))

    

;;;; Example Switch (2021-5-20)

(in-package :gtk-example)

(defun example-switch ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Switch"
                                 :default-width 250
                                 :border-width 24))
          (switch (make-instance 'gtk-switch
                                 :active t))
          (label (make-instance 'gtk-label
                                :xalign 0.0
                                :label "Switch is On"))
          (grid (make-instance 'gtk-grid
                               :orientation :horizontal
                               :halign :center
                               :valign :center
                               :column-spacing 24)))

      (g-signal-connect window "destroy"
                               (lambda (widget)
                                 (declare (ignore widget))
                                 (leave-gtk-main)))

      (g-signal-connect switch "notify::active"
         (lambda (widget param)
           (declare (ignore param))
           (if (gtk-switch-active widget)
               (setf (gtk-label-label label) "Switch is On")
               (setf (gtk-label-label label) "Switch is Off"))))

      (gtk-container-add grid switch)
      (gtk-container-add grid label)
      (gtk-container-add window grid)
      (gtk-widget-show-all window))))

     

;;;; Example Scale Button (2021-4-27)

(in-package :gtk-example)

(defun example-scale-button ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Scale Button"
                                 :border-width 12
                                 :width-request 360
                                 :height-request 240))
          (button (make-instance 'gtk-scale-button
                                 :margin-left 60
                                 :size 6
                                 :value 9.0
                                 :icons
                                 '("face-crying"     ; lowest value
                                   "face-smile-big"  ; highest value
                                   "face-sad"        ; other value between
                                   "face-worried"
                                   "face-uncertain"
                                   "face-plain"
                                   "face-smile")
                                 :adjustment
                                 (make-instance 'gtk-adjustment
                                                :lower 0.0
                                                :upper 10.0
                                                :step-increment 1.0
                                                :page-increment 2.0))))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Pack and show the widgets
      (gtk-container-add window button)
      (gtk-widget-show-all window))))

    

<object class="GtkLabel">
  <attributes>
    <attribute name="weight" value="PANGO_WEIGHT_BOLD"/>
    <attribute name="background" value="red" start="5" end="10"/>"
  </attributes>
</object>
     

;;;; Example Labels (2021-5-21)

(in-package :gtk-example)

(defparameter *label-text-1* "This is a normal label.")
(defparameter *label-text-2*
              (format nil "This is a multiline label.~%~
                           Second line.~%~
                           Third line."))
(defparameter *label-text-3*
              (format nil
                      "This is a center justified~%~
                       multiline label.~%~
                       Third line."))
(defparameter *label-text-4*
              (format nil
                      "This is a right justified~%~
                       multiline label.~%~
                       Third line."))
(defparameter *label-text-5*
              (format nil
                      "This label is underlined.~%~%~
                       This label is underlined~%~
                       in quite a funky fashion."))
(defvar *lorem-ipsum-short*
        (format nil "Lorem ipsum dolor sit amet, consectetur adipiscing elit. ~
Nunc scelerisque aliquam dui id ullamcorper. Sed placerat felis sed aliquam ~
sodales. Cras et ultricies nulla. Nullam ipsum ante, gravida vel malesuada ac, ~
sollicitudin eu diam. Morbi pellentesque elit et odio hendrerit dignissim. ~
Maecenas sagittis auctor leo a dictum. Sed at auctor."))

(defparameter *label-pattern*
  "_________________________ _ _________ _ ______     __ _______ ___")


(defun make-heading (text)
  (make-instance 'gtk-label
                 :xalign 0
                 :margin-top 6
                 :use-markup t
                 :label (format nil "<b>~A</b>" text)))

(defun example-label ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Labels"
                                 :default-width 250
                                 :border-width 18))
          (vbox1 (make-instance 'gtk-box
                                :orientation :vertical
                                :spacing 6))
          (vbox2 (make-instance 'gtk-box
                                :orientation :vertical
                                :spacing 6))
          (hbox (make-instance 'gtk-box
                               :orientation :horizontal
                               :spacing 24)))
      ;; Connect a handler for the signal "destroy" to window.
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Create a Normal Label
      (gtk-box-pack-start vbox1
                          (make-heading "Normal Label")
                          :expand nil)
      (gtk-box-pack-start vbox1
                          (make-instance 'gtk-label
                                         :label *label-text-1*)
                          :expand nil)
      ;; Create a Multi-line Label
      (gtk-box-pack-start vbox1
                          (make-heading "Multiline Label")
                          :expand nil)
      (gtk-box-pack-start vbox1
                          (make-instance 'gtk-label
                                         :label *label-text-2*)
                          :expand nil)
      ;; Create a Left Justified Label
      (gtk-box-pack-start vbox1
                          (make-heading "Center Justified Label")
                          :expand nil)
      (gtk-box-pack-start vbox1
                          (make-instance 'gtk-label
                                         :justify :center
                                         :label *label-text-3*)
                          :expand nil)
      ;; Create a Right Justified Label
      (gtk-box-pack-start vbox1
                          (make-heading "Right Justified Label")
                          :expand nil)
      (gtk-box-pack-start vbox1
                          (make-instance 'gtk-label
                                         :justify :right
                                         :label *label-text-4*)
                          :expand nil)
      ;; Create an underlined label
      (gtk-box-pack-start vbox1
                          (make-heading "Underlined Label")
                          :expand nil)
      (gtk-box-pack-start vbox1
                          (make-instance 'gtk-label
                                         :justify :left
                                         :use-underline t
                                         :pattern *label-pattern*
                                         :label *label-text-5*)
                          :expand nil)

      ;; Create a Line wrapped label
      (gtk-box-pack-start vbox2
                          (make-heading "Line Wrapped Label")
                          :expand nil)
      (gtk-box-pack-start vbox2
                          (make-instance 'gtk-label
                                         :wrap t
                                         :label *lorem-ipsum-short*)
                          :expand nil)
      ;; Create a Filled and wrapped label
      (gtk-box-pack-start vbox2
                          (make-heading "Filled and Wrapped Label")
                          :expand nil)
      (gtk-box-pack-start vbox2
                          (make-instance 'gtk-label
                                         :wrap t
                                         :justify :fill
                                         :label *lorem-ipsum-short*)
                          :expand nil)

      ;; Put the boxes into the window and show the window
      (gtk-box-pack-start hbox vbox1 :expand nil)
      (gtk-box-pack-start hbox (gtk-separator-new :vertical))
      (gtk-box-pack-start hbox vbox2 :expand nil)
      (gtk-container-add window hbox)
      (gtk-widget-show-all window))))

    

;;;; Example More Labels (2021-5-21)

(in-package :gtk-example)

(defun example-label-more ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example More Labels"
                                 :default-width 300
                                 :border-width 12))
          (vbox1 (make-instance 'gtk-box
                                :orientation :vertical
                                :homogeneous nil
                                :spacing 6))
          (vbox2 (make-instance 'gtk-box
                                :orientation :vertical
                                :homogeneous nil
                                :spacing 6))
          (hbox (make-instance 'gtk-box
                               :orientation :horizontal
                               :homogeneous nil
                               :spacing 6)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-box-pack-start hbox
                          (make-instance 'gtk-label
                                         :label "Angle 90°"
                                         :angle 90))
      (gtk-box-pack-start vbox1
                          (make-instance 'gtk-label
                                         :label "Angel 45°"
                                         :angle 45))
      (gtk-box-pack-start vbox1
                          (make-instance 'gtk-label
                                         :label "Angel 315°"
                                         :angle 315))
      (gtk-box-pack-start hbox vbox1)
      (gtk-box-pack-start hbox
                          (make-instance 'gtk-label
                                         :label "Angel 270°"
                                         :angle 270))
      (gtk-box-pack-start vbox2 hbox)
      (gtk-box-pack-start vbox2
                          (make-instance 'gtk-separator
                                         :orientation :horizontal))
      (gtk-box-pack-start vbox2
                          (gtk-label-new "Normal Label"))
      (gtk-box-pack-start vbox2
                          (gtk-label-new-with-mnemonic "With _Mnemonic"))
      (gtk-box-pack-start vbox2
                          (make-instance 'gtk-label
                                         :label "This Label is Selectable"
                                         :selectable t))
      (gtk-box-pack-start vbox2
                          (make-instance 'gtk-label
                                         :label
                                         "<small>Small text</small>"
                                          :use-markup t))
      (gtk-box-pack-start vbox2
                          (make-instance 'gtk-label
                                         :label
                                         "<b>Bold text</b>"
                                          :use-markup t))
      (gtk-box-pack-start vbox2
                          (make-instance 'gtk-label
                                         :use-markup t
                                         :label
                                         (format nil
                                         "Go to the ~
                                         <a href=\"http://gtk.org/\">~
                                         GTK+ Website</a> for more ...")))
      (gtk-container-add window vbox2)
      (gtk-widget-show-all window))))


    

;;;; Example Image Widgets (2021-5-23)
;;;;
;;;; GtkImage is used to display an image. The image can be in a number of
;;;; formats. Typically, you load an image into a GdkPixbuf, then display the
;;;; pixbuf.
;;;;
;;;; This demo code shows some of the more obscure cases, in the simple case a
;;;; call to the function gtk-image-new-from-file is all you need.

(in-package :gtk-example)

(let ((pixbuf-loader nil)
      (image-stream nil))

  (defun progressive-timeout (image)
    (if image-stream
        (let* ((buffer (make-array 128 :element-type '(unsigned-byte 8)))
               (len (read-sequence buffer image-stream)))
          (if (= 0 len)
              ;; We have reached the end of the file.
              (progn
                (close image-stream)
                (setf image-stream nil)
                (gdk-pixbuf-loader-close pixbuf-loader)
                (setf pixbuf-loader nil)
                (return-from progressive-timeout +g-source-remove+))
              ;; Load the buffer into GdkPixbufLoader
              (gdk-pixbuf-loader-write pixbuf-loader buffer 128)))
        (progn
          ;; Create the image stream and the GdkPixbufLoader
          (setf image-stream
                (open (sys-path "alphatest.png")
                      :element-type '(unsigned-byte 8)))
          (when pixbuf-loader
            (gdk-pixbuf-loader-close pixbuf-loader)
            (setf pixbuf-loader nil))
          (setf pixbuf-loader (gdk-pixbuf-loader-new))
          (g-signal-connect pixbuf-loader "area-prepared"
             (lambda (loader)
               (let ((pixbuf (gdk-pixbuf-loader-pixbuf loader)))
                 (gdk-pixbuf-fill pixbuf #xaaaaaaff)
                 (gtk-image-set-from-pixbuf image pixbuf))))
          (g-signal-connect pixbuf-loader "area-updated"
             (lambda (loader x y width height)
               (declare (ignore loader x y width height))
               ;; We know the pixbuf inside the GtkImage has changed, but the
               ;; image itself does not know this. So give it a hint by setting
               ;; the pixbuf again. Queuing a redraw used to be sufficient, but
               ;; nowadays GtkImage uses GtkIconHelper which caches the pixbuf
               ;; state and will just redraw from the cache.
               (let ((pixbuf (gtk-image-pixbuf image)))
                 (gtk-image-set-from-pixbuf image pixbuf))))))
    ;; Continue the GSource
    +g-source-continue+)

  (defun example-image ()
    (within-main-loop
      (let* ((timeout nil)
             (window (make-instance 'gtk-window
                                    :type :toplevel
                                    :title "Example Image Widgets"
                                    :default-width 320
                                    :border-width 12))
             (vgrid (make-instance 'gtk-grid
                                   :orientation :vertical
                                   :row-spacing 6)))

        (g-signal-connect window "destroy"
                          (lambda (widget)
                            (declare (ignore widget))
                            ;; Destroy the timeout source
                            (when timeout
                              (g-source-remove timeout)
                              (setf timeout nil))
                            ;; Close the GdkPixbufLoader object
                            (when pixbuf-loader
                              (gdk-pixbuf-loader-close pixbuf-loader)
                              (setf pixbuf-loader nil))
                            ;; Close open input stream
                            (when image-stream
                              (close image-stream)
                              (setf image-stream nil))
                            (leave-gtk-main)))

        ;; Image loaded from a file
        (let* ((label (make-instance 'gtk-label
                                     :margin-top 9
                                     :margin-bottom 6
                                     :use-markup t
                                     :label
                                     "<b>Image loaded from a file</b>"))
               (pixbuf (gdk-pixbuf-new-from-file (sys-path "gtk3-demo.png")))
               (image (gtk-image-new-from-pixbuf pixbuf)))
          (gtk-container-add vgrid label)
          (gtk-container-add vgrid image))

        ;; Animation loaded from a file
        (let* ((label (make-instance 'gtk-label
                                     :margin-top 9
                                     :margin-bottom 6
                                     :use-markup t
                                     :label
                                     "<b>Animation loaded from a file</b>"))
               (image (gtk-image-new-from-file (sys-path "spinner.gif"))))
          (gtk-container-add vgrid label)
          (gtk-container-add vgrid image))

        ;; Symbolic icon
        (let* ((label (make-instance 'gtk-label
                                     :margin-top 9
                                     :margin-bottom 6
                                     :use-markup t
                                     :label
                                     "<b>Symbolic themed icon</b>"))
               (gicon (g-themed-icon-new-with-default-fallbacks
                          "battery-caution-charging-symbolic"))
               (image (gtk-image-new-from-gicon gicon :dialog)))
          (gtk-container-add vgrid label)
          (gtk-container-add vgrid image))

        ;; Progressive loading
        (let* ((label (make-instance 'gtk-label
                                     :margin-top 18
                                     :justify :center
                                     :use-markup t
                                     :label
                                     (format nil
                                             "<b>Progressive image loading</b>~
                                              ~%Click to repeat loading")))
               (frame (make-instance 'gtk-frame
                                     :shadow-type :none
                                     :width-request 340
                                     :height-request 220))
               (event-box (make-instance 'gtk-event-box))
               ;; Create an empty image for now. The progressive loader will
               ;; create the pixbuf and fill it in.
               (image (gtk-image-new-from-pixbuf nil)))

          ;; This is obviously totally contrived (we slow down loading on
          ;; purpose to show how incremental loading works). The real purpose
          ;; of incremental loading is the case where you are reading data from
          ;; a slow source such as the network. The timeout simply simulates a
          ;; slow data source by inserting pauses in the reading process.
          (setf timeout
                (g-timeout-add 100 (lambda () (progressive-timeout image))))

          ;; Restart loading the image from the file
          (g-signal-connect event-box "button-press-event"
             (lambda (widget event)
               (declare (ignore widget))
               (format t "Event Box clicked at (~,2f, ~,2f)~%"
                         (gdk-event-button-x event)
                         (gdk-event-button-y event))
               (setf timeout
                     (g-timeout-add 100
                                    (lambda () (progressive-timeout image))))))
          (gtk-container-add vgrid label)
          (gtk-container-add event-box image)
          (gtk-container-add frame event-box)
          (gtk-container-add vgrid frame))

        (gtk-container-add window vgrid)
        (gtk-widget-show-all window)))))

    

;;;; Example Info Bar (2021-5-24)

(in-package :gtk-example)

(defun example-info-bar ()
  (within-main-loop
    (let* ((window (make-instance 'gtk-window
                                  :type :toplevel
                                  :title "Example Info bar"
                                  :border-width 12
                                  :default-width 250))
           (grid (make-instance 'gtk-grid
                                :orientation :vertical))
           (info-bar (make-instance 'gtk-info-bar
                                    :no-show-all t))
           (message (make-instance 'gtk-label
                                   :label ""))
           (content (gtk-info-bar-content-area info-bar)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-widget-show message)
      ;; Add a label to the content area of the info bar
      (gtk-container-add content message)
      ;; Add a button OK to the action area
      (gtk-info-bar-add-button info-bar "gtk-ok" 1)
      ;; Add two more buttons to the action area
      (gtk-info-bar-add-buttons info-bar "gtk-cancel" 2
                                         "gtk-no" 3)
      ;; Connect a handler for the "response" signal of the info bar
      (g-signal-connect info-bar "response"
         (lambda (widget response-id)
           (declare (ignore widget))
           (format t "response-id is ~A~%" response-id)
           (gtk-widget-hide info-bar)))
      (gtk-container-add grid info-bar)
      ;; Show the info bar
      (setf (gtk-label-text message) "An Info Message in the content area.")
      (setf (gtk-info-bar-message-type info-bar) :info)
      (gtk-widget-show info-bar)
      ;; Add the container grid to the window and show all
      (gtk-container-add window grid)
      (gtk-widget-show-all window))))

    

;;;; Example Progress Bar (2021-5-2)

(in-package :gtk-example)

(defstruct pbar
  widget
  timer
  mode)

(defun progress-bar-timeout (pdata)
  (if (pbar-mode pdata)
      (gtk-progress-bar-pulse (pbar-widget pdata))
      (let ((val (+ (gtk-progress-bar-fraction (pbar-widget pdata))
                    0.01)))
        (when (> val 1.0) (setq val 0.0))
        (setf (gtk-progress-bar-fraction (pbar-widget pdata)) val)))
  +g-source-continue+)

(defun example-progress-bar ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Progress Bar"
                                 :default-width 320))
          (pdata (make-pbar :widget (make-instance 'gtk-progress-bar)))
          (vbox (make-instance 'gtk-box
                               :orientation :vertical
                               :border-width 12
                               :spacing 6)))

      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (g-source-remove (pbar-timer pdata))
                          (setf (pbar-timer pdata) 0)
                          (leave-gtk-main)))

      (let ((provider (gtk-css-provider-new))
            (context (gtk-widget-style-context (pbar-widget pdata)))
            (css-data "progressbar > trough,
                       progressbar > trough > progress {
                           min-height : 24px; }"))
         (gtk-css-provider-load-from-data provider css-data)
         (gtk-style-context-add-provider context
                                         provider
                                         +gtk-style-provider-priority-application+))

      (setf (pbar-timer pdata)
            (g-timeout-add 100
                           (lambda ()
                             (progress-bar-timeout pdata))))

      (gtk-box-pack-start vbox
                          (make-instance 'gtk-label
                                         :use-markup t
                                         :xalign 0.0
                                         :label
                                         "<b>Progress bar</b>"))

      (gtk-box-pack-start vbox (pbar-widget pdata))

      (gtk-box-pack-start vbox
                          (make-instance 'gtk-label
                                         :use-markup t
                                         :xalign 0.0
                                         :margin-top 12
                                         :label
                                         "<b>Change properties</b>"))

      (let ((check (gtk-check-button-new-with-label "Show text")))
        (g-signal-connect check "clicked"
           (lambda (widget)
             (declare (ignore widget))
             (if (gtk-toggle-button-active check)
                 (setf (gtk-progress-bar-text (pbar-widget pdata))
                       (if (pbar-mode pdata)
                           "Progress bar is in activity mode"
                           "Progress bar is in normal mode"))
                 (setf (gtk-progress-bar-text (pbar-widget pdata)) ""))
             (setf (gtk-progress-bar-show-text (pbar-widget pdata))
                   (gtk-toggle-button-active check))))
        (gtk-box-pack-start vbox check))

      (let ((check (gtk-check-button-new-with-label "Activity mode")))
        (g-signal-connect check "clicked"
           (lambda (widget)
             (declare (ignore widget))
             (setf (pbar-mode pdata)
                   (not (pbar-mode pdata)))
             (if (pbar-mode pdata)
                 (progn
                   (gtk-progress-bar-pulse (pbar-widget pdata))
                   (setf (gtk-progress-bar-text (pbar-widget pdata))
                         "Progress bar is in activity mode"))
                 (progn
                   (setf (gtk-progress-bar-text (pbar-widget pdata))
                         "Progress bar is in normal mode")
                   (setf (gtk-progress-bar-fraction (pbar-widget pdata))
                         0.0)))))
        (gtk-box-pack-start vbox check))

      (let ((check (gtk-check-button-new-with-label "Inverted")))
        (g-signal-connect check "clicked"
           (lambda (widget)
             (declare (ignore widget))
             (setf (gtk-progress-bar-inverted (pbar-widget pdata))
                   (gtk-toggle-button-active check))))
        (gtk-box-pack-start vbox check))

      (gtk-container-add window vbox)
      (gtk-widget-show-all window))))

    

;;;; Example Statusbar (2021-5-28)

(in-package :gtk-example)

(defun example-statusbar ()
  (within-main-loop
    (let* ((window (make-instance 'gtk-window
                                  :type :toplevel
                                  :title "Example Statusbar"
                                  :default-width 300
                                  :border-width 12))
           (vbox (make-instance 'gtk-box
                                :orientation :vertical
                                :homogeneous nil
                                :spacing 3))
           (statusbar (make-instance 'gtk-statusbar))
           (id (gtk-statusbar-context-id statusbar "Example Statusbar"))
           (count 0))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-box-pack-start vbox statusbar)
      (let ((button (gtk-button-new-with-label "Push Item")))
        (g-signal-connect button "clicked"
           (lambda (widget)
             (declare (ignore widget))
             (setq count (+ 1 count))
             (gtk-statusbar-push statusbar id (format nil "Item ~A" count))))
        (gtk-box-pack-start vbox button :expand t :fill t :padding 3))
      (let ((button (gtk-button-new-with-label "Pop Item")))
        (g-signal-connect button "clicked"
           (lambda (widget)
             (declare (ignore widget))
             (gtk-statusbar-pop statusbar id)))
        (gtk-box-pack-start vbox button :expand t :fill t :padding 3))
      (gtk-container-add window vbox)
      (gtk-widget-show-all window))))

    

;;;; Example Scale Widget (2021-5-28)

(in-package :gtk-example)

(defun example-scale-widget ()
  (within-main-loop
    (let* ((window (make-instance 'gtk-window
                                  :type :toplevel
                                  :title "Example Scale Widget"))
           (box1 (make-instance 'gtk-box
                                :orientation :vertical
                                :homogeneous nil
                                :spacing 0))
           (box2 (make-instance 'gtk-box
                                :orientation :horizontal
                                :homogeneous nil
                                :spacing 12
                                :border-width 12))
           (box3 (make-instance 'gtk-box
                                :orientation :vertical
                                :homogeneous nil
                                :spacing 12))
           (adj1 (make-instance 'gtk-adjustment
                                :value 0.0
                                :lower 0.0
                                :upper 101.0
                                :step-increment 0.1
                                :page-increment 1.0
                                :page-size 1.0))
           (vscale (make-instance 'gtk-scale
                                  :orientation :vertical
                                  :digits 1
                                  :value-pos :top
                                  :draw-value t
                                  :adjustment adj1))
           (hscale (make-instance 'gtk-scale
                                   :orientation :horizontal
                                   :digits 1
                                   :value-pos :top
                                   :draw-value t
                                   :width-request 200
                                   :height-request -1
                                   :adjustment adj1))
           (scrollbar (make-instance 'gtk-scrollbar
                                     :orientation :horizontal
                                     :adjustment adj1)))
      ;; Connect a handler for the signal "destroy" to the main window.
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Packing of the global widgets hscale, vscale, and scrollbar
      (gtk-container-add window box1)
      (gtk-box-pack-start box1 box2)
      (gtk-box-pack-start box2 vscale)
      (gtk-box-pack-start box2 box3)
      (gtk-box-pack-start box3 hscale)
      (gtk-box-pack-start box3 scrollbar)
      ;; A check button to control whether the value is displayed or not.
      (let ((box (make-instance 'gtk-box
                                :orientation :horizontal
                                :homogeneous nil
                                :spacing 12
                                :border-width 12))
            (button (make-instance 'gtk-check-button
                                   :label "Display value on scale widget"
                                   :active t)))
        (g-signal-connect button "toggled"
           (lambda (widget)
             (setf (gtk-scale-draw-value hscale)
                   (gtk-toggle-button-active widget))
             (setf (gtk-scale-draw-value vscale)
                   (gtk-toggle-button-active widget))))
        (gtk-box-pack-start box button)
        (gtk-box-pack-start box1 box))
      ;; A ComboBox to change the position of the value.
      (let ((box (make-instance 'gtk-box
                                :orientation :horizontal
                                :homogeneous nil
                                :spacing 12
                                :border-width 12))
            (combo (make-instance 'gtk-combo-box-text)))
        (gtk-combo-box-text-append-text combo "TOP")
        (gtk-combo-box-text-append-text combo "BOTTOM")
        (gtk-combo-box-text-append-text combo "LEFT")
        (gtk-combo-box-text-append-text combo "RIGHT")
        (setf (gtk-combo-box-active combo) 0)
        (g-signal-connect combo "changed"
           (lambda (widget)
             (let ((pos (gtk-combo-box-text-active-text widget)))
               (format t "type      : ~A~%"
                         (g-type-from-instance (pointer widget)))
               (format t "active is : ~A~%"
                         (gtk-combo-box-active widget))
               (setq pos (if pos (intern pos :keyword) :top))
               (setf (gtk-scale-value-pos hscale) pos)
               (setf (gtk-scale-value-pos vscale) pos))))
        (gtk-box-pack-start box
                            (make-instance 'gtk-label
                                           :label "Scale value position")
                            :expand nil :fill nil :padding 0)
        (gtk-box-pack-start box combo)
        (gtk-box-pack-start box1 box))
      ;; Create a scale to change the digits of hscale and vscale.
      (let* ((box (make-instance 'gtk-box
                                 :orientation :horizontal
                                 :homogeneous nil
                                 :spacing 12
                                 :border-width 12))
             (adj (make-instance 'gtk-adjustment
                                 :value 1.0
                                 :lower 0.0
                                 :upper 5.0
                                 :step-increment 1.0
                                 :page-increment 1.0
                                 :page-size 0.0))
             (scale (make-instance 'gtk-scale
                                   :orientation :horizontal
                                   :digits 0
                                   :adjustment adj)))
        (g-signal-connect adj "value-changed"
           (lambda (adjustment)
             (setf (gtk-scale-digits hscale)
                   (truncate (gtk-adjustment-value adjustment)))
             (setf (gtk-scale-digits vscale)
                   (truncate (gtk-adjustment-value adjustment)))))
        (gtk-box-pack-start box
                            (make-instance 'gtk-label
                                           :label "Scale Digits:")
                            :expand nil :fill nil)
        (gtk-box-pack-start box scale)
        (gtk-box-pack-start box1 box))
      ;; Another hscale for adjusting the page size of the scrollbar
      (let* ((box (make-instance 'gtk-box
                                 :orientation :horizontal
                                 :homogeneous nil
                                 :spacing 12
                                 :border-width 12))
             (adj (make-instance 'gtk-adjustment
                                 :value 1.0
                                 :lower 1.0
                                 :upper 101.0
                                 :step-increment 1.0
                                 :page-increment 1.0
                                 :page-size 0.0))
             (scale (make-instance 'gtk-scale
                                   :orientation :horizontal
                                   :digits 0
                                   :adjustment adj)))
        (g-signal-connect adj "value-changed"
           (lambda (adjustment)
             (setf (gtk-adjustment-page-size adj1)
                   (gtk-adjustment-page-size adjustment))
             (setf (gtk-adjustment-page-increment adj1)
                   (gtk-adjustment-page-increment adjustment))))
        (gtk-box-pack-start box
                            (make-instance 'gtk-label
                                           :label "Scrollbar Page Size:")
                            :expand nil :fill nil)
        (gtk-box-pack-start box scale)
        (gtk-box-pack-start box1 box))
      (gtk-widget-show-all window))))

    

;;;; Example Button Boxes (2021-4-30)

(in-package :gtk-example)

(defun create-bbox (orientation title style)
  (let ((box (make-instance 'gtk-box
                            :orientation :vertical))
        (bbox (make-instance 'gtk-button-box
                             :orientation orientation
                             :border-width 6
                             :layout-style style
                             :spacing 6)))
    (gtk-container-add bbox
                       (make-instance 'gtk-button
                                      :label "OK"
                                      :always-show-image t
                                      :image
                                      (make-instance 'gtk-image
                                                     :icon-name "gtk-ok")))
    (gtk-container-add bbox
                       (make-instance 'gtk-button
                                      :label "Cancel"
                                      :always-show-image t
                                      :image
                                      (make-instance 'gtk-image
                                                     :icon-name "gtk-cancel")))
    (gtk-container-add bbox
                       (make-instance 'gtk-button
                                      :label "Help"
                                      :always-show-image t
                                      :image
                                      (make-instance 'gtk-image
                                                     :icon-name "gtk-help")))

    (gtk-box-pack-start box (make-instance 'gtk-label
                                           :xalign 0.0
                                           :label title)
                            :expand nil)
    (gtk-box-pack-start box (make-instance 'gtk-separator
                                           :margin-top 6
                                           :margin-bottom 6
                                           :orientation :horizontal)
                            :expand nil)
    (gtk-box-pack-start box bbox)
    box))

(defun example-button-box ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Button Box"
                                 :default-width 420
                                 :border-width 12))
          (vbox (make-instance 'gtk-box
                               :orientation :vertical
                               :homogeneous nil
                               :spacing 12)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-box-pack-start vbox
                          (make-instance 'gtk-label
                                         :margin-top 6
                                         :margin-bottom 6
                                         :xalign 0
                                         :use-markup t
                                         :label
                                         "<b>Horizontal Button Boxes</b>")
                          :expand nil)
      (gtk-box-pack-start vbox
                          (create-bbox :horizontal "Spread" :spread))
      (gtk-box-pack-start vbox
                          (create-bbox :horizontal "Edge" :edge))
      (gtk-box-pack-start vbox
                          (create-bbox :horizontal "Start" :start))
      (gtk-box-pack-start vbox
                          (create-bbox :horizontal "End" :end))
      (gtk-box-pack-start vbox
                          (create-bbox :horizontal "Center" :center))
      (gtk-box-pack-start vbox
                          (create-bbox :horizontal "Expand" :expand))
      (gtk-container-add window vbox)
      (gtk-widget-show-all window))))

    

;;;; Paned Window Widgets (2021-5-28)

(in-package :gtk-example)

(defun example-paned-window ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Paned Window"
                                 :default-width 320
                                 :default-height 280
                                 :border-width 12))
          (paned (make-instance 'gtk-paned
                                :position 100
                                :orientation :vertical))
          (frame1 (make-instance 'gtk-frame
                                 :label "Window 1"
                                 :label-yalign 0.0))
          (frame2 (make-instance 'gtk-frame
                                 :label "Window 2"
                                 :label-yalign 0.0)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-container-add window paned)
      (gtk-paned-add1 paned frame1)
      (gtk-paned-add2 paned frame2)
      (gtk-widget-show-all window))))

    

;;;; Example Layout widget (2021-4-26)

(in-package :gtk-example)

(defun example-layout ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Layout Widget"
                                 :width-request 360
                                 :height-request 240))
          (layout (make-instance 'gtk-layout)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))

      (gtk-layout-put layout
                      (make-instance 'gtk-button
                                     :label "Button 1")
                      40 60)
      (gtk-layout-put layout
                      (make-instance 'gtk-button
                                     :label "Button 2")
                      120 105)
      ;; Pack and show the widgets
      (gtk-container-add window layout)
      (gtk-widget-show-all window))))

    

;;;; Example Notebook (2021-6-4)

(in-package :gtk-example)

(defun example-notebook ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :title "Example Notebook"
                                 :type :toplevel
                                 :default-width 300
                                 :default-height 210))
          (notebook (make-instance 'gtk-notebook
                                   :enable-popup t)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (dotimes (i 3)
        (let ((page (make-instance 'gtk-label
                                   :label
                                   (format nil
                                           "Text for page ~a" (1+ i))))
              (tab-label (make-instance 'gtk-label
                                        :label (format nil "Page ~a" (1+ i))))
              (tab-button (make-instance 'gtk-button
                                         :image
                                         (make-instance 'gtk-image
                                                        :icon-name
                                                        "gtk-close"
                                                        :icon-size 1)
                                         :relief :none)))
          (g-signal-connect tab-button "clicked"
             (let ((page page))
               (lambda (button)
                 (declare (ignore button))
                 (format t "Removing page ~a~%" page)
                 (gtk-notebook-remove-page notebook page))))
          (let ((tab-hbox (make-instance 'gtk-box
                                         :orientation :horizontal)))
            (gtk-box-pack-start tab-hbox tab-label)
            (gtk-box-pack-start tab-hbox tab-button)
            (gtk-widget-show-all tab-hbox)
            (gtk-notebook-add-page notebook page tab-hbox))))
      (gtk-container-add window notebook)
      (gtk-widget-show-all window))))

    

;;;; Example Simple Frame (2021-5-28)

(in-package :gtk-example)

(defun example-frame ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Frame"
                                 :default-width 250
                                 :default-height 200
                                 :border-width 12))
          (frame (make-instance 'gtk-frame
                                :label "Frame Label"
                                :label-xalign 1.0
                                :label-yalign 0.5
                                :shadow-type :etched-in)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-container-add window frame)
      (gtk-widget-show-all window))))

    

;;;; Example Aspect Frame (2021-5-28)

(in-package :gtk-example)

(defun example-aspect-frame ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Aspect Frame"
                                 :default-width 300
                                 :default-height 240
                                 :border-width 12))
          (frame (make-instance 'gtk-aspect-frame
                                :label "Ratio 2 x 1"
                                :label-yalign 1.0
                                :xalign 0.5
                                :yalign 0.5
                                :ratio 2
                                :obey-child nil))
          (area (make-instance 'gtk-drawing-area
                               :width-request 200
                               :hight-request 200)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-container-add window frame)
      (gtk-container-add frame area)
      (gtk-widget-show-all window))))

    

;;;; Example Fixed Container (2021-5-28)
;;;;
;;;; In this example, three buttons are placed in the fixed container with the
;;;; function gtk-fixed-put. When pressed, the buttons are moved randomly with
;;;; the function gtk-fixed-move.
;;;;
;;;; To get the width and height of the fixed container and the buttons the
;;;; functions gtk-widget-allocated-width and gtk-widget-allocated-height are
;;;; used.

(in-package :gtk-example)

(defun move-button (fixed button)
  (let ((width (- (gtk-widget-allocated-width fixed)
                  (gtk-widget-allocated-width button)))
        (height (- (gtk-widget-allocated-height fixed)
                   (gtk-widget-allocated-height button))))
    (gtk-fixed-move fixed button (random width) (random height))))

(defun example-fixed ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Fixed Container"
                                 :default-width 350
                                 :default-height 200
                                 :border-width 12))
          (fixed (make-instance 'gtk-fixed)))
      (g-signal-connect window "destroy"
                        (lambda (window)
                          (declare (ignore window))
                          (leave-gtk-main)))
      (dotimes (i 3)
        (let ((button (gtk-button-new-with-label "Press me")))
          (g-signal-connect button "clicked"
                            (lambda (widget)
                              (move-button fixed widget)))
          (gtk-fixed-put fixed button (random 250) (random 180))))
      (gtk-container-add window fixed)
      (gtk-widget-show-all window))))

    

;;;; Scrolled Window (2021-3-19)

(in-package #:gtk-example)

(defun example-scrolled-window ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Scrolled Window"
                                 :width-request 350
                                 :height-request 300))
          (scrolled (make-instance 'gtk-scrolled-window
                                   :hscrollbar-policy :automatic
                                   :vscrollbar-policy :always))
          (image (gtk-image-new-from-file (sys-path "ducky.png"))))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Pack and show the widgets
      (gtk-container-add scrolled image)
      (gtk-container-add window scrolled)
      (gtk-widget-show-all window))))

    

;;;; Example Dialog Windows (2021-6-1)

(in-package :gtk-example)

(defun license-text ()
  (format nil
          "This program is free software: you can redistribute it and/or ~
          modify it under the terms of the GNU Lesser General Public ~
          License for Lisp as published by the Free Software Foundation, ~
          either version 3 of the License, or (at your option) any later ~
          version and with a preamble to the GNU Lesser General Public ~
          License that clarifies the terms for use with Lisp programs and ~
          is referred as the LLGPL.~%~% ~
          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 Lesser General Public License for more details. ~%~% ~
          You should have received a copy of the GNU Lesser General Public ~
          License along with this program and the preamble to the Gnu ~
          Lesser General Public License.  If not, see ~
          <http://www.gnu.org/licenses/> and ~
          <http://opensource.franz.com/preamble.html>."))

(defun create-dialog ()
  (let ((dialog (make-instance 'gtk-dialog
                               :title "Dialog Window"
                               :has-separator t)))
    ;; Add a border width to the vbox of the content area
    (setf (gtk-container-border-width (gtk-dialog-content-area dialog)) 12)
    ;; Add a label widget with text to the content area
    (let ((vbox (make-instance 'gtk-box
                               :orientation :vertical
                               :border-width 12))
          (label (make-instance 'gtk-label
                                :wrap t
                                :label
                                (format nil
                                        "The content area is the place to ~
                                         put in the widgets.~%~% ~
                                         The action area contains ~
                                         the buttons."))))
      (gtk-box-pack-start vbox label)
      (gtk-box-pack-start (gtk-dialog-content-area dialog) vbox)
      ;; Show the content area of the dialog
      (gtk-widget-show-all (gtk-dialog-content-area dialog)))
    ;; Add buttons with a stock id to the action area
    (gtk-dialog-add-button dialog "gtk-yes" :yes)
    (gtk-dialog-add-button dialog "gtk-no" :no)
    (gtk-dialog-add-button dialog "gtk-cancel" :cancel)
    (gtk-dialog-set-default-response dialog :cancel)
    ;; Change the order of the buttons
    (gtk-dialog-set-alternative-button-order dialog
                                             (list :yes :cancel :no))
    ;; Run the dialog and print the message on the console
    (format t "Response was: ~S~%" (gtk-dialog-run dialog))
    ;; Destroy the dialog
    (gtk-widget-destroy dialog)))

(defun create-message-dialog ()
  (let ((dialog (make-instance 'gtk-message-dialog
                               :message-type :info
                               :buttons :ok
                               :text "Info Message Dialog"
                               :secondary-text
                               (format nil
                                       "This is a message dialog of type ~
                                        :info with a secondary text."))))
    ;; Run the message dialog
    (gtk-dialog-run dialog)
    ;; Destroy the message dialog
    (gtk-widget-destroy dialog)))

(defun create-about-dialog ()
  (let ((dialog (make-instance 'gtk-about-dialog
                               :program-name "Example Dialog"
                               :version "0.00"
                               :copyright "(c) Dieter Kaiser"
                               :website
                               "github.com/crategus/cl-cffi-gtk"
                               :website-label "Project web site"
                               :license (license-text)
                               :authors '("Kalyanov Dmitry"
                                          "Dieter Kaiser")
                               :documenters '("Dieter Kaiser")
                               :artists '("None")
                               :logo-icon-name
                               "applications-development"
                               :wrap-license t)))
    ;; Run the about dialog
    (gtk-dialog-run dialog)
    ;; Destroy the about dialog
    (gtk-widget-destroy dialog)))

(defun example-dialog ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Dialog"
                                 :default-width 250
                                 :border-width 12))
          (vbox (make-instance 'gtk-box
                               :orientation :vertical
                               :spacing 6)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-container-add window vbox)
      (let ((button (make-instance 'gtk-button
                                   :label "Open a Dialog Window")))
        (gtk-box-pack-start vbox button)
        (g-signal-connect button "clicked"
           (lambda (widget)
             (declare (ignore widget))
             ;; Create and show the dialog
             (create-dialog))))
      (let ((button (make-instance 'gtk-button
                                   :label "Open a Message Dialog")))
        (gtk-box-pack-start vbox button)
        (g-signal-connect button "clicked"
           (lambda (widget)
             (declare (ignore widget))
             ;; Create and show the message dialog
             (create-message-dialog))))
      (let ((button (make-instance 'gtk-button
                                   :label "Open an About Dialog")))
        (gtk-box-pack-start vbox button)
        (g-signal-connect button "clicked"
           (lambda (widget)
             (declare (ignore widget))
             ;; Create and show the about dialog
             (create-about-dialog))))
      (gtk-box-pack-start vbox
                          (make-instance 'gtk-separator
                                         :orientation :horizontal))
      ;; Create a quit button
      (let ((button (make-instance 'gtk-button
                                   :label "Quit")))
        (g-signal-connect button "clicked"
                          (lambda (widget)
                            (declare (ignore widget))
                            (gtk-widget-destroy window)))
        (gtk-box-pack-start vbox button))
      (gtk-widget-show-all window))))


    

;;;; Simple Text View (2021-6-4)

(in-package :gtk-example)

(defun example-text-view-simple ()
  (within-main-loop
    (let* ((window (make-instance 'gtk-window
                                  :type :toplevel
                                  :title "Example Simple Text View"
                                  :default-width 350
                                  :default-height 200))
           (textview (make-instance 'gtk-text-view
                                    :wrap-mode :word
                                    :top-margin 6
                                    :left-margin 6
                                    :right-margin 6))
           (buffer (gtk-text-view-buffer textview)))
      (g-signal-connect window "destroy"
          (lambda (widget)
            (declare (ignore widget))
            (let ((start (gtk-text-buffer-start-iter buffer))
                  (end (gtk-text-buffer-end-iter buffer))
                  (include-hidden-chars t))
              (print (gtk-text-buffer-get-text buffer
                                               start
                                               end
                                               include-hidden-chars))
              (terpri)
              (leave-gtk-main))))
      (setf (gtk-text-buffer-text buffer) *lorem-ipsum-short*)
      (gtk-container-add window textview)
      (gtk-widget-show-all window))))

    

;;;; Text View Insert (2021-6-4)

(in-package :gtk-example)

(defvar *text-for-example-text-view-insert*
"<html>
    <head><title>Title</title></head>
    <body>
    <h1>Heading</h1>
")

(defun get-this-tag (iter buffer)
  (let* ((start-tag (gtk-text-iter-copy iter))
         end-tag)
    (and (gtk-text-iter-find-char start-tag #'alpha-char-p)
         (setq end-tag (gtk-text-iter-copy start-tag))
         (gtk-text-iter-find-char end-tag
                                  (lambda (ch) (not (alphanumericp ch))))
         (gtk-text-buffer-get-text buffer start-tag end-tag nil))))

(defun closing-tag-p (iter)
  (let ((slash (gtk-text-iter-copy iter)))
    (gtk-text-iter-forward-char slash)
    (eql (gtk-text-iter-char slash) #\/)))

(defun example-text-view-insert ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :title "Example Text View Insert"
                                 :type :toplevel
                                 :default-width 350
                                 :default-height 200))
          (textview (make-instance 'gtk-text-view
                                   :top-margin 6
                                   :left-margin 6
                                   :right-margin 6))
          (button-make-item (make-instance 'gtk-button
                                           :label "Make List Item"
                                           :margin 3))
          (button-close-tag (make-instance 'gtk-button
                                           :label "Insert Close Tag"
                                           :margin 3))
          (hbox (make-instance 'gtk-box
                               :orientation :horizontal))
          (vbox (make-instance 'gtk-box
                                :orientation :vertical)))
    (g-signal-connect window "destroy"
                      (lambda (widget)
                        (declare (ignore widget))
                        (leave-gtk-main)))
    (g-signal-connect button-make-item "clicked"
        (lambda (widget)
          (declare (ignore widget))
          (let* ((buffer (gtk-text-view-buffer textview))
                 (cursor (gtk-text-buffer-mark buffer "insert"))
                 (bound (gtk-text-buffer-mark buffer "selection_bound")))
            (if (gtk-text-buffer-has-selection buffer)
                ;; Insert text before and after the selection
                (progn
                  ;; Insert start tag
                  (let ((iter (gtk-text-buffer-iter-at-mark buffer cursor)))
                    (gtk-text-buffer-insert buffer "<li>" :position iter))
                  ;; Insert end tag
                  (let ((mark (gtk-text-mark-new nil t))
                        (iter (gtk-text-buffer-iter-at-mark buffer bound)))
                    ;; Add the anonymous mark with right gravity
                    (gtk-text-buffer-add-mark buffer mark iter)
                    ;; Do the insertion at the position of the mark
                    (let ((end (gtk-text-buffer-iter-at-mark buffer mark)))
                      (gtk-text-buffer-insert buffer "</li>" :position end))
                    ;; Reselect the previous selection
                    (let ((iter1 (gtk-text-buffer-iter-at-mark buffer cursor))
                          (iter2 (gtk-text-buffer-iter-at-mark buffer mark)))
                      (gtk-text-buffer-select-range buffer iter1 iter2))
                    ;; Delete the mark
                    (gtk-text-buffer-delete-mark buffer mark)))
                ;; Insert at start and end of current line
                (let ((iter (gtk-text-buffer-iter-at-mark buffer cursor)))
                  ;; Move to the start of the line
                  (setf (gtk-text-iter-line-offset iter) 0)
                  (gtk-text-buffer-insert buffer "<li>" :position iter)
                  ;; Move to the end of the line
                  (gtk-text-iter-forward-to-line-end iter)
                  (gtk-text-buffer-insert buffer "</li>" :position iter)
                  ;; Place cursor and selection and the end of the line
                  (gtk-text-iter-forward-to-line-end iter)
                  (gtk-text-buffer-select-range buffer iter iter))))))
      (g-signal-connect button-close-tag "clicked"
          (lambda (widget)
            (declare (ignore widget))
            (let* ((buffer (gtk-text-view-buffer textview))
                   (cursor (gtk-text-buffer-mark buffer "insert"))
                   (iter (gtk-text-buffer-iter-at-mark buffer cursor)))
              (do ((stack '()))
                  ((not (gtk-text-iter-find-char iter
                                                (lambda (ch) (eq ch #\<))
                                                :direction :backward)))
                (let ((tag (get-this-tag iter buffer)))
                  (if (closing-tag-p iter)
                      (push tag stack)
                      (let ((tag-in-stack (pop stack)))
                        (when (not tag-in-stack)
                          (gtk-text-buffer-insert buffer
                                                  (format nil "</~a>" tag))
                          (return)))))))))
   (setf (gtk-text-buffer-text (gtk-text-view-buffer textview))
         *text-for-example-text-view-insert*)
   ;; Pack and show the widgets
   (gtk-box-pack-start vbox textview)
   (gtk-box-pack-start hbox button-make-item)
   (gtk-box-pack-start hbox button-close-tag)
   (gtk-box-pack-start vbox hbox :expand nil)
   (gtk-container-add window vbox)
   (gtk-widget-show-all window))))

     

;;;; Example Tree View Simple (2021-6-4)

(in-package :gtk-example)

(let ((col-title 0) (col-author 1) (col-year 2))

  (defun create-and-fill-model-simple ()
    (let ((model (gtk-tree-store-new "gchararray" "gchararray" "guint")))
      ;; First Book
      (let ((iter (gtk-tree-store-append model nil))) ; Top-level iterator
        ;; Set the top-level row
        (gtk-tree-store-set model
                            iter
                            "The Art of Computer Programming"
                            "Donald E. Knuth"
                            2011)
        ;; Append and set child rows
        (gtk-tree-store-set model
                            (gtk-tree-store-append model iter) ; Child iterator
                            "Volume 1: Fundamental Algorithms"
                            ""
                            1997)
        (gtk-tree-store-set model
                            (gtk-tree-store-append model iter) ; Child iterator
                            "Volume 2: Seminumerical Algorithms"
                            ""
                            1998)
        (gtk-tree-store-set model
                            (gtk-tree-store-append model iter) ; Child iterator
                            "Volume 3: Sorting and Searching"
                            ""
                            1998))
      ;; Second Book
      (let ((iter (gtk-tree-store-append model nil))) ; Top-level iterator
        (gtk-tree-store-set model
                            iter
                            "Let Over Lambda"
                            "Doug Hoyte"
                            2008))
      ;; Third Book
      (let ((iter (gtk-tree-store-append model nil))) ; Top-level iterator
        (gtk-tree-store-set model
                            iter
                            "On Lisp"
                            "Paul Graham"
                            1993))
      model))

  (defun create-view-and-model-simple ()
    (let* ((model (create-and-fill-model-simple))
           (view (gtk-tree-view-new-with-model model)))
      ;; Create renderer for Title column
      (let* ((renderer (gtk-cell-renderer-text-new))
             (column (gtk-tree-view-column-new-with-attributes "Title"
                                                               renderer
                                                               "text"
                                                                col-title)))
        (gtk-tree-view-append-column view column))
      ;; Create renderer for Author column
      (let* ((renderer (gtk-cell-renderer-text-new))
             (column (gtk-tree-view-column-new-with-attributes "Author"
                                                               renderer
                                                               "text"
                                                               col-author)))
        (gtk-tree-view-append-column view column))
      ;; Create renderer for Year column
      (let* ((renderer (gtk-cell-renderer-text-new))
             (column (gtk-tree-view-column-new-with-attributes "Year"
                                                               renderer
                                                               "text"
                                                               col-year)))
        (gtk-tree-view-append-column view column))
      view))

  (defun example-tree-view-simple ()
    (within-main-loop
      (let* ((window (make-instance 'gtk-window
                                    :title "Example Simple Tree View"
                                    :type :toplevel
                                    :default-width 350
                                    :default-height 200))
             (view (create-view-and-model-simple)))
        (g-signal-connect window "destroy"
                          (lambda (widget)
                            (declare (ignore widget))
                            (leave-gtk-main)))
        ;; Setup the selection handler
        (let ((selection (gtk-tree-view-selection view)))
          (setf (gtk-tree-selection-mode selection) :single)
          (g-signal-connect selection "changed"
             (lambda (object)
               (let* ((view (gtk-tree-selection-tree-view object))
                      (model (gtk-tree-view-model view))
                      (iter (gtk-tree-selection-selected object))
                      (title (gtk-tree-model-value model iter col-title)))
                 (format t "Selected title is ~a~%" title)))))
        ;; Pack and show the widgets
        (gtk-container-add window view)
        (gtk-widget-show-all window)))))

      

;;;; Example Font Button Label (2021-6-5)

(in-package :gtk-example)

(defun font-filter (family face)
  (declare (ignore face))
  (member (pango-font-family-name family)
          '("Purisa" "Sans" "Serif" "Times New Roman")
          :test #'equal))

(defun example-font-button-label ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :title "Example Font Chooser Button"
                                 :type :toplevel
                                 :border-width 18
                                 :default-width 300
                                 :default-height 100))
          (provider (gtk-css-provider-new))
          (box (make-instance 'gtk-box
                              :orientation :horizontal
                              :spacing 12))
          (label (make-instance 'gtk-label
                                :label "Font Button"
                                :use-markup t))
          (button (make-instance 'gtk-font-button)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (g-signal-connect button "font-set"
         (lambda (chooser)
           (let* (;; Get the font description
                  (desc (gtk-font-chooser-font-desc chooser))
                  ;; Get font informations from the font description
                  (family (pango-font-description-family desc))
                  (size (pango-pixels (pango-font-description-size desc)))
                  (style (pango-font-description-style desc))
                  (weight (pango-font-description-weight desc))
                  (variant (pango-font-description-variant desc))
                  (stretch (pango-font-description-stretch desc))
                  ;; Write the CSS string
                  (css-label (format nil "label { font-family : ~a; ~
                                                  font-weight : ~a; ~
                                                  font-style : ~a; ~
                                                  font-variant : ~a; ~
                                                  font-stretch : ~a; ~
                                                  font-size : ~apx; }"
                                         family
                                         weight
                                         style
                                         variant
                                         stretch
                                         size))
                  ;; Get the style of the label
                  (context (gtk-widget-style-context label)))
             ;; Update the font of the label
             (gtk-css-provider-load-from-data provider css-label)
             (gtk-style-context-add-provider context
                                             provider
                                             +gtk-style-provider-priority-user+))))
      ;; Set a filter function to select fonts for the font chooser
      (gtk-font-chooser-set-filter-func button #'font-filter)
      ;; Pack the widgets
      (gtk-box-pack-start box button)
      (gtk-box-pack-start box label)
      (gtk-container-add window box)
      ;; Show the widgets
      (gtk-widget-show-all window))))

     

;;;; Example Toolbar by hand (2021-6-5)

(in-package :gtk-example)

(defun example-toolbar-by-hand ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :default-width 250
                                 :default-height 150
                                 :title "Example Toolbar"))
          ;; A vbox to put a menu and a button in
          (vbox (gtk-box-new :vertical 0)))
      (let ((toolbar (gtk-toolbar-new))
            (new-button (gtk-tool-button-new-from-stock "gtk-new"))
            (open-button (gtk-tool-button-new-from-stock "gtk-open"))
            (save-button (gtk-tool-button-new-from-stock "gtk-save"))
            (quit-button (gtk-tool-button-new-from-stock "gtk-quit"))
            (separator (make-instance 'gtk-separator-tool-item
                                      :draw nil)))
        (gtk-toolbar-insert toolbar new-button -1)
        (gtk-toolbar-insert toolbar open-button -1)
        (gtk-toolbar-insert toolbar save-button -1)
        (gtk-toolbar-insert toolbar separator -1)
        (gtk-toolbar-insert toolbar quit-button -1)
        (setf (gtk-tool-item-expand separator) t)
        (gtk-box-pack-start vbox toolbar :fill nil :expand nil :padding 3)
        ;; Connect a signal handler to the quit button
        (g-signal-connect quit-button "clicked"
                          (lambda (widget)
                            (declare (ignore widget))
                            (gtk-widget-destroy window))))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-container-add window vbox)
      (gtk-widget-show-all window))))

     

;;;; Calendar Widget (2021-6-10)

(in-package :gtk-example)

(defun calendar-detail (calendar year month day)
  (declare (ignore calendar year month))
  (when (= day 12)
    "This day has a tooltip."))

(defun example-calendar ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :title "Example Calendar"
                                 :type :toplevel
                                 :border-width 24
                                 :default-width 250
                                 :default-height 100))
          (frame (make-instance 'gtk-frame))
          (calendar (make-instance 'gtk-calendar
                                   :show-details nil)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Connect a signal handler to print the selected day
      (g-signal-connect calendar "day-selected"
                        (lambda (widget)
                          (declare (ignore widget))
                          (format t "selected: year ~A month ~A day ~A~%"
                                  (gtk-calendar-year calendar)
                                  (gtk-calendar-month calendar)
                                  (gtk-calendar-day calendar))))
      ;; Install a calendar detail function
      (gtk-calendar-set-detail-func calendar #'calendar-detail)
      ;; Mark a day
      (gtk-calendar-mark-day calendar 6)
      (gtk-container-add frame calendar)
      (gtk-container-add window frame)
      (gtk-widget-show-all window))))

   

;;;; Example Event Box (2021-6-11)
;;;;
;;;; Example Event Box demonstrates both uses of a GtkEventBox widget - a label
;;;; is created that is clipped to a small box, and set up so that a mouse-click
;;;; on the label causes the program to exit. Resizing the window reveals
;;;; varying amounts of the label.
;;;;
;;;; In addition, example Event Box shows how to change the cursor over a
;;;; window. Every widget has an associated window of type GdkWindow, which can
;;;; be get with the function gtk-widget-window. The function gdk-window-cursor
;;;; sets a cursor for this GdkWindow. A new cursor is created with the function
;;;; gdk-cursor-new-from-name. The function takes two arguments. The first
;;;; argument is the GdkDisplay object for which the cursor will be created.
;;;; The second argument is a string with the name of the cursor. Look at the
;;;; documentation of the function gdk-cursor-new-from-name for available cursor
;;;; names. In example Event Box the cursor with the name "pointer" is chosen.
;;;; This cursor is associated to the GdkWindow with the function
;;;; gdk-window-cursor.

(in-package :gtk-example)

(defun example-event-box ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Event Box"
                                 :default-height 150
                                 :border-width 24))
          (eventbox (make-instance 'gtk-event-box))
          (label (make-instance 'gtk-label
                                :ellipsize :end
                                :label
                                "Click here to quit this Example Event Box.")))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      ;; Set the available events for the event box
      (setf (gtk-widget-events eventbox) :button-press-mask)
      ;; Connect a signal handler to the eventbox
      (g-signal-connect eventbox "button-press-event"
                        (lambda (widget event)
                          (declare (ignore widget event))
                          (gtk-widget-destroy window)))
      ;; Add the label to the event box and the event box to the window
      (gtk-container-add eventbox label)
      (gtk-container-add window eventbox)
      ;; Realize the event box
      (gtk-widget-realize eventbox)
      ;; Set a new cursor for the event box
      (setf (gdk-window-cursor (gtk-widget-window eventbox))
            (gdk-cursor-new-from-name (gdk-display-default) "pointer"))
      ;; Show the window
      (gtk-widget-show-all window))))

   

;;;; Example Text Entry (2021-6-11)

(in-package :gtk-example)

(defun example-text-entry ()
  (within-main-loop
    (let* ((window (make-instance 'gtk-window
                                  :type :toplevel
                                  :title "Example Text Entry"
                                  :default-width 250
                                  :default-height 120))
           (vbox (make-instance 'gtk-box :orientation :vertical))
           (hbox (make-instance 'gtk-box :orientation :horizontal))
           (entry (make-instance 'gtk-entry
                                 :text "Hello"
                                 :max-length 50))
           (pos (gtk-entry-text-length entry)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (g-signal-connect entry "activate"
                        (lambda (widget)
                          (declare (ignore widget))
                          (format t "Entry contents: ~A"
                                  (gtk-entry-text entry))))
      (gtk-editable-insert-text entry " world" pos)
      (gtk-editable-select-region entry 0 (gtk-entry-text-length entry))
      (gtk-box-pack-start vbox entry :expand t :fill t :padding 0)
      (let ((check (gtk-check-button-new-with-label "Editable")))
        (g-signal-connect check "toggled"
           (lambda (widget)
             (declare (ignore widget))
             (setf (gtk-editable-editable entry)
                   (gtk-toggle-button-active check))))
        (gtk-box-pack-start hbox check))
      (let ((check (gtk-check-button-new-with-label "Visible")))
        (setf (gtk-toggle-button-active check) t)
        (g-signal-connect check "toggled"
           (lambda (widget)
             (declare (ignore widget))
             (setf (gtk-entry-visibility entry)
                   (gtk-toggle-button-active check))))
        (gtk-box-pack-start hbox check))
      (gtk-box-pack-start vbox hbox)
      (gtk-container-add window vbox)
      (gtk-widget-show-all window))))

   

;;;; Example Spin Button (2021-6-11)

(in-package :gtk-example)

(defun example-spin-button ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :type :toplevel
                                 :title "Example Spin Button"
                                 :default-width 300))
          (vbox (make-instance 'gtk-box
                               :orientation :vertical
                               :homogeneous nil
                               :spacing 6
                               :border-width 12)))

      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))

      (multiple-value-bind
          (second minute hour date month year day daylight-p zone)
          (get-decoded-time)
        (declare (ignore second minute hour day daylight-p zone))

        ;; A label for the three spin buttons for the input of day, month, year.
        (gtk-box-pack-start vbox
                            (make-instance 'gtk-label
                                           :label "<b>Not Accelerated</b>"
                                           :halign :start
                                             :margin-top 6
                                           :margin-bottom 3
                                           :use-markup t)
                            :expand nil)

        (let ((hbox (make-instance 'gtk-box :orientation :horizontal)))
          ;; A vertical Box with a label and a spin button for a day.
          (let ((vbox (make-instance 'gtk-box :orientation :vertical))
                (spinner (make-instance 'gtk-spin-button
                                        :adjustment
                                        (make-instance 'gtk-adjustment
                                                       :value date
                                                       :lower 1.0
                                                       :upper 31.0
                                                       :step-increment 1.0
                                                       :page-increment 5.0
                                                       :page-size 0.0)
                                        :climb-rate 0
                                        :digits 0
                                        :wrap t)))
            ;; FIXME: The entry does not show the default value.
            ;; What is the problem? We set the value explicitly.
            (setf (gtk-entry-text spinner) (format nil "~d" date))

            (gtk-box-pack-start vbox
                                (make-instance 'gtk-label
                                               :label "Day :"
                                               :xalign 0
                                               :yalign 0.5)
                                :expand nil)
            (gtk-box-pack-start vbox spinner :expand nil)
            (gtk-box-pack-start hbox vbox :padding 6))

          ;; A vertical Box with a label and a spin button for the month.
          (let ((vbox (make-instance 'gtk-box :orientation :vertical))
                (spinner (make-instance 'gtk-spin-button
                                        :adjustment
                                        (make-instance 'gtk-adjustment
                                                       :value month
                                                       :lower 1.0
                                                       :upper 12.0
                                                       :step-increment 1.0
                                                       :page-increment 5.0
                                                       :page-size 0.0)
                                        :climb-rate 0
                                        :digits 0
                                        :wrap t)))

          ;; FIXME: The entry does not show the default value.
          ;; What is the problem? We set the value explicitly.
          (setf (gtk-entry-text spinner) (format nil "~d" month))

          (gtk-box-pack-start vbox
                              (make-instance 'gtk-label
                                             :label "Month :"
                                             :xalign 0
                                             :yalign 0.5)
                              :expand nil)
          (gtk-box-pack-start vbox spinner :expand nil)
          (gtk-box-pack-start hbox vbox :padding 6))

          ;; A vertival Box with a label and a spin button for the year.
          (let ((vbox (make-instance 'gtk-box :orientation :vertical))
                (spinner (make-instance 'gtk-spin-button
                                        :adjustment
                                        (make-instance 'gtk-adjustment
                                                       :value year
                                                       :lower 1998.0
                                                       :upper 2100.0
                                                       :step-increment 1.0
                                                       :page-increment 100.0
                                                       :page-size 0.0)
                                        :climb-rate 0
                                        :digits 0
                                        :wrap t)))

          ;; FIXME: The entry does not show the default value.
          ;; What is the problem? We set the value explicitly.
          (setf (gtk-entry-text spinner) (format nil "~d" year))

          (gtk-box-pack-start vbox
                              (make-instance 'gtk-label
                                             :label "Year :"
                                             :xalign 0
                                             :yalign 0.5)
                              :expand nil)
          (gtk-box-pack-start vbox spinner :expand nil :fill t)
          (gtk-box-pack-start hbox vbox :padding 6))
        ;; Place the hbox in the vbox
        (gtk-box-pack-start vbox hbox :padding 6)))

      ;; A label for the accelerated spin button.
      (gtk-box-pack-start vbox
                          (make-instance 'gtk-label
                                         :label "<b>Accelerated</b>"
                                         :halign :start
                                         :margin-top 6
                                         :margin-bottom 3
                                         :use-markup t)
                            :expand nil)

      ;; A vertical Box with for the accelarated spin button
      (let ((spinner1 (make-instance 'gtk-spin-button
                                     :adjustment
                                     (make-instance 'gtk-adjustment
                                                    :value 0.0
                                                    :lower -10000.0
                                                    :upper  10000.0
                                                    :step-increment 0.5
                                                    :page-increment 100.0
                                                    :page-size 0.0)
                                     :climb-rate 1.0
                                     :digits 2
                                     :wrap t))
            (spinner2 (make-instance 'gtk-spin-button
                                     :adjustment
                                     (make-instance 'gtk-adjustment
                                                    :value 2
                                                    :lower 1
                                                    :upper 5
                                                    :step-increment 1
                                                    :page-increment 1
                                                    :page-size 0)
                                     :climb-rate 0.0
                                     :digits 0
                                     :wrap t)))
        ;; Customize the appearance of the number
        (g-signal-connect spinner1 "output"
          (lambda (spin-button)
            (let ((value (gtk-adjustment-value
                           (gtk-spin-button-adjustment spin-button)))
                  (digits (truncate
                            (gtk-adjustment-value
                              (gtk-spin-button-adjustment spinner2)))))
              (setf (gtk-entry-text spin-button)
                    (format nil "~@?" (format nil "~~,~d@f" digits) value)))))
         ;; Update number of digits if changed
         (g-signal-connect spinner2 "value-changed"
           (lambda (spin-button)
             (setf (gtk-spin-button-digits spinner1)
                   (gtk-spin-button-value-as-int spin-button))))
         ;; FIXME: The entry does not show the default value.
         ;; What is the problem? We set the value.
        (setf (gtk-entry-text spinner2) (format nil "~d" 2))

        (let ((hbox (make-instance 'gtk-box :orientation :horizontal)))
          ;; Put the accelarated spin button with a label in a vertical box.
          (let ((vbox (make-instance 'gtk-box :orientation :vertical)))
            (gtk-box-pack-start vbox
                                (make-instance 'gtk-label
                                               :label "Value :"
                                               :xalign 0
                                               :yalign 0.5)
                                :expand nil)
            (gtk-box-pack-start vbox spinner1 :expand nil)
            (gtk-box-pack-start hbox vbox :padding 6))

          ;; Put the spin button for digits with a label in a vertical box.
          (let ((vbox (make-instance 'gtk-box :orientation :vertical)))
            (gtk-box-pack-start vbox
                                (make-instance 'gtk-label
                                               :label "Digits :"
                                               :xalign 0
                                               :yalign 0.5)
                                :expand nil)
            (gtk-box-pack-start vbox spinner2 :expand nil)
            (gtk-box-pack-start hbox vbox :padding 6))

          (gtk-box-pack-start vbox hbox :padding 6))

        (let ((check (make-instance 'gtk-check-button
                                    :label "Snap to 0.5-ticks"
                                    :active t)))
          (g-signal-connect check "clicked"
             (lambda (widget)
               (setf (gtk-spin-button-snap-to-ticks spinner1)
                     (gtk-toggle-button-active widget))))
          (gtk-box-pack-start vbox check))

        (let ((check (make-instance 'gtk-check-button
                                    :label "Numeric only input mode"
                                    :active t)))
          (g-signal-connect check "clicked"
             (lambda (widget)
               (setf (gtk-spin-button-numeric spinner1)
                     (gtk-toggle-button-active widget))))
          (gtk-box-pack-start vbox check))

        (let ((label (make-instance 'gtk-label
                                    :label "0"
                                    :halign :start
                                    :margin-top 3
                                    :margin-bottom 3))
              (hbox (make-instance 'gtk-box :orientation :horizontal)))

          (let ((button (gtk-button-new-with-label "Value as Int")))
            (g-signal-connect button "clicked"
               (lambda (widget)
                 (declare (ignore widget))
                 (setf (gtk-label-text label)
                       (format nil "~A"
                               (gtk-spin-button-value-as-int spinner1)))))
              (gtk-box-pack-start hbox button))

          (let ((button (gtk-button-new-with-label "Value as Float")))
            (g-signal-connect button "clicked"
               (lambda (widget)
                 (declare (ignore widget))
                 (setf (gtk-label-text label)
                       (format nil "~A"
                               (gtk-spin-button-value spinner1)))))
            (gtk-box-pack-start hbox button))

          ;; Get the value of the accelerated spin button.
          (gtk-box-pack-start vbox
                              (make-instance 'gtk-label
                                             :label "<b>Get Value</b>"
                                             :halign :start
                                             :margin-top 3
                                             :margin-bottom 3
                                             :use-markup t)
                            :expand nil)
          (gtk-box-pack-start vbox label)
          (gtk-box-pack-start vbox hbox)))
      (gtk-container-add window vbox)
      (gtk-widget-show-all window))))

   

;;;; Combo Box

(in-package :gtk-example)

(defparameter *icon-list*
              '(("gchararray" "gchararray")
                ("dialog-warning" "Warning")
                ("process-stop" "Stop")
                ("document-new" "New")
                ("edit-clear" "Clear")
                ("" "separator")
                ("document-open" "Open")))

(defun create-and-fill-list-store (data)
  (flet ((mklist (obj) (if (listp obj) obj (list obj))))
    (let ((model (apply #'gtk-list-store-new (mklist (first data)))))
      (dolist (entry (rest data))
        (let ((iter (gtk-list-store-append model)))
          (apply #'gtk-list-store-set model iter (mklist entry))))
      model)))

(defun set-sensitivity (layout cell model iter)
  (declare (ignore layout))
  (let* ((path (gtk-tree-model-path model iter))
         (pathstr (gtk-tree-path-to-string path)))
    (if (string= "1" pathstr)
        (setf (gtk-cell-renderer-sensitive cell) nil)
        (setf (gtk-cell-renderer-sensitive cell) t))))

(defun example-combo-box ()
  (within-main-loop
    (let* ((window (make-instance 'gtk-window
                                 :border-width 12
                                 :title "Example Combo Box"))
           (vbox1 (make-instance 'gtk-box
                                 :orientation :vertical
                                 :spacing 6))
           (vbox2 (make-instance 'gtk-box
                                 :orientation :vertical
                                 :spacing 6))
           (hbox (make-instance 'gtk-box
                                :orientation :horizontal
                                :spacing 24))
           (label (make-instance 'gtk-label :label "label"))
           (model (create-and-fill-list-store *icon-list*))
           (combo (make-instance 'gtk-combo-box
                                 :model model)))
      ;; Setup Cell Renderer for icon
      (let ((renderer (gtk-cell-renderer-pixbuf-new)))
        (setf (gtk-cell-renderer-xpad renderer) 6) ; More space between cells
        (gtk-cell-layout-pack-start combo renderer :expand nil)
        (gtk-cell-layout-set-attributes combo renderer "icon-name" 0)
        (gtk-cell-layout-set-cell-data-func combo renderer #'set-sensitivity))
      ;; Setup Cell Renderer for icon-name
      (let ((renderer (gtk-cell-renderer-text-new)))
        (gtk-cell-layout-pack-start combo renderer)
        (gtk-cell-layout-set-attributes combo renderer "text" 1)
        (gtk-cell-layout-set-cell-data-func combo renderer #'set-sensitivity))
      ;; Setup a Row Separator Function
      (gtk-combo-box-set-row-separator-func combo
          (lambda (object iter)
            (let ((value (gtk-tree-model-value object iter 1)))
              (string= value "separator"))))
      ;; Combo box selection has changed
      (g-signal-connect combo "changed"
          (lambda (object)
            (let ((value (gtk-combo-box-active-id object)))
              (gtk-label-set-markup label
                                    (format nil "<tt>~a</tt>" value)))))
      (setf (gtk-combo-box-id-column combo) 1)
      (setf (gtk-combo-box-active combo) 0)
      ;; Pack and show widgets
      (gtk-box-pack-start vbox1
                          (make-instance 'gtk-label
                                         :use-markup t
                                         :xalign 0
                                         :label "<b>Select item</b>")
                          :expand nil)
      (gtk-box-pack-start vbox1 combo)
      (gtk-box-pack-start vbox2
                          (make-instance 'gtk-label
                                         :use-markup t
                                         :xaling 0
                                         :label "<b>Activated item</b>")
                          :expand nil)
      (gtk-box-pack-start vbox2 label)
      (gtk-box-pack-start hbox vbox1)
      (gtk-box-pack-start hbox vbox2)
      (gtk-container-add window hbox)
      (gtk-widget-show-all window))))

   

;;;; Combo Box Text

(in-package :gtk-example)

(defun example-combo-box-text ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :border-width 12
                                 :title "Example Combo Box Text"))
          (vbox1 (make-instance 'gtk-box
                                :orientation :vertical
                                :spacing 6))
          (vbox2 (make-instance 'gtk-box
                                :orientation :vertical
                                :spacing 6))
          (hbox (make-instance 'gtk-box
                               :orientation :horizontal
                               :spacing 24))
          (label (make-instance 'gtk-label :label "Label"))
          (combo (make-instance 'gtk-combo-box-text
                                :has-entry t)))
      ;; Setup the combo box
      (gtk-combo-box-text-append-text combo "First entry")
      (gtk-combo-box-text-append-text combo "Second entry")
      (gtk-combo-box-text-append-text combo "Third entry")
      ;; Combo box selection has changed
      (g-signal-connect combo "changed"
          (lambda (object)
            (let ((value (gtk-combo-box-text-active-text object)))
              (gtk-label-set-markup label
                                    (format nil "<tt>~a</tt>" value)))))
      ;; Select the first entry of the combo box
      (setf (gtk-combo-box-active combo) 0)
      ;; Setup the entry for the combo box
      (let ((entry (gtk-bin-child combo)))
        (setf (gtk-entry-primary-icon-name entry) "list-add")
        (setf (gtk-entry-primary-icon-tooltip-text entry) "Add to Combo Box")
        (setf (gtk-entry-secondary-icon-name entry) "list-remove")
        (setf (gtk-entry-secondary-icon-tooltip-text entry)
              "Remove from Combo Box")
        ;; Toggle the primary and secondary icons of the entry
        (g-signal-connect entry "focus-in-event"
            (lambda (widget event)
              (declare (ignore event))
              (setf (gtk-entry-primary-icon-sensitive widget) t)
              (setf (gtk-entry-secondary-icon-sensitive widget) nil)))
        (g-signal-connect entry "focus-out-event"
            (lambda (widget event)
              (declare (ignore event))
              (setf (gtk-entry-primary-icon-sensitive widget) nil)
              (setf (gtk-entry-secondary-icon-sensitive widget) t)))
        ;; One of the icons of the entry has been pressed
        (g-signal-connect entry "icon-press"
            (lambda (object pos event)
              (declare (ignore event))
              (if (eq :primary pos)
                  (let ((text (gtk-entry-text object)))
                    (gtk-combo-box-text-append-text combo text))
                  (let ((active (gtk-combo-box-active combo)))
                    (gtk-combo-box-text-remove combo active)
                    (setf (gtk-combo-box-active combo) active))))))
      ;; Pack and show widgets
      (gtk-box-pack-start vbox1 (make-instance 'gtk-label
                                               :xalign 0
                                               :use-markup t
                                               :label "<b>Select item</b>")
                                :expand nil)
      (gtk-box-pack-start vbox1 combo)
      (gtk-box-pack-start hbox vbox1)
      (gtk-box-pack-start vbox2 (make-instance 'gtk-label
                                               :xalign 0
                                               :use-markup t
                                               :label "<b>Activated item</b>")
                                 :expand nil)
      (gtk-box-pack-start vbox2 label)
      (gtk-box-pack-start hbox vbox2)
      (gtk-container-add window hbox)
      (gtk-widget-show-all window))))

   

;;;; Example Tool Palette
;;;;
;;;; A tool palette widget shows groups of toolbar items as a grid of icons or
;;;; a list of names.
;;;;
;;;; 2021-3-15

(in-package #:gtk-example)

(defun load-icon-items (palette)
  (let* ((max-icons 24) ; Do not load too much icons.
         (icon-theme (gtk-icon-theme-for-screen (gtk-widget-screen palette)))
         (contexts (gtk-icon-theme-list-contexts icon-theme)))
    (dolist (context contexts)
      (let ((group (gtk-tool-item-group-new context))
            (icons (gtk-icon-theme-list-icons icon-theme context)))
        (dolist (icon-name (subseq icons 0 (min max-icons (length icons))))
          (let ((item (make-instance 'gtk-tool-button
                                     :icon-name icon-name
                                     :label icon-name
                                     :tooltip-text icon-name)))
            (gtk-tool-item-group-insert group item -1)))
         (gtk-container-add palette group)))))

;; Palette DnD

(defun palette-drop-item (drag-item drop-group x y)
  (let ((drag-group (gtk-widget-parent drag-item))
        (drop-item (gtk-tool-item-group-drop-item drop-group x y))
        (drop-position -1))

    (format t "PALETTE-DROP-ITEM~%")
    (format t "   drag-group : ~A~%" drag-group)
    (format t "   drop-item  : ~A~%" drop-item)

    (when drop-item
      (setf drop-position
            (gtk-tool-item-group-child-position drop-group drop-item)))

    (format t "   drop-pos   : ~A~%" drop-position)

    (if (not (equal drag-group drop-group))
        (progn
          (format t "DRAG-GROUP and DROP-GROUP are different~%")
          (let ((child-props (gtk-container-child-get drag-group
                                                      drag-item
                                                      "homogeneous"
                                                      "expand"
                                                      "fill"
                                                      "new-row")))

            (format t "   child-props : ~A~%" child-props)

            (gtk-container-remove drag-group drag-item)
            (gtk-tool-item-group-insert drop-group drag-item drop-position)
            ;; FIXME: Does not work. Tries to assign NIL to a pointer.
            ;; This need to be fixed more general.
;            (gtk-container-child-set drop-group
;                                     drag-item
;                                     "homogenous" (pop child-props)
;                                     "expand" (pop child-props)
;                                     "fill" (pop child-props)
;                                     "new-row" (pop child-props))))
          ))
        (setf (gtk-tool-item-group-child-position drop-group drag-item)
              drop-position))))


(defun palette-drop-group (palette drag-group drop-group)
  (let ((drop-position -1))

    (format t "pos drag-group  : ~a~%"
              (gtk-tool-palette-group-position palette drag-group))
    (format t "pos drop-group  : ~a~%"
              (gtk-tool-palette-group-position palette drop-group))

    (when drop-group
      (setf drop-position
            (gtk-tool-palette-group-position palette drop-group)))

    (format t "drop-position   : ~a~%" drop-position)
    ;; FIXME: This does not work. The position is not changed.
    ;; Is this a bug in C Library? Does not work for the C gtk3-demo, too.
    (setf (gtk-tool-palette-group-position palette drag-group) drop-position)))


(defun palette-drag-date-received (widget context x y selection info time)
  (let ((drag-palette (gtk-drag-source-widget context)))

    (format t "DRAG-DATA-RECEIVED~%")
    (format t "   widget       : ~A~%" widget)
    (format t "   context      : ~A~%" context)
    (format t "   x,y          : ~A, ~A~%" x y)
    (format t "   selection    : ~A~%" selection)
    (format t "   info         : ~A~%" info)
    (format t "   time         : ~A~%" time)

    ;; Get the tool palette CONTEXT belongs to, its a parent widget
    (loop while (and drag-palette
                     (not (g-type-is-a (g-object-type drag-palette)
                                       "GtkToolPalette")))
          do (setf drag-palette
                   (gtk-widget-parent drag-palette)))

    (format t "   drag-palette : ~A~%~%" drag-palette)

    (when drag-palette
      (let ((drag-item (gtk-tool-palette-drag-item drag-palette selection))
            (drop-group (gtk-tool-palette-drop-group widget x y)))

        (format t "   drag-item    : ~A~%" drag-item)
        (format t "   drop-group   : ~A~%" drop-group)

        (cond ((g-type-is-a (g-object-type drag-item) "GtkToolItemGroup")
               (format t "PALETTE DROP GROUP~%")
               (palette-drop-group drag-palette drag-item drop-group))
              ((and drop-group
                    (g-type-is-a (g-object-type drag-item) "GtkToolItem"))
               (format t "PALETTE DROP ITEM~%")
               (let ((allocation (gtk-widget-allocation drop-group)))
                 (format t "   allocation = ~A~%" allocation)
                 (palette-drop-item drag-item
                                    drop-group
                                    (- x (gdk-rectangle-x allocation))
                                    (- y (gdk-rectangle-y allocation)))))
              (t
               (format t "NO VALID DRAG~%")))))))

;; Passive DnD

(defvar *canvas-items* nil)

(defstruct canvas-item
  pixbuf
  x
  y)

(defun canvas-item-new (widget button x y)
  (let* ((item (make-canvas-item))
         (icon-theme (gtk-icon-theme-for-screen (gtk-widget-screen widget)))
         (icon-name (gtk-tool-button-icon-name button))
         (icon-size 48) ; workaround, better implementation needed
         (pixbuf (gtk-icon-theme-load-icon icon-theme
                                           icon-name
                                           icon-size
                                           :generic-fallback)))
    (when pixbuf
      (setf (canvas-item-pixbuf item) pixbuf)
      (setf (canvas-item-x item) x)
      (setf (canvas-item-y item) y))
    item))

(defun canvas-item-draw (item cr preview)
  (let ((cx (gdk-pixbuf-width (canvas-item-pixbuf item)))
        (cy (gdk-pixbuf-height (canvas-item-pixbuf item))))

    (gdk-cairo-set-source-pixbuf cr (canvas-item-pixbuf item)
                                    (- (canvas-item-x item) (* 0.5d0 cx))
                                    (- (canvas-item-y item) (* 0.5d0 cy)))

    (if preview
        (cairo-paint-with-alpha cr 0.6d0)
        (cairo-paint cr))))

(defun canvas-draw (widget cr)
  (declare (ignore widget))
  (let ((cr (pointer cr)))

    (cairo-set-source-rgb cr 1.0 1.0 1.0)
    (cairo-paint cr)

    (dolist (item *canvas-items*)
      (canvas-item-draw item cr nil))

    (cairo-destroy cr)))


(defun passive-canvas-drag-data-received (widget context x y selection info time)
  (let ((palette (gtk-drag-source-widget context))
        (tool-item nil))

    (format t "DRAG-DATA-RECEIVED~%")
    (format t "   widget       : ~A~%" widget)
    (format t "   context      : ~A~%" context)
    (format t "   x,y          : ~A, ~A~%" x y)
    (format t "   selection    : ~A~%" selection)
    (format t "   info         : ~A~%" info)
    (format t "   time         : ~A~%" time)

    ;; Get the tool palette CONTEXT belongs to, its a parent widget
    (loop while (and palette
                     (not (g-type-is-a (g-object-type palette)
                                       "GtkToolPalette")))
          do (setf palette
                   (gtk-widget-parent palette)))

    (when palette
      (setf tool-item
            (gtk-tool-palette-drag-item palette selection)))

    (when tool-item
      (let ((canvas-item (canvas-item-new widget tool-item x y)))
        (when canvas-item
          (push canvas-item *canvas-items*)
          (gtk-widget-queue-draw widget))))))


(defun example-tool-palette ()
  (within-main-loop
    (let* (;; Create a toplevel window.
           (window (make-instance 'gtk-window
                                  :type :toplevel
                                  :title "Example Tool Palette"
                                  :border-width 12))
           ;; A horizontal Box for the content of the window.
           (content (make-instance 'gtk-grid
                                   :orientation :horizontal
                                   :column-spacing 24))
           ;; A scrollable
           (scroller (make-instance 'gtk-scrolled-window
                                    :hscrollbar-policy :never
                                    :vscrollbar-policy :automatic
                                    :hexpand t
                                    :vexpand t
                                    :default-width 300))
           ;; A tool palette
           (palette (make-instance 'gtk-tool-palette
                                   :default-width 300))
           ;; A vertical Grid for the actions.
           (action (make-instance 'gtk-grid
                                  :orientation :vertical
                                  :row-spacing 6))
           (contents (make-instance 'gtk-drawing-area
                                    :app-paintable t))
           (notebook (make-instance 'gtk-notebook
                                    :border-width 6))
           (page-1 (make-instance 'gtk-grid
                                  :border-width 12
                                  :orientation :vertical
                                  :row-spacing 6))
;           (page-2 (make-instance 'gtk-grid
;                                  :border-width 12
;                                  :orientation :vertical
;                                  :row-spacing 6))
)
      ;; Signal handler for the window to handle the signal "destroy".
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))

      ;; Orientation combo box
      (let ((combo (make-instance 'gtk-combo-box-text)))
        (g-signal-connect combo "changed"
           (lambda (combobox)
             (let* ((text (gtk-combo-box-text-active-text combobox))
                    (orientation (cdr (assoc text
                                             '(("Vertical" . :vertical)
                                               ("Horizontal" . :horizontal))
                                             :test #'string=))))
               (setf (gtk-orientable-orientation palette) orientation)
               (if (eq orientation :horizontal)
                   (setf (gtk-scrolled-window-policy scroller)
                         '(:automatic :never))
                   (setf (gtk-scrolled-window-policy scroller)
                         '(:never :automatic))))))
        (gtk-combo-box-text-append-text combo "Vertical")
        (gtk-combo-box-text-append-text combo "Horizontal")
        (setf (gtk-combo-box-active combo) 0)
        (gtk-container-add page-1
                           (make-instance 'gtk-label
                                          :use-markup t
                                          :xalign 0.0
                                          :margin-top 12
                                          :label "<b>Orientation</b>"))
        (gtk-container-add page-1 combo))

      ;; Style combo box
      (let ((combo (make-instance 'gtk-combo-box-text)))
        (g-signal-connect combo "changed"
           (lambda (combobox)
             (let* ((text (gtk-combo-box-text-active-text combobox))
                    (style (cdr (assoc text
                                             '(("Icons" . :icons)
                                               ("Text" . :text)
                                               ("Both" . :both)
                                               ("Both Horizontal" . :both-horiz)
                                               ("Default" . :default))
                                             :test #'string=))))
               (if (eq style :default)
                   ;; FIXME: This seems not to work as accepted.
                   (gtk-tool-palette-unset-style palette)
                   (setf (gtk-tool-palette-toolbar-style palette) style)))))
        (gtk-combo-box-text-append-text combo "Icons")
        (gtk-combo-box-text-append-text combo "Text")
        (gtk-combo-box-text-append-text combo "Both")
        (gtk-combo-box-text-append-text combo "Both Horizontal")
        (gtk-combo-box-text-append-text combo "Default")
        (setf (gtk-combo-box-active combo) 0)
        (gtk-container-add page-1
                           (make-instance 'gtk-label
                                          :use-markup t
                                          :xalign 0.0
                                          :margin-top 12
                                          :label
                                          "<b>Style</b>"))
        (gtk-container-add page-1 combo))

      ;; Icon size combo box
      (let ((combo (make-instance 'gtk-combo-box-text)))
        (g-signal-connect combo "changed"
           (lambda (combobox)
             (let* ((text (gtk-combo-box-text-active-text combobox))
                    (size (cdr (assoc text
                                      '(("Menu" . :menu)
                                        ("Small Toolbar" . :small-toolbar)
                                        ("Large Toolbar" . :large-toolbar)
                                        ("Button" . :button)
                                        ("Dnd" . :dnd)
                                        ("Dialog" . :dialog))
                                      :test #'equal))))
               (format t "Signal CHANGED text = ~A, size = ~A~%" text size)
               (setf (gtk-tool-palette-icon-size palette) size))))
        (gtk-combo-box-text-append-text combo "Menu")
        (gtk-combo-box-text-append-text combo "Small Toolbar")
        (gtk-combo-box-text-append-text combo "Large Toolbar")
        (gtk-combo-box-text-append-text combo "Button")
        (gtk-combo-box-text-append-text combo "Dnd")
        (gtk-combo-box-text-append-text combo "Dialog")
        (setf (gtk-combo-box-active combo) 1)
        (gtk-container-add page-1
                           (make-instance 'gtk-label
                                          :use-markup t
                                          :xalign 0.0
                                          :margin-top 12
                                          :label
                                          "<b>Icon Size</b>"))
        (gtk-container-add page-1 combo))

      (gtk-notebook-append-page notebook
                                page-1
                                (make-instance 'gtk-label
                                               :label "Properties"))

      ;; Fill the tool palette
      (load-icon-items palette)
      ;; Add the palette to the scrolled window
      (gtk-container-add scroller palette)
      ;; Add the scrolled window to the content
      (gtk-container-add content scroller)

      ;; DnD for tool items
      (gtk-tool-palette-add-drag-dest palette
                                      palette
                                      '(:all)
                                      '(:items :groups)
                                      '(:move))
      (g-signal-connect palette
                        "drag-data-received"
                        #'palette-drag-date-received)


      ;; Passive DnD dest

      (g-signal-connect contents "draw" #'canvas-draw)
      (g-signal-connect contents "drag-data-received"
                                 #'passive-canvas-drag-data-received)

      (gtk-tool-palette-add-drag-dest palette contents :all :items :copy)

      (let ((page-2 (make-instance 'gtk-scrolled-window
                                   :border-width 6
                                   :hscrollbar-policy :automatic
                                   :vscrollbar-policy :always)))
        (gtk-container-add page-2 contents)

        (gtk-notebook-append-page notebook
                                  page-2
                                  (make-instance 'gtk-label
                                                 :label "Passive DnD Mode")))

      ;; Add the notebook to the action container
      (gtk-container-add action notebook)

      ;; A Quit button
      (let ((button (make-instance 'gtk-button
                                   :label "Quit"
                                   :margin-top 12)))
        (g-signal-connect button "clicked"
           (lambda (widget)
             (declare (ignore widget))
             (gtk-widget-destroy window)))
        ;; Add the quit button to the action container
        (gtk-container-add action button))

      ;; Add frame, content, and action to the window.
      (gtk-container-add content action)
      (gtk-container-add window content)
      ;; Show the window.
      (gtk-widget-show-all window))))

   

;;;; Create Page Setup Dialog (2021-3-17)

(in-package :gtk-example)

(defun create-page-setup-dialog ()
  (let ((page-setup (gtk-page-setup-new))
        (dialog (make-instance 'gtk-page-setup-unix-dialog
                               :title "Page Setup Dialog"
                               :default-height 250
                               :default-width 400)))
    ;; Load and set Page setup from file
    (if (gtk-page-setup-load-file page-setup (sys-path "page-setup.ini"))
        (format t "PAGE SETUP successfully loaded~%")
        (format t "PAGE SETUP cannot be loaded, use standard settings~%"))
    (setf (gtk-page-setup-unix-dialog-page-setup dialog) page-setup)
    ;; Run the dialog
    (when (eq :ok (gtk-dialog-run dialog))
      (setf page-setup (gtk-page-setup-unix-dialog-page-setup dialog))
      (gtk-page-setup-to-file page-setup (sys-path "page-setup.ini")))
    ;; Destroy the dialog
    (gtk-widget-destroy dialog)))

   

;;;; Print Operation - 2021-3-17
;;;;
;;;; GtkPrintOperation offers a simple API to support printing in a
;;;; cross-platform way.

(in-package :gtk-example)

(defstruct print-data
  filename
  header-height
  header-gap
  header-font-size
  font-size
  lines
  lines-per-page
  number-lines
  number-pages)

(defvar *data* (make-print-data :filename (sys-path "print-operation.lisp")
                                :font-size 10
                                :header-font-size 11
                                :header-height 22
                                :header-gap 11))

(defun begin-print (operation context)
  ;; Load and split the file to print into a list of lines
  (setf (print-data-lines *data*)
        (split-sequence #\linefeed (read-file (print-data-filename *data*))))
  ;; Calculate and save the number of lines to print
  (setf (print-data-number-lines *data*)
        (length (print-data-lines *data*)))
  ;; Calculate and save the number of lines per page
  (setf (print-data-lines-per-page *data*)
        (floor (/ (- (gtk-print-context-height context)
                     (print-data-header-height *data*)
                     (print-data-header-gap *data*))
                  (print-data-font-size *data*))))
  ;; Calculate and save the number of pages to print
  (setf (print-data-number-pages *data*)
        (ceiling (/ (print-data-number-lines *data*)
                 (print-data-lines-per-page *data*))))
  ;; Set the number of pages to the print operation
  (setf (gtk-print-operation-n-pages operation)
        (print-data-number-pages *data*)))

(defun draw-page (operation context page-nr)
  (declare (ignore operation))
  (let ((cr (gtk-print-context-cairo-context context))
        (width (floor (gtk-print-context-width context)))
        (layout (gtk-print-context-create-pango-layout context)))

    ;; 1. Print the header
    ;; Print a grey colored bar
    (cairo-rectangle cr 0 0 width (print-data-header-height *data*))
    (cairo-set-source-rgb cr 0.9 0.9 0.9)
    (cairo-fill cr)

    ;; Set the font for the header
    (let ((desc (pango-font-description-from-string "sans")))
      (setf (pango-font-description-size desc)
            (* (print-data-header-font-size *data*) +pango-scale+))
      (setf (pango-layout-font-description layout) desc))
    ;; Set the text for the header
    (setf (pango-layout-text layout) (print-data-filename *data*))
    (setf (pango-layout-width layout) (* width +pango-scale+))
    (setf (pango-layout-alignment layout) :center)

    ;; Print the filename in the header
    (multiple-value-bind (text-width text-height)
        (pango-layout-pixel-size layout)
      (declare (ignore text-width))
      ;; Set color to black and center the text in header
      (cairo-set-source-rgb cr 0.0 0.0 0.0)
      (cairo-move-to cr 0 (floor (/ (- (print-data-header-height *data*)
                                       text-height)
                                    2)))
      (pango-cairo-show-layout cr layout))

    ;; Print the page number in the header
    (setf (pango-layout-text layout)
          (format nil "~d/~d" (+ page-nr 1) (print-data-number-pages *data*)))
    (setf (pango-layout-width layout) -1)
    (multiple-value-bind (text-width text-height)
        (pango-layout-pixel-size layout)
      (cairo-move-to cr (floor (- width text-width 4))
                        (floor (/ (- (print-data-header-height *data*)
                                     text-height)
                                  2)))
      (pango-cairo-show-layout cr layout))

    ;; 2. Print the text on the page
    (setf layout (gtk-print-context-create-pango-layout context))
    ;; Set the font for the page
    (let ((desc (pango-font-description-from-string "monospace")))
      (setf (pango-font-description-size desc)
            (* (print-data-font-size *data*) +pango-scale+))
      (setf (pango-layout-font-description layout) desc))
    ;; Move to the start of the page
    (cairo-move-to cr 0 (+ (print-data-header-height *data*)
                           (print-data-header-gap *data*)))

    ;; Print the lines on the page
    (do ((i 0 (+ i 1))
         (line (* page-nr (print-data-lines-per-page *data*)) (+ line 1)))
        ((or (>= i (print-data-lines-per-page *data*))
             (>= line (print-data-number-lines *data*))))
      (setf (pango-layout-text layout)
            (pop (print-data-lines *data*)))
      (pango-cairo-show-layout cr layout)
      (cairo-rel-move-to cr 0 (print-data-font-size *data*)))))

(defun do-print-operation ()
  (let* ((response nil)
         (filename (sys-path "print-dialog.ini"))
         (settings (gtk-print-settings-new-from-file filename))
         (print (gtk-print-operation-new)))
    ;; Connect signal handlers for the print operation
    (g-signal-connect print "draw-page" #'draw-page)
    (g-signal-connect print "begin-print" #'begin-print)
    ;; Restore the print settings
    (when settings
      (setf (gtk-print-operation-print-settings print) settings))
    ;; Perform the print operation
    (setf response (gtk-print-operation-run print :print-dialog nil))
    ;; Check the response and save the print settings
    (when (eq :apply response)
      (format t "~&Save print settings to ~A~%" (sys-path "print-dialog.ini"))
      (setf settings (gtk-print-operation-print-settings print))
      (gtk-print-settings-to-file settings (sys-path "print-dialog.ini")))))

   

;;;; Simple Application

(in-package #:gtk-example)

(defclass bloat-pad (gtk-application)
  ()
;  (:g-type-name . "BloatPad")
  (:metaclass gobject-class))

(register-object-type-implementation "BloatPad"
                                     bloat-pad
                                     "GtkApplication"
                                     nil
                                     nil)

(defun new-window (application file)
  (declare (ignore file))
    (let (;; Create the application window
          (window (make-instance 'gtk-application-window
                                 :application application
                                 :title "Bloatpad"
                                 :border-width 12
                                 :default-width 500
                                 :default-height 400))
          (grid (make-instance 'gtk-grid))
          (toolbar (make-instance 'gtk-toolbar)))

      ;; Connect signal "destroy" to the application window
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)
                          (if (zerop gtk::*main-thread-level*)
                              (g-application-quit application))))

      ;; Add action "copy" to the application window
      (let ((action (g-simple-action-new "copy" nil)))
        (g-action-map-add-action window action)
        (g-signal-connect action "activate"
           (lambda (action parameter)
             (declare (ignore action parameter))
             (let ((view (gobject::get-g-object-for-pointer
                           (g-object-data window "bloatpad-text"))))
               (gtk-text-buffer-copy-clipboard
                                  (gtk-text-view-buffer view)
                                  (gtk-widget-clipboard view "CLIPBOARD"))))))

      ;; Add action "paste" to the application window
      (let ((action (g-simple-action-new "paste" nil)))
        (g-action-map-add-action window action)
        (g-signal-connect action "activate"
           (lambda (action parameter)
             (declare (ignore action parameter))
             (let ((view (gobject::get-g-object-for-pointer
                           (g-object-data window "bloatpad-text"))))
               (gtk-text-buffer-paste-clipboard
                                       (gtk-text-view-buffer view)
                                       (gtk-widget-clipboard view "CLIPBOARD")
                                       :editable t)))))

      ;; Add action "fullscreen" to the application window
      (let ((action (g-simple-action-new-stateful
                                               "fullscreen"
                                               nil
                                               (g-variant-new-boolean nil))))
        (g-action-map-add-action window action)
        (g-signal-connect action "activate"
           (lambda (action parameter)
             (declare (ignore parameter))
             (let* ((state (g-action-state action))
                    (value (g-variant-boolean state)))
               (g-action-change-state action
                                      (g-variant-new-boolean (not value))))))
        (g-signal-connect action "change-state"
           (lambda (action parameter)
             (if (g-variant-boolean parameter)
                 (gtk-window-fullscreen window)
                 (gtk-window-unfullscreen window))
             (setf (g-simple-action-state action) parameter))))

      ;; Add action "justify" to the application window
      (let ((action (g-simple-action-new-stateful
                                             "justify"
                                             (g-variant-type-new "s")
                                             (g-variant-new-string "left"))))
        (g-action-map-add-action window action)
        (g-signal-connect action "activate"
           (lambda (action parameter)
             (g-action-change-state action parameter)))
        (g-signal-connect action "change-state"
           (lambda (action parameter)
             (let ((view (gobject::get-g-object-for-pointer
                           (g-object-data window "bloatpad-text")))
                   (str (g-variant-string parameter)))
               (cond ((equal str "left")
                      (setf (gtk-text-view-justification view) :left))
                     ((equal str "center")
                      (setf (gtk-text-view-justification view) :center))
                     (t
                      (setf (gtk-text-view-justification view) :right)))
               (setf (g-simple-action-state action) parameter)))))

      ;; Left justify toggle tool button for the toolbar
      (let ((button (make-instance 'gtk-toggle-tool-button
                                   :icon-name "format-justify-left")))
        (gtk-actionable-set-detailed-action-name button "win.justify::left")
        (gtk-container-add toolbar button))

      ;; Center justify toggle tool button for the toolbar
      (let ((button (make-instance 'gtk-toggle-tool-button
                                   :icon-name "format-justify-center")))
        (gtk-actionable-set-detailed-action-name button "win.justify::center")
        (gtk-container-add toolbar button))

      ;; Right justify toggle tool button for the toolbar
      (let ((button (make-instance 'gtk-toggle-tool-button
                                   :icon-name "format-justify-right")))
        (gtk-actionable-set-detailed-action-name button "win.justify::right")
        (gtk-container-add toolbar button))

      ;; Invisible separator which shift the next tool item to the right
      (let ((button (make-instance 'gtk-separator-tool-item
                                   :draw nil)))
        (setf (gtk-tool-item-expand button) t)
        (gtk-container-add toolbar button))

      ;; A label and a switch on the right of the toolbar
      (let ((button (make-instance 'gtk-tool-item))
            (box (make-instance 'gtk-box
                                :orientation :horizontal
                                :spacing 6))
            (label (make-instance 'gtk-label
                                  :label "Fullscreen:"))
            (switch (make-instance 'gtk-switch)))
        (setf (gtk-actionable-action-name switch) "win.fullscreen")
        (gtk-container-add box label)
        (gtk-container-add box switch)
        (gtk-container-add button box)
        (gtk-container-add toolbar button))

      ;; Place the toolbar in the grid
      (gtk-grid-attach grid toolbar 0 0 1 1)


      (let ((scrolled (make-instance 'gtk-scrolled-window
                                     :hexpand t
                                     :vexpand t))
            (view (make-instance 'gtk-text-view)))
        (setf (g-object-data window "bloatpad-text") (pointer view))
        (gtk-container-add scrolled view)
        (gtk-grid-attach grid scrolled 0 1 1 1))

      (gtk-container-add window grid)
      (gtk-widget-show-all window)))

(defun bloat-pad-activate (application)
  ;; Create a new application window
  (new-window application nil))

(defun create-about-dialog ()
  (let (;; Create an about dialog
        (dialog (make-instance 'gtk-about-dialog
                               :program-name "Simple Application"
                               :version "0.9"
                               :copyright "(c) Dieter Kaiser"
                               :website
                               "github.com/crategus/cl-cffi-gtk"
                               :website-label "Project web site"
                               :license "LLGPL"
                               :authors '("Dieter Kaiser")
                               :documenters '("Dieter Kaiser")
                               :artists '("None")
                               :logo-icon-name
                               "applications-development"
                               :wrap-license t)))
    ;; Run the about dialog
    (gtk-dialog-run dialog)
    ;; Destroy the about dialog
    (gtk-widget-destroy dialog)))

(defvar *menu*
  "<interface>
    <menu id='app-menu'>
     <section>
      <item>
       <attribute name='label' translatable='yes'>_New Window</attribute>
       <attribute name='action'>app.new</attribute>
       <attribute name='accel'>&lt;Primary&gt;n</attribute>
      </item>
     </section>
     <section>
      <item>
       <attribute name='label' translatable='yes'>_About Bloatpad</attribute>
       <attribute name='action'>app.about</attribute>
      </item>
     </section>
     <section>
      <item>
       <attribute name='label' translatable='yes'>_Quit</attribute>
       <attribute name='action'>app.quit</attribute>
       <attribute name='accel'>&lt;Primary&gt;q</attribute>
      </item>
     </section>
     </menu>
    <menu id='menubar'>
     <submenu>
      <attribute name='label' translatable='yes'>_Edit</attribute>
      <section>
       <item>
        <attribute name='label' translatable='yes'>_Copy</attribute>
        <attribute name='action'>win.copy</attribute>
        <attribute name='accel'>&lt;Primary&gt;c</attribute>
       </item>
       <item>
        <attribute name='label' translatable='yes'>_Paste</attribute>
        <attribute name='action'>win.paste</attribute>
        <attribute name='accel'>&lt;Primary&gt;v</attribute>
       </item>
      </section>
     </submenu>
     <submenu>
      <attribute name='label' translatable='yes'>_View</attribute>
      <section>
       <item>
        <attribute name='label' translatable='yes'>_Fullscreen</attribute>
        <attribute name='action'>win.fullscreen</attribute>
        <attribute name='accel'>F11</attribute>
       </item>
      </section>
     </submenu>
    </menu>
   </interface>")

(defun bloat-pad-startup (application)
  ;; Add action "new" to the application
  (let ((action (g-simple-action-new "new" nil)))
    ;; Connect a handler to the signal "activate"
    (g-signal-connect action "activate"
       (lambda (action parameter)
         (declare (ignore action parameter))
         ;; ensure-gtk-main increases the thread level for the new window
         (ensure-gtk-main)
         (new-window application nil)))
    ;; Add the action to the action map of the application
    (g-action-map-add-action application action))

  ;; Add action "about" to the application
  (let ((action (g-simple-action-new "about" nil)))
    ;; Connect a handler to the signal "activate"
    (g-signal-connect action "activate"
       (lambda (action parameter)
         (declare (ignore action parameter))
         (create-about-dialog)))
    ;; Add the action to the action map of the application
    (g-action-map-add-action application action))

  ;; Add action "quit" to the application
  (let ((action (g-simple-action-new "quit" nil)))
    ;; Connect a handler to the signal activate
    (g-signal-connect action "activate"
       (lambda (action parameter)
         (declare (ignore action parameter))
         ;; Destroy all windows of the application
         (dolist (window (gtk-application-windows application))
           (gtk-widget-destroy window))
         ;; Quit the main loop
         (leave-gtk-main)
         ;; Quit the application
         (g-application-quit application)))
    ;; Add the action to action map of the application
    (g-action-map-add-action application action))

  ;; Intitialize the application menu and the menubar
  (let ((builder (make-instance 'gtk-builder)))
    ;; Read the menus from a string
    (gtk-builder-add-from-string builder *menu*)
    ;; Set the application menu
    (setf (gtk-application-app-menu application)
          (gtk-builder-object builder "app-menu"))
    ;; Set the menubar
    (setf (gtk-application-menubar application)
          (gtk-builder-object builder "menubar"))))

(defun bloat-pad-open (application)
  (declare (ignore application))
  ;; Executed when the application is opened
  nil)

(defun bloat-pad-shutdown (application)
  (declare (ignore application))
  ;; Executed when the application is shut down
  nil)

(defmethod initialize-instance :after
    ((app bloat-pad) &key &allow-other-keys)
  (g-signal-connect app "activate" #'bloat-pad-activate)
  (g-signal-connect app "startup" #'bloat-pad-startup)
  (g-signal-connect app "open" #'bloat-pad-open)
  (g-signal-connect app "shutdown" #'bloat-pad-shutdown))

(defun bloat-pad-new ()
  (unless (string= "Bloatpad" (g-application-name))
      (setf (g-application-name) "Bloatpad"))
  (make-instance 'bloat-pad
                 :application-id "com.crategus.bloatpad"
                 :flags :handles-open
                 :inactivity-timeout 30000
                 :register-session t))

(defun bloatpad (&optional (argv nil))
  (within-main-loop
    (let (;; Create an instance of the application Bloat Pad
          (bloat-pad (bloat-pad-new)))
      ;; Run the application
      (g-application-run bloat-pad argv))))

   

(asdf:load-system :cl-cffi-gtk)

(defpackage :cairo-clock
  (:use :gtk :gdk :gobject :glib :pango :cairo :cffi :iterate :common-lisp)
  (:export #:demo-cairo-clock))

(in-package :cairo-clock)

;; Class egg-clock-face is a subclass of a GtkDrawingArea

(defclass egg-clock-face (gtk-drawing-area)
  ((time :initarg :time
         :initform (multiple-value-list (get-decoded-time))
         :accessor egg-clock-face-time))
  (:metaclass gobject-class))

(defmethod initialize-instance :after
    ((clock egg-clock-face) &key &allow-other-keys)
  ;; A timeout source for the time
  (g-timeout-add 1000
                 (lambda ()
                   (setf (egg-clock-face-time clock)
                         (multiple-value-list (get-decoded-time)))
                   (gtk-widget-queue-draw clock)
                   +g-source-continue+))
  ;; Signal handler which draws the clock
  (g-signal-connect clock "draw"
     (lambda (widget cr)
       (let ((cr (pointer cr))
             ;; Get the GdkWindow for the widget
             (window (gtk-widget-window widget)))
       ;; Clear surface
       (cairo-set-source-rgb cr 1.0 1.0 1.0)
       (cairo-paint cr)
       (let* ((x (/ (gdk-window-width window) 2))
              (y (/ (gdk-window-height window) 2))
              (radius (- (min x y) 12)))
         ;; Clock back
         (cairo-arc cr x y radius 0 (* 2 pi))
         (cairo-set-source-rgb cr 1 1 1)
         (cairo-fill-preserve cr)
         (cairo-set-source-rgb cr 0 0 0)
         (cairo-stroke cr)
         ;; Clock ticks
         (let ((inset 0.0)
               (angle 0.0))
           (dotimes (i 12)
             (cairo-save cr)
             (setf angle (/ (* i pi) 6))
             (if (eql 0 (mod i 3))
                 (setf inset (* 0.2 radius))
                 (progn
                   (setf inset (* 0.1 radius))
                   (cairo-set-line-width cr
                                         (* 0.5 (cairo-get-line-width cr)))))
             (cairo-move-to cr
                            (+ x (* (- radius inset) (cos angle)))
                            (+ y (* (- radius inset) (sin angle))))
             (cairo-line-to cr
                            (+ x (* radius (cos angle)))
                            (+ y (* radius (sin angle))))
             (cairo-stroke cr)
             (cairo-restore cr)))
         (let ((seconds (first (egg-clock-face-time clock)))
               (minutes (second (egg-clock-face-time clock)))
               (hours (third (egg-clock-face-time clock))))
           ;; The hour hand is rotated 30 degrees (pi/6 r) per hour
           ;; + 1/2 a degree (pi/360 r) per minute
           (let ((hours-angle (* (/ pi 6) hours))
                 (minutes-angle (* (/ pi 360) minutes)))
             (cairo-save cr)
             (cairo-set-line-width cr (* 2.5 (cairo-get-line-width cr)))
             (cairo-move-to cr x y)
             (cairo-line-to cr
                            (+ x
                               (* (/ radius 2)
                                  (sin (+ hours-angle minutes-angle))))
                            (+ y
                               (* (/ radius 2)
                                  (- (cos (+ hours-angle minutes-angle))))))
             (cairo-stroke cr)
             (cairo-restore cr))
           ;; The minute hand is rotated 6 degrees (pi/30 r)
           ;; per minute
           (let ((angle (* (/ pi 30) minutes)))
             (cairo-move-to cr x y)
             (cairo-line-to cr
                            (+ x (* radius 0.75 (sin angle)))
                            (+ y (* radius 0.75 (- (cos angle)))))
             (cairo-stroke cr))
           ;; Seconds hand: Operates identically to the minute hand
           (let ((angle (* (/ pi 30) seconds)))
             (cairo-save cr)
             (cairo-set-source-rgb cr 1 0 0)
             (cairo-move-to cr x y)
             (cairo-line-to cr (+ x (* radius 0.7 (sin angle)))
                               (+ y (* radius 0.7 (- (cos angle)))))
             (cairo-stroke cr)
             (cairo-restore cr))))
       ;; Destroy the Cario context
       (cairo-destroy cr)
       t))))

(defun demo-cairo-clock ()
  (within-main-loop
    (let ((window (make-instance 'gtk-window
                                 :title "Demo Cairo Clock"
                                 :default-width 250
                                 :default-height 250))
          (clock (make-instance 'egg-clock-face)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-container-add window clock)
      (gtk-widget-show-all window))))