{- The font data in the svg-file is stored in a glyph-tag, example: 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 Graphics.SVGFonts.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 Graphics.SVGFonts.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 ))