{-
   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 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 ))