PreviousUpNext

15.4.1299  src/lib/tk/src/toolkit/tests+examples/tabs_ex.pkg

## tabs_ex.pkg
## (C) 2000, Bremen Institute for Safe Systems, Universitaet Bremen
## Author: ludi (Last modification by $Author: 2cxl $)

# Compiled by:
#     src/lib/tk/src/toolkit/tests+examples/sources.sublib



# **************************************************************************
# tk-Tabs example
# **************************************************************************

package tabs_ex : (weak)
    api {
         go:  Void -> tk::Widget;
    }
{
    include tk;

    lab_id  = make_widget_id();
    show_id = make_widget_id();

    fun drop_newlines s =
        string::implode (list::take_n (string::explode s, size s - 2));

    my_txt         = REF "Welcome";
    my_font        = REF SANS_SERIF;
    my_fontsize    = REF NORMAL_SIZE;
    my_bold        = REF FALSE;
    my_italic      = REF FALSE;
    my_txtcol      = REF BLUE;
    my_bgcol       = REF GREEN;
    my_width       = REF 15;
    my_height      = REF 2;
    my_relief      = REF RAISED;
    my_borderwidth = REF 2;

    fun font_name f
        =
        case f
             SANS_SERIF  _  => "SansSerif";
            TYPEWRITER  _ => "Typewriter";
            NORMAL_FONT _ => "Normalfont"; esac;

    fun fontsize_name s
        =
        case s
             TINY       => "Tiny";
           SMALL       => "Small";
           NORMAL_SIZE => "NormalSize";
           LARGE       => "Large";
           HUGE        => "Huge"; esac;

    fun rel_name r
        =
        case r
             FLAT   => "Flat";
            GROOVE => "Groove";
            RIDGE  => "Ridge";
            RAISED => "Raised";
            SUNKEN => "Sunken"; esac;

    fun col_name c
        =
        case c
             BLACK  => "Black";
            WHITE  => "White";
            GREY   => "Grey";
            BLUE   => "Blue";
            GREEN  => "Green";
            RED    => "Red";
            BROWN  => "Brown";
            YELLOW => "Yellow"; esac;

    fun show_code ()
        =
        {
            txtconf =
                "FONT(" + font_name( *my_font []) + " [" + 
                fontsize_name *my_fontsize + 
                (if *my_bold  ", BOLD"; else "";fi) +
                (if *my_italic  ", ITALIC"; else "";fi) + "]),\n";

            txt = "LABEL { widget_id    = make_widget_id(),\n" +
                      "       packing_hints = [],\n" +
                      "       traits  = [TEXT \"" + *my_txt + "\",\n" +
                      "                   " + txtconf +
                      "                   FOREGROUND " +
                      col_name *my_txtcol + ",\n" +
                      "                   BACKGROUND " +
                      col_name *my_bgcol + ",\n" +
                      "                   WIDTH " +
                      int::to_string *my_width + ",\n" +
                      "                   HEIGHT " +
                      int::to_string *my_height + ",\n" +
                      "                   RELIEF " +
                      rel_name *my_relief + ",\n" +
                      "                   BORDER_THICKNESS " +
                      int::to_string *my_borderwidth + "],\n" +
                      "       event_callbacks = [] }";

            { add_trait show_id [ACTIVE TRUE];
             clear_text show_id;
             insert_text_end show_id txt;
             add_trait show_id [ACTIVE FALSE];};
        };

    fun color_chooser id act pack cols col
        =
        MENU_BUTTON {
            widget_id    => id,
            packing_hints => pack,
            event_callbacks => [],
            traits  => [    WIDTH 20,
                           RELIEF RAISED,
                           TEAR_OFF FALSE,
                           TEXT cols,
                           FOREGROUND col
                      ],
            mitems  => [   MENU_COMMAND [TEXT "Black",                    CALLBACK (act BLACK )],
                          MENU_COMMAND [TEXT "White",  FOREGROUND WHITE,  CALLBACK (act WHITE )],
                          MENU_COMMAND [TEXT "Grey",   FOREGROUND GREY,   CALLBACK (act GREY  )],
                          MENU_COMMAND [TEXT "Blue",   FOREGROUND BLUE,   CALLBACK (act BLUE  )],
                          MENU_COMMAND [TEXT "Green",  FOREGROUND GREEN,  CALLBACK (act GREEN )],
                          MENU_COMMAND [TEXT "Red",    FOREGROUND RED,    CALLBACK (act RED   )],
                          MENU_COMMAND [TEXT "Brown",  FOREGROUND BROWN,  CALLBACK (act BROWN )],
                          MENU_COMMAND [TEXT "Yellow", FOREGROUND YELLOW, CALLBACK (act YELLOW)]
                      ]
        };

    fun fconf ()
        =
        [!my_fontsize]
        @
        (if *my_bold  [BOLD]; else [];fi)
        @
        (if *my_italic  [ITALIC]; else [];fi);

    fun font ()
        =
        *my_font (fconf());

    page1
        =
        {   id      = make_widget_id();
            font_id  = make_widget_id();
            fsize_id = make_widget_id();

            fun ch_font f _ = { my_font := f;
                               add_trait font_id [TEXT (font_name (f []))];
                               add_trait lab_id [FONT (font())];
                               show_code();};

            fun ch_bold _ = { my_bold := not *my_bold;
                             add_trait lab_id [FONT (font())];
                             show_code();};

            fun ch_ital _ = { my_italic := not *my_italic;
                             add_trait lab_id [FONT (font())];
                             show_code();};

            fun ch_fsize s _ = { my_fontsize := s;
                                add_trait fsize_id [TEXT (fontsize_name s)];
                                add_trait lab_id [FONT (font())];
                                show_code();};

            { title    => "Text Settings",
             subwidgets  =>
               PACKED
                 [ LABEL { widget_id    => make_widget_id(),
                         packing_hints => [PAD_Y 8],
                         traits  => [TEXT "Enter text:"],
                         event_callbacks => [] },

                  TEXT_WIDGET { widget_id      => id,
                           live_text   => string_to_livetext "Welcome",
                           scrollbars => AT_RIGHT,
                           packing_hints   => [PAD_X 10],
                           traits    => [WIDTH 60, HEIGHT 10,
                                         BACKGROUND WHITE],
                           event_callbacks   => [ EVENT_CALLBACK (KEY_PRESS "",
                                     fn _ =>
                                       { add_trait lab_id
                                                [TEXT
                                                   (drop_newlines
                                                      (get_tcl_text id))];
                                                my_txt :=
                                                  (drop_newlines
                                                     (get_tcl_text id));
                                                show_code();}; end )] },
                  FRAME { widget_id    => make_widget_id(),
                         subwidgets  =>
                           GRIDDED
                             [ LABEL { widget_id    => make_widget_id(),
                                     packing_hints => [ROW 1, COLUMN 1],
                                     traits  => [TEXT "Font:"],
                                     event_callbacks => [] },
                              MENU_BUTTON
                                { widget_id    => font_id,
                                 mitems   =>
                                   [MENU_COMMAND [TEXT "Normalfont",
                                              FONT (NORMAL_FONT []),
                                              CALLBACK (ch_font NORMAL_FONT)],
                                    MENU_COMMAND [TEXT "Typewriter",
                                              FONT (TYPEWRITER []),
                                              CALLBACK (ch_font TYPEWRITER)],
                                    MENU_COMMAND [TEXT "Sans Serif",
                                              FONT (SANS_SERIF []),
                                              CALLBACK (ch_font SANS_SERIF)]],
                                 packing_hints => [ROW 1, COLUMN 2, PAD_Y 5,
                                             STICK TO_NSEW],
                                 traits  => [WIDTH 20, RELIEF RAISED,
                                             TEXT "SansSerif",
                                             FONT (SANS_SERIF []),
                                             TEAR_OFF FALSE],
                                 event_callbacks => [] },
                              LABEL { widget_id    => make_widget_id(),
                                     packing_hints => [ROW 2, COLUMN 1],
                                     traits  => [TEXT "Font size:"],
                                     event_callbacks => [] },
                              MENU_BUTTON
                                { widget_id    => fsize_id,
                                 mitems   =>
                                   [MENU_COMMAND [TEXT "Tiny",
                                              FONT (SANS_SERIF [TINY]),
                                              CALLBACK (ch_fsize TINY)],
                                    MENU_COMMAND [TEXT "Small",
                                              FONT (SANS_SERIF [SMALL]),
                                              CALLBACK (ch_fsize SMALL)],
                                    MENU_COMMAND [TEXT "Normal",
                                              FONT (SANS_SERIF
                                                     [NORMAL_SIZE]),
                                              CALLBACK (ch_fsize
                                                        NORMAL_SIZE)],
                                    MENU_COMMAND [TEXT "Large",
                                              FONT (SANS_SERIF [LARGE]),
                                              CALLBACK (ch_fsize LARGE)],
                                    MENU_COMMAND [TEXT "Huge",
                                              FONT (SANS_SERIF [HUGE]),
                                              CALLBACK (ch_fsize HUGE)]],
                                 packing_hints => [ROW 2, COLUMN 2, PAD_Y 5,
                                             STICK TO_NSEW],
                                 traits  => [WIDTH 20, RELIEF RAISED,
                                             TEXT "Normal", TEAR_OFF FALSE,
                                             FONT (SANS_SERIF [NORMAL_SIZE])],
                                 event_callbacks => [] },
                              CHECK_BUTTON {
                                  widget_id => make_widget_id(),
                                  packing_hints => [ROW 3, COLUMN 1],
                                  traits  =>
                                    [WIDTH 20, TEXT "Italic",
                                     FONT (SANS_SERIF [ITALIC]),
                                     CALLBACK ch_ital],
                                  event_callbacks => []
                                 },
                              CHECK_BUTTON {
                                  widget_id    => make_widget_id(),
                                  packing_hints => [ROW 3, COLUMN 2],
                                  traits  => [ WIDTH 20, TEXT "Bold",
                                              FONT (SANS_SERIF [BOLD]),
                                              CALLBACK ch_bold],
                                           event_callbacks => []
                              }
                        ],
                        packing_hints => [],
                        traits  => [],
                        event_callbacks => []
                    }
                 ],

             show     => fn() => { clear_text id;
                                 insert_text_end id *my_txt;
                                 add_trait fsize_id
                                         [TEXT (fontsize_name *my_fontsize)];
                                 add_trait font_id
                                         [TEXT (font_name( *my_font []))];}; end ,
             hide     => null_callback,
             shortcut => THE 0 };
        };

    page2 =
        {
            id   = make_widget_id();
            c1id = make_widget_id();
            c2id = make_widget_id();

            fun foreground c _ = { my_txtcol := c;
                                  add_trait c1id [TEXT (col_name c),
                                                 FOREGROUND c];
                                  add_trait lab_id [FOREGROUND c];
                                  show_code();};

            fun background c _ = { my_bgcol := c;
                                  add_trait c2id [TEXT (col_name c),
                                                FOREGROUND c];
                                  add_trait lab_id [BACKGROUND c];
                                  show_code();};

            { title    => "Color Settings",
             subwidgets  =>
               PACKED
                 [FRAME { widget_id   => make_widget_id(),
                         subwidgets =>
                           GRIDDED
                               [ LABEL { widget_id    => make_widget_id(),
                                       packing_hints => [ROW 2, COLUMN 1],
                                       traits  =>
                                         [TEXT "Text color:"],
                                       event_callbacks => [] },
                                color_chooser c1id foreground
                                              [ROW 2, COLUMN 2, PAD_Y 5]
                                              "Blue" BLUE,
                                LABEL { widget_id    => make_widget_id(),
                                       packing_hints => [ROW 3, COLUMN 1,
                                                   PAD_X 15],
                                       traits  =>
                                         [TEXT "BACKGROUND color:"],
                                       event_callbacks => [] },
                                color_chooser c2id background
                                              [ROW 3, COLUMN 2, PAD_Y 5]
                                              "Green" GREEN],
                         packing_hints => [PAD_Y 50],
                         traits  => [],
                         event_callbacks => [] } ],
             show     => fn() => { add_trait c1id [TEXT (col_name *my_txtcol),
                                               FOREGROUND *my_txtcol];
                                 add_trait c2id [TEXT (col_name *my_bgcol),
                                               FOREGROUND *my_bgcol];}; end ,
             hide     => null_callback,
             shortcut => THE 0 };
        };

    fun page3 () =
        {
            n_chooser1 =
                numeric_chooser::numeric_chooser
                  { initial_value      => 15,
                   min                => THE 0,
                   max                => NULL,
                   increment          => 1,
                   width              => 3,
                   orientation        => HORIZONTAL,
                   selection_notifier => fn i => { add_trait lab_id [WIDTH i];
                                                 my_width := i;
                                                 show_code();}; end  };

            n_chooser2 =
                numeric_chooser::numeric_chooser
                  { initial_value      => 2,
                   min                => THE 0,
                   max                => NULL,
                   increment          => 1,
                   width              => 2,
                   orientation        => VERTICAL,
                   selection_notifier => fn i => { add_trait lab_id [HEIGHT i];
                                                 my_height := i;
                                                 show_code();}; end  };

            { title    => "Dimensions",
             subwidgets  =>
               PACKED [FRAME { widget_id   => make_widget_id(),
                            subwidgets =>
                              GRIDDED [FRAME
                                      { widget_id    => make_widget_id(),
                                       subwidgets  =>
                                         PACKED
                                           [ LABEL
                                              { widget_id    => make_widget_id(),
                                               packing_hints => [PACK_AT LEFT],
                                               traits  =>
                                                 [TEXT "Width:", WIDTH 10],
                                               event_callbacks => [] },
                                            n_chooser1.chooser],
                                       packing_hints => [ROW 1, COLUMN 2,
                                                   PAD_Y 3, PAD_X 30],
                                       traits  => [],
                                       event_callbacks => [] },
                                    FRAME
                                      { widget_id    => make_widget_id(),
                                       subwidgets  =>
                                         PACKED
                                           [ LABEL
                                              { widget_id    => make_widget_id(),
                                               packing_hints => [PACK_AT LEFT],
                                               traits  => [TEXT "Height:",
                                                           WIDTH 10],
                                               event_callbacks => [] },
                                            n_chooser2.chooser],
                                       packing_hints => [ROW 1, COLUMN 4,
                                                   PAD_Y 3, PAD_X 30],
                                       traits  => [],
                                       event_callbacks => [] } ],
                            packing_hints => [PAD_Y 50],
                            traits  => [],
                            event_callbacks => [] } ],
               show     => fn() => { n_chooser1.set_value *my_width;
                                   n_chooser2.set_value *my_height;}; end ,
               hide     => null_callback,
               shortcut => THE 0 };
        };

    fun page4 () =
        {
            id1 = make_widget_id();
            id2 = make_widget_id();

            fun rel relk _ = { add_trait lab_id [RELIEF relk];
                              my_relief := relk;
                              show_code();};
            n_chooser =
                numeric_chooser::numeric_chooser
                  { initial_value => 2,
                   min           => THE 0,
                   max           => NULL,
                   increment     => 1,
                   width         => 3,
                   orientation   => HORIZONTAL,
                   selection_notifier => fn i => { add_trait lab_id
                                                         [BORDER_THICKNESS i];
                                                 my_borderwidth := i;
                                                 show_code();}; end  };

            fun rel_val () =
                case *my_relief   
                    FLAT   => "0";
                   GROOVE => "1";
                   RAISED => "2";
                   RIDGE  => "3";
                   SUNKEN => "4"; esac;

            { title    => "Relief",
             subwidgets  =>
               PACKED
                 [FRAME { widget_id    => make_widget_id(),
                         subwidgets  =>
                           PACKED
                             [FRAME
                                { widget_id    => make_widget_id(),
                                 subwidgets  =>
                                   GRIDDED
                                     [ LABEL { widget_id    => make_widget_id(),
                                             packing_hints => [ROW 1, COLUMN 1,
                                                         PAD_X 10, PAD_Y 5],
                                             traits  => [TEXT "Relief: ",
                                                         WIDTH 15],
                                             event_callbacks => [] },
                                      RADIO_BUTTON
                                        { widget_id    => make_widget_id(),
                                         packing_hints => [ROW 1, COLUMN 2,
                                                     STICK TO_W],
                                         traits  =>
                                           [TEXT "Flat",
                                            VARIABLE "relief", VALUE "0",
                                            CALLBACK (rel FLAT),
                                            FONT (SANS_SERIF [])],
                                         event_callbacks => [] },
                                      RADIO_BUTTON
                                        { widget_id    => make_widget_id(),
                                         packing_hints => [ROW 1, COLUMN 3,
                                                     STICK TO_W],
                                         traits  =>
                                           [TEXT "Groove",
                                            VARIABLE "relief", VALUE "1",
                                            CALLBACK (rel GROOVE),
                                            FONT (SANS_SERIF [])],
                                         event_callbacks => [] },
                                      RADIO_BUTTON
                                        { widget_id    => make_widget_id(),
                                         packing_hints => [ROW 2, COLUMN 2,
                                                     STICK TO_W],
                                         traits  =>
                                           [TEXT "Raised",
                                            VARIABLE "relief", VALUE "2",
                                            CALLBACK (rel RAISED),
                                            FONT (SANS_SERIF [])],
                                         event_callbacks => [] },
                                      RADIO_BUTTON
                                        { widget_id    => make_widget_id(),
                                         packing_hints => [ROW 2, COLUMN 3,
                                                     STICK TO_W],
                                         traits  =>
                                           [TEXT "Ridge",
                                            VARIABLE "relief", VALUE "3",
                                            CALLBACK (rel RIDGE),
                                            FONT (SANS_SERIF [])],
                                         event_callbacks => [] },
                                      RADIO_BUTTON
                                        { widget_id    => make_widget_id(),
                                         packing_hints => [ROW 3, COLUMN 2,
                                                     STICK TO_W],
                                         traits  =>
                                           [TEXT "Sunken",
                                            VARIABLE "relief", VALUE "4",
                                            CALLBACK (rel SUNKEN),
                                            FONT (SANS_SERIF [])],
                                         event_callbacks => [] } ],
                                 packing_hints => [PAD_Y 30],
                                 traits  => [],
                                 event_callbacks => [] },
                              FRAME
                                { widget_id    => make_widget_id(),
                                 subwidgets  =>
                                   PACKED
                                     [ LABEL { widget_id    => make_widget_id(),
                                             packing_hints => [PAD_X 10, PAD_Y 20,
                                                         PACK_AT LEFT],
                                             traits  =>
                                               [TEXT "BORDER_THICKNESS:",
                                                WIDTH 15],
                                             event_callbacks => [] },
                                      FRAME
                                        { widget_id    => make_widget_id(),
                                         subwidgets  =>
                                           PACKED [n_chooser.chooser],
                                         packing_hints => [PAD_X 20, PACK_AT LEFT],
                                         traits  => [],
                                         event_callbacks => [] } ],
                                 packing_hints => [ROW 2, COLUMN 2, PACK_AT LEFT],
                                 traits  => [],
                                 event_callbacks => [] } ],
                            packing_hints => [],
                            traits  => [],
                            event_callbacks => [] } ],
             show     => fn() => { set_var_value "relief" (rel_val());
                                 n_chooser.set_value *my_borderwidth;}; end ,
             hide     => fn() => my_borderwidth := n_chooser.read_value (); end ,
             shortcut => THE 0 };
        };

    page5 =
        { title    => "Info",
         subwidgets  => PACKED [ LABEL { widget_id    => make_widget_id(),
                                 packing_hints => [PAD_Y 30],
                                 traits  => [TEXT "tk-Tabs example",
                                             FOREGROUND RED,
                                             FONT (SANS_SERIF [HUGE])],
                                 event_callbacks => [] },
                          LABEL { widget_id    => make_widget_id(),
                                 packing_hints => [],
                                 traits  => [TEXT "(C) 2000, Bremen Institute for Safe Systems, Universitaet Bremen\nAdded to the tk Toolkit in april 2000",
                                             FONT (SANS_SERIF [LARGE])],
                                 event_callbacks => [] } ],
         show     => fn() => (); end ,
         hide     => fn() => (); end ,
         shortcut => THE 0 };

    fun go ()
        =
        {
            my (tabs, shortcuts) =
                tabs::tabs
                  { pages     => [page1, page2, page3(), page4(), page5],
                   configure => { width       => 700,
                                spare       => 50,
                                height      => 300,
                                font        => SANS_SERIF [BOLD],
                                labelheight => 34 }};

            {   my_txt         := "Welcome";
                my_font        := SANS_SERIF;
                my_fontsize    := NORMAL_SIZE;
                my_bold        := FALSE;
                my_italic      := FALSE;
                my_txtcol      := BLUE;
                my_bgcol       := GREEN;
                my_width       := 15;
                my_height      := 2;
                my_relief      := RAISED;
                my_borderwidth := 2;
                start_tcl [
                    make_window {
                        window_id    => make_window_id (),
                        subwidgets  => PACKED [ FRAME { widget_id    => make_widget_id(),
                                                   subwidgets  => PACKED [tabs],
                                                   packing_hints =>
                                                     [PAD_X 10, PAD_Y 10],
                                                   traits  => [],
                                                   event_callbacks => [] },
                                            FRAME
                                              { widget_id   => make_widget_id(),
                                               subwidgets =>
                                                 PACKED
                                                   [BUTTON
                                                      { widget_id    =>
                                                         make_widget_id(),
                                                       packing_hints =>
                                                         [PACK_AT RIGHT],
                                                       traits  =>
                                                         [TEXT "Ok", WIDTH 15,
                                                          CALLBACK
                                                            (fn _ =>
                                                               exit_tcl(); end )],
                                                       event_callbacks => [] } ],
                                               packing_hints => [PAD_Y 5, FILL ONLY_X,
                                                           EXPAND TRUE],
                                               traits  => [],
                                               event_callbacks => [] } ],
                                    traits  => [WINDOW_TITLE "Tabs example"],
                                    event_callbacks => shortcuts,
                                    init     => null_callback
                    },

                    make_window {
                        window_id   => make_window_id (),
                        subwidgets  => PACKED [
                                       LABEL {
                                           widget_id    => lab_id,
                                           packing_hints =>
                                                     [PAD_X 10, PAD_Y 10],
                                           traits  =>
                                                     [TEXT "Welcome",
                                                      FONT
                                                        (SANS_SERIF
                                                           [NORMAL_SIZE]),
                                                      FOREGROUND BLUE,
                                                      BACKGROUND GREEN,
                                                      BORDER_THICKNESS 2,
                                                      RELIEF RAISED,
                                                      HEIGHT 2,
                                                      WIDTH 15],
                                                   event_callbacks => []
                                       }
                                      ],
                        traits  => [WINDOW_TITLE "Constructed label"],
                        event_callbacks => [EVENT_CALLBACK (DESTROY, fn _ => exit_tcl(); end )],
                        init     => null_callback
                    },

                    make_window {
                        window_id   => make_window_id (),
                        subwidgets  => PACKED [TEXT_WIDGET
                                              { widget_id      => show_id,
                                               scrollbars => AT_RIGHT,
                                               live_text   => empty_livetext,
                                               packing_hints   =>
                                                 [PAD_X 10, PAD_Y 10],
                                               traits    => [WIDTH 80,
                                                             HEIGHT 15,
                                                             ACTIVE FALSE],
                                               event_callbacks   => [] } ],
                        traits  => [WINDOW_TITLE "Label code"],
                        event_callbacks => [EVENT_CALLBACK (DESTROY, fn _ => exit_tcl(); end )],
                        init     => show_code
                    }
                ];

                LABEL {
                    widget_id       => make_widget_id(),
                    packing_hints   => [],
                    event_callbacks => [],
                    traits          => [   TEXT        *my_txt,
                                          FONT         (font()),
                                          FOREGROUND   *my_txtcol,
                                          BACKGROUND   *my_bgcol,
                                          WIDTH        *my_width,
                                          HEIGHT       *my_height,
                                          RELIEF       *my_relief,
                                          BORDER_THICKNESS *my_borderwidth
                                      ]
                };
            };
        };
};


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext