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)
read_font :: FilePath -> ([(String, String, String, String)],String)
read_font file = (sort sel4_2 (zip4 (glyph_names, unicodes, horiz, ds)), bbox)
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
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 |
Z |
L_abs Tup | L_rel Tup |
H_abs X | H_rel X |
V_abs Y | V_rel Y |
C_abs (X1,Y1,X2,Y2,X,Y) |
C_rel (X1,Y1,X2,Y2,X,Y) |
S_abs (X2,Y2,X,Y) |
S_rel (X2,Y2,X,Y) |
Q_abs (X1,Y1,X,Y) |
Q_rel (X1,Y1,X,Y) |
T_abs Tup | T_rel Tup | A_abs | A_rel
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) } <|>
do{ symbol "a"; l <- many1 tupel2; return (map (\x-> A_rel) l) }
}
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 <|>
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
horiz_sum :: String -> Svg_glyph -> Int
horiz_sum str glyph = sum (map (\ch -> (ha ch) ) str)
where hlist = map sel4_3 glyph
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
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+xx2, y+yy2 )
contr ( C_rel (x1,y1,x2,y2,x,y) ) = (x0+x+xx2, y0+y+yy2 )
contr ( S_abs (x2,y2,x,y) ) = ( x+xx2, y+yy2 )
contr ( S_rel (x2,y2,x,y) ) = (x0+x+xx2, y0+y+yy2 )
contr ( Q_abs (x1,y1,x,y) ) = ( x+xx1, y+yy1 )
contr ( Q_rel (x1,y1,x,y) ) = (x0+x+xx1, y0+y+yy1 )
contr ( T_abs (x,y) ) = ( x+xcx, y+ycy )
contr ( T_rel (x,y) ) = (x0+x+(x0+x)cx, y0+y+(y0+y)cy )
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
x0 = fst (last points)
y0 = snd (last points)
cx = (fst last_contr)
cy = (snd last_contr)
linearInterp t (x0,y0) (x1,y1) = ( (1t)*x0 + t*x1, (1t)*y0 + t*y1)
eval t (bi:bj:[]) = [linearInterp t bi bj]
eval t (bi:bj:bs) = (linearInterp t bi bj) : (eval t (bj:bs))
deCas t (bi:[]) = bi
deCas t bs = deCas t (eval t bs)
bCurve n b = tail [deCas (fromIntegral x/fromIntegral n) b | x<- [0..n]]
data Tree = Node Int [F2] [Tree] | Nil
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
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
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 (c1) poly ((Node c p ps) : ts)]
|otherwise = (Node c p ps): ( insert_node f (Node c poly []) ts)
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 = (x0x1)*(x0x1)+(y0y1)*(y0y1)
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 (l1) poly
p1 = position l poly
p2 = position (l+1) poly
position l poly = head (drop (l `mod` lp) poly)
sub (x0,y0) (x1,y1) = (x0x1, y0y1)
crossp (v0,v1) (w0,w1) = v0*w1v1*w0
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 :: F2 -> [F2] -> Bool
point_inside (x,y) poly = (length intersect_pairs) `mod` 2 == 1
where intersect_pairs = [ p | p <- all_pairs, positive_x_axis p, above_below p]
all_pairs = cycle_neighbours poly
positive_x_axis p = (x0 p) > x || (x1 p) > x
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))
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)
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 ]]
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
inside_triangle :: Array Int (X,Y) -> Int -> Int -> Int -> (X,Y,Int,Int) -> Bool
inside_triangle parray a b c p =
((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) = (ccxbbx, ccybby)
(bx,by) = (aaxccx, aayccy)
(cx,cy) = (bbxaax, bbyaay)
(apx,apy) = (pxaax, pyaay)
(bpx,bpy) = (pxbbx, pybby)
(cpx,cpy) = (pxccx, pyccy)
aCROSSbp = ax*bpy ay*bpx;
cCROSSap = cx*apy cy*apx;
bCROSScp = bx*cpy by*cpx;
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)
where d = sel4_4 array_element
ha_string = sel4_3 array_element
ha | (length ha_string)>0 = read (sel4_3 array_element)
| otherwise = 0
array_element = binary_search [ch] sel4_2 glyph 0 (length glyph)
outl = delete_holes commands bez max_h
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 ))