One.hs

-- 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 provides a simple, generic API into the HGamer3D functionality.

module HGamer3D.APIs.One

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


	-- Data types - basic systems
	
	EngineSystem (EngineSystem, esRoot, esSceneManager, esResourceGroupManager, esTextureManager, esControllerManager),
	ViewSystem (ViewSystem, vsCamera, vsRenderWindow, vsViewport),
	InputSystem (InputSystem, isInputManager, isKeyboard, isMouse),
	
	
	-- Data types - internal objects
	-- The consctructores are provided, in case, extension on the base
	-- of the pure wrapping is used
	
	Light (Light),
	Object (ManualObject, Mesh),
	Node (Node),
	Time (Time),
	Animation (Animation),
	GraphicsObject (GraphicsObject, LightObject, CombinedObject),
	
	-- Enums
	--------
	
	module HGamer3D.Bindings.OIS.EnumKeyCode,
	
	-- Functions
	------------
	
	-- Initialize
	initializeHG3D,	
	
	-- Camera
	setCameraPos,
	setCameraLookAt,
	
	-- Light Creation
	createAmbientLight,
	createLight,
	
	-- Graphics Object Creation
	createLine,
	createCube,
	createMesh,


	-- Graphics Object Functions
	getPosition,
	setPosition,
	getOrientation,
	setOrientation,
	getScale,
	setScale,
	combineGraphicsObjects,
	
	-- helper function
	getGraphicsObject,
	
	-- Animation Functions
	getAnimation,
	startAnimation,
	stopAnimation,
	setAnimationTime,
	
	-- Time Functions
	getTime,
	
	-- Event Functions
	isKeyDown,
	
	-- 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.EnumSceneType

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.OIS.Utils
import HGamer3D.Bindings.OIS.ClassInputManager
import HGamer3D.Bindings.OIS.EnumType
import HGamer3D.Bindings.OIS.EnumKeyCode
import HGamer3D.Bindings.OIS.ClassObject
import HGamer3D.Bindings.OIS.ClassKeyboard

import HGamer3D.Bindings.Ogre.ClassManualObject
import HGamer3D.Bindings.Ogre.EnumOperationType


import HGamer3D.Bindings.Ogre.TypeHG3DClass
import HGamer3D.Bindings.OIS.TypeHG3DClass

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


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


-- Input System
data InputSystem = InputSystem {
	isMouse::HG3DClass,
	isKeyboard::HG3DClass,
	isInputManager::HG3DClass
} deriving (Show, Eq)

-- View System
data ViewSystem = ViewSystem {
	vsCamera::HG3DClass,
	vsRenderWindow::HG3DClass,
	vsViewport::HG3DClass
} deriving (Show, Eq)

-- Engine System
data EngineSystem = EngineSystem {
	esRoot::HG3DClass,
	esSceneManager::HG3DClass,
	esResourceGroupManager::HG3DClass,
	esTextureManager::HG3DClass,
	esControllerManager::HG3DClass 
} deriving (Show, Eq)


-- common 3D objects, internal data objects (to get typesafety, later to be done with typed pointers)
data Light = Light HG3DClass
data Object = ManualObject HG3DClass | Mesh HG3DClass
data Node = Node HG3DClass
data Time = Time Float
data Animation = Animation HG3DClass

-- common 3D Objects
data GraphicsObject = GraphicsObject Object Node | LightObject Light | CombinedObject Node

--


-- basic initialize function
--
initializeHG3D :: String -> String -> IO (EngineSystem, ViewSystem, InputSystem)
initializeHG3D windowName sceneManagerType = do

		root <- cRNew
		cRShowConfigDialog root
		fUAddResourceLocations "resources.cfg"
		renderWindow <-cRInitialise root True windowName ""
		
		(inputManager, keyboard, mouse) <- fUInitializeOis renderWindow
		
		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 mouse keyboard inputManager
			)


-- camera functions

setCameraPos :: ViewSystem -> Vector3 -> IO ()
setCameraPos vs pos = do
	cCSetPosition2 (vsCamera vs)  pos

setCameraLookAt :: ViewSystem -> Vector3 -> IO ()
setCameraLookAt vs vec3 = do
	cCLookAt (vsCamera vs) vec3


-- light functions

createAmbientLight :: EngineSystem -> ColourValue -> IO () 
createAmbientLight es colour = do
	cSmSetAmbientLight (esSceneManager es) colour
	return ()
	
	
createLight :: EngineSystem -> String -> ColourValue -> Vector3 -> IO (GraphicsObject) 
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 light))
	

-- helper functions, not exported

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

getObjectFromGraphicsObject :: GraphicsObject -> HG3DClass
getObjectFromGraphicsObject (GraphicsObject (ManualObject object) (Node node)) = object
getObjectFromGraphicsObject (GraphicsObject (Mesh mesh) (Node node)) = mesh

getNewNode :: EngineSystem -> IO (HG3DClass)
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)

getGraphicsObject :: EngineSystem -> Object -> IO (GraphicsObject)
getGraphicsObject es (ManualObject object) = do
	node <- getNewNode es
	cSnAttachObject node object
	return (GraphicsObject (ManualObject object) (Node node) )
getGraphicsObject es (Mesh mesh) = do
	node <- getNewNode es
	cSnAttachObject node mesh
	return (GraphicsObject (Mesh mesh) (Node node) )


-- use "BaseWhiteNoLighting" Material

createLine :: EngineSystem -> String -> String -> ColourValue -> Vector3 -> Vector3 -> IO (GraphicsObject)
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 <- getGraphicsObject es (ManualObject mo)
	return (go)


createCube :: EngineSystem -> String -> String -> ColourValue -> Vector3 -> IO (GraphicsObject)
createCube es cubeName materialName colour pos = 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 <- getGraphicsObject es (ManualObject mo)
	setPosition go pos
	return (go)


createMesh :: EngineSystem -> String -> String -> IO (GraphicsObject)
createMesh es meshName meshFile = do

	entity <- cSmCreateEntity (esSceneManager es) meshName meshFile "General"
	go <- getGraphicsObject es (Mesh entity)
	return (go)
	

-- combine objects into new one
combineGraphicsObjects :: EngineSystem -> [GraphicsObject] -> IO (GraphicsObject)
combineGraphicsObjects es listObjects = do

	node <- getNewNode es
	sequence_ (map ( \object -> do
						let objectnode = getNodeFromGraphicsObject 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
--

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

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

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

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

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

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

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


-- Animation Functions
getAnimation :: GraphicsObject -> String -> IO (Animation)
getAnimation (GraphicsObject (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

isKeyDown :: InputSystem -> EnumKeyCode -> IO (Bool)
isKeyDown is keycode = do
	isdown <- cOISKIsKeyDown (isKeyboard is) keycode
	return (isdown)



-- renderLoop function

renderLoop :: EngineSystem -> ViewSystem -> InputSystem -> (EngineSystem -> ViewSystem -> InputSystem -> IO ()) -> IO ()
renderLoop es vs is stepFunc = do
	fUMessagePump
	closed <- cRwIsClosed (vsRenderWindow vs)
	if (closed) then
		return ()
		else do
			cRRenderOneFrame (esRoot es)
			cOISOCapture (isKeyboard is)
			stepFunc es vs is
			renderLoop es vs is stepFunc