--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.Polygons
-- Copyright   :  (c) Sven Panne 2002-2019
-- License     :  BSD3
-- 
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to section 3.5 (Polygons) of the OpenGL 2.1 specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.Polygons (
   polygonSmooth, cullFace,
   PolygonStipple(..), GLpolygonstipple, polygonStipple,
   PolygonMode(..), polygonMode, polygonOffset,
   polygonOffsetPoint, polygonOffsetLine, polygonOffsetFill
) where

import Control.Monad
import Data.StateVar
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Ptr
import Graphics.Rendering.OpenGL.GL.Capability
import Graphics.Rendering.OpenGL.GL.Face
import Graphics.Rendering.OpenGL.GL.PixelRectangles
import Graphics.Rendering.OpenGL.GL.PolygonMode
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.GL.SavingState
import Graphics.GL

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

polygonSmooth :: StateVar Capability
polygonSmooth :: StateVar Capability
polygonSmooth = EnableCap -> StateVar Capability
makeCapability EnableCap
CapPolygonSmooth

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

cullFace :: StateVar (Maybe Face)
cullFace :: StateVar (Maybe Face)
cullFace = IO EnableCap -> IO Face -> (Face -> IO ()) -> StateVar (Maybe Face)
forall a.
IO EnableCap -> IO a -> (a -> IO ()) -> StateVar (Maybe a)
makeStateVarMaybe (EnableCap -> IO EnableCap
forall (m :: * -> *) a. Monad m => a -> m a
return EnableCap
CapCullFace)
                             ((GLenum -> Face) -> PName1I -> IO Face
forall p a. GetPName1I p => (GLenum -> a) -> p -> IO a
getEnum1 GLenum -> Face
unmarshalFace PName1I
GetCullFaceMode)
                             (GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glCullFace (GLenum -> IO ()) -> (Face -> GLenum) -> Face -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Face -> GLenum
marshalFace)

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

numPolygonStippleBytes :: Int
numPolygonStippleBytes :: Int
numPolygonStippleBytes = Int
128   -- 32x32 bits divided into GLubytes

class PolygonStipple s where
   withNewPolygonStipple :: (Ptr GLubyte -> IO ()) -> IO s
   withPolygonStipple :: s -> (Ptr GLubyte -> IO a) -> IO a
   newPolygonStipple :: [GLubyte] -> IO s
   getPolygonStippleComponents :: s -> IO [GLubyte]

   withNewPolygonStipple Ptr GLubyte -> IO ()
act =
      Int -> (Ptr GLubyte -> IO s) -> IO s
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
numPolygonStippleBytes ((Ptr GLubyte -> IO s) -> IO s) -> (Ptr GLubyte -> IO s) -> IO s
forall a b. (a -> b) -> a -> b
$ \Ptr GLubyte
p -> do
         Ptr GLubyte -> IO ()
act Ptr GLubyte
p
         [GLubyte]
components <- Int -> Ptr GLubyte -> IO [GLubyte]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
numPolygonStippleBytes Ptr GLubyte
p
         [GLubyte] -> IO s
forall s. PolygonStipple s => [GLubyte] -> IO s
newPolygonStipple [GLubyte]
components

   withPolygonStipple s
s Ptr GLubyte -> IO a
act = do
      [GLubyte]
components <- s -> IO [GLubyte]
forall s. PolygonStipple s => s -> IO [GLubyte]
getPolygonStippleComponents s
s
      [GLubyte] -> (Ptr GLubyte -> IO a) -> IO a
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [GLubyte]
components Ptr GLubyte -> IO a
act

   newPolygonStipple [GLubyte]
components =
      (Ptr GLubyte -> IO ()) -> IO s
forall s. PolygonStipple s => (Ptr GLubyte -> IO ()) -> IO s
withNewPolygonStipple ((Ptr GLubyte -> IO ()) -> IO s) -> (Ptr GLubyte -> IO ()) -> IO s
forall a b. (a -> b) -> a -> b
$
         (Ptr GLubyte -> [GLubyte] -> IO ())
-> [GLubyte] -> Ptr GLubyte -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr GLubyte -> [GLubyte] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray (Int -> [GLubyte] -> [GLubyte]
forall a. Int -> [a] -> [a]
take Int
numPolygonStippleBytes [GLubyte]
components)

   getPolygonStippleComponents s
s =
      s -> (Ptr GLubyte -> IO [GLubyte]) -> IO [GLubyte]
forall s a. PolygonStipple s => s -> (Ptr GLubyte -> IO a) -> IO a
withPolygonStipple s
s ((Ptr GLubyte -> IO [GLubyte]) -> IO [GLubyte])
-> (Ptr GLubyte -> IO [GLubyte]) -> IO [GLubyte]
forall a b. (a -> b) -> a -> b
$ Int -> Ptr GLubyte -> IO [GLubyte]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
numPolygonStippleBytes

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

data GLpolygonstipple = GLpolygonstipple (ForeignPtr GLubyte)
   deriving ( GLpolygonstipple -> GLpolygonstipple -> Bool
(GLpolygonstipple -> GLpolygonstipple -> Bool)
-> (GLpolygonstipple -> GLpolygonstipple -> Bool)
-> Eq GLpolygonstipple
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GLpolygonstipple -> GLpolygonstipple -> Bool
$c/= :: GLpolygonstipple -> GLpolygonstipple -> Bool
== :: GLpolygonstipple -> GLpolygonstipple -> Bool
$c== :: GLpolygonstipple -> GLpolygonstipple -> Bool
Eq, Eq GLpolygonstipple
Eq GLpolygonstipple
-> (GLpolygonstipple -> GLpolygonstipple -> Ordering)
-> (GLpolygonstipple -> GLpolygonstipple -> Bool)
-> (GLpolygonstipple -> GLpolygonstipple -> Bool)
-> (GLpolygonstipple -> GLpolygonstipple -> Bool)
-> (GLpolygonstipple -> GLpolygonstipple -> Bool)
-> (GLpolygonstipple -> GLpolygonstipple -> GLpolygonstipple)
-> (GLpolygonstipple -> GLpolygonstipple -> GLpolygonstipple)
-> Ord GLpolygonstipple
GLpolygonstipple -> GLpolygonstipple -> Bool
GLpolygonstipple -> GLpolygonstipple -> Ordering
GLpolygonstipple -> GLpolygonstipple -> GLpolygonstipple
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GLpolygonstipple -> GLpolygonstipple -> GLpolygonstipple
$cmin :: GLpolygonstipple -> GLpolygonstipple -> GLpolygonstipple
max :: GLpolygonstipple -> GLpolygonstipple -> GLpolygonstipple
$cmax :: GLpolygonstipple -> GLpolygonstipple -> GLpolygonstipple
>= :: GLpolygonstipple -> GLpolygonstipple -> Bool
$c>= :: GLpolygonstipple -> GLpolygonstipple -> Bool
> :: GLpolygonstipple -> GLpolygonstipple -> Bool
$c> :: GLpolygonstipple -> GLpolygonstipple -> Bool
<= :: GLpolygonstipple -> GLpolygonstipple -> Bool
$c<= :: GLpolygonstipple -> GLpolygonstipple -> Bool
< :: GLpolygonstipple -> GLpolygonstipple -> Bool
$c< :: GLpolygonstipple -> GLpolygonstipple -> Bool
compare :: GLpolygonstipple -> GLpolygonstipple -> Ordering
$ccompare :: GLpolygonstipple -> GLpolygonstipple -> Ordering
$cp1Ord :: Eq GLpolygonstipple
Ord, Int -> GLpolygonstipple -> ShowS
[GLpolygonstipple] -> ShowS
GLpolygonstipple -> String
(Int -> GLpolygonstipple -> ShowS)
-> (GLpolygonstipple -> String)
-> ([GLpolygonstipple] -> ShowS)
-> Show GLpolygonstipple
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GLpolygonstipple] -> ShowS
$cshowList :: [GLpolygonstipple] -> ShowS
show :: GLpolygonstipple -> String
$cshow :: GLpolygonstipple -> String
showsPrec :: Int -> GLpolygonstipple -> ShowS
$cshowsPrec :: Int -> GLpolygonstipple -> ShowS
Show )

instance PolygonStipple GLpolygonstipple where
   withNewPolygonStipple :: (Ptr GLubyte -> IO ()) -> IO GLpolygonstipple
withNewPolygonStipple Ptr GLubyte -> IO ()
f = do
      ForeignPtr GLubyte
fp <- Int -> IO (ForeignPtr GLubyte)
forall a. Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray Int
numPolygonStippleBytes
      ForeignPtr GLubyte -> (Ptr GLubyte -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr GLubyte
fp Ptr GLubyte -> IO ()
f
      GLpolygonstipple -> IO GLpolygonstipple
forall (m :: * -> *) a. Monad m => a -> m a
return (GLpolygonstipple -> IO GLpolygonstipple)
-> GLpolygonstipple -> IO GLpolygonstipple
forall a b. (a -> b) -> a -> b
$ ForeignPtr GLubyte -> GLpolygonstipple
GLpolygonstipple ForeignPtr GLubyte
fp

   withPolygonStipple :: GLpolygonstipple -> (Ptr GLubyte -> IO a) -> IO a
withPolygonStipple (GLpolygonstipple ForeignPtr GLubyte
fp) = ForeignPtr GLubyte -> (Ptr GLubyte -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr GLubyte
fp

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

polygonStipple :: PolygonStipple s => StateVar (Maybe s)
polygonStipple :: StateVar (Maybe s)
polygonStipple =
   IO EnableCap -> IO s -> (s -> IO ()) -> StateVar (Maybe s)
forall a.
IO EnableCap -> IO a -> (a -> IO ()) -> StateVar (Maybe a)
makeStateVarMaybe (EnableCap -> IO EnableCap
forall (m :: * -> *) a. Monad m => a -> m a
return EnableCap
CapPolygonStipple)
      (PixelStoreDirection -> IO s -> IO s
forall a. PixelStoreDirection -> IO a -> IO a
withoutGaps PixelStoreDirection
Pack (IO s -> IO s) -> IO s -> IO s
forall a b. (a -> b) -> a -> b
$ (Ptr GLubyte -> IO ()) -> IO s
forall s. PolygonStipple s => (Ptr GLubyte -> IO ()) -> IO s
withNewPolygonStipple Ptr GLubyte -> IO ()
forall (m :: * -> *). MonadIO m => Ptr GLubyte -> m ()
glGetPolygonStipple)
      (\s
s -> PixelStoreDirection -> IO () -> IO ()
forall a. PixelStoreDirection -> IO a -> IO a
withoutGaps PixelStoreDirection
Unpack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ s -> (Ptr GLubyte -> IO ()) -> IO ()
forall s a. PolygonStipple s => s -> (Ptr GLubyte -> IO a) -> IO a
withPolygonStipple s
s Ptr GLubyte -> IO ()
forall (m :: * -> *). MonadIO m => Ptr GLubyte -> m ()
glPolygonStipple)

-- Note: No need to set rowAlignment, our memory allocator always returns a
-- region which is at least 8-byte aligned (the maximum)
withoutGaps :: PixelStoreDirection -> IO a -> IO a
withoutGaps :: PixelStoreDirection -> IO a -> IO a
withoutGaps PixelStoreDirection
direction IO a
action =
   [ClientAttributeGroup] -> IO a -> IO a
forall a. [ClientAttributeGroup] -> IO a -> IO a
preservingClientAttrib [ ClientAttributeGroup
PixelStoreAttributes ] (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
      PixelStoreDirection -> StateVar GLint
rowLength  PixelStoreDirection
direction StateVar GLint -> GLint -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLint
0
      PixelStoreDirection -> StateVar GLint
skipRows   PixelStoreDirection
direction StateVar GLint -> GLint -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLint
0
      PixelStoreDirection -> StateVar GLint
skipPixels PixelStoreDirection
direction StateVar GLint -> GLint -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLint
0
      IO a
action

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

polygonMode :: StateVar (PolygonMode, PolygonMode)
polygonMode :: StateVar (PolygonMode, PolygonMode)
polygonMode = IO (PolygonMode, PolygonMode)
-> ((PolygonMode, PolygonMode) -> IO ())
-> StateVar (PolygonMode, PolygonMode)
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar IO (PolygonMode, PolygonMode)
getPolygonMode (PolygonMode, PolygonMode) -> IO ()
setPolygonMode

getPolygonMode :: IO (PolygonMode, PolygonMode)
getPolygonMode :: IO (PolygonMode, PolygonMode)
getPolygonMode = (GLint -> GLint -> (PolygonMode, PolygonMode))
-> PName2I -> IO (PolygonMode, PolygonMode)
forall p a. GetPName2I p => (GLint -> GLint -> a) -> p -> IO a
getInteger2 (\GLint
front GLint
back -> (GLint -> PolygonMode
un GLint
front, GLint -> PolygonMode
un GLint
back)) PName2I
GetPolygonMode
   where un :: GLint -> PolygonMode
un = GLenum -> PolygonMode
unmarshalPolygonMode (GLenum -> PolygonMode)
-> (GLint -> GLenum) -> GLint -> PolygonMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLint -> GLenum
forall a b. (Integral a, Num b) => a -> b
fromIntegral

setPolygonMode :: (PolygonMode, PolygonMode) -> IO ()
setPolygonMode :: (PolygonMode, PolygonMode) -> IO ()
setPolygonMode (PolygonMode
front, PolygonMode
back)
   -- OpenGL 3 deprecated separate polygon draw modes, so try to avoid them.
   | PolygonMode
front PolygonMode -> PolygonMode -> Bool
forall a. Eq a => a -> a -> Bool
== PolygonMode
back = Face -> PolygonMode -> IO ()
forall (m :: * -> *). MonadIO m => Face -> PolygonMode -> m ()
setPM Face
FrontAndBack PolygonMode
front
   | Bool
otherwise = do Face -> PolygonMode -> IO ()
forall (m :: * -> *). MonadIO m => Face -> PolygonMode -> m ()
setPM Face
Front PolygonMode
front; Face -> PolygonMode -> IO ()
forall (m :: * -> *). MonadIO m => Face -> PolygonMode -> m ()
setPM Face
Back PolygonMode
back
   where setPM :: Face -> PolygonMode -> m ()
setPM Face
f PolygonMode
m = GLenum -> GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glPolygonMode (Face -> GLenum
marshalFace Face
f) (PolygonMode -> GLenum
marshalPolygonMode PolygonMode
m)

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

polygonOffset :: StateVar (GLfloat, GLfloat)
polygonOffset :: StateVar (GLfloat, GLfloat)
polygonOffset =
   IO (GLfloat, GLfloat)
-> ((GLfloat, GLfloat) -> IO ()) -> StateVar (GLfloat, GLfloat)
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar ((GLfloat -> GLfloat -> (GLfloat, GLfloat))
-> IO GLfloat -> IO GLfloat -> IO (GLfloat, GLfloat)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) ((GLfloat -> GLfloat) -> PName1F -> IO GLfloat
forall p a. GetPName1F p => (GLfloat -> a) -> p -> IO a
getFloat1 GLfloat -> GLfloat
forall a. a -> a
id PName1F
GetPolygonOffsetFactor)
                            ((GLfloat -> GLfloat) -> PName1F -> IO GLfloat
forall p a. GetPName1F p => (GLfloat -> a) -> p -> IO a
getFloat1 GLfloat -> GLfloat
forall a. a -> a
id PName1F
GetPolygonOffsetUnits))
                ((GLfloat -> GLfloat -> IO ()) -> (GLfloat, GLfloat) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry GLfloat -> GLfloat -> IO ()
forall (m :: * -> *). MonadIO m => GLfloat -> GLfloat -> m ()
glPolygonOffset)

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

polygonOffsetPoint :: StateVar Capability
polygonOffsetPoint :: StateVar Capability
polygonOffsetPoint = EnableCap -> StateVar Capability
makeCapability EnableCap
CapPolygonOffsetPoint

polygonOffsetLine :: StateVar Capability
polygonOffsetLine :: StateVar Capability
polygonOffsetLine = EnableCap -> StateVar Capability
makeCapability EnableCap
CapPolygonOffsetLine

polygonOffsetFill :: StateVar Capability
polygonOffsetFill :: StateVar Capability
polygonOffsetFill = EnableCap -> StateVar Capability
makeCapability EnableCap
CapPolygonOffsetFill