PreviousUpNext

15.4.1251  src/lib/tk/src/fonts.pkg

## 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 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 (fn (b: Bool, it: Bool) =  ((*(.normal_font (font_config)) + "-*-*-*-*"))),
           typewriter_g'  => REF (fn (b: Bool, it: Bool) =  ((*(.typewriter  (font_config)) + "-*-*-*-*"))),
           sans_serif_g'  => REF (fn (b: Bool, it: Bool) =  ((*(.sans_serif  (font_config)) + "-*-*-*-*"))),
           symbol_g'      => REF (fn (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) 
                    
                     [] before {   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
            (fn (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 :=  (fn (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 (fn (b, it, p: Int) = (( (*(.normal_g'    (init_config))) (b, it) ) + "-*-*-*-*-*-*-*-*" )),
            typewriter_g  => REF (fn (b, it, p: Int) = (( (*(.typewriter_g'(init_config))) (b, it) ) + "-*-*-*-*-*-*-*-*" )),
            sans_serif_g  => REF (fn (b, it, p: Int) = (( (*(.sans_serif_g'(init_config))) (b, it) ) + "-*-*-*-*-*-*-*-*" )),
            symbol_g      => REF (fn (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 := (fn (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 := (fn (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") 

        };
        
};



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext