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