PreviousUpNext

15.4.1261  src/lib/tk/src/tests+examples/big_ex.pkg

/* ***********************************************************************

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

   Project: sml/Tk: an Tk Toolkit for sml
   Author: Stefan Westmeier, University of Bremen
           (ported to SmlTk30 by bu)
   Date: $Date: 2001/03/30 13:39:30 $
   Revision: $Revision: 3.0 $
   Purpose of this file: Test for Canvas and other new stuff ...

   *********************************************************************** */

package big_ex

: (weak)     api {  go:  Void -> String; }

{

    include tk;
    include tk_21;

    /*
        package daVinciSMLTK :
        api
            my startDaVinci:  Void -> Void
            my stopDaVinci:   Void -> Void
        end
        =
        pkg
            appId = "DAVINCI"
            prog  = ("/usr/local/software/daVinci/daVinci",["-pipe"])
            prot  = "/tmp/g2da.log"

            fun callBack s = (insertTextEnd "aText" (s + "\n"))
            quitAction = fn () => com::putLineApp appId "quit";

            fun stopDaVinci () = com::removeApp (appId)

            fun startDaVinci () = 
                let
                /* These two functions are not delivered with tk .
                 * They are intended to convert a file test2.nf into a string
                 * representation of a graph which daVinci can understand
                 */
                    g = FdrNf::parse("/home/stefan/bkb/sml/fdrnf/fdr-examples/test2.nf")
                    s = StringGraph::graph2daVinci (g, "0")
                in
                    (addApp (appId, prog, prot, callBack, quitAction);
                     com::putLineApp appId ("new_term_placed(" + s + ")") )
                end

            end;

            startDaVinci = daVinciSMLTK::startDaVinci;
            stopDaVinci = daVinciSMLTK::stopDaVinci;
     */

        #  --- path to images ---- 

        fun get_img_path name
            =
            winix__premicrothread::path::make_path_from_dir_and_file {
                dir => winix__premicrothread::path::cat (
                          get_lib_path(),
                          "tests+examples"
                      ),
                file=> name
            };


        #  ----------------------------- Id's ------------------------------------ 

        main_window_id      = make_tagged_window_id    "meister";
        a_text_id        = make_tagged_widget_id "atext";
        a_label_id       = make_tagged_widget_id "alabel";
        hide_button_id   = make_tagged_widget_id "hidebutton";
        hidden_button_id = make_tagged_widget_id "hiddenButton";
        hider_id        = make_tagged_widget_id "hider";

        hidden_frame_id  = make_tagged_widget_id "hiddenframe";
        hide_frame_id    = make_tagged_widget_id "hiddeframe";
        hider1id       = make_tagged_widget_id "hider1";

        b_label_id       = make_tagged_widget_id "bLabel";
        davi_id         = make_tagged_widget_id "davi"; 
        texter_id       = make_tagged_widget_id "texter";  
        da_vinci_hider_id = make_tagged_widget_id "davincihider"; 
        da_vinci_button_start_id  = make_tagged_widget_id "davincibuttonstart"; 
        da_vinci_button_stop_id   = make_tagged_widget_id "davincibuttonstop";
        entry_window_id     = make_tagged_window_id "entry";
        entry_id        = make_tagged_widget_id "entry";
        canvasfr_id     = make_tagged_widget_id "canvasfr"; 
        mes_can_fr_id     = make_tagged_widget_id "mescanFr";
        canvas_id       = make_tagged_widget_id "canvas";

        cnv_hidden_button_id = make_tagged_widget_id "cnvhiddenbutton";
        cnv_hider_id = make_tagged_widget_id "cnvhider";
        cnv_hide_button_id = make_tagged_widget_id "cnvhidebutton";
        cnv_deleter_id = make_tagged_widget_id "cnvdeleter";

        c1id = make_tagged_widget_id "c1";

        it0_cid = make_tagged_canvas_item_id "it0";
        it1_cid = make_tagged_canvas_item_id "it1";
        it2_cid = make_tagged_canvas_item_id "it2";
        it3_cid = make_tagged_canvas_item_id "it3";
        l1_2_cid = make_tagged_canvas_item_id "l1-2";
        l2_3_cid = make_tagged_canvas_item_id "l2-3";
        l3_1_cid = make_tagged_canvas_item_id "l3-1";
        it4_cid = make_tagged_canvas_item_id "it4";
        it4a_cid = make_tagged_canvas_item_id "it4a";
        it5_cid = make_tagged_canvas_item_id "it5";
        it6_cid = make_tagged_canvas_item_id "it6";
        its_cid = make_tagged_canvas_item_id "its";

        #  ----------------------------- hide Simple Widget ---------------------- 
        #  
        start_da_vinci = fn _ = (insert_text_end a_text_id "Start\n");
        stop_da_vinci  = fn _ = (insert_text_end a_text_id "Stop\n");
        #  
        do_quit       = fn () = close_window (main_window_id);

        fun a_label ()
            =
            label (a_label_id,[],[TEXT "My Example"],[]);

        fun do_hide_button ()
            =
            { delete_widget (hidden_button_id);
                               add_trait hide_button_id [TEXT "Add"];
                               add_trait hide_button_id [CALLBACK do_add_button] ;}

        also
        fun do_add_button ()
            =
            { add_widget (main_window_id) hider_id (hidden_button());
                              add_trait hide_button_id [TEXT "Hide"];
                              add_trait hide_button_id [CALLBACK do_hide_button];}

        also
        fun hide_button hide
            =
            button (hide_button_id,
                                     [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
                                     [TEXT "Hide", CALLBACK hide],[])

        also
        fun hidden_button ()
            =
            button (hidden_button_id,
                                     [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
                                     [TEXT "ToHide", CALLBACK null_callback],[]);

        fun hider ()
            =
            frame (hider_id, [hide_button do_hide_button, hidden_button ()],
                              [FILL ONLY_X],
                              [RELIEF RIDGE, BORDER_THICKNESS 2],[]);

        #  ----------------------------- hide Recursive Widget ---------------------- 

        fun do_hide_frame ()
            =
            { delete_widget (hidden_frame_id);
                              add_trait hide_frame_id [TEXT "Add"];
                              add_trait hide_frame_id [CALLBACK do_add_frame] ;}

        also
        fun do_add_frame ()
            =
            { add_widget (main_window_id) hider1id (hidden_frame());
                             add_trait hide_frame_id [TEXT "Hide"];
                             add_trait hide_frame_id [CALLBACK do_hide_frame];}

        also
        fun hide_frame hide
            =
            button (hide_frame_id,
                                    [FILL ONLY_X, EXPAND TRUE],
                                    [TEXT "Hide", CALLBACK hide],[])

        also
        fun hidden_button1 x
            =
            button (make_tagged_widget_id("hiddenButton" + x),
                                     [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
                                     [TEXT ("ToHide" + x), CALLBACK null_callback],[])

        also
        fun hidden_frame ()
            =
            frame (hidden_frame_id,
                                   [hidden_button1 "A", hidden_button1 "B"],
                                   [FILL ONLY_X],[RELIEF RIDGE, BORDER_THICKNESS 2],[]);

        fun hider1 ()
            =
            frame (hider1id,
                              [hide_frame do_hide_frame,
                               hidden_frame ()],
                              [FILL ONLY_X],
                              [RELIEF RIDGE, BORDER_THICKNESS 2],[]);

        #  ----------------------------- daVinci Starter ------------------------------ 


        fun b_label ()
            =
            label (b_label_id,[],[TEXT "Start daVinci"],[])

        also
        fun do_hide_da_vinci ()
            =
            { delete_widget (davi_id);delete_widget (texter_id);}

        also
        fun b_button ()
            =
            button (da_vinci_hider_id,[FILL ONLY_X],
                                [TEXT "Hide daVinci", CALLBACK do_hide_da_vinci],[])

        also
        fun da_vinci_button_start ()
            =
            button (da_vinci_button_start_id,[FILL ONLY_X],
                                          [TEXT "Start", CALLBACK start_da_vinci],[])

        also
        fun da_vinci_button_stop ()
            =
            button (da_vinci_button_stop_id,[FILL ONLY_X],
                                         [TEXT "Stop", CALLBACK stop_da_vinci],[])

        also
        fun da_vinci_starter ()
            =
            frame (davi_id, [b_label(), b_button(),
                                               da_vinci_button_start(),
                                               da_vinci_button_stop()],
                                      [FILL ONLY_X],
                                      [RELIEF RIDGE, BORDER_THICKNESS 2],[])

        also
        fun a_text ()
            =
            text_wid (a_text_id, NOWHERE, empty_livetext,[FILL ONLY_X],[WIDTH 60, HEIGHT 10],[])

        also
        fun texter ()
            =
            frame (texter_id,[a_text()],[FILL ONLY_X],[RELIEF RIDGE, BORDER_THICKNESS 2],[]);

        fun entry ()
            =
            frame (make_widget_id (),
                             [tk_21::entry (entry_id ,[FILL ONLY_X],[],
                                    [EVENT_CALLBACK (KEY_PRESS "Return",
                                                     (fn (_) => 
                                                      {
                                                          t = get_tcl_text entry_id;
                                                      
                                                          { # WAS:  de_focus "Entry"; 
                                                            # changed by bu 
                                                           de_focus main_window_id;
                                                           add_trait mes_can_fr_id 
                                                           [TEXT ("Entered: \"" + t + "\"")];};
                                                      }; end )
                                                     )]
                                    )],
                             [FILL ONLY_X],[RELIEF RIDGE, BORDER_THICKNESS 2],[]);
                                                                                        my
        count = REF (0: Int);                                                            my
        pos   = REF (0, 0);

        fun canvasfr ()
            =
            frame (canvasfr_id,
                                [canvas(), mes_can_fr()],
                                [FILL ONLY_X],
                                [RELIEF RIDGE, BORDER_THICKNESS 2],[])

        also
        fun mes_can_fr ()
            =
            message (mes_can_fr_id,
                                   [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
                                   [WIDTH 350, TEXT "some Text"],
                                   [])

        also
        fun canvas_items_namings wid cit
            =
            [   EVENT_CALLBACK (ENTER, enter_it wid cit),
                EVENT_CALLBACK (LEAVE, leave_it wid cit),
                EVENT_CALLBACK (MOTION, wr_mot_c wid cit),
                EVENT_CALLBACK (SHIFT   (BUTTON_PRESS   (THE 3)), grey_it wid cit),
                EVENT_CALLBACK (ALT     (BUTTON_PRESS   (THE 3)), display_width wid cit),
                EVENT_CALLBACK (CONTROL (BUTTON_PRESS   (THE 3)), display_height wid cit),
                EVENT_CALLBACK          (BUTTON_PRESS   (THE 3), delete_it wid cit),
                EVENT_CALLBACK          (BUTTON_PRESS   (THE 1), grab_it wid cit),
                EVENT_CALLBACK (DOUBLE  (BUTTON_PRESS   (THE 1)), grey_it wid cit),
                EVENT_CALLBACK          (BUTTON_RELEASE (THE 1), drop_it wid cit),
                EVENT_CALLBACK (MODIFIER_BUTTON (1, MOTION), move_it wid cit)
            ]

        also
        fun canvas_items (wid: Widget_Id)
            = 
            [   coval (it1_cid, (50, 50), (100, 100),
                      [FILL_COLOR RED, OUTLINE_WIDTH 3],
                      canvas_items_namings wid it1_cid),

                crectangle (it2_cid, (200, 200), (250, 250),
                           [FILL_COLOR RED, OUTLINE NO_COLOR],
                           canvas_items_namings wid it2_cid),

                coval (it3_cid, (50, 200), (100, 250),
                      [FILL_COLOR NO_COLOR, OUTLINE GREEN, OUTLINE_WIDTH 3],
                      canvas_items_namings wid it3_cid),

                cline (l1_2_cid,[(75, 75), (150, 100), (200, 150), (225, 225)],
                      [FILL_COLOR BROWN, OUTLINE_WIDTH 10, SMOOTH TRUE],
                      canvas_items_namings wid l1_2_cid),

                cline (l2_3_cid,[(225, 225), (75, 225)],
                      [FILL_COLOR WHITE, OUTLINE_WIDTH 3],
                      canvas_items_namings wid l2_3_cid),

                cline (l3_1_cid,[(75, 225), (75, 75)],
                      [FILL_COLOR BLUE, OUTLINE_WIDTH 5],
                      canvas_items_namings wid l3_1_cid),

                cicon (it4_cid, (300, 250),
                      FILE_BITMAP (get_img_path "myex.bmp"),
                      [BACKGROUND BLUE, FOREGROUND YELLOW, ANCHOR NORTHWEST],
                      canvas_items_namings wid it4_cid),

                cwidget (it5_cid, (250, 100), make_canvas_item_frame_id(),
                        [button (make_tagged_widget_id"canvBut",[FILL ONLY_X],
                                [TEXT "Add Subitem",
                                 CALLBACK (fn () => add_sub_canvas wid; end  )],
                                [])],
                        [],
                        [ANCHOR NORTHWEST],
                        canvas_items_namings wid it5_cid),

                cwidget (it6_cid, (200, 10), make_canvas_item_frame_id(),
                        sub_canvas wid it6_cid,
                        [BACKGROUND GREEN],
                        [ANCHOR NORTHWEST, WIDTH 200, HEIGHT 180],
                        canvas_items_namings wid it6_cid),

                ctag (its_cid,[it1_cid, it2_cid, it3_cid, it4_cid, it5_cid])
            ]



        also
        fun cnv_do_hide_button (wid: Widget_Id) (cid: Canvas_Item_Id)()
            = 
            { delete_widget (cnv_hidden_button_id);
             add_trait cnv_hide_button_id [TEXT "Add"];
             add_trait cnv_hide_button_id [CALLBACK (cnv_do_add_button wid cid)] ;}

        also
        fun cnv_do_add_button (wid: Widget_Id) (cid: Canvas_Item_Id) ()
            =
            {   cit = get_canvas_item wid cid;
            
                {   add_widget (main_window_id) cnv_hider_id (cnv_hidden_button());
                    add_trait cnv_hide_button_id [TEXT "Hide"];
                    add_trait cnv_hide_button_id [CALLBACK (cnv_do_hide_button wid cid)]
                ;};
             }

        also
        fun cnv_hide_button hide
            =
            button (
                cnv_hide_button_id,
                [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
                [TEXT "Hide", CALLBACK hide],[]
            )

        also
        fun cnv_hidden_button ()
            =
            button (cnv_hidden_button_id,
                                        [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
                                        [TEXT "Delete",
                                         CALLBACK (fn () => delete_canvas_item c1id it1_cid; end )],
                                        [])

        also
        fun testit ()
            =
            (add_trait cnv_hidden_button_id [TEXT "Deleted"])

        also
        fun cnv_hider (wid: Widget_Id) (cid: Canvas_Item_Id)
            = 
            frame (cnv_hider_id,
                  [cnv_hide_button (cnv_do_hide_button wid cid),
                   cnv_hidden_button ()],
                  [FILL ONLY_X, PAD_X 5, PAD_Y 5],
                  [RELIEF RIDGE, BORDER_THICKNESS 2],[])

        also
        fun cnv_deleter (wid: Widget_Id) (cid: Canvas_Item_Id)
            =
            button (cnv_deleter_id,
                   [FILL ONLY_X, EXPAND TRUE, PAD_X 5, PAD_Y 5],
                   [TEXT "Quit Subitem",
                    CALLBACK (fn () => delete_canvas_item wid cid; end )],
                   [])

        also
        fun sub_canvas (wid: Widget_Id) (cid: Canvas_Item_Id)
            = 
            [cnv_hider wid cid,
             cnv_deleter wid cid,
             tk_21::canvas (c1id, AT_RIGHT,
                          [ coval (it1_cid, (25, 25), (75, 75),
                            [FILL_COLOR RED, OUTLINE_WIDTH 3],
                            []) ],
                          [PAD_X 5, PAD_Y 5],
                          [BACKGROUND YELLOW, BORDER_THICKNESS 2, RELIEF RIDGE],
                          [])]

        also
        fun add_sub_canvas (wid: Widget_Id)
            =
            {
                cid = make_canvas_item_id();
                cit = cwidget (cid, (200, 10), make_canvas_item_frame_id(),
                                  sub_canvas wid cid,
                                  [BACKGROUND GREEN],
                                  [ANCHOR NORTHWEST, WIDTH 200, HEIGHT 180],
                                  canvas_items_namings wid cid);
            
                add_canvas_item wid cit;
            }


        also
        fun canvas ()
            =
            { c = canvas_id;
                           tk_21::canvas (c, AT_RIGHT, canvas_items c,
                                          [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
                                          [HEIGHT 300, WIDTH 200, BACKGROUND YELLOW,
                                          BORDER_THICKNESS 2, RELIEF RIDGE],
                                          [EVENT_CALLBACK (BUTTON_PRESS (THE 2), add_one_item c)]); 
                          }

        also
        fun add_one_item (wid: Widget_Id) (e: Tk_Event)
            =
            {   x    = get_x_coordinate e;
                y    = get_y_coordinate e;
                ncid = make_canvas_item_id ();
                ncit = coval (ncid, (x - 25, y - 25), (x+25, y+25),
                                 [FILL_COLOR RED, OUTLINE_WIDTH 3],
                                 canvas_items_namings wid ncid);
            
                add_canvas_item wid ncit;
            }

        also
        fun delete_it (wid: Widget_Id) (cid: Canvas_Item_Id) (_: Tk_Event)
            =
            delete_canvas_item wid cid

        also
        fun display_width (wid: Widget_Id) (cid: Canvas_Item_Id) (_: Tk_Event)
            =
            add_trait mes_can_fr_id [TEXT ("Item \"" + (canvas_item_id_to_string cid) + "\" has width: "  + 
                                        (int::to_string (get_tcl_canvas_item_width wid cid)))]

        also
        fun display_height (wid: Widget_Id) (cid: Canvas_Item_Id) (_: Tk_Event)
            =
            add_trait mes_can_fr_id [TEXT ("Item \"" + (canvas_item_id_to_string cid) + "\" has height: "  + 
                                        (int::to_string (get_tcl_canvas_item_height wid cid)))]

        also
        fun grey_it (wid: Widget_Id) (cid: Canvas_Item_Id) (_: Tk_Event)
            =
            { add_canvas_item_traits wid cid [FILL_COLOR GREY];
             add_canvas_item_event_callbacks wid cid [EVENT_CALLBACK (SHIFT (BUTTON_PRESS (THE 3)), blue_it wid cid)];}

        also
        fun blue_it (wid: Widget_Id) (cid: Canvas_Item_Id) (_: Tk_Event)
            =
            { add_canvas_item_traits wid cid [FILL_COLOR BLUE];
             add_canvas_item_event_callbacks wid cid [EVENT_CALLBACK (SHIFT (BUTTON_PRESS (THE 3)), grey_it wid cid)];}

        also
        fun enter_it (wid: Widget_Id) (cit: Canvas_Item_Id) (_: Tk_Event)
            = 
            { add_trait mes_can_fr_id [TEXT ("<Enter Canvas Item("  +  
                                        (widget_id_to_string wid)  +  ", "  +  
                                        (canvas_item_id_to_string cit)  +  ")>")];
             add_trait wid [CURSOR (XCURSOR("hand2", NULL))];}

        also
        fun grab_it (wid: Widget_Id) (cid: Canvas_Item_Id) (TK_EVENT(_, _, x, y, _, _))
            =
            { pos := (x, y);
             add_trait wid [CURSOR (XCURSOR("fleur", NULL))];}

        also
        fun move_it (wid: Widget_Id) (cid: Canvas_Item_Id) (TK_EVENT(_, _, x, y, _, _))
            = 
            {
                cit_col  = get_tcl_canvas_item_coordinates wid cid;
                my (x_p, y_p)  = *pos;
                pos     := (x, y);
                delta    = (x-x_p, y-y_p);
                cit_col' = map (add_coordinates (coordinate delta)) cit_col;
                t        = "<Drag Canvas Item(" + (int::to_string x) + ", " + 
                        (int::to_string y) + ", " + (widget_id_to_string wid) + ", " + 
                        (canvas_item_id_to_string cid) + ") > " + 
                        (int::to_string *count);

                basic_utilities::inc count;
            
        /*      (add_trait mesCanFrId [TEXT t]; 
         */
                set_canvas_item_coordinates wid cid cit_col'; 
        /*
                 move_canvas_item wid cid delta
        */
            }

        also
        fun drop_it (wid: Widget_Id) (cid: Canvas_Item_Id) (TK_EVENT(_, _, x, y, _, _))
            =
            add_trait wid [CURSOR (XCURSOR("hand2", NULL))]

        also
        fun leave_it (wid: Widget_Id) (cit: Canvas_Item_Id) (_: Tk_Event)
            = 
            { add_trait mes_can_fr_id [TEXT ("<Leave Canvas Item(" + (widget_id_to_string wid) + ", " + 
                                        (canvas_item_id_to_string cit) + ")>")];
             add_trait wid [CURSOR (NO_CURSOR)];}

        also
        fun wr_mot_c (wid: Widget_Id) (cid: Canvas_Item_Id) (TK_EVENT(_, _, x, y, _, _))
            = 
            {   t = "<Motion Canvas Item(" + (int::to_string x) + ", " + 
                        (int::to_string y) + ", " + (widget_id_to_string wid) + ", " + 
                        (canvas_item_id_to_string cid) + ") > " + 
                        (int::to_string  *count);

                basic_utilities::inc count;
             
                add_trait mes_can_fr_id [TEXT t];
            }

        also
        fun wr_ent (_: Tk_Event) = add_trait mes_can_fr_id [TEXT "<Enter>"]
        also
        fun wr_lea (_: Tk_Event) = add_trait mes_can_fr_id [TEXT "<Leave>"]
        also
        fun wr_mot (_: Tk_Event) = 
            {
                t = "<Motion> " + (int::to_string *count);
                my _ = basic_utilities::inc count;
             
                add_trait mes_can_fr_id [TEXT t];
            };

        fun quit_button quit
            =
            button(
                make_tagged_widget_id "quitButton",
                [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
                [   TEXT "Quit",
                    CALLBACK quit,
                    CURSOR(
                        FILE_CURSOR (
                            get_img_path "myex.cursor",
                            BLUE,
                            THE (
                                get_img_path "myex.cursor_mask",
                                YELLOW
                    )   )   )
                ],
                []
            );

        fun quitter ()
            =
            frame (make_tagged_widget_id "quitter",
                               [quit_button do_quit],
                               [FILL ONLY_X],
                               [RELIEF RIDGE, BORDER_THICKNESS 2],[]);

        fun initwin _
            =
            [   make_window {
                    window_id   => main_window_id,
                    traits => [   WINDOW_TITLE "Hider Example",
                                  WINDOW_SIZED_BY PROGRAM,
                                  WIDE_HIGH_X_Y (NULL, THE (50, 50))
                              ], 
                    subwidgets => PACKED [a_label(), hider(), hider1(), da_vinci_starter(),
                                                  texter(), entry(), canvasfr(), quitter()], 
                    event_callbacks => [],
                    init => null_callback
                }
            ];

                                                                                        my
        go   =   fn () => start_tcl_and_trap_tcl_exceptions (initwin ()); end ;

};


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext