diff --git a/README b/README --- a/README +++ b/README @@ -15,20 +15,15 @@ doens't work edit the file by hand or even cooler: help me with a patch to make this library more robust. Remember that a lot of fonts are not allowed to be distributed freely. - src/Test/Font.hs is an example how to use this library. - You can navigate around the 3d string with w,a,s,d, + arrows +Example: + src/Test/Font.hs generates a Collada file that can be read with tools like blender. + The data that is passed to genCollada is represented with a data type that I use for all my libraries to allow easy combination. The main function to generate a visual representation of a string is: - displayString :: String -> (Int,Int) -> Mode -> Spacing -> O -> V -> V -> P -> [AObj] + displayString :: String -> (Int,Int) -> Props -> Transf -> Mode -> Spacing -> O -> V -> V -> P -> TexMap -> [Geometry] The list [AObj] can contain various data: - Textures that can be used directly by OpenGL (TextureObject) - Names of texture files in the fontcache (collada-output needs this) - Extruded or non extruded outlines - - The data to generate can be specified by the last argument, the property-function: - type P = [Char] -> [(Char,[CharProp])] - that assigns properties to every character of the string (i.e. color of a char in syntaxhighlighting, Font) - - The [AObj] list has to be converted to whatever types you use diff --git a/SVGFonts.cabal b/SVGFonts.cabal --- a/SVGFonts.cabal +++ b/SVGFonts.cabal @@ -1,9 +1,27 @@ Name: SVGFonts -Version: 0.3 +Version: 0.4 Synopsis: Fonts from the SVG-Font format -Description: Parse SVG-Font files and generate outlines or textures or texture files from text strings. - This library uses algorithms similar to Freetype and therefore needs no binding. - Unfortunately some speed issues (xml, rasterization) and bugs (triangulation,rasterization) make an actual usage problematic, but they will be solved. +Description: SVG-Font is a very easy to parse format and was therefore chosen for a font library + completely written in Haskell + . + To use this library with your own font, the font has to be converted with + Features + . + * A very easy and powerful functional interface, see the Font.hs example + . + * The generated outlines can be transformed in various ways, i.e. + elimination of holes for easy extrusion (with the triangulation library) + . + * complete implementation of the SVG-Font format, that allows Kerning + (i.e. the two characters in "VA" have a shorter distance than in "VV") + . + * Everything is stored in a simple SceneGraph data type: + . + . + Some speed issues are left to be solved (xml) and rasterization is not finnished + . + Speed issues can be solved by trimming the svg file to only those characters that are used + . category: Graphics License: BSD3 License-file: LICENSE @@ -20,23 +38,25 @@ build-depends: haskell98, base == 4.*, - OpenGL, - GLUT, + OpenGL >= 2.2.3.0, + GLUT >= 2.1.2.1, xml == 1.3.*, - parsec == 2.1.*, + parsec == 3.1.*, array, - containers == 0.3.*, + containers == 0.4.*, SVGPath == 1.0.*, split == 0.1.*, - directory == 1.0.*, + directory == 1.1.*, bytestring == 0.9.1.*, tga, - tuple + tuple, + collada-types >= 0.2, + collada-output >= 0.5, + triangulation >= 0.2 exposed-modules: Graphics.SVGFonts.ReadFont - Graphics.SVGFonts.KETTriangulation - + Graphics.SVGFonts.RasterFont Executable Fonts hs-source-dirs: src main-is: Test/Fonts.hs - other-modules: Test.PointOfView, Graphics.SVGFonts.ReadFont, Paths_SVGFonts + other-modules: Graphics.SVGFonts.ReadFont, Paths_SVGFonts diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,8 +1,5 @@ -TO DO: - - Find errors in rasterization -- Find errors in triangulation -- Rasterization with Bytestring (if it is faster) -- Integration in collada-output +- integration in other libraries +- auto hinting - Binary XML (i.e. fast infoset), because xml-parsing has a speed problem - Unicode diff --git a/src/Graphics/SVGFonts/KETTriangulation.hs b/src/Graphics/SVGFonts/KETTriangulation.hs deleted file mode 100644 --- a/src/Graphics/SVGFonts/KETTriangulation.hs +++ /dev/null @@ -1,94 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright (C) 1997, 1998, 2008 Joern Dinkla, www.dinkla.net --------------------------------------------------------------------------------- --- --- see --- Joern Dinkla, Geometrische Algorithmen in Haskell, Diploma Thesis, --- University of Bonn, Germany, 1998. --- --- triangulation of simple polygons after Kong, Everett, Toussaint 91 --- with some changes by T.Vogt: return indices instead of coordinates of triangles - -module Graphics.SVGFonts.KETTriangulation (ketTri,cycle_n) where -import List ( (\\) ) -import Debug.Trace - -type XYI = (Float,Float,Int) - -ketTri :: [(Float,Float)] -> [(Int,Int,Int)] -ketTri poly = scan vs stack rs - where ps@(p1:p2:p3:qs) = vertices poly - vs = qs ++ [p1] - stack = [p3, p2, p1, last ps] - rs = reflexVertices ps - -scan :: [XYI] -> [XYI] -> [XYI] -> [(Int,Int,Int)] -scan [] _ _ = [] -scan [v] [x_p, x_i, _, _] rs = [(sel3_3 x_i, sel3_3 x_p, sel3_3 v)] -scan (v:vs) ss@[_,_,_] rs = scan vs (v:ss) rs -scan vs@(v:vs') ss@(x_p:x_i:ss'@(x_m:x_mm:xs)) rs - | isEar rs x_m x_i x_p = (sel3_3 x_m, sel3_3 x_i, sel3_3 x_p) : scan vs (x_p:ss') rs' - | otherwise = scan vs' (v:ss) rs - where rs' = rs \\ (isConvex x_m x_p v ++ isConvex x_mm x_m x_p) - isConvex im i ip = if isLeftTurn im i ip then [i] else [] - -isEar :: [XYI] -> XYI -> XYI -> XYI -> Bool -isEar [] _ _ _ = True -isEar rs m x p = isLeftTurn m x p && not (any ( (m,x,p) `containsBNV`) rs) - -reflexVertices :: [XYI] -> [XYI] -reflexVertices xs = [ x | (m,x,p) <- angles xs, isRightTurnOrOn m x p ] - -isRightTurnOrOn m x p = (area2 m x p) <= 0 -isLeftTurn m x p = (area2 m x p) > 0 -area2 (x2,y2,_) (x0,y0,_) (x1,y1,_) = (x1-x0)*(y2-y0)-(x2-x0)*(y1-y0) - -containsBNV (s,t,v) p = (a==b && b==c) - where a = isLeftTurn s t p - b = isLeftTurn t v p - c = isLeftTurn v s p - -angles :: [a] -> [(a,a,a)] -angles xs = zip3 (rotateR xs) xs (rotateL xs) - -rotateL xs = tail xs ++ [head xs] -rotateR xs = [last xs] ++ init xs -sel3_1 (x,y,z) = x -sel3_2 (x,y,z) = y -sel3_3 (x,y,z) = z - --- make vertices of polygon counterclockwise and add an index -vertices :: [(Float,Float)] -> [XYI] -vertices qs | polygon_direction ps = ps - | otherwise = reverse ps - where ps = zipWith (\(x,y) z -> (x,y,z) ) qs [0..] - --- the direction (clockwise or counterclockwise) of a polygon can be obtained by looking at a maximal point --- polygon_direction :: [XYI] -> Bool --- polygon_direction poly = isLeftTurn (p (l-1) poly) (p l poly) (p (l+1) poly) --- where p l poly = head (drop (l `mod` lp) poly) --- l = maxim poly 0 0 0 0 --- lp = length poly --- -- the index of the right-/upmost point --- maxim [] l ml mx my = ml --- maxim (x:xs) l ml mx my | ((sel3_1 x) > mx) && ((sel3_2 x) >= my) = maxim xs (l+1) l (sel3_1 x) (sel3_2 x) --- | otherwise = maxim xs (l+1) ml mx my - -polygon_direction :: [XYI] -> Bool -polygon_direction poly = trace (show (sum (zipWith crossp l1 l2))) (sum (zipWith crossp l1 l2) > 0) - where l1 = map (\(a,b) -> b `sub` a) ((tail c) ++ [head c]) - l2 = map (\(a,b) -> a `sub` b) c - c = map to_tuple (cycle_neighbours poly) -- [(p0,p1,0),(p1,p2,1),(p2,p3,2),.. - to_tuple (a:b:[]) = (a,b) - sub (x0,y0,_) (x1,y1,_) = (x0-x1, y0-y1, 0) - crossp (v0,v1,_) (w0,w1,_) = v0*w1-v1*w0 - --- 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 diff --git a/src/Graphics/SVGFonts/RasterFont.hs b/src/Graphics/SVGFonts/RasterFont.hs --- a/src/Graphics/SVGFonts/RasterFont.hs +++ b/src/Graphics/SVGFonts/RasterFont.hs @@ -1,29 +1,32 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts #-} module Graphics.SVGFonts.RasterFont - (raster, withCheckImage, createTexture, texData, bucketSort2d, array2d_to1d, + (raster, withCheckImage, createTexture, texData, bitmask, line, bitSum, endBits, bits, F2P, AA(..), Bitmask, ) where import Data.Array.MArray import Data.Array.ST (STArray,STUArray) -import Data.Array hiding (elems,array) +import Data.Array hiding (elems,array,bounds) import Data.Array.Unboxed -import Data.Bits ( (.&.) ) +import Data.Bits ( (.&.), testBit ) import Data.Word import Data.Bits (testBit,setBit, shiftL, bit, shiftR) import Data.STRef +import Data.Maybe +import Data.List import Control.Monad (when, forM_, forM) import Control.Monad.ST -import Graphics.Rendering.OpenGL hiding (get,set) +import Graphics.Rendering.OpenGL hiding (get) import Foreign (mallocBytes, withArray) import Debug.Trace import Graphics.Formats.TGA.TGA import qualified Data.ByteString as B +import System.IO.Unsafe (unsafePerformIO) var = Data.STRef.newSTRef get = Data.STRef.readSTRef -set = Data.STRef.writeSTRef +sett = Data.STRef.writeSTRef mutate = Data.STRef.modifySTRef type F2P = (X, Y, AA) @@ -36,19 +39,18 @@ instance Show AA where show (NB) = "NB" -- No Bitmask - show (B bits) = "B " -- ++ show bits + show (B bits) = "B " ++ show (elems bits) raster (dx,dy) xs = -- trace (" xs " ++ show (map (\(x,y,_)->(round x, round y)) (rasterr (dx,dy) xs))) $ + -- trace (" xs " ++ show (map (\(x,y,b) -> b) (rasterr (dx,dy) xs))) $ rasterr (dx,dy) xs rasterr :: (X,Y) -> [F2] -> [F2P] rasterr _ [a] = [] rasterr (dx,dy) ((p0x,p0y):((p1x,p1y):bs)) | (abs (p1x-p0x)) < dx && (abs (p1y-p0y)) < dy = div22 ++ rest -- line that is at most one pixel long - | (abs (p1x-p0x)) < dx = -- < 1 && p0x_int == p1x_int = - rasterStraightLine True ++ rest -- vertical line - | (abs (p1y-p0y)) < dy = -- 1 && p0y_int == p1y_int = - rasterStraightLine False ++ rest -- horizontal line + | (abs (p1x-p0x)) < dx = rasterStraightLine True ++ rest -- vertical line + | (abs (p1y-p0y)) < dy = rasterStraightLine False ++ rest -- horizontal line | otherwise = trace "test" rest -- should not happen where rest = rasterr (dx,dy) ((p1x, p1y):bs) (p0x_int, p0y_int) | p0y < p1y = (truncate p0x, truncate p0y) @@ -59,10 +61,10 @@ rasterStraightLine up | up = (divide 1 len_y smallerX p0y_int (line 1 len_y pixP0 pixP1)) -- up | otherwise = (divide len_x 1 smallerX p0y_int (line len_x 1 pixP2 pixP3)) -- right divide :: Int -> Int -> Int -> Int -> UArray (Int,Int) Word16 -> [F2P] - divide nx ny x y a = [ (fromIntegral (ex+x), fromIntegral (ey+y), B (mark (ey*nx+ex))) | -- (bitmask ex ey a)) | + divide nx ny x y a = [ (fromIntegral (ex+x), fromIntegral (ey+y), B (bitmask ex ey a)) | -- (mark (ey*nx+ex))) | -- (bitmask ex ey a)) | ey <- [0..(ny-1)], ex <- [0..(nx-1)] ] div22 = divide 2 2 p0x_int p0y_int (line 2 2 pixP4 pixP5) -- (array ((0,0),(0,15)) []) - mark n = array (0,15) [ (i,32) | i <- [0..15] ] -- bitmask ex ey a + -- mark n = array (0,15) [ (i,32) | i <- [0..15] ] -- bitmask ex ey a len_x = abs (p1x_int - p0x_int) len_y = p1y_int - p0y_int smallerX = truncate $ if (p0x < p1x) then p0x else p1x @@ -82,60 +84,22 @@ frac = snd.properFraction --- fil xs = filter (>0) (elems xs) - texData :: (Int,Int) -> [(Int, Int, Bitmask)] -> TGAData -texData (rx,ry) border_points = tga $ array2d_to1d rx ry $ fillSpans $ (bucketSort2d rx ry border_points) +texData (rx,ry) border_points = tga $ fillSpace (rx,ry) border_points where tga t = (TGAData (B.empty) - (RGB32 (B.concat (map color (elems t))) ) + (RGB32 (color t)) 0 0 rx ry) - color x = B.cons x $ B.cons x $ B.cons x $ B.singleton x - --- |Fill a bitmask with 1s if the bit/subpixel is inside a polygon, (the bitmask was filled before with --- subpixels of outline drawing of the polygon). The bitmask is an array of 16 word16 where the --- x-direction are the bit position in the word16s. Horizontal(x-direction) lines are drawn if the --- line is inside the polygon, called a span (see Jordan curve theorem). --- A subpixel marks the beginnig or the end of a span depending on the state of the line. --- At the beginning all lines are white, if one intersects a subpixel it becomes black until it --- hits a subpixel again. The states at the end of the lines are stored for the next pixel in fillSpans. --- If these state bits are all one or all zero and the next bitmask is completely zero then fewer --- calculations need to be done. - - fillSpans :: (UArray (Int,Int) Bool, UArray (Int,Int) Word16) -> UArray (Int,Int) Word16 - fillSpans (ar_bool, ar_word) = runST ( -- trace ("span " ++ show (fil ar_word)) $ runST ( - do ar <- newArray ((0,0),(rx-1,ry-1)) 0 :: ST s (STUArray s (Int,Int) Word16) - arb <- thaw2 ar_bool - arw <- thaw2 ar_word - forM_ [0..(ry-1)] ( \y -> do - startBits <- var (0::Word16) - forM_ [0..(rx-1)] ( \x -> do - b <- readArray arb (x,y) - sb <- get startBits - case b of True -> do s <- var $ False - forM_ [0..15] ( \suby -> do - set s (testBit sb suby) - forM_ [0..15] ( \subx -> do - line <- readArray arw (x,y*16+suby) - let b = (testBit line subx) - t <- get s - when (t==False && b == True) (writeArray arw (x,y*16+suby) (setBit line subx)) - when (t==False && b == True) (set s True) -- start filling - when (t==True && b == False) (writeArray arw (x,y*16+suby) (setBit line subx)) -- continue - when (t==True && b == True) (set s False) ) ) -- stop - bitm <- unsafeFreeze arw - let bsum = bitSum (bitmask x y bitm) -- trace (show ((bitmask x y bitm))) $ - set startBits (endBits (bitmask x y bitm)) -- ((endBits newMask) && not (endBits bm) ) - writeArray ar (x,y) bsum - False -> do writeArray ar (x,y) (shiftL (bits sb) 4) )) -- the same as: (bits startbits)*16 - a' <- unsafeFreeze ar - return (a' :: UArray (Int,Int) Word16) ) - + color x | b == Nothing = B.empty + | otherwise = B.cons c $ B.cons c $ B.cons c $ B.cons c (color xs) + where b = B.uncons x + c = fst (fromJust b) + xs = snd (fromJust b) withCheckImage :: [Word8] -> TextureSize2D -> ([Word8] -> [(Color4 GLubyte)]) -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () withCheckImage xs (TextureSize2D w h) f act = - withArray (f xs) -- (map f (map fromIntegral xs)) + withArray (f xs) $ act. PixelData RGBA UnsignedByte createTexture :: (Int,Int) -> TGAData -> String -> IO (TextureObject, String) @@ -147,60 +111,42 @@ textureBinding Texture2D $= Just texName textureFilter Texture2D $= ((Nearest, Nothing), Nearest) let imageSize = TextureSize2D (fromIntegral rx) (fromIntegral ry) - withCheckImage xs imageSize f $ -- (\c -> Color4 c c c 255) $ + withCheckImage xs imageSize f $ texImage2D Nothing NoProxy 0 RGBA' imageSize 0 return (texName, fileName) f (a:(b:(c:(d:ds)))) = (Color4 (fromIntegral a) (fromIntegral b) (fromIntegral c) 255) : (f ds) f _ = [] --- type Bitmask = UArray Int Word16 --- |generate a 2-dimensional array in which pixels are inserted -bucketSort2d :: Int -> Int -> [(Int,Int,Bitmask)] -> (UArray (Int,Int) Bool, UArray (Int,Int) Word16) -bucketSort2d rx ry pixels = -- trace ("bucket " ++ show pixels) -- (map (\(x,y,z) -> (x,y)) pixels) ) - (runST ( do - ar0 <- newArray ((0,0),(rx-1,ry-1)) False :: ST s (STUArray s (Int,Int) Bool) -- == True if pixel has a grey value (the outline goes through it) - ar1 <- newArray ((0,0),(rx-1,ry*16-1)) 0 :: ST s (STUArray s (Int,Int) Word16)-- an unboxed array of unboxed arrays is simulated with one big array - forM pixels (\(ix,iy,mask) -> do - when (ix >= 0 && iy >= 0 && (ix+iy*rx) < rx*ry) ( do - bbool <- readArray ar0 (ix, iy) - bm1 <- thawSTU mask - case bbool of False -> do writeArray ar0 (ix,iy) True - forM_ [0..15] ( \y -> do - e <- readArray bm1 y - writeArray ar1 (ix,iy*16+y) e ) - True -> do writeArray ar0 (0,0) True --- forM_ [0..15] ( \y -> do --- e0 <- readArray ar1 (ix,iy*16+y) --- e1 <- readArray bm1 y --- writeArray ar1 (ix,iy*16+y) (e0 `xor` e1) ) - ) ) - a0 <- unsafeFreeze ar0 - a1 <- unsafeFreeze ar1 - return (a0 :: UArray (Int,Int) Bool, a1 :: UArray (Int,Int) Word16) )) +fillSpace :: (Int, Int) -> [(Int,Int,Bitmask)] -> B.ByteString +fillSpace (rx,ry) pixels = fill (rx,ry) (sortBy sxy pixels) False + where sxy (x0,y0,b0) (x1,y1,b1) | y0 < y1 || (y0 == y1 && x0 < x1) = LT + | y0 == y1 && x0 == x1 = EQ + | otherwise = GT -ro = (\(x,y,z)->(round x, round y, z)) +fill :: (Int,Int) -> [(Int,Int,Bitmask)] -> Bool -> B.ByteString +fill (rx,ry) ((x0,y0,b0):(x1,y1,b1):cs) inside | y0 == y1 && inside == False + = B.cons (bitSum fbm) $ if ((x1-x0)>1) then B.append (B.replicate (x1-x0) ((endBits fbm)*16)) (fill (rx,ry) ((x1,y1,b1):cs) True) + else (fill (rx,ry) ((x1,y1,b1):cs) True) + | y0 == y1 && inside == True + = B.cons (256-(bitSum fbm)) $ if ((x1-x0)>1) then B.append (B.replicate (x1-x0) ((16-(endBits fbm))*16)) (fill (rx,ry) ((x1,y1,b1):cs) False) + else (fill (rx,ry) ((x1,y1,b1):cs) False) + | y0 /= y1 = B.append (B.append (B.replicate (rx-x0) ((16-(endBits fbm))*16)) + (B.replicate (x1+(y1-y0)*rx) 0)) (fill (rx,ry) ((x1,y1,b1):cs) True) + where + fbm = fillBitmask b0 +fill _ ((x0,y0,b0):cs) _ = B.empty + thawSTU :: (IArray UArray e, MArray (STUArray s) e (ST s)) => UArray Int e -> ST s (STUArray s Int e) thawSTU = thaw thaw2 :: (IArray UArray e, MArray (STUArray s) e (ST s)) => UArray (Int,Int) e -> ST s (STUArray s (Int,Int) e) thaw2 = thaw -array2d_to1d :: Int -> Int -> UArray (Int,Int) Word16 -> UArray Int Word8 -array2d_to1d rx ry mask = runST $ do -- trace ("mask " ++ show mask) runST $ do - ar <- thaw2 mask - m <- newArray (0,rx*ry-1) (0::Word8) :: ST s (STUArray s Int Word8) - forM_ [0..(ry-1)] ( \y -> do - forM_ [0..(rx-1)] ( \x -> do - e <- readArray ar (x,y) - writeArray m (x+y*rx) (fromIntegral e) - ) ) - m' <- unsafeFreeze m - return (m' :: UArray Int Word8) - --- |slice out a single bitmask from an array of bitmasks +-- |Slice out a single bitmask from an array of bitmasks +-- -- (this should be an unboxed array of unboxed arrays, -- but since this is not so easy in Haskell, one 2d-array with a supersampled y-coordinate (*16) is used) -- the x-supersampling are the bits in the Word16 @@ -214,7 +160,23 @@ m' <- unsafeFreeze m return (m' :: Bitmask) --- | bresenham line algorithm + +fillBitmask :: Bitmask -> Bitmask +fillBitmask mask = runST $ do -- trace ("x,y "++ show ix ++ "," ++ show iy ++ " ar ") (runST $ do + m <- newArray (0,15) (0::Word16) :: ST s (STUArray s Int Word16) + ar <- thawSTU mask + forM_ [0..15] $ \y -> do + e <- readArray ar y + writeArray m y (fillLine e) + m' <- unsafeFreeze m + return (m' :: Bitmask) + +-- | after the first occurrance of a 1 set all bits to 1 example: 00001000 ~> 00001111 +fillLine :: Word16 -> Word16 +fillLine w16 = w16 + w16 - 1 + +-- | Bresenham line algorithm +-- -- the data structure for the line is a 2d array of bits, in x-direction a sequence of word16s -- example: line :: Int -> Int -> (Int,Int) -> (Int,Int) -> UArray (Int,Int) Word16 @@ -245,10 +207,9 @@ setPix (a, x, y) = when (x=0 && y>=0) (writeArray a ((x `div` 16), y) (setBit (0::Word16) (x `mod` 16))) -- (x `mod` 16) can be replaced by x? --- data Bitmask = UArray Int Word16 --- | the sum of all bits in a Bitmask, 16 rows with 16 bits each => between 0 and 255 -bitSum :: Bitmask -> Word16 -bitSum mask = runST ( do + +bitSum :: Bitmask -> Word8 +bitSum mask = fromIntegral $ runST ( do s <- var $ 0 ar <- thawSTU mask forM_ [0..15] $ \y -> do @@ -256,9 +217,8 @@ mutate s (+ bits e) get s) --- | return the the rightmost column of a bitmask -endBits :: Bitmask -> Word16 -endBits mask = runST ( do +endBits :: Bitmask -> Word8 +endBits mask = fromIntegral $ runST ( do s <- var $ 0 ar <- thawSTU mask forM_ [0..15] $ \y -> do @@ -266,20 +226,55 @@ mutate s (+ shiftL (e .&. (bit 15)) y) get s) --- | count the number of 1-bits with divide and conquer --- it can be done a little bit faster, but for the beginning it should just be correct --- see "Hacker's Delight by Henry S. Warren, Addison Wesley" for bit counting bits :: Word16 -> Word16 bits w16 = runST ( do s <- var $ w16 -- fst line: starting to count the 1's in 2-tuples: 0x55 = 01010101 -- 2nd line: 4 tuples: 0x33 = 0011001100 sv <- get s - set s (sv .&. 0x5555 + (shiftR sv 1) .&. 0x5555) + sett s (sv .&. 0x5555 + (shiftR sv 1) .&. 0x5555) sv <- get s - set s (sv .&. 0x3333 + (shiftR sv 2) .&. 0x3333) + sett s (sv .&. 0x3333 + (shiftR sv 2) .&. 0x3333) sv <- get s - set s (sv .&. 0x0F0F + (shiftR sv 4) .&. 0x0F0F) + sett s (sv .&. 0x0F0F + (shiftR sv 4) .&. 0x0F0F) sv <- get s - set s (sv .&. 0x00FF + (shiftR sv 8)) + sett s (sv .&. 0x00FF + (shiftR sv 8)) get s ) + +-- | The sum of all bits in a Bitmask, 16 rows with 16 bits each => between 0 and 255 +-- bitSum2 :: B.ByteString -> Word8 -- 8 bytes == 64 grey values +-- bitSum2 bs = B.foldl (+) 0 (B.take 8 (map bits2 bs)) + +-- | Return the the rightmost column of a bitmask +-- endBits2 :: B.ByteString -> Word8 -- 64 grey values +-- endBits2 bs = (B.foldl (+) 0 (B.take 8 (map (\x -> x .&. 1) bs))) * 8 + +tga_trace :: (UArray (Int,Int) Bool, UArray (Int,Int) Word16) -> (UArray (Int,Int) Bool, UArray (Int,Int) Word16) +tga_trace (a,b) = unsafePerformIO $ + do writeTGA "test.tga" tga + return (a,b) + where + tga = trace ((show rx) ++ " " ++ (show ry)) (TGAData (B.empty) + (RGB32 $ B.concat $ map color $ concat $ map bits $ elems b) + 0 0 + (rx*16) ry) + (_,(rx,ry)) = bounds b + bits :: Word16 -> [Word8] + bits a = map (\x -> if x==True then 255 else 0) ( + (testBit a 0) : (testBit a 1) : (testBit a 2) : + (testBit a 3) : (testBit a 4) : (testBit a 5) : + (testBit a 6) : (testBit a 7) : (testBit a 8) : + (testBit a 9) : (testBit a 10): (testBit a 11): + (testBit a 12): (testBit a 13): (testBit a 14): + [testBit a 15] ) + color x = B.cons x $ B.cons x $ B.cons x $ B.singleton x + + -- |Fill a bitmask with 1s if the bit/subpixel is inside a polygon, (the bitmask was filled before with + -- subpixels of outline drawing of the polygon). The bitmask is an array of 16 word16 where the + -- x-direction are the bit position in the word16s. Horizontal(x-direction) lines are drawn if the + -- line is inside the polygon, called a span (see Jordan curve theorem). + -- A subpixel marks the beginnig or the end of a span depending on the state of the line. + -- At the beginning all lines are white, if one intersects a subpixel it becomes black until it + -- hits a subpixel again. The states at the end of the lines are stored for the next pixel in fillSpans. + -- If these state bits are all one or all zero and the next bitmask is completely zero then fewer + -- calculations need to be done. diff --git a/src/Graphics/SVGFonts/ReadFont.hs b/src/Graphics/SVGFonts/ReadFont.hs --- a/src/Graphics/SVGFonts/ReadFont.hs +++ b/src/Graphics/SVGFonts/ReadFont.hs @@ -1,42 +1,52 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts #-} module Graphics.SVGFonts.ReadFont -(triang, cycleNeighbours, displayString, AObj(..),Prop(..), Mode(..), Spacing(..), CharProp(..), makeMaps) +(displayString, + makeOutlMap, makeTexMap, + openFont, + Mode(..), Spacing(..), CharProp(..) +) where -import Text.XML.Light -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.Array hiding (elems,array,bounds) import Data.Char -import Data.Word -import Data.Bits -import Data.Array.Unboxed --- import Graphics.SVGFonts.KETTriangulation ( ketTri ) -import Graphics.SVGFonts.Triangulation (adaptTri, Triangle(..), cycle_n) +import Data.List +import Data.List.Split +import Data.Maybe +import qualified Data.Map as Map +import Data.Tuple.Select +import Debug.Trace +import Graphics.Formats.Collada.ColladaTypes +import Graphics.Formats.Collada.GenerateObjects (cube, blue, obj, makeScene, get_name) +import Graphics.Formats.TGA.TGA +import Graphics.Rendering.OpenGL hiding (Triangle) import Graphics.SVGFonts.RasterFont (raster,F2P,Bitmask,AA(..),createTexture,texData) import Graphics.SVG.ReadPath -import Debug.Trace +import Graphics.Triangulation.Triangulation(polygonDirection, alternate) import List(intersect,sortBy) -import Graphics.Rendering.OpenGL hiding (Triangle) -import Control.Monad -import Control.Monad.ST -import qualified Data.STRef -import Data.Maybe -import qualified Data.Map as Map import System.Directory -import Graphics.Formats.TGA.TGA -import Data.List.Split -import Data.Tuple.Select +import System.IO.Unsafe (unsafePerformIO) +import Text.XML.Light -- http://www.w3.org/TR/SVG/fonts.html#KernElements -type Kern = ( Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Array Int X) +type Kern = ( Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Array Int X ) type SvgGlyph = Map.Map Char (String, X, String) type FontData = (SvgGlyph, Kern, String, String) type X = Float type Y = Float type F2 = (X,Y) +-- | Open an SVG-Font File and extract the data +-- +-- Some explanation how kerning() is computed +-- +-- In Linlibertine.svg, there are two groups of chars: i.e. +-- \ +-- this line means: If there is an f followed by parentright, reduce the horizontal advance by 37. Therefore to quickly +-- check if two characters need kerning assign an index to the second group (g2 or u2) and assign to every unicode in +-- the first group (g1 or u1) this index, then sort these tuples after their name (for binary search). Because the same +-- unicode char can appear in several g1s, reduce this 'multiset', ie all the (\"name1\",0) (\"name1\",1) to (\"name1\",[0,1]). +-- Now the g2s are converted in the same way as the g1s. Whenever two consecutive chars are being printed try to find an +-- intersection of the list assigned to the first char and second char openFont :: FilePath -> FontData openFont file = (Map.fromList (zip4 (unicodes, glyphNames, horiz, ds)), -- sort after unicode (transform u1s, transform u2s, transform g1s, transform g2s, kAr), bbox, fname file ) @@ -56,21 +66,12 @@ g1s = map (fromMaybe "") $ map (findAttr (unqual "g1")) selectKerns g2s = map (fromMaybe "") $ map (findAttr (unqual "g2")) selectKerns ks = map (fromMaybe "") $ map (findAttr (unqual "k")) selectKerns - kAr = listArray (0,(length ks)-1) (map read ks) + kAr = Data.Array.listArray (0,(length ks)-1) (map read ks) transform chars = Map.fromList $ map ch $ multiSet $ map (\(x,y) -> (x,[y])) $ sort fst $ concat $ index chars ch = \(x,y) -> (myHead x,y) - -- ^ see Linlibertine.svg, there are two groups of chars: i.e. - -- - -- this line means: if there is an f followed by parentright reduce the horizontal advance by 37. Therefore to quickly - -- check if two characters need kerning assign an index to the second group (g2 or u2) and assign to every unicode in - -- the first group (g1 or u1) this index, then sort these tuples after their name (for binary search). Because the same - -- unicode char can appear in several g1s, reduce this 'multiset', ie all the ("name1",0) ("name1",1) to ("name1",[0,1]). - -- Now the g2s are converted in the same way as the g1s. Whenever two consecutive chars are being printed try to find an - -- intersection of the list assigned to the first char and second char - - index u = addIndex (map (splitBy isColon) u) -- ^ie ["aa,b","c,d"] to [["aa","b"],["c","d"]] - -- to [("aa",0),("b",0)],[("c",1), ("d",1)] + index u = addIndex (map (splitWhen isColon) u) -- ie ["aa,b","c,d"] to [["aa","b"],["c","d"]] + -- to [("aa",0),("b",0)],[("c",1), ("d",1)] isColon = (== ',') addIndex qs = zipWith (\x y -> (map (f x) y)) [0..] qs @@ -78,7 +79,7 @@ sort f xs = sortBy (\x y -> compare (f x) (f y) ) xs multiSet [] = [] - multiSet (a:[]) = [a] -- ^ example: [("n1",[0]),("n1",[1]),("n2",[1])] to [("n1",[0,1]),("n2",[1])] + multiSet (a:[]) = [a] -- example: [("n1",[0]),("n1",[1]),("n2",[1])] to [("n1",[0,1]),("n2",[1])] multiSet (a:b:bs) | fst a == fst b = multiSet ( (fst a, (snd a) ++ (snd b)) : bs) | otherwise = a : (multiSet (b:bs)) @@ -87,135 +88,13 @@ fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f)) zip4 (a:as, b:bs, c:cs, d:ds) = (myHead a, (b, read c, d)) : (zip4 (as,bs,cs,ds)) zip4 _ = [] - -splitBy :: (a -> Bool) -> [a] -> [[a]] -splitBy _ [] = [] -splitBy f list = first : splitBy f (dropWhile f rest) where - (first, rest) = break f list --- |convert path-commands to outline points, which consist of bitmaps (resolution 16x16) for subpixel rasterization -commandsToRasterPoints :: [PathCommand] -> F2 -> [[F2P]] -commandsToRasterPoints commands (dx, dy) | length result == 0 = [] - | otherwise = map (raster (dx, dy)) result - where result = ctp commands [(0,0)] (0,0) True 255 (dx/2,dy) - ---------------------------------------------------- - -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" - --- |transform a polygon with (nested) holes into one outline. --- I.e. the chars a,b,d,e,g,o,p,q contain holes tat have to be deleted. --- This is useful for operations like extrusion. -deleteHoles :: [PathCommand] -> F2 -> [[F2]] -deleteHoles commands deltas = flatten trees - where trees = generateTrees insidePoly $ commandsToPoints commands deltas - flatten [] = [] - flatten (Nil:ts) = flatten ts - flatten ((Node c poly [Nil]):ts) = (direction c (polygonDirection poly) poly) : (flatten ts) - flatten ((Node c poly ps) :ts) = ( embed (flatten ps) (direction c (polygonDirection poly) poly) ) : (flatten ts) - --- |cut a polygon at a good position and insert the contained hole-polygon with opposite direction -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 (rotatePoly (head s) poly) - --- |make sure that direction (clockwise or ccw) of polygons alternates depending on the nesting number c of 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 -generateTrees :: ([F2]->[F2]->Bool) -> [[F2]] -> [Tree] -generateTrees f [] = [] -generateTrees f ps = mergeNodes f (map (\p -> Node 0 p []) ps) [] - -mergeNodes :: ([F2]->[F2]->Bool) -> [Tree] -> [Tree] -> [Tree] -mergeNodes f [] result = result -mergeNodes f (v:vs) result = mergeNodes f vs (insertNode f v result) - -insertNode :: ([F2]->[F2]->Bool) -> Tree -> [Tree] -> [Tree] -insertNode 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 []) : ( insertNode f (Node (c+1) poly []) ts) -insertNode f (Node c poly []) [] = [(Node c poly [])] -insertNode f (Node _ poly []) ((Node c p ps):ts)|(f poly p) = (Node c p (insertNode f (Node (c+1) poly []) ps)) : ts - |(f p poly) = [Node (c-1) poly ((Node c p ps) : ts)] - |otherwise = (Node c p ps): ( insertNode 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 -rotatePoly :: F2 -> [F2] -> (Int,X) -rotatePoly 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 | (newDist < dist) || (dist < 0) = nearest (x0,y0) ps newDist (l+1) l - | otherwise = nearest (x0,y0) ps dist (l+1) ml - where newDist = (x0-x1)*(x0-x1)+(y0-y1)*(y0-y1) - - -polygonDirection :: [F2] -> Bool -polygonDirection poly = sum (zipWith crossp l1 l2) > 0 - where l1 = map (\(a,b) -> b `sub` a) ((tail c) ++ [head c]) - l2 = map (\(a,b) -> a `sub` b) c - c = map (\list -> (head list, last list)) (cycleNeighbours poly) -- [(p0,p1),(p1,p2),(p2,p3),.. - sub (x0,y0) (x1,y1) = (x0-x1, y0-y1) - crossp (v0,v1) (w0,w1) = v0*w1-v1*w0 - -insidePoly :: [F2] -> [F2] -> Bool -insidePoly [] _ = False -insidePoly _ [] = False -insidePoly poly1 poly2 = pointInside (head poly1) poly2 - --- |A point is inside a polygon if it has an odd number of intersections with the boundary (Jordan Curve theorem) -pointInside :: F2 -> [F2] -> Bool -pointInside (x,y) poly = (length intersectPairs) `mod` 2 == 1 -- trace (show intersectPairs) - where intersectPairs = [ p | p <- allPairs, positiveXAxis p, aboveBelow p] --, specialCases p] - allPairs = cycleNeighbours poly - positiveXAxis p = (x0 p) > x || (x1 p) > x -- ^intersect with positive x-axis - -- only lines with one point above + one point below can intersect - aboveBelow p = (((y0 p)> y && (y1 p)< y) || ((y0 p) < y && (y1 p) > y)) - specialCases 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] ] -cycleNeighbours :: [a] -> [[a]] -cycleNeighbours [] = [] -cycleNeighbours xs = cycleN (head xs) xs - -cycleN :: a -> [a] -> [[a]] -cycleN f (x:y:xs) = [x,y] : (cycle_n f (y:xs)) -cycleN f e = [[head e, f ]] -- ^if the upper doesn't match close cycle - -triang :: [(X,Y)] -> [(Int,Int,Int)] -triang poly = [] -- map indi (adaptTri poly) -- ketTri poly - where indi (Triangle ((_,_,i0), (_,_,i1), (_,_,i2))) = (i0,i1,i2) - -data F a = NotFound | Found a -fromFound (Found a) = a -instance Eq (F a) where - NotFound == NotFound = True - _ == _ = False - -- type Kern = ( Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Array Int X) -- |horizontal advances of characters inside a string -horizontalAdvances :: [(Char,FontData)] -> Bool -> [X] -- Kern -> SvgGlyph -> [X] -horizontalAdvances strfont kerning = hlist strfont -- kern glyphData = hlist str +horizontalAdvances :: [(Char,FontData)] -> Bool -> [X] +horizontalAdvances strfont kerning = hlist strfont where hlist :: [(Char,FontData)] -> [X] + hlist [] = [] hlist [(ch0,fd0)] = [ha ch0 fd0] hlist ((ch0,fd0):(ch1,fd1):s) = ((ha ch0 fd0) + (ka ch0 ch1 fd0 fd1 (sel2 fd0))) : (hlist ((ch1,fd1):s)) ka :: Char -> Char -> FontData -> FontData -> Kern -> Float @@ -225,64 +104,35 @@ ha ch fd = sel2 $ fromJust $ Map.lookup ch (sel1 fd) kernAdvance :: Char -> Char -> Kern -> Bool -> X -kernAdvance ch0 ch1 kern u | u && (length s0) > 0 = (sel5 kern)!(head s0) - | not u && (length s1) > 0 = (sel5 kern)!(head s1) +kernAdvance ch0 ch1 kern u | u && (length s0) > 0 = (sel5 kern)Data.Array.!(head s0) + | not u && (length s1) > 0 = (sel5 kern)Data.Array.!(head s1) | otherwise = 0 where s0 = intersect (s sel1 ch0) (s sel2 ch1) s1 = intersect (s sel3 ch0) (s sel4 ch1) s sel ch = concat (maybeToList (Map.lookup ch (sel kern))) --- |extrude a 2d polygon to 3d, the same points are added again with extrusion direction v -add_points3d :: V -> Prop -> [AObj] -> [AObj] -add_points3d v pr [] = [] -add_points3d v pr poly = - poly ++ -- bottom polygon - ( map (add_points v pr) (map (\x -> Annotate x pr) (cycleNeighbours (de_ann(head poly)))) ) ++ --side polygons - [ Annotate (map (add v) (de_ann(head poly))) (property (head poly)) ] -- top polygon - -property (Annotate ps pr) = pr -de_ann (Annotate ps pr) = ps - --- extrude a line to a construct a polygon -add_points :: V -> Prop -> AObj -> AObj -add_points v pr (Annotate p _) = Annotate (p ++ (map (add v) (reverse p))) pr --- add_points v pr _ = Annotate [] pr - - -type O = V -- position vector -data Prop = RedGreenBlue (Float, Float, Float) | N | -- N = not visible - TexObj (TextureObject,String) | - Textur (Maybe TextureObject) | - TexFile String | - Triangul [(Int,Int,Int)] -- list of triangles - -data CharProp = Outline V | Textured | ObjColor Int Int Int Int | Font (FontData, OutlineMap, TexMap) -data AObj = Annotate [V] Prop type V = (Float,Float,Float) -- x,y,z -blue = RedGreenBlue (0,0,1) +type O = V -- position vector set_len (x,y,z) l = (x*c*l, y*c*l, z*c*l) where c = 1 / v_len (x,y,z) v_len (x,y,z) = sqrt (x*x+y*y+z*z) - divide (x,y,z) c = (x/c, y/c, z/c) mul (x,y,z) c = (x*c, y*c, z*c) add (x0,y0,z0) (x1,y1,z1) = (x0+x1, y0+y1, z0+z1) - n = (0,0,0) --- ------------------------ --- main library functions --------------------------- -type TexMap = Map.Map Char (TextureObject, String) -type OutlineMap = Map.Map Char [([F2], Prop)] -data Mode = INSIDE_V1_V2_V3 | -- the string is inside v1 v2 v3 boundaries (height/length-relation not kept) - INSIDE_V1 | -- stay inside v1 boundary, size of v2 adjusted to height/length-relation - INSIDE_V2 -- stay inside v2 boundary, size of v1 adjusted to height/length-relation -data Spacing = MONO | -- use mono spacing between glyphs - HADV | -- every glyph has a unique constant horiz. advance - KERN -- same as HADV but sometimes overridden by kerning: i.e. the horizontal advance in "VV" is bigger than in "VA" +type TexMap = Map.Map (Char,String,String,Bool) (TextureObject, String) +type OutlineMap = Map.Map Char [[F2]] +data Mode = INSIDE_V1_V2 -- ^The string is inside v1 v2 boundaries (height/length-relation not kept) + | INSIDE_V1 -- ^Stay inside v1 boundary, size of v2 adjusted to height/length-relation + | INSIDE_V2 -- ^Stay inside v2 boundary, size of v1 adjusted to height/length-relation -mV1V2V3 INSIDE_V1_V2_V3 = True +data Spacing = MONO -- ^Use mono spacing between glyphs (used in programming) + | HADV -- ^Every glyph has a unique constant horiz. advance + | KERN -- ^Same as HADV but sometimes overridden by kerning: i.e. the horizontal advance in \"VV\" is bigger than in \"VA\" + -- + +mV1V2V3 INSIDE_V1_V2 = True mV1V2V3 _ = False mV1 INSIDE_V1 = True mV1 _ = False @@ -295,126 +145,142 @@ isKern _ = False type FileName = String -type P = [Char] -> [(Char,[CharProp])] +type P = [Char] -> [String] +data CharProp = Prop (FontData, OutlineMap) String Bool +type Transf = Map.Map String (Geometry -> Geometry) +type Props = Map.Map String CharProp +-- | Main library function +-- +-- The string to display, resolution: (Int,Int) , mode, spacing, position and size apply to a whole string and therefore +-- are given here. There are local properties that can be unique for every char like Font, Color, ... . +-- These are given with a property function that assign a list of properties to every char: P -displayString :: String -> (Int,Int) -> Mode -> Spacing -> O -> V -> V -> P -> [AObj] -displayString str (rx,ry) mode spacing o v1 v2 f | mV1V2V3 mode = concat (make_string v1 v2) - | mV1 mode = concat (make_string v1 new_v2) - | mV2 mode = concat (make_string new_v1 v2) +displayString :: String -> String -> (Int,Int) -> Props -> Transf -> Mode -> Spacing -> O -> V -> V -> P -> TexMap -> Scene +displayString str sid (rx,ry) props transf mode spacing o v1 v2 f tex | mV1V2V3 mode = make_string v1 v2 + | mV1 mode = make_string v1 new_v2 + | mV2 mode = make_string new_v1 v2 where - -- :type FontData = ([(glyph_names, unicodes, horiz_advance, ds)], Kern, bbox-string) - make_string u1 u2 = map (getC u1 u2 (sumh,(max_x,max_y)) (rx,ry)) (zip4 str hor_pos hs properties) + -- FontData = ([(glyph_names, unicodes, horiz_advance, ds)], Kern, bbox-string, filename) + make_string u1 u2 = makeScene sid $ map (\(x,y) -> obj (get_name (head x)) x y) (geometrieVs u1 u2) + geometrieVs u1 u2 = map (getC u1 u2 sumh (rx,ry) tex) (zip5 str hor_pos hs properties trList) sumh | isMono spacing = max_x * (fromIntegral (length str)) -- not meant to be monospaced, so this is just a hack | otherwise = sum hs -- maybe a very long glyph can mess up a font hor_pos | isMono spacing = reverse $ added (o: (replicate (length str) (v1_advance `mul` max_x))) | otherwise = reverse $ added (o: stretch hs) - hs = horizontalAdvances (zip str fontList) (isKern spacing) -- kern_list (sel1 fontD) - properties = map snd (f str) + hs = horizontalAdvances (zip str fontList) (isKern spacing) + properties = map (fromJust.((\x y -> Map.lookup y x) props)) (f str) fontList = map (sel1.getFont) properties + trList = map (fromJust.((\x -> Map.lookup x transf).getTr)) properties stretch = map (v1_advance `mul`) added = snd.(foldl (\(h,l) (b,_) -> (h`add`b, (h`add`b):l)) ((0,0,0),[])).(map (\x->(x,[]))) -- [o,o+h0,o+h0+h1,..] - new_v1 = set_len v1 ( (v_len v2) * (sumh/max_y) ) - new_v2 = set_len v2 ( (v_len v1) * (max_y/sumh) ) - max_x = maximum (map maximum_x fontList) - max_y = maximum (map maximum_y fontList) -- max height of glyph + new_v1 = set_len v1 ( (v_len v2) * (sumh/max_y) ) -- in case there are several fonts in a string + new_v2 = set_len v2 ( (v_len v1) * (max_y/sumh) ) -- max_y is the average of max heights + max_x = (sum (map maximum_x fontList)) / (fromIntegral (length fontList)) -- difficult to treat different fonts in one string + max_y = (sum (map maximum_y fontList)) / (fromIntegral (length fontList)) -- max height of glyph v1_advance | mV1V2V3 mode || mV1 mode = v1 `divide` sumh | mV2 mode = new_v1 `divide` sumh - - zip4 (a:as) (b:bs) (c:cs) (d:ds) = (a, b, c, d) : (zip4 as bs cs ds) - zip4 _ _ _ _ = [] - -getC u1 u2 tri (rx,ry) (ch,h,h_ad,pr) | or (map hasTex pr)= texChar (sel1 sfd) tm u1 u2 tri (ch,h,h_ad) - | (length v3s) > 0 = polygonChar (sel1 sfd) om sfd u1 u2 (head v3s) tri (rx,ry) (ch,h) - | otherwise = [] - where hasTex :: CharProp -> Bool - hasTex Textured = True - hasTex _ = False - - v3s :: [V] - v3s = concat (map outl pr) - outl (Outline v3) = [v3] - outl _ = [] + zip5 (a:as) (b:bs) (c:cs) (d:ds) (e:es) = (a, b, c, d, e) : (zip5 as bs cs ds es) + zip5 _ _ _ _ _ = [] +getC u1 u2 sh (rx,ry) tex (ch,h,h_ad,pr,tr) | isTex pr = texChar (sel1 sfd) tex u1 u2 sh (ch,h,h_ad) + | otherwise = (map tr (fst pc), snd pc) + where pc = polygonChar (sel1 sfd) om sfd u1 u2 sh (rx,ry) (ch,h) + isTex :: CharProp -> Bool + isTex (Prop _ _ b) = b sfd = sel1 fd fd = getFont pr om = sel2 fd - tm = sel3 fd -getFont :: [CharProp] -> (FontData, OutlineMap, TexMap) -getFont pr = head $ concat (map gF pr) -- if several Fonts are given, take the first - where gF (Font (fontD, outlMap, texMap)) = [(fontD, outlMap, texMap)] - gF _ = [] +-- data CharProp = Prop (FontData, OutlineMap) Bool (Geometry -> Geometry) +getFont :: CharProp -> (FontData, OutlineMap) +getFont (Prop pr _ _) = pr +getTr :: CharProp -> String +getTr (Prop _ tr _) = tr maximum_y fontData = read (head (drop 3 bbox)) -- bbox lower left x, lower left y, upper right x, upper right y - where bbox = splitBy isSpace (sel3 fontData) + where bbox = splitWhen isSpace (sel3 fontData) maximum_x fontData = read (head (drop 2 bbox)) - where bbox = splitBy isSpace (sel3 fontData) - + where bbox = splitWhen isSpace (sel3 fontData) -polygonChar :: SvgGlyph -> OutlineMap -> FontData -> V -> V -> V -> (Float, F2) -> (Int,Int) -> (Char,V) -> [AObj] -polygonChar g outl fontD v1 v2 v3 (sum_of_hs, (max_x, max_y)) (rx,ry) (ch,h) = glyph_faces - where - glyph_faces = if (length out_tri) == 0 then [] else glyph3d -- all the triangles/quads the whole glyph has - -- tail (init glyph3d) -- with tail and init top and bottom polygon are deleted - glyph3d = concat ( map (\(o,t) -> add_points3d v3 blue [ Annotate (map resize o) t ] ) (out_tri) ) - resize (x,y) = h `add` (v1 `mul` (x * (fst deltas) / sum_of_hs)) `add` (v2 `mul` (y * (snd deltas)/ max_y)) +polygonChar :: SvgGlyph -> OutlineMap -> FontData -> V -> V -> Float -> (Int,Int) -> (Char,V) -> ([Geometry],V) +polygonChar g outl fontD v1 v2 sum_of_hs (rx,ry) (ch,h) = ([geometry],h) + where -- h `add` + resize (x,y) = (v1 `mul` (x * (fst deltas) / sum_of_hs)) `add` (v2 `mul` (y * (snd deltas)/ max_y)) deltas = (max_x/(fromIntegral rx), max_y/(fromIntegral ry)) - out_tri = fromJust $ Map.lookup ch outl + out = fromJust $ Map.lookup ch outl + max_x = maximum_x fontD + max_y = maximum_y fontD + l = map (map resize) out + geometry = Geometry ("outline_" ++ [ch]) + [ LP (LinePrimitive indices indices [] [blue]) ] + (Vertices "cube_vertices" (concat l) -- vertices + (replicate (length (concat l)) (0,0,1)) )-- normals + indices = parts 0 lengths + parts n (l:ls) = [n..(n+l-1)] : (parts (n+l) ls) + parts _ [] = [] + lengths = map length l -texChar :: SvgGlyph -> TexMap -> V -> V -> (Float, F2) -> (Char,V,Float) -> [AObj] -texChar g texmap v1 v2 (sumh, (max_x, max_y)) (ch,h,h_ad) = - [ Annotate [ res (n,v2), res (n,n), res (v1,n), res (v1,v2) ] (TexObj tex) ] -- n = (0,0,0) +texChar :: SvgGlyph -> TexMap -> V -> V -> Float -> (Char,V,Float) -> ([Geometry],V) +texChar g texmap v1 v2 sum_of_hs (ch,h,h_ad) = ([geometry],h) +-- [ Annotate [ res (n,v2), res (n,n), res (v1,n), res (v1,v2) ] (TexObj tex) ] -- n = (0,0,0) where - res (v,w) = h `add` (v `mul` (h_ad / sumh)) `add` w - tex = fromJust (Map.lookup ch texmap) - - -makeMaps :: String -> (Int,Int) -> (FontData, OutlineMap, TexMap) -makeMaps str (rx,ry) = (fontD, makeOutlMap fontD (rx,ry), makeTexMap fontD (rx,ry)) - where fontD = openFont str + geometry = Geometry "outline" + [ LP (LinePrimitive indices indices [] [blue]) ] + (Vertices "cube_vertices" l -- vertices + (replicate 4 (0,0,1)) ) -- normals + l = [res (n,v2), res (n,n), res (v1,n), res (v1,v2)] + indices = [[0,1,2,3]] + res (v,w) = h `add` (v `mul` (h_ad / sum_of_hs)) `add` w +-- tex = fromJust (Map.lookup ch texmap) +-- | Avoid recalculation of font data, outlines and textures +-- -- a char like "i" has two outlines (one for the dot) and two triangulations -makeOutlMap :: FontData -> (Int,Int) -> OutlineMap -- type OutlineMap = Map.Map Char [([F2], Prop)] -makeOutlMap fontD (rx,ry) = Map.fromList [ (ch, zip (outlines ch) (triangles ch)) | ch <- allUnicodes ] +makeOutlMap :: String -> (Int,Int) -> (FontData, OutlineMap) -- type OutlineMap = Map.Map Char [([F2], Prop)] +makeOutlMap str (rx,ry) = (fontD, Map.fromList [ (ch, outlines ch) | ch <- allUnicodes ] ) where allUnicodes = Map.keys (sel1 fontD) - outlines ch = fst (glyph ch) - triangles ch = map (\x -> Triangul x) (snd (glyph ch)) max_x = maximum_x fontD max_y = maximum_y fontD - deltas = (max_x/(fromIntegral rx), max_y/(fromIntegral ry)) -- [ ([F2],[ (Int,Int,Int) ]) ] - glyph ch = trace ("outl ch " ++ show ch) getGlyphPolygon ch (sel1 fontD) deltas + deltas = (max_x/(fromIntegral rx), max_y/(fromIntegral ry)) + outlines ch = getGlyphPolygon ch (sel1 fontD) deltas + fontD = openFont str -makeTexMap :: FontData -> (Int,Int) -> TexMap -makeTexMap fontD (rx,ry) = Map.fromList [ (ch, (glyph ch)) | ch <- allUnicodes ] - where - allUnicodes = Map.keys (sel1 fontD) - max_x = maximum_x fontD - max_y = maximum_y fontD - nrx ch = fromIntegral $ round ((fromIntegral ry)*((h ch)/max_y)) -- ry/rx * (h_ad/max_y) * rx - h ch = sel2 (fromJust (Map.lookup ch (sel1 fontD))) - deltas ch = (max_x/(fromIntegral (nrx ch)), max_y/(fromIntegral ry)) - glyph ch = trace ("tex ch " ++ show ch) (unsafePerformIO $ getGlyphTexture ch fontD (nrx ch, fromIntegral ry) (deltas ch)) +-- data CharProp = Prop (FontData, OutlineMap) String Bool +makeTexMap :: (Int,Int) -> Props -> Transf -> TexMap +makeTexMap (rx,ry) ps trs = Map.fromList [ (getID ch p, (glyph ch p)) | p <- (Map.elems ps), isTex p, ch <- (allUnicodes p) ] + where + allUnicodes (Prop (fontD,_) _ _) = Map.keys (sel1 fontD) + max_x ch fontD = h ch fontD -- maximum_x fontD + max_y fontD = maximum_y fontD + nrx ch fontD = fromIntegral $ round ((fromIntegral ry)*((h ch fontD)/ (max_y fontD))) -- ry/rx * (h_ad/max_y) * rx + h ch fontD = sel2 (fromJust (Map.lookup ch (sel1 fontD))) + deltas ch fontD = ((max_x ch fontD)/(fromIntegral (nrx ch fontD)), (max_y fontD)/(fromIntegral ry)) + isTex (Prop _ _ tex) = tex + glyph ch (Prop (fontD,outl) tr _) = unsafePerformIO $ getGlyphTexture ch fontD (nrx ch fontD, fromIntegral ry) (deltas ch fontD) + getID :: Char -> CharProp -> (Char,String,String,Bool) + getID ch (Prop (fontD, _) transformation tex) = (ch, sel4 fontD, transformation, tex) +-- trNames = zip trs (map (\(Geometry str _ _) -> str) $ map (f cube) trs) +-- f a b = b a -getGlyphPolygon :: Char -> SvgGlyph -> F2 -> ([[F2]], [[ (Int,Int,Int) ]]) -getGlyphPolygon ch glyph deltas = (outlines, map triang outlines) -- the triangulation is a list of triangles(3 indices) - where d = sel3 (fromJust element) -- ie. a letter like 'i' consists of two lists of triangles +getGlyphPolygon :: Char -> SvgGlyph -> F2 -> [[F2]] +getGlyphPolygon ch glyph deltas = outlines -- the triangulation is a list of triangles(3 indices) + where d = sel3 (fromJust element) -- ie. a letter like 'i' consists of two lists of triangles element = Map.lookup ch glyph - outl = (deleteHoles commands deltas) - outlines = map (\o -> direction 0 (polygonDirection o) o) outl + outlines = commandsToPoints commands deltas commands | (length d) == 0 = [] | otherwise = unsafePerformIO ( pathFromString d ) getGlyphTexture :: Char -> FontData -> (Int,Int) -> F2 -> IO (TextureObject,String) -getGlyphTexture ch fontD (rx,ry) (dx,dy) = trace (show fileName) - (do fileExists <- doesFileExist fileName - if fileExists then do tga <- (readTGA fileName) - createTexture (rx,ry) tga fileName - else do (writeTGA fileName (texData (rx,ry) border_points)) - tga <- (readTGA fileName) - createTexture (rx,ry) tga fileName) +getGlyphTexture ch fontD (rx,ry) (dx,dy) = (do fileExists <- doesFileExist fileName + if fileExists then do tga <- (readTGA fileName) + createTexture (rx,ry) tga fileName + else do (writeTGA fileName (texData (rx,ry) border_points)) + tga <- (readTGA fileName) + createTexture (rx,ry) tga fileName + ) where d = sel3 (fromJust element) fileName = [ch] ++ "_" ++ (sel4 fontD) ++ (show rx) ++ "x" ++ (show ry) ++ ".tga" element = Map.lookup ch (sel1 fontD) @@ -423,3 +289,9 @@ texturing = True commands | (length d) == 0 = [] | otherwise = unsafePerformIO ( pathFromString d ) + +-- |convert path-commands to outline points, which consist of bitmaps (resolution 16x16) for subpixel rasterization +commandsToRasterPoints :: [PathCommand] -> F2 -> [[F2P]] +commandsToRasterPoints commands (dx, dy) | length result == 0 = [] + | otherwise = map (raster (dx, dy)) result + where result = ctp commands [(0,0)] (0,0) True 255 (dx,dy) diff --git a/src/Graphics/SVGFonts/Triangulation.hs b/src/Graphics/SVGFonts/Triangulation.hs deleted file mode 100644 --- a/src/Graphics/SVGFonts/Triangulation.hs +++ /dev/null @@ -1,177 +0,0 @@ -module Graphics.SVGFonts.Triangulation (adaptTri,Triangle(..),cycle_n) where - -import Maybe ( fromJust, mapMaybe, isJust ) -import List ( elemIndex ) -import Array ( Array, listArray, (!) ) -import Graphics.SVGFonts.TriangulationUtils hiding (intersection,vertices) -import Debug.Trace - -diagonal :: (Ord a, Floating a) => [P2 a] -> Line a -diagonal ps = case searchTriangles (m,i,p) ps of - Nothing -> Segment m p - Just q -> Segment i q - where (m,i,p) = findConvexVertex ps - -findConvexVertex :: (Ord a, Num a) => [P2 a] -> (P2 a, P2 a, P2 a) -findConvexVertex = head . filter (uncurry3 isLeftTurn) . angles - -searchTriangles :: (Floating a, Ord a) => Angle a -> [P2 a] -> Maybe (P2 a) -searchTriangles x@(m,i,p) ps - | y == a || y == b = Just y - | isJust inLeft && l /= m = inLeft - | isJust inRight && r /= p = inRight - | otherwise = Nothing - where ray = bisectInteriorAngle x - ps' = sublist p m ps - (a, y, b) = intersection ray x ps' - inLeft = vertexInTriangle (i,y,b) (sublist b m ps') - (Just l) = inLeft - inRight = vertexInTriangle (y,i,a) (sublist p a ps') - (Just r) = inRight - -bisectInteriorAngle :: (Ord a, Floating a) => Angle a -> Line a -bisectInteriorAngle (m,(ix,iy,ii),p) --- | phi > 0 = Ray i (rotate m i (-(2*pi-phi)/2)) - | phi > 0 = Ray i (rotate m (ix,iy,ii) (phi/2 - pi)) --- | phi == 0 = Ray i (ix+1,iy,ii) - | phi == 0 = Ray i (ix+1,iy,ii) - | phi < 0 = Ray i (rotate m i (phi/2)) - where phi = angle3 p i m - i = (ix,iy,ii) - -intersection :: (Ord a, Fractional a) => Line a -> Angle a -> [P2 a] -> Angle a -intersection ray (m,i,p) ps = minimumWith (\ (_,y,_) -> sqrDistance i y) is - where - is = mapMaybe inters (init (edges ps)) - inters (i,j) - | isJust res = Just (i,y,j) - | otherwise = Nothing - where - res = intersect ray (Segment i j) - y = fromJust res - -vertexInTriangle :: (Ord a, Num a) => Angle a -> [P2 a] -> Maybe (P2 a) -vertexInTriangle t@(p,q,r) xs = case filter (Triangle t `contains`) xs of - [] -> Nothing - ys -> Just (minimumBy (isLeftTurn p) ys) - --- Wir benötigen folgende Hilfsfunktionen: - --- S.15, |Wedge p q r| ist der Teil der Ebene, der ``rechts'' durch den von |p| ausgehenden Strahl --- durch |q| und ``rechts'' durch |r| begrenzt wird. Wir benötigen einen Test, ob eine Strecke in --- einem Keil enthalten ist. - -inWedge :: (Ord a, Floating a) => (P2 a, P2 a) -> (P2 a, P2 a, P2 a) -> Bool -(a,b) `inWedge` (p,q,s) - | r > 0 = not ( (0r && j<=0 && j>r - | r == 0 = True - | otherwise = False --- temp solution - where r = angleWrt p q s - i = angleWrt p q a - j = angleWrt p q b - -adaptTri :: (Floating a, Ord a) => [(a,a)] -> [Triangle a] -- newtype (Num a) => Triangle a = Triangle ((a,a,Int), (a,a,Int), (a,a,Int)) -adaptTri poly = triangulate ds - where - ds = [(i,j), (j,i)] -- the polygon is splitted in two parts: the lines from i to j (i,j) and from j to i - where i = sel3_3 xi - j = sel3_3 xj - (Segment xi xj) = diagonal ps -- a diagonal is a line inside the polygon - - triangulate [] = [] - triangulate ((i,j):ds) = map snd ts ++ triangulate (ds' ++ ds) - where (ds', ts) = sleeve i j [] - - ps = vertices poly - n = length ps - arr = listArray (0,n-1) ps - pred i = (i-1) `mod` n - succ i = (i+1) `mod` n - angle i = (arr!(pred i), arr!i, arr!(succ i)) - - sleeve i j ts -- ts are the accumulated triangles - | i==j || i==succ j || j==succ i = ([], ts) -- a triangle with i,j and something between - | (xi,xip) `inWedge` (xi,xj,xim) && (xj,xjm) `inWedge` (xj,xjp,xi) = turns (orientation xjm xj xi) (orientation xip xi xj) - | otherwise = freeTriangle - where - (xim,xi,xip) = angle i - (xjm,xj,xjp) = angle j - inBetween = sublist xip xjm ps - index x = (i + 1 + (fromJust (elemIndex x inBetween))) `mod` n - - turns Clockwise Clockwise = nexti - turns Collinear Clockwise = nexti - turns CounterClockwise CounterClockwise = prevj - turns CounterClockwise Collinear = prevj - turns CounterClockwise Clockwise - | xjm `inInteriourOf` (Triangle (xip,xi,xj)) = prevj - | otherwise = nexti - turns _ _ - | null wrongTriangles = newFreeTriangle - | otherwise = freeTriangle - - nexti = sleeve (succ i) j (((j,i,succ i), Triangle (xj,xi,xip)) : ts) - prevj = sleeve i (pred j) (((j,i,pred j), Triangle (xj,xi,xjm)) : ts) - - (ts', wrongTriangles) - | (xi,xip) `inWedge` (xi,xj,xim) = findWrong ts - | otherwise = let (vs, w:ss) = splitWhile notInTri ts - (xs, ws) = findWrong ss - in (xs, ws ++ [w] ++ reverse vs) - where - notInTri (_,t) = trace (show (not (t `containsBNV` xip))) (not (t `containsBNV` xip)) - findWrong ts = foldl delete (ts, []) (zip inBetween (tail inBetween)) - delete (ts, ts') (p, q) = (ds, reverse cs ++ ts') - where - (cs, ds) = splitWhile (doIntersect (Segment p q) . diag) ts - diag ((j,i,n), Triangle (xj,xi,xn)) - | n == succ i = Segment xn xj - | n == pred j = Segment xi xn - - -- after Lemma 5 - freeTriangle - | null wrongTriangles = ([], ts) - | otherwise = ([(s,k),(k,r)], (undefined, Triangle (xr,xs,xk)) : ts') - where - ((r,s,t), tri@(Triangle (xr,xs,xt))) = head wrongTriangles - inTriangle = filter (tri `containsBNV`) inBetween - xk = minimumWith (key xs xr) inTriangle - k = index xk - - key p q x = (angle3 x q p, sqrDistance q x) - - -- after Lemma 2+3 - newFreeTriangle = ([(i,l),(l,j)], (undefined, Triangle (xj,xi,xl)) : ts) - where - xk = fromJust (searchTriangles (xj,xi,xip) inBetween) - inTriangle = filter (Triangle (xj,xi,xk) `contains`) - (sublist2 xk xj inBetween) - xl | null inTriangle = xk - | otherwise = minimumWith (key xi xj) inTriangle - l = index xl - --- make vertices of polygon counterclockwise and add an index -vertices :: (Floating a, Ord a) => [(a,a)] -> [(a,a,Int)] -vertices qs | polygon_direction ps = ps - | otherwise = reverse ps - where ps = zipWith (\(x,y) z -> (x,y,z) ) qs [0..] - -polygon_direction :: (Floating a, Ord a) => [(a,a,Int)] -> Bool -polygon_direction poly = sum (zipWith crossp l1 l2) > 0 - where l1 = map (\(a,b) -> b `sub` a) ((tail c) ++ [head c]) - l2 = map (\(a,b) -> a `sub` b) c - c = map to_tuple (cycle_neighbours poly) -- [(p0,p1,0),(p1,p2,1),(p2,p3,2),.. - to_tuple (a:b:[]) = (a,b) - sub (x0,y0,_) (x1,y1,_) = (x0-x1, y0-y1, 0) - crossp (v0,v1,_) (w0,w1,_) = v0*w1-v1*w0 - --- 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 diff --git a/src/Graphics/SVGFonts/TriangulationUtils.hs b/src/Graphics/SVGFonts/TriangulationUtils.hs deleted file mode 100644 --- a/src/Graphics/SVGFonts/TriangulationUtils.hs +++ /dev/null @@ -1,226 +0,0 @@ -module Graphics.SVGFonts.TriangulationUtils where -import Maybe ( isJust, fromJust ) - -type P2 a = (a,a,Int) -type Angle a = (P2 a, P2 a, P2 a) -data (Num a) => Line a = Segment { point1, point2 :: P2 a } - | Ray { point1, point2 :: P2 a } - | Line { point1, point2 :: P2 a } - -angles :: [a] -> [(a,a,a)] -angles xs = zip3 (rotateR xs) xs (rotateL xs) - -isRightTurnOrOn m x p = (area2 m x p) <= 0 -isLeftTurn m x p = (area2 m x p) > 0 -area2 (x2,y2,_) (x0,y0,_) (x1,y1,_) = (x1-x0)*(y2-y0)-(x2-x0)*(y1-y0) - -containsBNV (Triangle (s,t,v)) p = (a==b && b==c) - where a = isLeftTurn s t p - b = isLeftTurn t v p - c = isLeftTurn v s p - -data Orientation = Collinear | Clockwise | CounterClockwise - deriving (Eq, Show) - -orientation :: (Num a, Ord a) => P2 a -> P2 a -> P2 a -> Orientation -orientation p q r - | s>0 = CounterClockwise -- to the left - | s==0 = Collinear - | s<0 = Clockwise -- to the right - where s = area2 p q r - -angle2 :: (Floating a, Ord a) => P2 a -> P2 a -> a -angle2 x y | denum == 0 = 0 - | cosPhi >= 1.0 = 0 - | cosPhi <= -1.0 = pi - | cross2 x y >= 0 = acos cosPhi - | otherwise = - acos cosPhi - where denum = (x <.> x) * (y <.> y) - cosPhi = (x <.> y) / sqrt denum - -(x0,y0,i) <.> (x1,y1,b) = x0*y0 + x1*y1 - -cross2 :: Num a => P2 a -> P2 a -> a -(x0,y0,a) `cross2` (x1,y1,b) = x0*y1 - x1*y0 - -rotateL xs = tail xs ++ [head xs] -rotateR xs = [last xs] ++ init xs - -add (ax,ay,i) (bx,by,_) = (ax+bx,ay+by,i) -sub (ax,ay,i) (bx,by,_) = (ax-bx,ay-by,i) - -sel3_1 (x,y,z) = x -sel3_2 (x,y,z) = y -sel3_3 (x,y,z) = z - -uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) -uncurry3 f p = f (sel3_1 p) (sel3_2 p) (sel3_3 p) - -sublist, sublist2, takeDrop :: Eq a => a -> a -> [a] -> [a] -sublist i j xs = takeDrop i j xs ++ [j] -sublist2 i j xs = case takeDrop i j xs of { [] -> []; ys -> tail ys } -takeDrop i j xs = takeWhile (/=j) (dropWhile (/=i) (xs++xs)) - -rotate :: (Floating a, Ord a) => P2 a -> P2 a -> a -> P2 a -rotate p o phi = o `add` (rotateOrg (p `sub` o) phi) - -rotateOrg :: (Floating a, Ord a) => P2 a -> a -> P2 a -rotateOrg (x,y,i) phi = (x*cos phi - y*sin phi, x*sin phi + y*cos phi,i) - -angleWrt, angle3 :: (Floating a, Ord a) => P2 a -> P2 a -> P2 a -> a -angleWrt p q r = angle2 (q `sub` p) (r `sub` p) -angle3 p q r = (-1) * angle2 (p `sub` q) (r `sub` q) - -choose1, choose2 :: Rel a -> (a -> a -> a) -choose1 rel x y = if x `rel` y then x else y -choose2 rel x y = if x `rel` y then y else x - -minimumBy, maximumBy :: Rel a -> [a] -> a -minimumBy rel = foldl1 (\ x y -> if x `rel` y then x else y) --- minimumBy = foldl1 . choose1 -maximumBy = foldl1 . choose2 - -extremaBy :: Rel a -> [a] -> [a] -extremaBy cmp [] = [] -extremaBy cmp [x] = [x] -extremaBy cmp xs@(_:_:_) = [minimumBy cmp xs, maximumBy cmp xs] - - -type Rel a = a -> a -> Bool -data With a b = a :& b - -sat :: With a b -> b -sat (a :& b) = b - -liftToWith :: (a -> b -> c) -> With a d -> With b e -> c -liftToWith r (a :& _) (b :& _) = a `r` b - -instance Eq a => Eq (With a b) where - (==) = liftToWith (==) - -instance Ord a => Ord (With a b) where - compare = liftToWith compare - -minimumWith, maximumWith :: Ord b => (a -> b) -> [a] -> a -minimumWith f xs = sat (minimum [f x :& x | x<-xs]) -maximumWith f xs = sat (maximum [f x :& x | x<-xs]) - -minima, maxima :: Ord a => [a] -> [a] -minima = minimaBy compare -maxima = maximaBy compare - -minimaBy, maximaBy :: (a -> a -> Ordering) -> [a] -> [a] -minimaBy cmp (x:xs) = foldl f [x] xs - where f ms@(h:_) b = case cmp b h of - LT -> [b] - EQ -> b:ms - GT -> ms - -maximaBy cmp (x:xs) = foldl f [x] xs - where f ms@(h:_) b = case cmp b h of - GT -> [b] - EQ -> b:ms - LT -> ms - -minimaWith, maximaWith :: Ord b => (a -> b) -> [a] -> [a] -minimaWith f xs = map sat (minima [f x :& x | x<-xs]) -maximaWith f xs = map sat (maxima [f x :& x | x<-xs]) - -minimaWithBy, maximaWithBy :: (a -> a -> Ordering) -> (b -> a) -> [b] -> [b] -minimaWithBy cmp f xs = map sat (minimaBy (liftToWith cmp) [f x :& x | x<-xs]) -maximaWithBy cmp f xs = map sat (maximaBy (liftToWith cmp) [f x :& x | x<-xs]) - - - -sqrDistance (x0,y0,_) (x1,y1,_) = r <.> r where r = (x0-x1,y0-y1,0) - -edges :: [a] -> [(a,a)] -edges xs = zip xs (rotateL xs) - - -intersect, strictIntersect :: (Ord a, Fractional a) => Line a -> Line a -> Maybe (P2 a) -doIntersect,doStrictIntersect :: (Ord a, Fractional a) => Line a -> Line a -> Bool - -intersect s1 s2 - | isJust res && ok s1 r && ok s2 s = Just i - | otherwise = Nothing - where - res = intersection s1 s2 - (i,r,s) = fromJust res - ok (Segment _ _) r = 0<=r && r<=1 - ok (Ray _ _) r = r>=0 - ok (Line _ _) r = True - -{- -intersect = interAux paramOk - where paramOk (Segment _ _) r = 0<=r && r<=1 - paramOk (Ray _ _) r = r>=0 - paramOk (Line _ _) r = True --} - -doIntersect s t = isJust (intersect s t) - -strictIntersect = interAux paramOk - where - paramOk (Segment _ _) r = 00 - paramOk (Line _ _) r = True -doStrictIntersect s t = isJust (strictIntersect s t) - -interAux :: Fractional a => (Line a -> a -> Bool) -> Line a -> Line a -> Maybe (P2 a) -interAux ok s1 s2 = if isJust res && ok s1 r && ok s2 s then Just i else Nothing - where - res = intersection s1 s2 - (i,r,s) = fromJust res - -k <*> p = mapP (k*) p -mapP f (x,y,i) = (f x, f y, i) - -intersection :: Fractional a => Line a -> Line a -> Maybe (P2 a,a,a) -intersection s1 s2 - | denom == 0 = Nothing - | otherwise = Just (i, r, s) - where (xa,ya,_) = point1 s1 - (xb,yb,_) = point2 s1 - (xc,yc,_) = point1 s2 - (xd,yd,_) = point2 s2 - denom = (xb-xa)*(yd-yc)-(yb-ya)*(xd-xc) - r = ((ya-yc)*(xd-xc)-(xa-xc)*(yd-yc)) / denom - s = ((ya-yc)*(xb-xa)-(xa-xc)*(yb-ya)) / denom --- i = Point2 (xa + r*(xb-xa), ya + r*(yb-ya)) - i = (xa+r*xb-xa, ya+r*yb-ya,0) - -splitWhile :: (a -> Bool) -> [a] -> ([a], [a]) -splitWhile p xs = split xs [] - where split [] ls = (reverse ls, []) - split ys@(x:xs) ls = if p x then split xs (x:ls) else (reverse ls, ys) - - -newtype (Num a) => Triangle a = Triangle (P2 a, P2 a, P2 a) - --- vertices :: (Num a) => Triangle (P2 a, P2 a, P2 a) -> [P2 a] -vertices (Triangle (p,q,r)) = [p,q,r] - --- segments :: (Num a) => Triangle (P2 a, P2 a, P2 a) -> [Line a] -segments (Triangle (p,q,r)) = [Segment p q, Segment q r, Segment r p] - --- area :: Fractional a => Triangle (P2 a, P2 a, P2 a) -> a -area (Triangle (p,q,r)) = 0.5 * area2 p q r - --- contains :: (Num a, Ord a) => Triangle (P2 a, P2 a, P2 a) -> P2 a -> Bool -contains tri@(Triangle (s,t,v)) p = containsBNV tri p || p==s || p==t || p==v - --- inInteriourOf :: (Num a, Ord a) => P2 a -> Triangle (P2 a, P2 a, P2 a) -> Bool -inInteriourOf p tri = checkBy test tri p - where test Collinear b c = False - test a Collinear c = False - test a b Collinear = False - test a b c = a==b && b==c - -type Rel3 a = a -> a -> a -> Bool - --- checkBy :: (Num a, Ord a) => Rel3 Orientation -> Triangle (P2 a, P2 a, P2 a) -> P2 a -> Bool -checkBy chk (Triangle (s,t,v)) p = chk a b c - where a = orientation s t p - b = orientation t v p - c = orientation v s p diff --git a/src/Test/Fonts.hs b/src/Test/Fonts.hs --- a/src/Test/Fonts.hs +++ b/src/Test/Fonts.hs @@ -1,178 +1,48 @@ module Main where -import Graphics.Rendering.OpenGL -import Graphics.UI.GLUT as GLUT-- (getArgsAndInitialize, initialDisplayMode, createWindow, windowSize, keyboardMouseCallback, idleCallback, displayCallback, reshapeCallback, mainLoop, swapBuffers, DisplayMode(..)) -import Data.IORef -import System.IO.Unsafe (unsafePerformIO) -import Test.PointOfView -import Graphics.SVGFonts.ReadFont(displayString, AObj(..), Prop(..), Mode(..), Spacing(..), CharProp(..), makeMaps) -import Data.Tuple.Select -import Paths_SVGFonts(getDataFileName) - -main= do - (progName,_) <- getArgsAndInitialize - initialDisplayMode $= [WithDepthBuffer, DoubleBuffered, RGBAMode, WithAlphaComponent, WithAccumBuffer] - createWindow progName - windowSize $= Size 800 600 - myInit - - gawFile <- getDataFileName "src/Test/GirlsareWeird.svg" - linFile <- getDataFileName "src/Test/LinLibertine.svg" +import Graphics.SVGFonts.ReadFont (displayString, makeOutlMap, makeTexMap, Mode(..), Spacing(..), CharProp(..)) +import Graphics.Formats.Collada.ColladaTypes (Geometry) +import Graphics.Formats.Collada.GenerateObjects (lightedScene, lightedSceneNode, emptyAnim) +import Graphics.Formats.Collada.GenerateCollada (genCollada) +import Graphics.Formats.Collada.Transformations (extrude, atop, translate) +import Graphics.Triangulation.Triangulation (triangulate, deleteHoles) +import Graphics.Triangulation.KETTriangulation (ketTri) +import qualified Data.Map as Map +import System.Environment - let resolution = (400, 400) - -- mode: INSIDE_V1_V2_V3: the string is inside v1 v2 v3 boundaries (height/length-relation not kept) - -- mode: INSIDE_V1: stay inside v1 boundary, size of v2 adjusted to height/length-relation - -- mode: INSIDE_V2: stay inside v2 boundary, size of v1 adjusted to height/length-relation +main = do + args <- getArgs + let str = if (length args)>0 then head args else "Haskell" -- ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + resolution = (300, 300) +-- mode: INSIDE_V1_V2: the string is inside v1 v2 boundaries (height/length-relation not kept) +-- mode: INSIDE_V1: stay inside v1 boundary, size of v2 adjusted to height/length-relation +-- mode: INSIDE_V2: stay inside v2 boundary, size of v1 adjusted to height/length-relation mode = INSIDE_V2 - -- spacing: MONO: use mono spacing between glyphs - -- HADV: every glyph has a unique constant horiz. advance - -- KERN: same as 1 but sometimes overridden by kerning: i.e. the horizontal advance in "VV" is bigger than in "VA" +-- spacing: MONO: Use mono spacing between glyphs +-- HADV: Every glyph has a unique constant horiz. advance +-- KERN: Same as HADV but sometimes overridden by kerning: i.e. the horizontal advance in "VV" is bigger than in "VA" spacing = HADV - gaw = makeMaps gawFile resolution - lin = makeMaps linFile resolution - o = (0,0,0) -- origin + gaw = makeOutlMap "../../../src/Test/GirlsareWeird.svg" resolution + lin = makeOutlMap "../../../src/Test/LinLibertine.svg" resolution + o = (0,0,1.1) -- origin v1 = (5,0,0) -- direction of char-advance v2 = (0,0,-1) -- height direction v3 = (0,0.2,0) -- extrusion - f :: [Char] -> [(Char,[CharProp])] - f (a:(b:(c:d))) = addStrProp ( [(a,[Textured, ObjColor 255 0 0 255]), -- no color yet - (b,[Outline v3]), - (c,[Textured, ObjColor 0 0 255 255])] ++ (f d) ) [Font gaw] - f _ = [] -- data CharProp = Outline V | Textured | ObjColor Int Int Int Int | Font (FontData, OutlineMap, TexMap) - addStrProp xs prop = map (\(a,bs) -> (a, bs ++ prop)) xs - onlyTextures (Annotate vs (TexObj (texobjs,str))) = Annotate vs (Textur (Just texobjs)) - -- str is the filename of the texture (for collada-output) - onlyTextures (Annotate vs rest) = Annotate vs rest - str = displayString "abcdef" resolution mode spacing (0,0,1.1) v1 v2 f - - g <- return ( G (map onlyTextures str) ) - - putStrLn "Font read" - l <- defineNewList Compile $ do display_g ( g ) - - pPos <- newIORef (0::GLdouble,1::GLdouble,0::GLdouble, 0::GLdouble,0::GLdouble,0::GLdouble, - 0::GLdouble,0::GLdouble,-1::GLdouble) - -- 0,1,0 : point of location in x,y,z then 0,0,0: where to look at - -- 0,0,-1: up direction - keystate <- newIORef [] - keyboardMouseCallback $= Just (keyboard keystate) - idleCallback$= Just (idle pPos) - displayCallback $= display keystate pPos l - reshapeCallback $= Just reshape - mainLoop - --- Initialize lighting and other values. -myInit :: IO () -myInit = do - materialAmbient Front $= Color4 1 0.5 1 1 - materialSpecular Front $= Color4 0.2 1 0.8 1 - materialShininess Front $= 50 - - position (Light 0) $= Vertex4 5 5 10 0 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - - -- cullFace $= Just Back - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - shadeModel $= Flat - normalize $= Enabled - rowAlignment Unpack $= 1 - - clearColor $= Color4 0.2 0 0 0 - clearAccum $= Color4 0 0 0 0 - - blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - textureFunction $= Replace - texture Texture2D $= Enabled - -display keystate pPos l = do - loadIdentity - setPointOfView keystate pPos - clear [ColorBuffer,DepthBuffer] - callList l - --deleteLists [l] - swapBuffers - -data Obj = G [ AObj ] | -- extruded objects in coords (G for Geometry) - Nil - -blue = RedGreenBlue (0,0,1) - --- ======================================================== --- conversion into G [AObj] (mainly with eval3d) --- meaning of G [AObj] by example: --- G [Annotate [1] pr, Annotate [2] pr, Annotate [3] pr, Annotate [4] pr] = four single points (0d) --- G [Annotate [1,2] pr, Annotate [2,3] pr, Annotate [3,4] pr, Annotate [4,1] pr] = four lines (1d) --- G [Annotate [1,2,3,4] pr] a rectangle (2d) --- G [Annotate [1,2,3,4] pr, Annotate [3,4,5,6] pr, Annotate [1,2,7,8] pr] = a 3d object, consisting of several rectangles --- ======================================================== - -redG (G obj) = obj - -add (x0,y0,z0) (x1,y1,z1) = (x0+x1, y0+y1, z0+z1) -sub (x0,y0,z0) (x1,y1,z1) = (x0-x1, y0-y1, z0-z1) - -skalar (x,y,z) (a,b,c) = x*a + y*b + z*c - --- ==================================================================== --- displaying (this is slow immediate mode, but it is just for testing) --- ==================================================================== -loc = preservingMatrix - -display_g :: Obj -> IO() -display_g (G []) = return () -display_g Nil = return() - -display_g (G (p:ps)) = disp p >> display_g (G ps) - -map3 = map (\(x,y,z) -> (realToFrac x, realToFrac y, realToFrac z)) - -disp :: AObj -> IO() -disp (Annotate ps ( Triangul tris )) = do diplay_primitive (generate_from_index (map3 ps) tris) blue Triangles -disp (Annotate ps pr) | (length ps) == 1 = do diplay_primitive (map3 ps) pr Points - | (length ps) == 2 = do diplay_primitive (map3 ps) pr Lines - | otherwise = do diplay_primitive (map3 ps) pr Polygon - -generate_from_index :: [(GLfloat,GLfloat,GLfloat)] -> [(Int,Int,Int)] -> [(GLfloat,GLfloat,GLfloat)] -generate_from_index ps [] = [] -generate_from_index ps (t:tris) = [tp0, tp1, tp2] ++ (generate_from_index ps tris) - where tp0 = head(drop (sel1 t) ps) - tp1 = head(drop (sel2 t) ps) - tp2 = head(drop (sel3 t) ps) - -norm points = (set_len (kreuz (v0 `sub` v1) (v2 `sub` v1) ) 1) - where v0 = head points - v1 = head (drop 1 points) - v2 = head (drop 2 points) - -diplay_primitive p (RedGreenBlue(r,g,b)) primitiveShape - | (length p) >=3 = do - materialAmbientAndDiffuse Front $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) 1 - currentNormal $= Normal3 (sel1(norm p)) (sel2(norm p)) (sel3(norm p)) - displayPoints p primitiveShape - | otherwise = do - materialAmbientAndDiffuse Front $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) 1 - displayPoints p primitiveShape + f :: String -> [String] -- assigning a property to every character by a unique string + f str = replicate (length str) "p" -diplay_primitive points (Textur image) primitiveShape = do - textureBinding Texture2D $= image - let verts = makeV points - let texs = [(TexCoord2 0 1), (TexCoord2 0 0), (TexCoord2 1 0), (TexCoord2 1 1)] - renderPrimitive Polygon $ do mapVertices texs verts - flush + prop :: Map.Map String CharProp -- data CharProp = Prop (FontData, OutlineMap) String Textured + prop = Map.fromList [("p", Prop lin "to3d" False)] -displayPoints points primitiveShape = do - renderPrimitive primitiveShape$makeVertices points - flush + transf :: Map.Map String (Geometry -> Geometry) -- transformation of a Geoemtry Node (i.e. triangulation) + transf = Map.fromList [("to3d", to3d)] -makeVertices = mapM_ ( \(x,y,z) -> vertex$Vertex3 x y z ) -makeV = map ( \(x,y,z) -> (Vertex3 x y z) ) + to3d geom = ( ((extrude (0,0.1,0)).deleteHoles) geom ) `atop` ( tri (translate (0,0.1,0) geom) ) -- not the perfect solution since some points are generated twice + tri = (triangulate ketTri).deleteHoles -setVertex :: (TexCoord2 GLfloat, Vertex3 GLfloat) -> IO () -setVertex (texCoordinates, vertexCoordinates) = do texCoord texCoordinates; vertex vertexCoordinates; + tex = makeTexMap resolution prop transf + node = displayString str "node" resolution prop transf mode spacing o v1 v2 f tex --- A routine used to draw a list of coordinates. -mapVertices :: [(TexCoord2 GLfloat)] -> [(Vertex3 GLfloat)] -> IO () -mapVertices texs verts = mapM_ setVertex (zip texs verts) + genCollada (lightedScene node) emptyAnim + putStrLn "Collada File generated" diff --git a/src/Test/PointOfView.hs b/src/Test/PointOfView.hs deleted file mode 100644 --- a/src/Test/PointOfView.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Test.PointOfView where - -import Graphics.Rendering.OpenGL -import Graphics.UI.GLUT -- hiding (GLdouble, get, lookAt, Vertex3, Vector3, $=, viewport) -import Data.IORef -import System(ExitCode(..), exitWith) -import Data.List (nub) --- import Graphics.UI.GLUT ( Key(SpecialKey, Char), postRedisplay, SpecialKey(..), KeyState(..) ) - -setPointOfView :: IORef [Key] -> IORef (GLdouble,GLdouble,GLdouble, GLdouble,GLdouble,GLdouble, GLdouble,GLdouble,GLdouble) -> IO () -setPointOfView ks pPos = do - keystate <- get ks - if Char 'w' `elem` keystate then do move_vw pPos 0.01 -- vorward - postRedisplay Nothing - else return() - if Char 's' `elem` keystate then do move_vw pPos (negate 0.01) -- backward - postRedisplay Nothing - else return() - if Char 'a' `elem` keystate then do strafe pPos (0.01) -- left - postRedisplay Nothing - else return() - if Char 'd' `elem` keystate then do strafe pPos (negate 0.01) - postRedisplay Nothing -- right - else return() - if (SpecialKey KeyLeft) `elem` keystate then do rot pPos (0,negate 0.002) - postRedisplay Nothing - else return() - if (SpecialKey KeyRight) `elem` keystate then do rot pPos (0, 0.002) - postRedisplay Nothing - else return() - if (SpecialKey KeyUp) `elem` keystate then do rot pPos (0.002, 0) - postRedisplay Nothing - else return() - if (SpecialKey KeyDown) `elem` keystate then do rot pPos (negate 0.002,0) - postRedisplay Nothing - else return() - (x,y,z,lx,ly,lz,ux,uy,uz) <- get pPos - lookAt (Vertex3 x y z) (Vertex3 lx ly lz) (Vector3 ux uy uz) -- x y z: the point where the viewer is situated - -- lx ly lz: the point at which the viewer is looking - -- ux uy uz: a vector, which is up for the viewer - -keyboard :: IORef [Key] -> Key -> KeyState -> t -> t1 -> IO () -keyboard keystate key ks _ _ = do - case (key,ks) of - (Char '\27',_) -> do exitWith ExitSuccess - (Char 'q',_) -> do exitWith ExitSuccess - (_,Down) -> modifyIORef keystate $ nub . (++[key]) - (_,Up) -> modifyIORef keystate $ filter (/=key) - ---move_vw :: IORef (GLdouble,GLdouble,GLdouble,GLdouble,GLdouble,GLdouble,GLdouble,GLdouble,GLdouble) -> GLdouble -> IO () -move_vw pPos delta = do - (x,y,z,lx,ly,lz,ux,uy,uz) <- get pPos - let dx = (lx-x)*delta - dy = (ly-y)*delta - dz = (lz-z)*delta - pPos $= (x+dx, y+dy, z+dz, lx+dx, ly+dy, lz+dz, ux,uy,uz) - -kreuz (v0,v1,v2) (w0,w1,w2) = (v1*w2-v2*w1, v2*w0-v0*w2, v0*w1-v1*w0) -kreuz2 (v0,v1,v2,pr) (w0,w1,w2,_) = (v1*w2-v2*w1, v2*w0-v0*w2, v0*w1-v1*w0, pr) -set_len (x,y,z) l = (x*c*l, y*c*l, z*c*l) where c = 1 / v_len (x,y,z) -v_len (x,y,z) = sqrt (x*x+y*y+z*z) - -strafe pPos delta = do - (x,y,z,lx,ly,lz,ux,uy,uz) <- get pPos - let (dx, dy, dz) = set_len (kreuz (x-lx,y-ly,z-lz) (ux,uy,uz)) delta - pPos $= (x+dx, y+dy, z+dz, lx+dx, ly+dy, lz+dz, ux,uy,uz) - -divide (x,y,z) c = (x/c, y/c, z/c) -mul (x,y,z) c = (x*c, y*c, z*c) - -rot pPos (alpha, beta) = do - (px,py,pz,lx,ly,lz,ux,uy,uz) <- get pPos - return (set_len (ux,uy,uz) (v_len (lx-px,ly-py,lz-pz))) - let lx_alpha = px + (lx-px)*(cos alpha) + ux*(sin alpha) - ly_alpha = py + (ly-py)*(cos alpha) + uy*(sin alpha) - lz_alpha = pz + (lz-pz)*(cos alpha) + uz*(sin alpha) - ux_alpha = - (lx-px)*(sin alpha) + ux*(cos alpha) - uy_alpha = - (ly-py)*(sin alpha) + uy*(cos alpha) - uz_alpha = - (lz-pz)*(sin alpha) + uz*(cos alpha) - k = (kreuz (lx_alpha-px, ly_alpha-py, lz_alpha-pz) (ux_alpha, uy_alpha, uz_alpha)) - (kx,ky,kz) = (k `divide` (v_len k)) `mul` (v_len (ux, uy, uz)) - - pPos $= (px, py, pz, - px + (lx_alpha-px)*(cos beta) + kx*(sin beta), - py + (ly_alpha-py)*(cos beta) + ky*(sin beta), - pz + (lz_alpha-pz)*(cos beta) + kz*(sin beta), - ux_alpha, uy_alpha, uz_alpha) - -idle pPos = do - postRedisplay Nothing - -reshape screenSize@(Size w h) = do - viewport $= ((Position 0 0), screenSize) - matrixMode $= Projection - loadIdentity - let near = 0.001 - far = 40 - fov = 90 - ang = (fov*pi)/(360) -- equals 45 degree - top = near / ( cos(ang) / sin(ang) ) -- top/near has the same value as 1/(x/y) - aspect = fromIntegral(w)/fromIntegral(h) - right = top*aspect - frustum (-right) right (-top) top near far - matrixMode $= Modelview 0