PreviousUpNext

15.4.1241  src/lib/tk/src/bind.pkg

#  *********************************************************************** 
#                                                                          
#  Project: sml/Tk: an Tk Toolkit for sml                                  
#  Author: Burkhart Wolff, University of Bremen                            
#  Date: 25.7.95                                                           
#  Purpose of this file: Functions related to "Tk-Namings"                 
#                                                                          
#  *********************************************************************** 

# Compiled by:
#     src/lib/tk/src/tk.sublib

package   bind
: (weak)  Bind                                  # Bind  is from   src/lib/tk/src/bind.api
{
        stipulate

            include  basic_tk_types;

        herein 

            infix my 20  bind_elem ;

            fun bind_eq (EVENT_CALLBACK (k1, c1)) (EVENT_CALLBACK (k2, c2))
                =
                k1 == k2;

            fun bind_elem_h (b,[]) => FALSE;
                bind_elem_h (b, (x . xs)) => bind_eq b x or bind_elem_h (b, xs);
            end;
                                                                                    my
            (bind_elem) = bind_elem_h;

            fun no_dbl_p [] => TRUE;
                no_dbl_p (x . xs) => not (x bind_elem xs) andalso no_dbl_p xs;
            end;


            # ***********************************************************************
            #   
            #       Convert Events to strings 
            #
            # *********************************************************************** *)

            fun sp_to_str NULL    =>   "";
                sp_to_str (THE i) =>   "-" + (int::to_string i);
            end;

            stipulate
                fun event_name' FOCUS_IN            => "FocusIn";
                    event_name' FOCUS_OUT           => "FocusOut";
                    event_name' CONFIGURE           => "Configure";
                    event_name' MAP                 => "Map";
                    event_name' UNMAP               => "Unmap";
                    event_name' VISIBILITY          => "Visibility";
                    event_name' DESTROY             => "Destroy";
                    event_name' (KEY_PRESS str)     => "KeyPress-" + str;
                    event_name' (KEY_RELEASE str)   => "KeyRelease-" + str;
                    event_name' (BUTTON_PRESS sp)   => "ButtonPress" + (sp_to_str sp);
                    event_name' (BUTTON_RELEASE sp) => "ButtonRelease" + (sp_to_str sp);
                    event_name' ENTER               => "Enter";
                    event_name' LEAVE               => "Leave";
                    event_name' MOTION              => "Motion";
                    event_name' (DEPRECATED_EVENT str) => str;
                    event_name' (SHIFT (KEY_PRESS s))=> "Shift-" + s;
                    event_name' (SHIFT e)           => "Shift-" + (event_name' e);
                    event_name' (CONTROL (KEY_PRESS s))=> "Control-" + s;
                    event_name' (CONTROL e)         => "Control-" + (event_name' e);
                    event_name' (LOCK e)            => "Lock-"    + (event_name' e);
                    event_name' (ANY e)             => "Any-"     + (event_name' e);
                    event_name' (DOUBLE e)          => "Double-"  + (event_name' e);
                    event_name' (TRIPLE e)          => "Triple-"  + (event_name' e);
                    event_name' (MODIFIER_BUTTON (i, e))  => "Button" + (int::to_string i) + "-" + (event_name' e);
                    event_name' (META e)            => "Meta-"    + (event_name' e);
                    event_name' (ALT  e)            => "Alt-"     + (event_name' e);
                    event_name' (MOD3 e)            => "Mod3-"    + (event_name' e);
                    event_name' (MOD4 e)            => "Mod4-"    + (event_name' e);
                    event_name' (MOD5 e)            => "Mod5-"    + (event_name' e);
                end;
            herein
                fun event_name event
                    =
                    "<"   +   (event_name' event)   +   ">";
            end;

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

               selectors on Event_Callback's

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


            fun sel_event (EVENT_CALLBACK (k, c))
                =
                k;

            fun sel_action (EVENT_CALLBACK (k, c))
                =
                c;


            fun get_action_by_name name [] => (fn e => (); end );
               get_action_by_name name (x . xs) => 
                               if (event_name (sel_event x) == name ) sel_action x; 
                               else get_action_by_name name xs;fi; end;

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

               defaults for Event_Callback's

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

            #  DefaultBindPack:  Widget_Type -> Key -> String 
            fun default_bind_pack _ _ = "";

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

               updating Event_Callback's

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


            fun add_one_bind (c, [])    => [c];
               add_one_bind (c, x . xs) => if (bind_eq x c ) c . xs; else x . add_one_bind (c, xs);fi; end;

            fun add old new
                =
                list::fold_backward add_one_bind old new;

            fun delete_one_bind cs c
                =
                list::filter (not o (bind_eq c)) cs;

            fun delete old new
                =
                map sel_event (fold_forward (basic_utilities::twist (basic_utilities::uncurry (delete_one_bind))) old new);


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

               Event_Callback's  ==>  Tcl

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

            # packOneWindowBind:  Window_ID -> Event_Callback -> String

            fun pack_one_window_bind w (EVENT_CALLBACK (e, _))
                =
                if (gui_state::is_init_window w)
                    
                    "bind . " + (event_name e) + " { if {\"%W\" == \".\"} {" +
                    com::comm_to_tcl + " \"WinNaming " + w + " " + (event_name e) + " " +
                    tk_event::show() + " \"}}\n";
                else
                    "bind ." + w + " " + (event_name e) + " { if {\"%W\" == \"." + w +
                    "\"} {" + com::comm_to_tcl + " \"WinNaming " + w + " " + (event_name e) +
                    " " + tk_event::show() + " \"}}\n";
                fi;



            /* packWindow:  Window_ID -> Event_Callback List -> String List
             */
            fun pack_window w bs
                =
                map (pack_one_window_bind w) bs;



            /* unpackOneWindowBind:  TclPath -> Event -> String
             */
            fun unpack_one_window_bind tp e
                =
                "bind " + tp + " " + (event_name e) + " {}";



            /* unpackWindow:  TclPath -> Event List -> String List
             */
            fun unpack_window tp es
                =
                map (unpack_one_window_bind tp) es;



            /*  packOneWidgetBind:  TclPath -> IntPath -> Event_Callback -> String
             */
            fun pack_one_widget_bind tp (w, p) (EVENT_CALLBACK (e, com))
                =
                "bind " + tp + " " + (event_name e) + " {" + com::comm_to_tcl +
                " \"WNaming " + w + " " + p + " " + (event_name e) + " " +
                tk_event::show() + " \"}\n";



            /* packWidget:  TclPath -> IntPath -> Event_Callback List -> String List
             */
            fun pack_widget tp ip bs
                =
                map (pack_one_widget_bind tp ip) bs;



            /* packOneCanvasBind:  TclPath -> IntPath -> Canvas_Item_ID -> Event_Callback -> String
             */
            fun pack_one_canvas_bind tp (w, p) cid (EVENT_CALLBACK (e, com))
                =
                tp + " bind " + cid + " " + (event_name e) + " {" + com::comm_to_tcl +
                " \"CNaming " + w + " " + p + " " + cid + " " + (event_name e) +
                " " + tk_event::show() + " \"}\n";



            /* packCanvas:  TclPath -> IntPath -> Event_Callback List -> String List
             */
            fun pack_canvas tp ip cid bs
                =
                map (pack_one_canvas_bind tp ip cid) bs;



            /* packOneTagBind:  TclPath -> IntPath -> Text_Item_ID -> Event_Callback -> String
             */
            fun pack_one_tag_bind tp (w, p) aid (EVENT_CALLBACK (e, com))
                =
                tp + " tag bind " + aid + " " + (event_name e) + " {" + com::comm_to_tcl +
                " \"TNaming " + w + " " + p + " " + aid + " " + (event_name e) +
                " " + tk_event::show() + " \"}\n";



            /* packTag:  TclPath -> IntPath -> Event_Callback List -> String List
             */
            fun pack_tag tp ip tn bs
                =
                map (pack_one_tag_bind tp ip tn) bs;



            /* unpackOneBind:  TclPath -> Widget_Type -> Event -> String
             */
            fun unpack_one_widget_bind tp wt e
                =
                "bind " + tp + " " + (event_name e) + " {" + default_bind_pack wt e + "}" +
                "\n";



            /* unpackWidget:  TclPath -> Widget_Type -> Event List -> String List:
             */
            fun unpack_widget tp wt es
                =
                map (unpack_one_widget_bind tp wt) es;
        end;

    };


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext