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