Fonts.hs

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"

  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
      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 = HADV
      gaw = makeMaps gawFile resolution
      lin = makeMaps linFile resolution
      o = (0,0,0) -- 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

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)