--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.GLUT.Objects
-- Copyright   :  (c) Sven Panne 2002-2018
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- GLUT includes a number of routines for generating easily recognizable 3D
-- geometric objects. These routines reflect functionality available in the
-- @aux@ toolkit described in the /OpenGL Programmer\'s Guide/ and are included
-- in GLUT to allow the construction of simple GLUT programs that render
-- recognizable objects. These routines can be implemented as pure OpenGL
-- rendering routines. The routines do not generate display lists for the
-- objects they create. The routines generate normals appropriate for lighting
-- but do not generate texture coordinates (except for the solid teapot, teacup
-- and teaspoon). If VBOs should be used instead of the fixed function pipeline,
-- specify at least one of the attribute locations
-- 'Graphics.UI.GLUT.State.vertexAttribCoord3' or
-- 'Graphics.UI.GLUT.State.vertexAttribNormal'.
--
--------------------------------------------------------------------------------

module Graphics.UI.GLUT.Objects (
   -- * Rendering flavour
   Flavour(..),

   -- * Object description
   Object(..),

   -- * Type synonyms
   Sides, Rings, NumLevels,

   -- * Rendering
   renderObject
) where

import Control.Monad.IO.Class ( MonadIO(..) )
import Foreign.C.Types ( CInt )
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( Ptr, castPtr )
import Graphics.Rendering.OpenGL (
  Height, Radius, Slices, Stacks, Vertex3(..), GLdouble, GLint )

import Graphics.UI.GLUT.Raw

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

-- | Flavour of object rendering

data Flavour
   = -- | Object is rendered as a solid with shading and surface normals.
     Solid
   | -- | Object is rendered as a wireframe without surface normals.
     Wireframe
   deriving ( Flavour -> Flavour -> Bool
(Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Bool) -> Eq Flavour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flavour -> Flavour -> Bool
$c/= :: Flavour -> Flavour -> Bool
== :: Flavour -> Flavour -> Bool
$c== :: Flavour -> Flavour -> Bool
Eq, Eq Flavour
Eq Flavour
-> (Flavour -> Flavour -> Ordering)
-> (Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Bool)
-> (Flavour -> Flavour -> Flavour)
-> (Flavour -> Flavour -> Flavour)
-> Ord Flavour
Flavour -> Flavour -> Bool
Flavour -> Flavour -> Ordering
Flavour -> Flavour -> Flavour
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 :: Flavour -> Flavour -> Flavour
$cmin :: Flavour -> Flavour -> Flavour
max :: Flavour -> Flavour -> Flavour
$cmax :: Flavour -> Flavour -> Flavour
>= :: Flavour -> Flavour -> Bool
$c>= :: Flavour -> Flavour -> Bool
> :: Flavour -> Flavour -> Bool
$c> :: Flavour -> Flavour -> Bool
<= :: Flavour -> Flavour -> Bool
$c<= :: Flavour -> Flavour -> Bool
< :: Flavour -> Flavour -> Bool
$c< :: Flavour -> Flavour -> Bool
compare :: Flavour -> Flavour -> Ordering
$ccompare :: Flavour -> Flavour -> Ordering
$cp1Ord :: Eq Flavour
Ord, Int -> Flavour -> ShowS
[Flavour] -> ShowS
Flavour -> String
(Int -> Flavour -> ShowS)
-> (Flavour -> String) -> ([Flavour] -> ShowS) -> Show Flavour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flavour] -> ShowS
$cshowList :: [Flavour] -> ShowS
show :: Flavour -> String
$cshow :: Flavour -> String
showsPrec :: Int -> Flavour -> ShowS
$cshowsPrec :: Int -> Flavour -> ShowS
Show )

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

-- | GLUT offers five types of objects:
--
-- *  The five Platonic solids, see
--    <http://mathworld.wolfram.com/PlatonicSolid.html>.
--
-- * A rhombic dodecahedron, see
--   <http://mathworld.wolfram.com/RhombicDodecahedron.html>.
--
-- * Approximations to rounded objects.
--
-- * The classic teaset modeled by Martin Newell in 1975. Both surface normals
--   and texture coordinates for the teaset are generated.
--
-- * A Sierpinski sponge, see
--   <http://mathworld.wolfram.com/Tetrix.html>.

data Object
   = -- | A cube centered at the modeling coordinates origin with sides of the
     --   given length.
     Cube Height
   | -- | A dodecahedron (12-sided regular solid) centered at the modeling
     --   coordinates origin with a radius of @sqrt 3@.
     Dodecahedron
   | -- | A icosahedron (20-sided regular solid) centered at the modeling
     --   coordinates origin with a radius of 1.0.
     Icosahedron
   | -- | Render a solid octahedron (8-sided regular solid) centered at the
     --   modeling coordinates origin with a radius of 1.0.
     Octahedron
   | -- | Render a solid tetrahedron (4-sided regular solid) centered at the
     --   modeling coordinates origin with a radius of @sqrt 3@.
     Tetrahedron
   | -- | (/freeglut only/) A rhombic dodecahedron whose corners are at most a
     -- distance of one from the origin. The rhombic dodecahedron has faces
     -- which are identical rhombi, but which have some vertices at which three
     -- faces meet and some vertices at which four faces meet. The length of
     -- each side is @(sqrt 3)\/2@. Vertices at which four faces meet are found
     -- at @(0, 0, +\/-1)@ and @(+\/-(sqrt 2)\/2, +\/-(sqrt 2)\/2, 0)@.
     RhombicDodecahedron
   | -- | A sphere centered at the modeling coordinates origin of the specified
     --   radius. The sphere is subdivided around the Z axis into slices
     --   (similar to lines of longitude) and along the Z axis into stacks
     --   (similar to lines of latitude).
     Sphere' Radius Slices Stacks
   | -- | A cone oriented along the Z axis. The base of the cone is placed at Z
     --   = 0, and the top at Z = the given height. The cone is subdivided
     --   around the Z axis into slices, and along the Z axis into stacks.
     Cone Radius Height Slices Stacks
   | -- |(/freeglut only/) A cylinder oriented along the Z axis. The base of the
     --  cylinder is placed at Z = 0, and the top at Z = the given height. The
     --  cylinder is subdivided around the Z axis into slices, and along the Z
     -- axis into stacks.
     Cylinder' Radius Height Slices Stacks
   | -- | A torus (doughnut) centered at the modeling coordinates origin
     -- whose axis is aligned with the Z axis. The torus is described by its
     -- inner and outer radius, the number of sides for each radial section,
     -- and the number of radial divisions (rings).
     Torus Radius Radius Sides Rings
   | -- | A teapot with a given relative size.
     Teapot Height
   | -- |(/freeglut only/) A teacup with a given relative size.
     Teacup Height
   | -- |(/freeglut only/) A teaspoon with a given relative size.
     Teaspoon Height
   | -- |(/freeglut only/) A Sierpinski sponge of a given level, where a level
     -- 0 sponge is the same as a 'Tetrahedron'.
     SierpinskiSponge NumLevels
   deriving ( Object -> Object -> Bool
(Object -> Object -> Bool)
-> (Object -> Object -> Bool) -> Eq Object
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Object -> Object -> Bool
$c/= :: Object -> Object -> Bool
== :: Object -> Object -> Bool
$c== :: Object -> Object -> Bool
Eq, Eq Object
Eq Object
-> (Object -> Object -> Ordering)
-> (Object -> Object -> Bool)
-> (Object -> Object -> Bool)
-> (Object -> Object -> Bool)
-> (Object -> Object -> Bool)
-> (Object -> Object -> Object)
-> (Object -> Object -> Object)
-> Ord Object
Object -> Object -> Bool
Object -> Object -> Ordering
Object -> Object -> Object
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 :: Object -> Object -> Object
$cmin :: Object -> Object -> Object
max :: Object -> Object -> Object
$cmax :: Object -> Object -> Object
>= :: Object -> Object -> Bool
$c>= :: Object -> Object -> Bool
> :: Object -> Object -> Bool
$c> :: Object -> Object -> Bool
<= :: Object -> Object -> Bool
$c<= :: Object -> Object -> Bool
< :: Object -> Object -> Bool
$c< :: Object -> Object -> Bool
compare :: Object -> Object -> Ordering
$ccompare :: Object -> Object -> Ordering
$cp1Ord :: Eq Object
Ord, Int -> Object -> ShowS
[Object] -> ShowS
Object -> String
(Int -> Object -> ShowS)
-> (Object -> String) -> ([Object] -> ShowS) -> Show Object
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Object] -> ShowS
$cshowList :: [Object] -> ShowS
show :: Object -> String
$cshow :: Object -> String
showsPrec :: Int -> Object -> ShowS
$cshowsPrec :: Int -> Object -> ShowS
Show )

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

type Sides     = GLint
type Rings     = GLint
type NumLevels = GLint

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

-- | Render an object in the given flavour.

renderObject :: MonadIO m => Flavour -> Object -> m ()
renderObject :: Flavour -> Object -> m ()
renderObject Flavour
Solid     (Cube Height
h)             = Height -> m ()
forall (m :: * -> *). MonadIO m => Height -> m ()
glutSolidCube Height
h
renderObject Flavour
Wireframe (Cube Height
h)             = Height -> m ()
forall (m :: * -> *). MonadIO m => Height -> m ()
glutWireCube  Height
h
renderObject Flavour
Solid     Object
Dodecahedron         = m ()
forall (m :: * -> *). MonadIO m => m ()
glutSolidDodecahedron
renderObject Flavour
Wireframe Object
Dodecahedron         = m ()
forall (m :: * -> *). MonadIO m => m ()
glutWireDodecahedron
renderObject Flavour
Solid     Object
Icosahedron          = m ()
forall (m :: * -> *). MonadIO m => m ()
glutSolidIcosahedron
renderObject Flavour
Wireframe Object
Icosahedron          = m ()
forall (m :: * -> *). MonadIO m => m ()
glutWireIcosahedron
renderObject Flavour
Solid     Object
Octahedron           = m ()
forall (m :: * -> *). MonadIO m => m ()
glutSolidOctahedron
renderObject Flavour
Wireframe Object
Octahedron           = m ()
forall (m :: * -> *). MonadIO m => m ()
glutWireOctahedron
renderObject Flavour
Solid     Object
Tetrahedron          = m ()
forall (m :: * -> *). MonadIO m => m ()
glutSolidTetrahedron
renderObject Flavour
Wireframe Object
Tetrahedron          = m ()
forall (m :: * -> *). MonadIO m => m ()
glutWireTetrahedron
renderObject Flavour
Solid     Object
RhombicDodecahedron  = m ()
forall (m :: * -> *). MonadIO m => m ()
glutSolidRhombicDodecahedron
renderObject Flavour
Wireframe Object
RhombicDodecahedron  = m ()
forall (m :: * -> *). MonadIO m => m ()
glutWireRhombicDodecahedron
renderObject Flavour
Solid     (Sphere' Height
r Slices
s Slices
t)      = Height -> Slices -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
Height -> Slices -> Slices -> m ()
glutSolidSphere Height
r Slices
s Slices
t
renderObject Flavour
Wireframe (Sphere' Height
r Slices
s Slices
t)      = Height -> Slices -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
Height -> Slices -> Slices -> m ()
glutWireSphere  Height
r Slices
s Slices
t
renderObject Flavour
Solid     (Cone Height
r Height
h Slices
s Slices
t)       = Height -> Height -> Slices -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
Height -> Height -> Slices -> Slices -> m ()
glutSolidCone Height
r Height
h Slices
s Slices
t
renderObject Flavour
Wireframe (Cone Height
r Height
h Slices
s Slices
t)       = Height -> Height -> Slices -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
Height -> Height -> Slices -> Slices -> m ()
glutWireCone  Height
r Height
h Slices
s Slices
t
renderObject Flavour
Solid     (Cylinder' Height
r Height
h Slices
s Slices
t)  = Height -> Height -> Slices -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
Height -> Height -> Slices -> Slices -> m ()
glutSolidCylinder Height
r Height
h Slices
s Slices
t
renderObject Flavour
Wireframe (Cylinder' Height
r Height
h Slices
s Slices
t)  = Height -> Height -> Slices -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
Height -> Height -> Slices -> Slices -> m ()
glutWireCylinder Height
r Height
h Slices
s Slices
t
renderObject Flavour
Solid     (Torus Height
i Height
o Slices
s Slices
r)      = Height -> Height -> Slices -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
Height -> Height -> Slices -> Slices -> m ()
glutSolidTorus Height
i Height
o Slices
s Slices
r
renderObject Flavour
Wireframe (Torus Height
i Height
o Slices
s Slices
r)      = Height -> Height -> Slices -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
Height -> Height -> Slices -> Slices -> m ()
glutWireTorus  Height
i Height
o Slices
s Slices
r
renderObject Flavour
Solid     (Teapot Height
h)           = Height -> m ()
forall (m :: * -> *). MonadIO m => Height -> m ()
glutSolidTeapot Height
h
renderObject Flavour
Wireframe (Teapot Height
h)           = Height -> m ()
forall (m :: * -> *). MonadIO m => Height -> m ()
glutWireTeapot  Height
h
renderObject Flavour
Solid     (Teacup Height
h)           = Height -> m ()
forall (m :: * -> *). MonadIO m => Height -> m ()
glutSolidTeacup Height
h
renderObject Flavour
Wireframe (Teacup Height
h)           = Height -> m ()
forall (m :: * -> *). MonadIO m => Height -> m ()
glutWireTeacup  Height
h
renderObject Flavour
Solid     (Teaspoon Height
h)         = Height -> m ()
forall (m :: * -> *). MonadIO m => Height -> m ()
glutSolidTeaspoon Height
h
renderObject Flavour
Wireframe (Teaspoon Height
h)         = Height -> m ()
forall (m :: * -> *). MonadIO m => Height -> m ()
glutWireTeaspoon  Height
h
renderObject Flavour
Solid     (SierpinskiSponge Slices
n) = Slices -> m ()
forall (m :: * -> *). MonadIO m => Slices -> m ()
solidSierpinskiSponge Slices
n
renderObject Flavour
Wireframe (SierpinskiSponge Slices
n) = Slices -> m ()
forall (m :: * -> *). MonadIO m => Slices -> m ()
wireSierpinskiSponge Slices
n

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

solidSierpinskiSponge :: MonadIO m => NumLevels -> m ()
solidSierpinskiSponge :: Slices -> m ()
solidSierpinskiSponge = (CInt -> Ptr Height -> Height -> IO ()) -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
(CInt -> Ptr Height -> Height -> IO ()) -> Slices -> m ()
sierpinskiSponge CInt -> Ptr Height -> Height -> IO ()
forall (m :: * -> *).
MonadIO m =>
CInt -> Ptr Height -> Height -> m ()
glutSolidSierpinskiSponge

wireSierpinskiSponge :: MonadIO m => NumLevels -> m ()
wireSierpinskiSponge :: Slices -> m ()
wireSierpinskiSponge = (CInt -> Ptr Height -> Height -> IO ()) -> Slices -> m ()
forall (m :: * -> *).
MonadIO m =>
(CInt -> Ptr Height -> Height -> IO ()) -> Slices -> m ()
sierpinskiSponge CInt -> Ptr Height -> Height -> IO ()
forall (m :: * -> *).
MonadIO m =>
CInt -> Ptr Height -> Height -> m ()
glutWireSierpinskiSponge

-- for consistency, we hide the offset and scale on the Haskell side
sierpinskiSponge :: MonadIO m => (CInt -> Ptr GLdouble -> Height -> IO ()) -> NumLevels -> m ()
sierpinskiSponge :: (CInt -> Ptr Height -> Height -> IO ()) -> Slices -> m ()
sierpinskiSponge CInt -> Ptr Height -> Height -> IO ()
f Slices
n = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
   Vertex3 Height -> (Ptr (Vertex3 Height) -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (Height -> Height -> Height -> Vertex3 Height
forall a. a -> a -> a -> Vertex3 a
Vertex3 Height
0 Height
0 Height
0) ((Ptr (Vertex3 Height) -> IO ()) -> IO ())
-> (Ptr (Vertex3 Height) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Vertex3 Height)
offsetBuf ->
      CInt -> Ptr Height -> Height -> IO ()
f (Slices -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Slices
n) ((Ptr (Vertex3 Height) -> Ptr Height
forall a b. Ptr a -> Ptr b
castPtr :: Ptr (Vertex3 GLdouble) -> Ptr GLdouble) Ptr (Vertex3 Height)
offsetBuf) Height
1