module Graphics.FieldTrip.Geometry2
(
Geometry2, renderer2, renderWith2, render2
, ubox2, box2
, approx2, udisk, polygon, regularPolygon
, diskWedge, regularPolygonWedge
, utext, utextWidth, utextBaseline
, 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
newtype Geometry2 = Renderer2 { unRenderer2 :: Renderer }
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 (>>))
renderer2 :: Renderer -> Geometry2
renderer2 = Renderer2
renderWith2 :: GContext -> Geometry2 -> IO ()
renderWith2 = flip unRenderer2
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 :: (Real s, Floating s, MatrixComponent s) => s -> s -> Geometry2
box2 width height = scale2 width height *% ubox2
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
approx2 :: (ErrorBound -> Geometry2) -> Geometry2
approx2 f = Renderer2 $ \ gc -> renderWith2 gc (f (gcErr gc))
udisk :: Geometry2
udisk = approx2 $ regularPolygon . max 3 . round . recip
diskWedge :: R -> Geometry2
diskWedge frac =
approx2 $ regularPolygonWedge frac . max 3 . round . (frac /)
polygon :: VertexComponent s => [Vertex2 s] -> Geometry2
polygon vs =
renderer2 (\(GC _ mTrans _) -> do material (mTrans defaultMat)
renderPrimitive Polygon (mapM_ vertex vs))
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,sides1 .. 1]]
theta = 2*pi / fromIntegral sides
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,sides1 .. 0]]
p :: s -> Point2 s
p = point2Polar 1
v :: s -> IO ()
v = vertex . p
theta :: s
theta = frac * (2*pi / fromIntegral sides)
withDefaultMat :: IO () -> Geometry2
withDefaultMat x =
renderer2 (\(GC _ mTrans _) -> material (mTrans defaultMat) >> x)
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
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))
utextWidth :: String -> Double
utextWidth = flip (/) (glAboveBaseline+glBelowBaseline) . glTextWidth
utextBaseline :: Double
utextBaseline = glBelowBaseline/(glAboveBaseline+glBelowBaseline) 0.5
type Filter2 = Geometry2 -> Geometry2
move2 :: (MatrixComponent s, Real s, Floating s) =>
s -> s -> Filter2
move2 dx dy = (translate2 (Vector2 dx dy) *%)
move2X, move2Y :: (MatrixComponent s, Real s, Floating s) =>
s -> Filter2
move2X dx = move2 dx 0
move2Y dy = move2 0 dy
andFlip2 :: Filter2
andFlip2 im = im `mappend` (rotate2 (pi :: Float) *% im)