-- This source file is part of HGamer3D
-- (A project to enable 3D game development in Haskell)
-- For the latest info, see http://www.althainz.de/HGamer3D.html
--
-- Copyright 2011 Dr. Peter Althainz
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- One.hs

-- |This module is the first attempt, to provide an abstracted interface
-- to the HGamer3D API Bindings. It is named 'One' on purpose, since it is
-- assumed, that there will be additional APIs in the future, which then 
-- might be named 'APIs.Two', 'APIs.Three' and so on. Also note the plural
-- in 'APIs'!
--
-- It should be possible, to write 3D applications, by using the API of 
-- this module alone. Anyhow, to enable a mixture also with the code
-- of the underlying bindings, the constructors of the data types are made
-- public.
module HGamer3D.APIs.One

(
	-- Data types
	-------------
	
	ColourValue (ColourValue),
	Quaternion (Quaternion),
	Vector3 (Vector3),
	Radian (Radian),
	Degree (Degree),


	-- Data types - basic systems
	
	InputSystem (InputSystem, isOisbSystem, isOisbSchema),
	ViewSystem (ViewSystem, vsCamera, vsRenderWindow, vsViewport),
	EngineSystem (EngineSystem, esRoot, esSceneManager, esResourceGroupManager, esTextureManager, esControllerManager),
	
	
	-- Data types - internal objects
	-- The consctructores are provided, in case, extension on the base
	-- of the pure wrapping is used
	
	Light (Light),
	MeshTemplate (MeshSphere, MeshCube, MeshPlane, MeshResource, MeshManual),
	Mesh (Mesh),
	Node (Node),
	Time (Time),
	Animation (Animation),
	GraphicsObject (MeshObject, LightObject, CombinedObject),
	
	-- Enums
	--------
	
	module HGamer3D.Bindings.Ogre.EnumTransformSpace,
	
	-- Functions
	------------
	
	-- Initialize
	initializeHG3D,	
	
	-- Camera
	setCameraPos,
	setCameraLookAt,
	
	-- Light Creation
	createAmbientLight,
	createLight,
	
	-- Graphics Object Creation
	meshTemplateFromManual,
	createMesh,
	createLine,
	createCube,


	-- Graphics Object Functions
	scale,
	translate,
	roll,
	pitch,
	yaw,
	rotate,
	
	getPosition,
	setPosition,
	getOrientation,
	setOrientation,
	getScale,
	setScale,
	combineGraphicsObjects,
	
	-- Animation Functions
	getAnimation,
	startAnimation,
	stopAnimation,
	setAnimationTime,
	
	-- Time Functions
	getTime,
	
	-- Event Functions
	Action (Action),
	createTriggerAction,
	bindKey,
	isActionActive,
	createAnalogAxisAction,
	bindMouseAxis,
	bindJoystickAxis,
	bindMouseButton,
	bindJoystickButton,
	getActionAbsoluteValue,
	getActionRelativeValue,

	isMouseAvailable,
	isJoystickAvailable,
	getAvailableAxisMouse,
	getAvailableButtonsMouse,
	getAvailableAxisJoystick,
	getAvailableButtonsJoystick,
	
	-- run it
	renderLoop,
	
)

where

import GHC.Ptr

import HGamer3D.Bindings.Ogre.ClassPtr
import HGamer3D.Bindings.OIS.ClassPtr

import HGamer3D.Bindings.Ogre.Utils

import HGamer3D.Data.ColourValue
import HGamer3D.Data.Quaternion
import HGamer3D.Data.Vector3
import HGamer3D.Data.Radian
import HGamer3D.Data.Degree

import HGamer3D.Bindings.Ogre.TypeColourValue
import HGamer3D.Bindings.Ogre.TypeQuaternion
import HGamer3D.Bindings.Ogre.TypeVector3
import HGamer3D.Bindings.Ogre.TypeSharedPtr

import HGamer3D.Bindings.Ogre.EnumSceneType
import HGamer3D.Bindings.Ogre.EnumTransformSpace

import HGamer3D.Bindings.Ogre.ClassCamera
import HGamer3D.Bindings.Ogre.ClassRoot
import HGamer3D.Bindings.Ogre.ClassLight
import HGamer3D.Bindings.Ogre.ClassNode
import HGamer3D.Bindings.Ogre.ClassSceneManager
import HGamer3D.Bindings.Ogre.ClassSceneNode
import HGamer3D.Bindings.Ogre.ClassRenderTarget
import HGamer3D.Bindings.Ogre.ClassRenderWindow
import HGamer3D.Bindings.Ogre.ClassResourceGroupManager
import HGamer3D.Bindings.Ogre.ClassTextureManager
import HGamer3D.Bindings.Ogre.ClassControllerManager
import HGamer3D.Bindings.Ogre.ClassViewport
import HGamer3D.Bindings.Ogre.ClassFrustum
import HGamer3D.Bindings.Ogre.ClassAnimationState
import HGamer3D.Bindings.Ogre.ClassEntity
import HGamer3D.Bindings.Ogre.ClassControllerManager

import HGamer3D.Bindings.Ogre.ClassManualObject
import HGamer3D.Bindings.Ogre.EnumOperationType
import HGamer3D.Bindings.Ogre.TypeHG3DClass
import HGamer3D.Bindings.Ogre.EnumPrefabType

import HGamer3D.Bindings.OIS.Utils
import HGamer3D.Bindings.OIS.ClassSystem
import HGamer3D.Bindings.OIS.ClassAction
import HGamer3D.Bindings.OIS.ClassActionSchema
import HGamer3D.Bindings.OIS.ClassAnalogAxisAction
import HGamer3D.Bindings.OIS.EnumActionType
import HGamer3D.Bindings.OIS.ClassDevice


import HGamer3D.Bindings.OIS.TypeHG3DClass

import HGamer3D.Data.Vector3
import HGamer3D.Data.Quaternion
import HGamer3D.Data.HG3DClass


---
-- data declarations for basic API
---


-- |The encapsulation of the state of input devices, like keyboard, mouse, ...
data InputSystem = InputSystem {
	isOisbSystem::HG3DClass,
	isOisbSchema::HG3DClass
} deriving (Show, Eq)

-- |The encapsulation of the state of the view, camera, window and viewport
data ViewSystem = ViewSystem {
	vsCamera::HG3DClass,
	vsRenderWindow::HG3DClass,
	vsViewport::HG3DClass
} deriving (Show, Eq)

-- |The encapsulation of the state of the graphics engine
data EngineSystem = EngineSystem {
	esRoot::HG3DClass,
	esSceneManager::HG3DClass,
	esResourceGroupManager::HG3DClass,
	esTextureManager::HG3DClass,
	esControllerManager::HG3DClass 
} deriving (Show, Eq)


	
-- | The time as abstracted type, to recognize it in the api
data Time = Time Float

-- | An Animation, the encapsulation of simple types has the usual reason, to
-- get a better type checking in the API
data Animation = Animation HG3DClass


-- common 3D objects, internal data objects (to get typesafety, later to be done with typed pointers)

-- | Encapsulation of a Light Object, has a name and an ogre object
data Light = Light String HG3DClass

-- | MeshTemplate, a new template from with Meshes are created
data MeshTemplate = MeshSphere | MeshCube | MeshPlane | MeshResource String | MeshManual String SharedPtr

-- | a displayed Mesh, in Ogre, this is an Entity
data Mesh = Mesh HG3DClass


-- | A Node gives position, rotation and connection to other nodes and child parent relationships
-- this is a Ogre abstration, which is used in the One API, to generate the 'GraphicsObject' below
data Node = Node HG3DClass

-- helper not exported
getNewNode :: EngineSystem -> IO (Node)
getNewNode es = do
	rootNode <- cSmGetRootSceneNode (esSceneManager es)
	let vzero = Vector3 0.0 0.0 0.0
	let qident = Quaternion 1.0 0.0 0.0 0.0
	node <- cSnCreateChildSceneNode rootNode vzero qident
	return (Node node)

-- | The graphics object
data GraphicsObject = MeshObject Mesh Node | LightObject Light | CombinedObject Node

getNodeFromGo :: GraphicsObject -> HG3DClass
getNodeFromGo (MeshObject _ (Node node)) = node
getNodeFromGo (CombinedObject (Node node)) = node

meshTemplateFromManual :: EngineSystem -> String -> HG3DClass -> IO (MeshTemplate)
meshTemplateFromManual es name object = do
	mesh <- cMnoConvertToMesh object name "General"
	let mt = MeshManual name mesh
	return (mt)

goFromMesh :: EngineSystem -> HG3DClass -> IO (GraphicsObject)
goFromMesh es entity = do
	(Node node) <- getNewNode es
	cSnAttachObject node entity
	return (MeshObject (Mesh entity) (Node node))


-- | Create one mesh, which can be placed into a scene
createMesh :: EngineSystem -> MeshTemplate -> IO (GraphicsObject)

createMesh es MeshSphere = do
	entity <- cSmCreateEntity4 (esSceneManager es) PtSphere
	go <- goFromMesh es entity
	return (go)

createMesh es MeshCube = do
	entity <- cSmCreateEntity4 (esSceneManager es) PtCube
	go <- goFromMesh es entity
	return (go)

createMesh es MeshPlane = do
	entity <- cSmCreateEntity4 (esSceneManager es) PtPlane
	go <- goFromMesh es entity
	return (go)

createMesh es (MeshResource name) = do
	entity <- cSmCreateEntity2 (esSceneManager es) name
	go <- goFromMesh es entity
	return (go)
	
createMesh es (MeshManual name mesh) = do
	entity <- cSmCreateEntity2 (esSceneManager es) name
	go <- goFromMesh es entity
	return (go)
	
 

-- basic initialize function

-- | With this function, the graphics system is being initialized. The return 
-- value consists of the three state types, which carry the state for 
-- the graphics engine, the input system and the view
initializeHG3D :: String -- ^Name of the window, displayed
			-> String  -- ^SceneManager type used
			-> IO (EngineSystem, ViewSystem, InputSystem)
initializeHG3D windowName sceneManagerType = do

		root <- cRNew
		cRShowConfigDialog root
		fUAddResourceLocations "resources.cfg"
		renderWindow <-cRInitialise root True windowName ""
		
		fUInitializeOis renderWindow
		oisbSystem <- cSyGetSingletonPtr
		oisbSchema <- cSyGetDefaultActionSchemaAutoCreate oisbSystem
		
		
		sceneManager <- cRCreateSceneManager root sceneManagerType "SceneManager"
		
		camera <- cSmCreateCamera sceneManager "SimpleCamera"
		cFSetNearClipDistance camera 5.0
		cFSetFarClipDistance camera 5000.0
		
	
		viewport <- cRtAddViewport renderWindow camera 0 0.0 0.0 1.0 1.0
		let bgColor = ColourValue 0.0 0.0 0.0 1.0
		cVpSetBackgroundColour viewport bgColor
		
		height <- cVpGetActualHeight viewport
		width <- cVpGetActualWidth viewport
		
		cFSetAspectRatio camera ((fromIntegral width) / (fromIntegral height))
		
		tm <- cTmGetSingletonPtr
		cTmSetDefaultNumMipmaps tm 20
		
		rgm <- cRgmGetSingletonPtr
		cRgmInitialiseAllResourceGroups rgm
		
		cm <- cCmNew

		return (
			EngineSystem root sceneManager rgm tm cm,
			ViewSystem  camera renderWindow viewport,
			InputSystem oisbSystem oisbSchema
			)


-- camera functions

-- |Postions the camera
setCameraPos :: ViewSystem -> Vector3 -> IO ()
setCameraPos vs pos = do
	cCSetPosition2 (vsCamera vs)  pos

-- |Sets the camera view direction
setCameraLookAt :: ViewSystem -> Vector3 -> IO ()
setCameraLookAt vs vec3 = do
	cCLookAt (vsCamera vs) vec3


-- light functions

-- | creates a light, which fills all the room with similar strength
createAmbientLight :: EngineSystem -> ColourValue -> IO () 
createAmbientLight es colour = do
	cSmSetAmbientLight (esSceneManager es) colour
	return ()
	
-- | creates a point light at a specific location
createLight :: EngineSystem -> String -- ^Name of the light
		-> ColourValue -- ^Color of the light
		-> Vector3 -- ^Position, where light is created
		-> IO (GraphicsObject) -- ^Return value is a graphics object
createLight es lightName colour (Vector3 x y z) = do
	cSmSetAmbientLight (esSceneManager es) colour
	light <- cSmCreateLight (esSceneManager es) lightName
	cLSetPosition light x y z
	return (LightObject (Light lightName light))
	


-- use "BaseWhiteNoLighting" Material

-- |Creates a line by using the ManualObject functionality of Ogre
createLine :: EngineSystem -- ^The engine system
		-> String -- ^The name of the line object
		-> String -- ^The material used for the line
		-> ColourValue -- ^The color of the line
		-> Vector3 -- ^The start point of the line
		-> Vector3 -- ^The end point of the line
		-> IO (MeshTemplate) -- ^Return value is a graphics object
createLine es lineName materialName colour vStart vEnd = do
	mo <- cSmCreateManualObject (esSceneManager es) lineName
	cMnoBegin mo materialName OtLineList "General"
	cMnoPosition mo vStart
	cMnoColour mo colour
	cMnoPosition mo vEnd
	cMnoColour mo colour
	cMnoEnd mo

	go <- meshTemplateFromManual es lineName mo 
	return (go)

-- |Creates a cube by using the ManualObject functionality of Ogre
createCube :: EngineSystem -- ^The engine system 
		-> String -- ^The name of the cube object 
		-> String -- ^The material used for the cube 
		-> ColourValue -- ^The color of the line 
		-> IO (MeshTemplate) -- ^Return value is a graphics object
createCube es cubeName materialName colour = do
	mo <- cSmCreateManualObject (esSceneManager es) cubeName
	-- set Dynamic to false
	cMnoSetDynamic mo False
	
	-- basic parameters
	let lsize = 1.0
	let cp = 1.0 * lsize
	let cm = -1.0 * lsize
	
	cMnoBegin mo materialName OtTriangleList "General"
	
	cMnoPosition2 mo cm cp cm   -- a vertex
	cMnoColour mo colour
	cMnoPosition2 mo cp cp cm   -- a vertex
	cMnoColour mo colour
	cMnoPosition2 mo cp cm cm   -- a vertex
	cMnoColour mo colour
	cMnoPosition2 mo cm cm cm   -- a vertex
	cMnoColour mo colour
	
	cMnoPosition2 mo cm cp cp   -- a vertex
	cMnoColour mo colour
	cMnoPosition2 mo cp cp cp   -- a vertex
	cMnoColour mo colour
	cMnoPosition2 mo cp cm cp   -- a vertex
	cMnoColour mo colour
	cMnoPosition2 mo cm cm cp   -- a vertex
	cMnoColour mo colour
	
	cMnoTriangle mo 0 1 2
	cMnoTriangle mo 2 3 0
	cMnoTriangle mo 4 6 5
	cMnoTriangle mo 6 4 7
	
	cMnoTriangle mo 0 4 5 
	cMnoTriangle mo 5 1 0
	cMnoTriangle mo 2 6 7
	cMnoTriangle mo 7 3 2

	cMnoTriangle mo 0 7 4
	cMnoTriangle mo 7 0 3
	cMnoTriangle mo 1 5 6
	cMnoTriangle mo 6 2 1
	
	cMnoEnd mo
	
	go <- meshTemplateFromManual es cubeName mo 
	return (go)


-- |This function groups objects into a new object
-- it is not perfoming any geometric operations, it just groups the 
-- input objects. Can be used, to move and rotate a group.
combineGraphicsObjects :: EngineSystem -- ^The engine system
		-> [GraphicsObject] -- ^A list of objects, to be grouped
		-> IO (GraphicsObject) -- ^The return value is a new GraphicsObject
combineGraphicsObjects es listObjects = do

	(Node node) <- getNewNode es
	sequence_ (map ( \object -> do
						let objectnode = getNodeFromGo object
						parent <- cNGetParent objectnode
						-- currently no check here, if parent exists!
						-- no parent is only valid for root node and this is not accessible to the
						-- user of this api (should not be used, at least)
						cNRemoveChild2 parent objectnode
						cNAddChild node objectnode
						return ()
						)
								listObjects)
	return ( CombinedObject (Node node) )
	

--
-- GraphicsObject functions
--

--	scale

-- |Scales a GraphicsObject by multiplying a scale to the existing one
scale :: GraphicsObject -> Vector3 -> IO ()
scale go sc  = do
	cNScale (getNodeFromGo go) sc
	return () 

--	| Translate a GraphicsObject from its current position
translate :: GraphicsObject -> Vector3 -> EnumTransformSpace -> IO ()
translate go v ets = do
	cNTranslate (getNodeFromGo go) v ets
	return () 

--	roll
roll :: GraphicsObject -> Radian -> EnumTransformSpace -> IO ()
roll go r ets = do
	cNRoll (getNodeFromGo go) r ets
	return () 

--	pitch
pitch :: GraphicsObject -> Radian -> EnumTransformSpace -> IO ()
pitch go r ets = do
	cNPitch (getNodeFromGo go) r ets
	return () 

--	yaw
yaw :: GraphicsObject -> Radian -> EnumTransformSpace -> IO ()
yaw go r ets = do
	cNYaw (getNodeFromGo go) r ets
	return () 

--	rotate
rotate :: GraphicsObject -> Vector3 -> Radian -> EnumTransformSpace -> IO ()
rotate go v r ets = do
	cNRotate (getNodeFromGo go) v r ets
	return () 

	

getPosition :: GraphicsObject -> IO (Vector3)
getPosition go = do
	pos <- cNGetPosition (getNodeFromGo go)
	return (pos) 

setPosition :: GraphicsObject -> Vector3 -> IO ()
setPosition go pos = do
	cNSetPosition (getNodeFromGo go) pos
	return ()

setLightPos :: Light -> Float -> Float -> Float -> IO ()
setLightPos (Light name light) x y z = do
	cLSetPosition light x y z

getOrientation :: GraphicsObject -> IO (Quaternion)
getOrientation go = do
	quat <- cNGetOrientation (getNodeFromGo go)
	return (quat) 

setOrientation :: GraphicsObject -> Quaternion -> IO ()
setOrientation go quat = do
	cNSetOrientation (getNodeFromGo go) quat
	return ()

getScale :: GraphicsObject -> IO (Vector3)
getScale go = do
	scale <- cNGetScale (getNodeFromGo go)
	return (scale) 

setScale :: GraphicsObject -> Vector3 -> IO ()
setScale go scale = do
	cNSetScale (getNodeFromGo go) scale
	return ()


-- Animation Functions
getAnimation :: GraphicsObject -> String -> IO (Animation)
getAnimation (MeshObject (Mesh mesh) _ ) animName = do
	anim <- cEGetAnimationState mesh animName
	return (Animation anim)
	
startAnimation :: Animation -> IO ()
startAnimation (Animation anim) = do
	cAnsSetEnabled anim True
	cAnsSetLoop anim True

stopAnimation :: Animation -> IO ()
stopAnimation (Animation anim) = do
	cAnsSetEnabled anim False
	cAnsSetLoop anim False

setAnimationTime :: Animation -> Time -> IO ()
setAnimationTime (Animation anim) (Time time) = do
	cAnsSetTimePosition anim time

-- Time Functions
getTime :: EngineSystem -> IO (Time)
getTime es = do
	time <- cCmGetElapsedTime (esControllerManager es)
	return (Time time)


-- event functions, OIS stuff

data Action = Action HG3DClass

runIsFrame :: InputSystem -> Float -> IO ()
runIsFrame is delta = do
	cSyProcess (isOisbSystem is) delta
	return ()

createTriggerAction :: InputSystem -> String -> IO (Action)
createTriggerAction is actionName = do
	let schema = isOisbSchema is
	action <- cAsCreateTriggerAction schema actionName
	return (Action action)
	
createAnalogAxisAction :: InputSystem -> Float -> Float -> String -> IO (Action)
createAnalogAxisAction is minval maxval actionName = do
	let schema = isOisbSchema is
	action <- cAsCreateAnalogAxisAction schema actionName
	cAaaSetMinimumValue action minval
	cAaaSetMaximumValue action maxval
	return (Action action)
	
bindKey :: Action -> String -> IO ()
bindKey (Action action) keyChar = do
	cABind4 action ("Keyboard/" ++ keyChar)
	return ()

isMouseAvailable :: InputSystem -> IO (Bool)
isMouseAvailable is = do
	avail <- cSyHasDevice (isOisbSystem is) "Mouse"
	return (avail)

bindMouseAxis :: Action -> String -> IO ()
bindMouseAxis (Action action) axisName = do
	cABind4 action ("Mouse/" ++ axisName)
	return ()

bindMouseButton :: Action -> String -> IO ()
bindMouseButton (Action action) buttonName = do
	cABind4 action ("Mouse/" ++ buttonName)
	return ()

isJoystickAvailable :: InputSystem -> String -> IO (Bool)
isJoystickAvailable is name = do
	avail <- cSyHasDevice (isOisbSystem is) name
	return (avail)
	
bindJoystickAxis :: Action -> String -> String -> IO ()
bindJoystickAxis (Action action) joystickName axisName = do
	cABind4 action (joystickName ++ "/" ++ axisName)
	return ()

bindJoystickButton :: Action -> String -> String -> IO ()
bindJoystickButton (Action action) joystickName buttonName = do
	cABind4 action (joystickName ++ "/" ++ buttonName)
	return ()

                   
getAvailableAxisMouse :: InputSystem -> IO [String]
getAvailableAxisMouse is = do
	dev <- cSyGetDevice (isOisbSystem is) "Mouse"
	let axes = map (\x -> x ++ " Axis") ["X", "Y", "Z"]
	bools <- mapM (cDHasState dev) axes
	let avail = map fst $ filter snd (zip axes bools)
	return (avail)
	
getAvailableButtonsMouse :: InputSystem -> IO [String]
getAvailableButtonsMouse is = do
	dev <- cSyGetDevice (isOisbSystem is) "Mouse"
	let buttons = (map (\bt -> "Button " ++ (show bt)) [0..50]) ++ (map (\bt -> bt ++ " Button") ["Left", "Middle", "Right"])
	bools <- mapM (cDHasState dev) buttons
	let avail = map fst $ filter snd (zip buttons bools)
	return (avail)
	
getAvailableAxisJoystick :: InputSystem -> String -> IO [String]
getAvailableAxisJoystick is name = do
	dev <- cSyGetDevice (isOisbSystem is) name
	let axes = (map (\x -> "Axis " ++ (show x)) [0..50]) ++  (map (\x -> "Slider " ++ (show x)) [0..50])
	bools <- mapM (cDHasState dev) axes
	let avail = map fst $ filter snd (zip axes bools)
	return (avail)
	
getAvailableButtonsJoystick :: InputSystem -> String -> IO [String]
getAvailableButtonsJoystick is name = do
	dev <- cSyGetDevice (isOisbSystem is) name
	let buttons = (map (\bt -> "Button " ++ (show bt)) [0..50])
	bools <- mapM (cDHasState dev) buttons
	let avail = map fst $ filter snd (zip buttons bools)
	return (avail)
	

isActionActive :: Action -> IO (Bool)
isActionActive (Action action) = do
	flag <- cAIsActive action
	return (flag)
	
getActionAbsoluteValue :: Action -> IO (Float)
getActionAbsoluteValue (Action action) = do
	val <- cAaaGetAbsoluteValue action
	return (val)
	
getActionRelativeValue :: Action -> IO (Float)
getActionRelativeValue (Action action) = do
	val <- cAaaGetRelativeValue action
	return (val)
	
-- renderLoop function

renderLoop :: EngineSystem -> ViewSystem -> InputSystem -> Time -> (EngineSystem -> ViewSystem -> InputSystem -> IO ()) -> IO ()
renderLoop es vs is (Time lastTime) stepFunc = do
	(Time time) <- getTime es
	let delta = time - lastTime
	runIsFrame is delta
	fUMessagePump
	closed <- cRwIsClosed (vsRenderWindow vs)
	if (closed) then
		return ()
		else do
			cRRenderOneFrame (esRoot es)
			stepFunc es vs is
			renderLoop es vs is (Time time) stepFunc