HGamer3D-Graphics3D-0.5.0: HGamer3D/Graphics3D/SystemGraphics3D.hs
{-# Language StandaloneDeriving #-}
{-# OPTIONS_HADDOCK hide #-}
-- This source file is part of HGamer3D
-- (A project to enable 3D game development in Haskell)
-- For the latest info, see http://www.hgamer3d.org
--
-- (c) 2011-2014 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.
-- | the Graphics3D System of the Entity-Component-System World
module HGamer3D.Graphics3D.SystemGraphics3D
where
import Control.Concurrent.MVar
import qualified Data.Map as M
import Data.Maybe
import Data.Typeable
import Data.Dynamic
import Data.IORef
import Data.List.Split
import HGamer3D.Data
import HGamer3D.Common
import qualified HGamer3D.BaseAPI.Graphics3D as Gr
import HGamer3D.Graphics3D.Graphics3DSchema
import HGamer3D.Graphics3D.GUISchema
data EventReceiver = EventReceiver ERef [Gr.EventType]
data ECSGraphics3D = ECSGraphics3D Gr.Graphics3DSystem Gr.GUISystem (IORef GameTime) (IORef [EventReceiver]) (IORef Bool)
createRecordFig g3ds eref rep e ct = do
if e #? ct then do
l <- componentListener eref ct
ref <- newIORef rep
let uf = case ct of
CTFig -> \ _ e' -> do
r <- readIORef ref
r' <- (Gr.update3D g3ds) r (e' # CTFig)
writeIORef ref r'
return ()
CTOri -> \ _ e' -> do
r <- readIORef ref
orientationTo r (e' # CTOri)
return ()
CTPos -> \ _ e' -> do
r <- readIORef ref
positionTo r (e' # CTPos)
return ()
_ -> \ _ _ -> return ()
let df = return ()
return $ Just (l, uf, df)
else return Nothing
createRecordCam g3ds eref rep e ct = do
if e #? ct then do
l <- componentListener eref ct
ref <- newIORef rep
let uf = case ct of
CTCam -> \ _ e' -> do
r <- readIORef ref
r' <- (Gr.updateCamera g3ds) r (e' # CTCam)
writeIORef ref r'
return ()
CTOri -> \ _ e' -> do
r <- readIORef ref
orientationTo r (e' # CTOri)
return ()
CTPos -> \ _ e' -> do
r <- readIORef ref
positionTo r (e' # CTPos)
return ()
_ -> \ _ _ -> return ()
let df = return ()
return $ Just (l, uf, df)
else return Nothing
createRecordLight g3ds eref rep e ct = do
if e #? ct then do
l <- componentListener eref ct
ref <- newIORef rep
let uf = case ct of
CTLig -> \ _ e' -> do
r <- readIORef ref
r' <- (Gr.updateLight g3ds) r (e' # CTLig)
writeIORef ref r'
return ()
CTOri -> \ _ e' -> do
r <- readIORef ref
orientationTo r (e' # CTOri)
return ()
CTPos -> \ _ e' -> do
r <- readIORef ref
positionTo r (e' # CTPos)
return ()
_ -> \ _ _ -> return ()
let df = return ()
return $ Just (l, uf, df)
else return Nothing
createRecordForm guis eref rep e ct = do
if e #? ct then do
l <- componentListener eref ct
ref <- newIORef rep
let uf = case ct of
CTGFo -> \ _ e' -> do
r <- readIORef ref
r' <- (Gr.updateForm guis) r (e' # CTGFo)
writeIORef ref r'
return ()
CTCmd -> \ _ e' -> do
r <- readIORef ref
case (e' ?# CTCmd) of
Just (Gr.FormSetValue values) -> Gr.setFormValues r values
_ -> return ()
CTEvt -> \ _ e' -> case (e' ?# CTEvt) of
Just evts -> mapM (\evt -> do
case evt of
Gr.GUIEvt (Gr.GUIEvent tag sender window) -> do
r <- readIORef ref
values <- Gr.getFormValues r
if tag `elem` (map fst values) then do
-- check if button
strType <- Gr.typeOfGuiEl window >>= return . last . (splitOn "/")
let newEvt = if strType == "Button"
then Gr.FormEvt (Gr.FormButtonClick tag)
else Gr.FormEvt (Gr.FormValueChange tag values)
sendEvt eref [newEvt]
else return ()
_ -> return () ) evts >> return ()
_ -> return ()
_ -> \ _ _ -> return ()
let df = return ()
return $ Just (l, uf, df)
else return Nothing
createRecordScene g3ds eref e qRef ct = do
if e #? ct then do
l <- componentListener eref ct
let uf = case ct of
CTScP -> \ _ e' -> do
(Gr.setSceneParameter g3ds) (e' # CTScP)
return ()
CTCmd -> \ _ e' -> do
case (e' ?# CTCmd) of
Just Gr.AppQuit -> writeIORef qRef True
_ -> return ()
return ()
_ -> \ _ _ -> return ()
let df = return ()
return $ Just (l, uf, df)
else return Nothing
addEvents eref system types = do
let ECSGraphics3D g3ds guis refT refER _ = system
erList <- readIORef refER
let erList' = ( (EventReceiver eref types) : erList )
writeIORef refER erList'
return ()
instance System ECSGraphics3D where
initializeSystem = do
g3d <- Gr.initHGamer3D "HGamer3D" False True True
let (g3ds, guis, gtime) = g3d
Gr.setAmbientLight g3ds white
lock <- newMVar ()
newERefs <- newIORef []
delERefs <- newIORef []
let records = []
refT <- newIORef gtime
refER <- newIORef []
fRef <- newIORef False
let system = ECSGraphics3D g3ds guis refT refER fRef
let systemFunction system eref = do
let r = []
e <- readE eref -- this e is used to create the representation
-- figures
figs <- if e #? CTFig then do
-- create figure
rep <- Gr.object3D g3ds ((e # CTFig) :: Figure)
if e #? CTPos then positionTo rep (e # CTPos) else return ()
if e #? CTOri then orientationTo rep (e # CTOri) else return ()
newRecords <- Prelude.mapM (createRecordFig g3ds eref rep e) [CTFig, CTOri, CTPos]
return (map fromJust (filter isJust newRecords))
else return []
-- cameras
cams <- if e #? CTCam then do
-- create camera
rep <- Gr.addCamera g3ds ((e # CTCam) :: Camera)
if e #? CTPos then positionTo rep (e # CTPos) else return ()
if e #? CTOri then orientationTo rep (e # CTOri) else return ()
newRecords <- Prelude.mapM (createRecordCam g3ds eref rep e) [CTCam, CTOri, CTPos]
return (map fromJust (filter isJust newRecords))
else return []
-- lights
lights <- if e #? CTLig then do
-- create camera
rep <- Gr.addLight g3ds ((e # CTLig) :: Light)
if e #? CTPos then positionTo rep (e # CTPos) else return ()
if e #? CTOri then orientationTo rep (e # CTOri) else return ()
newRecords <- Prelude.mapM (createRecordLight g3ds eref rep e) [CTLig, CTOri, CTPos]
return (map fromJust (filter isJust newRecords))
else return []
-- guiforms
guiforms <- if e #? CTGFo then do
addEvents eref system [Gr.GUIEvents, Gr.FormEvents]
rep <- Gr.createForm guis ((e # CTGFo) :: Form)
newRecords <- Prelude.mapM (createRecordForm guis eref rep e) [CTGFo, CTOri, CTPos, CTEvt, CTCmd]
return (map fromJust (filter isJust newRecords))
else return []
-- window, just receive events
if e #? CTWin then do
addEvents eref system [Gr.WinEvents]
else return ()
-- scene
scene <- if e #? CTScP then do
let (ECSGraphics3D g3ds guis refT refER quitRef) = system
addEvents eref system [Gr.ApplicationEvents]
Gr.setSceneParameter g3ds ((e # CTScP) :: SceneParameter)
newRecords <- Prelude.mapM (createRecordScene g3ds eref e quitRef) [CTScP, CTCmd]
return (map fromJust (filter isJust newRecords))
else return []
return (figs ++ cams ++ lights ++ guiforms ++ scene)
return (SystemData lock newERefs delERefs records system systemFunction)
stepSystem (SystemData lock newERefs delERefs records system systemFunction) = do
let (ECSGraphics3D g3ds guis refT refER quitRef) = system
t <- readIORef refT
(evts, nt, qFlag) <- Gr.stepHGamer3D g3ds guis t
let evts' = if qFlag then (Gr.AppEvt Gr.AppQuit : evts) else evts
writeIORef refT nt
erList <- readIORef refER
mapM (\(EventReceiver eref evttypes) -> do
let outlist = Gr.filterEventType evttypes evts'
if length outlist > 0 then
sendEvt eref outlist
else return ()
) erList
qFlag' <- readIORef quitRef
return qFlag'
forkGraphics3DWorld :: GameTime -> IO [SomeSystem]
forkGraphics3DWorld sleepT = do
system <- (runSystem sleepT) :: IO (SystemData ECSGraphics3D)
return $ [SomeSystem system]
regQuitHandler envE = do
qvar <- newEmptyMVar
regEvtH envE (\listAppEvents -> do
mapM (\appEvent -> case appEvent of
(Gr.AppEvt Gr.AppQuit) -> sendCmd envE Gr.AppQuit >> putMVar qvar ()
_ -> return ()) listAppEvents
return ())
return qvar
{-
-- the system of entity component system, in general a system has internal state
-- entities can be added to it and the system has a step function, to run it
-- Systems are self-contained, so they can be run in a thread and manage their state themselves
data ECSGraphics3D = ECSGraphics3D {
-- status of graphics engine
g3d :: (Gr.Graphics3DSystem, GU.GUISystem),
receivers :: ListAndCache EventReceiver (),
-- figures
figures :: ListAndCache Figure (Gr.Object3D Figure),
posfig :: ListAndCache D.Position (),
orifig :: ListAndCache D.Orientation (),
-- cameras
cameras :: ListAndCache Camera Gr.Camera,
poscam :: ListAndCache D.Position (),
oricam :: ListAndCache D.Orientation (),
-- lights
lights :: ListAndCache Light Gr.Light,
poslig :: ListAndCache D.Position (),
orilig :: ListAndCache D.Orientation (),
-- gui forms
guiforms :: ListAndCache Form GU.GUIEngineData,
-- scene parameter
scenepars :: ListAndCache SceneParameter (),
-- gametime
gt :: IORef D.GameTime
}
instance System ECSGraphics3D where
addEntity ecsg3d entity = do
lacAdd entity (receivers ecsg3d)
lacAdd entity (figures ecsg3d)
lacAdd entity (posfig ecsg3d)
lacAdd entity (orifig ecsg3d)
lacAdd entity (cameras ecsg3d)
lacAdd entity (poscam ecsg3d)
lacAdd entity (oricam ecsg3d)
lacAdd entity (lights ecsg3d)
lacAdd entity (poslig ecsg3d)
lacAdd entity (orilig ecsg3d)
lacAdd entity (guiforms ecsg3d)
lacAdd entity (scenepars ecsg3d)
return ecsg3d
removeEntity ecsg3d entity = do
lacRemove entity (receivers ecsg3d)
lacRemove entity (figures ecsg3d)
lacRemove entity (posfig ecsg3d)
lacRemove entity (orifig ecsg3d)
lacRemove entity (cameras ecsg3d)
lacRemove entity (poscam ecsg3d)
lacRemove entity (oricam ecsg3d)
lacRemove entity (lights ecsg3d)
lacRemove entity (poslig ecsg3d)
lacRemove entity (orilig ecsg3d)
lacRemove entity (guiforms ecsg3d)
lacRemove entity (scenepars ecsg3d)
return ecsg3d
initializeSystem = do
g3d <- E.initHGamer3D "HGamer3D" False True True
let (g3ds, guis, gtime) = g3d
Gr.setAmbientLight g3ds D.white
recv <- lacInitialize CTEvR
figs <- lacInitialize CTFig
posfig <- lacInitialize CTPos
orifig <- lacInitialize CTOri
cams <- lacInitialize CTCam
poscam <- lacInitialize CTPos
oricam <- lacInitialize CTOri
ligs <- lacInitialize CTLig
poslig <- lacInitialize CTPos
orilig <- lacInitialize CTOri
gfos <- lacInitialize CTGFo
scpars <- lacInitialize CTScP
mgt <- newIORef gtime
return $ (ECSGraphics3D (g3ds, guis) recv figs posfig orifig cams poscam oricam ligs poslig orilig gfos scpars mgt)
stepSystem ecsg3d = do
let (g3ds, guis) = (g3d ecsg3d)
-- small helper functions
let update' pos edata schema = D.positionTo edata pos
let update'' pos edata schema = D.orientationTo edata pos
-- receivers
lacApplyChanges (receivers ecsg3d) (\s -> return ()) (\s e -> return ()) (\e -> return ()) lacHandleU2CEvents lacHandleC2UEvents
-- figures
lacApplyChanges (figures ecsg3d) (Gr.object3D g3ds) (Gr.update3D g3ds) (Gr.remove3D g3ds) lacHandleU2CEvents lacHandleC2UEvents
lacApplyOtherChanges (posfig ecsg3d) (figures ecsg3d) update'
lacApplyOtherChanges (orifig ecsg3d) (figures ecsg3d) update''
-- cameras
let handleU2CEvents evts cam = do
mapM (\evt -> case evt of
(E.WindowEvt (WinEvt.EvtWindow _ _ WinEvt.SDL_WINDOWEVENT_SIZE_CHANGED x y)) -> Gr.cameraAdaptAspectRatio cam
_ -> return ()
) evts
return ()
lacApplyChanges (cameras ecsg3d) (Gr.addCamera g3ds) (Gr.updateCamera g3ds) (Gr.removeCamera g3ds) handleU2CEvents lacHandleC2UEvents
lacApplyOtherChanges (poscam ecsg3d) (cameras ecsg3d) update'
lacApplyOtherChanges (oricam ecsg3d) (cameras ecsg3d) update''
-- lights
lacApplyChanges (lights ecsg3d) (Gr.addLight g3ds) (Gr.updateLight g3ds) (Gr.removeLight g3ds) lacHandleU2CEvents lacHandleC2UEvents
lacApplyOtherChanges (poslig ecsg3d) (lights ecsg3d) update'
lacApplyOtherChanges (orilig ecsg3d) (lights ecsg3d) update''
-- gui forms
newFormEvents <- newIORef []
let handleU2CEvents evts form = do
mapM (\evt -> case evt of
(E.FormEvt (E.FormSetValue values)) -> GU.setFormValues form values
(E.GUIEvt (GU.GUIEvent tag sender window)) -> do
values <- GU.getFormValues form
strType <- GU.typeOfGuiEl window >>= return . last . (splitOn "/")
if tag `elem` (map fst values) then do
-- check if button
let newEvt = if strType == "Button"
then E.FormEvt (E.FormButtonClick tag)
else E.FormEvt (E.FormValueChange tag values)
-- show for testing
modifyIORef newFormEvents (\oldList -> (newEvt : oldList))
return ()
else return ()
_ -> return ()
) evts
return ()
lacApplyChanges (guiforms ecsg3d) (GU.createForm guis) (GU.updateForm guis) (GU.removeForm guis) handleU2CEvents lacHandleC2UEvents
-- scene parameters
let updateScene eng new = Gr.setSceneParameter g3ds new
let removeScene eng = return ()
lacApplyChanges (scenepars ecsg3d) (Gr.setSceneParameter g3ds) updateScene removeScene lacHandleU2CEvents lacHandleC2UEvents
-- step graphics system
t <- readIORef (gt ecsg3d)
(evts, nt, qFlag) <- E.stepHGamer3D g3ds guis t
writeIORef (gt ecsg3d) nt
-- handover evts towards the event system
inList <- readIORef (lacList (receivers ecsg3d))
evts' <- readIORef newFormEvents
mapM (\(eid, com) -> do
_pushC2UEvents com evts
_pushC2UEvents com evts'
if qFlag then
_pushC2UEvents com [Evt.AppEvt Evt.AppQuit]
else return ()
) inList
-- send camera resize events, set gui size
let camEvts = filter (\evt -> case evt of
(E.WindowEvt (WinEvt.EvtWindow _ _ WinEvt.SDL_WINDOWEVENT_SIZE_CHANGED x y)) -> True
_ -> False) evts
if length camEvts > 0 then do
camList <- readIORef (lacList (cameras ecsg3d))
mapM (\cam -> _pushU2CEvents (snd cam) camEvts) camList
mapM (\(E.WindowEvt (WinEvt.EvtWindow _ _ WinEvt.SDL_WINDOWEVENT_SIZE_CHANGED x y)) -> GU.notifyDisplaySizeChanged guis (fromIntegral x) (fromIntegral y)) camEvts
else return [()]
-- handle GUI events, create high level gui events, push GUI events to gfos
let guiEvts = filterEventType [GUIEvents] evts
gfoList <- readIORef (lacList (guiforms ecsg3d))
mapM (\gfo -> _pushU2CEvents (snd gfo) guiEvts) gfoList
return (ecsg3d, qFlag)
shutdownSystem ecsg3d = do
let (g3ds, guis) = (g3d ecsg3d)
E.freeHGamer3D g3ds guis
return ()
-}