SVGFonts 1.0 → 1.1

raw patch · 9 files changed

+308/−835 lines, 9 filesdep +data-defaultdep +diagrams-libdep +vector-spacedep −GLUTdep −OpenGLdep −SVGPathdep ~parsecdep ~splitPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, diagrams-lib, vector-space

Dependencies removed: GLUT, OpenGL, SVGPath, array, bytestring, collada-output, collada-types, haskell98, tga, triangulation

Dependency ranges changed: parsec, split

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• README +0/−8
• SVGFonts.cabal +30/−30
• TODO +1/−7
• src/Graphics/SVGFonts/CharReference.hs +6/−8
• src/Graphics/SVGFonts/RasterFont.hs +0/−370
• src/Graphics/SVGFonts/ReadFont.hs +136/−342
• src/Graphics/SVGFonts/ReadPath.hs +134/−0
• src/Test/Fonts.hs +0/−69

@@ -1,4 +1,4 @@-Copyright (c) 2010, Tillmann Vogt
+Copyright (c) 2011, Tillmann Vogt
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

@@ -5,11 +5,3 @@   "Save All"). If a font converted on your own doesn't work, try the repair options, and if this still
   doens't work edit the file by hand or tell me.
   Remember that a lot of fonts are not allowed to be distributed freely.
-
-Example:
-  src/Test/Font.hs generates a Collada file that can be read with tools like blender.
-  Textures currently don't work with blenders new native collada import.
-  But one can see them in Scenixviewer from nvidia.
-  The data that is passed to genCollada is represented with a data type that I use for all my libraries
-  to allow easy combination.
-

@@ -1,30 +1,39 @@ Name:             SVGFonts
-Version:          1.0
+Version:          1.1
 Synopsis:         Fonts from the SVG-Font format
-Description:      This format is easy to parse and was therefore chosen for a font library
-                  completely written in Haskell
+Description:      Native font support for the Diagrams library. The SVG-Font format is easy to parse
+                  and was therefore chosen for a font library completely written in Haskell
                   .
                   You can convert your own font to SVG with <http://fontforge.sourceforge.net/> or use the included LinLibertine, Bitstream
                   .
                   Features
                   .
-                  * A powerful functional interface, demonstrated with an example (Fonts.hs)
-                  .
-                  * The generated outlines can be transformed in various ways, i.e.
-                    elimination of holes for triangulation, representation with triangles, extrusion
-                  .
-                  * Color textures that are stored as files (font cache). Foreground and background color can be freely chosen.
-                  .
-                  * Everything is stored in a simple SceneGraph: <http://hackage.haskell.org/package/collada-types>
-                  .
                   * Complete implementation of the features that fontforge produces (but not the complete SVG format):
                   .
                   * Kerning (i.e. the two characters in \"VA\" have a shorter distance than in \"VV\")
                   .
-                  * Unicode, Ligatures
+                  * Unicode
                   .
+                  * Ligatures
+                  .
                   XML speed issues can be solved by trimming the svg file to only those characters that are used (or maybe binary xml one day)
+                  . 
+                  Version 1.0 of this library supports texturing which would only make sense in a Diagrams Backend that does rasterization in Haskell.
                   .
+                  Example:
+                  .
+                  >  # LANGUAGE NoMonomorphismRestriction #
+                  >
+                  > import Diagrams.Prelude
+                  > import Diagrams.Backend.Cairo.CmdLine
+                  > import Graphics.SVGFonts.ReadFont (textSVG)
+                  >
+                  >
+                  > main = defaultMain ( (text' "Hello World") <> (rect 8 1) # alignBL )
+                  >
+                  > text'  t = stroke (textSVG t 1) # fc purple # fillRule EvenOdd
+                  > text'' t = stroke (textSVG_ $ TextOpts t lin INSIDE_H KERN 1 1 ) # fc purple # fillRule EvenOdd
+                  .
 category:         Graphics
 License:          BSD3
 License-file:     LICENSE
@@ -39,30 +48,21 @@     hs-source-dirs: src
     other-modules: Paths_SVGFonts
     build-depends:
-        array,
         attoparsec-text,
         base == 4.*,
-        bytestring == 0.9.1.*,
         containers == 0.4.*,
-        collada-types >= 0.3,
-        collada-output >= 0.6,
+        data-default,
+        diagrams-lib,
         directory >= 1.0 && <1.2,
-        GLUT >= 2.1.2.1,
-        haskell98,
-        OpenGL >= 2.2.3.0,
-        parsec >= 2.1 && <= 3.2,
-        split == 0.1.*,
-        SVGPath == 1.1,
+        parsec,
+        split,
         text,
-        tga >= 0.2,
-        triangulation >= 0.3,
         tuple,
         vector,
+        vector-space,
         xml == 1.3.*
     exposed-modules:
         Graphics.SVGFonts.ReadFont
-        Graphics.SVGFonts.RasterFont
-Executable Fonts
-    hs-source-dirs: src
-    main-is:        Test/Fonts.hs
-    other-modules:  Graphics.SVGFonts.ReadFont, Paths_SVGFonts
+        Graphics.SVGFonts.CharReference
+        Graphics.SVGFonts.ReadPath
+

@@ -1,11 +1,5 @@ Sorted after importance
 
-- correct errors in rasterization (negative x or higher than hadv: "fjJ" in LinLibertine, wrong tga size, ...)
-- correct errors in triangulation
-- syntax highlighter example
-
-- Integration in other libraries (support other scengraphs?)
 - speed
 - Binary XML (i.e. fast infoset), or a temp file, because xml-parsing has a speed problem)
-- Auto Hinting
-- Mono spacing of non-mono-spaced fonts
+- Auto Hinting (this depends on how the rasterization in the backend works)

@@ -4,7 +4,7 @@ import qualified Data.Map as Map
 import qualified Data.Text as T
 import Data.Maybe (fromJust)
-import List (sortBy)
+import Data.List (sortBy)
 
 charRef :: Parser Int
 charRef
@@ -43,15 +43,13 @@ charsFromFullName (Just str) = map toEnum ( fromCharRefs (T.pack str) )
 
 
--- | a string defines a glyph, i.e. the ligature \"ffi\" is a string that defines the ligature glyph ffi
-characterStrings :: Map.Map String [String] -> [(Char,String)] -> [T.Text]
-characterStrings ligmap fstr | null ligs = map ((T.pack).(\x->[x]).fst) fstr
-                             | otherwise = case parseOnly myParser str
+-- | A string defines a glyph, i.e. the ligature \"ffi\" is a string that defines the ligature glyph ffi
+characterStrings :: String -> [String] -> [T.Text]
+characterStrings str ligs | null ligs = map ((T.pack).(\x->[x])) str
+                          | otherwise = case parseOnly myParser (T.pack str)
                                            of Right x -> x
                                               Left  x -> []
-  where str = T.pack $ map fst fstr
-        ligs = fromJust $ Map.lookup (snd (head fstr)) ligmap
-        myParser = many (try ligatures <|> charToText)
+  where myParser = many (try ligatures <|> charToText)
         ligatures = buildChain $ sortBy -- sort so that the longest ligatures come first, i.e. "ffi", "ff", ..
                                  (\x y -> compare (length y) (length x)) $ ligs
         buildChain [x]    = parseLigature x -- try to parse with the first parsers in the chain first

@@ -1,370 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts #-}-module Graphics.SVGFonts.RasterFont-(- commandsToRasterPoints, bitmasks, line, bitmask, borderToTex, sortSpans, overlaps, orBm, fillSpans, fillBitmask,- bitSum, endBits, bits, showBits, createTexture, F2P(..), AA(..), Bitmask, ftrace-)-where--import Data.Array.MArray-import Data.Array.ST (STArray,STUArray)-import Data.Array.Unboxed (elems, amap, UArray, IArray, listArray)-import Data.Bits ( (.&.), (.|.), testBit, setBit, clearBit, shiftL, bit, shiftR, complement)-import Data.Maybe (isJust)-import Data.Word (Word8, Word16)-import Data.Tuple.Select-import Graphics.Formats.Collada.Vector2D3D (V4(..))-import Graphics.Formats.TGA.TGA -- (TGAData, Picture (..))-import Graphics.SVG.ReadPath (PathCommand, ctp)-import Graphics.Rendering.OpenGL-import List (sortBy)-import qualified Data.STRef-import Control.Monad (when, forM_)-import Control.Monad.ST-import Foreign (withArray)-import Debug.Trace-import System.IO.Unsafe-import qualified Data.ByteString.Lazy as B--var = Data.STRef.newSTRef-gett = Data.STRef.readSTRef-mutate = Data.STRef.modifySTRef--type X = Float-type Y = Float-type F2 = (X,Y)-type F2P = (X, Y, AA)-data AA = NB | -- ^ No Bitmask-          B Bitmask-type Bitmask = UArray Int Word16 -- ^ A Bitmask contains 256 values: An Array of 16 Word16---- | Convert path-commands to outline points, which consist of bitmaps (resolution 16x16) of lines that go through---   the pixel (subpixel rasterization)-commandsToRasterPoints :: [PathCommand] -> F2 -> F2 -> [[F2P]]-commandsToRasterPoints commands (dx, dy) (offsetX, offsetY)-    | null points = []-    | otherwise = map (bitmasks (dx, dy)) (map (\r -> r ++ [head r]) points)-  where points = ctp commands [(0,0)] (0,0) True (dx,dy) (offsetX, offsetY)---------------------------------------------------------------------------------------------------------------------- generating bitmasks for rasterization---- | Every tuple of consecutive outline points builds a line that is rasterized and cut into little bitmasks-bitmasks :: (X,Y) -> [F2] -> [F2P]-bitmasks _ [a] = []-bitmasks (dx,dy) ((p0x,p0y):((p1x,p1y):bs))-     | p0x_int == p1x_int = -- ftrace ((show p0x) ++ " " ++ (show p0y) ++ " " ++ " vert\n" ++ (concat (map showF2P (rasterStraightLine True)) ) ++ "\n\n\n" ) $-                            (rasterStraightLine True) ++-                            rest -- vertical line-     | p0y_int == p1y_int = -- ftrace ((show p0x) ++ " " ++ (show p0y) ++ " " ++ " hor\n" ++ (concat (map showF2P (rasterStraightLine False)) ) ++ "\n\n\n" ) $-                            (rasterStraightLine False) ++-                            rest -- horizontal line-     | ( (abs (p1x_int-p0x_int)) == 1 && (abs (p1y_int-p0y_int)) == 1 ) || (abs (p1x-p0x)) < dx && (abs (p1y-p0y)) < dy = - -- ftrace ((show p0x) ++ " " ++ (show p0y) ++ " " ++ " div22\n" ++ (concat (map showF2P div22) ) ++ "\n\n\n" ) $-                                                      div22 ++-                                                      rest -- line that is at most one pixel long-     | otherwise = rest -- trace (show (p1x_int-p0x_int) ++ " " ++ show (p1y_int-p0y_int) ++ " error in RasterFont.hs") rest -- should not happen-  where  rest = bitmasks (dx,dy) ((p1x, p1y):bs)-         (p0x_int, p0y_int) | p0y < p1y = (truncate $ p0x/dx, truncate $ p0y/dy)-                            | otherwise = (truncate $ p1x/dx, truncate $ p1y/dy)-         (p1x_int, p1y_int) | p0y < p1y = (truncate $ p1x/dx, truncate $ p1y/dy)-                            | otherwise = (truncate $ p0x/dx, truncate $ p0y/dy)--         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 (x+ex), fromIntegral (y+ey), B (bitmask ex ey a)) |-		                                                         ey <- [0..(ny-1)], ex <- [0..(nx-1)] ]-         div22 = divide 2 2 smallerX p0y_int (line 2 2 pixP4 pixP5)-         len_x = abs (p1x_int - p0x_int) + 1-         len_y = p1y_int - p0y_int + 1-         smallerX = truncate $ if (p0x < p1x) then p0x/dx else p1x/dx--         pixP0 | p0y < p1y =  (fracX p0x, fracY p0y)-               | otherwise =  (fracX p1x, fracY p1y)-         pixP1 | p0y < p1y =  (fracX p1x,(fracY p1y) + (p1y_int-p0y_int) * 16)-               | otherwise =  (fracX p0x,(fracY p0y) + (p1y_int-p0y_int) * 16)-         pixP2 | p0x < p1x =  (fracX p0x, fracY p0y)-               | otherwise =  (fracX p1x, fracY p1y)-         pixP3 | p0x < p1x = ((fracX p1x) + (abs (p1x_int-p0x_int)) * 16, fracY p1y)-               | otherwise = ((fracX p0x) + (abs (p1x_int-p0x_int)) * 16, fracY p0y)-         pixP4 | p0y < p1y = ((fracX p0x) + if p0x<p1x then 0 else 16, fracY p0y)-               | otherwise = ((fracX p1x) + if p0x<p1x then 16 else 0, fracY p1y)-         pixP5 | p0y < p1y = ((fracX p1x) + if p0x<p1x then 16 else 0, (fracY p1y) + 16)-               | otherwise = ((fracX p0x) + if p0x<p1x then 0 else 16, (fracY p0y) + 16)--         fracX = truncate.(*16).snd.properFraction.(/dx)-         fracY = truncate.(*16).snd.properFraction.(/dy)---thawSTU :: (IArray UArray e, MArray (STUArray s) e (ST s)) => UArray (Int,Int) e -> ST s (STUArray s (Int,Int) e)-thawSTU = thaw---- | Bresenham line algorithm, adjusted to produce only one y value per row--- The data structure for the line is a 2d array of bits, in x-direction a sequence of word16s--- nx,ny are the size as multiples of 16,  draw line from (xa, ya) to (xb, yb)-line :: Int -> Int -> (Int,Int) -> (Int,Int) -> UArray (Int,Int) Word16-line nx ny (xa, ya) (xb, yb) = runST $ do-    a <- newArray ((0,0),(nx-1,ny*16-1)) (0 :: Word16) :: ST s (STUArray s (Int,Int) Word16)-    yV <- var y1-    errorV <- var $ deltax `div` 2-    forM_ [x1 .. x2] (\x -> do-        y <- gett yV-        mutate errorV $ subtract deltay-        error <- gett errorV-        when steep (setPix (a, y, x))-        when (not steep && (error < 0)) (setPix (a, x, y))-        when (error < 0) (do-            mutate yV (+ ystep)-            mutate errorV (+ deltax)))-    a' <- unsafeFreeze a-    return (a' :: UArray (Int,Int) Word16)-  where steep = abs (yb - ya) > abs (xb - xa)-        (xa', ya', xb', yb') = if steep-          then (ya, xa, yb, xb)-          else (xa, ya, xb, yb)-        (x1, y1, x2, y2) = if xa' > xb'-          then (xb', yb', xa', ya')-          else (xa', ya', xb', yb')-        deltax = x2 - x1-        deltay = abs $ y2 - y1-        ystep = if y1 < y2 then 1 else -1-        setPix (a, x, y) =-          when (x<nx*16 && y<ny*16 && x>=0 && y>=0)-          (writeArray a ((x `div` 16), y) (setBit (0::Word16) (x `mod` 16)))---- | 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-bitmask :: Int -> Int -> UArray (Int,Int) Word16 -> Bitmask-bitmask ix iy mask = runST $ do-  ar <- thawSTU mask-  m <- newArray (0,15) (0::Word16) :: ST s (STUArray s Int Word16)-  forM_ [iy*16..iy*16+15] $ \y -> do-    e <- readArray ar (ix,y)-    writeArray m (y-iy*16) e-  m' <- unsafeFreeze m-  return (m' :: Bitmask)----------------------------------------------------------------------------------------------------------- rasterization--alpha (V4 _ _ _ a) = a---- | Border points to texture-borderToTex :: (Int,Int) -> [(Int, Int, Bitmask)] -> (V4,V4) -> TGAData-borderToTex (rx,ry) borderPoints (col, bgCol) | (alpha col) == 1 && (alpha bgCol) == 1-                         = TGAData (B.empty) (RGB24 (tgaRGB24 (col,bgCol) tgaData)) 0 0 rx ry-       | otherwise       = TGAData (B.empty) (RGB32 (tgaRGB32  col        tgaData)) 0 0 rx ry-  where-  tgaData = lines fs -- traceBitmask (overlaps $ sortSpans borderPoints) -- Caution! only small resolutions, i.e. 27x50, or you wait forever-  lines bs | B.null bs = B.empty-           | otherwise = B.append (B.reverse (B.take (fromIntegral rx) bs)) (lines (B.drop (fromIntegral rx) bs))--  fs = fillSpans (rx,ry) $ overlaps $ sortSpans borderPoints--tgaRGB32 col@(V4 r g b a) bs-    | isJust (B.uncons bs) = B.cons (m b) $-                             B.cons (m g) $-                             B.cons (m r) $-                             B.cons x (tgaRGB32 col (B.tail bs))-    | otherwise = B.empty-  where x = B.head bs-        m c = if (truncate (c*256)) == 0 then 0 else (truncate (c*256)) - 1--tgaRGB24 ( col@(V4 r g b _), bgCol@(V4 br bg bb _)) bs-    | isJust (B.uncons bs) = B.cons (m (sel3 color)) $-                             B.cons (m (sel2 color)) $-                             B.cons (m (sel1 color)) (tgaRGB24 (col,bgCol) (B.tail bs))-    | otherwise = B.empty-  where color = ( r*x + br*(256-x), g*x + bg*(256-x), b*x + bb*(256-x) )-        x = fromIntegral $ B.head bs-        m c = if (truncate c) == 0 then 0 else (truncate c) - 1----- | Sorting so that the lowest y comes first, equal ys then the lowest x comes first-sortSpans :: [(Int,Int,Bitmask)] -> [(Int,Int,Bitmask)]-sortSpans pixels = sortBy sxy pixels -  where sxy (x0,y0,b0) (x1,y1,b1) | y0 < y1 || (y0 == y1 && x0 < x1) = LT-                                  | y0 == y1 && x0 == x1 = EQ-                                  | otherwise = GT---- | Assuming the list of bitmasks is sorted, two consecutive bitmasks can be on the same position---   this happens if a line ends in pixel and a new line starts in the same pixel-overlaps :: [(Int,Int,Bitmask)] -> [(Int,Int,Bitmask)]-overlaps [] = []-overlaps [(x0,y0,b0)] = [(x0,y0,b0)]-overlaps ((x0,y0,b0):(x1,y1,b1):cs) | x0 == x1 && y0 == y1 = overlaps ( (x0,y0,b0 `orBm` b1) : cs )-                                    | otherwise            = (x0,y0,b0) : (overlaps ((x1,y1,b1):cs))---- | Bitwise oring two Bitmasks-orBm :: Bitmask -> Bitmask -> Bitmask-orBm b0 b1 = listArray (0,15) $ zipWith (.|.) (elems b0) (elems b1)---- | 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 :: (Int, Int) -> [(Int,Int,Bitmask)] -> B.ByteString-fillSpans (rx,ry) [] = B.replicate (fromIntegral (rx*ry)) 0-fillSpans (rx,ry) ((x0,y0,b0):cs) = B.reverse $ B.append (B.replicate (fromIntegral (rx*y0+x0)) 0)-                                                         ( fillSp (rx,ry) 0 ((x0,y0,b0):cs) )--fillSp :: (Int, Int) -> Word16 -> [(Int,Int,Bitmask)] -> B.ByteString-fillSp (rx,ry) endbs ((x0,y0,b0):(x1,y1,b1):cs)-    | y0 /= y1 = B.append-    -- filling the end of a line (rx-x0) and the room between two shapes and the beginning of a new one (x1)-                 (B.cons (toC (bitSum fbm)) (B.replicate (fromIntegral (rx-x0-1+x1+linesBetween)) 0))-                 ( fillSp (rx,ry) 0 ((x1,y1,b1):cs) )--    | otherwise =    -- between two border points-        ( B.append (B.cons (toC (bitSum fbm)) (B.replicate (fromIntegral (x1-x0-1)) c))-                   (fillSp (rx,ry) eb ((x1,y1,b1):cs))-        )-  where fbm = fillBitmask b0 endbs-        eb  = endBits fbm-        beb = bits eb-        c = toC beb*16-        toC c | c /= 0 = fromIntegral $ c-1   -- because 256 is not a Byte-              | otherwise = fromIntegral c-        newl x y = x ++ "\n" ++ y-        linesBetween = (y1-y0-1)*rx -- the room between two shapes----ftrace (if (y0==36) then (show x0 ++ " " ++ show y0 ++ " " ++ show endbs ++ " " ++ show (x1-x0) ++---                  " " ++ show eb ++ " " ++ "\n" ++ (foldr newl "" $ map showBits $ elems b0) ++ (foldr newl "" $---                  map showBits $ elems fbm) ++ "$\n" ) else [])--fillSp (rx,ry) _ [(x0,y0,b0)] =-    B.replicate (fromIntegral (rx-x0+(ry-y0-1)*rx)) 0 -- filling after the last border point----- | Assuming a single line passes through a Bitmask, set all points right to this line to 1-fillBitmask :: Bitmask -> Word16 -> Bitmask-fillBitmask mask endbs =  listArray (0,15) $-                          zipWith (\x y -> if testBit endbs x then fillBefore y else fillAfter y)-                                 [0..15]-                                 (elems mask)--fillWord w16 i b | i == 15 = if tb then (if b then clearBit w16 i else setBit w16 i)-                                   else (if b then setBit w16 i   else clearBit w16 i)-                 | b && not tb = fillWord (setBit w16 i) (i+1) True  --  filling-                 | b &&     tb = fillWord  w16           (i+1) False -- no filling-                 | not b && not tb = fillWord  w16       (i+1) False -- no filling-                 | not b &&     tb = fillWord  w16       (i+1) True  --  filling-  where tb = testBit w16 i---- | Before the first occurrance of a 1 set all bits to 1 example: 00001000 ~> 11110000-fillBefore :: Word16 -> Word16-fillBefore w16 = fillWord w16 0 True---- | After the first occurrance of a 1 set all bits to 1 example: 00001000 ~> 00001111-fillAfter :: Word16 -> Word16-fillAfter w16 = fillWord w16 0 False---- fillBefore w16 | w16 /= 0  = w16 + w16 - 1---               | otherwise = -1  -- 00xFF--- not always correct, but fast--- fillAfter w16 | w16 /= 0  = complement (w16 + w16 - 1)---               | otherwise = 0---- | The sum of all bits in a Bitmask, 16 rows with 16 bits each => between 0 and 255-bitSum :: Bitmask -> Word16-bitSum mask = foldr (+) 0 $ elems $ amap bits mask---- | Return the the rightmost column of a bitmask-endBits :: Bitmask -> Word16-endBits mask = sum $ zipWith shiftR (map lastBit (elems mask)) (reverse [0..15])-lastBit x = x .&. bit 15---- | 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--- fst line: starting to count the 1's in 2-tuples: 0x55 = 01010101--- 2nd line: 4 tuples:  0x33 = 0011001100-bits :: Word16 -> Word16-bits w16 = d8-  where d  = w16 .&. 0x5555 + (shiftR w16 1) .&. 0x5555-        d2 = d   .&. 0x3333 + (shiftR d  2)  .&. 0x3333-        d4 = d2  .&. 0x0F0F + (shiftR d2 4)  .&. 0x0F0F-        d8 = d4  .&. 0x00FF + (shiftR d4 8)--------------------------------------------------------------------------------------------------------------------- | OpenGL specific texture-createTexture :: (Int,Int) -> TGAData -> String -> IO (TextureObject, String)-createTexture (rx,ry) (TGAData _ (RGB24 picture) _ _ w h) fileName = tex fileName (rx,ry) (B.unpack picture)-createTexture (rx,ry) (TGAData _ (RGB32 picture) _ _ w h) fileName = tex fileName (rx,ry) (B.unpack picture)--tex :: String -> (Int,Int) -> [Word8] -> IO (TextureObject,String)-tex fileName (rx,ry) xs = do-  [texName] <- genObjectNames 1-  textureBinding Texture2D $= Just texName-  textureFilter Texture2D $= ((Nearest, Nothing), Nearest)-  let imageSize = TextureSize2D (fromIntegral rx) (fromIntegral ry)-  withCheckImage xs imageSize f $-    texImage2D Nothing NoProxy 0  RGBA' imageSize 0-  return (texName, fileName)- where-  f (a:(b:(c:(d:ds)))) = (Color4 (fromIntegral a) (fromIntegral b) (fromIntegral c) 255) : (f ds)-  f _ = []--withCheckImage :: [Word8] -> TextureSize2D ->-                  ([Word8] -> [(Color4 GLubyte)]) ->-                  (PixelData (Color4 GLubyte) -> IO ()) ->-                  IO ()-withCheckImage xs (TextureSize2D w h) f act =-  withArray (f xs)-  $ act. PixelData RGBA UnsignedByte------------------------------------------------------------------------------------------------------------------- show / debugging functions--instance Show AA-  where show (NB) = "NB"-        show (B bits) = "B " ++ show (elems bits)---- | Show a binary representation of a Word16-showBits :: Word16 -> String-showBits w16 = map ((\x -> if x then '1' else '0').(testBit w16)) (reverse [0..15])--showBitmask :: Bitmask -> String-showBitmask b = foldr newl "" (map showBits (elems b))-  where newl x y = x ++ "\n" ++ y--showF2P :: F2P -> String-showF2P (x,y,B b)  = show (truncate x) ++ " " ++ show (truncate y) ++ "\n" ++ (showBitmask b)---- | Like trace from Debug.Trace but into a file-ftrace :: String -> a -> a-ftrace string expr = unsafePerformIO $ do-    appendFile "debug.txt" string-    return expr--traceBitmask :: [(Int,Int,Bitmask)] -> a -> a-traceBitmask bms expr = unsafePerformIO $ do-    writeFile "bitmasks.txt" (unlines (mergeBitmasks bms []))-    return expr---- | Insert every Bitmask in a x,y-position to generate an ASCII picture in a text file-mergeBitmasks :: [(Int,Int,Bitmask)] -> [String] -> [String]-mergeBitmasks [] res = res-mergeBitmasks ((x,y,b):bs) ls = mergeBitmasks bs newPic-  where newPic = (take (y*16) ls) ++  -- copy lines until y-position-                 -- if an y-position is accessed that is bigger than ever before, write empty lines-                 (replicate (y*16-(length ls)) []) ++ -                 insertedBitmasks ++ -- 16 lines where the bitmask is located-                 (drop ((y+1)*16) ls)-        insertLines = take 16 $ (drop (y*16) ls) ++ (replicate ((y+1)*16-(length ls)) [])-        insertedBitmasks = zipWith (\line bmLine-> (take (x*16) line) ++ (replicate (x*16- (length line)) '.' ) ++-                                                    bmLine ++ (drop ((x+1)*16) line))-                                   insertLines-                                   (map (reverse.showBits) (elems b))

@@ -1,42 +1,37 @@ module Graphics.SVGFonts.ReadFont
-(openFont, makeOutlMaps, makeTexMap, Mode(..), Spacing(..), Rx(..), displayString,
-Kern, SvgGlyph, FontData, OutlineMap, OutlineTexMap,
-P, CharProp(..), Props, Transf, TexMap, X ,Y
-)
+-- (openFont, outlMap, textSVG, textSVG_, Mode(..), Spacing(..), Kern, SvgGlyph, FontData, OutlineMap, TextOpts(..))
 where
 
 import Data.Char (isSpace)
-import Data.List (zip5)
+import Data.Default
+import Data.List (intersect,sortBy)
 import Data.List.Split (splitOn, splitWhen)
-import Data.Maybe (fromMaybe, fromJust, isJust, maybeToList, catMaybes)
+import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList)
 import qualified Data.Map as Map
 import qualified Data.Text as T
+import Data.Monoid (mconcat)
 import Data.Tuple.Select (sel1, sel2, sel3, sel4, sel5)
 import Data.Vector (Vector)
+import Data.VectorSpace
+import Diagrams.Path
+import Diagrams.Segment
+import Diagrams.TwoD.Types
+import Diagrams.Prelude
 import qualified Data.Vector as V
-import Graphics.Formats.Collada.ColladaTypes
-import Graphics.Formats.Collada.GenerateObjects (cube, blue, obj, makeScene, get_name, getDiffuseColor, getAmbientColor)
-import Graphics.Formats.Collada.Vector2D3D (V3(..), V4(..), mul, divide, v_len, set_len, cross3)
-import Graphics.Formats.TGA.TGA (readTGA, writeTGA)
-import Graphics.Rendering.OpenGL (TextureObject)
 import Graphics.SVGFonts.CharReference (charsFromFullName, characterStrings)
-import Graphics.SVGFonts.RasterFont (createTexture, borderToTex, commandsToRasterPoints, AA(..), F2P(..), ftrace)
-import Graphics.SVG.ReadPath (commandsToPoints, pathFromString)
-import List (intersect,sortBy)
+import Graphics.SVGFonts.ReadPath (pathFromString, PathCommand(..))
+import Paths_SVGFonts(getDataFileName)
 import System.Directory
 import System.IO.Unsafe (unsafePerformIO)
 import Text.XML.Light
-import Debug.Trace
 
 -- http://www.w3.org/TR/SVG/fonts.html#KernElements
 type Kern = ( Map.Map String [Int],
               Map.Map String [Int],
               Map.Map String [Int],
-              Map.Map String [Int], Vector X ) -- ^ u1s, u2s, g1s, g2s, k
-type SvgGlyph = Map.Map String (String, X, String) -- ^ \[ (unicode, (glyph_name, horiz_advance, ds)) \]
-type FontData = (SvgGlyph, Kern, [Float], String) -- ^ (SvgGlyph, Kern, bbox-string, filename)
-type X = Float
-type Y = Float
+              Map.Map String [Int], Vector Double ) -- ^ u1s, u2s, g1s, g2s, k
+type SvgGlyph = Map.Map String (String, Double, String) -- ^ \[ (unicode, (glyph_name, horiz_advance, ds)) \]
+type FontData = (SvgGlyph, Kern, [Double], String) -- ^ (SvgGlyph, Kern, bbox-string, filename)
 
 -- | Open an SVG-Font File and extract the data
 --
@@ -51,7 +46,8 @@ -- 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 
+-- intersection of the list assigned to the first char and second char
+
 openFont :: FilePath -> FontData
 openFont file = ( Map.fromList (myZip4 (unicodes, glyphNames, horiz, ds)),  -- Map with unicode keys
                   (transform u1s, transform u2s, transform g1s, transform g2s, kAr), -- kerning data
@@ -60,11 +56,11 @@                 )
   where
     -- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with bbox value
-    myZip4 (a:as, b:bs, c:cs, d:ds) | c == []   = (a, (b, (parsedBBox!!2) - (parsedBBox!!0), d)) : (myZip4 (as,bs,cs,ds))
+    myZip4 (a:as, b:bs, c:cs, d:ds) | c == []   = (a, (b, (parsedBBox!!2) - (parsedBBox!!0), d)) :
+                                                  (myZip4 (as,bs,cs,ds))
                                     | otherwise = (a, (b, read c, d)) : (myZip4 (as,bs,cs,ds))
     myZip4 _ = []
-
-    xml = onlyElems $ parseXML (unsafePerformIO (readFile file))
+    xml = onlyElems $ parseXML $ unsafePerformIO $ readFile $ file
     selectFontface = concat $ map (findElements (unqual "font-face")) xml
     selectGlyphs   = concat $ map (findElements (unqual "glyph"))     xml
     selectKerns    = concat $ map (findElements (unqual "hkern"))     xml
@@ -99,22 +95,22 @@ 
     fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f))
 
+
 -- | horizontal advances of characters inside a string
 -- a character is stored with a string (originally because of ligatures)
-horizontalAdvances :: [(String,FontData)] -> Bool -> [X]
-horizontalAdvances []                      _       = []
-horizontalAdvances [(ch,fd)]               _       = [hadv ch fd]
-horizontalAdvances ((ch0,fd0):(ch1,fd1):s) kerning = ((hadv ch0 fd0) - (ka (sel2 fd0)))
-                                                      : (horizontalAdvances ((ch1,fd1):s) kerning)
-  where ka kern |(sel4 fd0) == (sel4 fd1) && kerning = (kernAdvance ch0 ch1 kern True) +
-                                                       (kernAdvance ch0 ch1 kern False) -- no kerning when different fonts
+horizontalAdvances :: [String] -> FontData -> Bool -> [Double]
+horizontalAdvances []          _  _       = []
+horizontalAdvances [ch]        fd _       = [hadv ch fd]
+horizontalAdvances (ch0:ch1:s) fd kerning = ((hadv ch0 fd) - (ka (sel2 fd))) :
+                                            (horizontalAdvances (ch1:s) fd kerning)
+  where ka kern | kerning = (kernAdvance ch0 ch1 kern True) + (kernAdvance ch0 ch1 kern False)
                 | otherwise = 0
 
 hadv ch fontD | isJust lookup = sel2 (fromJust (Map.lookup ch (sel1 fontD)))
               | otherwise = 0
   where lookup = Map.lookup ch (sel1 fontD)
 
-kernAdvance :: String -> String -> Kern -> Bool -> X
+kernAdvance :: String -> String -> Kern -> Bool -> Double
 kernAdvance ch0 ch1 kern u |     u && not (null s0) = (sel5 kern) V.! (head s0)
                            | not u && not (null s1) = (sel5 kern) V.! (head s1)
                            | otherwise = 0
@@ -122,355 +118,153 @@         s1 = intersect (s sel3 ch0) (s sel4 ch1)
         s sel ch = concat (maybeToList (Map.lookup ch (sel kern)))
 
-type TexMap =  Map.Map (String,String,String) (TextureObject, String)
-type OutlineMap =  Map.Map String [[(X,Y)]]
-type OutlineTexMap =  Map.Map String [[F2P]]
-data Mode = INSIDE_V1_V2-- ^ INSIDE_V1_V2: The string is inside v1 v2 boundaries (height/length-relation not kept)
-          | INSIDE_V1 -- ^ INSIDE_V1: Stay inside v1 boundary, size of v2 adjusted to height/length-relation
-          | INSIDE_V2 -- ^ INSIDE_V2: Stay inside v2 boundary, size of v1 adjusted to height/length-relation
+type OutlineMap =  Map.Map String (Path R2)
+data Mode = INSIDE_WH-- ^ INSIDE_WH: The string is stretched inside Width and Height boundaries
+          | INSIDE_W -- ^ INSIDE_W:  The string fills the complete width, heigth adjusted
+          | INSIDE_H -- ^ INSIDE_H:  The string fills the complete height, width adjusted
 
-mV1V2V3 INSIDE_V1_V2 = True
-mV1V2V3 _ = False
-mV1 INSIDE_V1 = True
-mV1 _ = False
-mV2 INSIDE_V2 = True
-mV2 _ = False
+mWH INSIDE_WH = True
+mWH _ = False
+mW INSIDE_W = True
+mW _ = False
+mH INSIDE_H = True
+mH _ = False
 
 -- | See <http://en.wikipedia.org/wiki/Kerning>
 data Spacing = KERN -- ^ Recommended, same as HADV but sometimes overridden by kerning:
                     -- i.e. the horizontal advance in "VV" is bigger than in "VA"
              | HADV -- ^ Every glyph has a unique constant horiz. advance
-             | MONO -- ^ Mono spacing between glyphs. Experimental.
-                    -- Better use a monospaced font from the beginning.
-                    -- The longest glyph influences the bbox that is used.
-isMono MONO = True
-isMono _    = False
+
 isKern KERN = True
 isKern _    = False
 
--- | The y resolution is constant. The x resolution of a glyph changes in non-mono-spaced fonts.
-data Rx = Exactly Int
-        | ConstDx -- ^ The x-resolution of a single glvph is chosen so that all pixels
-                  -- from several glyphs have the same size
-        | XPowerOfTwo -- ^ With this option the resolution nearest of a power of two is chosen
-                      -- i.e. "l" would have (256,512), while "w" would have (512,512)
-        | OneTexture -- ^ The whole string as one texture (not implemented yet)
+type FileName = String
 
-isExactly (Exactly _) = True
-isExactly _           = False
-isConstDx ConstDx = True
-isConstDx _       = False
-isXPowerOfTwo XPowerOfTwo = True
-isXPowerOfTwo _           = False
-getRx (Exactly rx) = Just rx
-getRx _ = Nothing
 
-type FileName = String
-type P = [Char] -> [String]
-data CharProp = Outl (FontData, OutlineMap, OutlineTexMap) String |
-                Tex (FontData, OutlineMap, OutlineTexMap) String
+textSVG :: String -> Double -> Path R2
+textSVG t h = textSVG_ with { txt = t, textHeight = h }
 
-isTex :: CharProp -> Bool
-isTex (Tex _ _) = True
-isTex (Outl _ _) = False
+data TextOpts = TextOpts
+                { txt :: String
+                , fdo :: (FontData, OutlineMap)
+                , mode :: Mode
+                , spacing :: Spacing
+                , textWidth :: Double
+                , textHeight :: Double
+                }
 
-getFont :: CharProp -> (FontData, OutlineMap, OutlineTexMap)
-getFont (Outl font _) = font
-getFont (Tex font _) = font
-getTr (Outl _ tr) = tr
-getTr (Tex _ tr) = tr
+ro = unsafePerformIO . getDataFileName -- read only of static data (safe)
 
-type Transf = Map.Map String (Geometry -> Geometry)
-type Props = Map.Map String CharProp
--- | Main library function, explained with an example (that is also in Fonts.hs):
---
--- @
--- main = do
---   args <- getArgs
---   let str = if null args then \"Haskell\"
---                          else head args
---       resolution = (400, 400)
--- @
---
--- The resolution is used for textures but also for outlines.
--- Every outline point is placed in one grid position
---
--- @
---       mode = INSIDE_V2
---       spacing = KERN
---       tex = ConstDx
---       bit = makeOutlMaps \"../../../src/Test/Bitstream.svg\" resolution
---       lin = makeOutlMap \"..\/..\/../src\/Test\/LinLibertine.svg\" resolution
--- @
---
--- Several different fonts can be used. They are stored in Data.Map structures to avoid recalculation.
--- Lazy Evaluation ensures that outlines are only calculated if needed.
---
--- @
---      o  = V3 0 0 0 -- origin
---      v1 = V3 (-5) 0 0 -- direction of char-advance
---      v2 = V3 0 0 1  -- height direction
---      v3 = V3 0 0.1 0 -- extrusion
--- @
---
--- The position and size of the string
---
--- @
---       f :: String -> [String]
---       f str = take (length str) (concat (repeat [\"p\",\"q\"]))
--- @
---
--- Assigning a property to every character by a string. Here an alternation of 3d and textured characters
---
--- @
---      props :: Props
---      props = Map.fromList [("p", Outl bit "to3d"), ("q", Outl bit "to3d2"),
---                            ("r", Tex bit "red"),   ("s", Tex bit "blue") ]
--- @
---
--- Finite data structures are assigned to every property string.
--- This is needed to lazily make a Data.Map with every possible representation of a character.
--- A textured character needs an unchanged (maybe colored) outline. Thats why \"q\" uses the id function.
--- If several fonts are used, kerning is disabled between every two characters that are from different fonts.
---
--- @
---       transf :: Transf
---       transf = Map.fromList [("to3d",to3d), ("to3d2",to3d2), ("red", red.bgWhite), ("blue",blue.bgWhite), ("id",id)]
--- @
---
--- Although there might be finitely many functions that make sense it is still to much and we need
--- a small finite list for Data.Map. The number of combinations is ((Number of chars in font0) +
--- (Number of chars in font1) + ...) * (number of transformation functions) and every of these
--- combinations is built (but only evaluated if needed because of lazy evaluation)
--- Example: (font1: 40 chars + font2: 1000 chars) X (5 colors (transformation functions))
---          5200 key-value-pairs (assuming all colors are used in both fonts).
+bit = outlMap (ro "src/Test/Bitstream.svg")
+lin = outlMap (ro "src/Test/LinLibertine.svg")
+
+instance Default TextOpts where
+    def = TextOpts "text" lin INSIDE_H KERN 1 1
+
+-- | Main library functions, usage:
 --
 -- @
---      to3d geom = red $ ( ((extrude v3).deleteHoles) geom ) \`atop\` ( tri ((translate v3) geom) )
---      to3d2 geom = blue $ ( ((extrude (0,0.2,0)).deleteHoles) geom ) `atop` ( tri ((translate (0,0.2,0)) geom) )
---      tri = (triangulate ketTri).deleteHoles -- openglTriangulation
---      red =  changeDiffuseColor "red" (1,0,0,1) -- if used with textures diffuse is interpreted as foreground color
---      blue = changeDiffuseColor "blue" (0,0,1,1)
---      bgWhite = changeAmbientColor "white" (1,1,1,1) -- if used with textures interpreted as background color
--- @
--- 
--- The functions can be anything like extrusion, triangulation, color
+-- \{-\# LANGUAGE NoMonomorphismRestriction \#-\}
 --
--- @
---       texmap = makeTexMap resolution props transf
--- @
+--import Diagrams.Prelude
+--import Diagrams.Backend.Cairo.CmdLine
+--import Graphics.SVGFonts.ReadFont
 --
--- Again a Data.Map-structure to avoid recalculation of textures.
--- This has been separated from the outlineMap because it may one day also store
--- the transformations applied to the outlines and maybe not every char is a texture
+--main = defaultMain ( (text' \"Hello World\") \<\> (rect 8 1) \# alignBL )
 --
--- @
---      node = displayString str "node" resolution mode spacing (o,v1,v2) f props transf texmap
---   genCollada (lightedScene node) emptyAnim
---   putStrLn \"Collada File generated\"
+--text' t = stroke (textSVG_ $ TextOpts t lin INSIDE_H KERN 1 1 ) \# fc purple \# fillRule EvenOdd
 -- @
 --
--- node is a Node in a Scenegraph, that is inserted into a lighted scene 
--- and written into file that can be viewed in Blender
---
-displayString :: String -> String -> (Rx,Int) ->Mode->Spacing-> (V3,V3,V3) ->P->Props->Transf-> TexMap -> Scene
-displayString txt sid (rx,ry) mode spacing (o,v1,v2) f props transf texmap | mV1V2V3 mode = makeString v1 v2
-                                                                           | mV1 mode     = makeString v1 newV2
-                                                                           | mV2 mode     = makeString newV1 v2
+textSVG_ :: TextOpts -> Path R2
+textSVG_ to | mWH (mode to) = makeString (textWidth to) (textHeight to)
+            | mW  (mode to) = makeString (textWidth to) ((textWidth to) * maxY / sumh)
+            | mH  (mode to) = makeString ((textHeight to) * sumh / maxY) (textHeight to)
   where
-    makeString u1 u2 = makeScene sid $ map (\(g,transl) -> obj (get_name (head g)) g transl) (withoutSpaces u1 u2)
-    withoutSpaces u1 u2 = filter ((not.null).fst) (geometrieVs u1 u2)
-    geometrieVs u1 u2 = map (getC u1 u2 sumh (rx,ry) texmap) (zip5 str horPos hs newProps newTrList)
-    sumh | isMono spacing = maxX * (fromIntegral (length str)) -- a hack, not meant to be monospaced
-         | otherwise      = sum hs                              -- maybe a very long glyph can mess up a font
-    horPos | isMono spacing = reverse $ added (o: (replicate (length str) (v1Advance * (V3 maxX maxX maxX))))
-           | otherwise      = reverse $ added (o: stretch hs)
-    hs = horizontalAdvances (zip str newFontList) (isKern spacing)
-    stretch = map (v1Advance `mul`)
-    added = snd.(foldl (\(h,l) (b,_) -> (h + b, (h + b):l))
-                       ((V3 0 0 0),[])).  (map (\x->(x,[]))) -- [o,o+h0,o+h0+h1,..]
-    newV1 = set_len v1 ( (v_len v2) * (sumh/maxY) ) -- in case there are several fonts in a string
-    newV2 = set_len v2 ( (v_len v1) * (maxY/sumh) ) -- maxY is the average of max heights
-    maxX = (sum (map maximum_x fontList)) /
-           (fromIntegral (length fontList)) -- difficult to treat different fonts in one string
-
-    maxY = (sum (map bbox_dy fontList)) / (fromIntegral (length fontList)) -- max height of glyph
-    v1Advance | mV1V2V3 mode || mV1 mode = v1    `divide` sumh
-              | mV2 mode                 = newV1 `divide` sumh
-
-    properties = map (fromJust.((\x y -> Map.lookup y x) props)) (f txt)
-    fontList = map (sel1.getFont) properties
-    trList = map ((\x -> (x, fromJust (Map.lookup x transf))).getTr) properties
-
-	-- because of ligatures, str may contain fewer glyphs, properties, fontList and trList have to be adjsuted
-    newProps = dropSome (map length str) properties
-    newFontList = dropSome (map length str) fontList
-    newTrList = dropSome (map length str) trList
-    dropSome [] _ = []
-    dropSome _ [] = []
-    dropSome (l:ls) ps = (head ps) : (dropSome ls (drop l ps))
+    makeString w h = -- translate (-w/2, - h/2) $ -- origin in the middle
+                     scaleY (h/maxY) $ scaleX (w/sumh) $
+                     translate (0, - bbox_ly fontD) $
+                     mconcat $
+                     zipWith translate horPos
+                     (map (polygonChar outl) str)
+    (fontD,outl) = (fdo to)
+    polygonChar outl ch = fromJust (Map.lookup ch outl)
+    horPos = reverse $ added ( (0,0) : (map ((1,0) ^*) hs) )
+    hs = horizontalAdvances str fontD (isKern (spacing to))
+    sumh = sum hs
+    added = snd.(foldl (\(h,l) (b,_) -> (h ^+^ b, (h ^+^ b):l))
+                       ((0,0),[])).  (map (\x->(x,[]))) -- [o,o+h0,o+h0+h1,..]
+    maxY = bbox_dy fontD -- max height of glyph
 
-    ligaturesOfFontName = Map.fromList $ zip (map sel4 fontList)
-                                             (map ((filter ((>1).length)).(Map.keys).sel1) fontList)
-    constFontStrings :: String -> [String] -> [(Char,String)] -> [[(Char,String)]]
-    constFontStrings [c] [f] cc = [((c,f):cc)] -- group characters that have consecutively the same font
-    constFontStrings (c0:c1:cs) (f0:f1:fs) cc | f0 == f1  =  constFontStrings (c1:cs) (f1:fs) ((c0,f0):cc)
-                                              | otherwise = ((c0,f0):cc) : constFontStrings (c1:cs) (f1:fs) []
-    str = map T.unpack $ concat $ map (characterStrings ligaturesOfFontName)
-                                      (map reverse (constFontStrings txt (map sel4 fontList) []))
+    ligatures = ((filter ((>1).length)).(Map.keys).sel1) fontD
+    str = map T.unpack $ characterStrings (txt to) ligatures
 
 
-type Glyphdata = (String,V3,Float,CharProp,(String,Geometry->Geometry))
-
-getC :: V3 -> V3 -> Float -> (Rx,Int) -> TexMap -> Glyphdata -> ([Geometry],V3)
-getC u1 u2 sh (rx,ry) tex (ch,h,h_ad,pr,tr) | isTex pr  = texChar tex sfd u1 u2 sh (ch,h,h_ad,fst tr) (rx,ry)
-                                            | otherwise = (map (snd tr) (fst pc), snd pc)
-  where pc = polygonChar om sfd u1 u2 sh (rx,ry) (fst tr) (ch,h)
-        sfd = sel1 fd
-        fd = getFont pr
-        om = sel2 fd
-
 bbox_dy fontData = (bbox!!3) - (bbox!!1)
   where bbox = sel3 fontData -- bbox = [lower left x, lower left y, upper right x, upper right y]
 
 bbox_lx fontData   = (sel3 fontData) !! 0
 bbox_ly fontData   = (sel3 fontData) !! 1
-maximum_x fontData = (sel3 fontData) !! 2
 
-polygonChar :: OutlineMap -> FontData -> V3->V3->Float -> (Rx,Int) -> String -> (String,V3) -> ([Geometry],V3)
-polygonChar outl fontD v1 v2 sum_of_hs (rx,ry) tr (ch,h) = (geometry,h)
-  where
-  resize (x,y) = (v1 `mul` (x / sum_of_hs)) + (v2 `mul` (y / (bbox_dy fontD)  ))
-  out = fromMaybe [] (Map.lookup ch outl)
-  l = map (map resize) out
-  geometry | ch /= " " = [outline_geometry ch l fontD ("outline_" ++ ch ++ "_" ++ (sel4 fontD) ++ "_" ++ tr)]
-           | otherwise = []
 
-
-outline_geometry ch l fontD name = Geometry name
-                          [ LP (LinePrimitive indices indices V.empty [blue]) ]
-                           (Vertices "outline_vertices" (V.fromList (concat l))  -- vertices
-                             (V.replicate (length (concat l)) (V3 0 0 1))) -- normals
-  where
-    indices = parts 0 lengths
-    parts n (p:ps) = V.cons (V.fromList [n..(n+p-1)]) (parts (n+p) ps)
-    parts _ []     = V.empty
-    lengths = map length l
-
-
-texChar :: TexMap -> FontData -> V3 -> V3 -> Float -> (String,V3,Float,String) -> (Rx,Int) -> ([Geometry],V3)
-texChar texmap fontD v1 v2 sum_of_hs (ch,h,h_ad,tr) (rx,ry) = (geometry,h)
-  where
-  fontName = sel4 fontD
-  cn | isJust $ Map.lookup ch (sel1 fontD) = sel1 $ fromJust $ Map.lookup ch (sel1 fontD) -- description of the char (with a word)
-     | otherwise = ch
-  charName ch | length ch == 1 && (head ch) >= 'A' && (head ch) <= 'Z' = ch ++ "BIG" -- for Windows
-              | otherwise = ch
-  name = "tex_" ++ (charName cn) ++ "_" ++ fontName ++ "_" ++ tr
-  tex = Texture (name ++ "_im") fileName $! texObj -- force texObj to be evaluated because it produces a file
-  fileName = (charName cn) ++"_"++ fontName ++"_"++ tr ++ (show (getx ch fontD (rx,ry))) ++ "x" ++ (show ry) ++ ".tga"
-  geometry =
-    [Geometry name [PL (LinePrimitive (V.fromList [V.fromList [0,1,2,3]]) -- indices to vertices
-                                      (V.fromList [V.fromList [0,0,0,0]]) -- indices to normals
-                                      (V.fromList [V.fromList [0,1,2,3]]) -- indices to texture coordinates
-         [("phong_" ++ name, COMMON "" NoParam
-           (PhongTex [(TDiffuse tex)]
-             [[0,0,1,0,1,1,0,1]] -- [u0,v0,u1,v1,..] coordinates (Floats betw. 0 and 1)
-                                                        -- that point into the texture
-           ) ""
-         )]
-                  )]
-       (Vertices (name ++ "_vertices")
-        (V.fromList [res (n,n), res (v1,n), res (v1,v2), res (n,v2)]) -- vertices
-        (V.fromList [ cross3 v1 v2 ]) -- normals
-       )
-    ]
-
-  res (v,w) = (v `mul` (h_ad / sum_of_hs)) + w
-  texObj = case Map.lookup (ch,fontName,tr) texmap of
-           Just x -> Just $! (fst $! x)
-           Nothing -> Nothing
-
-n = (V3 0 0 0)
-
--- | Generate a map of lists of outlines
--- i.e. the letter 'i' consists of two lists.
---
--- Two different kinds of outlines are produced because:
---
--- * 'OutlineMap': There are non-equally-spaced points possible (for outlines)
+-- | Generate Paths of outlines
 --
--- * 'OutlineTexMap': There are only equally spaced points (for spans in rasterization)
-makeOutlMaps :: String -> (Rx,Int) -> (FontData, OutlineMap, OutlineTexMap)
-makeOutlMaps str (rx,ry) = ( fontD, Map.fromList [ (ch, outlines ch)     | ch <- allUnicodes ],
-                                    Map.fromList [ (ch, outlinesTex ch)  | ch <- allUnicodes ] )
+outlMap :: String -> (FontData, OutlineMap)
+outlMap str = ( fontD, Map.fromList [ (ch, outlines ch) | ch <- allUnicodes ] )
   where
   allUnicodes = Map.keys (sel1 fontD)
-  outlines ch    = commandsToPoints (cs ch) (ds ch) (0, -(bbox_ly fontD))
-  -- TO DO: screws up rasterization in LinLibertine
-  outlinesTex ch = map positiveX ( commandsToRasterPoints (cs ch) (stretch ch (ds ch)) (0, -(bbox_ly fontD)) )
-  positiveX = map ( \(x,y,b) -> (if x>0 then x else 0, y, b) )
-  stretch ch (x,y) = (x * (hadv ch fontD) / max_x, y)
-  max_x = maximum_x fontD
-  cs ch = commands ch (sel1 fontD)
-  ds ch = deltas ch fontD (rx, ry)
+  outlines ch = mconcat $ commandsToTrails (commands ch (sel1 fontD)) [] (0,0) (0,0) (0,0)
   fontD = openFont str
 
-deltas :: String -> FontData -> (Rx,Int) -> (Float,Float)
-deltas ch fontD (rx, ry) = (max_x/(fromIntegral $ getx ch fontD (rx,ry) ), (bbox_dy fontD) / (fromIntegral ry))
-  where max_x = maximum_x fontD
-
-getx :: String -> FontData -> (Rx,Int) -> Int
-getx ch fontD (rx, ry) | isExactly rx = fromJust $ getRx rx
-                       | isConstDx rx = round nrx
-                       | isXPowerOfTwo rx = roundP2 nrx
-
-  where nrx = ((fromIntegral ry)*((hadv ch fontD)/ (bbox_dy fontD) )) -- ry/rx * (h_ad/max_y) * rx
-        -- | Round to the Power of two, i.e. roundP2 110 == 128, roundP2 130 == 256
-        roundP2 :: Float -> Int
-        roundP2 a = round $ head $ filter (>a) (take 100 (power2s 1))
-        power2s a = a : (power2s (a*2))
-
+commandsToTrails :: [PathCommand] -> [Segment R2] -> R2 -> R2 -> R2 -> [Path R2]
+commandsToTrails [] _ _ _ _ = []
+commandsToTrails (c:cs) segments (lx,ly) lastContr beginPoint -- (lx,ly) is the endpoint of the last segment
+      | isNothing nextSegment = (translate beginPoint (pathFromTrail $ fromSegments segments)) :
+                  ( commandsToTrails cs [] (lx+x0, ly+y0) (contr c) (beginP c) ) -- one outline completed
+      | otherwise = commandsToTrails cs (segments ++ [fromJust nextSegment])
+                                           (lx+x0, ly+y0) (contr c) (beginP c)   -- work on outline
+  where nextSegment = go c
+        (x0,y0) | isJust nextSegment = segOffset (fromJust nextSegment)
+                | otherwise = (0,0)
+        (cx,cy) = lastContr -- last control point is always in absolute coordinates
+        beginP ( M_abs (x,y) ) = (x,y)
+        beginP ( M_rel (x,y) ) = (lx+x, ly+y)
+        beginP _ = beginPoint
+        contr ( C_abs (x1,y1,x2,y2,x,y) ) = (x0+x-x2, y0+y-y2 ) -- control point of bezier curve
+        contr ( C_rel (x1,y1,x2,y2,x,y) ) = (   x-x2,    y-y2 )
+        contr ( S_abs (x2,y2,x,y) )       = (x0+x-x2, y0+y-y2 )
+        contr ( S_rel (x2,y2,x,y) )       = (   x-x2,    y-y2 )
+        contr ( Q_abs (x1,y1,x,y) ) = (x0+x-x1, y0+y-y1 )
+        contr ( Q_rel (x1,y1,x,y) ) = (   x-x1,    y-y1 )
+        contr ( T_abs (x,y) )       = (2*x0-cx, 2*y0-cy )
+        contr ( T_rel (x,y) )       = (   x-cx,    y-cy )
+        contr ( L_abs (x,y) ) = (x0, y0)
+        contr ( L_rel (x,y) ) = ( 0,  0)
+        contr ( M_abs (x,y) ) = (x0, y0)
+        contr ( M_rel (x,y) ) = ( 0,  0)
+        contr ( H_abs x ) = (x0, y0)
+        contr ( H_rel x ) = ( 0, y0)
+        contr ( V_abs y ) = (x0, y0)
+        contr ( V_rel y ) = (x0,  0)
+        go ( M_abs (x,y) ) = Nothing
+        go ( M_rel (x,y) ) = Nothing
+        go ( L_abs (x,y) ) = Just $ straight (x0+x, y0+y)
+        go ( L_rel (x,y) ) = Just $ straight (x, y)
+        go ( H_abs x) = Just $ straight (x0 + x, y0)
+        go ( H_rel x) = Just $ straight (x, 0)
+        go ( V_abs y) = Just $ straight (x0, y0 + y)
+        go ( V_rel y) = Just $ straight (0, y)
+        go ( C_abs (x1,y1,x2,y2,x,y) ) = Just $ bezier3 (x0+x1, y0+y1) (x0+x2,y0+y2) (x0+x,y0+y)
+        go ( C_rel (x1,y1,x2,y2,x,y) ) = Just $ bezier3 (x1, y1) (x2, y2) (x, y)
+        go ( S_abs (      x2,y2,x,y) ) = Just $ bezier3 (cx, cy) (x0+x2, y0+y2) (x0+x, y0+y)
+        go ( S_rel (      x2,y2,x,y) ) = Just $ bezier3 (cx, cy) (x2, y2) (x, y)
+        go ( Q_abs (x1,y1,x,y) ) = Just $ bezier3 (x0 + x1, y0 + y1) (x0 + x1, y0 + y1) (x0 + x, y0 + y)
+        go ( Q_rel (x1,y1,x,y) ) = Just $ bezier3 (x1, y1) (x1, y1) (x, y)
+        go ( T_abs (x,y) ) = Just $ bezier3 (cx, cy) (cx, cy) (x0 + x, y0 + y)
+        go ( T_rel (x,y) ) = Just $ bezier3 (cx, cy) (cx, cy) (x, y)
+        go ( Z ) = Nothing
 
+commands :: String -> SvgGlyph -> [PathCommand]
 commands ch glyph | isJust element = unsafePerformIO $ pathFromString $ sel3 $ fromJust element
                   | otherwise      = []
   where element = Map.lookup ch glyph
 
--- | Texture images for all combinations of characters, fonts and transformations
--- for combinations of fonts and transformations only those are used that exist in this combination in the
--- property list while every character is used that exists in the svg-font file.
-makeTexMap :: (Rx,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 (Tex (fontD,_,_) _) = Map.keys (sel1 fontD)
-   glyph ch (Tex (fontD,_,outl) tr) = trace ch $ unsafePerformIO $
-                             getGlyphTexture ch fontD outl (tr,trs) (getx ch fontD (rx,ry), fromIntegral ry)
-   getID :: String -> CharProp -> (String, String, String)
-   getID ch (Tex (fontD, _, _) transformation) = (ch, sel4 fontD, transformation)
-
-
-getGlyphTexture :: String -> FontData -> OutlineTexMap -> (String,Transf) -> (Int,Int) ->
-                   IO (TextureObject,String)
-getGlyphTexture ch fontD om (tr,trs) (rx,ry) =
-    (do fileExists <- doesFileExist fileName
-        if fileExists then do tga <- (readTGA fileName)
-                              createTexture (rx,ry) tga fileName
-                      else do (writeTGA fileName (borderToTex (rx,ry) borderPoints (color coloredDummyObj) ))
-                              tga <- (readTGA fileName)
-                              createTexture (rx,ry) tga fileName
-    )
-  where cn | isJust $ Map.lookup ch (sel1 fontD) = sel1 $ fromJust $ Map.lookup ch (sel1 fontD) -- description of the char (with a word)
-           | otherwise = ch
-        charName ch | length ch == 1 && (head ch) >= 'A' && (head ch) <= 'Z' = ch ++ "BIG" -- for Windows
-                    | otherwise = ch
-
-        fileName = (charName cn) ++ "_" ++ (sel4 fontD) ++ "_" ++ tr ++ (show rx) ++ "x" ++ (show ry) ++ ".tga"
-        f :: Geometry -> Geometry
-        f = fromJust $ Map.lookup tr trs
-        coloredDummyObj = f  $ Geometry "" [ LP (LinePrimitive e e e [blue]) ] (Vertices "" e e)
-        e = V.empty
-        color (Geometry "" [ LP (LinePrimitive _ _ _ [ (_, COMMON "" NoParam (PhongCol cs) _) ]) 
-                           ] _) = ( head $ catMaybes (map getDiffuseColor cs), 
-                                    head $ catMaybes (map getAmbientColor cs) )
-        borderPoints = map (\(x,y,B b) -> (truncate x, truncate y, b)) $ concat $ fromJust ( Map.lookup ch om )

@@ -0,0 +1,134 @@+--------------------------------------------------------------------
+-- |
+-- Module    : Graphics.SVG.ReadPath
+-- Copyright : (c) 2011 Tillmann Vogt
+-- License   : BSD3
+--
+-- Maintainer: Tillmann Vogt <tillk.vogt@googlemail.com>
+-- Stability : stable
+-- Portability: portable
+--
+-- parsing the SVG path command, see <http://www.w3.org/TR/SVG/paths.html#PathData> :
+
+module Graphics.SVGFonts.ReadPath
+ ( pathFromString,
+   PathCommand(..),
+ )
+ where
+
+import Text.ParserCombinators.Parsec hiding (spaces)
+import Text.ParserCombinators.Parsec.Expr
+import Text.ParserCombinators.Parsec.Prim
+import qualified Text.ParserCombinators.Parsec.Token as P
+import Text.ParserCombinators.Parsec.Language(emptyDef)
+import System.IO.Unsafe (unsafePerformIO)
+import Debug.Trace
+
+type X = Double
+type Y = Double
+type F2 = (X,Y)
+type Tup = (X,Y)
+type X1 = X
+type Y1 = Y
+type X2 = X
+type Y2 = Y
+data PathCommand =
+  M_abs Tup | -- ^Establish a new current point (with absolute coords)
+  M_rel Tup | -- ^Establish a new current point (with coords relative 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 | -- ^A line from the current point to Tup which becomes the new current point
+  L_rel Tup |
+  H_abs X | -- ^A horizontal line from the current point (cpx, cpy) to (x, cpy)
+  H_rel X |
+  V_abs Y | -- ^A vertical line from the current point (cpx, cpy) to (cpx, y)
+  V_rel 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_Abs = Shorthand/smooth quadratic Bezier curveto
+  T_rel Tup |
+  A_abs | -- ^A = Elliptic arc (not used)
+  A_rel
+  deriving Show
+
+-- | convert a SVG path string into a list of commands
+pathFromString :: String -> IO [PathCommand]
+pathFromString str
+  = do{ case (parse path "" str) of
+           Left err -> do{ putStr "parse error at "
+                         ; print err
+                         ; return []
+                         }
+           Right x  -> return x
+      }
+
+spaces = skipMany space
+
+path :: Parser [PathCommand]
+path = do{ l <- many pathElement
+         ; eof
+         ; return (concat l)
+         }
+
+pathElement :: Parser [PathCommand]
+pathElement = 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 "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 myfloat; return (map (\x-> H_abs (realToFrac x)) l) } <|>
+              do{ symbol "h";  l <- many1 myfloat; return (map (\x-> H_rel (realToFrac x)) l) } <|>
+              do{ symbol "V";  l <- many1 myfloat; return (map (\x-> V_abs (realToFrac x)) l) } <|>
+              do{ symbol "v";  l <- many1 myfloat; return (map (\x-> V_rel (realToFrac 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
+            }
+
+comma = do{ spaces; try (do { (char ','); return () }) <|> spaces }
+
+tupel2 :: Parser (X,Y)
+tupel2 = do{ x <- myfloat; comma; y <- myfloat; spaces;
+             return (realToFrac x, realToFrac y)
+           }
+
+tupel4 :: Parser (X,Y,X,Y)
+tupel4 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces;
+              x <- myfloat; comma;  y <- myfloat; spaces;
+             return (realToFrac x1, realToFrac y1, realToFrac x, realToFrac y)
+           }
+
+tupel6 :: Parser (X,Y,X,Y,X,Y)
+tupel6 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces;
+             x2 <- myfloat; comma; y2 <- myfloat; spaces;
+              x <- myfloat; comma;  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 to float
+              do { i<-integer; return(fromIntegral i) } 
+
+lexer = P.makeTokenParser emptyDef
+
+whiteSpace      = P.whiteSpace lexer    
+symbol          = P.symbol lexer    
+integer         = P.integer lexer    
+float           = P.float lexer

@@ -1,69 +0,0 @@-module Main where
-
-import Data.Tree
-import Graphics.SVGFonts.ReadFont
-import Graphics.Formats.Collada.ColladaTypes (Geometry, SceneNode(..))
-import Graphics.Formats.Collada.GenerateObjects (lightedScene, lightedSceneNode, emptyAnim)
-import Graphics.Formats.Collada.GenerateCollada (genCollada)
-import Graphics.Formats.Collada.Transformations (extrude, atop, translate, changeDiffuseColor, changeAmbientColor)
-import Graphics.Formats.Collada.Vector2D3D (V3(..),V4(..))
-import Graphics.Triangulation.Triangulation (triangulate, deleteHoles, gjpTri)
-import Graphics.Triangulation.KETTriangulation (ketTri)
-import qualified Data.Map as Map
-import System.Environment
-
-main = do
-  args <- getArgs
-  let str = if null args then "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTVXYZ0123456789" -- UW
--- "The fluffiest bunny VVAV \x2192\x2193 x2200\x2203\x21d2\x2192\x2190 ss"
-                         else head args
-      resolution = (ConstDx, 100) -- (Exactly 512, 512) (ConstDx, 512) (XPowerOfTwo, 512) (OneTexture, 512)
--- The y resolution is constant. The x resolution of a glyph changes in non-mono-spaced fonts.
--- Rx: Exactly: Use this resolution
---     ConstDx: The x-resolution of a glvph is chosen so that the pixels of all glyphs have the same size
---     XPowerOfTwo: With this option the resolution nearest of a power of two is chosen,
---                  i.e. "l" would have (256,512), while "w" would have (512,512)
---     OneTexture: The whole string as one texture (not implemented yet)
-      mode = INSIDE_V2
--- 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
-      spacing = HADV -- KERN
--- spacing: MONO: Use mono spacing between glyphs. The longest glyph influences the bbox that is used
---          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"
-      bit = makeOutlMaps "../../../src/Test/Bitstream.svg" resolution
-      lin = makeOutlMaps "../../../src/Test/LinLibertine.svg" resolution
-      o  = V3 0 0 0 -- origin
-      v1 = V3 (-5) 0 0 -- direction of char-advance
-      v2 = V3 0 0 1  -- height direction
-      v3 = V3 0 0.1 0 -- extrusion
-
-      f :: String -> [String]  -- assigning a property to every character by a unique string
-      f str = take (length str) (concat (repeat ["r","s"]))
-
-      props :: Props
-      props = Map.fromList [("p", Outl lin "to3d"), ("q", Outl lin "to3d2"),
-                            ("r", Tex bit "red"),   ("s", Tex bit "blue") ]
-
-      -- transformation of a Geoemtry Node (i.e. triangulation) has to be done with a string assignment,
-      -- because there has to be a finite number of functions for Data.Map
-      transf :: Transf
-      transf = Map.fromList [("to3d",to3d), ("to3d2",to3d2), ("red", red.bgWhite), ("blue",blue.bgWhite), ("id",id)]
-      -- not the perfect solution since some points are generated twice
-      to3d geom  = red  $ ( ((extrude v3).deleteHoles) geom ) `atop`
-                          ( tri ((translate v3) geom) )
-      to3d2 geom = blue $ ( ((extrude (V3 0 0.05 0)).deleteHoles) geom ) `atop`
-                          ( tri ((translate (V3 0 0.05 0)) geom) )
-      tri = (triangulate ketTri).deleteHoles -- gjpTri
-      red =  changeDiffuseColor "red" (V4 1 0 0 1) -- if used with textures diffuse is interpreted as foreground color
-      blue = changeDiffuseColor "blue" (V4 0 0 1 1)
-      bgWhite = changeAmbientColor "white" (V4 1 1 1 1) -- if used with textures interpreted as background color
-
-      texmap = makeTexMap resolution props transf
-      n0 = displayString str "line0" resolution mode spacing (o,v1,v2) f props transf texmap
---      n1 = displayString "test" "line1" resolution mode spacing (V3 0 0 (-1),v1,v2) f props transf texmap
-      node = Node EmptyRoot [n0]
-  genCollada (lightedScene node) emptyAnim
-  putStrLn "Collada File generated"