PreviousUpNext

15.4.1304  src/lib/tk/src/toolkit/tree-list-g.pkg

## tree-list-g.pkg
## (C) 1999, Albert Ludwigs Universität Freiburg
## Author: bu

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



# ***************************************************************************
# A hierarchical Listbox -- tree-lie browsing and selection.
# **************************************************************************



###                    "The essence of mathematics lies in its freedom."
###
###                                               -- Georg Cantor 



api Treelist_Callbacks {

          Part_Ilk;     #  SML-necessity since no HO-generics 
       eqtype Node_Info;    #  SML-necessity since no HO-generics 
          Subnode_Info; #  SML-necessity since no HO-generics 
          Path;         #  SML-necessity since no HO-generics 

        content_label_action:  
           { path: Path, was: String, cc: String -> Void } -> Void;
           # fired whenever a content label is activated. 
           # Should be a modal action.

        focus_change_notifier:  
           { changed_at: List( Path ) } -> Void;
           # fired whenever a folder label or a folder icon is modified; 
           # should be used if tree_list_g is nonmodally coupled over  
           # gui_state with a notepad.

        objtree_change_notifier :
           { changed_at: Path } -> Void;
           # fired whenever the tree-package (gui_state) has been modified -
           # e.g. as a consequence of an internal drag-drop.
           # Used for rehresh`s of other views.

        open_close_notifier:  
           { is_open: Bool, changed_at: List( Path ) } -> Void;
           # fired whenever a folder label or a folder icon is opened; 
           # can be used if internal tree is incrementally .

        error_action:           String -> Void;
           # fired whenever illegal drag-drop-operations are attempted. 
           # Should be a modal action.
   };


api Join {              #  Only there for stupid SML-reasons 

      package  m:   Ptree_Part_Class;                           # Ptree_Part_Class      is from   src/lib/tk/src/toolkit/tree_object_class.api
      package  a:   Treelist_Callbacks;                         # Treelist_Callbacks    is from   src/lib/tk/src/toolkit/tree-list-g.pkg
      package  clipboard:  Clipboard;                           # Clipboard             is from   src/lib/tk/src/toolkit/clipboard-g.pkg
      sharing    a::Part_Ilk     ==   m::Part_Ilk; 
      sharing    clipboard::Part ==   m::Cb_Objects; 
      sharing    a::Node_Info    ==   m::Node_Info;
      sharing    a::Subnode_Info ==   m::Subnode_Info;
      sharing    a::Path         ==   m::Path;
   };

generic package tree_list_g (package  s:  Join;)                # Join                  is from   src/lib/tk/src/toolkit/tree-list-g.pkg
: (weak)
api {
    Scale   = MICRO | MINI | DEMO;
    Config      = { height:      Ref( Int ),             #  Default 300 
                       width:      Ref( Int ),             #  Default 400 
                       scrollbars: Ref( tk::Scrollbars_At ),#  Default NOWHERE
                       no_icons:   Ref( Bool ),            # no icons used;
                                                        # default FALSE
                       std_icons:  Ref( Bool ),            # use icons speci-
                                                        # fied in M or use 
                                                        # std-icons; 
                                                        # default TRUE
                       scale_factor: Ref( Scale )          # scales display,
                                                        # default MICRO
                      };
    my_config:     Config;

    create_canvas:  List( s::m::Part_Ilk ) -> tk::Widget;

    upd_guistate:  s::m::Path -> List( s::m::Part_Ilk ) -> Void;
    get_guistate:  Void -> List( s::m::Part_Ilk );
    refresh:       s::m::Path -> Void;
    refresh_label: Void -> Void;

    get_selected:  Void -> List( s::m::Part_Ilk );
    set_selected:  List( s::m::Path ) -> Void;
}

{

    include s;
    include tk;
    include global_configuration;

  #  *********************************************************************** 
  #                                                                          
  #  Configuration ...                                                       
  #                                                                          
  #  *********************************************************************** 


     Scale = MICRO | MINI | DEMO;       #  According to icons / filer / * 

     Config
        =
        {   height:         Ref( Int ),             #  Default 300 
            width:         Ref( Int ),             #  Default 400 
            scrollbars:    Ref( tk::Scrollbars_At ),#  Default NOWHERE 
            no_icons:      Ref( Bool ),            /* no icons used;
                                                   default FALSE */
            std_icons:     Ref( Bool ),            #  Default TRUE 
            scale_factor:  Ref(  Scale )            /* scales display,
                                                   default 1 */  
        };
                                                                                  my
    my_config
        =
        {    height        => REF (300),
             width        => REF (400),
             scrollbars   => REF (tk::AT_RIGHT),
             no_icons     => REF FALSE,
             std_icons    => REF TRUE,
             scale_factor => REF MICRO
        };

    fun debugmsg msg
        =
        debug::print 11 ("tree_list_g: " + msg);
                                                                                my
    default_printmode
        =
        {   mode => print::long,
            printdepth => 100,
            height => NULL,
            width => NULL
        };  #  the value is temporary 

    fun name2string x
        =
        m::string_of_name (m::path2name x) default_printmode;


    fun scale_to_string MICRO => "micro";
       scale_to_string MINI  => "mini";
       scale_to_string DEMO  => "demo"; end;


  #  Some Display Parameters 

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

      <  in2  >    -
              *    ^
              *    | <hi
      <in1 >****** -   -
            *    *     ^
            * ** ****  |
            *    *     | <box_height
            ******     _
      <in3          >
            <    >box_width
     **************************************************************** */

                                                                                my
    box_height   = 9;                                                            my
    box_width    = 8;                                                            my
    box_w_middle = 4;                                                            my
    box_h_middle = 5;                                                            my
    icon_width   = 9; /* in realitaet 12 !!! */                                  my
    in1          = 4;                                                            my
    in2          = 9;                                                            my
    in3          = 12;                                                           my
    hi           = 9;

    # The crosshair for dragging an item:
                                                                             my
    drag_cursor = CURSOR (XCURSOR (make_cursor_name("fleur"), NULL));

    fun height n
        =
        coordinate (0, n * (hi+box_height));

  #  *********************************************************************** 
  #                                                                          
  #  The internal object-tree                                                
  #                                                                          
  #  *********************************************************************** 

  # The internal object tree contains not only the pure data-package
  # with labels, icons and object items, but also a decent abstraction of
  # the state of the canvas, i.e. which folders are displayed
  # open or closed ("is_open"), which ones are selected ("is_selct"), etc.
  #
  # For efficiency reasons, even more information is stored:
  # - namely hooks to redisplay functions for local labels
  # - and the CItems used in order to move substrees efficiently.
  #   (not yet implemented)
  #
  # However, there no real good reason for the fact, that I dicided to
  # implement obj_tree in its own in this class here instead of providing
  # a new instance of object_to_tree_object_g. Better patternmatch, and efficiency,
  # maybe. But the price is code duplicity for critical functions like update.


     Leaf_Type =   { lab:        (m::basic::Part_Ilk, m::Subnode_Info),
                        path:       m::Path,
                        icon:       Null_Or( Icon_Variety ), 
                        cids:       (Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id),
                        is_selct:   Ref( Bool ),
                        rd_hook:     Ref( Null_Or( Void_Callback ) )
                       };

     Folder_Type( A_obj_tree ) = 
                       { lab:        m::Node_Info,
                        path:       m::Path,
                        subtrees:   List( A_obj_tree ), 
                        icon:       Null_Or( Icon_Variety ), 
                        cids:       (Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id ,
                                    Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id),
                        is_open:    Ref( Bool ),
                        is_selct:   Ref( Bool ),
                        rd_hook:     Ref( Null_Or( Void_Callback ) ) };

     Obj_Tree = LEAF      Leaf_Type
                  | FOLDER    Folder_Type( Obj_Tree );

    fun get_folder (folder x) = x;
    fun get_leaf   (leaf x)   = x;

    fun fst (x, y) = x;
    fun snd (x, y) = y;

    fun convert_ft ( { lab, path, icon, cids, is_selct, rd_hook, ... } 
                  : Folder_Type( A_obj_tree )) = 
        { my (x1, x2, x3, _, _, _, _) = cids; 
                { lab, path, icon, 
                 cids=>(x1, x2, x3),
                 is_selct,
                 rd_hook  => rd_hook };
        };


    fun length []             => 0;
       length ((leaf _) . rrr)  => 1 + length rrr;
       length ((folder { is_open, subtrees, ... } ) . rrr) => 
               1 + (if *is_open  length subtrees; else 0;fi) + (length rrr); end; 

    fun relabel (path, _) obs = 
        { fun rel p [] => [];
               rel p (a as (leaf { lab, path, icon, cids,
                       is_selct, rd_hook } ) . rrr) => 
                       leaf { lab, path=>m::path_abs (list::reverse p, snd (m::path_rep path)), 
                            icon, cids, is_selct,
                            rd_hook }
                       . (rel p rrr);
               rel p (a as (aob as (folder { lab, path, subtrees, icon, cids,
                                           is_open, is_selct, rd_hook } )) . rrr) => 
                       folder { lab, path => m::path_abs (list::reverse p, NULL),
                              subtrees => rel (lab . p) subtrees,
                              icon, cids,
                              is_open, is_selct,
                              rd_hook  => REF NULL } 
                       . (rel p rrr); end; 
          rel (list::reverse path) obs; };

    exception WRONG_UPDATE;

    fun get_subtrees (folder { subtrees, ... } ) => subtrees;
       get_subtrees _ => raise exception WRONG_UPDATE; end;

    fun update clean path ob [] => [];
       update clean path ob x =>
        {   fun upd path [] => [];
                  #  search for leaf on leaf >>> 
                 upd ([], THE x) ((aob as (leaf { lab, ... } )) . rrr) => 
                      (case (m::basic::ord (x, fst lab))   
                        EQUAL => { clean aob; ob . rrr;};
                       _     => aob . (upd ([], THE x) rrr); esac);
                  #  search for leaf on fold >>> 
                 upd  ([], THE x) (aaa . rrr) => aaa . upd ([], THE x) rrr; 
                  #  replace folder by folder content >>> 
                 upd  ([x], NULL)((aob as (folder { lab, path, subtrees, icon, cids,
                                                 is_open, is_selct, rd_hook } )) . rrr)=> 
                      (case (m::ord_node (x, lab))   
                        EQUAL => { apply clean subtrees; 
                                  folder { lab, path,
                                         subtrees=>get_subtrees ob /* !!! */,
                                         icon, cids, is_open,
                                         is_selct, rd_hook } . rrr;};
                       _     => aob . (upd ([x], NULL) rrr); esac);
                  #  search for folder on leaf >>> 
                 upd  ([x], NULL) (aaa . rrr) => aaa . upd ([x], NULL) rrr;   
                  #  Descending in folder >>> 
                 upd  (x . rrr, hhh)((aob as (folder { lab, path, subtrees, icon, cids,
                                               is_open, is_selct, rd_hook } )) . rrr') =>
                      (case (m::ord_node (x, lab))   
                        EQUAL => (folder { lab, path,
                                  subtrees=>upd (rrr, hhh) subtrees,
                                  icon, cids, is_open,
                                  is_selct, rd_hook } . rrr');
                       _     => aob . (upd (x . rrr, hhh) rrr'); esac); 
                 upd (x . rrr, hhh) (aaa . rrr') => aaa . upd (x . rrr, hhh) rrr'; end;

         upd (m::path_rep path) x; }; end;

    exception WRONG_INSERT;

    fun insert path obs [] => raise exception WRONG_INSERT;
       insert path obs x =>
        {   fun ins path [] => [];
                  #  search for leaf on leaf >>> 
                 ins ([], THE x) ((aob as (leaf { lab, ... } )) . rrr) =>
                      (case (m::basic::ord (x, fst lab))   
                        EQUAL => (aob . (relabel (m::path_rep path) obs)@rrr);
                       _     =>  aob . (ins ([], THE x) rrr); esac);
                  #  search for leaf on fold >>> 
                 ins  ([], THE x) (aaa . rrr) => aaa . ins ([], THE x) rrr;
                  #  replace folder by folder content >>> 
                 ins  ([x], NULL)((aob as (folder { lab, path, subtrees, icon, cids,
                                                 is_open, is_selct, rd_hook } )) . rrr)=>
                      (case (m::ord_node (x, lab))   
                        EQUAL => (aob . (relabel (m::path_rep path) obs)@rrr);
                       _     => aob . (ins ([x], NULL) rrr); esac);
                  #  search for folder on leaf >>> 
                 ins  ([x], NULL) (aaa . rrr) => aaa . ins ([x], NULL) rrr;
                  #  Descending in folder >>> 
                 ins  (x . rrr, hhh)((aob as (folder { lab, path, subtrees, icon, cids,
                                               is_open, is_selct, rd_hook } )) . rrr') =>
                      (case (m::ord_node (x, lab))   
                        EQUAL => (folder { lab, path,
                                  subtrees=>ins (rrr, hhh) subtrees,
                                  icon, cids, is_open,
                                  is_selct, rd_hook } . rrr');
                       _     => aob . (ins (x . rrr, hhh) rrr'); esac);
                 ins (x . rrr, hhh) (aaa . rrr') => aaa . ins (x . rrr, hhh) rrr'; end;

         ins (m::path_rep path) x; }; end;

    fun is_open_at _ [] => FALSE;
       is_open_at (a . rrr) ((leaf _) . rrr') => is_open_at (a . rrr) (rrr');
       is_open_at [a] ((folder { lab, is_open, subtrees, ... } ) . rrr') =>
           if *is_open    
              case (m::ord_node (a, lab))   
                EQUAL => TRUE;
               _     => FALSE; esac;
           else is_open_at [a] (rrr');fi;
       is_open_at (a . rrr) ((folder { lab, is_open, subtrees, ... } ) . rrr') =>
           if *is_open    
              case (m::ord_node (a, lab))   
                EQUAL => is_open_at (rrr) (subtrees);
               _     => FALSE; esac;
           else is_open_at (a . rrr) (rrr');fi; end; 


    fun cids_of [] => [];
       cids_of((leaf { cids=>(aaa, bbb, ccc, dddd), ... } ) . rrr)  => aaa . bbb . ccc . dddd . (cids_of rrr);
       cids_of((folder { cids=>(aaa, bbb, ccc, dddd, eee', fff, ggg), subtrees, ... } ) . rrr)  => 
               aaa . bbb . ccc . dddd . eee' . fff . ggg . (cids_of rrr)@(cids_of subtrees); end;

  #  *********************************************************************** 
  #                                                                          
  #  Conversion ...                                                          
  #                                                                          
  #  *********************************************************************** 

    fun gen_cids1 () = (make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id());
    fun gen_cids2 () = (make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id(),
                        make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id());


                                                                                my
    texticon_id   = make_image_id ();                                               my
    foldericon_id = make_image_id ();


    fun text_icon  ()
        =
        FILE_IMAGE((tk::get_lib_path())$
                                  "/icons/treelist/"$ 
                                  (scale_to_string *my_config.scale_factor) $
                                  "/text.gif", 
                                  texticon_id);
    fun folder_icon ()
        =
        FILE_IMAGE((tk::get_lib_path())$
                                  "/icons/treelist/"$
                                  (scale_to_string *my_config.scale_factor) $
                                  "/folder.gif", 
                                  foldericon_id);

    fun obj2obj_tree0 p obj
        = 
        if (m::is_folder obj ) 
              { my (h, s)       = m::get_folder obj;
                  p           = h . p;
                folder { lab      => h,
                         path     => m::path_abs (list::reverse p, NULL),
                         subtrees => map (obj2obj_tree0 p) s,
                         icon     => if   *my_config.no_icons  NULL;
                                    else THE (folder_icon ());fi, 
                         cids     => gen_cids2 (),
                         is_open  => REF FALSE, is_selct => REF FALSE, 
                         rd_hook  => REF NULL };
              };           
        else
             leaf { lab  => m::get_content obj, 
                    path => m::path_abs (list::reverse p, THE (fst (m::get_content obj))),
                    icon => if   *my_config.no_icons   NULL; 
                            elif *my_config.std_icons  THE (text_icon ());
                            else                       THE (icons::get_microlined_variety (m::icon (m::part_type obj)));
                            fi, 
                    cids => gen_cids1 (),

                    is_selct => REF FALSE,
                    rd_hook  => REF NULL
                  };
        fi;

                                                                                my
    obj2obj_tree = obj2obj_tree0 [];

    fun obj_tree2obj (folder { lab, subtrees, ... } )
        => 
        m::folder
            (lab, map obj_tree2obj subtrees);

       obj_tree2obj (leaf { lab, ... } )
        =>
        m::content lab; end;


  #  *********************************************************************** 
  #                                                                          
  #  Display related dagwalk ...                                            
  #                                                                          
  #  *********************************************************************** 

    fun clear_sel [] => ();
       clear_sel((leaf { is_selct, rd_hook, ... } ) . rrr)  => 
                { if *is_selct  { is_selct:=FALSE; the *rd_hook ();};
                 fi;
                 clear_sel rrr;};
       clear_sel((folder { is_selct, rd_hook, subtrees, ... } ) . rrr)  => 
                { if *is_selct  { is_selct:=FALSE; the *rd_hook ();};
                 fi;
                 clear_sel subtrees;
                 clear_sel rrr;}; end;

    fun deselect [] => FALSE;
       deselect ((leaf { is_selct, ... } ) . rrr)  => 
                  ({ h = *is_selct;
                       r = deselect rrr;
                     is_selct:=FALSE; h or r; });
       deselect ((folder { is_selct, subtrees, ... } ) . rrr) => 
                  ({ h  = *is_selct;
                       r  = deselect rrr;
                       r' = deselect subtrees;
                     is_selct:=FALSE; h or r or r'; }); end;

    fun set_sel_range aaa tree =
        { mark_mode = REF (0); /* 0 = init, 1 = fill-to-mode,
                                      2 = fill-from-mode, 3 = delete-mode */
            fun mlr [] => ();
               mlr ((leaf { cids=>(_, _, ccc, _), is_selct, rd_hook, ... } ) . rrr)  =>
                    { case *mark_mode   
                          0 => if (aaa == ccc)   mark_mode:=1;
                                                 is_selct:=TRUE;
                                                 the *rd_hook ();
                               elif *is_selct  mark_mode:=2;
                               fi;

                         1 =>  if (aaa == ccc)   mark_mode:=3;
                                                 is_selct:=TRUE;
                                                 the *rd_hook();

                               elif *is_selct    mark_mode:=3; 

                               else              is_selct:=TRUE;
                                                 the *rd_hook ();
                               fi;

                         2 =>  if (aaa == ccc )   mark_mode:=3;
                                                 is_selct:=TRUE;
                                                 the *rd_hook ();

                               elif *is_selct    (); 

                               else              is_selct:=TRUE;
                                                 the *rd_hook ();
                               fi;

                         3 =>  if   not *is_selct  (); 

                               else                is_selct:=FALSE;
                                                   the *rd_hook ();
                               fi;
                     esac;
                     mlr rrr;};

               mlr((folder { cids=>(_, _, _, _, _, ccc, _), is_open, is_selct,
                            rd_hook, subtrees, ... } ) . rrr)  =>
                    { case *mark_mode   
                          0 => if (aaa == ccc )  mark_mode:=1;
                                                 is_selct:=TRUE;
                                                 the *rd_hook ();

                               elif *is_selct    mark_mode:=2;
                               fi;

                          1 => if (aaa == ccc )   mark_mode:=3;
                                                  is_selct:=TRUE;
                                                  the *rd_hook ();

                               elif *is_selct     mark_mode:=3; 
                               else               is_selct:=TRUE;
                                                  the *rd_hook ();
                               fi;

                          2 => if (aaa == ccc )   mark_mode:=3;
                                                  is_selct:=TRUE;
                                                  the *rd_hook ();

                               elif *is_selct     (); 

                               else               is_selct:=TRUE;
                                                  the *rd_hook ();
                               fi;

                          3 => if (not *is_selct) (); 

                               else               is_selct:=FALSE;
                                                  the *rd_hook ();
                               fi;
                     esac;

                     if *is_open  mlr subtrees; fi;

                     mlr rrr;
                   };
              end;
         mlr tree; };




  #  *********************************************************************** 
  #                                                                          
  #  State ...                                                               
  #                                                                          
  #  *********************************************************************** 



    gui_state = REF ([]: List( Obj_Tree ));
    global_drag_drop_namings = REF([]:List( Event_Callback ));
    refresh_hook = REF( NULL:  Null_Or( s::m::Path -> Void ) );

  /*
    fun get_selected0 () =  
        let fun get_sel [] = []
               |get_sel((leaf { is_selct, lab, path, ... } ) . rrr)  = 
                       (if *is_selct then [(path, m::Content lab)] 
                        else []) @ (get_sel rrr)
               |get_sel((folder { is_selct, subtrees, lab, path, ... } ) . rrr)  = 
                       (if *is_selct 
                        then [(path, m::Folder (lab, map obj_tree2obj subtrees))] 
                        else get_sel subtrees) 
                       @ (get_sel rrr)
        in  get_sel *gui_state end;

   */
    fun get_selected0 ()
        =
        get_sel *gui_state
        where
            fun get_sel []
                    =>
                    [];

                get_sel ((a as leaf { is_selct, lab, path, ... } ) . rrr)
                    =>
                    if *is_selct  [ (path, a) ];
                    else          [           ];
                    fi
                    @
                    (get_sel rrr);

                get_sel ((a as folder { is_selct, subtrees, lab, path, ... } ) . rrr)
                    =>
                    if *is_selct   [(path, a)];
                    else           get_sel subtrees;
                    fi
                    @
                    (get_sel rrr);
            end;
        end;


    fun get_selected ()
        =
        map (obj_tree2obj o snd) (get_selected0());

    fun rem_selected []
            =>
            [];

        rem_selected ((a as (leaf { is_selct, lab, path, ... } )) . rrr)
            =>
            (if *is_selct  []; else [a];fi) @ (rem_selected rrr);

        rem_selected ((a as (folder { lab, path, subtrees, icon, cids, is_open, is_selct, rd_hook } )) . rrr)
            => 
            if *is_selct

                 [];
            else
                 [ folder { lab,
                            path,
                            icon,
                            cids, 
                            is_open,
                            is_selct,
                            rd_hook,
                            subtrees => rem_selected subtrees
                          }
                 ];
            fi
            @
            (rem_selected rrr);
    end;

    fun set_selected _  = ();   #  NOT YET IMPLEMETED 


    fun get_guistate () =  map obj_tree2obj *gui_state;

  #  *********************************************************************** 
  #                                                                          
  #  Drag-drop-control  ...                                                  
  #                                                                          
  #  *********************************************************************** 

  fun debugmsg x = print x;
  fun debugmsg x = ();

     Dragmodetype = INTERNAL #  from tl-canvas to tl-canvas 
                          | EXTERNAL #  from tl-canvas to extern 
                          | IMPORT;   #  from extern to tl-canvas 
    dragmode     = REF (NULL: Null_Or( Dragmodetype )); #  NULL:  don't know 

    fun press_grab_button   path can_id (ev: Tk_Event)
        = 
               { dragmode := NULL;
                debugmsg "drag:";
                debugmsg (name2string path);
                 debugmsg "\n";
               add_trait can_id [drag_cursor];};

    fun release_grab_button path can_id (TK_EVENT(_, _, x, y, _, _))
        = 
               { debugmsg ("release:");
                debugmsg (name2string path);

                case *dragmode
                   
                    NULL         => debugmsg ": none \n";
                    THE IMPORT   => debugmsg ": Import \n";
                    THE INTERNAL => debugmsg ": internal \n";
                    THE EXTERNAL => debugmsg ": external \n";
                esac;

                #  Dragmode := NULL; 
                add_trait can_id [CURSOR (NO_CURSOR)];};

    fun grabbed_motion can_id _
        = 
               { dragmode := THE (internal);
                debugmsg "motion \n";};

    fun leave_canvas can_id ev = 
               { case *dragmode    
                  THE (internal) => dragmode := THE (external);
                 _              => dragmode := NULL; esac; 
                debugmsg "leave: \n";
                { objs = get_selected();
                    fun remove objs = (print "   export objects \n");
                  clipboard::put (m::cb_objects_abs (fn() => objs; end )) ev 
                           (fn() => remove (objs); end );  }
               ;};  

    fun import_objects to_path objs ev = 
        { print "   include objects \n";
         if (clipboard::is_empty ev ) ();
         else { objs = (m::cb_objects_rep (clipboard::get ev))();
                  fun do_it x = ();
                do_it objs; };fi;};

    fun move_objects path intern canvas_id =
        { print "   move objects \n";
         # internal objects have been dragged into can Id.
         # This resulted in storing the objects in the
         # internal_release_buffer.
         { objs    = map snd (get_selected0());
             state'  = rem_selected *gui_state;
             state'' = insert path objs state';
          # first: delete everything from screen (including 
            # stuff not in nustate)
            apply (fn x => (delete_canvas_item canvas_id x 
                       except CANVAS_ITEM _ => (); end ); end )
                (cids_of *gui_state);
            gui_state:=state'';
            the *refresh_hook (m::path_abs([], NULL));
            #  <<< removes again, but does not hurt <<< 
            a::objtree_change_notifier { changed_at=>m::path_abs([], NULL) };
            #  HACK! more precise: least common prefix of all paths . . . 
         };};


    #  enterCanvas atpath called_internally inCanvasId ... 
    fun enter_canvas path TRUE can_id ev
            => 
            {   debugmsg ("enter:1:");
                debugmsg (name2string path);

                case *dragmode
                   
                     THE EXTERNAL => (print (":ext \n"));
                     THE IMPORT   => { print (":imp \n");
                                     import_objects path TRUE ev;};
                     THE INTERNAL => { print (":int \n");
                                     move_objects path TRUE can_id;};
                     _            => print (":no \n");
               esac;

               dragmode := NULL;};                

       enter_canvas path FALSE can_id ev
           => 
           {   debugmsg ("enter:2:");
               debugmsg (name2string path);

               case *dragmode
                  
                    THE EXTERNAL => print (":ext \n");
                    THE INTERNAL => { print (":int \n");
                                     move_objects path FALSE can_id;};
                    THE IMPORT   => { print (":imp \n");
                                     import_objects path FALSE ev;};
                    _            => print (":no \n");
               esac;

               dragmode := NULL;
           };
    end;


    fun press_sel_button can_id _
        =
        ();


  #  *********************************************************************** 
  #                                                                          
  #  object-tree - drawing ...                                               
  #                                                                          
  #  *********************************************************************** 

    canvas_id = make_widget_id();

    fun cline (cid, c, cl, bl)
        =
        tk::CANVAS_LINE { citem_id=>cid, coords=>c, 
                                             traits=>cl, event_callbacks=>bl };

    # make_label:  generates a editable label for folders and basicobjects.
    # Lots of functionality for selection is provided - 
    # requiring additional information of the global tree, the surrounding
    # canvas-widget, the Canvas_Item_ID for delete-management.

    fun make_label is_selected rd_hook (gttxt, updtxt) pos aaa wid path
        = 
        # in order not to redraw the whole tree in case of a selection,
        # local redraw functions are provided here and stored in the 
        # obj_tree via the hooks. Thus, selection with global effects
        # can be implemented via evaluating the local redraw functions
        # on demand. This complicates the story a bit.

        { label_id  = make_widget_id();

            fun col_lab b
                =
                if b     BACKGROUND (*(colors::config.background_sel));
                        else BACKGROUND (*(colors::config.background));fi;

            fun relief_lab b
                =
                b ?? RELIEF SUNKEN
                  :: RELIEF FLAT;

            fun redraw _
                =
                (add_trait label_id [col_lab *is_selected,
                                            relief_lab *is_selected,
                                            TEXT (gttxt())]);

            fun hilite b _
                =
                if (not *is_selected)
                     add_trait label_id [col_lab (b)];
                fi;

            fun sel_action _
                =
                {   clear_sel *gui_state;
                    is_selected := TRUE; 
                    the *rd_hook ();
                };

            fun sel_range_action _
                =
                (set_sel_range aaa *gui_state);

            fun sel_group_elem_action _
                =
                { is_selected:= not *is_selected;
                                           the *rd_hook ();};

            fun activate _
                =
                {   updtxt (the *rd_hook);
                    redraw ()
                ;};

            fun lab b
                =
                LABEL { widget_id=>label_id,
                              packing_hints => [],
                              event_callbacks => [EVENT_CALLBACK (events::sel_elem_event(),
                                               fn XX => { sel_action XX;
                                                         #  Drag-code >>> 
                                                         press_grab_button 
                                                            path wid XX;}; end ),
                              /*CONFLICT with:
                                        EVENT_CALLBACK (Events::drag_event(), 
                                               pressGrabButton path wid), */                                 /* Problem:  This conflict-resolution above
                                 assumes a particular configuration
                                 of sel_elem_event() and drag_event() */
            EVENT_CALLBACK (events::drop_event(), release_grab_button path wid),
            EVENT_CALLBACK (events::dd_motion_event(), grabbed_motion wid),                               
                                        EVENT_CALLBACK (events::sel_range_event(),
                                               sel_range_action),
                                        EVENT_CALLBACK (events::sel_group_elem_event(),
                                               sel_group_elem_action),
                                        EVENT_CALLBACK (events::activate_event(),
                                               activate),

                                        EVENT_CALLBACK (ENTER, fn XX=>{ hilite TRUE XX;
                                                              enter_canvas path
                                                                FALSE wid XX;}; end ),
                                        EVENT_CALLBACK (LEAVE, hilite FALSE)
                                       ],
                              traits => [TEXT (gttxt ()),
                                       col_lab b, relief_lab b,
                                       FONT (tk::SANS_SERIF [tk::SMALL])]

                             };

            m = coordinate (icon_width + 4, 0);

            fun make_clab b
                =
                CANVAS_WIDGET {
                    citem_id => aaa,
                    coord => add_coordinates pos m, 
                    subwidgets => PACKED [lab b],
                    traits => [ANCHOR WEST], 
                    event_callbacks => []
                };
        
            rd_hook := THE redraw;
            make_clab *is_selected;
        };

    # mini-box: clickable symbol for folders; activation may result in opening
    # the folder by displaying the subtree. The symbol is drawn - not a gif.
    #    b: open/close status; pos: top-left start position of the drawing,
    #    aaa, bbb, ccc, dddd:  Canvas_Item_ID's stored here for systematic release,
    #    cmd: command for activation, path: info for activation and debugging:

    fun mini_box b pos (aaa, bbb, ccc, dddd) cmd path
        =
        {   fun cm _ = { a::open_close_notifier { is_open=> *b, changed_at => [path] };
                        #  Caution ! this may change the gui_state ! 
                        cmd();};
            bi = EVENT_CALLBACK (events::activate_event(), cm); 
           [CANVAS_BOX { citem_id=>aaa, coord1=>pos, 
                       coord2=>add_coordinates pos (coordinate (box_width, box_height)),
                       traits => [FILL_COLOR WHITE, OUTLINE BLACK], event_callbacks => [bi] },
            cline (bbb,[add_coordinates pos (coordinate (2, box_h_middle)),
                     add_coordinates pos (coordinate (box_width - 1, box_h_middle))],[],[bi]),
            cline (ccc,[add_coordinates pos (coordinate (box_width, box_h_middle)),
                     add_coordinates pos (coordinate (in3, box_h_middle))],[],[bi])] @
           (if *b  [];
            else [cline (dddd,[add_coordinates pos (coordinate (box_w_middle, 2)),
                           add_coordinates pos (coordinate (box_w_middle, box_width))],
                        [],[bi])];fi);
        };


    # icon_piece: clickable symbol for folders and basicobjects; 
    # activation may result in firing the activation fate. 
    # The symbol is a gif - either user-defined (i available), or standard.
    #    p: top-left start position of the drawing,
    #    path: info for activation and debugging

    fun icon_piece (THE i) citem_id p path hi wid
        =>
        { fun activate _
                =
                a::focus_change_notifier { changed_at => [path] }; 
         
            [   CANVAS_ICON {
                    citem_id,
                    coord    => add_coordinates p (add_coordinates (in3+1, box_h_middle) hi),
                    icon_variety => i,
                    traits  => [ANCHOR WEST],
                    event_callbacks => [    /* EVENT_CALLBACK (Events::sel_elem_event(), sel_action),
                                              EVENT_CALLBACK (Events::sel_range_event(), sel_range_action),
                                              EVENT_CALLBACK (Events::sel_group_elem_event(),
                                                            sel_group_elem_action),
                                            */
                                           EVENT_CALLBACK (events::drag_event(), press_grab_button path wid),
                                           EVENT_CALLBACK (events::drop_event(), release_grab_button path wid),
                                           EVENT_CALLBACK (events::activate_event(), activate),
                                           EVENT_CALLBACK (ENTER, enter_canvas path FALSE wid) 
                                      ]
                  }
            ];
         };

        icon_piece (NULL) citem_id p path hi wid => []; end;


    # folder_line: line in tree consisting of box, icon, and label (for folders).
    # All information from the context tree must be passed to the drawing 
    # functions of these subitems. 
    # The offset off produces a shift of the line level and a suitably prologued 
    # front vertex.

    fun folder_line is_open is_slct rdh icon p path 
                    off lab (aaa, bbb, ccc, dddd, eee', fff, ggg) cmd wid
        = 
        { p'  = add_coordinates p (coordinate (in1, 0));
            hi  = add_coordinates (coordinate (0, hi)) (height off);
            li  = cline (aaa, [p', add_coordinates p' hi],[],[]);
            p'' = add_coordinates p hi;
            p'''= add_coordinates p (add_coordinates (coordinate (in3, box_h_middle)) hi);
        
            li . mini_box is_open p'' (bbb, ccc, dddd, eee') cmd path @ 
            icon_piece icon ggg p path hi wid @ 
            [make_label is_slct rdh lab p''' fff wid path]; 
        }; 

    # object_line: line in tree consisting of front vertrex, icon, and label 
    # (for basicobjects).
    # All information from the context tree must be passed to the drawing 
    # functions of these subitems.  
    # The offset off produces a shift of the line level and a suitably 
    # prolongued front vertex.

    fun object_line is_open is_slct rdh icon p path off lab (aaa, bbb, ccc, dddd) wid
        = 
        { p'    = add_coordinates p (coordinate (in1, 0));
            hi    = add_coordinates (coordinate (0, hi)) (height off);
            hi_tot= add_coordinates hi (coordinate (0, box_height));
            p''   = add_coordinates (add_coordinates p' hi) 
                                 (coordinate (0, box_h_middle));
            p'''  = if is_open  add_coordinates p' hi_tot; else p'';fi;
            p'''' = add_coordinates p (add_coordinates (coordinate (in3, box_h_middle)) hi);
        
            [cline (aaa, [p', p'''],[],[]),
             cline (bbb, [p'', add_coordinates p'' (coordinate (in3-in1, 0))],[],[])] @
             icon_piece icon dddd p path hi wid @
            [make_label is_slct rdh lab p'''' ccc wid path];
        };

    fun diag1 maxcl p lab ccc
        =
        { s = m::basic::string_of_name (m::basic::name_of lab) maxcl;
            fun upd1 s lab ccc= (fn s' => if (s==s' ) (); 
                                        else { m::basic::rename s' lab; ccc();};fi; end ); 
        
            a::content_label_action {
                path => p,
                was => s,
                cc => upd1 s lab ccc
            };
        };

    fun diag2 maxcl p lab ccc
        = 
        { s = m::string_of_name_node lab maxcl;
            fun upd2 s lab ccc= (fn s' => if (s==s' ) (); 
                                        else { m::rename_node s' lab; ccc();};fi; end ); 
        
            a::content_label_action {
                path=>p,
                was=>s,
                cc=>upd2 s lab ccc
            };
        };

    #  placing a tree into a canvas - with all jingles . . . 
    fun place_tree pos wid tree
        = 
        { cl         = { mode=>print::short, printdepth=>1, 
                              height=>NULL, width=>NULL };          #  HACK ! 
            fun str1  lab  = (fn () => m::basic::string_of_name 
                                          (m::basic::name_of lab) cl; end );
            fun str2  lab  = (fn () => m::string_of_name_node lab cl; end );
            fun shift n p  = add_coordinates p (height n); 
            fun indent  p  = add_coordinates p (coordinate (in3 + (icon_width div 2) - 1, 0));
            fun beh1 p lab = (str1 lab, diag1 cl p lab);
            fun beh2 p lab = (str2 lab, diag2 cl p lab);
            fun open_cont p lt is_open_ref _ = 
                       { is_open_ref := not *is_open_ref;
                        (.is_selct (get_folder lt)) := deselect [lt];
                        refresh (m::path_rep p);};
            #  the core of the display algorithm: 
            fun pt p off ([]) => [];
               pt p off ((leaf { lab, icon, cids, is_selct, rd_hook, path, ... } ) . rrr)  => 
                        (object_line (not (null rrr)) is_selct rd_hook icon p path
                                      off (beh1 path (fst lab)) cids wid) @ 
                        (pt (shift (1+off) p) 0 rrr); 
               pt p off ((lt as folder { icon, lab, cids, is_selct,
                                        rd_hook, is_open, subtrees, path, ... } ) . rrr)=> 
                       if *is_open  
                            (folder_line is_open is_selct rd_hook icon p path
                                         off (beh2 path lab) 
                                         cids (open_cont path lt is_open) wid) @
                            (pt (indent (shift 1 p)) (0) subtrees) @
                            (pt (shift (1+off) p) (length subtrees) rrr);
                       else (folder_line is_open is_selct rd_hook icon p path
                                         off (beh2 path lab) 
                                         cids (open_cont path lt is_open) wid) @
                            (pt (shift (1+off) p) 0 rrr);fi; end;

       
           debugmsg "place_tree ... "; pt pos 0 tree;
       }

    also
    fun refresh ([], _)
        => 
        { apply (fn x => (delete_canvas_item canvas_id x
                       except CANVAS_ITEM _ => (); end ); end ) 
             (cids_of *gui_state);
         #  gui_state := map (obj2obj_tree o obj_tree2obj) *gui_state; 
         apply (add_canvas_item canvas_id) 
             (place_tree (coordinate (10, 15)) canvas_id *gui_state)
        ;};

      refresh (p, NULL) =>  refresh ([], NULL); end;  
         /* correct, but inefficient. This refresh is used for internal
            use - i.e. redisplay for open-close-actions. */

    fun refresh_o ([], xxx')
            =>
            refresh ([], xxx');

        refresh_o (p, NULL)
            =>
            if (is_open_at p *gui_state)
                                                # Very simple heuristic 
                                                # to keep it smooth.
                  print "refresh full\n";
                  refresh ([], NULL);
            else
                 (print "refresh optimized\n");
            fi;
    end;

    refresh   =   (fn p =  refresh   (m::path_rep p));
    refresh_o =   (fn p =  refresh_o (m::path_rep p));


     fun refresh_label ()
         = 
         rl *gui_state
         where

            fun rl [] => ();

                rl ((leaf { rd_hook, ... } ) . rrr)
                    =>
                    {   the *rd_hook ();
                        rl rrr;
                    };

                rl ((folder { rd_hook, is_open, subtrees, ... } ) . rrr)
                    =>
                    {   the *rd_hook ();
                        if *is_open  rl subtrees; fi;
                        rl rrr;
                    };
            end;
        end;



     fun redisplay ()
         = 
        {   apply
                (fn x = (delete_canvas_item canvas_id x 
                       except CANVAS_ITEM _ = ())) 
                (cids_of *gui_state); 

           #  <<< better: scratch everything from complete canvas ...
           #
           gui_state
               :=
               map (obj2obj_tree o obj_tree2obj)
                   *gui_state;

           apply
               (add_canvas_item canvas_id) 
               (place_tree (coordinate (10, 15)) canvas_id *gui_state);
        };

  #  *********************************************************************** 
  #                                                                          
  #  update access to gui_state ...                                          
  #                                                                          
  #  *********************************************************************** 

    /* merge maintains the internal data-package,
       as long as there are no differences to the
       analogous external package.  Maintaining
       means open/Close, cids, etc. Path is patched.
    */
    fun merge p rrr [] => rrr;
        merge p [] rrr => map (obj2obj_tree0 p) rrr;
        merge p ((aob as (leaf { lab, ... } )) . rrr) (a . rrr') => 
               if (m::is_folder a ) ((obj2obj_tree0 p a) . (merge p rrr rrr'));
               else (case (m::basic::ord (fst (m::get_content a), fst lab))   
                       EQUAL => aob . (merge p rrr rrr');
                      _ => (obj2obj_tree0 p a) . (merge p rrr rrr'); esac);fi;

        merge p ((aob as (folder { lab, path, subtrees, icon, cids,
                                is_open, is_selct, rd_hook } )) . rrr) (a . rrr') =>
               if (m::is_folder a ) 
                    { my (n, rrr'') = m::get_folder a;
                      (case (m::ord_node (n, lab))   
                           EQUAL => ((folder { lab, path=>m::path_abs (list::reverse p, NULL),
                                          subtrees => merge (n . p) subtrees rrr'',
                                          icon, cids, is_open,
                                          is_selct, rd_hook } ) 
                                    . (merge p rrr rrr'));
                          _ => (obj2obj_tree0 p a) . (merge p rrr rrr'); esac);
                    };
               else (obj2obj_tree0 p a) . (merge p rrr rrr');fi;
    end;






    fun upd_guistate (p as ([], NULL)) obs
        =>
                     { apply (fn x => (delete_canvas_item canvas_id x
                           except CANVAS_ITEM _ => (); end ); end ) 
                          (cids_of *gui_state);
                      gui_state:= map obj2obj_tree obs;};  
       upd_guistate (p as (m, _)) [ob] =>
                      { fun clean dob = apply (fn x => (delete_canvas_item canvas_id x
                                                       except CANVAS_ITEM _ => (); end ); end ) 
                                             (cids_of [dob]); 
                        gui_state:=update clean (m::path_abs p) 
                                             (obj2obj_tree0 (tl (reverse m)) ob) 
                                             *gui_state;
                      };
    end;

    upd_guistate = fn p => fn obs =>  upd_guistate (m::path_rep p) obs; end; end ;  


    fun canvas_event_callbacks can_id
        =  
          [ EVENT_CALLBACK (events::drag_event(), fn _ => { clear_sel *gui_state;
                                                 dragmode:=NULL;
                                                 refresh_label ();}; end ),
            EVENT_CALLBACK (events::drop_event(), release_grab_button (m::path_abs([], NULL)) can_id),
            EVENT_CALLBACK (events::dd_motion_event(), grabbed_motion can_id),
            EVENT_CALLBACK (events::dd_leave_event(), leave_canvas can_id),
            #  EVENT_CALLBACK (Events::dd_enter_event(), enterCanvas([], NULL)TRUE canId), 
            #  <<< seems to have no effect . . . 
            #  EVENT_CALLBACK (ENTER, enterCanvas ([], NULL) FALSE canId) 
            EVENT_CALLBACK (LEAVE, leave_canvas can_id) 
          ];

  /* Events::drag_event()      = BUTTON_PRESS    (THE 1) 
     Events::drop_event()      = BUTTON_RELEASE  (THE 1) 
     Events::dd_motion_event() = MODIFIER_BUTTON (1, MOTION) 
     Events::dd_leave_event()  = MODIFIER_BUTTON (1, LEAVE)
     Events::dd_enter_event()  = MODIFIER_BUTTON (1, ENTER)   
   */

    fun create_canvas obj
        =
        { my () = { gui_state := map obj2obj_tree obj;
                      global_drag_drop_namings := canvas_event_callbacks canvas_id;
                      refresh_hook:=THE (refresh);};
        
            CANVAS {
                widget_id       => canvas_id,
                scrollbars      => *my_config.scrollbars,
                citems          => (place_tree (coordinate (10, 15))canvas_id *gui_state),

                packing_hints   => [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
                event_callbacks => *global_drag_drop_namings,

                traits          => [   HEIGHT *my_config.height, 
                                      WIDTH *my_config.width, 
                                      RELIEF GROOVE, 
                                      BACKGROUND (*(colors::config.background))
                                  ]

            };
        };

                                                                                my
    refresh = refresh_o;   #  This optimized refresh is exported ... 

};


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext