minitypeset-opengl-0.2.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

mkBox w h l r t b hgap vgap = Box (w,h) outer bound gap where
  outer = Quad (-l,-t) (w+r     ,h+b     )
  gap   = Quad (-l,-t) (w+r+hgap,h+b+vgap)
  bound = Quad (-l/2,-t/3) (w*2/3,h*3/4)

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

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

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

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 = do
  setCol (scaleCol 0.5  col) ; renderQuadOutline (boxGapQuad   box)
  setCol (scaleCol 0.75 col) ; renderQuadOutline (boxOuterQuad box)
  setCol col                 ; renderQuadOutline (boxInnerQuad box)

renderBoxFilled:: Col -> Float -> Box -> IO ()
renderBoxFilled col alpha box = do
  blend     $= Enabled
  blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
  setColAlpha (scaleCol 0.5  col) alpha ; renderQuadFilled (boxGapQuad   box)
  setColAlpha (scaleCol 0.75 col) alpha ; renderQuadFilled (boxOuterQuad box)
  setColAlpha col                 alpha ; renderQuadFilled (boxInnerQuad box)
  blend     $= Disabled

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

--------------------------------------------------------------------------------
  
renderQuadOutline :: Quad -> IO ()
renderQuadOutline (Quad (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 :: Quad -> IO ()
renderQuadFilled (Quad (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) 

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