PreviousUpNext

15.4.1271  src/lib/tk/src/text_item.pkg

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

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

   Project: sml/Tk: an Tk Toolkit for sml
   Author: Stefan Westmeier, University of Bremen

  $Date: 2001/03/30 13:38:58 $
  $Revision: 3.0 $

   Purpose of this file: Functions related to Text Widget Annotations

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

package   text_item
: (weak)  Text_Item                     # Text_Item     is from   src/lib/tk/src/text_item.api
{

#    nonfix prefix;


    stipulate

        include basic_tk_types;
        include basic_utilities;

    herein

        exception TEXT_ITEM  String;


        Widget_Pack_Fun = Bool -> Tcl_Path -> Int_Path -> Null_Or( Bool ) -> Widget ->
                             String;

        Widget_Add_Fun  = List( Widget ) -> Widget     -> Widget_Path           -> List( Widget );
        Widget_Del_Fun  = List( Widget ) -> Widget_Id  -> Widget_Path           -> List( Widget );
        Widget_Upd_Fun  = List( Widget ) -> Widget_Id  -> Widget_Path -> Widget -> List( Widget );

        Widget_Del_Func = Widget_Id -> Void;
        Widget_Add_Func = Window_Id -> Widget_Path -> Widget -> Void;


        fun sel_text_wid_wid_id (TEXT_WIDGET { widget_id, ... } )
                =>
                widget_id;

            sel_text_wid_wid_id _      
                => 
                raise exception WIDGET "text_item::selTextWidWidId applied to non-Text Widget";
        end;

        fun get_text_widget_scrollbars (TEXT_WIDGET { scrollbars, ... } )
                =>
                scrollbars;

            get_text_widget_scrollbars _ 
                =>
                raise exception WIDGET "text_item::get_text_widget_scrollbars applied to non-Text Widget";
        end;

        fun get_text_widget_livetext (TEXT_WIDGET { live_text=>a, ... } )
                =>
                a;

            get_text_widget_livetext _ 
                =>
                raise exception WIDGET "text_item::get_text_widget_text applied to non-Text Widget";
        end;

        fun sel_text_wid_pack (TEXT_WIDGET { packing_hints, ... } )
                =>
                packing_hints;

            sel_text_wid_pack _
                =>
                raise exception WIDGET "text_item::selTextWidPack applied to non-Text Widget";
        end;

        fun sel_text_wid_configure (TEXT_WIDGET { traits, ... } )
                =>
                traits;

            sel_text_wid_configure _
                =>
                raise exception WIDGET "text_item::selTextWidConfigure applied to non-Text Widget";
        end;

        fun sel_text_wid_naming (TEXT_WIDGET { event_callbacks, ... } )
                =>
                event_callbacks;

            sel_text_wid_naming _ 
                =>
                raise exception WIDGET "text_item::selTextWidNaming applied to non-Text Widget";
        end;



        fun upd_text_wid_wid_id (TEXT_WIDGET { scrollbars, live_text,
                                     packing_hints, traits, event_callbacks, ... } ) wid
                => 
                TEXT_WIDGET { widget_id=>wid, scrollbars, live_text, 
                        packing_hints, traits, event_callbacks };

            upd_text_wid_wid_id _ _
                => 
                raise exception WIDGET "text_item::updTextWidWidId applied to non-Text Widget";
        end;

        fun update_text_widget_scrollbars (TEXT_WIDGET { widget_id=>wid, live_text=>at, packing_hints=>p,
                                          traits=>c, event_callbacks=>b, ... } ) st
                => 
                TEXT_WIDGET { widget_id=>wid, live_text=>at, packing_hints=>p,
                        traits=>c, event_callbacks=>b, scrollbars=>st };

            update_text_widget_scrollbars _ _
                => 
                raise exception WIDGET "text_item::update_text_widget_scrollbars applied to non-Text Widget";
        end;

        fun upd_text_wid_anno_text (TEXT_WIDGET { widget_id=>wid, scrollbars=>st, packing_hints=>p,
                                        traits=>c, event_callbacks=>b, ... } ) at
                => 
                TEXT_WIDGET { widget_id=>wid, scrollbars=>st, packing_hints=>p,
                                        traits=>c, event_callbacks=>b, live_text=>at };

            upd_text_wid_anno_text _ _
                => 
                raise exception WIDGET "text_item::updTextWidAnnoText applied to non-Text Widget";
        end;

        fun upd_text_wid_pack (TEXT_WIDGET { widget_id, scrollbars=>st, live_text=>at, traits=>c,
                                    event_callbacks=>b, ... } ) p
                => 
                TEXT_WIDGET { widget_id, scrollbars=>st, live_text=>at, traits=>c,
                        event_callbacks=>b, packing_hints=>p };

            upd_text_wid_pack _ _
                => 
                raise exception WIDGET "text_item::updTextWidPack applied to non-Text Widget";
        end;

        fun upd_text_wid_configure (TEXT_WIDGET { widget_id=>wid, scrollbars=>st, live_text=>at,
                                         packing_hints=>p, event_callbacks=>b, ... } ) c
                => 
                TEXT_WIDGET { widget_id=>wid, scrollbars=>st, live_text=>at,
                                         packing_hints=>p, event_callbacks=>b, traits=>c };

            upd_text_wid_configure _ _
                => 
                raise exception WIDGET "text_item::updTextWidConfigure applied to non-Text Widget";
        end;

        fun upd_text_wid_naming (TEXT_WIDGET { widget_id=>wid, scrollbars=>st, live_text=>at,
                                       packing_hints=>p, traits=>c, ... } ) b
                => 
                TEXT_WIDGET { widget_id=>wid, scrollbars=>st, live_text=>at,
                                       packing_hints=>p, traits=>c, event_callbacks=>b };

            upd_text_wid_naming _ _
                => 
                raise exception WIDGET "text_item::updTextWidNaming applied to non-Text Widget";
        end;

        fun sel_annotation_type (TEXT_ITEM_TAG _)    => TEXT_ITEM_TAG_TYPE;
            sel_annotation_type (TEXT_ITEM_WIDGET _) => TEXT_ITEM_WIDGET_TYPE;
        end;

        fun get_text_item_id (TEXT_ITEM_TAG { text_item_id=>tn, ... } )          => tn;
           get_text_item_id (TEXT_ITEM_WIDGET { text_item_id=>tn, ... } ) => tn; end;

        fun sel_annotation_configure (TEXT_ITEM_TAG { traits, ... } )    => traits;
           sel_annotation_configure (TEXT_ITEM_WIDGET { traits, ... } ) => traits; end;

        fun sel_annotation_naming (TEXT_ITEM_TAG { event_callbacks, ... } )
                =>
                event_callbacks;

            sel_annotation_naming  _
                =>
                raise exception TEXT_ITEM ("text_item::selAnnotationNaming applied to non TEXT_ITEM_TAG");
        end;

        fun get_text_item_marks (TEXT_ITEM_TAG    { marks, ... } ) =>  marks;
            get_text_item_marks (TEXT_ITEM_WIDGET { mark,  ... } ) =>  [(mark, mark)];
        end;

        fun get_text_widget_subwidgets (TEXT_ITEM_WIDGET { subwidgets, ... } )
                =>
                get_raw_widgets subwidgets;

            get_text_widget_subwidgets _
                =>
                raise exception TEXT_ITEM ("Annotataion::get_text_widget_subwidgets applied to non TEXT_ITEM_WIDGET");
        end;

        fun is_annotation_grid (TEXT_ITEM_WIDGET { subwidgets, ... } )
                =>
                case subwidgets
                    PACKED _ => FALSE;
                    _        => TRUE;
                esac;

            is_annotation_grid _
                =>
                raise exception TEXT_ITEM "text_item::is_gridded applied to non TEXT_ITEM_WIDGET";
        end;

        fun upd_annotation_configure (TEXT_ITEM_WIDGET { text_item_id=>tn, mark=>i, subwidgets=>wids,
                                             event_callbacks=>b, ... } ) c
                => 
                TEXT_ITEM_WIDGET { text_item_id=>tn, mark=>i, subwidgets=>wids,
                                             traits=>c, event_callbacks=>b };

            upd_annotation_configure (TEXT_ITEM_TAG { text_item_id=>tn, marks=>i, event_callbacks=>b, ... } ) c
                =>
                TEXT_ITEM_TAG { text_item_id=>tn, marks=>i, event_callbacks=>b, traits=>c };
        end;

        fun upd_annotation_naming (TEXT_ITEM_WIDGET { text_item_id=>tn, mark=>i, subwidgets=>wids,
                                           traits=>c, ... } ) b
                => 
                TEXT_ITEM_WIDGET { text_item_id=>tn, mark=>i, subwidgets=>wids,
                                           traits=>c, event_callbacks=>b };
            upd_annotation_naming (TEXT_ITEM_TAG { text_item_id=>tn, marks=>i, traits=>c, ... } ) b
                =>
                TEXT_ITEM_TAG { text_item_id=>tn, marks=>i, traits=>c, event_callbacks=>b };
        end;

        fun update_text_item_subwidgets (TEXT_ITEM_WIDGET { text_item_id=>tn, mark=>i, traits=>c,
                                           event_callbacks=>b, subwidgets=>oldwids } )
                                 newwids
                =>
                {   wids = case oldwids
                               PACKED  _ => PACKED  newwids;
                               GRIDDED _ => GRIDDED newwids;
                           esac;

                    TEXT_ITEM_WIDGET { text_item_id=>tn, mark=>i, traits=>c, event_callbacks=>b, subwidgets=>wids };
                };

            update_text_item_subwidgets _ _
                =>
                raise exception TEXT_ITEM ("text_item::update_text_item_subwidgets applied to non TEXT_ITEM_WIDGET");
        end;


        get_text_widget_text_items
            =
            live_text::get_livetext_text_items o get_text_widget_livetext;

        fun update_text_widget_annotations w a
            =
            upd_text_wid_anno_text w (live_text::update_livetext_text_items (get_text_widget_livetext w) a);


        get_text_widget_text
            =
            live_text::get_livetext_text o get_text_widget_livetext; 



        fun get wid tn
            =
            {   anots = get_text_widget_text_items wid;

                item  = list_util::getx
                            (fn an = get_text_item_id an == tn) anots 
                            (TEXT_ITEM ("text_item::get: " + tn + " not found"));
                item;
            };

        fun get_naming_by_name wid tn name
            =
            {
                anot = get wid tn;
                bis  = sel_annotation_naming anot;
                bi   = bind::get_action_by_name name bis;

                bi;
            };

        fun upd widg tn nan
            =
            {
                at    = get_text_widget_livetext widg;

                ans   = live_text::get_livetext_text_items at;

                an    = list_util::getx (fn an => ((get_text_item_id an) == tn); end )
                                                   ans
                                                   (TEXT_ITEM ("annotation: " + tn + " not found"));

                nans  = list_util::update_val (fn an => ((get_text_item_id an) == tn); end )
                                                         nan
                                                         ans;

                nwidg = upd_text_wid_anno_text widg (live_text::update_livetext_text_items at nans);

                nwidg;
            };


        fun get_text_wid_widgets (TEXT_WIDGET { widget_id=>wid, scrollbars=>st, live_text=>at, packing_hints=>p, traits=>c, event_callbacks=>b } )
                =>
                {
                    widans = list::filter (fn an => (sel_annotation_type an == TEXT_ITEM_WIDGET_TYPE); end )
                                             (live_text::get_livetext_text_items at);

                    wids   = map get_text_widget_subwidgets widans;

                    wids'  = list::cat wids;

                    wids';
                };

            get_text_wid_widgets _
                =>
                raise exception WIDGET "text_item::getTextWidWidgets applied to non-Text Widget";
        end;


        fun get_text_wid_annotation_widget_ass_list (TEXT_WIDGET { widget_id=>wid, scrollbars=>st, live_text=>at, packing_hints=>p, traits=>c, event_callbacks=>b } )
                =>
                {
                    widans = list::filter
                                 (fn an = (sel_annotation_type an == TEXT_ITEM_WIDGET_TYPE)) 
                                 (live_text::get_livetext_text_items at);

                    wids   = map get_text_widget_subwidgets widans;

                    paired_lists::zip (widans, wids);
                };

            get_text_wid_annotation_widget_ass_list _
                =>
                raise exception WIDGET "text_item::getTextWidAnnotationWidgetAssList applied to non-Text Widget";
        end;


        fun add_text_wid_widget af (w as (TEXT_WIDGET _)) widg wp
                =>
                {   debug::print 4 ("addTextWidWidget " + (get_widget_id w) + " " + (get_widget_id widg) + " " + wp);

                    my (w_id, nwp)     = paths::fst_wid_path wp;       #  strip ".txt"
                    my (w_id', nwp')   = paths::fst_wid_path nwp;      #  strip ".tfr"

                    if (nwp' == "") 
                        raise exception TEXT_ITEM "text_item::addTextWidWidget called for TEXT_ITEM_WIDGET-Toplevel";
                    else

                        my (w_id'', nwp'')
                            =
                            paths::fst_wid_path nwp';

                        anwidass
                            =
                            get_text_wid_annotation_widget_ass_list w;

                        my (an, swidgs)
                            =
                            list_util::getx
                                (fn (c, (ws: List( Widget )))
                                    =
                                    fold_backward
                                        (fn (w, t)
                                            =
                                            get_widget_id w == w_id''
                                            or
                                            t
                                        )
                                 FALSE ws
                                )
                                anwidass 
                                (TEXT_ITEM ("text_item::addTextWidWidget: subwidget " + w_id'' + " not found" ));

                        debug::print 4 ("addTextWidWidget (ass): " + (get_text_item_id an) + " ["  + 
                                       (string::join ", " (map (get_widget_id) swidgs)) + "]");

                        nswidgs       = af swidgs widg nwp';
                        nan           = update_text_item_subwidgets an nswidgs;
                        nwidg         = upd w (get_text_item_id nan) nan;

                        nwidg;

                    fi;
                };

            add_text_wid_widget _ _ _ _
                =>
                raise exception WIDGET "text_item::addTextWidWidget applied to non-Text Widget";
        end;

        fun delete_text_wid_widget df (w as (TEXT_WIDGET _)) wid wp
                =>
                nwidg
                where 

                    debug::print 4 ("deleteTextWidWidget " + (get_widget_id w) + " " + wp);

                    my (w_id, nwp)     = paths::fst_wid_path wp;         #  strip ".tfr" 
                    my (w_id', nwp')   = paths::fst_wid_path nwp;

                    anwidass      = get_text_wid_annotation_widget_ass_list w;

                    my (an, swidgs)
                        =
                        list_util::getx
                           (fn (c, (ws: List( Widget )))
                               =
                               fold_backward
                                   (fn (w, t) =  get_widget_id w == w_id'  or  t)
                                   FALSE ws
                           )
                           anwidass 
                           (TEXT_ITEM ("text_item::deleteTextWidWidget: subwidget " + w_id' + " not found"));

                    nswidgs       = df swidgs w_id' nwp';
                    nan           = update_text_item_subwidgets an nswidgs;
                    nwidg         = upd w (get_text_item_id nan) nan;
                end;

           delete_text_wid_widget _ _ _ _
                =>
                raise exception WIDGET "text_item::deleteTextWidWidget applied to non-Text Widget";
        end;

        fun upd_text_wid_widget uf (w as (TEXT_WIDGET _)) wid wp neww
                =>
                {
                    debug::print 4 ("updTextWidWidget " + (get_widget_id w) + " " + wp);

                    my (w_id, nwp)     = paths::fst_wid_path wp;         #  strip ".tfr" 
                    my (w_id', nwp')   = paths::fst_wid_path nwp;

                    anwidass      = get_text_wid_annotation_widget_ass_list w;

                    my (an, swidgs)
                        =
                        list_util::getx
                            (fn (c, (ws: List( Widget )))
                                =
                                fold_backward
                                    (fn (w, t) =  get_widget_id w == w_id'   or  t)
                                    FALSE ws
                            )
                            anwidass 
                            (TEXT_ITEM ("text_item::updTextWidWidget did not find Subwidget " + w_id'));

                    nswidgs       = uf swidgs w_id' nwp' neww;
                    nan           = update_text_item_subwidgets an nswidgs;
                    nwidg         = upd w (get_text_item_id nan) nan;

                    nwidg;
                };
            upd_text_wid_widget _ _ _ _ _
                =>
                raise exception WIDGET "text_item::updTextWidWidgets applied to non-CANVAS Widget";
        end;


        fun pack pf tp (ip as (window, pt)) (TEXT_ITEM_TAG { text_item_id => nm, marks => il,
                                                 traits => c, event_callbacks => b } )
                =>
                {
                    is   = mark::show_l il;
                    conf = config::pack ip c;

                    (tp + " tag add " + nm + " " + is + "\n" +
                     tp + " tag configure " + nm + " " + conf + "\n" +
                     cat (bind::pack_tag tp ip nm b));
                };

            pack pf tp (ip as (window, pt)) (TEXT_ITEM_WIDGET { text_item_id => nm, mark => i, subwidgets => ws,
                                                    traits => c, event_callbacks => b } )
                =>
                {
                    widget_id = nm;
                    it    = mark::show i;
                    conf  = config::pack ip c;

                    frw   = FRAME { widget_id, subwidgets => ws, packing_hints => [],
                                       traits => [], event_callbacks => [] };

                    frtp  = tp + "." + widget_id;

                    (pf TRUE tp ip (THE TRUE) frw +
                     tp + " window create " + it + " " + conf + " -window " + frtp + "\n");

    #            + (bind::packTag tp ip cid b)

                };
        end;


        fun add pf widg an
            =
            {   my ip as (window, pt)
                    =
                    paths::get_int_path_gui (get_widget_id widg);

                tp             = paths::get_tcl_path_gui ip;
                nip            = (window, pt + ".txt");
                ntp            = tp + ".txt";
                ans            = get_text_widget_text_items widg;
                nans           = ans @ [an];
                nwidg          = update_text_widget_annotations widg nans;

                { com::put_tcl_cmd (pack pf ntp nip an);
                  nwidg;
                };
            };

        fun delete dwf widg tn
            =
            {   fun delete' dwf widg (an as (TEXT_ITEM_WIDGET { text_item_id=>tn, subwidgets=>ws, ... } ))
                    =>
                    {
                        wi             = tn;

                        my ip as (window, pt)
                            =
                            paths::get_int_path_gui (get_widget_id widg);

                        tp             = paths::get_tcl_path_gui ip;
                        nip            = (window, pt + ".txt");
                        ntp            = tp + ".txt";
                        ans            = get_text_widget_text_items widg;
                        nans           = list::filter (fn an => not ((get_text_item_id an) == tn); end ) ans;
                        nwidg          = update_text_widget_annotations widg nans;

                        apply (dwf o get_widget_id) (get_raw_widgets ws);

                        com::put_tcl_cmd ("destroy " + ntp + "." + wi);

#                        com::putTclCmd (ntp + " delete " + cid); 

                        nwidg;
                    };

                    delete' dwf widg (an as (TEXT_ITEM_TAG { text_item_id=>tn, ... } ))
                        =>
                        {   my ip as (window, pt)
                                =
                                paths::get_int_path_gui (get_widget_id widg);

                            tp             = paths::get_tcl_path_gui ip;
                            nip            = (window, pt + ".txt");
                            ntp            = tp + ".txt";
                            ans            = get_text_widget_text_items widg;
                            nans           = list::filter (fn an => not ((get_text_item_id an) == tn); end ) ans;
                            nwidg          = update_text_widget_annotations widg nans;

                            com::put_tcl_cmd (ntp + " tag delete " + tn);
                            nwidg;
                        };
                end;

                an = get widg tn;

                delete' dwf widg an;
            };


        fun add_annotation_configure widg tn cf
            =
            {
                fun cmd_text (TEXT_ITEM_WIDGET _) => " window configure ";
                    cmd_text (TEXT_ITEM_TAG _)    => " tag configure ";
                end;

                my ip as (window, pt)
                    =
                    paths::get_int_path_gui (get_widget_id widg);

                tp             = paths::get_tcl_path_gui ip;
                nip            = (window, pt + ".txt");
                ntp            = tp + ".txt";
                ans            = get_text_widget_text_items widg;
                an             = list_util::getx (fn an = ((get_text_item_id an) == tn))
                                                   ans 
                                                   (TEXT_ITEM ("annotation: " + tn + " not found"));

                conf           = sel_annotation_configure an;
                nconf          = config::add conf cf;
                nan            = upd_annotation_configure an nconf;
                nans           = list_util::update_val (fn an = ((get_text_item_id an) == tn))
                                                         nan
                                                         ans;

                nwidg          = update_text_widget_annotations widg nans;

                com::put_tcl_cmd (ntp + (cmd_text an) + tn + " " +
                                config::pack nip cf);
                nwidg;
            };


        fun add_annotation_naming widg tn bi
            =
            nwidg
            where 

                fun cmd_text (TEXT_ITEM_WIDGET _) _ _ _ _
                        =>
                        raise exception TEXT_ITEM "text_item::addAnnotationNaming applied to non TEXT_ITEM_TAG";

                    cmd_text (TEXT_ITEM_TAG _) ntp nip tn bi
                        => 
                        bind::pack_tag ntp nip tn bi;
                end;

                my ip as (window, pt)
                    =
                    paths::get_int_path_gui (get_widget_id widg);

                tp             = paths::get_tcl_path_gui ip;
                nip            = (window, pt + ".txt");
                ntp            = tp + ".txt";
                ans            = get_text_widget_text_items widg;

                an             = list_util::getx (fn an = ((get_text_item_id an) == tn))
                                                   ans 
                                                   (TEXT_ITEM ("annotation: " + tn + " not found"));

                bind           = sel_annotation_naming an;
                nbind          = bind::add bind bi;
                nan            = upd_annotation_naming an nbind;

                nans           = list_util::update_val (fn an = ((get_text_item_id an) == tn))
                                                         nan
                                                         ans;

                nwidg          = update_text_widget_annotations widg nans;

                com::put_tcl_cmd (cat (cmd_text an ntp nip tn bi));
            end;


        fun read_selection wid
            =
            {   ip   = paths::get_int_path_gui (get_widget_id wid);
                tp   = paths::get_tcl_path_gui ip;

                ms   = com::read_tcl_val (tp + ".txt tag ranges sel");

                mark::read_l ms;
            };

        fun read_marks wid tn
            =
            {   ip   = paths::get_int_path_gui (get_widget_id wid);
                tp   = paths::get_tcl_path_gui ip;

                an   = get wid tn;

                case (sel_annotation_type an)

                    TEXT_ITEM_TAG_TYPE
                        => 
                        mark::read_l (com::read_tcl_val (tp + ".txt tag ranges " + tn));

                    TEXT_ITEM_WIDGET_TYPE
                        => 
                        raise exception TEXT_ITEM ("text_item::readMarks applied to non TEXT_ITEM_TAG");
                esac;
            };



        #  ************************************************************************ 
        #                                                                           
        #  Anonymous AnnotationId Manager                                           
        #                                                                           
        #  ************************************************************************ 

                                                                                        my
        anotagn_nr = REF (0);

        fun new_id ()
            =
            {   inc (anotagn_nr);
                "anotagn" + int::to_string *anotagn_nr;};

                                                                                        my
        anofrid_nr = REF (0);

        fun new_fr_id ()
            =
            {   inc (anofrid_nr);
                "tfr" + int::to_string *anofrid_nr;
            };

    end;

};



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext