## fonts.pkg
## Author: cxl
## (C) 1997, Bremen Institute for Safe Systems, Universitaet Bremen
# Compiled by:
# src/lib/tk/src/tk.sublib# **************************************************************************
# Fonts for tk.
# **************************************************************************
# **************************************************************************
# This module tries to provide a wee bit more abstract approach to
# specifying fonts than as in "-*-bollocks-*-*-37-" X-style font
# description.
# **************************************************************************
### "We are all in the gutter,
### but some of us are
### looking at the stars."
###
### -- Oscar Wilde
package fonts
: (weak) Fonts # Fonts is from src/lib/tk/src/fonts.api{
include package basic_utilities;
my
font_config
=
{ normal_font => REF "-*-courier",
typewriter => REF "-misc-fixed", # "-*-lucidatypewriter",
sans_serif => REF "-*-helvetica",
symbol => REF "-*-symbol",
base_size => REF 12,
exact_match => REF TRUE,
resolution => REF 75
};
Font_Trait
=
BOLD | ITALIC |
TINY | SMALL | NORMAL_SIZE | LARGE | HUGE |
SCALE Float;
my
init_config
=
{ normal_g' => REF (\\ (b: Bool, it: Bool) = ((*(.normal_font (font_config)) + "-*-*-*-*"))),
typewriter_g' => REF (\\ (b: Bool, it: Bool) = ((*(.typewriter (font_config)) + "-*-*-*-*"))),
sans_serif_g' => REF (\\ (b: Bool, it: Bool) = ((*(.sans_serif (font_config)) + "-*-*-*-*"))),
symbol_g' => REF (\\ (b: Bool, it: Bool) = ((*(.symbol (font_config)) + "-*-*-*-*")))
};
Font
=
XFONT String
| NORMAL_FONT List( Font_Trait )
| TYPEWRITER List( Font_Trait )
| SANS_SERIF List( Font_Trait )
| SYMBOL List( Font_Trait );
# should have more here ...
# selector function
fun sel_font_conf (NORMAL_FONT c) => c;
sel_font_conf (TYPEWRITER c) => c;
sel_font_conf (SANS_SERIF c) => c;
sel_font_conf (SYMBOL c) => c;
sel_font_conf (XFONT _) => [];
end; # should raise exception ?!
# update function
fun upd_font_conf ((NORMAL_FONT _), c) => NORMAL_FONT c;
upd_font_conf ((TYPEWRITER _), c) => TYPEWRITER c;
upd_font_conf ((SANS_SERIF _), c) => SANS_SERIF c;
upd_font_conf ((SYMBOL _), c) => SYMBOL c;
upd_font_conf ((XFONT str), _) => XFONT str; # should raise exception ?!
end;
fun is_bold BOLD => TRUE;
is_bold _ => FALSE;
end;
fun is_italic ITALIC => TRUE;
is_italic _ => FALSE;
end;
exception NO_SIZE;
fun size_of TINY => 10.0 / 14.0;
size_of SMALL => 12.0 / 14.0;
size_of NORMAL_SIZE => 14.0 / 14.0;
size_of LARGE => 18.0 / 14.0;
size_of HUGE => 24.0 / 14.0;
size_of (SCALE s) => s;
size_of _ => raise exception NO_SIZE;
end;
fun descr_from_init_config family TRUE TRUE => family + "-bold-o-*-*";
descr_from_init_config family TRUE FALSE => family + "-bold-r-*-*";
descr_from_init_config family FALSE TRUE => family + "-medium-o-*-*";
descr_from_init_config family FALSE FALSE => family + "-medium-r-*-*";
end;
# This should be the only reference to the name of the lsfonts utility
#
fun get_testfont_path lib
=
winix__premicrothread::path::make_path_from_dir_and_file { dir=>lib, file=>"lsfonts"};
fun split_fields str
=
tl (string::fields (eq '-') str);
#
# Get a list of the descriptions of all fonts.
# We split up the descriptions into the constituting fields separated
# by dashes.
fun get_all_fonts lib
=
{ my (si, so) = file_util::execute (get_testfont_path lib, []);
fun read_em si
=
if (file::end_of_stream si)
[] then { file::close_input si;
file::close so;
};
else
string_or_none
=
file::read_line si;
string
=
case string_or_none
#
THE string => string;
NULL => "";
esac; /* 2006-11-27 CrT Quick hack to get it working -- what's right here? XXX BUGGO FIXME */
(split_fields string) . (read_em si);
fi;
read_em si;
};
# A pattern is matched by a description, if they are equal or the
# pattern is a "*" or empty; this has to hold for all fields of
# the font, although the pattern can be shorter than the description,
# in that case the rest of the description is irrelevant and always
# matches.
#
fun descr_matches pat desc
=
paired_lists::all
(\\ (p, d) = p==d or p=="*" or (p==""))
(pat, desc);
# Check whether a font description can be found.
#
fun check_font (fonts, fnt_str)
=
{ fnt_flds = split_fields fnt_str;
list::exists (descr_matches fnt_flds) fonts;
};
fun add_one_font (fonts, fr, fam)
=
{ fstr = descr_from_init_config fam;
fun add_one b it
=
if (check_font (fonts, fstr b it))
fr' = *fr;
fr := (\\ (b', it')
=
if (b == b' and it == it')
fstr b it;
else
fr' (b', it');
fi);
else
debug::warning("Could not find font \"" + (fstr b it) +
"\"; installing default.");
fi;
add_one TRUE TRUE;
add_one TRUE FALSE;
add_one FALSE TRUE;
add_one FALSE FALSE;
};
my
final_config
=
{ normal_g => REF (\\ (b, it, p: Int) = (( (*(.normal_g' (init_config))) (b, it) ) + "-*-*-*-*-*-*-*-*" )),
typewriter_g => REF (\\ (b, it, p: Int) = (( (*(.typewriter_g'(init_config))) (b, it) ) + "-*-*-*-*-*-*-*-*" )),
sans_serif_g => REF (\\ (b, it, p: Int) = (( (*(.sans_serif_g'(init_config))) (b, it) ) + "-*-*-*-*-*-*-*-*" )),
symbol_g => REF (\\ (b, it, p: Int) = (( (*(.symbol_g' (init_config))) (b, it) ) + "-*-*-*-*-*-*-*-*" ))
};
fun descr_from_final_config fam b it size
=
(*fam (b, it)) + "-" + (int::to_string size) + "-*-*-*-*-*-*-*";
fun descr_from_final_config_test fam b it size
=
# wenn man den vollen String, wie in descrFromFinalConfig,
# zum Testen benutzt, funktioniert xlsfonts leider nicht.
#
(*fam (b, it)) + "-" + (int::to_string size) + "-*";
fun add_one_font_size (fonts, fr, ini_fr)
=
{ fstr = descr_from_final_config (ini_fr);
fstrt = if (*(.exact_match (font_config)))
descr_from_final_config_test (ini_fr);
else
descr_from_final_config (ini_fr);
fi;
fun add_default fr
=
{ fr' = *fr;
fr := (\\ (b, it, size) = ( *ini_fr (b, it)) + "-*-*-*-*-*-*-*-*");
};
fun find_one b it size []
=>
NULL;
find_one b it size (x . xl)
=>
if (check_font (fonts, fstrt b it (size+x)))
THE (fstr b it (size+x));
else
find_one b it size xl;
fi;
end;
fun add_one b it size_in dlst
=
{ size = (float::round (float::(*) (float::from_int(*(.base_size (font_config))), (size_of size_in))));
str = find_one b it size dlst;
case str
NULL
=>
debug::warning("Could not find font \"" + (fstr b it size) + "\"; installing default.");
THE fs
=>
{ fr' = *fr;
fr := (\\ (b', it', size')
=
if (b == b' and it == it' and size == size')
debug::print 5 ("Found FontSize: " + (fstr b' it' size') + "\n");
fs;
else
debug::print 5 ("Descending FontSize: " + (fstr b' it' size') + "\n");
(fr')(b', it', size');
fi);
};
esac;
};
# addDefault fr;
add_one TRUE TRUE TINY [0,-1, 1];
add_one TRUE FALSE TINY [0,-1, 1];
add_one FALSE TRUE TINY [0,-1, 1];
add_one FALSE FALSE TINY [0,-1, 1];
add_one TRUE TRUE SMALL [0,-1, 1,-2, 2];
add_one TRUE FALSE SMALL [0,-1, 1,-2, 2];
add_one FALSE TRUE SMALL [0,-1, 1,-2, 2];
add_one FALSE FALSE SMALL [0,-1, 1,-2, 2];
add_one TRUE TRUE LARGE [0,-1, 1,-2, 2, 3];
add_one TRUE FALSE LARGE [0,-1, 1,-2, 2, 3];
add_one FALSE TRUE LARGE [0,-1, 1,-2, 2, 3];
add_one FALSE FALSE LARGE [0,-1, 1,-2, 2, 3];
add_one TRUE TRUE HUGE [0,-1, 1,-2, 2, 3, 4, 5];
add_one TRUE FALSE HUGE [0,-1, 1,-2, 2, 3, 4, 5];
add_one FALSE TRUE HUGE [0,-1, 1,-2, 2, 3, 4, 5];
add_one FALSE FALSE HUGE [0,-1, 1,-2, 2, 3, 4, 5];
add_one TRUE TRUE NORMAL_SIZE [0,-1, 1,-2, 2];
add_one TRUE FALSE NORMAL_SIZE [0,-1, 1,-2, 2];
add_one FALSE TRUE NORMAL_SIZE [0,-1, 1,-2, 2];
add_one FALSE FALSE NORMAL_SIZE [0,-1, 1,-2, 2];
};
fun descr_from_config (family, conf)
=
{ wght = (list::exists is_bold ) conf;
slant= (list::exists is_italic) conf;
size =
{ fun size_fold (c, rest)
=
(size_of c)
except
NO_SIZE = rest;
fold_backward size_fold 1.000 conf;
};
pxlsz = (float::round(
float::(*) (float::from_int(*(.base_size (font_config))), size)));
str = (*(family (final_config))) (wght, slant, pxlsz);
debug::print 5 ("descrFromConfig: " + str + "\n");
str;
};
fun font_descr (XFONT str) => str;
font_descr (NORMAL_FONT conf) => descr_from_config (.normal_g, conf);
font_descr (TYPEWRITER conf) => descr_from_config (.typewriter_g, conf);
font_descr (SANS_SERIF conf) => descr_from_config (.sans_serif_g, conf);
font_descr (SYMBOL conf) => descr_from_config (.symbol_g, conf);
end;
fun init lib
=
# This should
# - check if all possible fonts exists
# - if not, find some `close matches'. This is particularly
# important for the size.
# - and remember them for future reference.
{
normal = *(.normal_font (font_config));
typewr = *(.typewriter (font_config));
sans = *(.sans_serif (font_config));
symbol = *(.symbol (font_config));
fonts = get_all_fonts lib;
debug::print 5 ("Found " + (int::to_string (length fonts)) + " fonts.");
file::write (file::stdout, "Configuring fonts-- this may take a wee while...\n");
add_one_font (fonts, .normal_g'(init_config), normal);
add_one_font (fonts, .typewriter_g'(init_config), typewr);
add_one_font (fonts, .sans_serif_g'(init_config), sans);
add_one_font (fonts, .symbol_g'(init_config), symbol);
debug::print 5 (((*(.normal_g'(init_config)))(TRUE, true) ) + "\n");
debug::print 5 (((*(.normal_g'(init_config)))(TRUE, FALSE) ) + "\n");
debug::print 5 (((*(.normal_g'(init_config)))(FALSE, TRUE) ) + "\n");
debug::print 5 (((*(.normal_g'(init_config)))(FALSE, false) ) + "\n");
debug::print 5 (((*(.typewriter_g'(init_config)))(TRUE, true) ) + "\n");
debug::print 5 (((*(.typewriter_g'(init_config)))(TRUE, FALSE) ) + "\n");
debug::print 5 (((*(.typewriter_g'(init_config)))(FALSE, TRUE) ) + "\n");
debug::print 5 (((*(.typewriter_g'(init_config)))(FALSE, false) ) + "\n");
debug::print 5 (((*(.sans_serif_g'(init_config)))(TRUE, true) ) + "\n");
debug::print 5 (((*(.sans_serif_g'(init_config)))(TRUE, FALSE) ) + "\n");
debug::print 5 (((*(.sans_serif_g'(init_config)))(FALSE, TRUE) ) + "\n");
debug::print 5 (((*(.sans_serif_g'(init_config)))(FALSE, false) ) + "\n");
debug::print 5 (((*(.symbol_g'(init_config)))(TRUE, true) ) + "\n");
debug::print 5 (((*(.symbol_g'(init_config)))(TRUE, FALSE) ) + "\n");
debug::print 5 (((*(.symbol_g'(init_config)))(FALSE, TRUE) ) + "\n");
debug::print 5 (((*(.symbol_g'(init_config)))(FALSE, false) ) + "\n");
add_one_font_size (fonts, .normal_g (final_config), .normal_g' (init_config));
add_one_font_size (fonts, .typewriter_g (final_config), .typewriter_g' (init_config));
add_one_font_size (fonts, .sans_serif_g (final_config), .sans_serif_g' (init_config));
add_one_font_size (fonts, .symbol_g (final_config), .symbol_g' (init_config));
# file::write (file::stdout, "Fonts configured.\n")
};
};