/* ***********************************************************************
# 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 package basic_tk_types;
include package 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
(\\ 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 (\\ an => ((get_text_item_id an) == tn); end )
ans
(TEXT_ITEM ("annotation: " + tn + " not found"));
nans = list_util::update_val (\\ 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 (\\ 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
(\\ 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
(\\ (c, (ws: List( Widget )))
=
fold_backward
(\\ (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
(\\ (c, (ws: List( Widget )))
=
fold_backward
(\\ (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
(\\ (c, (ws: List( Widget )))
=
fold_backward
(\\ (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 (\\ 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 (\\ 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 (\\ 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 (\\ 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 (\\ 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 (\\ 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;
};