# ***********************************************************************
#
# Project: sml/Tk: an Tk Toolkit for sml
# Author: Burkhart Wolff, University of Bremen
# Date: 25.7.95
# Purpose of this file: Functions related to "Tk-Configurations"
#
# ***********************************************************************
# Compiled by:
# src/lib/tk/src/tk.sublibpackage config
: (weak) Config # Config is from src/lib/tk/src/config.api{
stipulate
include package basic_utilities;
include package basic_tk_types;
include package gui_state;
herein
infix my 20 conf_elem ;
# ***********************************************************************
#
# IMPLEMENTATION: ADD PACK INFORMATION to the "real" GUI
#
# ***********************************************************************
fun show_expand t
=
if t "1"; else "0";fi;
fun show_style ONLY_X => "x";
show_style ONLY_Y => "y";
show_style XY => "both";
end;
fun show_edge TOP => "top";
show_edge BOTTOM => "bottom";
show_edge LEFT => "left";
show_edge RIGHT => "right";
end;
fun show_sticky_kind TO_N => "n";
show_sticky_kind TO_S => "s";
show_sticky_kind TO_E => "e";
show_sticky_kind TO_W => "w";
show_sticky_kind TO_NS => "ns";
show_sticky_kind TO_NE => "ne";
show_sticky_kind TO_NW => "nw";
show_sticky_kind TO_SE => "se";
show_sticky_kind TO_SW => "sw";
show_sticky_kind TO_EW => "ew";
show_sticky_kind TO_NSE => "nse";
show_sticky_kind TO_NSW => "nsw";
show_sticky_kind TO_NEW => "new";
show_sticky_kind TO_SEW => "sew";
show_sticky_kind TO_NSEW => "nsew";
end;
fun pack_one_info (EXPAND b) => " -expand " + show_expand b;
pack_one_info (FILL s) => " -fill " + show_style s;
pack_one_info (PAD_X n) => " -padx " + string_util::from_int n;
pack_one_info (PAD_Y n) => " -pady " + string_util::from_int n;
pack_one_info (PACK_AT e)=> " -side " + show_edge e;
pack_one_info _ => "";
end;
fun pack_info ps
=
cat (map pack_one_info ps);
fun grid_one_info (PAD_X n) => " -padx " + string_util::from_int n;
grid_one_info (PAD_Y n) => " -pady " + string_util::from_int n;
grid_one_info (COLUMN n) => " -column " + string_util::from_int n;
grid_one_info (ROW n) => " -row " + string_util::from_int n;
grid_one_info (STICK s) => " -sticky " + show_sticky_kind s;
grid_one_info _ => "";
end;
fun grid_info ps
=
cat (map grid_one_info ps);
# ***********************************************************************
#
# IMPLEMENTATION: SELECT CONFIGURE INFORMATION
#
# ***********************************************************************
fun conf_eq (WIDTH _ ) (WIDTH _ ) => TRUE;
conf_eq (HEIGHT _ ) (HEIGHT _ ) => TRUE;
conf_eq (BORDER_THICKNESS _ ) (BORDER_THICKNESS _ ) => TRUE;
conf_eq (RELIEF _ ) (RELIEF _ ) => TRUE;
conf_eq (FOREGROUND _ ) (FOREGROUND _ ) => TRUE;
conf_eq (BACKGROUND _ ) (BACKGROUND _ ) => TRUE;
conf_eq (MENU_UNDERLINE _ ) (MENU_UNDERLINE _ ) => TRUE;
conf_eq (ACCELERATOR _ ) (ACCELERATOR _ ) => TRUE;
conf_eq (TEXT _ ) (TEXT _ ) => TRUE;
conf_eq (FONT _ ) (FONT _ ) => TRUE;
conf_eq (VARIABLE _ ) (VARIABLE _ ) => TRUE;
conf_eq (VALUE _ ) (VALUE _ ) => TRUE;
conf_eq (ICON _ ) (ICON _ ) => TRUE;
conf_eq (CURSOR _ ) (CURSOR _ ) => TRUE;
conf_eq (CALLBACK _ ) (CALLBACK _ ) => TRUE;
conf_eq (ANCHOR _ ) (ANCHOR _ ) => TRUE;
conf_eq (FILL_COLOR _ ) (FILL_COLOR _ ) => TRUE;
conf_eq (OUTLINE _ ) (OUTLINE _ ) => TRUE;
conf_eq (OUTLINE_WIDTH _ ) (OUTLINE_WIDTH _ ) => TRUE;
# | confEq (STIPPLE ) (STIPPLE ) = TRUE
conf_eq (SMOOTH _ ) (SMOOTH _ ) => TRUE;
conf_eq (OFFSET _ ) (OFFSET _ ) => TRUE;
conf_eq UNDERLINE UNDERLINE => TRUE;
conf_eq (JUSTIFY _ ) (JUSTIFY _ ) => TRUE;
conf_eq (WRAP _ ) (WRAP _ ) => TRUE;
conf_eq (ARROW _ ) (ARROW _ ) => TRUE;
conf_eq (CAP_STYLE _ ) (CAP_STYLE _ ) => TRUE;
conf_eq (JOIN_STYLE _ ) (JOIN_STYLE _ ) => TRUE;
conf_eq (SCROLL_REGION _ ) (SCROLL_REGION _ ) => TRUE;
conf_eq (ORIENT _ ) (ORIENT _ ) => TRUE;
conf_eq (SLIDER_LABEL _ ) (SLIDER_LABEL _ ) => TRUE;
conf_eq (LENGTH _ ) (LENGTH _ ) => TRUE;
conf_eq (SLIDER_LENGTH _ ) (SLIDER_LENGTH _ ) => TRUE;
conf_eq (FROM _ ) (FROM _ ) => TRUE;
conf_eq (TO _ ) (TO _ ) => TRUE;
conf_eq (RESOLUTION _ ) (RESOLUTION _ ) => TRUE;
conf_eq (DIGITS _ ) (DIGITS _ ) => TRUE;
conf_eq (BIG_INCREMENT _ ) (BIG_INCREMENT _ ) => TRUE;
conf_eq (TICK_INTERVAL _ ) (TICK_INTERVAL _ ) => TRUE;
conf_eq (SHOW_VALUE _ ) (SHOW_VALUE _ ) => TRUE;
conf_eq (SLIDER_RELIEF _ ) (SLIDER_RELIEF _ ) => TRUE;
conf_eq (ACTIVE _ ) (ACTIVE _ ) => TRUE;
conf_eq (REAL_CALLBACK _ ) (REAL_CALLBACK _ ) => TRUE;
conf_eq (REPEAT_DELAY _ ) (REPEAT_DELAY _ ) => TRUE;
conf_eq (REPEAT_INTERVAL _) (REPEAT_INTERVAL _) => TRUE;
conf_eq (THROUGH_COLOR _ ) (THROUGH_COLOR _ ) => TRUE;
conf_eq (INNER_PAD_X _ ) (INNER_PAD_X _ ) => TRUE;
conf_eq (INNER_PAD_Y _ ) (INNER_PAD_Y _ ) => TRUE;
conf_eq (SHOW _ ) (SHOW _ ) => TRUE;
conf_eq (TEAR_OFF _ ) (TEAR_OFF _ ) => TRUE;
conf_eq _ _ => FALSE;
end;
fun conf_name (WIDTH _) => "Width";
conf_name (HEIGHT _) => "Height";
conf_name (BORDER_THICKNESS _) => "Borderwidth";
conf_name (RELIEF _) => "Relief";
conf_name (FOREGROUND _) => "Foreground";
conf_name (BACKGROUND _) => "Background";
conf_name (MENU_UNDERLINE _) => "MUnderline";
conf_name (ACCELERATOR _) => "Accelerator";
conf_name (TEXT _) => "Text";
conf_name (FONT _) => "Font";
conf_name (VARIABLE _) => "Variable";
conf_name (VALUE _) => "Value";
conf_name (ICON _) => "Icon";
conf_name (CURSOR _) => "Cursor";
conf_name (CALLBACK _) => "Command";
conf_name (ANCHOR _) => "Anchor";
conf_name (FILL_COLOR _) => "FillColor";
conf_name (OUTLINE _) => "Outline";
conf_name (OUTLINE_WIDTH _) => "OutlineWidth";
# | confName (STIPPLE _) = "Stipple"
conf_name (SMOOTH _) => "Smooth";
conf_name (ARROW _) => "Arrow";
conf_name (SCROLL_REGION _) => "ScrollRegion";
conf_name (CAP_STYLE _) => "Capstyle";
conf_name (JOIN_STYLE _) => "Joinstyle";
conf_name (COLOR_MAP _) => "ColorMap";
conf_name (COLOR_MODE _) => "ColorMode";
conf_name (FILE _) => "File";
conf_name (FONT_MAP _) => "FontMap";
conf_name (PRINT_HEIGHT _) => "PrintHeight";
conf_name (PAGE_ANCHOR _) => "PageAnchor";
conf_name (PAGE_HEIGHT _) => "PageHeight";
conf_name (PAGE_WIDTH _) => "PageWidth";
conf_name (PAGE_X _) => "PageX";
conf_name (PAGE_Y _) => "PageY";
conf_name (ROTATE _) => "Rotate";
conf_name (PRINT_WIDTH _) => "PrintWidth";
conf_name (PRINT_X _) => "PrintX";
conf_name (PRINT_Y _) => "PrintY";
conf_name (OFFSET _) => "Offset";
conf_name UNDERLINE => "Underline";
conf_name (JUSTIFY _) => "Justify";
conf_name (WRAP _) => "Wrap";
conf_name (ORIENT _) => "Orient";
conf_name (SLIDER_LABEL _) => "SLabel";
conf_name (LENGTH _) => "Length";
conf_name (SLIDER_LENGTH _) => "SliderLength";
conf_name (FROM _) => "From";
conf_name (TO _) => "To";
conf_name (RESOLUTION _) => "Resolution";
conf_name (DIGITS _) => "Digits";
conf_name (BIG_INCREMENT _) => "BigIncrement";
conf_name (TICK_INTERVAL _) => "TickInterval";
conf_name (SHOW_VALUE _) => "ShowValue";
conf_name (SLIDER_RELIEF _) => "SliderRelief";
conf_name (ACTIVE _) => "Active";
conf_name (REAL_CALLBACK _) => "SCommand";
conf_name (REPEAT_DELAY _) => "RepeatDelay";
conf_name (REPEAT_INTERVAL _)=> "RepeatInterval";
conf_name (THROUGH_COLOR _) => "ThroughColor";
conf_name (INNER_PAD_X _) => "InnerPadX";
conf_name (INNER_PAD_Y _) => "InnerPadY";
conf_name (SHOW _) => "Show";
conf_name (TEAR_OFF _) => "Tearoff";
end;
# | confName _ =
# raise exception WIDGET "widget_tree::confName not yet fully implemented!"
fun conf_elem_h (c,[]) => FALSE;
conf_elem_h (c, (x ! xs)) => conf_eq c x or conf_elem_h (c, xs);
end;
conf_elem = conf_elem_h;
fun no_dbl_p [] => TRUE;
no_dbl_p (x ! xs) => not (x conf_elem xs) and no_dbl_p xs;
end;
# DefaultWidth: Widget_Type -> Int
fun default_width _ = 0;
fun default_height _ = 0;
fun default_borderwidth _ = 0;
fun default_relief _ = FLAT;
fun default_foreground _ = BLACK;
fun default_backgound _ = GREY;
fun default_text _ = "";
fun default_font _ = (fonts::NORMAL_FONT []);
fun default_variable _ = "BLA"; # interesting...
fun default_value _ = "0";
fun default_icon _ = NO_ICON;
fun default_cursor _ = NO_CURSOR;
fun default_command _ = \\ () => (); end ;
fun default_anchor _ = CENTER;
fun default_text_wid_state _ = FALSE;
fun default_fill_color _ = WHITE;
fun default_outline _ = BLACK;
fun default_outline_width _ = 1;
# fun defaultStipple _ = ...
fun default_smooth _ = FALSE;
# fun defaultArrow _ = ...
fun default_scroll_region _ = (0, 0, 0, 0);
# fun defaultCapstyle _ = ...
# fun defaultJoinstyle _ = ...
# scw . Trait List -> Widget_Type -> Int
#
fun scw [] wt => default_width wt;
scw ((WIDTH (n)) ! xs) _ => n;
scw (x ! xs) wt => scw xs wt;
end;
fun get_width w
=
scw (get_the_widget_traits w) (get_widget_type w);
fun get_menu_item_width m
=
scw (get_menu_item_traits m) (get_the_menu_item_type m);
fun sch [] wt => default_height wt;
sch ((HEIGHT h) ! _) _ => h;
sch (_ ! xs) w => sch xs w;
end;
fun get_height w
=
sch (get_the_widget_traits w) (get_widget_type w);
# screen: Trait List -> Widget_Type -> RelKind
#
fun screen [] wt => default_relief wt;
screen ((RELIEF r) ! xs) _ => r;
screen (x ! xs) wt => screen xs wt;
end;
fun sel_relief w
=
screen (get_the_widget_traits w) (get_widget_type w);
fun get_menu_item_relief_kind w
=
screen (get_menu_item_traits w) (get_the_menu_item_type w);
# my sct: Trait List -> Widget_Type -> String
#
fun sct [] wt => default_text wt;
sct ((TEXT t) ! xs) _ => t;
sct (x ! xs) wt => sct xs wt;
end;
fun get_livetext_text w
=
sct (get_the_widget_traits w) (get_widget_type w);
fun get_menu_item_text w
=
sct (get_menu_item_traits w) (get_the_menu_item_type w);
# scc: Trait List -> Widget_Type -> SimpleCallback
#
fun scc [] wt => default_command wt;
scc ((CALLBACK c) ! xs) _ => c;
scc (x ! xs) wt => scc xs wt;
end;
fun sel_command w
=
scc (get_the_widget_traits w) (get_widget_type w);
fun get_menu_item_callback w
=
scc (get_menu_item_traits w) (get_the_menu_item_type w);
fun scc' [] => (\\ _ = ());
scc' ((REAL_CALLBACK c) ! xs) => c;
scc' (x ! xs) => scc' xs;
end;
fun sel_scommand w
=
scc' (get_the_widget_traits w);
# ***********************************************************************
#
# 4C. ADD and UPDATE CONFIGURE INFORMATION to the internal GUI stat
#
# ***********************************************************************
# AddOneConf: Trait List -> Trait -> Trait List
#
fun add_one_conf (c, [])
=>
[c];
add_one_conf (c, x ! xs)
=>
if (conf_eq x c) c ! xs;
else x ! add_one_conf (c, xs);
fi;
end;
fun add old new
=
list::fold_backward add_one_conf old new;
# new_one_conf: Trait List -> Trait -> Trait List
#
fun new_one_conf cs c
=
list::filter (not o (conf_eq c)) cs;
# default_conf: Widget_Type -> Trait -> Trait
#
fun default_conf wt (WIDTH _) => WIDTH (default_width wt);
default_conf wt (HEIGHT _) => HEIGHT (default_height wt);
default_conf wt (BORDER_THICKNESS _) => BORDER_THICKNESS (default_borderwidth wt);
default_conf wt (RELIEF _) => RELIEF (default_relief wt);
# defaultConf wt (FOREGROUND _) = FOREGROUND (defaultForeground wt)
# defaultConf wt (BACKGROUND _) = BACKGROUND (defaultBackground wt)
default_conf wt (TEXT _) => TEXT (default_text wt);
default_conf wt (FONT _) => FONT (default_font wt);
default_conf wt (VARIABLE _) => VARIABLE (default_variable wt);
default_conf wt (VALUE _) => VALUE (default_value wt);
default_conf wt (ICON _) => ICON (default_icon wt);
default_conf wt (CURSOR _) => CURSOR (default_cursor wt);
default_conf wt (CALLBACK _) => CALLBACK (default_command wt);
default_conf wt (FILL_COLOR _) => FILL_COLOR (default_fill_color wt);
default_conf wt (OUTLINE _) => OUTLINE (default_outline wt);
default_conf wt (OUTLINE_WIDTH _)=> OUTLINE_WIDTH (default_outline_width wt);
# defaultconf wt (STIPPLE) = STIPPLE
default_conf wt (SMOOTH _) => SMOOTH (default_smooth wt);
# defaultConf wt (ARROW _) = ARROW (defaultArrow wt)
# defaultConf wt (SCROLL_REGION _)= SCROLL_REGION (defaultScrollRegion wt)
# defaultConf wt (CAP_STYLE _) = CAP_STYLE (defaultCapstyle wt)
# defaultConf wt (JOIN_STYLE _) = JOIN_STYLE (defaultJoinstyle wt)
default_conf wt _
=>
raise exception CONFIG "config::defaultConf: not yet fully implemented";
end;
fun new wt old nw
=
{
defold = fold_forward (twist (uncurry (new_one_conf))) old nw;
nw @ map (default_conf wt) defold;
};
# ***********************************************************************
#
# 4D. ADD CONFIGURE INFORMATION to the "real" GUI
#
# ***********************************************************************
fun show_rel FLAT => "flat";
show_rel GROOVE => "groove";
show_rel RAISED => "raised";
show_rel RIDGE => "ridge";
show_rel SUNKEN => "sunken";
end;
stipulate
fun round n
=
if (n < 0 ) 0;
elif (n > 255) 255;
else n;
fi;
herein
fun show_col NO_COLOR=> "{}";
show_col BLACK => "black";
show_col WHITE => "white";
show_col GREY => "grey";
show_col BLUE => "blue";
show_col GREEN => "green";
show_col RED => "red";
show_col BROWN => "brown";
show_col YELLOW => "yellow";
show_col PURPLE => "purple";
show_col ORANGE => "orange";
show_col (MIX { red, blue, green } )
=>
"\"#" + unt::to_string (unt::from_int (round red)) +
unt::to_string (unt::from_int (round green)) +
unt::to_string (unt::from_int (round blue)) + "\"";
end;
end;
fun show_anchor_kind NORTH => "n";
show_anchor_kind NORTHEAST => "ne";
show_anchor_kind EAST => "e";
show_anchor_kind SOUTHEAST => "se";
show_anchor_kind SOUTH => "s";
show_anchor_kind SOUTHWEST => "sw";
show_anchor_kind WEST => "w";
show_anchor_kind NORTHWEST => "nw";
show_anchor_kind CENTER => "center";
end;
fun show_state FALSE => "normal";
show_state TRUE => "disabled";
end;
fun show_icon_kind (NO_ICON)
=>
" -bitmap {}";
show_icon_kind (TK_BITMAP (s))
=>
" -bitmap \"" + s + "\"";
show_icon_kind (FILE_BITMAP (s))
=>
" -bitmap \"@" + s + "\"";
# showIconKind (FILE_PIXMAP (f, imId))
# =.
# " -image [image create pixmap " + imId + " -file " + f + "]"
show_icon_kind (FILE_IMAGE (f, im_id))
=>
" -image [image create photo " + im_id + " -file " + f + "]";
end;
fun show_cursor_kind (NO_CURSOR) => "{}";
show_cursor_kind (XCURSOR (cn, NULL)) => cn;
show_cursor_kind (XCURSOR (cn, THE (fg, NULL))) => cn + " " + (show_col fg);
show_cursor_kind (XCURSOR (cn, THE (fg, THE (bg))))
=>
cn + " " + (show_col fg) + " " + (show_col bg);
show_cursor_kind (FILE_CURSOR (cf, fg, NULL))
=>
"{@" + cf + " " + (show_col fg) + "}";
show_cursor_kind (FILE_CURSOR (cf, fg, THE (mf, bg)))
=>
"{@" + cf + " " + mf + " " + (show_col fg) + " " + (show_col bg) + "}";
end;
# Added by E.L.Gunter 14 July 1998
#
fun show_arrow_pos ARROWHEAD_NONE => "none";
show_arrow_pos ARROWHEAD_FIRST => "first";
show_arrow_pos ARROWHEAD_LAST => "last";
show_arrow_pos ARROWHEAD_BOTH => "both";
end;
fun show_color_mode PRINTCOLOR => "color";
show_color_mode PRINTGREY => "grey";
show_color_mode PRINTMONO => "mono";
end;
fun show_color_map_entry (index, r, g, b)
=
"set colorMap(" + index + ") {" + r + " " + g + " " + b + " " + "setrgbcolor }";
fun declare_color_map []
=>
[];
declare_color_map (COLORMAP_ENTRY (cme1) ! cmrest)
=>
{ com::put_tcl_cmd (show_color_map_entry cme1);
declare_color_map cmrest;
};
end;
fun show_font_map_entry (xfont, newfont, size)
=
"set fontMap(" + xfont + ") [" + newfont + " " +
string_util::from_int size + "]";
fun declare_font_map []
=>
[];
declare_font_map (FONTMAP_ENTRY (fme1) ! fmrest)
=>
{ com::put_tcl_cmd (show_font_map_entry fme1);
declare_font_map fmrest;
};
end;
fun show_bool b
=
b ?? "true"
:: "false";
fun show_real r
=
if (r < 0.0) "-" + float::to_string (float::abs r);
else float::to_string r;
fi;
# showConf: IntPath -> Bool -> Trait -> String
#
fun show_conf _ (WIDTH n) => " -width " + string_util::from_int n;
show_conf _ (HEIGHT n) => " -height " + string_util::from_int n;
show_conf _ (BORDER_THICKNESS n) => " -borderwidth " + string_util::from_int n;
show_conf _ (RELIEF r) => " -relief " + show_rel r;
show_conf _ (FOREGROUND r) => " -foreground " + show_col r;
show_conf _ (BACKGROUND r) => " -background " + show_col r;
show_conf _ (TEXT t) => " -text \"" + string_util::adapt_string t + "\"";
show_conf _ (FONT r) => " -font " + fonts::font_descr r;
show_conf _ (VARIABLE r) => " -variable " + r;
show_conf _ (VALUE r) => " -value " + r;
show_conf _ (ICON ick) => show_icon_kind ick;
show_conf _ (CURSOR ck) => " -cursor " + show_cursor_kind ck;
show_conf (w, p) (CALLBACK c) => " -command {" + com::comm_to_tcl + " \"Command " + w + " " + p + "\"}";
show_conf _ (ANCHOR a) => " -anchor " + show_anchor_kind a;
show_conf _ (FILL_COLOR r) => " -fill " + show_col r;
show_conf _ (OUTLINE r) => " -outline " + show_col r;
show_conf _ (OUTLINE_WIDTH n) => " -width " + string_util::from_int n;
# showconf _ (STIPPLE) = ...
show_conf _ (SMOOTH TRUE) => " -smooth true";
show_conf _ (SMOOTH FALSE) => "";
show_conf _ (CAP_STYLE csk) =>
"-capstyle " + case csk BUTT => "butt";
PROJECTING => "projecting";
ROUND => "round";
esac;
show_conf _ (JOIN_STYLE jk)
=>
"-joinstyle " + case jk BEVEL => "bevel";
MITER => "miter";
ROUNDJOIN => "round";
esac;
show_conf _ (SCROLL_REGION (srl, srt, srr, srb))
=>
" -scrollregion {" + string_util::from_int srl + " " + string_util::from_int srt + " " +
string_util::from_int srr + " " + string_util::from_int srb + "}";
show_conf _ (OFFSET i) => " -offset " + string_util::from_int i;
show_conf _ (UNDERLINE) => " -underline true";
show_conf _ (MENU_UNDERLINE n) => " -underline " + string_util::from_int n;
show_conf _ (JUSTIFY j)
=>
" -justify " + case j JUSTIFY_LEFT => "left";
JUSTIFY_RIGHT => "right";
JUSTIFY_CENTER => "center";
esac;
show_conf _ (WRAP wm)
=>
" -wrap " + case wm NO_WRAP => "none";
WRAP_CHAR => "char";
WRAP_WORD => "word";
esac;
show_conf _ (ARROW ap) => " -arrow " + show_arrow_pos ap;
show_conf _ (ORIENT or_op)
=>
" -orient " + case or_op HORIZONTAL => "horizontal";
VERTICAL => "vertical";
esac;
show_conf _ (SLIDER_LABEL s) => " -label " + s;
show_conf _ (LENGTH i) => " -length " + string_util::from_int i;
show_conf _ (SLIDER_LENGTH i) => " -sliderlength " + string_util::from_int i;
show_conf _ (FROM r) => " -from " + show_real r;
show_conf _ (TO r) => " -to " + show_real r;
show_conf _ (RESOLUTION r) => " -resolution " + show_real r;
show_conf _ (DIGITS i) => " -digits " + string_util::from_int i;
show_conf _ (BIG_INCREMENT r) => " -bigincrement " + show_real r;
show_conf _ (TICK_INTERVAL r) => " -tickinterval " + show_real r;
show_conf _ (SHOW_VALUE b)
=>
" -showvalue " + (b ?? "true" :: "false");
show_conf _ (SLIDER_RELIEF r) => " -sliderrelief " + show_rel r;
show_conf _ (ACTIVE b) => " -state " + show_state (not b);
show_conf (w, p) (REAL_CALLBACK c)
=>
" -command {" + com::comm_to_tcl' + " \"SCommand " + w + " " + p + "\"}";
show_conf _ (REPEAT_DELAY i) => " -repeatdelay " + string_util::from_int i;
show_conf _ (REPEAT_INTERVAL i) => " -repeatinterval " + string_util::from_int i;
show_conf _ (THROUGH_COLOR c) => " -throughcolor " + show_col c;
show_conf _ (INNER_PAD_X i) => " -padx " + string_util::from_int i;
show_conf _ (INNER_PAD_Y i) => " -pady " + string_util::from_int i;
show_conf _ (SHOW c) => " -show " + char::to_string c;
show_conf _ (TEAR_OFF to) => " -tearoff " + bool::to_string to;
show_conf _ _
=>
raise exception CONFIG "config::showConf: not yet fully implemented";
end;
fun show_print_conf (COLOR_MAP cml) => { declare_color_map cml; " -colormap colorMap";};
show_print_conf (COLOR_MODE c) => " -colormode " + (show_color_mode c);
show_print_conf (FILE f) => " -file " + f;
show_print_conf (FONT_MAP fml) => { declare_font_map fml;
" -fontmap fontMap";
};
show_print_conf (PRINT_HEIGHT h)=> " -height " + h;
show_print_conf (PAGE_ANCHOR pa)=> " -pageanchor " + show_anchor_kind pa;
show_print_conf (PAGE_HEIGHT ph)=> " -pageheight " + ph;
show_print_conf (PAGE_WIDTH pw) => " -pagewidth " + pw;
show_print_conf (PAGE_X px) => " -pagex " + px;
show_print_conf (PAGE_Y py) => " -pagey " + py;
show_print_conf (ROTATE r) => " -rotate " + show_bool r;
show_print_conf (PRINT_WIDTH w) => " -width " + w;
show_print_conf (PRINT_X px) => " -x " + px;
show_print_conf (PRINT_Y py) => " -y " + py;
show_print_conf _
=>
raise exception CONFIG "config::showPrintConf: not yet fully implemented";
end;
fun pack p cs
=
cat (map (show_conf p) cs);
fun pack_casc_path [m: Int] => string_util::from_int m;
pack_casc_path (m ! n ! s) => string_util::from_int m + "." + pack_casc_path (n ! s);
pack_casc_path _
=>
raise exception CONFIG "config::packCascPath: match exhausted";
end;
fun read_casc_path str
=
{ fun rc str_s
=
{ my (m1, m2)
=
(string_util::break_at_dot) str_s;
if (m2 == "" ) [string_util::to_int m1];
else (string_util::to_int m1) ! (rc m2);
fi;
};
rc str;
};
fun show_all_print_conf [] => "";
show_all_print_conf (c1 ! crest)
=>
cat ([(show_print_conf c1)] @ [(show_all_print_conf crest)]);
end;
# showMConf . IntPath -> Int -> Trait s -> String
# -- Width and RELIEF may not appear in menu configures
# -- showMConf _ (WIDTH n) = " -width " + (shop n)
# -- showMConf _ (RELIEF r) = " -relief " + (showRel r)
fun show_mconf _ _ (TEXT t)
=>
" -label \"" + string_util::adapt_string t + "\"";
# Check missing: The following two options only possible in
# radio- or CHECK_BUTTONs XXX BUGGO FIXME
show_mconf _ _ (VARIABLE r) => " -variable " + r;
show_mconf _ _ (VALUE r) => " -value " + r;
show_mconf _ _ (MENU_UNDERLINE n) => " -underline " + string_util::from_int n;
show_mconf _ _ (ACCELERATOR s) => " -accelerator " + s;
show_mconf _ _ (TEAR_OFF b) => " -tearoff " + bool::to_string b;
show_mconf (w, p) m (CALLBACK c)
=>
" -command {" + com::comm_to_tcl + " \"MCommand " + w + " " + p + " "
+ (pack_casc_path m) + "\"}";
show_mconf _ _ (FONT f) => " -font " + fonts::font_descr f;
show_mconf _ _ (FOREGROUND r) => " -foreground " + show_col r;
show_mconf _ _ (BACKGROUND r) => " -background " + show_col r;
show_mconf _ _ _
=>
raise exception CONFIG ("config::showMConf: got wrong config");
end;
# packM ! IntPath -> Int -> [Trait s] -> String
#
fun pack_m p m cs
=
cat (map (show_mconf p m) cs);
fun window_conf_eq (WINDOW_ASPECT_RATIO_LIMITS (_, _, _, _)) (WINDOW_ASPECT_RATIO_LIMITS (_, _, _, _)) => TRUE;
window_conf_eq (WIDE_HIGH_X_Y (_, _)) (WIDE_HIGH_X_Y (_, _)) => TRUE;
# winConfEq (WinIcon _ ) (WinIcon _ ) = TRUE
# winConfEq (WinIconMask _ ) (WinIconMask _ ) = TRUE
# winConfEq (WinIconName _ ) (WinIconName _ ) = TRUE
window_conf_eq (WIDE_HIGH_MAX (_, _)) (WIDE_HIGH_MAX (_, _)) => TRUE;
window_conf_eq (WIDE_HIGH_MIN (_, _)) (WIDE_HIGH_MIN (_, _)) => TRUE;
window_conf_eq (WINDOW_POSITIONED_BY _ ) (WINDOW_POSITIONED_BY _ ) => TRUE;
window_conf_eq (WINDOW_SIZED_BY _ ) (WINDOW_SIZED_BY _ ) => TRUE;
window_conf_eq (WINDOW_TITLE _ ) (WINDOW_TITLE _ ) => TRUE;
window_conf_eq (WINDOW_GROUP _ ) (WINDOW_GROUP _ ) => TRUE;
window_conf_eq (TRANSIENTS_LEADER _ ) (TRANSIENTS_LEADER _ ) => TRUE;
window_conf_eq (OMIT_WINDOW_MANAGER_DECORATIONS _ ) (OMIT_WINDOW_MANAGER_DECORATIONS _ ) => TRUE;
window_conf_eq _ _ => FALSE;
end;
fun add_one_window_conf (c, [] )
=>
[c];
add_one_window_conf (c, x ! xs)
=>
if (window_conf_eq x c) c ! xs;
else x ! add_one_window_conf (c, xs);
fi;
end;
fun add_window_conf old new
=
list::fold_backward add_one_window_conf old new;
fun acc_maybe f wcnfgs
=
{ mbs = map f wcnfgs;
list::fold_forward
\\ (_, THE x) => THE x;
(x, NULL ) => x;
end
NULL
mbs;
};
# old :-
# let
# fun ddd (THE x) _ = THE x
# | ddd NULL x = x
# mbs = map f wcnfgs
# in
# basic_utilities::fold_forward ddd NULL mbs
# end
fun s_asp (WINDOW_ASPECT_RATIO_LIMITS (c as (_, _, _, _))) => THE c;
s_asp _ => NULL;
end;
fun sel_window_aspect w
=
acc_maybe s_asp (get_window_traits w);
fun s_geometry (WIDE_HIGH_X_Y (c as (_, _))) => THE c;
s_geometry _ => NULL;
end;
fun sel_window_shape w
=
acc_maybe s_geometry (get_window_traits w);
# fun sIcon (WinIcon i) = THE i
# |sIcon _ = NULL
#
# fun selWinIcon w = accMaybe sIcon (get_window_traits w)
#
# fun sIconMask (WinIconMask i) = THE i
# |sIconMask _ = NULL
#
# fun selWinIconMask w = accMaybe sIconMask (get_window_traits w)
#
# fun sIconName (WinIconName i) = THE i
# |sIconName _ = NULL
#
# fun selWinIconName w = accMaybe sIconName (get_window_traits w)
fun s_max_size (WIDE_HIGH_MAX (c as _)) => THE c;
s_max_size _ => NULL;
end;
fun sel_window_max_size w
=
acc_maybe s_max_size (get_window_traits w);
fun s_min_size (WIDE_HIGH_MIN (c as _)) => THE c;
s_min_size _ => NULL;
end;
fun sel_window_min_size w
=
acc_maybe s_min_size (get_window_traits w);
fun s_position_from (WINDOW_POSITIONED_BY i) => THE i;
s_position_from _ => NULL;
end;
fun sel_window_position_from w
=
acc_maybe s_position_from (get_window_traits w);
fun s_size_from (WINDOW_SIZED_BY i) => THE i;
s_size_from _ => NULL;
end;
fun sel_window_size_from w
=
acc_maybe s_size_from (get_window_traits w);
fun s_title (WINDOW_TITLE i) => THE i;
s_title _ => NULL;
end;
fun sel_window_title w
=
acc_maybe s_title (get_window_traits w);
fun s_group (WINDOW_GROUP gl) => THE gl;
s_group _ => NULL;
end;
fun sel_window_group w
=
acc_maybe s_group (get_window_traits w);
fun s_transient (TRANSIENTS_LEADER i) => THE i;
s_transient _ => NULL;
end;
fun sel_window_transient w
=
acc_maybe s_transient (get_window_traits w);
fun s_over (OMIT_WINDOW_MANAGER_DECORATIONS b) => THE b;
s_over _ => NULL;
end;
fun sel_window_override w
=
acc_maybe s_over (get_window_traits w);
fun show_pos i
=
if (i >= 0) ("+" + (string_util::from_int i));
else ("-" + (string_util::from_int (i * -1)));
fi;
fun pack_window_conf window (WINDOW_ASPECT_RATIO_LIMITS (x1, y1, x2, y2))
=>
"wm aspect " + window + " " + string_util::from_int x1 + " " + string_util::from_int y1
+ " " + string_util::from_int x2 + " " + string_util::from_int y2 + "\n";
pack_window_conf window (WIDE_HIGH_X_Y (NULL, THE (x, y)))
=>
"wm geometry " + window + " =" + show_pos x + show_pos y + "\n";
pack_window_conf window (WIDE_HIGH_X_Y (THE (w, h), NULL))
=>
"wm geometry " + window + " =" + string_util::from_int w + "x" + string_util::from_int h + "\n";
pack_window_conf window (WIDE_HIGH_X_Y (THE (w, h), THE (x, y)))
=>
"wm geometry " + window + " ="
+ string_util::from_int w + "x" + string_util::from_int h + show_pos x + show_pos y + "\n";
pack_window_conf window (WIDE_HIGH_MAX (w, h))
=>
"wm maxsize " + window + " " + string_util::from_int w + " " + string_util::from_int h + "\n";
pack_window_conf window (WIDE_HIGH_MIN (w, h))
=>
"wm minsize " + window + " " + string_util::from_int w + " " + string_util::from_int h + "\n";
pack_window_conf window (WINDOW_POSITIONED_BY USER)
=>
"wm positionfrom " + window + " user" + "\n";
pack_window_conf window (WINDOW_POSITIONED_BY PROGRAM)
=>
"wm positionfrom " + window + " program" + "\n";
pack_window_conf window (WINDOW_SIZED_BY USER)
=>
"wm sizefrom " + window + " user" + "\n";
pack_window_conf window (WINDOW_SIZED_BY PROGRAM)
=>
"wm sizefrom " + window + " program" + "\n";
pack_window_conf window (WINDOW_TITLE t)
=>
"wm title " + window + " \"" + string_util::adapt_string t + "\"" + "\n";
pack_window_conf window (WINDOW_GROUP gl)
=>
if (is_init_window gl) "wm group " + window + " ." + "\n";
else "wm group " + window + " ." + gl + "\n";
fi;
pack_window_conf window (TRANSIENTS_LEADER NULL)
=>
"wm transient " + window + "\n";
pack_window_conf window (TRANSIENTS_LEADER (THE w))
=>
if (is_init_window w ) "wm transient " + window + " ." + "\n";
else "wm transient " + window + " ." + w + "\n";
fi;
pack_window_conf window (OMIT_WINDOW_MANAGER_DECORATIONS TRUE)
=>
"wm overrideredirect " + window + " true" + "\n";
pack_window_conf window (OMIT_WINDOW_MANAGER_DECORATIONS FALSE)
=>
"wm overrideredirect " + window + " false" + "\n";
end;
end;
};