module Graphics.Rendering.OpenGL.GLU.Quadrics (
QuadricNormal, QuadricTexture(..), QuadricOrientation(..),
QuadricDrawStyle(..), QuadricStyle(..),
Radius, Height, Angle, Slices, Stacks, Loops, QuadricPrimitive(..),
renderQuadric
) where
import Control.Monad ( unless )
import Foreign.Ptr ( Ptr, nullPtr, freeHaskellFunPtr )
import Graphics.GLU
import Graphics.Rendering.OpenGL.GL.Colors ( ShadingModel(Smooth,Flat) )
import Graphics.Rendering.OpenGL.GL.Exception ( bracket )
import Graphics.Rendering.OpenGL.GL.GLboolean ( marshalGLboolean )
import Graphics.Rendering.OpenGL.GLU.ErrorsInternal (
recordErrorCode, recordOutOfMemory )
import Graphics.GL
data QuadricDrawStyle =
PointStyle
| LineStyle
| FillStyle
| SilhouetteStyle
deriving ( QuadricDrawStyle -> QuadricDrawStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
$c/= :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
== :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
$c== :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
Eq, Eq QuadricDrawStyle
QuadricDrawStyle -> QuadricDrawStyle -> Bool
QuadricDrawStyle -> QuadricDrawStyle -> Ordering
QuadricDrawStyle -> QuadricDrawStyle -> QuadricDrawStyle
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 :: QuadricDrawStyle -> QuadricDrawStyle -> QuadricDrawStyle
$cmin :: QuadricDrawStyle -> QuadricDrawStyle -> QuadricDrawStyle
max :: QuadricDrawStyle -> QuadricDrawStyle -> QuadricDrawStyle
$cmax :: QuadricDrawStyle -> QuadricDrawStyle -> QuadricDrawStyle
>= :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
$c>= :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
> :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
$c> :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
<= :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
$c<= :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
< :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
$c< :: QuadricDrawStyle -> QuadricDrawStyle -> Bool
compare :: QuadricDrawStyle -> QuadricDrawStyle -> Ordering
$ccompare :: QuadricDrawStyle -> QuadricDrawStyle -> Ordering
Ord, Int -> QuadricDrawStyle -> ShowS
[QuadricDrawStyle] -> ShowS
QuadricDrawStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QuadricDrawStyle] -> ShowS
$cshowList :: [QuadricDrawStyle] -> ShowS
show :: QuadricDrawStyle -> String
$cshow :: QuadricDrawStyle -> String
showsPrec :: Int -> QuadricDrawStyle -> ShowS
$cshowsPrec :: Int -> QuadricDrawStyle -> ShowS
Show )
marshalQuadricDrawStyle :: QuadricDrawStyle -> GLenum
marshalQuadricDrawStyle :: QuadricDrawStyle -> GLenum
marshalQuadricDrawStyle QuadricDrawStyle
x = case QuadricDrawStyle
x of
QuadricDrawStyle
PointStyle -> GLenum
GLU_POINT
QuadricDrawStyle
LineStyle -> GLenum
GLU_LINE
QuadricDrawStyle
FillStyle -> GLenum
GLU_FILL
QuadricDrawStyle
SilhouetteStyle -> GLenum
GLU_SILHOUETTE
type QuadricNormal = Maybe ShadingModel
marshalQuadricNormal :: QuadricNormal -> GLenum
marshalQuadricNormal :: QuadricNormal -> GLenum
marshalQuadricNormal (Just ShadingModel
Smooth) = GLenum
GLU_SMOOTH
marshalQuadricNormal (Just ShadingModel
Flat ) = GLenum
GLU_FLAT
marshalQuadricNormal QuadricNormal
Nothing = GLenum
GLU_NONE
data QuadricOrientation =
Outside
| Inside
deriving ( QuadricOrientation -> QuadricOrientation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QuadricOrientation -> QuadricOrientation -> Bool
$c/= :: QuadricOrientation -> QuadricOrientation -> Bool
== :: QuadricOrientation -> QuadricOrientation -> Bool
$c== :: QuadricOrientation -> QuadricOrientation -> Bool
Eq, Eq QuadricOrientation
QuadricOrientation -> QuadricOrientation -> Bool
QuadricOrientation -> QuadricOrientation -> Ordering
QuadricOrientation -> QuadricOrientation -> QuadricOrientation
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 :: QuadricOrientation -> QuadricOrientation -> QuadricOrientation
$cmin :: QuadricOrientation -> QuadricOrientation -> QuadricOrientation
max :: QuadricOrientation -> QuadricOrientation -> QuadricOrientation
$cmax :: QuadricOrientation -> QuadricOrientation -> QuadricOrientation
>= :: QuadricOrientation -> QuadricOrientation -> Bool
$c>= :: QuadricOrientation -> QuadricOrientation -> Bool
> :: QuadricOrientation -> QuadricOrientation -> Bool
$c> :: QuadricOrientation -> QuadricOrientation -> Bool
<= :: QuadricOrientation -> QuadricOrientation -> Bool
$c<= :: QuadricOrientation -> QuadricOrientation -> Bool
< :: QuadricOrientation -> QuadricOrientation -> Bool
$c< :: QuadricOrientation -> QuadricOrientation -> Bool
compare :: QuadricOrientation -> QuadricOrientation -> Ordering
$ccompare :: QuadricOrientation -> QuadricOrientation -> Ordering
Ord, Int -> QuadricOrientation -> ShowS
[QuadricOrientation] -> ShowS
QuadricOrientation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QuadricOrientation] -> ShowS
$cshowList :: [QuadricOrientation] -> ShowS
show :: QuadricOrientation -> String
$cshow :: QuadricOrientation -> String
showsPrec :: Int -> QuadricOrientation -> ShowS
$cshowsPrec :: Int -> QuadricOrientation -> ShowS
Show )
marshalQuadricOrientation :: QuadricOrientation -> GLenum
marshalQuadricOrientation :: QuadricOrientation -> GLenum
marshalQuadricOrientation QuadricOrientation
x = case QuadricOrientation
x of
QuadricOrientation
Outside -> GLenum
GLU_OUTSIDE
QuadricOrientation
Inside -> GLenum
GLU_INSIDE
data QuadricTexture
= NoTextureCoordinates
| GenerateTextureCoordinates
deriving ( QuadricTexture -> QuadricTexture -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QuadricTexture -> QuadricTexture -> Bool
$c/= :: QuadricTexture -> QuadricTexture -> Bool
== :: QuadricTexture -> QuadricTexture -> Bool
$c== :: QuadricTexture -> QuadricTexture -> Bool
Eq,Eq QuadricTexture
QuadricTexture -> QuadricTexture -> Bool
QuadricTexture -> QuadricTexture -> Ordering
QuadricTexture -> QuadricTexture -> QuadricTexture
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 :: QuadricTexture -> QuadricTexture -> QuadricTexture
$cmin :: QuadricTexture -> QuadricTexture -> QuadricTexture
max :: QuadricTexture -> QuadricTexture -> QuadricTexture
$cmax :: QuadricTexture -> QuadricTexture -> QuadricTexture
>= :: QuadricTexture -> QuadricTexture -> Bool
$c>= :: QuadricTexture -> QuadricTexture -> Bool
> :: QuadricTexture -> QuadricTexture -> Bool
$c> :: QuadricTexture -> QuadricTexture -> Bool
<= :: QuadricTexture -> QuadricTexture -> Bool
$c<= :: QuadricTexture -> QuadricTexture -> Bool
< :: QuadricTexture -> QuadricTexture -> Bool
$c< :: QuadricTexture -> QuadricTexture -> Bool
compare :: QuadricTexture -> QuadricTexture -> Ordering
$ccompare :: QuadricTexture -> QuadricTexture -> Ordering
Ord )
marshalQuadricTexture :: QuadricTexture -> GLboolean
marshalQuadricTexture :: QuadricTexture -> GLboolean
marshalQuadricTexture QuadricTexture
NoTextureCoordinates = forall a. Num a => Bool -> a
marshalGLboolean Bool
False
marshalQuadricTexture QuadricTexture
GenerateTextureCoordinates = forall a. Num a => Bool -> a
marshalGLboolean Bool
True
data QuadricStyle
= QuadricStyle QuadricNormal
QuadricTexture
QuadricOrientation
QuadricDrawStyle
deriving ( QuadricStyle -> QuadricStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QuadricStyle -> QuadricStyle -> Bool
$c/= :: QuadricStyle -> QuadricStyle -> Bool
== :: QuadricStyle -> QuadricStyle -> Bool
$c== :: QuadricStyle -> QuadricStyle -> Bool
Eq,Eq QuadricStyle
QuadricStyle -> QuadricStyle -> Bool
QuadricStyle -> QuadricStyle -> Ordering
QuadricStyle -> QuadricStyle -> QuadricStyle
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 :: QuadricStyle -> QuadricStyle -> QuadricStyle
$cmin :: QuadricStyle -> QuadricStyle -> QuadricStyle
max :: QuadricStyle -> QuadricStyle -> QuadricStyle
$cmax :: QuadricStyle -> QuadricStyle -> QuadricStyle
>= :: QuadricStyle -> QuadricStyle -> Bool
$c>= :: QuadricStyle -> QuadricStyle -> Bool
> :: QuadricStyle -> QuadricStyle -> Bool
$c> :: QuadricStyle -> QuadricStyle -> Bool
<= :: QuadricStyle -> QuadricStyle -> Bool
$c<= :: QuadricStyle -> QuadricStyle -> Bool
< :: QuadricStyle -> QuadricStyle -> Bool
$c< :: QuadricStyle -> QuadricStyle -> Bool
compare :: QuadricStyle -> QuadricStyle -> Ordering
$ccompare :: QuadricStyle -> QuadricStyle -> Ordering
Ord )
type Radius = GLdouble
type Height = GLdouble
type Angle = GLdouble
type Slices = GLint
type Stacks = GLint
type Loops = GLint
data QuadricPrimitive
= Sphere Radius Slices Stacks
| Cylinder Radius Radius Height Slices Stacks
| Disk Radius Radius Slices Loops
| PartialDisk Radius Radius Slices Loops Angle Angle
deriving ( QuadricPrimitive -> QuadricPrimitive -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QuadricPrimitive -> QuadricPrimitive -> Bool
$c/= :: QuadricPrimitive -> QuadricPrimitive -> Bool
== :: QuadricPrimitive -> QuadricPrimitive -> Bool
$c== :: QuadricPrimitive -> QuadricPrimitive -> Bool
Eq, Eq QuadricPrimitive
QuadricPrimitive -> QuadricPrimitive -> Bool
QuadricPrimitive -> QuadricPrimitive -> Ordering
QuadricPrimitive -> QuadricPrimitive -> QuadricPrimitive
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 :: QuadricPrimitive -> QuadricPrimitive -> QuadricPrimitive
$cmin :: QuadricPrimitive -> QuadricPrimitive -> QuadricPrimitive
max :: QuadricPrimitive -> QuadricPrimitive -> QuadricPrimitive
$cmax :: QuadricPrimitive -> QuadricPrimitive -> QuadricPrimitive
>= :: QuadricPrimitive -> QuadricPrimitive -> Bool
$c>= :: QuadricPrimitive -> QuadricPrimitive -> Bool
> :: QuadricPrimitive -> QuadricPrimitive -> Bool
$c> :: QuadricPrimitive -> QuadricPrimitive -> Bool
<= :: QuadricPrimitive -> QuadricPrimitive -> Bool
$c<= :: QuadricPrimitive -> QuadricPrimitive -> Bool
< :: QuadricPrimitive -> QuadricPrimitive -> Bool
$c< :: QuadricPrimitive -> QuadricPrimitive -> Bool
compare :: QuadricPrimitive -> QuadricPrimitive -> Ordering
$ccompare :: QuadricPrimitive -> QuadricPrimitive -> Ordering
Ord )
renderQuadric :: QuadricStyle -> QuadricPrimitive -> IO ()
renderQuadric :: QuadricStyle -> QuadricPrimitive -> IO ()
renderQuadric QuadricStyle
style QuadricPrimitive
prim = do
forall a. IO a -> (QuadricObj -> IO a) -> IO a
withQuadricObj IO ()
recordOutOfMemory forall a b. (a -> b) -> a -> b
$ \QuadricObj
quadricObj ->
forall a. QuadricObj -> QuadricCallback -> IO a -> IO a
withErrorCallback QuadricObj
quadricObj QuadricCallback
recordErrorCode forall a b. (a -> b) -> a -> b
$ do
QuadricObj -> QuadricStyle -> IO ()
setStyle QuadricObj
quadricObj QuadricStyle
style
QuadricObj -> QuadricPrimitive -> IO ()
renderPrimitive QuadricObj
quadricObj QuadricPrimitive
prim
withQuadricObj :: IO a -> (QuadricObj -> IO a) -> IO a
withQuadricObj :: forall a. IO a -> (QuadricObj -> IO a) -> IO a
withQuadricObj IO a
failure QuadricObj -> IO a
success =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket forall (m :: * -> *). MonadIO m => m QuadricObj
gluNewQuadric QuadricObj -> IO ()
safeDeleteQuadric
(\QuadricObj
quadricObj -> if QuadricObj -> Bool
isNullQuadricObj QuadricObj
quadricObj
then IO a
failure
else QuadricObj -> IO a
success QuadricObj
quadricObj)
safeDeleteQuadric :: QuadricObj -> IO ()
safeDeleteQuadric :: QuadricObj -> IO ()
safeDeleteQuadric QuadricObj
quadricObj =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QuadricObj -> Bool
isNullQuadricObj QuadricObj
quadricObj) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => QuadricObj -> m ()
gluDeleteQuadric QuadricObj
quadricObj
withErrorCallback :: QuadricObj -> QuadricCallback -> IO a -> IO a
withErrorCallback :: forall a. QuadricObj -> QuadricCallback -> IO a -> IO a
withErrorCallback QuadricObj
quadricObj QuadricCallback
callback IO a
action =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (QuadricCallback -> IO (FunPtr QuadricCallback)
makeQuadricCallback QuadricCallback
callback) forall a. FunPtr a -> IO ()
freeHaskellFunPtr forall a b. (a -> b) -> a -> b
$ \FunPtr QuadricCallback
callbackPtr -> do
forall (m :: * -> *) a.
MonadIO m =>
QuadricObj -> GLenum -> FunPtr a -> m ()
gluQuadricCallback QuadricObj
quadricObj GLenum
GLU_ERROR FunPtr QuadricCallback
callbackPtr
IO a
action
setStyle :: QuadricObj -> QuadricStyle -> IO ()
setStyle :: QuadricObj -> QuadricStyle -> IO ()
setStyle QuadricObj
quadricObj (QuadricStyle QuadricNormal
n QuadricTexture
t QuadricOrientation
o QuadricDrawStyle
d) = do
forall (m :: * -> *). MonadIO m => QuadricObj -> GLenum -> m ()
gluQuadricNormals QuadricObj
quadricObj (QuadricNormal -> GLenum
marshalQuadricNormal QuadricNormal
n)
forall (m :: * -> *). MonadIO m => QuadricObj -> GLboolean -> m ()
gluQuadricTexture QuadricObj
quadricObj (QuadricTexture -> GLboolean
marshalQuadricTexture QuadricTexture
t)
forall (m :: * -> *). MonadIO m => QuadricObj -> GLenum -> m ()
gluQuadricOrientation QuadricObj
quadricObj (QuadricOrientation -> GLenum
marshalQuadricOrientation QuadricOrientation
o)
forall (m :: * -> *). MonadIO m => QuadricObj -> GLenum -> m ()
gluQuadricDrawStyle QuadricObj
quadricObj (QuadricDrawStyle -> GLenum
marshalQuadricDrawStyle QuadricDrawStyle
d)
renderPrimitive :: QuadricObj -> QuadricPrimitive -> IO ()
renderPrimitive :: QuadricObj -> QuadricPrimitive -> IO ()
renderPrimitive QuadricObj
quadricObj (Sphere Radius
r Slices
s Slices
n) =
forall (m :: * -> *).
MonadIO m =>
QuadricObj -> Radius -> Slices -> Slices -> m ()
gluSphere QuadricObj
quadricObj Radius
r Slices
s Slices
n
renderPrimitive QuadricObj
quadricObj (Cylinder Radius
b Radius
t Radius
h Slices
s Slices
n) =
forall (m :: * -> *).
MonadIO m =>
QuadricObj
-> Radius -> Radius -> Radius -> Slices -> Slices -> m ()
gluCylinder QuadricObj
quadricObj Radius
b Radius
t Radius
h Slices
s Slices
n
renderPrimitive QuadricObj
quadricObj (Disk Radius
i Radius
o Slices
s Slices
l) =
forall (m :: * -> *).
MonadIO m =>
QuadricObj -> Radius -> Radius -> Slices -> Slices -> m ()
gluDisk QuadricObj
quadricObj Radius
i Radius
o Slices
s Slices
l
renderPrimitive QuadricObj
quadricObj (PartialDisk Radius
i Radius
o Slices
s Slices
l Radius
a Radius
w) =
forall (m :: * -> *).
MonadIO m =>
QuadricObj
-> Radius -> Radius -> Slices -> Slices -> Radius -> Radius -> m ()
gluPartialDisk QuadricObj
quadricObj Radius
i Radius
o Slices
s Slices
l Radius
a Radius
w
type QuadricObj = Ptr GLUquadric
isNullQuadricObj :: QuadricObj -> Bool
isNullQuadricObj :: QuadricObj -> Bool
isNullQuadricObj = (forall a. Ptr a
nullPtr forall a. Eq a => a -> a -> Bool
==)