PreviousUpNext

15.4.1293  src/lib/tk/src/toolkit/tests+examples/boxes.pkg

## boxes.pkg
## (C) 1996, Bremen Institute for Safe Systems, Universitaet Bremen
## Author: cxl

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



# ***************************************************************************
# Test and example program for the drag&drop package. 
#
# It presents the amazed user with a window in which he can move
# around wee blue, red and green boxes. Moving a box on the red box
# makes it go away, moving it onto the green box makes it replicate
# itself. You can't move the green or red box onto anything. In fact,
# you can't move the red box at all. 
#
# Use WeeBoxes::go() to start. You have to call SysInit::initSmlTk() first,
# and the drag_and_drop_g class macro has to be in the environment.
# ***************************************************************************


package wee_boxes

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

{

    include basic_utilities;
    include tk;

    
     Box = RED_BOX  Canvas_Item_Id
                 | GREEN_BOX  Canvas_Item_Id
                 | BLUE_BOX  Canvas_Item_Id;
                 
    fun is_blue (blue_box _) => TRUE;
       is_blue _           => FALSE; end;
     
                                                                              my
    backdrop = make_widget_id();

    # Bit of a hack, this: this variable will point towards the function
    # exported from drag_and_drop_g by which we can place items on the
    # drag&drop area.

                                                                              my
    add_new_box_fun = REF (fn e: Box=> (); end ); 
                                                                              my
    box_size = 50;                                                              my
    backdrop_height = 300;                                                      my
    backdrop_width = 400;


    fun debug str
        =
        debug::print 19 ("Boxes: " $ str);

    # This function adds a new box to the area. You can only use it
    # after initializing addNewBoxFun above. 
    #
    fun add_new_box (boxitem, boxcit)
        =
        {   add_canvas_item backdrop boxcit;
            *add_new_box_fun boxitem;
        };
 

    # Auxiliary functions to create new Boxes in a format to 
    # use with addNewBox above. 
    #
    fun new_box colour w_here
        = 
        CANVAS_BOX { citem_id=>make_canvas_item_id(), coord1=>w_here, 
                   coord2 => add_coordinates w_here (coordinate (box_size, box_size)), 
                   traits => [FILL_COLOR colour, OUTLINE BLACK, OUTLINE_WIDTH 3], 
                   event_callbacks => []
        };
 
    fun new_green_box w_here
        =
        {   nu_box = new_box GREEN w_here;
        
            (green_box (get_canvas_item_id (nu_box)), nu_box);
        };
 
    fun new_red_box w_here
        = 
        {   nu_box = new_box RED w_here;
        
            (red_box (get_canvas_item_id (nu_box)), nu_box);
        };
 
    fun new_blue_box w_here
        =
        {   nu_box = new_box BLUE w_here;
        
            (blue_box (get_canvas_item_id (nu_box)), nu_box);
        };

    # List of the initial boxes:

    all_my_boxes
        =
        [new_blue_box  (coordinate (10, 10)), new_blue_box (coordinate (10, 80)), new_blue_box (coordinate (10, 150)),
         new_green_box (coordinate (10, backdrop_height - 10-box_size)), 
         new_red_box   (coordinate (backdrop_width - 10-box_size, backdrop_height - 10-box_size))]; 
 
 
    fun sel_box_id (red_box cit)   => cit;
       sel_box_id (green_box cit) => cit;
       sel_box_id (blue_box cit)  => cit; end;
        
    fun enlarge_box cit
        =
        {   coords = get_tcl_canvas_item_coordinates backdrop cit;
            nuc    = (subtract_coordinates (hd coords) (coordinate (5, 5))) . 
                        (add_coordinates (hd (tl coords)) (coordinate (5, 5))) . NIL;
        
            set_canvas_item_coordinates backdrop cit nuc;
        };

    fun shrink_box cit
        =
        {   coords = get_tcl_canvas_item_coordinates backdrop cit;
            nuc    = (add_coordinates (hd coords) (coordinate (5, 5))) .
                        (subtract_coordinates (hd (tl coords)) (coordinate (5, 5))) . NIL;
        
            set_canvas_item_coordinates backdrop cit nuc;
        };

    fun colour_box cit colour
        =
        add_canvas_item_traits backdrop cit [FILL_COLOR colour];

    fun hilight_box (red_box cit)   => enlarge_box cit;
        hilight_box (green_box cit) => shrink_box  cit;
        hilight_box (blue_box cit)  => colour_box  cit YELLOW;
    end;

    fun enter_box box boxes
        =
        {   cin_drop = list::all is_blue boxes;                                     

            if cin_drop  hilight_box box;
                    fi;
        
            { debug (canvas_item_id_to_string (sel_box_id box)$" entered by "$
                   (string::join " " (map (canvas_item_id_to_string o sel_box_id) boxes))$
                   ": " $ (bool::to_string cin_drop));
            cin_drop;};
        }; 

    fun leave_box (red_box   cit) =>  shrink_box  cit;
        leave_box (green_box cit) =>  enlarge_box cit;
        leave_box (blue_box  cit) =>  colour_box  cit BLUE;
    end;

    fun lowlight_box (blue_box cit) =>  colour_box cit BLUE;
        lowlight_box _              =>  ();
    end;


    fun drop_box (red_box _)  _
            =>
            FALSE;

        drop_box (blue_box _) _
            => 
            {   posix::sleep (time::from_seconds 20);
                TRUE;
            };

        drop_box (green_box cit) _
            => 
            {   w_here          = get_tcl_canvas_item_coordinates backdrop cit;
                add_new_box (new_blue_box (add_coordinates (coordinate (60, 0)) (hd w_here)));
                TRUE;
            };
    end;


                                                                                my
    move_opaque = REF FALSE;  

    #  Changed by toggleMove, see moveButton() below 

    fun move_box box delta
        =
        if *move_opaque
            move_canvas_item backdrop (sel_box_id box) delta;
        fi;
            


    #  Boxes as Drag&Drop-Items: 
    #
    package box_items: (weak)  Drag_And_Drop_Items {            # Drag_And_Drop_Items   is from   src/lib/tk/src/toolkit/drag-and-drop.api

         Item = Box;
         Item_List =  List( Box );

        fun  item_list_rep x = x;
        fun  item_list_abs x = x;

                                                                            my
        get_canvas_item_id     = sel_box_id;

        fun is_immobile (red_box _) => TRUE;
           is_immobile _          => FALSE; end;

        fun sel_drop_zone _
            =
            make_box (coordinate (2, 2), coordinate (box_size- 2, box_size -2));

        fun grab _   = ();                                                   my

        release  = lowlight_box;                                              my
        move     = move_box;
                                                                            my
        select   = hilight_box;                                               my
        deselect = lowlight_box;
                                                                            my
        enter = enter_box;                                                    my
        leave = leave_box;

        fun drop b bb
            =
            { debug ("drop " $ (string::join " " 
                                         (map (canvas_item_id_to_string o sel_box_id) bb)) $ " on " $
                                        (canvas_item_id_to_string (sel_box_id b))); drop_box b bb;};

        # Although we do not use the clipboard, it has to be here. 
        #
        package clipboard
            =
            clipboard_g ( Part = List( Box ); );
    };


    package drag_drop_boxes
        =
        drag_and_drop_g( box_items );


    fun init_boxes ()
        =
        {                                                                     my
            ddboxes = drag_drop_boxes::init backdrop;

            fun place_new_blue_box (TK_EVENT(_, _, x, y, _, _))
                =
                add_new_box (new_blue_box (coordinate (x, y)));
        
           {   add_new_box_fun := drag_drop_boxes::place ddboxes;
               apply add_new_box all_my_boxes;
               add_event_callbacks backdrop [EVENT_CALLBACK (DOUBLE (BUTTON_PRESS (THE 1)), make_callback (place_new_blue_box))];
           };            
        };


    #  Get a window 

    fun backdrop_namings ()
        =
        [   EVENT_CALLBACK (
                LEAVE,
                make_callback (
                    fn TK_EVENT(_, _, x, y, _, _)
                        =>
                        debug::print 19 ("Leave event occurred at " $
                               (int::to_string x) $ ", " $ (int::to_string y)); end 
                )
            )
        ];
        
    fun backdrop_canvas ()
        =
        CANVAS {
            widget_id       => backdrop,
            scrollbars      => NOWHERE,
            citems          => [],
            packing_hints   => [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
            event_callbacks => backdrop_namings(),
            traits => [   HEIGHT backdrop_height,
                         WIDTH backdrop_width,
                         RELIEF GROOVE,
                         BACKGROUND GREY
                     ]
        };


    fun quit_button window
        = 
        BUTTON {
            widget_id       => make_widget_id (),
            packing_hints   => [PACK_AT BOTTOM, FILL ONLY_X, EXPAND TRUE],
            event_callbacks => [],

            traits => [   TEXT "Quit",
                         CALLBACK (make_simple_callback (fn _ = tk::close_window window)),
                         RELIEF RIDGE,
                         BORDER_THICKNESS 2
                     ]
        };

    fun toggle_move mb ()
        =
        if *move_opaque

             move_opaque := FALSE;
             add_trait mb [TEXT "Move Opaque", CALLBACK (make_simple_callback (toggle_move mb))];
        else
             move_opaque := TRUE;
             add_trait mb [TEXT "Move Invisible", CALLBACK (make_simple_callback (toggle_move mb))];
        fi;
        

    fun move_button ()
        = 
        {                                                                     my
            mb = make_widget_id ();
        
            BUTTON {
                widget_id       => mb,
                packing_hints   => [PACK_AT BOTTOM, FILL ONLY_X, EXPAND TRUE],
                event_callbacks => [],
                traits          => [   TEXT "Move Opaque",
                                      CALLBACK (make_simple_callback (toggle_move mb)),
                                      RELIEF RIDGE,
                                      BORDER_THICKNESS 2
                                  ]
            };
        };
        

    fun go ()
        = 
        {                                                                 my
            mw     = make_window_id ();                                             my
            boxwin = make_window {
                         window_id => mw, 
                         traits => [WINDOW_TITLE "LittleBoxes"], 
                         subwidgets => PACKED [backdrop_canvas(), 
                                                 quit_button mw, move_button()],
                         event_callbacks => [],
                         init => init_boxes
                     };

        
            start_tcl_and_trap_tcl_exceptions [boxwin]
            except
                drag_drop_boxes::DRAG_AND_DROP why
                    =>
                    why; end ;
        };

}; 










Comments and suggestions to: bugs@mythryl.org

PreviousUpNext