{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
----------------------------------------------------------------------
-- |
-- Module      :  Graphics.FieldTrip.Geometry2
-- Copyright   :  (c) Conal Elliott and Andy J Gill 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net, andygill@ku.edu
-- Stability   :  experimental
-- 
-- 2D geometry
----------------------------------------------------------------------

module Graphics.FieldTrip.Geometry2
  (
    Geometry2, renderer2, renderWith2, render2
  , ubox2, box2
  , approx2, udisk, polygon, regularPolygon
  , diskWedge, regularPolygonWedge
  -- * Text
  , utext, utextWidth, utextBaseline
  -- * Geometry2 filters
  , Filter2, move2, move2X, move2Y, andFlip2
  ) where

import Data.Monoid
import Control.Applicative
import System.IO.Unsafe( unsafePerformIO )

import Graphics.UI.GLUT

import Graphics.FieldTrip.Misc
import Graphics.FieldTrip.Point2
import Graphics.FieldTrip.Transform
import Graphics.FieldTrip.Transform2
import Graphics.FieldTrip.Render
import Graphics.FieldTrip.Material

-- | 2D geometry
-- In the 'Monoid' instance, 'mempty' is completely invisible (aka
-- transparent or empty), and @a 'mappend' b@ places @a@ on top of @b@.

newtype Geometry2 = Renderer2 { unRenderer2 :: Renderer }

-- TODO: consider expanding Geometry2 with more constructors, as in
-- Geometry3, e.g., 
-- 
--   -- | 2D geometry
--   data Geometry2
--      = EmptyG
--      | OverG Geometry2 Geometry2
--      | forall s. (Floating s, Real s, MatrixComponent s) =>
--           TransformG (Transform2 s) Geometry2
--      | RenderG Renderer
--      -- temporary:
--      | ColorG ColorTrans Geometry2


inRenderer2 :: (Renderer -> Renderer)
        -> (Geometry2 -> Geometry2)
inRenderer2 f = Renderer2 . f . unRenderer2

inRenderer22 :: (Renderer -> Renderer -> Renderer)
         -> (Geometry2 -> Geometry2 -> Geometry2)
inRenderer22 f = inRenderer2 . f . unRenderer2

instance Monoid Geometry2 where
  mempty  = Renderer2 (pure (return ()))
  mappend = inRenderer22 (liftA2 (>>))

-- | Make a geometry from a rendering action.  The action must leave graphics
-- state as it found it.
renderer2 :: Renderer -> Geometry2
renderer2 = Renderer2

-- | Render the geometry, given a graphics context.  Leaves graphics state unchanged.
renderWith2 :: GContext -> Geometry2 -> IO ()
renderWith2 = flip unRenderer2

-- | Render the geometry with default graphics context.  See also 'renderWith2'.
render2 :: Geometry2 -> IO ()
render2 = renderWith2 defaultGC

instance (Floating s, Real s, MatrixComponent s) =>
     Transform (Transform2 s) Geometry2 where
  xf *% im = Renderer2 $ \ gc ->
               preservingMatrix $ do
                 tweakMatrix2 xf
                 renderWith2 (onErr (tweakError2 xf) gc) im


-- | Box2 of given @width@ and @height@.  See also 'ubox2.
box2 :: (Real s, Floating s, MatrixComponent s) => s -> s -> Geometry2
box2 width height = scale2 width height *% ubox2

-- | Box2 of unit @width@ and @height@.  See also 'box2.
ubox2 :: Geometry2
ubox2 = polygon [Vertex2 p p, Vertex2 p m, Vertex2 m m, Vertex2 m p]
 where
   p,m :: Float
   p = 1/2
   m = -p

-- | Approximate one geometry by another, given an error bound
approx2 :: (ErrorBound -> Geometry2) -> Geometry2
approx2 f = Renderer2 $ \ gc -> renderWith2 gc (f (gcErr gc))

-- | The unit disk, approximated as regular n-gons
udisk :: Geometry2
udisk = approx2 $ regularPolygon . max 3 . round . recip

-- | Portion of a disk
diskWedge :: R -> Geometry2
diskWedge frac =
  approx2 $ regularPolygonWedge frac . max 3 . round . (frac /)

-- | A polygon
polygon :: VertexComponent s => [Vertex2 s] -> Geometry2
polygon vs =
  renderer2 (\(GC _ mTrans _) -> do material (mTrans defaultMat)
                                    renderPrimitive Polygon (mapM_ vertex vs))

-- | Regular polygon
regularPolygon :: Int -> Geometry2
regularPolygon sides
  | sides < 3 = error "regularPolygon must have at least three sides"
  | otherwise = polygon points
 where
   points :: [Point2 Float]
   points = [ point2Polar 1 (fromIntegral i * theta)
            | i <- [sides,sides-1 .. 1]]
   theta  = 2*pi / fromIntegral sides

-- | Regular polygon wedge.  Oops!  only works for frac <= 1/2, since
-- otherwise the polygon is non-convex.
regularPolygonWedge :: forall s. (Ord s, Floating s, VertexComponent s) =>
                       s -> Int -> Geometry2
regularPolygonWedge frac sides
  | sides < 1 = error "regularPolygonWedge must have at least one side"
  | frac > 1/2 = error "regularPolygonWedge: requires frac <= 1/2 for now."
  | otherwise = renderer2 $ const $
                  renderPrimitive Polygon $
                    do verts
                       vertex (point2 0 0 :: Point2 s)
 where
   verts :: IO ()
   verts = sequence_ [ v (fromIntegral i * theta)
                     | i <- [sides,sides-1 .. 0]]
   p :: s -> Point2 s
   p = point2Polar 1
   v :: s -> IO ()
   v = vertex . p
   theta :: s
   theta  = frac * (2*pi / fromIntegral sides)

-- TODO: refactor regularPolygon & regularPolygonWedge, and disk & wedge.

-- TODO: verify counter-clockwise order.  might not be what GL expects.


{--------------------------------------------------------------------
    Text
--------------------------------------------------------------------}

-- Utility function for allowing material transformations for when lifted to
-- 3d geometry.
withDefaultMat :: IO () -> Geometry2
withDefaultMat x =
  renderer2 (\(GC _ mTrans _) -> material (mTrans defaultMat) >> x)

-- TODO: I think withDefaultMat leaves the graphics state changed, thus
-- breaking composability.  - Conal

glText :: String -> Geometry2
glText = withDefaultMat . preservingMatrix . renderString Roman

glAboveBaseline, glBelowBaseline :: Double
glAboveBaseline = 119.05
glBelowBaseline = 33.33

glTextWidth :: String -> Double
glTextWidth = fromIntegral . unsafePerformIO . stringWidth Roman

-- | The passed string of text centered at the origin with height 1.0
utext :: String -> Geometry2
utext s = (m . sc . glText) s
  where
    h = glAboveBaseline + glBelowBaseline
    z = glBelowBaseline / h
    m = move2 (-utextWidth s/2) (-0.5 + z)
    sc = (*%) (uscale2 (1.0/h))

-- | The width of the geometry of utext of that string.
utextWidth :: String -> Double
utextWidth = flip (/) (glAboveBaseline+glBelowBaseline) . glTextWidth

-- | The height of the baseline of geometry created by utext. This can be
-- used for underlining, for example.
utextBaseline :: Double
utextBaseline = glBelowBaseline/(glAboveBaseline+glBelowBaseline) - 0.5



{--------------------------------------------------------------------
    Filters
--------------------------------------------------------------------}

-- | Geometry2 filter
type Filter2 = Geometry2 -> Geometry2

-- | Simplified interface to 'translate2'
move2 :: (MatrixComponent s, Real s, Floating s) =>
         s -> s -> Filter2
move2 dx dy = (translate2 (Vector2 dx dy) *%)

-- | Specializations of 'move2'
move2X, move2Y :: (MatrixComponent s, Real s, Floating s) =>
                  s -> Filter2
move2X dx = move2 dx 0
move2Y dy = move2 0 dy

-- | A geometry plus its a rotated-by-pi version.
andFlip2 :: Filter2
andFlip2 im = im `mappend` (rotate2 (pi :: Float) *% im)