Fonts.hs

module Main where

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT as GLUT
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Test.PointOfView
import Graphics.SVGFonts.ReadFont(get_glyph_polygon, read_font, horiz_sum, cycle_neighbours, triang)
import Char

main= do
  (progName,_) <- getArgsAndInitialize
  initialDisplayMode $= [WithDepthBuffer, DoubleBuffered, RGBAMode, WithAlphaComponent, WithAccumBuffer]
  createWindow progName
  windowSize $= Size 800 600
  myInit

  -- display_string uses 4 vectors and a mode: origin, v1 (direction of char-advance), v2(height direction), v3(extrusion), mode
  -- mode 0: the string is inside v1 v2 v3 boundaries (height/length-relation not kept)
  -- mode 1: stay inside v1 boundary, size of v2 adjusted to height/length-relation
  -- mode 2: stay inside v2 boundary, size of v1 adjusted to height/length-relation
  g <- return ( G (display_string "Haskell will be mainstream"
                                  --"abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 +-~{}[]()=*/%"
                                 "../../../src/Test/GirlsareWeird.svg" -- "LinLibertineO.svg" "Scriptin.svg"
                                  5 (0,0,0) (10,0,0) (0,0,-1) (0,0.2,0) 1) )

  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 1 1 1
   materialSpecular Front $= Color4 1 1 1 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

   clearColor $= Color4 0 0 0 0
   clearAccum $= Color4 0 0 0 0
--   spriteInit 800 600

display keystate pPos l = do
  loadIdentity
  setPointOfView keystate pPos
  clear [ColorBuffer,DepthBuffer]
  callList l
  --deleteLists [l]
  swapBuffers


type Rad = Val
type X = Val
type Y = Val
type Z = Val
type B = Bool
type T = Int -- times
type C = Float -- const
type O = V -- position vector
data Prop = RedGreenBlue (Float, Float, Float) | N |   -- N = not visible
            Textur (Maybe TextureObject)  | --deriving (Show) -- from sprites.hs
            Triangul [(Int,Int,Int)] -- list of triangles
data AObj = Annotate [V] Prop

type V = (Float,Float,Float) -- x,y,z

instance Show Prop where
         show (RedGreenBlue (a,b,c)) = "RGB(" ++ show (floor a) ++ "," ++ show (floor b) ++ "," ++
                                                 show (floor c) ++ ")"
type Val = GLfloat  -- size in meters
type Tup = (O, V, V, C, C)
type Svg_glyph = [(String, String, String, String)]
nul = ( (0,0,0), (0,0,0), (0,0,0), 1, 1)

data Obj = G  [ AObj ]  | -- extruded objects in coords (G for Geometry)
              Nil

red   = RedGreenBlue (1,0,0)
green = RedGreenBlue (0,1,0)
blue  = RedGreenBlue (0,0,1)
white = RedGreenBlue (1,1,1)
grey  = RedGreenBlue (0.7,0.7,0.7)
turk  = RedGreenBlue (0,1,1)

-- 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) (cycle_neighbours (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

-- ========================================================
-- conversion into G [AObj]  (mainly with eval3d)
-- meaning of G [AObj] by example:
-- G [Annotate pr [1], Annotate pr [2], Annotate pr [3], Annotate pr [4]] = four single points (0d)
-- G [Annotate pr [1,2], Annotate pr [2,3], Annotate pr [3,4], Annotate pr [4,1]] = four lines (1d)
-- G [Annotate pr [1,2,3,4]]  a rectangle (2d)
-- G [Annotate pr [1,2,3,4], Annotate pr [3,4,5,6], Annotate pr [1,2,7,8]] = a 3d object, consisting of several rectangles
-- ========================================================

  -- mode 0: the string is inside v1 v2 v3 boundaries (height/length-relation not kept)
  -- mode 1: stay inside v1 boundary, size of v2 adjusted to height/length-relation
  -- mode 2: stay inside v2 boundary, size of v1 adjusted to height/length-relation
display_string :: String -> FilePath -> Int -> O -> V -> V -> V -> Int -> [AObj]
display_string str file bez o v1 v2 v3 mode | mode == 0 = make_str str (fst glyph) h max_h bez o v1 v2 v3
                                            | mode == 1 = make_str str (fst glyph) h max_h bez o v1 new_v2 v3
                                            | mode == 2 = make_str str (fst glyph) h max_h bez o new_v1 v2 v3
  where
    glyph = read_font file
    h = fromIntegral (horiz_sum str (fst glyph))
    bbox = splitBy isSpace (snd glyph)
    max_h = read (head (drop 3 bbox)) -- bbox)  -- max height of glyph
    new_v1 = set_len v1 ( (v_len v2) * (h/max_h) )
    new_v2 = set_len v2 ( (v_len v1) * (max_h/h) )

splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy _ [] = []
splitBy f list = first : splitBy f (dropWhile f rest) where
 (first, rest) = break f list

make_str :: String -> Svg_glyph -> Float -> Float -> Int -> O -> V -> V -> V -> [AObj]
make_str []       g h mh bez o v1 v2 v3 = []
make_str (ch:str) g h mh bez o v1 v2 v3 | (length outline) == 0 =    (make_str str g h mh bez (o `add` v1_advance) v1 v2 v3)
                                        | otherwise = glyph_faces ++ (make_str str g h mh bez (o `add` v1_advance) v1 v2 v3)
  where
    glyph_faces = glyph3d -- 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 )
    out_tri = zip outline triangles -- list of tuples of outline with its triangulation:
     --  i.e. a character like "j" has two outlines (one for the point).
    resize (x,y) = o `add` (v1 `mul` (x/h)) `add` (v2 `mul` (y/mh))
    outline = sel3_1 glyph
    triangles = map (\x -> Triangul x) (sel3_3 glyph)
    v1_advance = v1 `mul` ((sel3_2 glyph) / h)
    glyph = get_glyph_polygon ch g bez mh -- ([[F2]], X,[[ (Int,Int,Int) ]]) = (outline, ha, map triang outline)

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

sel3_1 (x,y,z) = x
sel3_2 (x,y,z) = y
sel3_3 (x,y,z) = z

-- ====================================================================
-- displaying
-- ====================================================================
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)

disp :: AObj -> IO()
disp (Annotate ps ( Triangul tris )) = do diplay_primitive (generate_from_index ps tris) blue Triangles
disp (Annotate ps pr) | (length ps) == 1 = do diplay_primitive ps pr Points
                      | (length ps) == 2 = do diplay_primitive ps pr Lines
                      | otherwise        = do diplay_primitive ps pr Polygon

generate_from_index :: [(Float,Float,Float)] -> [(Int,Int,Int)] -> [(Float,Float,Float)]
generate_from_index ps [] = []
generate_from_index ps (t:tris) = [tp0, tp1, tp2] ++ (generate_from_index ps tris)
  where tp0 = head(drop (sel3_1 t) ps)
        tp1 = head(drop (sel3_2 t) ps)
        tp2 = head(drop (sel3_3 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 r g b 1
                        currentNormal $= Normal3 (sel3_1(norm p)) (sel3_2(norm p)) (sel3_3(norm p))
                        displayPoints p primitiveShape
   | otherwise = do
                        materialAmbientAndDiffuse Front $= Color4 r g b 1
                        displayPoints p primitiveShape

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

displayPoints points primitiveShape = do
   renderPrimitive primitiveShape$makeVertices points
   flush

makeVertices = mapM_ ( \(x,y,z) -> vertex$Vertex3 x y z )
makeV = map ( \(x,y,z) -> (Vertex3 x y z) )

setVertex :: (TexCoord2 GLfloat, Vertex3 GLfloat) -> IO ()
setVertex (texCoordinates, vertexCoordinates) = do texCoord texCoordinates; vertex vertexCoordinates;

-- A routine used to draw a list of coordinates.
mapVertices :: [(TexCoord2 GLfloat)] -> [(Vertex3 GLfloat)] -> IO ()
mapVertices texs verts = mapM_ setVertex (zip texs verts)