15.4.1369  src/lib/x-kit/widget/fancy/graphviz/font-family-cache.pkg

## font-family-cache.pkg

# Compiled by:
#     src/lib/x-kit/widget/xkit-widget.sublib

stipulate
    include threadkit;                                  # threadkit             is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg
    #
    package f8b =  eight_byte_float;                    # eight_byte_float      is from   src/lib/std/eight-byte-float.pkg
    package xc  =  xclient;                             # xclient               is from   src/lib/x-kit/xclient/xclient.pkg
    package xtr =  xlogger;                             # xlogger               is from   src/lib/x-kit/xclient/pkg/stuff/xlogger.pkg
    #
    package wg  =  widget;                              # widget                is from   src/lib/x-kit/widget/basic/widget.pkg
herein

    package   font_family_cache
    :         Font_Family_Cache                         # Font_Family_Cache     is from   src/lib/x-kit/widget/fancy/graphviz/font-family-cache.api
    {
        default_font_size =  dotgraph_to_planargraph::default_font_size;                                #  points 

        default_font_family
            =
            "-adobe-times-medium-r-normal--%d-*-*-*-p-*-iso8859-1";

        Font_Family_Cache
            = 
            FONT_FAMILY_CACHE
              {  plea_slot:  Mailslot( ( Oneshot_Maildrop(  Null_Or(xc::Font)), # Reply slot
                                         Int                                    # Requested fontsize
                                     ) )
              };

        fun make_font_family_cache
                root_window                             # Fonts are a per-X-server thing, this effectively specifies which X server.
                font_family                             # A string like "-adobe-times-medium-r-normal--%d-*-*-*-p-*-iso8859-1"
            =
            {   plea_slot  =  make_mailslot ();

                open_font
                    =
                    xc::open_font  (wg::xsession_of  root_window);
                                                                    # Sfprintf  is from   src/lib/src/sfprintf.api
                                                                    # sfprintf  is from   src/lib/src/sfprintf.pkg
                fun make_font_name size
                    =
                    sfprintf::sprintf' font_family [sfprintf::INT size];


                fun load_font 0
                        =>
                        NULL;

                    load_font size
                        =>
                        (THE (open_font (make_font_name size)))
                        except
                            xc::FONT_NOT_FOUND
                                =
                                {   print ("Font size" + (int::to_string size) + " : not found\n");
                                    load_font (size - 1);
                                };
                end;


                fun do_plea (fonts, (reply_1shot, requested_font_size))
                    =
                    {   size =  f8b::truncate ((f8b::from_int requested_font_size) * 1.4);
                        #
                        case (list::find (fn (s, _) =  s == size) fonts)
                            #
                            THE (_, f)
                                =>
                                {   set (reply_1shot, THE f);
                                    fonts;
                                };

                            NULL => 
                                case (load_font size)
                                    #
                                    NULL     =>  {  set (reply_1shot, NULL    );                                fonts;  };
                                    THE font =>  {  set (reply_1shot, THE font);  (requested_font_size, font) ! fonts;  };
                                esac;
                        esac;
                    };

                # Our argument here is our cache state,
                # a list of (fontsize, font) pairs:
                #
                fun plea_loop fonts
                    =
                    plea_loop (
                        #
                        do_plea (fonts, take plea_slot)
                    );

                xtr::make_thread  "font_family_cache"  .{
                    #
                    plea_loop [];
                };

                FONT_FAMILY_CACHE { plea_slot };
            };                                                  # fun make_font_family_cache

        fun get_font (FONT_FAMILY_CACHE { plea_slot }) size
            =
            {   reply_1shot =   make_oneshot_maildrop ();
                give (plea_slot, (reply_1shot, size));
                get reply_1shot;
            };
    };

end;