home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / gprocs / xbfont.icn < prev    next >
Text File  |  2001-05-02  |  11KB  |  323 lines
  1. ############################################################################
  2. #
  3. #    File:     xbfont.icn
  4. #
  5. #    Subject:  Procedures for X font selection
  6. #
  7. #    Author:   Gregg M. Townsend
  8. #
  9. #    Date:     May 2, 2001
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    BestFont(W, s, ...) generates X-windows font names matching a
  18. #    given specification, beginning with the closest match.  The
  19. #    ranking algorithm is similar to that used in Font() but it is
  20. #    not identical.
  21. #
  22. ############################################################################
  23. #
  24. #      BestFont(window, spec, ...) returns the name of whichever available
  25. #   X-Windows font most closely matches the given specification.  Note that
  26. #   matching is done using a slightly different algorithm from that of the
  27. #   Icon runtime system; this procedure preceded Icon's font selection
  28. #   implementation and served as a prototype.
  29. #
  30. #      The font specification is one or more strings containing whitespace-
  31. #   or comma-separated tokens.  Tokens are case-insensitive.  There are
  32. #   three kinds of tokens.
  33. #      A token having the form of an integer specifies the desired "pixel
  34. #   size" (height).  If no size is included, a target size of 14 is used.
  35. #      An unrecognized token is taken as a substring of the desired X font
  36. #   name.  Family names, weights, and other such factors are specified this
  37. #   way.
  38. #      Certain tokens are recognized and handled specially:
  39. #         m  mono  monospaced
  40. #         p  prop  proportional
  41. #         r  roman
  42. #         i  italic
  43. #         o  oblique
  44. #         s  sans  sans-serif  sansserif
  45. #   These are turned into search strings of a particular form.  For example,
  46. #   "roman" and "r" specify the search string "-r-".
  47. #
  48. #      The "best match" to a given specification is calculated by reviewing
  49. #   all the available fonts, assigning a score to each, then choosing the
  50. #   one with the highest value.  There are several aspects of scoring.
  51. #      Size is the most important factor.  A tuned font of the correct size
  52. #   gets the maximum score.  Nearby sizes receive partial credit, with
  53. #   an undersized font preferred over an oversized font.  Scalable fonts
  54. #   are also recognized, but a tuned font of the correct or nearly-correct
  55. #   size gets a higher score.
  56. #      Each successful substring match increases the score, whether the
  57. #   test string comes from an unrecognized token or a special keyword.
  58. #   Earlier tokens receive slightly more weight than later ones.
  59. #      All tokens need not match.  The string "lucida gill sans 18"
  60. #   is perfectly reasonable; it specifies a preference for Lucida Sans
  61. #   over Gill Sans by the position of the tokens, but will match either.
  62. #      Ties are broken by giving slight preferences for normal weight,
  63. #   no slant, normal width, and ASCII ("iso8859") encoding.  A slight
  64. #   penalty is assessed for "typewriter" fonts.  Oblique fonts receive
  65. #   partial credit for matching "italic" requests, and vice versa.
  66. #      The scoring function can be altered by assigning values to certain
  67. #   global variables.  See XBF_defaults() for a commented list of these.
  68. #
  69. #      For a scalable font, the returned value is a string specifying an
  70. #   instance of the font scaled to the target size.  For large sizes, the
  71. #   scaling time may be noticeable when the font is used.
  72. #
  73. #      BestFont() is actually a generator that produces the entire list
  74. #   of available fonts in order of preference.  RankFonts(w, spec, ...)
  75. #   is similar to BestFont but produces a sequence of two-element records,
  76. #   where result.str is the font name and result.val is its score.  For
  77. #   either of these, a list of X font names can be passed instead of a
  78. #   window.
  79. #
  80. #      There is some startup cost the first time BestFont is called; it
  81. #   opens a pipe to the "xlsfonts" program and reads the output.  Results
  82. #   are cached, so this overhead is only incurred once.
  83. #
  84. #      Examples:
  85. #         Font(w, BestFont(w, "times bold italic 20"))
  86. #         s := BestFont(w, size, family, "italic")
  87. #
  88. ############################################################################
  89. #
  90. #  Requires:  Version 9 graphics under Unix
  91. #
  92. ############################################################################
  93.  
  94.  
  95. record XBF_rec(str, val)
  96.  
  97. global XBF_wantsize        # requested font size
  98. global XBF_sizval        # array of scores indexed by actual font size
  99.  
  100.  
  101. # globals used for tuning the scoring function; see XBF_defaults()
  102.  
  103. global XFW_defsize, XFW_size, XFW_maxover, XFW_maxunder, XFW_scaled
  104. global XFW_spacing, XFW_slant, XFW_aslant, XFW_sans
  105. global XFW_default, XFW_exact, XFW_posn, XFW_tiebreakers
  106.  
  107.  
  108. #  BestFont(window, spec...) - generate ranked sequence of font names
  109.  
  110. procedure BestFont(args[])        #: generate best X fonts
  111.    suspend (RankFonts ! args) . str
  112. end
  113.  
  114.  
  115. #  XRankFont(window, spec...) - generate sequence of (name,score) tuples
  116.  
  117. procedure RankFonts(w, args[])        #: generate scores for X fonts
  118.    local tokens, cklist, sclist, fspec, ranks, r
  119.  
  120.    if type(w) ~== "window" & type(w) ~== "list" then {
  121.       push(args, w)
  122.       w := &window
  123.       }
  124.    XBF_defaults()            # set default values
  125.    XBF_wantsize := XFW_defsize        # set target size to default
  126.    tokens := XBF_tokenlist(args)    # break args into list of tokens
  127.    cklist := XBF_weights(tokens)    # get list of (substring,weight)s
  128.    XBF_sizval := XBF_sizes(XBF_wantsize) # build array for scoring sizes
  129.  
  130.    # make a list of (fontname,score) tuples, and sort it
  131.    sclist := []
  132.    every fspec := XBF_fontlist(w) do
  133.       put(sclist, XBF_rec(fspec, XBF_eval(fspec, cklist)))
  134.    ranks := sortf(sclist, 2)
  135.  
  136.    # generate results from hightest to lowest rank
  137.    while r := pull(ranks) do
  138.       suspend XBF_rec(XBF_spec(r.str, XBF_wantsize), r.val)
  139. end
  140.  
  141.  
  142. #  XBF_defaults() - assign default values to any unset tuning parameters
  143.  
  144. procedure XBF_defaults()
  145.    /XFW_defsize := 14        # default size if unspecified
  146.    /XFW_size := 1000        # points for matching size exactly
  147.    /XFW_maxover := 30        # max allowable overage on size (per cent)
  148.    /XFW_maxunder := 60        # max allowable shortfall on size (per cent)
  149.    /XFW_scaled := 800        # points for matching size with scaled font
  150.  
  151.    /XFW_spacing := 500        # points for matching prop/mono spacing
  152.    /XFW_slant := 500        # points for matching slant
  153.    /XFW_aslant := 300        # points for approx slant (oblique : italic)
  154.    /XFW_sans := 500        # points for matching "sans" spec
  155.  
  156.    /XFW_exact := 1100        # points for matching entire font name
  157.    /XFW_default := 500        # points for matching unrecognized token
  158.    /XFW_posn := 10        # points for position in request list
  159.  
  160.    /XFW_tiebreakers := [    # "tiebreaker" strings always scored
  161.       XBF_rec("-normal-", 1),        # prefer normal width
  162.       XBF_rec("-medium-", 1),        # prefer medium weight
  163.       XBF_rec("-r-", 2),        # upright slant is even more important
  164.       XBF_rec("-iso8859-", 1),        # prefer ASCII, not symbol/kana/etc
  165.       XBF_rec("typewriter", -4)]    # penalize typewriter fonts
  166.  
  167.    return
  168. end
  169.  
  170.  
  171. #  XBF_tokenlist(args) -- turn list of args into list of tokens
  172.  
  173. procedure XBF_tokenlist(args)
  174.    local tokens
  175.  
  176.    tokens := []
  177.    every map(trim(!args)) ? repeat {
  178.       tab(many(' \t,'))
  179.       if pos(0) then
  180.          break
  181.       put(tokens, tab(upto(' \t,') | 0))
  182.       }
  183.    return tokens
  184. end
  185.  
  186.  
  187. #  XBF_weights(tokens) -- turn tokens into list of substrings and weights
  188. #
  189. #  Also saves the size value in the global XBF_wantsize.
  190.  
  191. procedure XBF_weights(tokens)
  192.    local cklist, tk, pf
  193.  
  194.    cklist := []
  195.    pf := *tokens * XFW_posn
  196.    every tk := !tokens do {
  197.       if not (XBF_wantsize := integer(tk)) then {
  198.          pf -:= XFW_posn
  199.          case tk of {
  200.             "m" | "mono" | "monospaced":
  201.                every put(cklist, XBF_rec("-m-" | "-c-", XFW_spacing + pf))
  202.             "p" | "prop" | "proportional":
  203.                put(cklist, XBF_rec("-p-", XFW_spacing + pf))
  204.             "r" | "roman":
  205.                put(cklist, XBF_rec("-r-", XFW_slant + pf))
  206.             "i" | "italic": {
  207.                put(cklist, XBF_rec("-i-", XFW_slant + pf))
  208.                put(cklist, XBF_rec("-o-", XFW_aslant + pf))
  209.                }
  210.             "o" | "oblique": {
  211.                put(cklist, XBF_rec("-o-", XFW_slant + pf))
  212.                put(cklist, XBF_rec("-i-", XFW_aslant + pf))
  213.                }
  214.             "s" | "sans" | "sans-serif" | "sansserif":
  215.                put(cklist, XBF_rec("sans", XFW_sans + pf))
  216.             default:
  217.                put(cklist, XBF_rec(tk, XFW_default + pf))
  218.             }
  219.          }
  220.       }
  221.    every put(cklist, !XFW_tiebreakers)
  222.    return cklist
  223. end
  224.  
  225.  
  226. #  XBF_sizes(wantsize) -- build array of scores for evaluating font sizes
  227.  
  228. procedure XBF_sizes(wantsize)
  229.    local l, sz, diff, score, maxunder, maxover
  230.  
  231.    l := [XFW_scaled]            # initial entry scores scaled fonts
  232.  
  233.    # set scores for undersized fonts
  234.    maxunder := (XFW_maxunder / 100.0) * wantsize
  235.    every sz := 1 to wantsize-1 do {
  236.       diff := wantsize - sz
  237.       score := integer(XFW_size * (1 - diff / maxunder))
  238.       score <:= 0
  239.       put(l, score)
  240.       }
  241.  
  242.    # set scores for correct and oversized fonts
  243.    maxover := (XFW_maxover / 100.0) * wantsize
  244.    repeat {
  245.       sz +:= 1
  246.       diff := sz - wantsize
  247.       score := integer(XFW_size * (1 - diff / maxover))
  248.       if score <= 0 then
  249.          break            # quit when too big to be useful
  250.       put(l, score)
  251.       }
  252.  
  253.    return l
  254. end
  255.  
  256.  
  257. # XBF_fontlist(w) - generate list of font names for window (or list) w
  258.  
  259. procedure XBF_fontlist(w)
  260.    static fontlist
  261.    local pipe
  262.  
  263.    if type(w) == "list" then
  264.       suspend !w
  265.    else {
  266.       if /fontlist then {
  267.          fontlist := []
  268.          pipe := open("xlsfonts", "rp") | stop("can't open xlsfonts pipe")
  269.          while put(fontlist, trim(read(pipe)))
  270.          close(pipe)
  271.          }
  272.       suspend !fontlist
  273.       }
  274. end
  275.  
  276.  
  277. #  XBF_eval(fontname, cklist) -- evaluate the score of an X font name
  278.  
  279. procedure XBF_eval(fontname, cklist)
  280.    local t, r
  281.  
  282.    # find the size and look up its score in the XBF_sizval array
  283.    fontname ? {
  284.       every 1 to 7 do
  285.          tab(upto('-')) & move(1)
  286.       t := XBF_sizval [1 + integer(tab(upto('-')))] | 0
  287.    }
  288.  
  289.    # add the corresponding value for every substring that matches
  290.    every r := !cklist do
  291.       if find(r.str, fontname) then
  292.          if r.str == fontname then
  293.             t +:= XFW_exact        # high score for matching entire name
  294.          else
  295.             t +:= r.val            # else give specified value
  296.    return t
  297. end
  298.  
  299.  
  300. #  XBF_spec(fontname, size) -- return the correct form of an X font name
  301. #
  302. #  This is just the name itself except in the case of scalable fonts.
  303.  
  304. procedure XBF_spec(fontname, size)
  305.    local s
  306.  
  307.    fontname ? {
  308.       s := tab(find("-0-0-")) | return fontname    # return if not scalable
  309.       move(5)                    # skip pixel size, point size
  310.       tab(upto('-')) & move(1)            # skip x-resolution
  311.       tab(upto('-')) & move(1)            # skip y-resolution
  312.       s ||:= "-"
  313.       s ||:= size                # spec pixel size
  314.       s ||:= "-*-*-*-"                # wildcard ptsize & resolutions
  315.       s ||:= tab(upto('-'))            # copy spacing field
  316.       s ||:= move(1)
  317.       tab(upto('-'))                # skip average width
  318.       s ||:= "*"
  319.       s ||:= tab(0)                # copy the rest
  320.       }
  321.    return s
  322. end
  323.