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