PreviousUpNext

15.4.1300††src/lib/tk/src/toolkit/tests+examples/tree_list_ex.pkg

## tree_list.pkg
## (C) 1999, Albert Ludwigs Universitšt Freiburg
## Author: bu

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



# **************************************************************************
# Test of hierarchical Listbox. 
# **************************************************************************



package little_tree_list

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

    #  *********************************************************************** 
    #                                                                          
    #  Data Construction                                                       
    #                                                                          
    #  *********************************************************************** 

   package m: (weak)  Part_Class                # Part_Class    is from   src/lib/tk/src/toolkit/object_class.api
                 =
                 package {
                      Name = Ref( String );
                      Part_Ilk = ((Int, Name));
                      Part_Type = INT;
                     fun  ord ((x, _), (x', _)) = int::compare (x, x');
                     fun  name_of(_, y) = y;
                     fun  rename s (x, y) = (y:=s);
                     fun  reset_name (x, y)=(y:="stdname: " $ (int::to_string x)); 
                     fun  string_of_name s t = *s;
                     fun  part_type _ = INT;
                     fun  icon _    = { print"W\n";raise exception empty;};
                      Cb_Objects = Void -> List( Part_Ilk );
                     fun  cb_objects_abs x = x;
                     fun  cb_objects_rep x = x;
                 };

   package n: (weak)  Folder_Info               # Folder_Info   is from   src/lib/tk/src/toolkit/tree_object_class.api
                 = 
                 package { 
                      Node_Info = Ref( String );
                      Subnode_Info = Void;
                     fun  ord_node (x, y) = string::compare(*x,*y); 
                     fun  string_of_name_node s _ = *s;
                     fun  rename_node s t   = (t:=s);
                     fun  reset_name_node s = (s:="...");
                 };
 
   package tree_obj
       =
       object_to_tree_object_g (package n = n also m = m;);

#  *********************************************************************** 
#                                                                          
#  Provoding additional TreeList-Behaviour                                 
#  (Renaming dialogues etc.)  and intantiating tree_list_g                    
#                                                                          
#  *********************************************************************** 


   package treelist_callbacks: (weak)  Treelist_Callbacks               # Treelist_Callbacks    is from   src/lib/tk/src/toolkit/tree-list-g.pkg
                 =
                 package {
                      Part_Ilk        = tree_obj::Part_Ilk;
                      Node_Info    = tree_obj::Node_Info;
                      Subnode_Info = tree_obj::Subnode_Info;
                      Path         = tree_obj::Path;

                     fun  content_label_action { path, was, cc } = 
                          uw::enter_line { title=>"enter label:",
                                       prompt=>"", default=>was,
                                       width=>15, cc };
                     fun to_str x = tree_obj::string_of_name 
                                       (tree_obj::path2name x)
                                            { mode => print::long,
                                             printdepth=>100,
                                             height=>NULL,
                                             width=>NULL };

                     fun  objtree_change_notifier { changed_at: Path } = 
                            (print ( "general change notifier at :"$
                                     (to_str changed_at) + "\n"));

                     fun  focus_change_notifier { changed_at: List( Path ) } = 
                            (print ( "notifier activated at :" + 
                                     (string::cat 
                                     (map to_str changed_at)) +
                                     "\n"));
                        
                     fun  open_close_notifier { is_open: Bool, 
                                               changed_at: List( Path ) } = 
                           (print ( "open/close notifier activated at :" + 
                                     (string::cat 
                                     (map to_str changed_at)) +
                                     "\n"));


                     fun  error_action          s = (uw::error "ERROR" );
                 };

   package clipboard = clipboard_g ( Part = Void -> List( tree_obj::Part_Ilk ); );

   package tree_list = 
                 tree_list_g (package s = package {
                                          package m  = tree_obj;
                                          package a  = treelist_callbacks;
                                           Objlist = Void -> 
                                                          List( tree_obj::Part_Ilk );
                                          package clipboard = clipboard;
                                        };);

#  *********************************************************************** 
#                                                                          
#  Wrapping TreeList in a window                                           
#                                                                          
#  *********************************************************************** 

   fun quit_button window
       =
       BUTTON {
           widget_id => make_widget_id(),
           packing_hints => [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
           traits => [TEXT "Quit",      CALLBACK (fn () = close_window window)],
           event_callbacks => []
       };
      
  

  fun testwin test
      = 
      {                                                                       my
          winid = make_window_id ();
      
           make_window {
               window_id  => winid, 

               traits => [   WINDOW_TITLE "Little Folder Tree",
                            WINDOW_ASPECT_RATIO_LIMITS (4, 3, 4, 3),
                             WIDE_HIGH_MIN (200, 200),
                             WIDE_HIGH_MAX (500, 400)], 
               subwidgets => PACKED [tree_list::create_canvas test,
                                 quit_button winid], 
               event_callbacks => [],
               init => (fn ()=> (); end )
           };
      };
        

#  *********************************************************************** 
#                                                                          
#  Building a hierarchical object "test"                                   
#                                                                          
#  *********************************************************************** 

   stipulate
       include tree_obj;
   herein
         
       # local name generation management:
                                                                                my
       ctr = REF (0);

       fun make_obj s
           =
           ((*ctr, REF (s)), ());

       fun make_fol s
           =
           REF (s);

       fun emb s
           =
           ((), s);
                                                                                my
       test = [ content (make_obj"blub"),
                folder (make_fol"bla",
                                 [content (make_obj"fgh"),
                                  folder (make_fol"g8tgku",[]),
                                  folder (make_fol"rtfu",[])
                                 ]
                        ),
                folder (make_fol"blerg",[])
              ];
   end;

    #  *********************************************************************** 
    #                                                                          
    #  Run the sucker !                                                        
    #                                                                          
    #  *********************************************************************** 

  fun go ()
      =
      start_tcl_and_trap_tcl_exceptions [ testwin test ];

};


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext