SVGFonts-0.1: ReadFont.hs
{-
The font data in the svg-file is stored in a glyph-tag, example:
<glyph glyph-name="T" unicode="T" horiz-adv-x="577"
d="M77 646h423c21 0 22 17 22 23l26 4c4 -49 11 -101 22 -154l-29 -5c-20 80 -34 92 -89 92h-66c-36 0 -48 -8 -48 -42v-492c0 -31 16 -44 55 -44h26c5 0 9 -3 9 -8v-19l-2 -2s-88 2 -127 2c-35 0 -128 -2 -128 -2l-2 2v19c0 5 3 8 8 8h26c41 0 55 16 55 44v495
c0 31 -12 39 -49 39h-84c-55 0 -68 -12 -88 -92l-30 5c12 53 18 105 22 154l27 -4c0 -6 0 -23 21 -23z" />
d is the path data(lines, bezier-curves, ...). For the syntax of this data see http://www.w3.org/TR/SVG/paths.html#PathData
-}
module ReadFont(read_font, get_glyph_polygon, horiz_sum, triang, cycle_neighbours) where
import Text.XML.Light.Input (parseXML,parseXMLDoc)
import Text.XML.Light.Types
import Text.XML.Light.Proc
import System.IO.Unsafe (unsafePerformIO)
import Text.ParserCombinators.Parsec hiding (spaces)
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language( javaStyle )
import Data.Char
import Array
import KETTriangulation (ketTri)
-------------------------------------------
-- XML
-------------------------------------------
read_font :: FilePath -> ([(String, String, String, String)],String)
read_font file = (sort sel4_2 (zip4 (glyph_names, unicodes, horiz, ds)), bbox) -- sort after unicode for binary search later
where xml = parseXML (unsafePerformIO (readFile file))
select_fontface = concat $ map (findElements named_fontface) (onlyElems xml)
select_glyphs = concat $ map (findElements named_glyph) (onlyElems xml)
bbox = deJust $ head $ map (findAttr named_bbox) select_fontface
glyph_names = map (findAttr named_glyph_name) select_glyphs
unicodes = map (findAttr named_unicode) select_glyphs
horiz = map (findAttr named_horiz_adv) select_glyphs
ds = map (findAttr named_d) select_glyphs
named_fontface = QName { qName = "font-face", qURI = Nothing, qPrefix = Nothing }
named_bbox = QName { qName = "bbox", qURI = Nothing, qPrefix = Nothing }
named_glyph = QName { qName = "glyph", qURI = Nothing, qPrefix = Nothing }
named_glyph_name = QName { qName = "glyph-name", qURI = Nothing, qPrefix = Nothing }
named_unicode = QName { qName = "unicode", qURI = Nothing, qPrefix = Nothing }
named_horiz_adv = QName { qName = "horiz-adv-x", qURI = Nothing, qPrefix = Nothing }
named_d = QName { qName = "d", qURI = Nothing, qPrefix = Nothing }
sort f [] = []
sort f (x:xs) = (sort f [l | l <- xs, (compare (f l) (f x)) == LT ]) ++ [x] ++
(sort f [r | r <- xs, (compare (f r) (f x)) == GT ])
zip4 ([],_,_,_) = []
zip4 (_,[],_,_) = []
zip4 (_,_,[],_) = []
zip4 (_,_,_,[]) = []
zip4 (a:as, b:bs, c:cs, d:ds) = (deJust a, deJust b, deJust c, deJust d) : (zip4 (as,bs,cs,ds))
deJust Nothing = ""
deJust (Just x) = x
sel3_1 (a,b,c) = a
sel3_2 (a,b,c) = b
sel3_3 (a,b,c) = c
sel4_1 (a,b,c,d) = a
sel4_2 (a,b,c,d) = b
sel4_3 (a,b,c,d) = c
sel4_4 (a,b,c,d) = d
-------------------------------------------
-- parsing of the path-field (d="")
-------------------------------------------
type X = Float
type Y = Float
type F2 = (X,Y)
type Svg_glyph = [(String, String, String, String)]
type Tup = (X,Y)
type X1 = X
type Y1 = Y
type X2 = X
type Y2 = Y
data GlyphCommand = M_abs Tup | M_rel Tup | -- establish a new current point (with absolute coords or rel. to the current point)
Z | -- Close current subpath by drawing a straight line from current point to current subpath's initial point
L_abs Tup | L_rel Tup | -- a line from the current point to Tup which becomes the new current point
H_abs X | H_rel X | -- a horizontal line from the current point (cpx, cpy) to (x, cpy)
V_abs Y | V_rel Y | -- a vertical line from the current point (cpx, cpy) to (cpx, y)
C_abs (X1,Y1,X2,Y2,X,Y) | -- Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the
-- control point at the beginning of the curve and (x2,y2) as the control point at the end of the curve.
C_rel (X1,Y1,X2,Y2,X,Y) |
S_abs (X2,Y2,X,Y) | -- Draws a cubic Bézier curve from the current point to (x,y). The first control point is
-- assumed to be the reflection of the second control point on the previous command relative to the current point. (If there is
-- no previous command or if the previous command was not an C, c, S or s, assume the first control point is coincident with the
-- current point.) (x2,y2) is the second control point (i.e., the control point at the end of the curve).
S_rel (X2,Y2,X,Y) |
Q_abs (X1,Y1,X,Y) | -- a quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point
Q_rel (X1,Y1,X,Y) | -- nearly the same as cubic, but with one point less
T_abs Tup | T_rel Tup | A_abs | A_rel -- T_Abs = Shorthand/smooth quadratic Bézier curveto, A = elliptic arc
glyphFromString :: String -> IO [GlyphCommand]
glyphFromString str
= do{ case (parse glyph_path "" str) of
Left err -> do{ putStr "parse error at "
; print err
; return []
}
Right x -> return x
}
spaces = skipMany space
glyph_path :: Parser [GlyphCommand]
glyph_path = do{ whiteSpace
; l <- many1 glyph_element
; eof
; return (concat l)
}
glyph_element :: Parser [GlyphCommand]
glyph_element = do{ whiteSpace;
do{ symbol "M"; l <- many1 tupel2; return (map (\x-> M_abs x) l) } <|>
do{ symbol "m"; l <- many1 tupel2; return (map (\x-> M_rel x) l) } <|>
do{ symbol "z"; return [Z]; } <|>
do{ symbol "L"; l <- many1 tupel2; return (map (\x-> L_abs x) l) } <|>
do{ symbol "l"; l <- many1 tupel2; return (map (\x-> L_rel x) l) } <|>
do{ symbol "H"; l <- many1 integer; return (map (\x-> H_abs (fromIntegral x)) l) } <|>
do{ symbol "h"; l <- many1 integer; return (map (\x-> H_rel (fromIntegral x)) l) } <|>
do{ symbol "V"; l <- many1 integer; return (map (\x-> V_abs (fromIntegral x)) l) } <|>
do{ symbol "v"; l <- many1 integer; return (map (\x-> V_rel (fromIntegral x)) l) } <|>
do{ symbol "C"; l <- many1 tupel6; return (map (\x-> C_abs x) l) } <|>
do{ symbol "c"; l <- many1 tupel6; return (map (\x-> C_rel x) l) } <|>
do{ symbol "S"; l <- many1 tupel4; return (map (\x-> S_abs x) l) } <|>
do{ symbol "s"; l <- many1 tupel4; return (map (\x-> S_rel x) l) } <|>
do{ symbol "Q"; l <- many1 tupel4; return (map (\x-> Q_abs x) l) } <|>
do{ symbol "q"; l <- many1 tupel4; return (map (\x-> Q_rel x) l) } <|>
do{ symbol "T"; l <- many1 tupel2; return (map (\x-> T_abs x) l) } <|>
do{ symbol "t"; l <- many1 tupel2; return (map (\x-> T_rel x) l) } <|>
do{ symbol "A"; l <- many1 tupel2; return (map (\x-> A_abs) l) } <|> -- not used
do{ symbol "a"; l <- many1 tupel2; return (map (\x-> A_rel) l) } -- not used
}
tupel2 :: Parser (X,Y)
tupel2 = do{ x <- myfloat; spaces; y <- myfloat; spaces;
; return (realToFrac x, realToFrac y)
}
tupel4 :: Parser (X,Y,X,Y)
tupel4 = do{ x1 <- myfloat; spaces; y1 <- myfloat; spaces; x <- myfloat; spaces; y <- myfloat; spaces;
; return (realToFrac x1, realToFrac y1, realToFrac x, realToFrac y)
}
tupel6 :: Parser (X,Y,X,Y,X,Y)
tupel6 = do{ x1 <- myfloat; spaces; y1 <- myfloat; spaces;
x2 <- myfloat; spaces; y2 <- myfloat; spaces; x <- myfloat; spaces; y <- myfloat; spaces;
; return (realToFrac x1, realToFrac y1, realToFrac x2, realToFrac y2, realToFrac x, realToFrac y)
}
myfloat = try (do{ symbol "-"; n <- float; return (negate n) }) <|>
try float <|> -- 0 is not recognized as a float, so recognize it as an integer and then convert it to float
do { i<-integer; return(fromIntegral i) }
-----------------------------------------------------------
lexer = P.makeTokenParser oDef
oDef = javaStyle
{
P.commentLine = "#"
}
whiteSpace = P.whiteSpace lexer
symbol = P.symbol lexer
integer = P.integer lexer
float = P.float lexer
-------------------------------------------
-- path-commands to points
-------------------------------------------
-- to do: use a state monad to avoid recalculation
horiz_sum :: String -> Svg_glyph -> Int
horiz_sum str glyph = sum (map (\ch -> (ha ch) ) str)
where hlist = map sel4_3 glyph -- list of all advances
a = array (0,length hlist) [(i, head (drop i hlist)) | i <- [0..(length hlist)]]
ha_string ch = sel4_3 (binary_search [ch] sel4_2 glyph 0 (length glyph))
ha ch | (length (ha_string ch))>0 = read (ha_string ch)
| otherwise = 0 -- advance in horiz.-direction for next glyph
commands_to_points :: [GlyphCommand] -> [F2] -> F2 -> Int -> Float -> [[F2]]
commands_to_points [] _ _ _ _ = []
commands_to_points (c:commands) points last_contr p max_h
| (length next_points) == 0 = [ tail points ] ++ (commands_to_points commands next_points (contr c) p max_h)
| otherwise = commands_to_points commands (points ++ next_points) (contr c) p max_h
where next_points = go c
contr ( C_abs (x1,y1,x2,y2,x,y) ) = ( x+x-x2, y+y-y2 ) -- control point of bezier curve
contr ( C_rel (x1,y1,x2,y2,x,y) ) = (x0+x+x-x2, y0+y+y-y2 )
contr ( S_abs (x2,y2,x,y) ) = ( x+x-x2, y+y-y2 )
contr ( S_rel (x2,y2,x,y) ) = (x0+x+x-x2, y0+y+y-y2 )
contr ( Q_abs (x1,y1,x,y) ) = ( x+x-x1, y+y-y1 )
contr ( Q_rel (x1,y1,x,y) ) = (x0+x+x-x1, y0+y+y-y1 )
contr ( T_abs (x,y) ) = ( x+x-cx, y+y-cy )
contr ( T_rel (x,y) ) = (x0+x+(x0+x)-cx, y0+y+(y0+y)-cy ) -- absolute coordinates
contr ( L_abs (x,y) ) = ( x, y)
contr ( L_rel (x,y) ) = (x0 + x, y0 + y)
contr ( M_abs (x,y) ) = ( x, y)
contr ( M_rel (x,y) ) = (x0 + x, y0 + y)
contr ( H_abs x ) = ( x, y0 )
contr ( H_rel x ) = (x0 + x, y0 )
contr ( V_abs y ) = (x0, y )
contr ( V_rel y ) = (x0, y0 + y )
go ( L_abs (x,y) ) = [(x,y)]
go ( L_rel (x,y) ) = [(x0+x, y0+y)]
go ( M_abs (x,y) ) = [(x, y)]
go ( M_rel (x,y) ) = [(x0+x, y0+y)]
go ( H_abs x) = [(x, y0)]
go ( H_rel x) = [(x0+x, y0)]
go ( V_abs y) = [(x0, y )]
go ( V_rel y) = [(x0, y0+y)]
go ( C_abs (x1,y1,x2,y2,x,y) ) = bCurve (bez x y) [(x0, y0), (x1, y1), (x2, y2), (x, y) ]
go ( C_rel (x1,y1,x2,y2,x,y) ) = bCurve (bez x y) [(x0, y0), (x0+x1,y0+y1), (x0+x2,y0+y2), (x0+x,y0+y)]
go ( S_abs ( x2,y2,x,y) ) = bCurve (bez x y) [(x0, y0), (cx, cy), (x2, y2), (x, y) ]
go ( S_rel ( x2,y2,x,y) ) = bCurve (bez x y) [(x0, y0), (cx, cy), (x0+x2,y0+y2), (x0+x,y0+y)]
go ( Q_abs (x1,y1,x,y) ) = bCurve (bez x y) [(x0, y0), (x1, y1), (x, y)]
go ( Q_rel (x1,y1,x,y) ) = bCurve (bez x y) [(x0, y0), (x0+x1, y0+y1), (x0+x, y0+y)]
go ( T_abs (x,y) ) = bCurve (bez x y) [(x0,y0), (cx, cy), (x, y) ]
go ( T_rel (x,y) ) = bCurve (bez x y) [(x0,y0), (cx, cy), (x0+x,y0+y)]
go ( Z ) = []
bez xd yd = p -- round ((fromIntegral p) * (sqrt ((xd-x0)*(xd-x0) + (yd-y0)*(yd-y0))) / max_h) -- not better
x0 = fst (last points)
y0 = snd (last points)
cx = (fst last_contr) -- last control point is always in absolute coordinates
cy = (snd last_contr)
---------------------------------------------------
-- bezier-curves (inspired by wikipedia article)
---------------------------------------------------
-- linearInterp:: Float -> F2 -> F2 -> F2
linearInterp t (x0,y0) (x1,y1) = ( (1-t)*x0 + t*x1, (1-t)*y0 + t*y1)
-- eval:: Float -> [F2] -> [F2]
eval t (bi:bj:[]) = [linearInterp t bi bj]
eval t (bi:bj:bs) = (linearInterp t bi bj) : (eval t (bj:bs))
-- deCas:: Float -> [F2] -> F2
deCas t (bi:[]) = bi
deCas t bs = deCas t (eval t bs)
-- bCurve:: Int -> [F2] -> [F2]
bCurve n b = tail [deCas (fromIntegral x/fromIntegral n) b | x<- [0..n]]
---------------------------------------------------
-- transform a polygon with (nested) holes into one outline
-- i.e. the letters a,b,d,e,g,o,p,q contain holes tat have to be deleted
---------------------------------------------------
data Tree = Node Int [F2] [Tree] | Nil -- c is the nesting counter and p a polygon
instance Show Tree where
show (Node c p tree) = "Node" ++ (show c) ++ (show (length p)) ++ "[" ++ (concat(map show tree)) ++ "]"
show (Nil) = "Nil"
delete_holes :: [GlyphCommand] -> Int -> Float -> [[F2]]
delete_holes commands bez max_h = flatten trees -- trace (show trees)
where trees = generate_trees inside_poly (commands_to_points commands [(0,0)] (0,0) bez max_h)
flatten [] = []
flatten (Nil:ts) = flatten ts
flatten ((Node c poly [Nil]):ts) = (direction c (polygon_direction poly) poly) : (flatten ts)
flatten ((Node c poly ps) :ts) = ( embed (flatten ps) (direction c (polygon_direction poly) poly) ) : (flatten ts)
embed :: [[F2]] -> [F2] -> [F2]
embed [] poly = poly
embed (s:sub_polys) poly = embed sub_polys ((take (n+1) poly) ++ s ++ (drop n poly))
where n = fst (rotate_poly (head s) poly)
direction :: Int -> Bool -> [F2] -> [F2]
direction c b poly | (b && (even c)) || (not b && (odd c)) = poly
| otherwise = reverse poly
-- f should be the funtion to test "contains"
-- the trees then are the hierarchy of containedness of outlines
generate_trees :: ([F2]->[F2]->Bool) -> [[F2]] -> [Tree]
generate_trees f [] = []
generate_trees f ps = merge_nodes f (map (\p -> Node 0 p []) ps) []
merge_nodes :: ([F2]->[F2]->Bool) -> [Tree] -> [Tree] -> [Tree]
merge_nodes f [] result = result
merge_nodes f (v:vs) result = merge_nodes f vs (insert_node f v result)
insert_node :: ([F2]->[F2]->Bool) -> Tree -> [Tree] -> [Tree]
insert_node f (Node _ poly []) ((Node c p []):ts)|(f poly p)= (Node c p [Node (c+1) poly []]) : ts
|(f p poly)= (Node c poly [Node (c+1) p []]) : ts
|otherwise = (Node c p []) : ( insert_node f (Node (c+1) poly []) ts)
insert_node f (Node c poly []) [] = [(Node c poly [])]
insert_node f (Node _ poly []) ((Node c p ps):ts)|(f poly p) = (Node c p (insert_node f (Node (c+1) poly []) ps)) : ts
|(f p poly) = [Node (c-1) poly ((Node c p ps) : ts)]
|otherwise = (Node c p ps): ( insert_node f (Node c poly []) ts)
-- how many positions to rotate a polygon until the start point is nearest to some other point
-- call i.e. with nearest (3,4) [(0,0),(1,2), ... ] 0 0
rotate_poly :: F2 -> [F2] -> (Int,X)
rotate_poly p points = (fst tup, snd tup)
where tup = nearest p points (-1) 0 0
nearest :: F2 -> [F2] -> X -> Int -> Int -> (Int,X)
nearest _ [] dist l ml = (ml,dist)
nearest (x0,y0) ((x1,y1):ps) dist l ml | (new_dist < dist) || (dist < 0) = nearest (x0,y0) ps new_dist (l+1) l
| otherwise = nearest (x0,y0) ps dist (l+1) ml
where new_dist = (x0-x1)*(x0-x1)+(y0-y1)*(y0-y1)
---------------------------------------------------
-- general algorithms for various applications
---------------------------------------------------
-- the direction of a polygon can be determined by taking the right-/upmost point and calculating the
-- crossproduct of the two adjacent points
polygon_direction :: [F2] -> Bool
polygon_direction [] = False
polygon_direction poly | (crossp (p1 `sub` p0) (p1 `sub` p2) ) > 0 = True
| otherwise = False
where l = maxim poly 0 0 0 0
lp = length poly
p0 = position (l-1) poly
p1 = position l poly
p2 = position (l+1) poly
position l poly = head (drop (l `mod` lp) poly)
sub (x0,y0) (x1,y1) = (x0-x1, y0-y1)
crossp (v0,v1) (w0,w1) = v0*w1-v1*w0
-- the index of the right-/upmost point
maxim [] l ml mx my = ml
maxim (x:xs) l ml mx my | ((fst x) > mx) && ((snd x) >= my) = maxim xs (l+1) l (fst x) (snd x)
| otherwise = maxim xs (l+1) ml mx my
inside_poly :: [F2] -> [F2] -> Bool
inside_poly [] _ = False
inside_poly _ [] = False
inside_poly poly1 poly2 = point_inside (head poly1) poly2
-- point_inside: A point that is inside a polygon if it has an odd number of intersections with the boundary (Jordan Curve theorem)
-- to do: find the error
point_inside :: F2 -> [F2] -> Bool
point_inside (x,y) poly = (length intersect_pairs) `mod` 2 == 1 -- trace (show intersect_pairs)
where intersect_pairs = [ p | p <- all_pairs, positive_x_axis p, above_below p] --, special_cases p]
all_pairs = cycle_neighbours poly
positive_x_axis p = (x0 p) > x || (x1 p) > x -- intersect with positive x-axis
-- only lines with one point above + one point below can intersect
above_below p = (((y0 p)> y && (y1 p)< y) || ((y0 p) < y && (y1 p) > y))
special_cases p = (((dir1 p) > 0 && (dir2 p) <= 0) || ((dir1 p) <= 0 && (dir2 p) > 0)) -- cross product for special cases
dir1 p = cross ((x1 p)-(x0 p),(y1 p)-(y0 p)) (1,0)
dir2 p = cross ((x1 p)-(x0 p),(y1 p)-(y0 p)) (x-(x0 p),y-(y0 p))
cross (a0,b0) (a1,b1) = a0*b1 - a1*b0
x0 p = fst (head p)
x1 p = fst (last p)
y0 p = snd (head p)
y1 p = snd (last p)
-- return a list containing lists of every element with its neighbour
-- i.e. [e1,e2,e3] -> [ [e1,e2], [e2,e3], [e3, e1] ]
cycle_neighbours :: [a] -> [[a]]
cycle_neighbours [] = []
cycle_neighbours xs = cycle_n (head xs) xs
cycle_n :: a -> [a] -> [[a]]
cycle_n f (x:y:xs) = [x,y] : (cycle_n f (y:xs))
cycle_n f e = [[head e, f ]] -- if the upper doesn't match close cycle
qsort f [] = []
qsort f (x:xs) = (qsort f [l | l <- xs, (f l)<=(f x)]) ++ [x] ++ (qsort f [r | r <- xs, (f r) > (f x)])
triang :: [(X,Y)] -> [(Int,Int,Int)]
triang poly = ketTri poly -- to do: try O(n(1+t0)) from Toussaint (already implemented by Joern Dinkla)
-- The idea: the three sides of the triangle are represented by vectors in one direction around the triangle.
-- For every vector the crossprodukt divides the plane into two regions.
-- The intersection of the three regions is the inner area
inside_triangle :: Array Int (X,Y) -> Int -> Int -> Int -> (X,Y,Int,Int) -> Bool
inside_triangle parray a b c p = -- trace ("in" ++ show a ++ show b ++ show c ++ show (parray!a) ++ show (parray!b) ++ show (parray!c) ++ show p ++ show ((aCROSSbp <= 0) && (bCROSScp <= 0) && (cCROSSap <= 0)))
((aCROSSbp <= 0) && (bCROSScp <= 0) && (cCROSSap <= 0))
where (aax,aay) = parray!a
(bbx,bby) = parray!b
(ccx,ccy) = parray!c
(px,py) = parray!(sel4_3 p)
(ax,ay) = (ccx-bbx, ccy-bby)
(bx,by) = (aax-ccx, aay-ccy)
(cx,cy) = (bbx-aax, bby-aay)
(apx,apy) = (px-aax, py-aay)
(bpx,bpy) = (px-bbx, py-bby)
(cpx,cpy) = (px-ccx, py-ccy)
aCROSSbp = ax*bpy - ay*bpx;
cCROSSap = cx*apy - cy*apx;
bCROSScp = bx*cpy - by*cpx;
--------------------------
-- main library function, together with read_font which produces the Svg_glyph-type needed for this function
--------------------------
get_glyph_polygon :: Char -> Svg_glyph -> Int -> Float -> ([[F2]], X,[[ (Int,Int,Int) ]])
get_glyph_polygon ch glyph bez max_h = (outline, ha, map triang outline) -- the triangulation is a list of triangles(3 indices)
where d = sel4_4 array_element -- ie. a letter like 'i' consists of two lists of triangles
ha_string = sel4_3 array_element
ha | (length ha_string)>0 = read (sel4_3 array_element) -- how much to advance in the horiz.-direction for the next glyph
| otherwise = 0
array_element = binary_search [ch] sel4_2 glyph 0 (length glyph)
outl = delete_holes commands bez max_h -- bez is the # of points in a bezier-curve
outline = map (\o -> direction 0 (polygon_direction o) o) outl
commands | (length d) == 0 = []
| otherwise = unsafePerformIO ( glyphFromString d )
binary_search ch f glyph left right | compare ch s == EQ = head (drop ((left+right)`div`2) glyph )
| compare ch s == LT = binary_search ch f glyph left ((left+right)`div`2)
| compare ch s == GT = binary_search ch f glyph ((left+right)`div`2) right
| otherwise = head glyph
where s = f (head (drop ((left+right)`div`2) glyph ))