{-# OPTIONS_HADDOCK hide #-}
{- | 
This module contains the FunGEn objects procedures
-}
{- 
FunGEN - Functional Game Engine
http://www.cin.ufpe.br/~haskell/fungen
Copyright (C) 2002  Andre Furtado <awbf@cin.ufpe.br>

This code is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

-}

module Graphics.UI.Fungen.Objects (
  ObjectManager,
  GameObject,
  ObjectPicture(..), Primitive(..),
  FillMode (..),
  -- ** creating
  object,
  -- ** object attributes
  getGameObjectId, getGameObjectName, getGameObjectManagerName, getGameObjectAsleep,
  getGameObjectPosition, getGameObjectSize, getGameObjectSpeed, getGameObjectAttribute,
  -- ** updating
  updateObject, updateObjectAsleep, updateObjectSize, updateObjectPosition,
  updateObjectSpeed, updateObjectAttribute, updateObjectPicture,
  -- ** drawing
  drawGameObjects, drawGameObject,
  -- ** moving
  moveGameObjects,
  -- ** destroying
  destroyGameObject,
  -- ** groups of objects
  objectGroup, addObjectsToManager,
  getObjectManagerName, getObjectManagerCounter , getObjectManagerObjects,
  -- ** searching
  findObjectFromId, searchObjectManager, searchGameObject,
) where

import Graphics.UI.Fungen.Types
import Graphics.UI.Fungen.Util
import Graphics.Rendering.OpenGL hiding (Primitive)

data GameObject t = GO {
    objId          :: Integer,
    objName        :: String,
    objManagerName :: String,
    objPicture     :: GameObjectPicture,
    objAsleep      :: Bool,
    objSize        :: Point2D,
    objPosition    :: Point2D,
    objSpeed       :: Point2D,
    objAttribute   :: t
    }

data ObjectManager t = OM {
    mngName    :: String,               -- name of the manager
    mngCounter :: Integer,              -- next current avaible index for a new object
    mngObjects :: [(GameObject t)]      -- the SET of objects
    }

data GamePrimitive
    = P [Vertex3 GLdouble] (Color4 GLfloat) FillMode
    | C GLdouble (Color4 GLfloat) FillMode

data GameObjectPicture
    = Tx Int
    | B GamePrimitive
--  | A [TextureObject] Int -- miliseconds between frames

data Primitive
    = Polyg [Point2D] GLfloat GLfloat GLfloat FillMode -- the points (must be in CCW order!), color, fill mode
    | Circle GLdouble GLfloat GLfloat GLfloat FillMode -- color, radius, fill mode
    
data ObjectPicture
    = Tex (GLdouble,GLdouble) Int -- size, current texture
    | Basic Primitive
--  | Animation [(FilePath,InvList)] Int -- (path to file, invisible colors), miliseconds between frames

data FillMode
    = Filled
    | Unfilled
    deriving Eq

-------------------------------------------
-- get & updating routines for GameObjects
-------------------------------------------
getGameObjectId :: GameObject t -> Integer
getGameObjectId = objId

getGameObjectName :: GameObject t -> String
getGameObjectName = objName

getGameObjectManagerName :: GameObject t -> String
getGameObjectManagerName = objManagerName

-- internal use only!
getGameObjectPicture :: GameObject t -> GameObjectPicture
getGameObjectPicture = objPicture

getGameObjectAsleep :: GameObject t -> Bool
getGameObjectAsleep = objAsleep

getGameObjectSize :: GameObject t -> (GLdouble,GLdouble)
getGameObjectSize o = (realToFrac sX,realToFrac sY)
                      where (sX,sY) = objSize o

getGameObjectPosition :: GameObject t -> (GLdouble,GLdouble)
getGameObjectPosition o = (realToFrac pX,realToFrac pY)
                          where (pX,pY) = objPosition o

getGameObjectSpeed :: GameObject t -> (GLdouble,GLdouble)
getGameObjectSpeed o = (realToFrac sX,realToFrac sY)
                       where (sX,sY) = objSpeed o

getGameObjectAttribute :: GameObject t -> t
getGameObjectAttribute = objAttribute

updateObjectPicture :: Int -> Int -> GameObject t -> GameObject t
updateObjectPicture newIndex maxIndex obj =
    case (getGameObjectPicture obj) of
        Tx _ -> if (newIndex <= maxIndex)
                        then (obj {objPicture = Tx newIndex})
                        else (error ("Objects.updateObjectPicture error: picture index out of range for object " ++
                              (getGameObjectName obj) ++ " of group " ++ (getGameObjectManagerName obj)))
        _ -> error ("Objects.updateObjectPicture error: object " ++ (getGameObjectName obj) ++
                     " of group " ++ (getGameObjectManagerName obj) ++ " is not a textured object!")

updateObjectAsleep :: Bool -> GameObject t -> GameObject t
updateObjectAsleep asleep o = o {objAsleep = asleep}

updateObjectSize :: (GLdouble,GLdouble) -> GameObject t -> GameObject t
updateObjectSize (sX,sY) o = o {objSize = (realToFrac sX, realToFrac sY)}

updateObjectPosition :: (GLdouble,GLdouble) -> GameObject t -> GameObject t
updateObjectPosition (pX,pY) o = o {objPosition = (realToFrac pX, realToFrac pY)}

updateObjectSpeed :: (GLdouble,GLdouble) -> GameObject t -> GameObject t
updateObjectSpeed (sX,sY) o = o {objSpeed = (realToFrac sX, realToFrac sY)}

updateObjectAttribute :: t -> GameObject t -> GameObject t
updateObjectAttribute oAttrib o = o {objAttribute = oAttrib}

----------------------------------------------
-- get & updating routines for ObjectManagers
----------------------------------------------
getObjectManagerName :: ObjectManager t -> String
getObjectManagerName = mngName

getObjectManagerCounter :: ObjectManager t -> Integer
getObjectManagerCounter = mngCounter

getObjectManagerObjects :: ObjectManager t -> [(GameObject t)]
getObjectManagerObjects = mngObjects

updateObjectManagerObjects :: [(GameObject t)] -> ObjectManager t -> ObjectManager t
updateObjectManagerObjects objs mng = mng {mngObjects = objs}

----------------------------------------
-- initialization of GameObjects
----------------------------------------
object :: String -> ObjectPicture -> Bool -> (GLdouble,GLdouble) -> (GLdouble,GLdouble) -> t -> GameObject t
object name pic asleep pos speed oAttrib = let (picture, size) = createPicture pic in
                        GO {
                        objId          = 0,
                        objName        = name,
                        objManagerName = "object not grouped yet!",
                        objPicture     = picture,
                        objAsleep      = asleep,
                        objSize        = size,
                        objPosition    = pos,
                        objSpeed       = speed,
                        objAttribute   = oAttrib
                        }

createPicture :: ObjectPicture -> (GameObjectPicture,Point2D)
createPicture (Basic (Polyg points r g b fillMode))  = (B (P (point2DtoVertex3 points) (Color4 r g b 1.0) fillMode),findSize points)
createPicture (Basic (Circle radius r g b fillMode)) = (B (C radius (Color4 r g b 1.0) fillMode),(2 * radius,2 * radius))
createPicture (Tex size picIndex) = (Tx picIndex,size)

-- given a point list, finds the height and width
findSize :: [Point2D] -> Point2D
findSize l = ((x2 - x1),(y2 - y1))
    where (xList,yList) = unzip l
          (x2,y2) = (maximum xList,maximum yList)
          (x1,y1) = (minimum xList,minimum yList)

----------------------------------------------
-- grouping GameObjects and creating managers
----------------------------------------------
objectGroup :: String -> [(GameObject t)] -> (ObjectManager t)
objectGroup name objs = OM {mngName = name, mngCounter = toEnum (length objs), mngObjects = objectGroupAux objs name 0}

objectGroupAux :: [(GameObject t)] -> String -> Integer -> [(GameObject t)]
objectGroupAux [] _ _ = []
objectGroupAux (o:os) managerName oId = (o {objId = oId, objManagerName = managerName}):(objectGroupAux os managerName (oId + 1))

addObjectsToManager :: [(GameObject t)] -> String -> [(ObjectManager t)] -> [(ObjectManager t)]
addObjectsToManager _ managerName [] = error ("Objects.addObjectsToManager error: object manager " ++ managerName ++ " does not exists!")
addObjectsToManager objs managerName (m:ms) | (getObjectManagerName m == managerName) = (addObjectsToManagerAux objs m):ms
                                            | otherwise = m:(addObjectsToManager objs managerName ms)


addObjectsToManagerAux :: [(GameObject t)] -> ObjectManager t -> ObjectManager t
addObjectsToManagerAux objs mng = let counter = getObjectManagerCounter mng
                                      newObjects = adjustNewObjects objs (getObjectManagerCounter mng) (getObjectManagerName mng)
                                  in mng {mngObjects = newObjects ++ (getObjectManagerObjects mng), mngCounter = counter + (toEnum (length objs))}

adjustNewObjects :: [(GameObject t)] -> Integer -> String -> [(GameObject t)]
adjustNewObjects [] _ _ = []
adjustNewObjects (o:os) oId managerName = (o {objId = oId, objManagerName = managerName}):(adjustNewObjects os (oId + 1) managerName)

------------------------------------------
-- draw routines
------------------------------------------
drawGameObjects :: [(ObjectManager t)] -> QuadricPrimitive -> [TextureObject] -> IO ()
drawGameObjects [] _ _ = return ()
drawGameObjects (m:ms) qobj picList = drawGameObjectList (getObjectManagerObjects m) qobj picList >> drawGameObjects ms qobj picList

drawGameObjectList :: [(GameObject t)] -> QuadricPrimitive -> [TextureObject] -> IO ()
drawGameObjectList [] _ _ = return ()
drawGameObjectList (o:os) qobj picList | (getGameObjectAsleep o) = drawGameObjectList os qobj picList
                                       | otherwise = drawGameObject o qobj picList >> drawGameObjectList os qobj picList

drawGameObject :: GameObject t -> QuadricPrimitive -> [TextureObject] -> IO ()
drawGameObject o _qobj picList = do
    loadIdentity
    let (pX,pY) = getGameObjectPosition o
        picture = getGameObjectPicture o
    translate (Vector3 pX pY (0 :: GLdouble) )
    case picture of
        (B (P points c fillMode)) -> do
                    color c
                    if (fillMode == Filled)
                        then (renderPrimitive Polygon  $ mapM_ vertex points)
                        else (renderPrimitive LineLoop $ mapM_ vertex points) 

        (B (C r c fillMode)) -> do
                    color c
                    renderQuadric style $ Disk 0 r 20 3
                 where style = QuadricStyle Nothing NoTextureCoordinates Outside fillStyle
                       fillStyle = if (fillMode == Filled) then FillStyle else SilhouetteStyle

        (Tx picIndex) -> do
                        texture Texture2D $= Enabled
                        bindTexture Texture2D (picList !! picIndex)
                        color (Color4 1.0 1.0 1.0 (1.0 :: GLfloat))
                        renderPrimitive Quads $ do
                            texCoord2 0.0 0.0;  vertex3 (-x) (-y) 0.0
                            texCoord2 1.0 0.0;  vertex3   x  (-y) 0.0
                            texCoord2 1.0 1.0;  vertex3   x    y  0.0
                            texCoord2 0.0 1.0;  vertex3 (-x)   y  0.0
                        texture Texture2D $= Disabled
                   where (sX,sY) = getGameObjectSize o
                         x = sX/2
                         y = sY/2
            
------------------------------------------
-- search routines
------------------------------------------

findObjectFromId :: GameObject t -> [(ObjectManager t)] -> GameObject t
findObjectFromId o mngs = findObjectFromIdAux (getGameObjectId o) (getGameObjectManagerName o) mngs

findObjectFromIdAux :: Integer -> String ->  [(ObjectManager t)] -> GameObject t
findObjectFromIdAux _ managerName [] = error ("Objects.findObjectFromIdAux error: object group " ++ managerName ++ " not found!")
findObjectFromIdAux objectId managerName (m:ms) | (managerName == getObjectManagerName m) = searchFromId objectId (getObjectManagerObjects m)
                                                | otherwise = findObjectFromIdAux objectId managerName ms

searchFromId :: Integer -> [(GameObject t)] -> GameObject t
searchFromId _ [] = error ("Objects.searchFromId error: object not found!")
searchFromId objectId (o:os) | (objectId == getGameObjectId o) = o
                             | otherwise = searchFromId objectId os


searchObjectManager :: String -> [(ObjectManager t)] -> ObjectManager t
searchObjectManager managerName [] = error ("Objects.searchObjectManager error: object group " ++ managerName ++ " not found!")
searchObjectManager managerName (m:ms) | (getObjectManagerName m == managerName) = m
                                       | otherwise = searchObjectManager managerName ms

searchGameObject :: String -> ObjectManager t -> GameObject t
searchGameObject objectName m = searchGameObjectAux objectName (getObjectManagerObjects m)

searchGameObjectAux :: String -> [(GameObject t)] -> GameObject t
searchGameObjectAux objectName [] = error ("Objects.searchGameObjectAux error: object " ++ objectName ++ " not found!")
searchGameObjectAux objectName (a:as) | (getGameObjectName a == objectName) = a
                                      | otherwise = searchGameObjectAux objectName as

------------------------------------------
-- update routines
------------------------------------------

-- substitutes an old object by a new one, given the function to be applied to the old object (whose id is given),
-- the name of its manager and the group of game managers.
updateObject :: (GameObject t -> GameObject t) -> Integer -> String -> [(ObjectManager t)] -> [(ObjectManager t)]
updateObject _ _ managerName [] = error ("Objects.updateObject error: object manager: " ++ managerName ++ " not found!")
updateObject f objectId managerName (m:ms) | (getObjectManagerName m == managerName) = (updateObjectManagerObjects newObjects m):ms
                                           | otherwise = m:(updateObject f objectId managerName ms)
                                           where newObjects = updateObjectAux f objectId (getObjectManagerObjects m)

updateObjectAux :: (GameObject t -> GameObject t) -> Integer -> [(GameObject t)] -> [(GameObject t)]
updateObjectAux _ _ [] = error ("Objects.updateObjectAux error: object not found!")
updateObjectAux f objectId (o:os) | (getGameObjectId o == objectId) = (f o):os
                                  | otherwise = o:(updateObjectAux f objectId os)

------------------------------------------
-- moving routines
------------------------------------------

-- modifies all objects position according to their speed
moveGameObjects :: [(ObjectManager t)] -> [(ObjectManager t)]
moveGameObjects [] = []
moveGameObjects (m:ms) = (updateObjectManagerObjects (map moveSingleObject (getObjectManagerObjects m)) m):(moveGameObjects ms)

moveSingleObject :: GameObject t -> GameObject t
moveSingleObject o = if (getGameObjectAsleep o)
                        then o
                        else let (vX,vY) = getGameObjectSpeed o
                                 (pX,pY) = getGameObjectPosition o
                             in updateObjectPosition (pX + vX, pY + vY) o

------------------------------------------
-- destroy routines
------------------------------------------

destroyGameObject :: String -> String -> [(ObjectManager t)] -> [(ObjectManager t)]
destroyGameObject _ managerName [] = error ("Objects.destroyGameObject error: object manager: " ++ managerName ++ " not found!")
destroyGameObject objectName managerName (m:ms) | (getObjectManagerName m == managerName) = (updateObjectManagerObjects newObjects m):ms
                     | otherwise = m:(destroyGameObject objectName managerName ms)
                       where newObjects = destroyGameObjectAux objectName (getObjectManagerObjects m)

destroyGameObjectAux :: String -> [(GameObject t)] -> [(GameObject t)]
destroyGameObjectAux objectName [] = error ("Objects.destroyGameObjectAux error: object: " ++ objectName ++ " not found!") 
destroyGameObjectAux objectName (o:os) | (getGameObjectName o == objectName) = os
                    | otherwise = o:(destroyGameObjectAux objectName os)
