SVGFonts-1.0: src/Graphics/SVGFonts/RasterFont.hs
{-# 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))