m2-GTK4/demos/DemosText.mod

IMPLEMENTATION MODULE DemosText ;

(*
   See the GTK C originals in gtk/demos/gtk-demo:
     read_more.c   -> DoReadMore
     rotated_text.c-> DoRotatedText
     textmask.c    -> DoTextMask
     textscroll.c  -> DoTextScroll
     textundo.c    -> DoTextUndo

   The gtk-demo contract is: on the first call build the window and store
   it in a module-level variable; on later calls just toggle the window's
   visibility, destroying it (and clearing the variable) when it is
   already visible.  Return the window, or NIL once destroyed.

   Several C helpers used by the originals are not part of the binding
   set under src/, so those spots are simplified and marked below:
     * ReadMore is a custom GtkWidget subclass with its own measure() and
       size_allocate(); subclassing is not exposed, so a plain wrapping
       GtkLabel plus a "Read More" button is used instead.
     * The Pango custom shape renderer / PangoAttrList of rotated_text
       are not bound; the layout is drawn with its plain font.
     * gtk_text_buffer_set_enable_undo(), *begin/end_irreversible_action()
       and gtk_text_view_scroll_mark_onscreen() are not bound.
     * cairo_fill_preserve() is not bound; textmask rebuilds the path to
       stroke the outline.
*)

FROM SYSTEM IMPORT ADDRESS, ADR, CAST;
FROM GtkWindow IMPORT gtk_window_new, gtk_window_set_title,
   gtk_window_set_default_size, gtk_window_set_resizable,
   gtk_window_set_child, gtk_window_destroy;
FROM GtkWidget IMPORT gtk_widget_set_visible, gtk_widget_get_visible,
   gtk_widget_set_size_request, gtk_widget_set_vexpand, gtk_widget_set_hexpand,
   gtk_widget_add_css_class;
FROM GtkBox IMPORT gtk_box_new, gtk_box_append;
FROM GtkEnums IMPORT GtkVertical, GtkHorizontal, GtkWrapWord;
FROM GtkLabel IMPORT gtk_label_new, gtk_label_set_wrap,
   gtk_label_set_max_width_chars;
FROM GtkButton IMPORT gtk_button_new_with_label;
FROM GtkScrolledWindow IMPORT gtk_scrolled_window_new,
   gtk_scrolled_window_set_child, gtk_scrolled_window_set_policy,
   GtkPolicyAutomatic;
FROM GtkTextView IMPORT gtk_text_view_new, gtk_text_view_get_buffer,
   gtk_text_view_set_wrap_mode, gtk_text_view_set_left_margin,
   gtk_text_view_set_right_margin, gtk_text_view_set_top_margin,
   gtk_text_view_set_bottom_margin, gtk_text_view_scroll_to_mark;
FROM GtkTextBuffer IMPORT gtk_text_buffer_get_start_iter,
   gtk_text_buffer_insert, gtk_text_buffer_get_end_iter,
   gtk_text_buffer_create_mark, gtk_text_buffer_get_mark,
   gtk_text_buffer_get_iter_at_mark;
FROM GtkTextIter IMPORT GtkTextIter;
FROM GtkDrawingArea IMPORT gtk_drawing_area_new,
   gtk_drawing_area_set_content_width, gtk_drawing_area_set_content_height,
   gtk_drawing_area_set_draw_func;
FROM Pango IMPORT pango_font_description_from_string,
   pango_font_description_free, pango_layout_set_text,
   pango_layout_set_font_description, pango_layout_get_pixel_size;
FROM PangoCairo IMPORT pango_cairo_create_layout, pango_cairo_show_layout,
   pango_cairo_update_layout;
FROM Cairo IMPORT cairo_move_to, cairo_rotate, cairo_scale, cairo_translate,
   cairo_set_source, cairo_save, cairo_restore, cairo_fill, cairo_stroke,
   cairo_set_source_rgb, cairo_set_line_width, cairo_select_font_face,
   cairo_set_font_size, cairo_text_path, cairo_pattern_create_linear,
   cairo_pattern_add_color_stop_rgb, cairo_pattern_destroy,
   CairoFontSlantNormal, CairoFontWeightBold;
FROM GObject IMPORT g_signal_connect_data, GConnectDefault, g_object_unref;
FROM GLib IMPORT g_timeout_add, g_source_remove, guint, GSourceContinue;

CONST
   (* rotated_text *)
   Radius = 150;                  (* pixels; window is 4*Radius by 2*Radius *)
   NWords = 5;
   Pi     = 3.141592653589793;
   RotatedText = "I \xE2\x99\xA5 GTK";

   ReadMoreText =
"I'd just like to interject for a moment. What you're referring to as Linux, is in fact, GNU/Linux, or as I've recently taken to calling it, GNU plus Linux. Linux is not an operating system unto itself, but rather another free component of a fully functioning GNU system made useful by the GNU corelibs, shell utilities and vital system components comprising a full OS as defined by POSIX.\n\nMany computer users run a modified version of the GNU system every day, without realizing it. Through a peculiar turn of events, the version of GNU which is widely used today is often called \x22Linux\x22, and many of its users are not aware that it is basically the GNU system, developed by the GNU Project.\n\nThere really is a Linux, and these people are using it, but it is just a part of the system they use. Linux is the kernel: the program in the system that allocates the machine's resources to the other programs that you run. The kernel is an essential part of an operating system, but useless by itself; it can only function in the context of a complete operating system. Linux is normally used in combination with the GNU operating system: the whole system is basically GNU with Linux added, or GNU/Linux. All the so-called \x22Linux\x22 distributions are really distributions of GNU/Linux.";

   UndoText =
"The GtkTextView supports undo and redo through the use of a GtkTextBuffer. You can enable or disable undo support using gtk_text_buffer_set_enable_undo().\nType to add more text.\nUse Control+z to undo and Control+Shift+z or Control+y to redo previously undone operations.";

   ScrollToEndPrefix =
      "Scroll to end scroll to end scroll to end scroll to end ";
   ScrollToBottomPrefix =
      "Scroll to bottom scroll to bottom scroll to bottom scroll to bottom ";

VAR
   readMoreWindow, rotatedTextWindow, textMaskWindow,
   textScrollWindow, textUndoWindow: ADDRESS;

   (* static counters of the C originals *)
   endCount, bottomCount: INTEGER;

(* ================================================================== *)
(* read_more                                                          *)
(* ================================================================== *)

PROCEDURE OnReadMore (button: ADDRESS; data: ADDRESS);
BEGIN
   (* The real demo grows the custom widget; with no subclassing the
      best we can do is hide the reveal button. *)
   gtk_widget_set_visible(button, 0)
END OnReadMore;

PROCEDURE DoReadMore (doWidget: ADDRESS) : ADDRESS;
VAR
   box, label, button: ADDRESS;
BEGIN
   IF readMoreWindow = NIL THEN
      readMoreWindow := gtk_window_new();
      gtk_window_set_title(readMoreWindow, "Read More");
      gtk_window_set_default_size(readMoreWindow, 400, 300);

      box := gtk_box_new(GtkVertical, 6);
      gtk_window_set_child(readMoreWindow, box);

      label := gtk_label_new(ReadMoreText);
      gtk_label_set_wrap(label, 1);
      gtk_label_set_max_width_chars(label, 30);
      gtk_widget_set_vexpand(label, 1);
      gtk_box_append(box, label);

      button := gtk_button_new_with_label("Read More");
      g_signal_connect_data(button, "clicked", ADR(OnReadMore), NIL, NIL,
                            GConnectDefault);
      gtk_box_append(box, button)
   END;

   IF gtk_widget_get_visible(readMoreWindow) = 0 THEN
      gtk_widget_set_visible(readMoreWindow, 1)
   ELSE
      gtk_window_destroy(readMoreWindow);
      readMoreWindow := NIL
   END;
   RETURN readMoreWindow
END DoReadMore;

(* ================================================================== *)
(* rotated_text                                                       *)
(* ================================================================== *)

PROCEDURE RotatedTextDraw (area: ADDRESS; cr: ADDRESS;
                           width, height: INTEGER; data: ADDRESS);
VAR
   layout, desc, pattern: ADDRESS;
   deviceRadius: REAL;
   lw, lh, i: INTEGER;
BEGIN
   IF width < height THEN
      deviceRadius := VAL(REAL, width) / 2.0
   ELSE
      deviceRadius := VAL(REAL, height) / 2.0
   END;

   cairo_translate(cr,
      deviceRadius + (VAL(REAL, width) - 2.0 * deviceRadius) / 2.0,
      deviceRadius + (VAL(REAL, height) - 2.0 * deviceRadius) / 2.0);
   cairo_scale(cr, deviceRadius / 150.0, deviceRadius / 150.0);

   pattern := cairo_pattern_create_linear(-150.0, -150.0, 150.0, 150.0);
   cairo_pattern_add_color_stop_rgb(pattern, 0.0, 0.5, 0.0, 0.0);
   cairo_pattern_add_color_stop_rgb(pattern, 1.0, 0.0, 0.0, 0.5);
   cairo_set_source(cr, pattern);

   layout := pango_cairo_create_layout(cr);
   pango_layout_set_text(layout, RotatedText, -1);
   desc := pango_font_description_from_string("Serif 18");
   pango_layout_set_font_description(layout, desc);
   pango_font_description_free(desc);

   FOR i := 0 TO NWords - 1 DO
      pango_cairo_update_layout(cr, layout);
      pango_layout_get_pixel_size(layout, lw, lh);
      cairo_move_to(cr, -VAL(REAL, lw) / 2.0, -150.0 * 0.9);
      pango_cairo_show_layout(cr, layout);
      cairo_rotate(cr, 2.0 * Pi / VAL(REAL, NWords))
   END;

   g_object_unref(layout);
   cairo_pattern_destroy(pattern)
END RotatedTextDraw;

PROCEDURE DoRotatedText (doWidget: ADDRESS) : ADDRESS;
VAR
   box, drawingArea, label: ADDRESS;
BEGIN
   IF rotatedTextWindow = NIL THEN
      rotatedTextWindow := gtk_window_new();
      gtk_window_set_title(rotatedTextWindow, "Rotated Text");
      gtk_window_set_default_size(rotatedTextWindow, 4 * Radius, 2 * Radius);

      box := gtk_box_new(GtkHorizontal, 0);
      gtk_window_set_child(rotatedTextWindow, box);

      drawingArea := gtk_drawing_area_new();
      gtk_drawing_area_set_content_width(drawingArea, 2 * Radius);
      gtk_drawing_area_set_content_height(drawingArea, 2 * Radius);
      gtk_widget_set_hexpand(drawingArea, 1);
      gtk_widget_set_vexpand(drawingArea, 1);
      gtk_box_append(box, drawingArea);
      gtk_widget_add_css_class(drawingArea, "view");
      gtk_drawing_area_set_draw_func(drawingArea, ADR(RotatedTextDraw),
                                     NIL, NIL);

      label := gtk_label_new(RotatedText);
      gtk_widget_set_hexpand(label, 1);
      gtk_widget_set_vexpand(label, 1);
      gtk_box_append(box, label)
   END;

   IF gtk_widget_get_visible(rotatedTextWindow) = 0 THEN
      gtk_widget_set_visible(rotatedTextWindow, 1)
   ELSE
      gtk_window_destroy(rotatedTextWindow);
      rotatedTextWindow := NIL
   END;
   RETURN rotatedTextWindow
END DoRotatedText;

(* ================================================================== *)
(* textmask                                                           *)
(* ================================================================== *)

PROCEDURE MaskPath (cr: ADDRESS);
BEGIN
   cairo_move_to(cr, 30.0, 20.0);
   cairo_text_path(cr, "Pango power!");
   cairo_move_to(cr, 30.0, 60.0);
   cairo_text_path(cr, "Pango power!");
   cairo_move_to(cr, 30.0, 100.0);
   cairo_text_path(cr, "Pango power!")
END MaskPath;

PROCEDURE TextMaskDraw (area: ADDRESS; cr: ADDRESS;
                        width, height: INTEGER; data: ADDRESS);
VAR
   pattern: ADDRESS;
BEGIN
   cairo_save(cr);

   cairo_select_font_face(cr, "sans", CairoFontSlantNormal,
                          CairoFontWeightBold);
   cairo_set_font_size(cr, 34.0);
   MaskPath(cr);

   pattern := cairo_pattern_create_linear(0.0, 0.0,
                                          VAL(REAL, width), VAL(REAL, height));
   cairo_pattern_add_color_stop_rgb(pattern, 0.0, 1.0, 0.0, 0.0);
   cairo_pattern_add_color_stop_rgb(pattern, 0.2, 1.0, 0.0, 0.0);
   cairo_pattern_add_color_stop_rgb(pattern, 0.3, 1.0, 1.0, 0.0);
   cairo_pattern_add_color_stop_rgb(pattern, 0.4, 0.0, 1.0, 0.0);
   cairo_pattern_add_color_stop_rgb(pattern, 0.6, 0.0, 1.0, 1.0);
   cairo_pattern_add_color_stop_rgb(pattern, 0.7, 0.0, 0.0, 1.0);
   cairo_pattern_add_color_stop_rgb(pattern, 0.8, 1.0, 0.0, 1.0);
   cairo_pattern_add_color_stop_rgb(pattern, 1.0, 1.0, 0.0, 1.0);

   cairo_set_source(cr, pattern);
   cairo_fill(cr);                    (* cairo_fill_preserve is unbound *)
   cairo_pattern_destroy(pattern);

   (* Rebuild the path (fill consumed it) and outline it in black. *)
   MaskPath(cr);
   cairo_set_source_rgb(cr, 0.0, 0.0, 0.0);
   cairo_set_line_width(cr, 0.5);
   cairo_stroke(cr);

   cairo_restore(cr)
END TextMaskDraw;

PROCEDURE DoTextMask (doWidget: ADDRESS) : ADDRESS;
VAR
   da: ADDRESS;
BEGIN
   IF textMaskWindow = NIL THEN
      textMaskWindow := gtk_window_new();
      gtk_window_set_resizable(textMaskWindow, 1);
      gtk_widget_set_size_request(textMaskWindow, 400, 240);
      gtk_window_set_title(textMaskWindow, "Text Mask");

      da := gtk_drawing_area_new();
      gtk_window_set_child(textMaskWindow, da);
      gtk_drawing_area_set_draw_func(da, ADR(TextMaskDraw), NIL, NIL)
   END;

   IF gtk_widget_get_visible(textMaskWindow) = 0 THEN
      gtk_widget_set_visible(textMaskWindow, 1)
   ELSE
      gtk_window_destroy(textMaskWindow);
      textMaskWindow := NIL
   END;
   RETURN textMaskWindow
END DoTextMask;

(* ================================================================== *)
(* textscroll                                                         *)
(* ================================================================== *)

(* Fill s with n spaces (NUL-terminated). *)
PROCEDURE MakeSpaces (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
   i, hi: INTEGER;
BEGIN
   hi := VAL(INTEGER, HIGH(s));
   IF n > hi - 1 THEN
      n := hi - 1
   END;
   FOR i := 0 TO n - 1 DO
      s[i] := ' '
   END;
   s[n] := 0C
END MakeSpaces;

(* Copy prefix then append the decimal rendering of n (NUL-terminated). *)
PROCEDURE BuildScrollText (prefix: ARRAY OF CHAR; n: INTEGER;
                           VAR s: ARRAY OF CHAR);
VAR
   pos, k, hi: INTEGER;
   digits: ARRAY [0..15] OF CHAR;
BEGIN
   hi := VAL(INTEGER, HIGH(s));
   pos := 0;
   WHILE (pos < hi) AND (prefix[pos] # 0C) DO
      s[pos] := prefix[pos];
      INC(pos)
   END;
   k := 0;
   IF n = 0 THEN
      digits[0] := '0';
      k := 1
   ELSE
      WHILE n > 0 DO
         digits[k] := CHR(ORD('0') + VAL(CARDINAL, n MOD 10));
         n := n DIV 10;
         INC(k)
      END
   END;
   WHILE k > 0 DO
      DEC(k);
      IF pos < hi THEN
         s[pos] := digits[k];
         INC(pos)
      END
   END;
   s[pos] := 0C
END BuildScrollText;

PROCEDURE ScrollToEnd (textview: ADDRESS) : INTEGER;
VAR
   buffer, mark: ADDRESS;
   iter: GtkTextIter;
   spaces, text: ARRAY [0..255] OF CHAR;
BEGIN
   buffer := gtk_text_view_get_buffer(textview);

   mark := gtk_text_buffer_get_mark(buffer, "end");
   gtk_text_buffer_get_iter_at_mark(buffer, iter, mark);

   MakeSpaces(endCount, spaces);
   INC(endCount);
   gtk_text_buffer_insert(buffer, iter, "\n", -1);
   gtk_text_buffer_insert(buffer, iter, spaces, -1);
   BuildScrollText(ScrollToEndPrefix, endCount, text);
   gtk_text_buffer_insert(buffer, iter, text, -1);

   gtk_text_view_scroll_to_mark(textview, mark, 0.0, 0, 0.0, 0.0);

   IF endCount > 150 THEN
      endCount := 0
   END;

   RETURN GSourceContinue
END ScrollToEnd;

PROCEDURE ScrollToBottom (textview: ADDRESS) : INTEGER;
VAR
   buffer, mark: ADDRESS;
   iter: GtkTextIter;
   spaces, text: ARRAY [0..255] OF CHAR;
BEGIN
   buffer := gtk_text_view_get_buffer(textview);

   gtk_text_buffer_get_end_iter(buffer, iter);

   MakeSpaces(bottomCount, spaces);
   INC(bottomCount);
   gtk_text_buffer_insert(buffer, iter, "\n", -1);
   gtk_text_buffer_insert(buffer, iter, spaces, -1);
   BuildScrollText(ScrollToBottomPrefix, bottomCount, text);
   gtk_text_buffer_insert(buffer, iter, text, -1);

   (* gtk_text_iter_set_line_offset() and gtk_text_buffer_move_mark()
      are not bound, so the "scroll" mark stays at its original spot. *)
   mark := gtk_text_buffer_get_mark(buffer, "scroll");
   gtk_text_view_scroll_to_mark(textview, mark, 0.0, 0, 0.0, 0.0);

   IF bottomCount > 40 THEN
      bottomCount := 0
   END;

   RETURN GSourceContinue
END ScrollToBottom;

PROCEDURE SetupScroll (textview: ADDRESS; toEnd: BOOLEAN) : guint;
VAR
   buffer, mark: ADDRESS;
   iter: GtkTextIter;
BEGIN
   buffer := gtk_text_view_get_buffer(textview);
   gtk_text_buffer_get_end_iter(buffer, iter);

   IF toEnd THEN
      mark := gtk_text_buffer_create_mark(buffer, "end", iter, 0);
      RETURN g_timeout_add(50, ScrollToEnd, textview)
   ELSE
      mark := gtk_text_buffer_create_mark(buffer, "scroll", iter, 1);
      RETURN g_timeout_add(100, ScrollToBottom, textview)
   END
END SetupScroll;

(* void remove_timeout(GtkWidget *window, gpointer timeout) *)
PROCEDURE RemoveTimeout (window: ADDRESS; data: ADDRESS);
BEGIN
   g_source_remove(CAST(guint, data))
END RemoveTimeout;

PROCEDURE CreateTextView (hbox: ADDRESS; toEnd: BOOLEAN);
VAR
   swindow, textview: ADDRESS;
   timeout: guint;
BEGIN
   swindow := gtk_scrolled_window_new();
   gtk_widget_set_hexpand(swindow, 1);
   gtk_box_append(hbox, swindow);

   textview := gtk_text_view_new();
   gtk_scrolled_window_set_child(swindow, textview);

   timeout := SetupScroll(textview, toEnd);

   (* Remove the timeout when the view goes away, so it cannot scroll a
      destroyed widget. *)
   g_signal_connect_data(textview, "destroy", ADR(RemoveTimeout),
                         CAST(ADDRESS, timeout), NIL, GConnectDefault)
END CreateTextView;

PROCEDURE DoTextScroll (doWidget: ADDRESS) : ADDRESS;
VAR
   hbox: ADDRESS;
BEGIN
   IF textScrollWindow = NIL THEN
      textScrollWindow := gtk_window_new();
      gtk_window_set_title(textScrollWindow, "Automatic Scrolling");
      gtk_window_set_default_size(textScrollWindow, 600, 400);

      hbox := gtk_box_new(GtkHorizontal, 6);
      gtk_window_set_child(textScrollWindow, hbox);

      CreateTextView(hbox, TRUE);
      CreateTextView(hbox, FALSE)
   END;

   IF gtk_widget_get_visible(textScrollWindow) = 0 THEN
      gtk_widget_set_visible(textScrollWindow, 1)
   ELSE
      gtk_window_destroy(textScrollWindow);
      textScrollWindow := NIL
   END;
   RETURN textScrollWindow
END DoTextScroll;

(* ================================================================== *)
(* textundo                                                           *)
(* ================================================================== *)

PROCEDURE DoTextUndo (doWidget: ADDRESS) : ADDRESS;
VAR
   view, sw, buffer: ADDRESS;
   iter: GtkTextIter;
BEGIN
   IF textUndoWindow = NIL THEN
      textUndoWindow := gtk_window_new();
      gtk_window_set_default_size(textUndoWindow, 330, 330);
      gtk_window_set_resizable(textUndoWindow, 0);
      gtk_window_set_title(textUndoWindow, "Undo and Redo");

      view := gtk_text_view_new();
      gtk_text_view_set_wrap_mode(view, GtkWrapWord);
      gtk_text_view_set_left_margin(view, 20);
      gtk_text_view_set_right_margin(view, 20);
      gtk_text_view_set_top_margin(view, 20);
      gtk_text_view_set_bottom_margin(view, 20);

      buffer := gtk_text_view_get_buffer(view);
      (* gtk_text_buffer_set_enable_undo() is not bound; the buffer keeps
         its default undo support, so Ctrl+Z / Ctrl+Y still work. *)

      gtk_text_buffer_get_start_iter(buffer, iter);
      gtk_text_buffer_insert(buffer, iter, UndoText, -1);

      sw := gtk_scrolled_window_new();
      gtk_scrolled_window_set_policy(sw, GtkPolicyAutomatic,
                                     GtkPolicyAutomatic);
      gtk_window_set_child(textUndoWindow, sw);
      gtk_scrolled_window_set_child(sw, view)
   END;

   IF gtk_widget_get_visible(textUndoWindow) = 0 THEN
      gtk_widget_set_visible(textUndoWindow, 1)
   ELSE
      gtk_window_destroy(textUndoWindow);
      textUndoWindow := NIL
   END;
   RETURN textUndoWindow
END DoTextUndo;

BEGIN
   readMoreWindow := NIL;
   rotatedTextWindow := NIL;
   textMaskWindow := NIL;
   textScrollWindow := NIL;
   textUndoWindow := NIL;
   endCount := 0;
   bottomCount := 0
END DemosText.