PreviousUpNext

15.4.1267  src/lib/tk/src/tests+examples/popup_ex.pkg

/*
 *
 *  Project: sml/Tk: an Tk Toolkit for sml
 *  Author: Burkhart Wolff, University of Bremen
 * $Date: 2001/03/30 13:39:33 $
 * $Revision: 3.0 $
 *  Purpose of this file: PopUp example
 *
 */

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

package pop_up_ex :   api {                                                       
                          go:  Void -> String;
                      }
{

    include tk;
                                                                                my
    warn = make_tagged_window_id "warning";

    #  Warning Window 
    fun warning_window msg yes no
        = 
        make_window {
            window_id => warn, 
            traits => [WINDOW_TITLE "Warning"], 
            subwidgets => PACKED [
                          LABEL {
                              widget_id => make_widget_id(),
                              packing_hints => [FILL ONLY_X, EXPAND TRUE],
                              traits => [TEXT msg, RELIEF FLAT, WIDTH 25],
                              event_callbacks => []
                          },

                          FRAME {
                              widget_id => make_widget_id(),
                              subwidgets => PACKED [
                                            BUTTON {
                                                widget_id => make_widget_id (),
                                                packing_hints => [PACK_AT LEFT,  FILL ONLY_X, EXPAND TRUE],
                                                traits => [TEXT "YES", CALLBACK yes],
                                                event_callbacks => []
                                            },
                                            BUTTON {
                                                widget_id => make_widget_id (),
                                                packing_hints => [PACK_AT RIGHT, FILL ONLY_X, EXPAND TRUE],
                                                traits => [TEXT "NO",  CALLBACK  no],
                                                event_callbacks => []
                                            }
                                         ],
                                packing_hints => [],
                                traits => [],
                                event_callbacks => []
                          }
                      ],
            event_callbacks => [],
            init => null_callback
       };

    fun warning msg yes no
        =
        open_window (warning_window msg yes no);



    #  Enter Window 

    main_window_id = make_tagged_window_id "meisterfenster";
    entern = make_tagged_window_id "entername";
    p1 = make_tagged_widget_id "p1";
    p2 = make_tagged_widget_id "p2";
    c1 = make_tagged_widget_id "c1";
    it1 = make_tagged_canvas_item_id "it1";
    it2 = make_tagged_canvas_item_id "it2";
    e1 = make_tagged_widget_id "e1";
    itemmenu = make_tagged_widget_id "itemmenu";


    enterwin = 
        { 
            inputok  = fn () => { change_title main_window_id (make_title (get_tcl_text e1));
                                     close_window entern ;}; end ;
        
            make_window {
                window_id =>  entern, 
                traits => [WINDOW_TITLE "Please enter name"], 
                subwidgets => PACKED [
                              LABEL {
                                  widget_id => make_widget_id (),
                                  packing_hints => [PACK_AT LEFT],
                                  traits => [TEXT "name:"],
                                  event_callbacks => []
                              },
                              TEXT_ENTRY {
                                  widget_id => e1,
                                  packing_hints => [],
                                  traits => [WIDTH 20],
                                  event_callbacks => [ EVENT_CALLBACK ( KEY_PRESS "Return",
                                                                       fn (_: Tk_Event) => inputok(); end  )
                                                    ]
                              }
                          ],
                event_callbacks => [],
                init => null_callback
            };
        };
                                                                                my 
    playername
        =
        fn () => open_window enterwin; end ;

    #  Main Window 
                                                                                my 
    entername
        =
        MENU_COMMAND [TEXT "Enter name", CALLBACK playername];
                                                                                my 
    menu
        = 
        {
            nogoon   = make_simple_callback (fn () = close_window warn);
            yesquit  = make_simple_callback (fn () = close_window main_window_id);
            yesreset = make_simple_callback (fn () = ());
            newgame  = make_simple_callback (fn() = warning "really reset?" yesreset nogoon);
            quitgame = make_simple_callback (fn () = warning "really quit?"  yesquit  nogoon);
        
            FRAME {
                widget_id => make_widget_id (),
                packing_hints => [FILL ONLY_X],
                traits => [RELIEF RAISED, BORDER_THICKNESS 2],
                event_callbacks => [],
                subwidgets   => PACKED [
                                MENU_BUTTON {
                                    widget_id => make_widget_id (),
                                    mitems => [   MENU_COMMAND([TEXT "New", CALLBACK newgame]),
                                                 MENU_SEPARATOR,
                                                 MENU_COMMAND( [TEXT "Quit", CALLBACK quitgame])
                                             ],
                                    packing_hints => [PACK_AT LEFT],
                                    traits => [TEXT "File", TEAR_OFF TRUE],
                                    event_callbacks => []
                                }, 
                                MENU_BUTTON {
                                    widget_id => make_widget_id (),
                                    mitems => [ MENU_COMMAND([TEXT "Enter name", CALLBACK playername])
                                             ],
                                    packing_hints => [PACK_AT LEFT],
                                    traits => [TEXT "Special", TEAR_OFF TRUE],
                                    event_callbacks => []
                                },
                                MENU_BUTTON {
                                    widget_id => itemmenu,
                                    mitems => [    MENU_COMMAND([TEXT "Add", CALLBACK playername]),
                                                  MENU_COMMAND([TEXT "Delete", CALLBACK (make_simple_callback((fn () => (); end )))])
                                             ],
                                    packing_hints => [PACK_AT LEFT],
                                    traits => [TEXT "Item", TEAR_OFF TRUE],
                                    event_callbacks => []
                                }
                   ]
            };
        };

    fun popup1 wid =
        POPUP { widget_id   => wid,
              mitems  => [MENU_COMMAND([TEXT "Add",
                                   CALLBACK (make_simple_callback (fn () => (); end )) ]),
                         MENU_COMMAND([TEXT "Delete",
                                   CALLBACK (make_simple_callback (fn () => (); end ))]),
                         MENU_SEPARATOR,
                         MENU_COMMAND([TEXT "Properties", CALLBACK playername])],
              traits => [] };
                                                                                my
    board
        = 
        {                                                                     my
            pos = REF (0: Int, 0: Int);

            fun grab_it (wid: Widget_Id) (cid: Canvas_Item_Id) (TK_EVENT(_, _, x, y, _, _))
                =
                pos := (x, y);

            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    = coordinate (x-x_p, y-y_p);
                
                    move_canvas_item wid cid delta;
                };

            fun popitup_m (TK_EVENT(_, _, _, _, xr, yr))
                = 
                pop_up_menu itemmenu NULL (coordinate (xr, yr));

            fun popitup_p (TK_EVENT(_, _, _, _, xr, yr))
                = 
                pop_up_menu p1 (THE 4) (coordinate (xr, yr));

            fun popitup_d (TK_EVENT(_, _, _, _, xr, yr))
                = 
    #       widget_ops::make_and_pop_up_window (Popup1 p2) (THE 4) (xr, yr) 
                make_and_pop_up_window (popup1 p2) (THE 4) (coordinate (xr, yr));

            fun popitdown_d _
                =
                delete_widget p2;

            fun itbds (wid: Widget_Id) (cid: Canvas_Item_Id)
                = 
                [   EVENT_CALLBACK (BUTTON_PRESS (THE 2),           make_callback (popitup_m)),
                    EVENT_CALLBACK (SHIFT (BUTTON_PRESS (THE 3)),   make_callback (popitup_d)),
                    EVENT_CALLBACK (SHIFT (BUTTON_RELEASE (THE 3)), make_callback (popitdown_d)),
                    EVENT_CALLBACK (BUTTON_PRESS (THE 3),           make_callback (popitup_p)),
                    EVENT_CALLBACK (BUTTON_PRESS (THE 1),           make_callback (grab_it wid cid)),
                    EVENT_CALLBACK (MODIFIER_BUTTON (1, MOTION),     make_callback (move_it wid cid))
                 ];
        
            FRAME {
                widget_id  => make_widget_id (),
                packing_hints => [PACK_AT LEFT, FILL ONLY_X],
                traits => [WIDTH 200, HEIGHT 200, RELIEF RAISED, BORDER_THICKNESS 2], 
                event_callbacks => [],
                subwidgets => PACKED [
                                 CANVAS {
                                     widget_id  => c1,
                                     scrollbars => AT_LEFT_AND_BOTTOM,
                                     citems => [   CANVAS_OVAL {
                                                           citem_id=>it1, coord1=>coordinate (50, 50), 
                                                                     coord2=>coordinate (100, 100), 
                                                                     traits => [FILL_COLOR RED], 
                                                                     event_callbacks=>itbds c1 it1
                                                       },
                                                       CANVAS_OVAL {
                                                           citem_id=>it2,
                                                           coord1 => coordinate (100, 100),
                                                           coord2 => coordinate (150, 150),
                                                           traits => [FILL_COLOR RED],
                                                           event_callbacks=>itbds c1 it2
                                                       }
                                                   ],
                                     packing_hints => [],
                                     traits => [SCROLL_REGION (0, 0, 400, 400)],
                                     event_callbacks => []
                                 }
                             ]
            };
        };
                                                                                my
    area    = [menu, board, (popup1 p1)];

                                                                                my
    initwin  = [   make_window {
                       window_id => main_window_id, 
                       traits => [WINDOW_TITLE "POPUP Example"], 
                       subwidgets => PACKED area,
                       event_callbacks => [],
                       init => null_callback
                   }
               ];


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


};



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext