minitypeset-opengl-0.1.0.0: example/example-boxes.hs

-- | This example program demonstrates how \"boxes\" work.
--
-- It is also useful for debugging.
--
-- Note: this program does not do any font rendering; for that, see the
-- other example program (example-STIX.hs)!
--

module Main where

--------------------------------------------------------------------------------

import Data.Char hiding ( Space )

import Control.Monad
import Data.IORef
import System.IO.Unsafe as Unsafe

import qualified Data.Map as Map ; import Data.Map (Map)

import Graphics.Rendering.OpenGL as GL
import Graphics.UI.GLFW ( Window )

import Graphics.Rendering.MiniTypeset

import GL

--------------------------------------------------------------------------------

box1, box2 :: Box

box1 = Box 50  75  5 10 15 20 10 5
box2 = Box 63 105 10 25 5   5 12 8

--------------------------------------------------------------------------------

scaleCol :: Double -> Col -> Col
scaleCol s (Col r g b) = Col (s*r) (s*g) (s*b)

setCol :: Col -> IO ()
setCol (Col r g b) = color (Color3 r g b)

setColAlpha :: Col -> Double -> IO ()
setColAlpha (Col r g b) a = color (Color4 r g b a)

withPos :: Pos -> IO a -> IO a
withPos (Pos x y) action = do
  GL.translate (Vector3 x y 0)
  r <- action 
  GL.translate (Vector3 (-x) (-y) 0)     -- quick hack :)
  return r

--------------------------------------------------------------------------------

renderBoxOutline :: Col -> Box -> IO ()
renderBoxOutline col (Box w h l r t b hgap vgap) = do
  setCol (scaleCol 0.5  col) ; renderQuadOutline (-l,-t) (w+r+hgap,h+b+vgap)
  setCol (scaleCol 0.75 col) ; renderQuadOutline (-l,-t) (w+r,h+b)
  setCol col                 ; renderQuadOutline ( 0, 0) (w,h)

renderBoxFilled:: Col -> Double -> Box -> IO ()
renderBoxFilled col alpha  (Box w h l r t b hgap vgap) = do
  blend     $= Enabled
  blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
  setColAlpha (scaleCol 0.5  col) alpha ; renderQuadFilled (-l,-t) (w+r+hgap,h+b+vgap)
  setColAlpha (scaleCol 0.75 col) alpha ; renderQuadFilled (-l,-t) (w+r,h+b)
  setColAlpha col                 alpha ; renderQuadFilled ( 0, 0) (w,h)
  blend     $= Disabled

withAbsBox :: AbsBox -> (Box -> IO a) -> IO a
withAbsBox (AbsBox pos box) action = withPos pos (action box)

--------------------------------------------------------------------------------
  
renderQuadOutline :: (Double,Double) -> (Double,Double) -> IO ()
renderQuadOutline (x1,y1) (x2,y2) = do
  renderPrimitive LineLoop $ do
    vertex (Vertex2 x1 y1)
    vertex (Vertex2 x2 y1)
    vertex (Vertex2 x2 y2)
    vertex (Vertex2 x1 y2)

renderQuadFilled :: (Double,Double) -> (Double,Double) -> IO ()
renderQuadFilled (x1,y1) (x2,y2) = do
  renderPrimitive Quads $ do
    vertex (Vertex2 x1 y1)
    vertex (Vertex2 x2 y1)
    vertex (Vertex2 x2 y2)
    vertex (Vertex2 x1 y2)

--------------------------------------------------------------------------------

renderTriple :: (Box,(AbsBox,AbsBox)) -> IO ()
renderTriple (box,(abox1,abox2)) = do
  withAbsBox abox1 $ renderBoxFilled (Col 0 1 0) 0.75 
  withAbsBox abox2 $ renderBoxFilled (Col 0 0 1) 0.75 

  let abox = AbsBox (Pos 0 0) box
  blend $= Enabled  
  setColAlpha (Col 1 0 0) 0.20
  renderOuterBoxQuad abox
  renderInnerBoxQuad abox
  setColAlpha (Col 1 1 1) 0.25
  renderBoxGap       abox
  blend $= Disabled

  renderBoxOutline (Col 1 0 0) box

display :: Window -> Double -> IO ()
display window time = do
  
  clearColor $=! (Color4 0 0 0 0)  
  clear [ColorBuffer,DepthBuffer]
  
  -- setWindowCoordSystem 
  -- GL.scale 2 2 (0.5::Double)

  matrixMode $= Projection
  loadIdentity
  ortho 0 800 500 0 (-1) (1::Double)   -- to avoid issues with "retina" displays (window size /= framebuffer res)

  withPos (Pos  15  25) $ renderTriple $ hcatBox2 AlignTop     box1 box2 
  withPos (Pos 215  25) $ renderTriple $ hcatBox2 AlignBottom  box1 box2
  withPos (Pos  15 225) $ renderTriple $ vcatBox2 AlignLeft    box1 box2
  withPos (Pos 215 225) $ renderTriple $ vcatBox2 AlignRight   box1 box2

  withPos (Pos 415  25) $ renderTriple $ hcatBox2 AlignTop     box2 box1 
  withPos (Pos 615  25) $ renderTriple $ hcatBox2 AlignBottom  box2 box1
  withPos (Pos 415 225) $ renderTriple $ vcatBox2 AlignLeft    box2 box1
  withPos (Pos 615 225) $ renderTriple $ vcatBox2 AlignRight   box2 box1

  return ()

--------------------------------------------------------------------------------

main = do
  initGL (return ()) (\() -> display) 

--------------------------------------------------------------------------------