PreviousUpNext

15.4.1286  src/lib/tk/src/toolkit/object-to-tree-object-g.pkg

## object-to-tree-object-g.pkg
## (C) 1999, Albert-Ludwigs-Uni Freiburg
## Author: bu

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



# ***************************************************************************
# Unified Object Interface
#
# This class macro produces out of an Part_Class-class 
# a (standard) Tree_Part_Class-class, i.e. in particular
# also another Part_Class-class. It provides
# standard notions for paths and path-operations on the
# generated TREE_OBJECT's. 
#
# These operations require that the application will assure
# uniqueness of object-names and node-info's.
# There are two fundamentally different way's to assure this:
# - update and rename must assure this via postconditions
# - internally in node-infos and names, unique key's are
#   generated.



###               "No matter how correct a mathematical theorem
###                may appear to be, one ought never to be satisfied
###                that there was not something imperfect about it
###                until it also gives the impression of being beautiful."
###
###                                          -- George Boole



generic package object_to_tree_object_g (package n: Folder_Info                 # Folder_Info   is from   src/lib/tk/src/toolkit/tree_object_class.api
                            also 
                                m: Part_Class ;)                # Part_Class    is from   src/lib/tk/src/toolkit/object_class.api

: (weak)  Ptree_Part_Class                                      # Ptree_Part_Class      is from   src/lib/tk/src/toolkit/tree_object_class.api
# where nodeinfo = N.nodeinfo and basic_object = M.Part_Ilk and 
#  mlabel = M.label

#  We have: obj_to_treeobj (aaa, bbb) : Part_Class  

{

    include print;

    package basic = m;

     Node_Info = n::Node_Info;
     Subnode_Info = n::Subnode_Info;

     Part_Ilk = CONTENT  (basic::Part_Ilk, Subnode_Info)
                  | FOLDER   (n::Node_Info, List( Part_Ilk ));

     Cb_Objects = Void -> List( Part_Ilk );

    fun  cb_objects_abs x = x;
    fun  cb_objects_rep x = x;

    fun is_folder   (folder x) => TRUE;
       is_folder   _          => FALSE; end;

    fun get_content (content x) = x;
    fun get_folder  (folder x) = x;

     Path = (List( n::Node_Info ), Null_Or( m::Part_Ilk ));

    fun  path_rep x = x;
    fun  path_abs x = x;
     Name = Path;

    fun  name2path x = x; 
    fun  path2name x = x;  

    fun  path_of (p, _) = p;

    fun  base_of (_, b) = the b;

    Part_Type = LEAF_T  m::Part_Type 
              | FOLDER_T;

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

    fun lex_ord ord ([],[]) => EQUAL;
        lex_ord ord ([], s)  => LESS;
        lex_ord ord (s,[])  => GREATER;
        lex_ord ord (a . s, a' . s')  => 
           (case (ord (a, a'))   
              LESS => LESS;
            GREATER => GREATER;
            EQUAL => lex_ord ord (s, s'); esac);
    end;

    fun ord (content a, content b)  => m::ord (fst a, fst b);
        ord (content a, folder b)   => LESS;
        ord (folder b, content a)   => GREATER;
        ord (folder (a, s), folder (b, s')) => 
          case (n::ord_node (a, b))   
             LESS => LESS;
            GREATER => GREATER;
            EQUAL => lex_ord ord (s, s'); esac;
    end;

    fun name_of (content (a, _)) => ([], THE (a));
        name_of (folder (a, s)) => ([a], NULL);
    end;



    fun rename s (content a) => m::rename s (fst a);
        rename s (folder (a, s)) => n::rename_node s a;
    end;

    fun reset_name (content a) => m::reset_name (fst a);
        reset_name (folder (a, s)) => n::reset_name_node a;
    end;

    separator = "/";

    #  treatment of printdepth and margin incorrect !!! 
    fun mgs m
        =
        fn (a, b) =  separator + (n::string_of_name_node a m) + b;

    fun string_of_path p (m as { mode, printdepth, height, width }: print::Format)
        = 
        {   m' = { mode,
                   printdepth => 0,                     # Print from scratch.
                   height => THE 1,                     # No internal breaking.
                   width  => NULL: Null_Or( Int )       # Unbounded.
                 };

            fun string_of ([],  THE l) => m::string_of_name (m::name_of l) m';
                string_of (rrr, THE l) => (fold_backward (mgs m') "" rrr) + separator +
                                           (m::string_of_name (m::name_of l) m');
                string_of ([],  NULL ) => ""; #  ??? 
                string_of ([a], NULL ) => (n::string_of_name_node a m')
                                           + case mode

                                                  short => "";
                                                  _     => "";
                                             esac;

                string_of (a . rrr, NULL)  => (fold_backward (mgs m') 
                                              (n::string_of_name_node a m')(rrr))
                                           + case mode
                                                  short => "";  # XXX BUGGO FIXME um...???
                                                  _     => "";
                                             esac;
            end;

            fun blk len txt
                =
                if (size txt > len)

                     substring (txt, 0, len) . 
                                     blk len (substring (txt, len,
                                               size (txt)-len));
                else
                     [txt];
                fi;

            fun block len txt
                =
                {   tt = blk len txt; 

                    fold_forward (fn (a, b) = b + "\n" + a)
                                         (hd tt)(tl tt); 
                };

            fun ht len txt
                =
                ((size txt) div len) + 1;

          case (height, width)

               (NULL, NULL)   => string_of p;    #  printing unbounded 
               (THE k, NULL)  => string_of p;    #  unrealistic case   
               (NULL, THE k)  => block k (string_of p);
                                             #  printing unbounded height 
               (THE l, THE k) => if (ht k (string_of p) <= l)
                                      block k (string_of p); 
                                 else substring (string_of p, 0, k - 3) + "...";
                                 fi;
          esac;  
                                #  printing shortened - somewhat panicking 

      };

    string_of_name = string_of_path;


    fun part_type (content x) => leaf_t (m::part_type (fst x));
       part_type (folder (a, _)) => folder_t; end;

    fun is_folder_type folder_t => TRUE; 
       is_folder_type _       => FALSE; end;

    fun get_content_type (leaf_t x) = x;
    fun content_type (x) = leaf_t x;

    fun folder_icon ()= icons::get_icon
                             ((tk::get_lib_path()) +
                               "/icons/gengui/",  
                                                 /* HACK !!! This is not
                                                    config-dependent XXX BUGGO FIXME */
                               "folder.gif");

    fun icon (leaf_t x) => m::icon x;
       icon (folder_t) => folder_icon(); end;/* INEFFICIENT ! ! ! leads to
                                         reload of the icon whenever
                                         drag on folder dragged... */

    string_of_name_node = n::string_of_name_node;
    rename_node = n::rename_node;
    reset_name_node = n::reset_name_node;
    ord_node = n::ord_node;

    fun get_path p a b  = 
        (case (ord (a, b))   
          EQUAL => [(reverse p, if (is_folder b ) NULL; 
                           else THE (fst (get_content b));fi)];
         _     => (if (not (is_folder a) ) [];
                    else { my (n, s) = get_folder a;
                             fun f a = get_path (n . p) a b;
                           list::cat (map f s); };fi); esac

        );

    get_path  = get_path [];

    fun ord_path ((p, mmm), (p', mmm'))
        = 
        case (lex_ord ord_node (p, p'))   
                EQUAL => (case mmm   
                            NULL => (case mmm'    
                                         NULL => EQUAL;
                                        THE _ => LESS; esac);
                           THE xxx => (case mmm'    
                                         NULL => GREATER;
                                        THE xxx' => m::ord (xxx, xxx'); esac); esac);
               xxx => xxx; esac;


    fun  is_prefix (([], NULL), (p, mmm'))         => TRUE;
        is_prefix (([], THE xxx), ([], THE (xxx')))=> (m::ord (xxx, xxx') == EQUAL);
        is_prefix (([], THE xxx), _)            => FALSE;
        is_prefix ((a . p, mmm), ([], mmm'))         => FALSE;
        is_prefix ((a . p, mmm), (a' . p', mmm'))     => 
                  case (ord_node (a, a'))   
                     EQUAL => is_prefix ((p, mmm), (p', mmm'));
                    xxx     => FALSE; esac; end;


    fun join_path ((p1, NULL), (p2, rrr)) = (p1@p2, rrr);

    exception INCONSIST_PATH;

    /* one could imagine a more liberal version (which is
       even easier to implement), that yields the *list of objects*
       if path-id's are not unique. I chose this more strict
       version for efficiency reasons */
    fun select_from_path (obj . rrr) ([a], NULL) => 
              if (is_folder obj ) 
                 case (ord_node (a, fst (get_folder obj)))   
                   EQUAL => obj;
                  _ => select_from_path rrr ([a], NULL); esac;
              else select_from_path rrr ([a], NULL);fi;
       select_from_path (obj . rrr) ([], THE a)=>
              if (is_folder obj ) select_from_path rrr ([], THE a);
              else (case (m::ord (a, fst (get_content obj)))   
                     EQUAL => obj;
                    _     => select_from_path rrr ([], THE a); esac);fi;
       select_from_path (obj . rrr) (a . rrr', r)=> 
              if (not (is_folder obj) ) select_from_path rrr (a . rrr', r);
              else { my (n, s) = get_folder obj;
                     case (ord_node (a, n))   
                         EQUAL => select_from_path s (rrr', r); 
                        _     => select_from_path rrr (a . rrr', r); esac;
                   };fi;
       select_from_path _ _ => raise exception INCONSIST_PATH;
    end;


   fun update objs path xxx = 
    # update is very liberal - it allows none or multiple
    # replacements in cases of ambiguities
    # potential improvements: other map' (only first replacement)
    #                           working inherently on lists ...
        { fun upd path [] => raise exception INCONSIST_PATH;
               upd ([], THE x) (content (bob, h) . rrr) => 
                    #  search for leaf on leaf 
                    (case (m::ord (x, bob))   
                      EQUAL => xxx@rrr;
                      _    => (content (bob, h) . upd ([], THE x) rrr); esac);
               upd ([], THE x) (aaa . rrr) => aaa . upd ([], THE x) rrr;
                    #  search for leaf on folder 
               upd ([x], NULL) (folder (n, s) . rrr) =>
                    (case (ord_node (x, n))   
                       EQUAL => xxx@rrr;
                      _     => (folder (n, s) . upd ([x], NULL) rrr); esac);
               upd ([x], NULL) (aaa . rrr) => aaa . upd ([x], NULL) rrr;
               upd (x . rrr, hhh) (folder (n, s) . rrr') => 
                    (case (ord_node (x, n))   
                       EQUAL => folder (n, upd (rrr, hhh) s) . rrr';
                      _     => folder (n, s) . upd (x . rrr, hhh) rrr'; esac);
               upd (x . rrr, hhh) (aaa . rrr') => aaa . upd (x . rrr, hhh) (rrr'); end;

          upd path objs; };


    fun remove_at_path objs path
        =
        update objs path [];

    fun update_at_path objs path repojb
        =
        update objs path [repojb];

};
   
#   fields (fn x = '/')  translate ... 
          
     

     

      
     


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext