1 --------------------------------------------------------------------------------
    2 -- Copyright 1994 by Peter Thiemann
    3 -- $Log: Fonts.hs,v $
    4 -- Revision 1.7  2000/01/24 17:14:26  simonmar
    5 -- Undo fromInt changes: already converted to fromIntegral.
    6 --
    7 -- Revision 1.6  1999/12/08 09:56:37  simonmar
    8 -- -syslib updates for new libraries.
    9 --
   10 -- Revision 1.5  1999/11/26 10:29:54  simonpj
   11 -- fromInt wibble
   12 --
   13 -- Revision 1.4  1999/09/14 10:18:24  simonmar
   14 -- Replace all instances of fromInt in nofib with fromIntegral.
   15 --
   16 -- We generate the same code in most cases :-)
   17 --
   18 -- Revision 1.3  1997/03/14 08:08:05  simonpj
   19 -- Major update to more-or-less 2.02
   20 --
   21 -- Revision 1.2  1996/07/25 21:23:54  partain
   22 -- Bulk of final changes for 2.01
   23 --
   24 -- Revision 1.1  1996/01/08 20:02:33  partain
   25 -- Initial revision
   26 --
   27 -- Revision 1.1  1993/08/31  12:31:32  thiemann
   28 -- Initial revision
   29 --
   30 -- Revision 1.1  1993/08/31  12:31:32  thiemann
   31 -- Initial revision
   32 --
   33 -- $Locker:  $
   34 --------------------------------------------------------------------------------
   35 
   36 module Fonts (FONT, makeFont, fontDescender, stringWidth, stringHeight, fontName, fontScale, noFont)
   37 where
   38 
   39 import Char--1.3
   40 
   41 -- not in 1.3
   42 readDec :: (Integral a) => ReadS a
   43 readDec = readInt 10 isDigit (\d -> ord d - ord_0)
   44 
   45 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
   46 readInt radix isDig digToInt s =
   47     [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
   48         | (ds,r) <- nonnull isDig s ]
   49 
   50 ord_0 :: Num a => a
   51 ord_0 = fromIntegral (ord '0')
   52 
   53 nonnull                 :: (Char -> Bool) -> ReadS String
   54 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
   55 
   56 readSigned :: (Real a) => ReadS a -> ReadS a
   57 readSigned readPos = readParen False read'
   58                      where read' r  = read'' r ++
   59                                       [(-x,t) | ("-",s) <- lex r,
   60                                                 (x,t)   <- read'' s]
   61                            read'' r = [(n,s)  | (str,s) <- lex r,
   62                                                 (n,"")  <- readPos str]
   63 
   64 
   65 
   66 data FONT = FONT String Int Int (String -> Int)
   67 
   68 instance Eq FONT where
   69   FONT s1 m1 n1 f1 == FONT s2 m2 n2 f2 = s1 == s2 && m1 == m2 && n1 == n2
   70 
   71 noFont = FONT "" 0 0 (const 0)
   72 
   73 data Afm = Descender Int
   74          | CharMetric Int    Int    String   Int Int Int Int
   75 --         CharMetric charNo charWX charName llx lly urx ury
   76 --       deriving Text
   77 
   78 fontName :: FONT -> String
   79 fontName (FONT name _ _ _) = name
   80 
   81 fontScale :: FONT -> Int
   82 fontScale (FONT _ scale _ _) = scale
   83 
   84 fontDescender :: FONT -> Int
   85 fontDescender (FONT _ _ theDescender _) = theDescender
   86 
   87 stringWidth :: FONT -> String -> Int
   88 stringWidth (FONT _ _ _ theStringWidth) = theStringWidth
   89 
   90 stringHeight :: FONT -> String -> Int
   91 stringHeight (FONT _ scale _ _) _ = scale * 100
   92 
   93 makeFont :: String -> Int -> String -> FONT
   94 makeFont fontName fontScale fontAfm =
   95         FONT fontName fontScale theDescender
   96         ((`div` 10). (* fontScale). getStringWidth parsedAfm)
   97     where
   98         parsedAfm = parseAfmFile (lines fontAfm)
   99         theDescender = getDescender parsedAfm
  100 
  101 getStringWidth :: [Afm] -> String -> Int
  102 getStringWidth afms str = sum (map (getCharWidth afms . fromEnum) str)
  103 
  104 getCharWidth :: [Afm] -> Int -> Int
  105 getCharWidth (CharMetric charNo charWX charName llx lly urx ury: afms) chNo
  106         | charNo == chNo = charWX
  107         | otherwise      = getCharWidth afms chNo
  108 getCharWidth (_:afms) chNo = getCharWidth afms chNo
  109 getCharWidth [] chNo = 0
  110 
  111 getDescender :: [Afm] -> Int
  112 getDescender (Descender d: _) = d
  113 getDescender (_:rest) = getDescender rest
  114 getDescender [] = 0
  115 
  116 --------------------------------------------------------------------------------
  117 
  118 parseAfmFile :: [String] -> [Afm]
  119 parseAfmFile [] = []
  120 parseAfmFile (('D':'e':'s':'c':'e':'n':'d':'e':'r':line):lines) =
  121         Descender descender: parseAfmFile lines
  122         where (descender,_):_ = readSigned readDec (skipWhite line)
  123 parseAfmFile (('E':'n':'d':'C':'h':'a':'r':'M':'e':'t':'r':'i':'c':'s':_):_) = []
  124 parseAfmFile (('C':' ':line):lines) = CharMetric charNo charWX charName llx lly urx ury:
  125                                   parseAfmFile lines
  126         where  (charNo, rest1):_ = readSigned readDec (skipWhite line)
  127                 'W':'X':rest2   = skipWhiteOrSemi rest1
  128                 (charWX, rest3):_ = readDec (skipWhite rest2)
  129                 'N':rest4       = skipWhiteOrSemi rest3
  130                 (charName, rest5) = span isAlpha (skipWhite rest4)
  131                 'B':rest6       = skipWhiteOrSemi rest5
  132                 (llx, rest7):_          = readSigned readDec (skipWhite rest6)
  133                 (lly, rest8):_          = readSigned readDec (skipWhite rest7)
  134                 (urx, rest9):_          = readSigned readDec (skipWhite rest8)
  135                 (ury, _):_      = readSigned readDec (skipWhite rest9)
  136 parseAfmFile (_:lines) = parseAfmFile lines
  137 
  138 skipWhite = dropWhile isSpace
  139 skipWhiteOrSemi = dropWhile isSkipChar
  140 isSkipChar c = isSpace c || c == ';'
  141 
  142