HGamer3D-Graphics3D 0.4.0 → 0.5.0
raw patch · 26 files changed
+3491/−1799 lines, 26 filesdep +HGamer3D-CEGUI-Bindingdep +HGamer3D-Commondep +HGamer3D-SDL2-Bindingdep ~HGamer3D-Datadep ~HGamer3D-Ogre-Bindingsetup-changed
Dependencies added: HGamer3D-CEGUI-Binding, HGamer3D-Common, HGamer3D-SDL2-Binding, split
Dependency ranges changed: HGamer3D-Data, HGamer3D-Ogre-Binding
Files
- HGamer3D-Graphics3D.cabal +35/−35
- HGamer3D/BaseAPI/Graphics3D.hs +74/−0
- HGamer3D/Graphics3D.hs +41/−0
- HGamer3D/Graphics3D/BaseAPI.hs +0/−95
- HGamer3D/Graphics3D/Event.hs +66/−0
- HGamer3D/Graphics3D/GUIBase.hs +1206/−0
- HGamer3D/Graphics3D/GUISchema.hs +101/−0
- HGamer3D/Graphics3D/GameLoop.hs +93/−0
- HGamer3D/Graphics3D/Graphics3DBase.hs +1016/−0
- HGamer3D/Graphics3D/Graphics3DSchema.hs +138/−0
- HGamer3D/Graphics3D/Internal/Base.hs +0/−385
- HGamer3D/Graphics3D/Internal/Camera.hs +0/−173
- HGamer3D/Graphics3D/Internal/Light.hs +0/−195
- HGamer3D/Graphics3D/Internal/PlatonShapes.hs +0/−228
- HGamer3D/Graphics3D/Internal/Shapes.hs +0/−314
- HGamer3D/Graphics3D/Schema/Camera.hs +0/−51
- HGamer3D/Graphics3D/Schema/Figure.hs +0/−38
- HGamer3D/Graphics3D/Schema/Geometry.hs +0/−50
- HGamer3D/Graphics3D/Schema/Light.hs +0/−50
- HGamer3D/Graphics3D/Schema/Material.hs +0/−35
- HGamer3D/Graphics3D/Schema/Scene.hs +0/−48
- HGamer3D/Graphics3D/SystemGraphics3D.hs +514/−0
- HGamer3D/Graphics3D/WinEvent.hs +143/−0
- HGamer3D/Internal/Graphics3D.hs +0/−38
- LICENSE +42/−42
- Setup.hs +22/−22
HGamer3D-Graphics3D.cabal view
@@ -1,35 +1,35 @@-Name: HGamer3D-Graphics3D -Version: 0.4.0 -Synopsis: 3D Graphics Functionality for HGamer3D -Description: - HGamer3D is a game engine for developing 3D games in the programming - language Haskell. This package provides the 3D Graphics functionality - based on the package HGamer3D-Ogre-Binding. HGamer3D-Graphics3D is - available on Windows and Linux. - -License: OtherLicense -License-file: LICENSE -Author: Peter Althainz -Maintainer: althainz@gmail.com -Build-Type: Simple -Cabal-Version: >=1.4 -Homepage: http://www.hgamer3d.org -Category: Game Engine -Extra-source-files: Setup.hs - -Library - Build-Depends: base >= 3 && < 5, containers, mtl, transformers, filepath, directory, HGamer3D-Data >= 0.4.0 && < 0.5.0, HGamer3D-Ogre-Binding >= 0.4.0 && < 0.5.0 - - - Exposed-modules: HGamer3D.Graphics3D.Schema.Figure, HGamer3D.Graphics3D.Schema.Geometry, HGamer3D.Graphics3D.Schema.Camera, HGamer3D.Graphics3D.Schema.Light, HGamer3D.Graphics3D.Schema.Material, HGamer3D.Graphics3D.Schema.Scene, HGamer3D.Graphics3D.Internal.Base, HGamer3D.Graphics3D.Internal.Shapes, HGamer3D.Graphics3D.Internal.Light, HGamer3D.Graphics3D.Internal.PlatonShapes, HGamer3D.Graphics3D.Internal.Camera, HGamer3D.Graphics3D.BaseAPI, HGamer3D.Internal.Graphics3D - - Other-modules: - - c-sources: - - ghc-options: - cc-options: -Wno-attributes - hs-source-dirs: . - Include-dirs: . - build-depends: - extra-libraries: +Name: HGamer3D-Graphics3D+Version: 0.5.0+Synopsis: Toolset for the Haskell Game Programmer - 3D Graphics Functionality+Description: + HGamer3D is a toolset for developing 3D games in the programming + language Haskell. This package provides the 3D Graphics functionality+ based on the package HGamer3D-Ogre-Binding. HGamer3D-Graphics3D is+ available on Windows and Linux.++License: OtherLicense+License-file: LICENSE+Author: Peter Althainz+Maintainer: althainz@gmail.com+Build-Type: Simple+Cabal-Version: >=1.4+Homepage: http://www.hgamer3d.org+Category: Game Engine+Extra-source-files: Setup.hs ++Library+ Build-Depends: base >= 3 && < 5, containers, mtl, transformers, filepath, directory, split, HGamer3D-Data >= 0.5.0 && < 0.6.0, HGamer3D-Common >= 0.5.0 && < 0.6.0, HGamer3D-Ogre-Binding >= 0.5.0 && < 0.6.0, HGamer3D-SDL2-Binding >= 0.5.0 && < 0.6.0, HGamer3D-CEGUI-Binding >= 0.5.0 && < 0.6.0+++ Exposed-modules: HGamer3D.Graphics3D.Graphics3DBase, HGamer3D.Graphics3D.Graphics3DSchema, HGamer3D.Graphics3D.WinEvent, HGamer3D.Graphics3D.GUIBase, HGamer3D.Graphics3D.GUISchema, HGamer3D.Graphics3D.Event, HGamer3D.Graphics3D.GameLoop, HGamer3D.BaseAPI.Graphics3D, HGamer3D.Graphics3D.SystemGraphics3D, HGamer3D.Graphics3D++ Other-modules: ++ c-sources: + + ghc-options: -O2+ cc-options: -Wno-attributes + hs-source-dirs: .+ Include-dirs: . + build-depends: + extra-libraries:
+ HGamer3D/BaseAPI/Graphics3D.hs view
@@ -0,0 +1,74 @@+-- 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.++-- | 3D Graphics for HGamer3D, public API.+module HGamer3D.BaseAPI.Graphics3D++(+ -- * Basic Data Types and Enums+ EnumWinEventInit (..),+ SDLSystem,+ module HGamer3D.Bindings.SDL2.StructSDLEvent,+ module HGamer3D.Bindings.SDL2.EnumSDLEventType,+ module HGamer3D.Bindings.SDL2.EnumSDLKeymod,+ module HGamer3D.Bindings.SDL2.EnumSDLScancode,+ module HGamer3D.Bindings.SDL2.EnumSDLWindowEventID,+ module HGamer3D.Bindings.SDL2.EnumSDLWindowFlags,++ -- * Graphics3D Base API+ module HGamer3D.Graphics3D.Graphics3DBase,++ -- * Graphics3D Schema+-- module HGamer3D.Graphics3D.Graphics3DSchema,++ -- * GUI Base API+ module HGamer3D.Graphics3D.GUIBase,++ -- * GUI Schema+-- module HGamer3D.Graphics3D.GUISchema,++ -- * WinEvent+ module HGamer3D.Graphics3D.WinEvent,++ -- * Events, GameLoop, other+ module HGamer3D.Graphics3D.Event,+ module HGamer3D.Graphics3D.GameLoop++)++where++ import HGamer3D.Graphics3D.Graphics3DBase+ -- import HGamer3D.Graphics3D.Graphics3DSchema+ import HGamer3D.Graphics3D.GUIBase+ --import HGamer3D.Graphics3D.GUISchema+ import HGamer3D.Graphics3D.WinEvent+ import HGamer3D.Graphics3D.Event+ import HGamer3D.Graphics3D.GameLoop+ + import HGamer3D.Bindings.SDL2.EnumSDLEventType+ import HGamer3D.Bindings.SDL2.EnumSDLKeymod+ import HGamer3D.Bindings.SDL2.EnumSDLScancode+ import HGamer3D.Bindings.SDL2.EnumSDLWindowEventID+ import HGamer3D.Bindings.SDL2.EnumSDLWindowFlags+ import HGamer3D.Bindings.SDL2.StructSDLEvent++ +++
+ HGamer3D/Graphics3D.hs view
@@ -0,0 +1,41 @@+-- 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.++-- Graphics.hs++-- | 3D Graphics for HGamer3D, public API.++module HGamer3D.Graphics3D++(+ module HGamer3D.Graphics3D.Graphics3DSchema+ , module HGamer3D.Graphics3D.GUISchema+ , module HGamer3D.Graphics3D.Event++ , forkGraphics3DWorld,+ regQuitHandler+)++where++ import HGamer3D.Graphics3D.Graphics3DSchema+ import HGamer3D.Graphics3D.GUISchema+ import HGamer3D.Graphics3D.Event+ import HGamer3D.Graphics3D.SystemGraphics3D++
− HGamer3D/Graphics3D/BaseAPI.hs
@@ -1,95 +0,0 @@--- 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.---- Graphics.hs---- | 3D Graphics for HGamer3D, public API.-module HGamer3D.Graphics3D.BaseAPI--(- -- * Basic Types for the Graphics3D System- Graphics3DSystem,- Object3D,- Camera,-- -- * Initializing the Graphics3D Subsystem- - -- |- -- The initialization, step and free functions are called from the HGamer3D corresponding functions, therefore- -- they do not need to be called in code, which includes HGamer3D - BaseAPI.- - initGraphics3D,- stepGraphics3D,- freeGraphics3D,-- -- * Creating, Updating and Removing of 3D Objects- Graphics3DItem (..),- - -- * Creating simple 3D objects- sphere,- cube,- cuboid,- ikosaeder,- dodekaeder,-- -- * Light- Light,- addLight,- updateLight,- removeLight,- - HGamer3D.Graphics3D.Internal.Light.setAmbientLight,- pointLight,- spotLight,- spotLightSetDirection,- directionalLight,-- -- * Material- Material (..),- - -- * Misc Functions-- addCamera,- removeCamera,- updateCamera,- cameraLookAt,- cameraAdaptAspectRatio,-- addResourceLocationMedia,- addResourceZipfileMedia,- addResourceLocationGUI,--)--where-- import HGamer3D.Data- import HGamer3D.Util- - import HGamer3D.Graphics3D.Internal.Base- import HGamer3D.Graphics3D.Internal.Light- import HGamer3D.Graphics3D.Internal.Shapes- import HGamer3D.Graphics3D.Internal.Camera- - import HGamer3D.Graphics3D.Schema.Material- --- import HGamer3D.Graphics3D.Internal.PlatonShapes- ---
+ HGamer3D/Graphics3D/Event.hs view
@@ -0,0 +1,66 @@+{-# Language DeriveDataTypeable #-}+{-# 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.althainz.de/HGamer3D.html+--+-- (c) 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.++-- HGamer3D/Internal/Event Module+--++module HGamer3D.Graphics3D.Event+where++import HGamer3D.Graphics3D.WinEvent+import HGamer3D.Graphics3D.GUIBase+import HGamer3D.Graphics3D.GUISchema+import Data.Dynamic++data GUIFormEvent = FormSetValue [(String, FormValue)]+ | FormValueChange String [(String, FormValue)]+ | FormButtonClick String+ deriving (Typeable, Show)++data ApplicationEvent = AppQuit+ deriving (Typeable, Show)++data HG3DEvent = WindowEvt SDLEvent+ | GUIEvt GUIEvent -- ^ Low level GUI evts+ | FormEvt GUIFormEvent -- ^ High level GUI evts, directly form related+ | AppEvt ApplicationEvent+ deriving (Typeable, Show)+ +data EventType = WinEvents | GUIEvents | FormEvents | ApplicationEvents | AllEvents deriving (Typeable, Show)++filterEventType :: [EventType] -> [HG3DEvent] -> [HG3DEvent]+filterEventType types events = let+ isTypeOf evt evttype = case evttype of+ WinEvents -> case evt of+ (WindowEvt _) -> True+ _ -> False+ GUIEvents -> case evt of+ (GUIEvt _) -> True+ _ -> False+ FormEvents -> case evt of+ (FormEvt _) -> True+ _ -> False+ ApplicationEvents -> case evt of+ (AppEvt _) -> True+ _ -> False+ AllEvents -> True+ _ -> False+ in concat (map (\t -> filter (\e -> isTypeOf e t) events) types)
+ HGamer3D/Graphics3D/GUIBase.hs view
@@ -0,0 +1,1206 @@+{-# 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-2013 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.++-- |Base functionality of the GUI. Implementation module with internal data structures exposed. Public API in HGamer3D.GUI.++module HGamer3D.Graphics3D.GUIBase+where++import GHC.Ptr+import Data.List.Split+import Data.Maybe+import Control.Monad++import HGamer3D.Bindings.CEGUI.ClassOgreRenderer as CEGUIOgreRenderer+import HGamer3D.Bindings.CEGUI.ClassSystem as CEGUISystem+import HGamer3D.Bindings.CEGUI.ClassSystemHG3D as CEGUISystemHG3D+import HGamer3D.Bindings.CEGUI.ClassWindowManagerHG3D as CEGUIWindowManagerHG3D+import HGamer3D.Bindings.CEGUI.ClassWindowManager as CEGUIWindowManager+import HGamer3D.Bindings.CEGUI.ClassResourceProvider as CEGUIResourceProvider+import HGamer3D.Bindings.CEGUI.ClassDefaultResourceProvider as CEGUIDefaultResourceProvider+import HGamer3D.Bindings.CEGUI.ClassImageset as CEGUIImageset+import HGamer3D.Bindings.CEGUI.ClassFont as CEGUIFont+import HGamer3D.Bindings.CEGUI.ClassEventSet as EventSet+import HGamer3D.Bindings.CEGUI.ClassScheme as CEGUIScheme+import HGamer3D.Bindings.CEGUI.ClassWidgetLookManager as CEGUIWidgetLookManager+import HGamer3D.Bindings.CEGUI.ClassScriptModule as CEGUIScriptModule+import HGamer3D.Bindings.CEGUI.ClassLogger as CEGUILogger+import HGamer3D.Bindings.CEGUI.EnumLoggingLevel+import HGamer3D.Bindings.CEGUI.EnumMouseButton as CEGUIButton+import HGamer3D.Bindings.CEGUI.ClassFontManager as CEGUIFontManager+import HGamer3D.Bindings.CEGUI.ClassSchemeManager as CEGUISchemeManager+import HGamer3D.Bindings.CEGUI.ClassDefaultLogger as CEGUIDefaultLogger+import HGamer3D.Bindings.CEGUI.ClassHG3DEventController as HG3DEventController+import HGamer3D.Bindings.CEGUI.ClassWindowManagerHG3D as HG3DWindowManager+--import HGamer3D.Bindings.Ogre.ClassHG3DMessagePump as MessagePump+++import HGamer3D.Bindings.CEGUI.ClassPtr+import HGamer3D.Bindings.CEGUI.Utils++import HGamer3D.Bindings.CEGUI.ClassWindowManager as WindowManager+import HGamer3D.Bindings.CEGUI.ClassWindowManagerHG3D as WindowManagerHG3D+import HGamer3D.Bindings.CEGUI.ClassWindow as Window+import HGamer3D.Bindings.CEGUI.ClassSystem as System+import HGamer3D.Bindings.CEGUI.ClassSystemHG3D as SystemHG3D+import HGamer3D.Bindings.CEGUI.ClassPropertySet as PropertySet+import HGamer3D.Bindings.CEGUI.ClassHG3DEventStaticFunctions as EvtSF +import HGamer3D.Bindings.CEGUI.ClassHG3DListboxStaticFunctions as ListboxSF+import HGamer3D.Bindings.CEGUI.ClassHG3DWindowStaticFunctions as WindowSF+import HGamer3D.Bindings.CEGUI.ClassListbox as Listbox+import HGamer3D.Bindings.CEGUI.ClassListboxItem as ListboxItem+import HGamer3D.Bindings.CEGUI.ClassCombobox as Combobox+import HGamer3D.Bindings.CEGUI.EnumKeyScan+import HGamer3D.Bindings.CEGUI.ClassHG3DEventStaticFunctions as EvtSF +import HGamer3D.Bindings.CEGUI.EnumMouseButton as CEGUIButton+import qualified HGamer3D.Bindings.CEGUI.ClassUDim as Ud++import HGamer3D.Data+import HGamer3D.Common+import HGamer3D.Data.HG3DClass++import HGamer3D.Graphics3D.WinEvent+import HGamer3D.Graphics3D.GUISchema++++{- ----------------------------------------------------------------+ Basic Data Types+ ---------------------------------------------------------------- -}++-- | the basic data item, carrying status information on implementation details for GUI system+data GUISystem = GUISystem {+ guiRoot::HG3DClass,+ guiRenderer::HG3DClass,+ guiWindowManager::HG3DClass,+ guiWindowManagerHG3D::HG3DClass,+ guiFontManager::HG3DClass,+ guiSchemeManager::HG3DClass,+ guiEventController::HG3DClass,+ guiUniqueName::UniqueName+} ++-- type constructors for phantom types++data GEButton = GEButton+data GERadioButton = GERadioButton+data GECheckBox = GECheckBox+data GEEditText = GEEditText+data GEMultilineText = GEMultilineText++data GEListBox = GEListBox+data GEComboBox = GEComboBox++data GESlider = GESlider+data GESpinner = GESpinner++data GEWindow = GEWindow+data GEHLayout = GEHLayout+data GEVLayout = GEVLayout+data GEGridLayout = GEGridLayout++-- | The GUI Element, a window, a button, any widget or widget element, organized in a hierarchy+data GUIElement a = GUIElement HG3DClass a -- ^ only one constructor, phantom type a, to allow GUIElement sub-typing++{- ----------------------------------------------------------------+ Basic GUI Initialization+ ---------------------------------------------------------------- -}++-- | load a complete layout file into the application+loadGuiLayoutFromFile :: GUISystem + -> String -- ^ filename, without the path (this is defined by resource locations)+ -> String -- ^ prefix to append to the identifiers in the layout, this allows, to load the same dailog/gui element multiple times with different names, if needed+ -> IO (GUIElement a) -- ^ the resulting tree of GUI elements as top GUI element+loadGuiLayoutFromFile guis layoutFile prefix = do+ let hg3dWinMgr = guiWindowManagerHG3D guis+ window <- WindowManagerHG3D.loadWindowLayoutHG3D hg3dWinMgr layoutFile prefix+ return (GUIElement window undefined)++-- | add a GUI element to the display+addGuiElToDisplay :: GUISystem + -> GUIElement a -- ^ GUI element+ -> IO ()+addGuiElToDisplay guis (GUIElement window _) = do+ let guir = guiRoot guis+ guiSheet <- System.getGUISheet guir+ Window.addChildWindow2 guiSheet window++-- | remove a GUI element from the display+removeGuiElFromDisplay :: GUISystem + -> GUIElement a -- ^ GUI element+ -> IO ()+removeGuiElFromDisplay guis (GUIElement window _) = do+ let guir = guiRoot guis+ guiSheet <- System.getGUISheet guir+ Window.removeChildWindow2 guiSheet window++-- | enable GUI element, allow interaction with it and render it accordingly+enableGuiEl :: GUIElement a -- ^ GUI element to enable+ -> IO ()+enableGuiEl (GUIElement window _) = do+ Window.enable window++-- | disable GUI element, disallow interaction with it and render it accordingly+disableGuiEl :: GUIElement a -- ^ GUI element to disable+ -> IO ()+disableGuiEl (GUIElement window _) = do+ Window.disable window++-- | activate GUI element, process events send to it+activateGuiEl :: GUIElement a -- ^ GUI element to activate+ -> IO ()+activateGuiEl (GUIElement window _) = do+ Window.activate window++-- | deactivate GUI element, do not process events send to it+deactivateGuiEl :: GUIElement a -- ^ GUI element to deactivate+ -> IO ()+deactivateGuiEl (GUIElement window _) = do+ Window.deactivate window++-- | delete a GUI element, do not process events send to it+deleteGuiEl :: GUISystem -> GUIElement a -- ^ GUI element to deactivate+ -> IO ()+deleteGuiEl guis (GUIElement window _) = do+ let wmgr = guiWindowManager guis+ EventSet.removeAllEvents window+ CEGUIWindowManager.destroyWindow wmgr window++-- | show GUI element+showGuiEl :: GUIElement a -- ^ GUI element to show+ -> IO ()+showGuiEl (GUIElement window _) = do+ Window.show window++-- | hide GUI element+hideGuiEl :: GUIElement a -- ^ GUI element to hide+ -> IO ()+hideGuiEl (GUIElement window _) = do+ Window.hide window++-- | add a GUI element as a child to another GUI element+addChildGuiEl :: GUIElement a -- ^ parent GUI element+ -> GUIElement b -- ^ child GUI element+ -> IO ()+addChildGuiEl (GUIElement parentW _) (GUIElement childW _) = do+ Window.addChildWindow2 parentW childW++-- | remove a GUI element as a child from the parent GUI element+removeChildGuiEl :: GUIElement a -- ^ parent GUI element+ -> GUIElement b -- ^ child GUI element+ -> IO ()+removeChildGuiEl (GUIElement parentW _) (GUIElement childW _) = do+ Window.removeChildWindow2 parentW childW++-- | get child gui element, throws an exception, if element not found in children, only searches the direct children of element.+getChildGuiEl :: GUIElement a -- ^ GUI element, which childrens are searched for child element+ -> String -- ^ name of searched child element+ -> IO (GUIElement a) -- ^ found element (throws exception, in case no child found)+getChildGuiEl (GUIElement window _) name = do+ window <- Window.getChild window name+ return (GUIElement window undefined)++-- | find child element recursively, searches all sub-trees+findChildGuiElRecursive :: GUIElement a -- ^ GUI element, which childrens are searched, including children of children and so on.+ -> String -- ^ name of child element to be found+ -> IO (Maybe (GUIElement b)) -- ^ in case of found element: Just el, Nothing otherwhise+findChildGuiElRecursive (GUIElement window _) name = do+ window <- Window.getChildRecursive window name+ if (ocPtr window) == nullPtr then do+ return Nothing+ else do+ return (Just (GUIElement window undefined))++-- | get a named property as string from element+getGuiElProperty :: GUIElement a -- ^ GUI element+ -> String -- ^ property name to get+ -> IO String -- ^ property value+getGuiElProperty (GUIElement window _) name = do+ prop <- PropertySet.getProperty window name+ return prop++-- | set a named property +setGuiElProperty :: GUIElement a -- ^ GUI element+ -> String -- ^ property name to set+ -> String -- ^ property value as string+ -> IO ()+setGuiElProperty (GUIElement window _) name value = do+ PropertySet.setProperty window name value++-- | load a complete GUI scheme, see CEGUI manual for details+loadGuiScheme :: GUISystem -> String -- ^ scheme name+ -> IO ()+loadGuiScheme guis schemeName = do+ SystemHG3D.schemeManagerCreate (guiSchemeManager guis) schemeName++-- | load a GUI font+loadGuiFont :: GUISystem -> String -- ^ font name+ -> IO () +loadGuiFont guis fontName = do+ SystemHG3D.fontManagerCreate (guiFontManager guis) fontName+ +-- | set default GUI font+setGuiDefaultFont :: GUISystem -> String -- ^ font name+ -> IO () +setGuiDefaultFont guis fontName = do+ let guir = guiRoot guis+ System.setDefaultFont guir fontName+ +-- | set default mouse cursor+setGuiDefaultMouseCursor :: GUISystem + -> String -- ^ scheme name, where cursor is contained in+ -> String -- ^ cursor name+ -> IO () +setGuiDefaultMouseCursor guis schemeName cursorName = do+ let guir = guiRoot guis+ System.setDefaultMouseCursor3 guir schemeName cursorName++-- | set default tool tip+setGuiDefaultTooltip :: GUISystem -> String -- ^ default tool tip name+ -> IO () +setGuiDefaultTooltip guis ttName = do+ let guir = guiRoot guis+ System.setDefaultTooltip2 guir ttName+++++-- | initialize the GUI system, used internally+initGUI :: Bool -- ^ logging flag+ -> Bool -- ^ show graphics cursor flag+ -> IO (GUISystem) -- ^ GUI system object+initGUI fShowGraphicsCursor fLog = do+++ -- CEGUI system+ ---------------+ + -- first logger, loglevel+ + if not fLog then do+ ceguilog <- CEGUISystemHG3D.createNoLogger + return ()+ else do+ ceguilog <- CEGUIDefaultLogger.new+ CEGUILogger.setLogFilename ceguilog "hgamer3d-gui.log" False+ CEGUILogger.setLoggingLevel ceguilog LoggingLevelInformative+ return ()++ -- bootstrap complete cegui system+ + guirenderer <- CEGUIOgreRenderer.bootstrapSystem+ + guiroot <- CEGUISystem.getSingletonPtr+ guiwindowmgr <- CEGUIWindowManagerHG3D.getSingleton+ guifontmgr <- CEGUISystemHG3D.getFontManagerSingleton+ guischememgr <- CEGUISystemHG3D.getSchemeManagerSingleton+ + CEGUIScheme.setDefaultResourceGroup "Schemes"+ CEGUIImageset.setDefaultResourceGroup "Imagesets"+ CEGUIFont.setDefaultResourceGroup "Fonts"+ CEGUIWidgetLookManager.setDefaultResourceGroup "LookNFeel"+ CEGUIWindowManager.setDefaultResourceGroup "Layouts"+-- CEGUIScriptModule.setDefaultResourceGroup "lua_scripts"++ CEGUISystemHG3D.schemeManagerCreate guischememgr "VanillaSkin.scheme"+ CEGUISystemHG3D.schemeManagerCreate guischememgr "WindowsLook.scheme"+ CEGUISystemHG3D.schemeManagerCreate guischememgr "WindowsLookWidgets.scheme"+ CEGUISystemHG3D.schemeManagerCreate guischememgr "TaharezLook.scheme"+ CEGUISystemHG3D.schemeManagerCreate guischememgr "TaharezLookWidgets.scheme"+ + CEGUISystemHG3D.fontManagerCreate guifontmgr "DejaVuSans-10.font"+ + CEGUISystem.setDefaultFont guiroot "DejaVuSans-10"+ if fShowGraphicsCursor then do+ CEGUISystem.setDefaultMouseCursor3 guiroot "Vanilla-Images" "MouseArrow"+ showCursor False+ return ()+ else do+ showCursor True+ return ()+ CEGUISystem.setDefaultTooltip2 guiroot "WindowsLook/Tooltip"+ + -- set standard empty gui sheet+ myRoot <- CEGUIWindowManager.createWindow guiwindowmgr "DefaultWindow" "root"+ CEGUISystem.setGUISheet guiroot myRoot+ + eventController <- HG3DEventController.new+ guiwmgrhg3d <- HG3DWindowManager.new+ uniqueName <- createUniqueName "GUI"+ + return (GUISystem guiroot guirenderer guiwindowmgr guiwmgrhg3d guifontmgr guischememgr eventController uniqueName)++freeGUI :: GUISystem -> IO ()+freeGUI gs = return ()++keyscanToScancode :: EnumSDLScancode -> Maybe Int+keyscanToScancode keyscan = if out == KeyMediaSelect then Nothing else (Just (fromIntegral (fromEnum out))) where+ out = case keyscan of+ SDL_SCANCODE_RETURN -> KeyReturn+ SDL_SCANCODE_ESCAPE -> KeyEscape+ SDL_SCANCODE_BACKSPACE -> KeyBackspace+ SDL_SCANCODE_TAB -> KeyTab+ SDL_SCANCODE_INSERT -> KeyInsert+ SDL_SCANCODE_HOME -> KeyHome+ SDL_SCANCODE_PAGEUP -> KeyPageUp+ SDL_SCANCODE_DELETE -> KeyDelete+ SDL_SCANCODE_END -> KeyEnd + SDL_SCANCODE_PAGEDOWN -> KeyPageDown+ SDL_SCANCODE_RIGHT -> KeyArrowRight+ SDL_SCANCODE_LEFT -> KeyArrowLeft+ SDL_SCANCODE_DOWN -> KeyArrowDown+ SDL_SCANCODE_UP ->KeyArrowUp+ _ -> KeyMediaSelect -- misused as Nothing indicator+ + +_injectKeyUp guiroot keycode = do + case keyscanToScancode keycode of+ Nothing -> return False+ Just scancode -> System.injectKeyUp guiroot scancode++_injectKeyDown guiroot keycode = do + case keyscanToScancode keycode of+ Nothing -> return False+ Just scancode -> System.injectKeyDown guiroot scancode++-- keypressInject++-- | injects key presses into the CEGUI engine, used internally+injectWinEventToGUI :: GUISystem -> SDLEvent -> IO ()+injectWinEventToGUI guis evt = do+ + let guiroot = guiRoot guis+ case evt of+ EvtText ts window text -> System.injectChar guiroot (fromEnum (text !! 0))+ EvtKeyUp ts window keyscan keycode keymode -> _injectKeyUp guiroot keyscan+ EvtKeyDown ts window keyscan keycode keymode -> _injectKeyDown guiroot keyscan+ EvtMouseButtonUp ts window mid button x y -> do+ case button of+ SDLButtonLeft -> System.injectMouseButtonUp guiroot CEGUIButton.MouseLeftButton+ SDLButtonRight -> System.injectMouseButtonUp guiroot CEGUIButton.MouseRightButton+ SDLButtonMiddle -> System.injectMouseButtonUp guiroot CEGUIButton.MouseMiddleButton+ _ -> return True+ EvtMouseButtonDown ts window mid button x y -> do+ case button of+ SDLButtonLeft -> System.injectMouseButtonDown guiroot CEGUIButton.MouseLeftButton+ SDLButtonRight -> System.injectMouseButtonDown guiroot CEGUIButton.MouseRightButton+ SDLButtonMiddle -> System.injectMouseButtonDown guiroot CEGUIButton.MouseMiddleButton+ _ -> return True+ EvtMouseMotion ts window mid x y rx ry -> CEGUISystem.injectMousePosition guiroot (fromIntegral x) (fromIntegral y)+ _ -> return True+ + return () + +-- | register a GUI Event, for later retrieval+registerGUIEvent :: GUISystem + -> GUIElement a -- ^ GUI Element from which event is registered+ -> String -- ^ event name, for which registration is done+ -> String -- ^ identifier, with which event is identified later on+ -> IO ()+registerGUIEvent guis (GUIElement el _) eventToRegister registrationTag = do+ EvtSF.subscribeScriptedEvent el eventToRegister registrationTag+ +data GUIEvent = GUIEvent String String (GUIElement ())++instance Show GUIEvent where+ show (GUIEvent str1 str2 _) = "GUI Event - " ++ str1 ++ " " ++ str2++pollGUIEvent :: GUISystem -> IO (Maybe GUIEvent)+pollGUIEvent guis = do+ let eventController = guiEventController guis+ processEvents <- HG3DEventController.eventsAvailable eventController+ if processEvents+ then do+ (name, sender, window) <- HG3DEventController.popEvent eventController+ let evt = GUIEvent name sender (GUIElement window ())+ return $ Just evt+ else return Nothing++injectGUITimeDelta :: GUISystem -> GameTime -> IO ()+injectGUITimeDelta guis gtime = do+ CEGUISystem.injectTimePulse (guiRoot guis) ((fromIntegral . msec) gtime)+ return ()++notifyDisplaySizeChanged :: GUISystem -> Float -> Float -> IO ()+notifyDisplaySizeChanged guis width height = do+ WindowSF.setNewWindowSize (guiRoot guis) width height+ return ()++type GUIElementProperty a b = (GUIElement a -> IO b, GUIElement a -> b -> IO ())++(=:) :: (GUIElementProperty a b) -> b -> (GUIElement a -> IO ())+(=:) prop val = (\val' guiel -> (snd prop) guiel val') val ++setP :: GUIElement a -> [GUIElement a -> IO ()] -> IO [()]+setP guiel ps = sequence $ fmap (\f -> f guiel) ps++getP :: GUIElement a -> GUIElementProperty a b -> IO b+getP guiel p = (fst p) guiel++{- ----------------------------------------------------------------+ GUI Properties+ ---------------------------------------------------------------- -}++type GUIButtonProperty b = GUIElementProperty GEButton b+type GUIEditTextProperty b = GUIElementProperty GEEditText b++type GUIHasSelectionProperty a b = GUIElementProperty a b+type GUIRadioButtonProperty b = GUIHasSelectionProperty GERadioButton b+type GUICheckBoxProperty b = GUIHasSelectionProperty GECheckBox b++type GUIHasValueProperty a b = GUIElementProperty a b+type GUISliderProperty b = GUIHasValueProperty GESlider b+type GUISpinnerProperty b = GUIHasValueProperty GESpinner b++type GUIListBoxProperty b = GUIElementProperty GEListBox b+type GUIComboBoxProperty b = GUIElementProperty GEComboBox b++_stringProp :: String -> GUIElementProperty a String+_stringProp name = ( + (flip getGuiElProperty) name, + (\pname guiel val -> setGuiElProperty guiel pname val) name+ )++_toBool :: String -> Bool+_toBool instr = case instr of+ "True" -> True+ "False" -> False+ _ -> False++_fromBool :: Bool -> String+_fromBool inb = case inb of+ True -> "True"+ False -> "False"+ _ -> "False"++_toFloat :: String -> Float+_toFloat = read++_fromFloat :: Float -> String+_fromFloat = Prelude.show++_boolProp :: String -> GUIElementProperty a Bool+_boolProp name = ( + ((flip getGuiElProperty) name) >=> return . _toBool, + ((\pname guiel val -> setGuiElProperty guiel pname (_fromBool val)) name)+ )++_floatProp :: String -> GUIElementProperty a Float+_floatProp name = ( + ((flip getGuiElProperty) name) >=> return . _toFloat, + ((\pname guiel val -> setGuiElProperty guiel pname (_fromFloat val)) name)+ )++pText :: GUIElementProperty a String+pText = _stringProp "Text"++pDisabled :: GUIElementProperty a Bool+pDisabled = _boolProp "Disabled"++pVisible :: GUIElementProperty a Bool+pVisible = _boolProp "Visible"++pAlpha :: GUIElementProperty a Float+pAlpha = _floatProp "Alpha"++pAlwaysOnTop :: GUIElementProperty a Bool+pAlwaysOnTop = _boolProp "AlwaysOnTop"++pTooltip :: GUIElementProperty a String+pTooltip = _stringProp "Tooltip"++pFont :: GUIElementProperty a String+pFont = _stringProp "Font"++pX :: GUIElementProperty a GUIDim+pX = (getProp, setProp) where+ getProp (GUIElement window _) = do+ ud <- Window.getXPosition window+ scale <- WindowSF.udScale ud+ offset <- WindowSF.udOffset ud+ return $ GUIDim scale offset+ setProp (GUIElement window _) (GUIDim scale offset) = do+ ud <- Ud.new scale offset+ Window.setXPosition window ud+ Ud.delete ud+ return ()++pY :: GUIElementProperty a GUIDim+pY = (getProp, setProp) where+ getProp (GUIElement window _) = do+ ud <- Window.getYPosition window+ scale <- WindowSF.udScale ud+ offset <- WindowSF.udOffset ud+ return $ GUIDim scale offset+ setProp (GUIElement window _) (GUIDim scale offset) = do+ ud <- Ud.new scale offset+ Window.setYPosition window ud+ Ud.delete ud+ return ()++pWidth :: GUIElementProperty a GUIDim+pWidth = (getProp, setProp) where+ getProp (GUIElement window _) = do+ ud <- WindowSF.getWindowWidth window+ scale <- WindowSF.udScale ud+ offset <- WindowSF.udOffset ud+ Ud.delete ud+ return $ GUIDim scale offset+ setProp (GUIElement window _) (GUIDim scale offset) = do+ ud <- Ud.new scale offset+ Window.setWidth window ud+ Ud.delete ud+ return ()++pHeight :: GUIElementProperty a GUIDim+pHeight = (getProp, setProp) where+ getProp (GUIElement window _) = do+ ud <- WindowSF.getWindowHeight window+ scale <- WindowSF.udScale ud+ offset <- WindowSF.udOffset ud+ Ud.delete ud+ return $ GUIDim scale offset+ setProp (GUIElement window _) (GUIDim scale offset) = do+ ud <- Ud.new scale offset+ Window.setHeight window ud+ Ud.delete ud+ return ()++pMargin :: GUIElementProperty a GUIDim+pMargin = (getProp, setProp) where+ getProp (GUIElement window _) = do+ ud <- WindowSF.getWindowMargin window+ scale <- WindowSF.udScale ud+ offset <- WindowSF.udOffset ud+ Ud.delete ud+ return $ GUIDim scale offset+ setProp (GUIElement window _) (GUIDim scale offset) = do+ ud <- Ud.new scale offset+ WindowSF.setWindowMargin window ud+ Ud.delete ud+ return ()++pSelected :: GUIHasSelectionProperty a Bool+pSelected = _boolProp "Selected"++pValue :: GUIHasValueProperty a Float+pValue = _floatProp "CurrentValue"++pTextSelection :: GUIListBoxProperty [(String, Bool)]+pTextSelection = (listboxStatus, listboxInitialize)++pTextChoice :: GUIComboBoxProperty [String]+pTextChoice = (getProp, setProp) where+ setProp w strings = do+ comboboxRemoveAllText w+ mapM (comboboxAddText w) strings+ return ()+ getProp w = do+ comboboxStatus w++{- ----------------------------------------------------------------+ GUI Widgets+ ---------------------------------------------------------------- -}+++-- | GUI Element, Sybtype Button+type GUIButton = GUIElement GEButton++-- | GUI Elements, which have a selection+type GUIHasSelection a = GUIElement a++-- | GUI Element, Sybtype CheckBox+type GUICheckBox = GUIHasSelection GECheckBox++-- | GUI Element, Sybtype RadioButton+type GUIRadioButton = GUIHasSelection GERadioButton++-- | GUI Element, Sybtype EditText+type GUIEditText = GUIElement GEEditText++-- | GUI Element, Sybtype MultilineText+type GUIMultilineText = GUIElement GEMultilineText++-- | GUI Element, Sybtype Listbox+type GUIListBox = GUIElement GEListBox++-- | GUI Element, Sybtype Combobox+type GUIComboBox = GUIElement GEComboBox++-- | GUI Element, which have a value+type GUIHasValue a = GUIElement a++-- | GUI Element, Sybtype Slider+type GUISlider = GUIHasValue GESlider++-- | GUI Element, Sybtype Spinner+type GUISpinner = GUIHasValue GESpinner++-- | GUI Element, Subtype FrameWindow+type GUIWindow = GUIElement GEWindow++-- | GUI Element, which is a layout container+type GUILayout a = GUIElement a++-- | GUI Element, vertical layout container+type GUIVLayout = GUILayout GEVLayout++-- | GUI Element, horizontal layout container+type GUIHLayout = GUILayout GEHLayout++-- | GUI Element, grid layout container+type GUIGridLayout = GUILayout GEGridLayout+++-- | get Type of GUI element as string+typeOfGuiEl :: GUIElement a -- ^ GUI element to enable+ -> IO String+typeOfGuiEl (GUIElement window _) = do+ Window.getType window++toGuiType :: String -> b -> GUIElement a -> IO (GUIElement b)+toGuiType typestr cons guiel@(GUIElement window _) = do+ tp <- typeOfGuiEl guiel+ -- CEGUI Types as String have the format "WindowLook/Button" for example+ -- sometimes they have no "xyzLook" part and no /+ let tp' = last (splitOn "/" tp) + let guiel' = case tp' of+ typestr -> GUIElement window cons+ _ -> error ("HGamer3D.GUI.Internal.Widgets.toGuiType: " ++ typestr ++ " not found!")+ return guiel'++_createElement :: String -> (GUIElement a -> IO (GUIElement b)) -> GUISystem -> String -> [GUIElement b -> IO ()] -> IO (GUIElement b)+_createElement elType convFunc guis style proplist = do+ let winMgr = guiWindowManager guis+ let uname = guiUniqueName guis+ elName <- nextUniqueName uname+ window <- WindowManager.createWindow winMgr (style ++ "/" ++ elType) elName+ el <- convFunc (GUIElement window undefined)+ -- set the properties+ setP el proplist + return el++_createElement' :: String -> (GUIElement a -> IO (GUIElement b)) -> GUISystem -> [GUIElement b -> IO ()] -> IO (GUIElement b)+_createElement' elType convFunc guis proplist = do+ let winMgr = guiWindowManager guis+ let uname = guiUniqueName guis+ elName <- nextUniqueName uname+ window <- WindowManager.createWindow winMgr (elType) elName+ el <- convFunc (GUIElement window undefined)+ -- set the properties+ setP el proplist + return el++button :: GUISystem -> String -> [GUIButton -> IO ()] -> IO GUIButton+button = _createElement "Button" toButton++radioButton :: GUISystem -> String -> [GUIRadioButton -> IO ()] -> IO GUIRadioButton+radioButton = _createElement "RadioButton" toRadioButton++checkBox :: GUISystem -> String -> [GUICheckBox -> IO ()] -> IO GUICheckBox+checkBox = _createElement "Checkbox" toCheckBox++editText :: GUISystem -> String -> [GUIEditText -> IO ()] -> IO GUIEditText+editText = _createElement "Editbox" toEditText++multilineText :: GUISystem -> String -> [GUIMultilineText -> IO ()] -> IO GUIMultilineText+multilineText = _createElement "MultiLineEditbox" toMultilineText++comboBox :: GUISystem -> String -> [GUIComboBox -> IO ()] -> IO GUIComboBox+comboBox = _createElement "Combobox" toComboBox++listBox :: GUISystem -> String -> [GUIListBox -> IO ()] -> IO GUIListBox+listBox = _createElement "Listbox" toListBox++spinner :: GUISystem -> String -> [GUISpinner -> IO ()] -> IO GUISpinner+spinner = _createElement "Spinner" toSpinner++slider :: GUISystem -> String -> [GUISlider -> IO ()] -> IO GUISlider+slider = _createElement "Slider" toSlider++window :: GUISystem -> String -> [GUIWindow -> IO ()] -> IO GUIWindow+window = _createElement "FrameWindow" toWindow++hLayout :: GUISystem -> [GUIHLayout -> IO ()] -> IO GUIHLayout+hLayout = _createElement' "HorizontalLayoutContainer" toHLayout++vLayout :: GUISystem -> [GUIVLayout -> IO ()] -> IO GUIVLayout+vLayout = _createElement' "VerticalLayoutContainer" toVLayout++gridLayout :: GUISystem -> [GUIGridLayout -> IO ()] -> IO GUIGridLayout+gridLayout = _createElement' "GridLayoutContainer" toGridLayout++toButton = toGuiType "Button" GEButton+toRadioButton = toGuiType "RadioButton" GERadioButton+toCheckBox = toGuiType "Checkbox" GECheckBox++toEditText = toGuiType "Editbox" GEEditText+toMultilineText = toGuiType "MultiLineEditbox" GEMultilineText++toComboBox = toGuiType "Combobox" GEComboBox+toListBox = toGuiType "Listbox" GEListBox++toSlider = toGuiType "Slider" GESlider+toSpinner = toGuiType "Spinner" GESpinner++toHLayout = toGuiType "HorizontalLayoutContainer" GEHLayout+toVLayout = toGuiType "VerticalLayoutContainer" GEVLayout+toGridLayout = toGuiType "GridLayoutContainer" GEGridLayout+toWindow = toGuiType "FrameWindow" GEWindow++findElement :: (GUIElement a -> IO (GUIElement b))+ ->String + -> GUIElement a + -> IO (GUIElement b)+findElement toNewType name topel = do+ mFound <- findChildGuiElRecursive topel name+ el <- toNewType (fromJust mFound)+ return el ++findButton = findElement toButton+findRadioButton = findElement toRadioButton+findCheckBox = findElement toCheckBox+findEditText = findElement toEditText+findMultilineText = findElement toMultilineText+findComboBox = findElement toComboBox+findListBox = findElement toListBox+findSpinner = findElement toSpinner+findSlider = findElement toSlider++-- | add one line of text as a selectable entry to a combobox+comboboxAddText :: GUIComboBox -- ^ GUI element, needs to be a combobox+ -> String -- ^ the entry string to add+ -> IO ()+comboboxAddText (GUIElement window GEComboBox) itemname = do+ realcombo <- WindowSF.castWindowToCombobox window+ ListboxSF.comboboxAddItem realcombo itemname+ +-- | removes all lines of entries from a combobox+comboboxRemoveAllText :: GUIComboBox -- ^ the GUI elements, needs to be a combobox+ -> IO ()+comboboxRemoveAllText (GUIElement window GEComboBox) = do+ realcombo <- WindowSF.castWindowToCombobox window+ Combobox.resetList realcombo+ +comboboxStatus :: GUIComboBox -- ^ GUI element, needs to be a listbox+ -> IO [String] -- ^ list of entry, selected pairs+comboboxStatus (GUIElement window GEComboBox) = do+ realbox <- WindowSF.castWindowToCombobox window+ count <- Combobox.getItemCount realbox+ outlist <- mapM ( \ind -> do+ item <- Combobox.getListboxItemFromIndex realbox ind+ txt <- ListboxItem.getText item+ return txt+ ) [0..(count-1)]+ return outlist++-- | add one line of text as a selectable entry to a listbox+listboxAddText :: GUIListBox -- ^ GUI element, needs to be a listbox+ -> String -- ^ the entry string to add+ -> IO ()+listboxAddText (GUIElement window GEListBox) itemname = do+ reallistbox <- WindowSF.castWindowToListbox window+ ListboxSF.listboxAddItem reallistbox itemname+ +_getTextListOfItem reallistbox item list = do+ let (HG3DClass ptra ptrb) = item+ if ptra /= nullPtr then do+ txt <- ListboxItem.getText item+ let list' = list ++ [txt]+ item' <- Listbox.getNextSelected reallistbox item+ list'' <- _getTextListOfItem reallistbox item' list'+ return list''+ else do+ return list+ +listboxInitialize :: GUIListBox -- ^ GUI element, needs to be a listbox+ -> [(String, Bool)] -- ^ list of entry, selected pairs+ -> IO ()+listboxInitialize (GUIElement window GEListBox) pairs = do+ reallistbox <- WindowSF.castWindowToListbox window+ Listbox.resetList reallistbox+ mapM ( \((entry, selected), ind) -> do+ ListboxSF.listboxAddItem reallistbox entry+ item <- Listbox.getListboxItemFromIndex reallistbox ind+ ListboxItem.setSelected item selected+ return ()+ ) (zip pairs [0..])+ return ()+ +listboxStatus :: GUIListBox -- ^ GUI element, needs to be a listbox+ -> IO [(String, Bool)] -- ^ list of entry, selected pairs+listboxStatus (GUIElement window GEListBox) = do+ reallistbox <- WindowSF.castWindowToListbox window+ count <- Listbox.getItemCount reallistbox+ outlist <- mapM ( \ind -> do+ item <- Listbox.getListboxItemFromIndex reallistbox ind+ sel <- ListboxItem.isSelected item+ txt <- ListboxItem.getText item+ return (txt, sel)+ ) [0..(count-1)]+ return outlist+ ++-- | return the selected items as an array of strings+listboxGetSelectedText :: GUIListBox -- ^ the GUI element, needs to be a listbox+ -> IO [String] -- ^ the selected items as an array of strings+listboxGetSelectedText (GUIElement window GEListBox) = do+ reallistbox <- WindowSF.castWindowToListbox window+ item <- Listbox.getFirstSelectedItem reallistbox+ list <- _getTextListOfItem reallistbox item ([]::[String])+ return list+ +-- | removes all lines of entries from a listbox+listboxRemoveAllText :: GUIListBox -- ^ the GUI element, needs to be a listbox+ -> IO ()+listboxRemoveAllText (GUIElement window GEListBox) = do+ reallistbox <- WindowSF.castWindowToListbox window+ Listbox.resetList reallistbox+ ++ +{- ----------------------------------------------------------------+ Functions for ECS API+ ---------------------------------------------------------------- -}++data GUIEngineDataWidget = GEDButton GUIButton String+ | GEDRadioButton GUIRadioButton String+ | GEDCheckBox GUICheckBox String+ | GEDComboBox GUIComboBox String+ | GEDListBox GUIListBox String+ | GEDSpinner GUISpinner String+ | GEDSlider GUISlider String+ | GEDEditText GUIEditText String+ | GEDMultilineText GUIMultilineText String+ +data GUIEngineDataLayout = GEDHLayout GUIHLayout+ | GEDVLayout GUIVLayout+ | GEDGridLayout GUIGridLayout+ | GEDWindow GUIWindow++data GUIEngineData = GUIEngineData GUIEngineDataElement Form++data GUIEngineDataElement = GEDSingleElement GUIEngineDataWidget+ | GEDCombinedElement GUIEngineDataLayout [GUIEngineDataElement]++-- there is a big distinction in the typesystem between a type which is not known to the function but it is assumed it has a specific type on calling (typevariable a) and the return value of being any possible type which is requested by outer world type (typevariable b). So _undef is polymorphic in its out value, this only can be accomplished by undef!+_toUndef :: GUIElement a -> GUIElement b+_toUndef (GUIElement window _) = (GUIElement window undefined)++_getWidget :: GUIEngineDataElement -> GUIElement a+_getWidget (GEDSingleElement (GEDButton w _)) = _toUndef w+_getWidget (GEDSingleElement (GEDRadioButton w _)) = _toUndef w+_getWidget (GEDSingleElement (GEDCheckBox w _)) = _toUndef w+_getWidget (GEDSingleElement (GEDComboBox w _)) = _toUndef w+_getWidget (GEDSingleElement (GEDListBox w _)) = _toUndef w+_getWidget (GEDSingleElement (GEDSpinner w _)) = _toUndef w+_getWidget (GEDSingleElement (GEDSlider w _)) = _toUndef w+_getWidget (GEDSingleElement (GEDEditText w _)) = _toUndef w+_getWidget (GEDSingleElement (GEDMultilineText w _)) = _toUndef w++_getWidget (GEDCombinedElement (GEDHLayout l) _) = _toUndef l+_getWidget (GEDCombinedElement (GEDVLayout l) _) = _toUndef l+_getWidget (GEDCombinedElement (GEDGridLayout l) _) = _toUndef l+_getWidget (GEDCombinedElement (GEDWindow l) _) = _toUndef l++_createLayout :: GUISystem -> Layout -> String -> IO GUIEngineDataLayout+_createLayout guis layout typename = do+ case layout of+ VerticalLayout props -> vLayout guis (_createProps props) >>= return . GEDVLayout+ HorizontalLayout props -> hLayout guis (_createProps props) >>= return . GEDHLayout+ GridLayout x y props -> gridLayout guis (_createProps props) >>= return . GEDGridLayout+ Window name props -> window guis typename (_createProps props) >>= return . GEDWindow++-- the following routine assume same typename for new layout, it only modify props+_updateLayoutProps :: GUIEngineDataLayout -> Layout -> IO ()+_updateLayoutProps edata layout = do+ -- check assumptions+ case (edata, layout) of+ (GEDHLayout hLayout, HorizontalLayout props) -> setP hLayout (_createProps props)+ (GEDVLayout vLayout, VerticalLayout props) -> setP vLayout (_createProps props)+ (GEDGridLayout gLayout, GridLayout x y props) -> setP gLayout (_createProps props)+ (GEDWindow window, Window n props) -> setP window (_createProps props)+ _ -> error "HGamer3D.GUI.Internal.Form._updateLayoutProps: update parameters not matching!"+ return ()+ +_createProps' :: (WidgetProperty -> GUIElement a -> IO ()) -> [WidgetProperty] -> [GUIElement a -> IO ()]+_createProps' addOn props = + let oneProp prop = case prop of+ XPos gd -> pX =: gd+ YPos gd -> pY =: gd+ Width gd -> pWidth =: gd+ Height gd -> pHeight =: gd+ Visible v -> pVisible =: v+ Alpha f -> pAlpha =: f+ Text t -> pText =: t+ Margin m -> pMargin =: m+ Tooltip t -> pTooltip =: t+ _ -> addOn prop+ in map oneProp props++_createProps = _createProps' (\w -> (const (return ())))++_createPropsCB :: [WidgetProperty] -> [GUIComboBox -> IO ()]+_createPropsCB props =+ let addOn prop = case prop of+ TextChoice tc -> pTextChoice =: tc+ _ -> const (return ())+ in _createProps' addOn props++_createPropsLB :: [WidgetProperty] -> [GUIListBox -> IO ()]+_createPropsLB props =+ let addOn prop = case prop of+ TextSelection ts -> pTextSelection =: ts+ _ -> const (return ())+ in _createProps' addOn props++_createPropsHV :: [WidgetProperty] -> [GUIHasValue a -> IO ()]+_createPropsHV props =+ let addOn prop = case prop of+ Value v -> pValue =: v+ _ -> const (return ())+ in _createProps' addOn props++_createPropsHS :: [WidgetProperty] -> [GUIHasSelection a -> IO ()]+_createPropsHS props =+ let addOn prop = case prop of+ Selected s -> pSelected =: s+ _ -> const (return ())+ in _createProps' addOn props++_createWidget :: GUISystem -> Widget -> String -> IO GUIEngineDataElement+_createWidget guis widget typename = do+ case widget of+ Button name props -> do+ w <- button guis typename (_createProps props)+ registerGUIEvent guis w "Clicked" name+ return (GEDSingleElement (GEDButton w name))+ RadioButton name props -> do+ w <- radioButton guis typename (_createPropsHS props)+ registerGUIEvent guis w "SelectStateChanged" name+ return (GEDSingleElement (GEDRadioButton w name))+ CheckBox name props -> do+ w <- checkBox guis typename (_createPropsHS props)+ registerGUIEvent guis w "CheckStateChanged" name+ return (GEDSingleElement (GEDCheckBox w name))+ ComboBox name props -> do+ w <- comboBox guis typename (_createPropsCB props)+ registerGUIEvent guis w "ListSelectionAccepted" name+ return (GEDSingleElement (GEDComboBox w name))+ ListBox name props -> do+ w <- listBox guis typename (_createPropsLB props)+ registerGUIEvent guis w "ItemSelectionChanged" name+ return (GEDSingleElement (GEDListBox w name))+ Spinner name props -> do+ w <- spinner guis typename (_createPropsHV props)+ registerGUIEvent guis w "ValueChanged" name+ return (GEDSingleElement (GEDSpinner w name))+ Slider name props -> do+ w <- slider guis typename (_createPropsHV props)+ registerGUIEvent guis w "ValueChanged" name+ return (GEDSingleElement (GEDSlider w name))+ EditText name props -> do+ w <- editText guis typename (_createProps props)+ registerGUIEvent guis w "TextAccepted" name+ registerGUIEvent guis w "TextChanged" name+ return (GEDSingleElement (GEDEditText w name))+ MultilineText name props -> do+ w <- multilineText guis typename (_createProps props)+ registerGUIEvent guis w "TextAccepted" name+ registerGUIEvent guis w "TextChanged" name+ return (GEDSingleElement (GEDMultilineText w name))++_updateWidgetProps :: GUIEngineDataElement -> Widget -> IO ()+_updateWidgetProps edata widget = do+ case (edata, widget) of+ (GEDSingleElement (GEDButton w _), Button name props) -> setP w (_createProps props)+ (GEDSingleElement (GEDRadioButton w _), RadioButton name props) -> setP w (_createPropsHS props)+ (GEDSingleElement (GEDCheckBox w _), CheckBox name props) -> setP w (_createPropsHS props)+ (GEDSingleElement (GEDComboBox w _), ComboBox name props) -> setP w (_createPropsCB props)+ (GEDSingleElement (GEDListBox w _), ListBox name props) -> setP w (_createPropsLB props)+ (GEDSingleElement (GEDSpinner w _), Spinner name props) -> setP w (_createPropsHV props)+ (GEDSingleElement (GEDSlider w _), Slider name props) -> setP w (_createPropsHV props)+ (GEDSingleElement (GEDEditText w _), EditText name props) -> setP w (_createProps props)+ (GEDSingleElement (GEDMultilineText w _), MultilineText name props) -> setP w (_createProps props)+ _ -> error "HGamer3D.GUI.Internal.Form._updateWidgetProps: update parameters not matching!"+ return ()++createForm :: GUISystem -> Form -> IO GUIEngineData+createForm guis form = do+ let (Form typename formcontent) = form+ + let createFormContent formcontent = do+ case formcontent of+ WidgetFC widget -> _createWidget guis widget typename+ LayoutFC layout formList -> do+ layoutW <- _createLayout guis layout typename+ widgetsW <- mapM createFormContent formList+ let cl = GEDCombinedElement layoutW widgetsW+ mapM (\f -> addChildGuiEl (_getWidget cl) (_getWidget f)) widgetsW+ return $ cl+ + formW <- createFormContent formcontent+ addGuiElToDisplay guis (_getWidget formW)+ return $ GUIEngineData formW form++getFormValues :: GUIEngineData -> IO [(String, FormValue)]+getFormValues (GUIEngineData elem form) = do++ let addTo oldList n con = return . (flip (:)) oldList . (,) n . con+ + let getItem oldList eitem = case eitem of+ GEDSingleElement widget -> case widget of+ GEDButton w n -> return ( (n, FVE) : oldList)+ GEDRadioButton w n -> getP w pSelected >>= addTo oldList n FVB+ GEDCheckBox w n -> getP w pSelected >>= addTo oldList n FVB+ GEDComboBox w n -> getP w pText >>= addTo oldList n FVS+ GEDListBox w n -> getP w pTextSelection >>= addTo oldList n FVTS+ GEDSpinner w n -> getP w pValue >>= addTo oldList n FVF+ GEDSlider w n -> getP w pValue >>= addTo oldList n FVF+ GEDEditText w n -> getP w pText >>= addTo oldList n FVS+ GEDMultilineText w n -> getP w pText >>= addTo oldList n FVS++ let foldEitems oldList eitem = case eitem of+ GEDSingleElement widget -> getItem oldList eitem+ GEDCombinedElement _ widgetList -> foldM foldEitems oldList widgetList+ + foldEitems [] elem++_getFormStructure :: Form -> [String]+_getFormStructure (Form typename content) = + + let getItem oldList eitem = case eitem of+ WidgetFC widget -> case widget of+ Button n _ -> ("Button/" ++ n) : oldList+ RadioButton n _ -> ("RadioButton/" ++ n) : oldList+ CheckBox n _ -> ("CheckBox/" ++ n) : oldList+ ComboBox n _ -> ("ComboBox/" ++ n) : oldList+ ListBox n _ -> ("ListBox/" ++ n) : oldList+ Spinner n _ -> ("Spinner/" ++ n) : oldList+ Slider n _ -> ("Slider/" ++ n) : oldList+ EditText n _ -> ("EditText/" ++ n) : oldList+ MultilineText n _ -> ("MultilineText/" ++ n) : oldList+ LayoutFC layout itemList -> let+ subList = foldl getItem [] itemList+ in case layout of+ VerticalLayout props -> ["VLStart"] ++ subList ++ ["VLEnd"] ++ oldList+ HorizontalLayout props -> ["HLStart"] ++ subList ++ ["HLEnd"] ++ oldList+ GridLayout _ _ props -> ["GridStart"] ++ subList ++ ["GridEnd"] ++ oldList+ Window n props -> ["WStart"] ++ subList ++ ["WEnd"] ++ oldList+ + in getItem [typename] content+++setFormValues :: GUIEngineData -> [(String, FormValue)] -> IO ()+setFormValues (GUIEngineData elem form) valueList = do++ let filterItemSet w n prop valueList = do+ case filter (\(name, value) -> name == n) valueList of+ [] -> return ()+ ((n', v') : _) -> do+ setP w [prop v']+ return ()+ + let setItem valueList eitem = case eitem of+ GEDSingleElement widget -> case widget of+ GEDButton w n -> return ()+ GEDRadioButton w n -> filterItemSet w n (\v -> let (FVB v') = v in pSelected =: v') valueList+ GEDCheckBox w n -> filterItemSet w n (\v -> let (FVB v') = v in pSelected =: v') valueList+ GEDComboBox w n -> filterItemSet w n (\v -> let (FVS v') = v in pText =: v') valueList+ GEDListBox w n -> filterItemSet w n (\v -> let (FVTS v') = v in pTextSelection =: v') valueList+ GEDSpinner w n -> filterItemSet w n (\v -> let (FVF v') = v in pValue =: v') valueList+ GEDSlider w n -> filterItemSet w n (\v -> let (FVF v') = v in pValue =: v') valueList+ GEDEditText w n -> filterItemSet w n (\v -> let (FVS v') = v in pText =: v') valueList+ GEDMultilineText w n -> filterItemSet w n (\v -> let (FVS v') = v in pText =: v') valueList+ GEDCombinedElement _ widgetList -> mapM (setItem valueList) widgetList >> return ()++ setItem valueList elem+ return ()++removeForm :: GUISystem -> GUIEngineData -> IO ()+removeForm guis form = do+ let (GUIEngineData elem schema) = form+ + -- first detach from screen+ removeGuiElFromDisplay guis (_getWidget elem)++ -- then delete the elements in order+ let deleteSingleItem elem = case elem of+ GEDSingleElement w -> deleteGuiEl guis (_getWidget elem)+ GEDCombinedElement layout widgetList -> do+ -- remove childs from parent, then delete+ mapM (\el -> removeChildGuiEl (_getWidget elem) (_getWidget el)) widgetList+ mapM deleteSingleItem widgetList+ deleteGuiEl guis (_getWidget elem)++ deleteSingleItem elem+ return ()+++-- update form with same structure, apply properties again for all elements, which are different+_updateFormElement :: GUISystem -> GUIEngineDataElement -> FormContent -> FormContent -> IO ()+_updateFormElement guis elem oldFC newFC = do+ case (elem, oldFC, newFC) of+ (GEDSingleElement w, WidgetFC (Button _ oldProps), WidgetFC wid@(Button _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDSingleElement w, WidgetFC (RadioButton _ oldProps), WidgetFC wid@(RadioButton _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDSingleElement w, WidgetFC (CheckBox _ oldProps), WidgetFC wid@(CheckBox _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDSingleElement w, WidgetFC (ComboBox _ oldProps), WidgetFC wid@(ComboBox _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDSingleElement w, WidgetFC (ListBox _ oldProps), WidgetFC wid@(ListBox _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDSingleElement w, WidgetFC (Spinner _ oldProps), WidgetFC wid@(Spinner _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDSingleElement w, WidgetFC (Slider _ oldProps), WidgetFC wid@(Slider _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDSingleElement w, WidgetFC (EditText _ oldProps), WidgetFC wid@(EditText _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDSingleElement w, WidgetFC (MultilineText _ oldProps), WidgetFC wid@(MultilineText _ newProps)) -> do+ if oldProps /= newProps then _updateWidgetProps elem wid else return ()+ (GEDCombinedElement layout elems, LayoutFC oldLayout oldContentList, LayoutFC newLayout newContentList) -> do+ if oldLayout /= newLayout then _updateLayoutProps layout newLayout else return ()+ mapM (\(elem, oldContent, newContent) -> _updateFormElement guis elem oldContent newContent) (zip3 elems oldContentList newContentList)+ return ()+ +++updateForm :: GUISystem -> GUIEngineData -> Form -> IO GUIEngineData+updateForm guis edata form = do+ -- check if different structure, then redo+ let ed@(GUIEngineData elem oldForm) = edata+ if (_getFormStructure oldForm) /= (_getFormStructure form) then do+ removeForm guis ed+ createForm guis form+ -- if structure is the same, only update properties+ else do+ let (Form typename content) = form+ let (Form typename oldContent) = oldForm+ _updateFormElement guis elem oldContent content+ return edata+++++++++
+ HGamer3D/Graphics3D/GUISchema.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveDataTypeable, 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.++-- | Types which describe the GUI Schema Types+module HGamer3D.Graphics3D.GUISchema+where++import Data.Typeable+import HGamer3D.Data as Dat++{- ----------------------------------------------------------------+ GUI Dimensions+ ---------------------------------------------------------------- -}++data GUIDim = GUIDim {+ gdScale :: Float,+ gdOffset :: Float + } deriving (Eq, Show, Typeable)++data GUIVec2 = GUIVec2 {+ gv2X :: GUIDim,+ gv2Y :: GUIDim +}++{- ----------------------------------------------------------------+ GUI Layout+ ---------------------------------------------------------------- -}++data Layout = VerticalLayout [WidgetProperty]+ | HorizontalLayout [WidgetProperty]+ | GridLayout Int Int [WidgetProperty]+ | Window String [WidgetProperty]+ deriving (Eq, Show, Typeable)+++{- ----------------------------------------------------------------+ GUI Widget+ ---------------------------------------------------------------- -}++-- | The data to specify a widget+data Widget = Button String [WidgetProperty]+ | RadioButton String [WidgetProperty]+ | CheckBox String [WidgetProperty]+ | ComboBox String [WidgetProperty]+ | ListBox String [WidgetProperty]+ | EditText String [WidgetProperty]+ | MultilineText String [WidgetProperty]+ | Spinner String [WidgetProperty]+ | Slider String [WidgetProperty]+ deriving (Eq, Show, Typeable)++-- | Widget Properties+data WidgetProperty = XPos GUIDim+ | YPos GUIDim+ | Width GUIDim+ | Height GUIDim+ | Visible Bool+ | Alpha Float+ | Text String+ | Margin GUIDim+ | Tooltip String+ | TextChoice [String] -- only ComboBox+ | TextSelection [(String, Bool)] -- only ListBox+ | Value Float -- only Spinner, Slider+ | Selected Bool -- only CheckBox, RadioButton+ deriving (Eq, Show, Typeable)++{- ----------------------------------------------------------------+ GUI Form+ ---------------------------------------------------------------- -}++data Form = Form String FormContent deriving (Eq, Show, Typeable)++data FormContent = WidgetFC Widget+ | LayoutFC Layout [FormContent]+ deriving (Eq, Show, Typeable)+ +data FormValue = FVF Float+ | FVS String+ | FVTC [String] -- Text Choice+ | FVTS [(String, Bool)] -- Text Selection+ | FVB Bool+ | FVE -- Empty+ deriving (Eq, Show, Typeable)
+ HGamer3D/Graphics3D/GameLoop.hs view
@@ -0,0 +1,93 @@+{-# 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.althainz.de/HGamer3D.html+--+-- (c) 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.++-- HGamer3D/Internal/GameLoop Module+--++-- | HGamer3D - A game engine for the Haskell Programmer, this module includes the implementation of the gameloop and initialization routines. This is an internal module, the public API is in HGamer3D.BaseAPI.+module HGamer3D.Graphics3D.GameLoop++(+ HG3DEvent (..),+ + initHGamer3D,+ freeHGamer3D,+ stepHGamer3D,+ + ) where++ import HGamer3D.Data+ import HGamer3D.Common++ import HGamer3D.Graphics3D.Graphics3DBase+ import HGamer3D.Graphics3D.WinEvent+ import HGamer3D.Graphics3D.GUIBase+ import HGamer3D.Graphics3D.Event++ import qualified System.Info as SI++ freeHGamer3D :: Graphics3DSystem -> GUISystem -> IO ()+ freeHGamer3D g3ds guis = do + freeGraphics3D g3ds+++ -- | Game Loop+ -- The game loop works in a way, that window events are much faster processed then + -- update of rendering -> all events needs to be cleared, then next renderOneFrame is processed+ -- after that the call returns.+ stepHGamer3D :: Graphics3DSystem -- ^ the Graphics System+ -> GUISystem -- ^ the GUI System+ -> GameTime -- ^ last time called+ -> IO ([HG3DEvent], GameTime, Bool) -- ^ list of Events received, quit flag (True if quit received)+ + stepHGamer3D g3ds guis lastTime = do++ now <- getTime+ let tdiff = now - lastTime+ injectGUITimeDelta guis tdiff+ let getEvents evts = do+ mWinEvt <- pollWinEvent+ case mWinEvt of+ Just winEvt -> do+ injectWinEventToGUI guis winEvt -- inject event into gui+ getEvents (evts ++ [WindowEvt winEvt])+ Nothing -> do+ mGuiEvt <- pollGUIEvent guis+ case mGuiEvt of+ Just guiEvt -> getEvents (evts ++ [GUIEvt guiEvt])+ Nothing -> return evts++ qFlag <- stepGraphics3D g3ds+ events <- getEvents []+ + return (events, now, qFlag)+ + initHGamer3D :: String -- ^ Window Title+ -> Bool -- ^ Flag show config dialogue+ -> Bool -- ^ Flag logging enabled+ -> Bool -- ^ show Graphics Cursor+ -> IO (Graphics3DSystem, GUISystem, GameTime)+ initHGamer3D windowTitle fConfigDialogue fLog fGraphicsCursor = do+ success <- initWinEvent [WEV_INIT_EVENTS, WEV_INIT_TIMER, WEV_INIT_VIDEO]+ (g3ds, window) <- initGraphics3D windowTitle "DefaultSceneManager" fConfigDialogue fLog+ win <- attachToWindow window+ guis <- initGUI fLog fGraphicsCursor+ now <- getTime+ return (g3ds, guis, now)
+ HGamer3D/Graphics3D/Graphics3DBase.hs view
@@ -0,0 +1,1016 @@+{-# Language FlexibleInstances #-}+{-# 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.++module HGamer3D.Graphics3D.Graphics3DBase +where++import HGamer3D.Data+import HGamer3D.Common++import HGamer3D.Data.HG3DClass+import HGamer3D.Data.Window+++import qualified HGamer3D.Bindings.Ogre.ClassRoot as Root+import HGamer3D.Bindings.Ogre.ClassCamera as Camera+import HGamer3D.Bindings.Ogre.ClassLight as Light+import HGamer3D.Bindings.Ogre.ClassNode as Node+import HGamer3D.Bindings.Ogre.ClassSceneManager as SceneManager+import HGamer3D.Bindings.Ogre.ClassResourceGroupManager as ResourceGroupManager+import HGamer3D.Bindings.Ogre.ClassTextureManager as TextureManager+import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager+import HGamer3D.Bindings.Ogre.ClassViewport as Viewport+import HGamer3D.Bindings.Ogre.ClassFrustum as Frustum+import HGamer3D.Bindings.Ogre.ClassAnimationState as AnimationState+import HGamer3D.Bindings.Ogre.ClassEntity as Entity+import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager+import HGamer3D.Bindings.Ogre.ClassLogManager as LogManager+import HGamer3D.Bindings.Ogre.ClassLog as Log+import HGamer3D.Bindings.Ogre.ClassHG3DUtilities as Util+import HGamer3D.Bindings.Ogre.ClassRenderTarget as RenderTarget+import HGamer3D.Bindings.Ogre.ClassManualObject as ManualObject+import HGamer3D.Bindings.Ogre.EnumRenderOperationOperationType+import HGamer3D.Bindings.Ogre.StructHG3DClass+import HGamer3D.Bindings.Ogre.EnumSceneManagerPrefabType+import HGamer3D.Bindings.Ogre.EnumLightType+import HGamer3D.Bindings.Ogre.ClassWindowEventUtilities as WindowEventUtilities+import HGamer3D.Bindings.Ogre.ClassSceneNode as SceneNode++import Control.Monad+import Control.Monad.Trans+import Control.Monad.IO.Class+import Control.Monad.State.Class+import qualified System.Info as SI++import Control.Concurrent+import Data.Maybe++import qualified HGamer3D.Graphics3D.Graphics3DSchema as Sc++{- ----------------------------------------------------------------+ Basic Data Types+ ---------------------------------------------------------------- -}++data SceneManager = SceneManager HG3DClass+data ResourceGroupManager = ResourceGroupManager HG3DClass+data RootObject = RootObject HG3DClass+data TextureManager = TextureManager HG3DClass+data LogManager = LogManager HG3DClass+data RenderTarget = RenderTarget HG3DClass++-- | This data type holds the internal pointers to implementation objects and some additional state+-- like a unique name generator for implementation purposes.+data Graphics3DSystem = Graphics3DSystem {+ g3dsRoot :: RootObject,+ g3dsSceneManager :: SceneManager,+ g3dsResourceGroupManager :: ResourceGroupManager,+ g3dsLogManager :: LogManager,+ g3dsTextureManager :: TextureManager,+ g3dsRenderTarget :: RenderTarget,+ g3dsUniqueName :: UniqueName+}+++{- ----------------------------------------------------------------+ Initialization and Runtime+ ---------------------------------------------------------------- -}+++-- | initializes the 3d graphics module+initGraphics3D :: String -- ^ Name of the window, displayed+ -> String -- ^ SceneManager type used+ -> Bool -- ^ flag, show configuration dialogue+ -> Bool -- ^ flag, is logging enabled+ -> IO (Graphics3DSystem, Window)+ +initGraphics3D windowName sceneManagerType fConfig fLog = do++ -- configuration path can be app user dir or local dir+ appDir <- getAppConfigDirectory+ configFile <- findFileInDirs "engine.cfg" [appDir]+ pluginsFile <- findFileInDirs "plugins.cfg" [appDir]+ + -- check both files exists+ let config = case configFile of+ Just cf -> cf+ Nothing -> error $ "HGamer3D - Graphics3D: could not find engine configuration file engine.cfg"+ + let plugins = case pluginsFile of+ Just pf -> pf+ Nothing -> error $ "HGamer3D - Graphics3D: could not find plugins configuration file plugins.cfg"+ + root <- Root.new plugins config ""+ lmgr <- LogManager.getSingletonPtr+ if not fLog then do+ newlog <- LogManager.createLog lmgr "SilentLog" True False True+ return ()+ else do+ newlog <- LogManager.createLog lmgr "hgamer3d-engine.log" True False False+ return ()+ + fOk <- if fConfig then+ Root.showConfigDialog root+ else do+ fLoaded <- Root.restoreConfig root+ if not fLoaded then+ Root.showConfigDialog root+ else+ return True+ + +-- fUAddResourceLocations "resources.cfg"+ renderWindow <-Root.initialise root True windowName ""+ setupCloseEventHandler renderWindow+ windowHandle <- Util.getWindowHandle renderWindow+ + -- Suppress logging unless, fLog+ + sceneManager <- Root.createSceneManager root sceneManagerType "SceneManager"+{- + camera <- SceneManager.createCamera sceneManager "SimpleCamera"+ Frustum.setNearClipDistance camera 5.0+ Frustum.setFarClipDistance camera 5000.0+ ++ viewport <- RenderTarget.addViewport renderWindow camera 0 0.0 0.0 1.0 1.0+ let bgColor = Colour 0.0 0.0 0.0 1.0+ Viewport.setBackgroundColour viewport bgColor+ + height <- Viewport.getActualHeight viewport+ width <- Viewport.getActualWidth viewport+ + Frustum.setAspectRatio camera ((fromIntegral width) / (fromIntegral height))+-} + tm <- TextureManager.getSingletonPtr+ TextureManager.setDefaultNumMipmaps tm 20+ + -- resource locations, if path given, use this as base, if not use standard locations+ + rgm <- ResourceGroupManager.getSingletonPtr+ + ResourceGroupManager.createResourceGroup rgm "Schemes" False+ ResourceGroupManager.createResourceGroup rgm "Imagesets" False+ ResourceGroupManager.createResourceGroup rgm "Fonts" False+ ResourceGroupManager.createResourceGroup rgm "Layouts" False+ ResourceGroupManager.createResourceGroup rgm "Meshes" False+ ResourceGroupManager.createResourceGroup rgm "LookNFeel" False+ ResourceGroupManager.createResourceGroup rgm "LuaScripts" False+ ResourceGroupManager.createResourceGroup rgm "XMLSchemas" False+ + mediapath1 <- getAppMediaDirectory+ -- mediapath2 <- getExeMediaDirectory+ + mapM (\mediapath -> do+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "materials") "FileSystem" "General" False+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "schemes") "FileSystem" "Schemes" False+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "imagesets") "FileSystem" "Imagesets" False+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "fonts") "FileSystem" "Fonts" False+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "layouts") "FileSystem" "Layouts" False+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "meshes") "FileSystem" "Meshes" False+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "looknfeel") "FileSystem" "LookNFeel" False+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "lua_scripts") "FileSystem" "LuaScripts" False+ ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "xml_schemas") "FileSystem" "XMLSchemas" False+ return ()) [mediapath1]+ ++ ResourceGroupManager.initialiseAllResourceGroups rgm+ uniqueName <- createUniqueName "HG3DObj"+ + return $ (Graphics3DSystem (RootObject root) (SceneManager sceneManager) (ResourceGroupManager rgm) (LogManager lmgr) (TextureManager tm) (RenderTarget renderWindow) uniqueName, (Window windowHandle)) +++-- | steps the game loop by one tick, renders a frame and handles system messages+stepGraphics3D :: Graphics3DSystem -- ^ the graphics3d system+ -> IO Bool -- ^ quit flag, true if window closed+stepGraphics3D g3ds = do+ renderOneFrame g3ds+ -- this one is quite tricky, on Linux we need to call the message loop in addition to WinEvent!+ if SI.os /= "mingw32" then graphics3DPumpWindowMessages else return ()+ graphics3DPumpWindowMessages+ i <- checkQuitReceived+ return (i == 1)++-- | frees resources and shutdown the Graphics3D sub-system+freeGraphics3D :: Graphics3DSystem -> IO ()+freeGraphics3D g3ds = do+ let (RootObject root) = g3dsRoot g3ds+ let (RenderTarget rt) = g3dsRenderTarget g3ds+ Root.destroyRenderTarget root rt+ Root.delete root+ return ()++-- | adds a resource location for 3D media (Ogre)+addResourceLocationMedia :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D+ -> String -- ^ path to new resource location, the path should identify a directory+ -> IO ()+addResourceLocationMedia g3ds path = do+ let (ResourceGroupManager rgm) = (g3dsResourceGroupManager g3ds)+ ResourceGroupManager.addResourceLocation rgm path "FileSystem" "General" False+ ResourceGroupManager.initialiseResourceGroup rgm "General"++-- | adds a resource location for 3D media (Ogre) which is a zip file+addResourceZipfileMedia :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D + -> String -- ^ path to new resource location, the path should identify a zip file+ -> IO ()+addResourceZipfileMedia g3ds path = do+ let (ResourceGroupManager rgm) = (g3dsResourceGroupManager g3ds)+ ResourceGroupManager.addResourceLocation rgm path "Zip" "General" False+ ResourceGroupManager.initialiseResourceGroup rgm "General"++-- | adds a resource location for GUI media (CEGUI) which is a directory+addResourceLocationGUI :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D+ -> String -- ^ path to the directory with the GUI media in it+ -> String -- ^ category of GUI media, for example: Layout, Images, ...+ -> IO ()+addResourceLocationGUI g3ds path category = do+ let (ResourceGroupManager rgm) = (g3dsResourceGroupManager g3ds)+ ResourceGroupManager.addResourceLocation rgm path "FileSystem" category False+ ResourceGroupManager.initialiseResourceGroup rgm category++-- | pump window messages for graphics+-- Not to be used, if WinEvent pollWinEvent or pumpWinEvents is used!+graphics3DPumpWindowMessages :: IO ()+graphics3DPumpWindowMessages = do+ WindowEventUtilities.messagePump+ return ()++-- | renders one frame on the screen+renderOneFrame :: Graphics3DSystem -> IO ()+renderOneFrame g3ds = do + let (RootObject root) = g3dsRoot g3ds+ Root.renderOneFrame root+ return ()++{- ----------------------------------------------------------------+ Camera+ ---------------------------------------------------------------- -}++-- | Camera, internal data object for engine+data Camera = Camera {+ cameraCamObject :: HG3DClass,+ cameraViewportObject :: HG3DClass,+ cameraSchema :: Sc.Camera+ }++-- | add a camera, you probably want to do this at least once+addCamera :: Graphics3DSystem -- ^ the graphics system+ -> Sc.Camera -- ^ the Schema data for the camera+ -> IO Camera -- ^ the resulting engine object+addCamera g3ds schema = do+ let (SceneManager sceneManager) = g3dsSceneManager g3ds+ let uname = g3dsUniqueName g3ds+ let (RenderTarget renderWindow) = g3dsRenderTarget g3ds+ let Sc.Camera (Sc.Frustum nd fd fov) (Sc.Viewport z pos bgr) = schema+ -- create camera+ cameraName <- (nextUniqueName uname) >>= (\n -> return ("Camera"++n))+ camera <- SceneManager.createCamera sceneManager cameraName+ -- add Viewport+ viewport <- RenderTarget.addViewport renderWindow camera z (rectX pos) (rectY pos) (rectWidth pos) (rectHeight pos)+ -- set Viewport parameters+ Viewport.setBackgroundColour viewport bgr+ -- set Frustum parameters+ Frustum.setNearClipDistance camera nd+ Frustum.setFarClipDistance camera fd+ Frustum.setFOVy camera (fromAngle fov)+ -- create camera return value+ let cam = Camera camera viewport schema+ -- adapt aspect ratio+ cameraAdaptAspectRatio cam++ return cam++-- | remove a camera +removeCamera :: Graphics3DSystem -> Camera -> IO ()+removeCamera g3ds (Camera camera viewport schema) = do+ let (SceneManager sceneManager) = g3dsSceneManager g3ds+ let (RenderTarget renderWindow) = g3dsRenderTarget g3ds+ let Sc.Camera (Sc.Frustum nd fd fov) (Sc.Viewport z pos bgr) = schema+ RenderTarget.removeViewport renderWindow z+ SceneManager.destroyCamera sceneManager camera++-- | update an existing camera with new parameters+updateCamera :: Graphics3DSystem -> Camera -> Sc.Camera -> IO Camera+updateCamera g3ds cam@(Camera camera viewport schema) schema' = do+ + let Sc.Camera (Sc.Frustum nd fd fov) (Sc.Viewport z pos bgr) = schema+ let Sc.Camera (Sc.Frustum nd' fd' fov') (Sc.Viewport z' pos' bgr') = schema'+ -- if zorder or position are not equal, we need to rebuild+ if (z /= z') || (pos /= pos') then do+ removeCamera g3ds cam+ addCamera g3ds schema'+ else do+ -- adapt single values, as needed+ if nd /= nd' then Frustum.setNearClipDistance camera nd' else return ()+ if fd /= fd' then Frustum.setFarClipDistance camera fd' else return ()+ if fov /= fov' then Frustum.setFOVy camera (fromAngle fov') else return ()+ if bgr /= bgr' then Viewport.setBackgroundColour viewport bgr' else return ()+ return (Camera camera viewport schema')+ +-- | adapt the aspect ration, in case the window size and aspect ratio changes, this+-- is called inside the engine automatically.+cameraAdaptAspectRatio :: Camera -> IO ()+cameraAdaptAspectRatio cam = do+ let (Camera camera viewport schema) = cam+ height <- Viewport.getActualHeight viewport+ width <- Viewport.getActualWidth viewport+ Frustum.setAspectRatio camera ((fromIntegral width) / (fromIntegral height))+ return ()+ +instance HasPosition Camera where+ position (Camera c _ _) = Camera.getPosition c+ positionTo (Camera c _ _) pos = Camera.setPosition2 c pos+ +instance HasOrientation Camera where+ orientation (Camera c _ _) = do+ q <- Camera.getOrientation c+ let uq = mkNormal q+ return uq+ orientationTo (Camera c _ _) uq = do+ Camera.setOrientation c (fromNormal uq)+ return ()++-- | set the direction in a way, that the camera looks toward a specified point+cameraLookAt :: Camera -> Vec3 -> IO ()+cameraLookAt (Camera c _ _) v = do+ Camera.lookAt c v+ return ()++-- | Background colour of the 3d drawing window+setBackgroundColour :: Graphics3DSystem -> Camera -> Colour -> IO Camera+setBackgroundColour g3ds cam@(Camera camera viewport schema) bgColour = do+ let Sc.Camera (Sc.Frustum nd fd fov) (Sc.Viewport z pos bgr) = schema+ let schema' = Sc.Camera (Sc.Frustum nd fd fov) (Sc.Viewport z pos bgColour)+ updateCamera g3ds cam schema'++{- ----------------------------------------------------------------+ Light+ ---------------------------------------------------------------- -}++-- | The light.+data Light = Light ONode OLight Sc.Light++instance HasNode Light where+ getNode (Light node _ _) = node++instance HasPosition Light where+ position obj = Node.getPosition (getNode' obj)+ positionTo obj pos = Node.setPosition (getNode' obj) pos+ +instance HasOrientation Light where+ orientation obj = do+ q <- Node.getOrientation (getNode' obj)+ let uq = mkNormal q+ return uq+ orientationTo obj uq = do+ Node.setOrientation (getNode' obj) (fromNormal uq)+ return ()++addLight :: Graphics3DSystem -> Sc.Light -> IO Light+addLight g3ds schema = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ let (Sc.Light diffuse@(Colour r g b _) specular@(Colour r' g' b' _) ltype) = schema+ lightName <- nextUniqueName (g3dsUniqueName g3ds)+ light <- SceneManager.createLight scm lightName+ Light.setDiffuseColour light r g b + Light.setSpecularColour light r' g' b' + case ltype of + Sc.PointLight -> Light.setType light LT_POINT+ Sc.DirectionalLight dir -> do+ Light.setType light LT_DIRECTIONAL+ Light.setDirection2 light dir+ Sc.SpotLight dir inner outer -> do+ Light.setType light LT_SPOTLIGHT+ Light.setDirection2 light dir+ Light.setSpotlightInnerAngle light (fromAngle inner)+ Light.setSpotlightOuterAngle light (fromAngle outer)+ let l = OL light+ rn <- _getRootNode g3ds+ n <- _createSubNode rn+ attachToNode l n+ return $ Light n l schema++removeLight :: Graphics3DSystem -> Light -> IO ()+removeLight g3ds (Light n@(ON node) l@(OL light) schema) = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ detachFromNode l n+ (ON rn) <- _getRootNode g3ds+ Node.removeChild2 rn node+ SceneManager.destroyLight2 scm light ++updateLight :: Graphics3DSystem -> Light -> Sc.Light -> IO Light+updateLight g3ds l schema = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ removeLight g3ds l+ addLight g3ds schema+ +-- | Ambient light is present everywhere, this function creates it and sets the colour of it.+-- There is no light object, since movement, rotation, scaling would make no sense anyhow.+setAmbientLight :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D+ -> Colour -> IO () +setAmbientLight g3ds colour = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ SceneManager.setAmbientLight scm colour++-- | creates a point light at a specific location+pointLight :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D+ -> Colour -- ^ diffuse Color of the light+ -> Colour -- ^ specular Color of the light+ -> Vec3 -- ^ Position, where light is created+ -> IO (Light) -- ^ The light object+pointLight g3ds diffuse specular pos = do+ let schema = Sc.Light diffuse specular Sc.PointLight+ light <- addLight g3ds schema+ positionTo light pos+ return $ light++-- | creates a spot light at a specific location+spotLight :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D+ -> Colour -- ^ diffuse Colour of the light+ -> Colour -- ^ specular Colour of the light+ -> Vec3 -- ^ Position, where light is created+ -> Vec3 -- ^ Direction, where light points+ -> Angle -- ^ inner Angle of cone (5..355 degrees)+ -> Angle -- ^ outer Angle of cone (5..355 degrees)+ -> IO Light -- ^ The light object+spotLight g3ds diffuse specular pos dir inner outer = do+ let schema = Sc.Light diffuse specular (Sc.SpotLight dir inner outer)+ light <- addLight g3ds schema+ positionTo light pos+ return $ light++-- | sets spotlight direction+spotLightSetDirection :: Graphics3DSystem -> Light -> Vec3 -> IO Light+spotLightSetDirection g3ds light dir' = do+ let (Light n l schema) = light+ let (Sc.Light diffuse@(Colour r g b _) specular@(Colour r' g' b' _) ltype) = schema+ case ltype of+ (Sc.SpotLight dir inner outer) -> updateLight g3ds light (Sc.Light diffuse specular (Sc.SpotLight dir' inner outer))+ _ -> return light++-- | creates a directional light at a specific location+directionalLight :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D+ -> Colour -- ^ diffuse Colour of the light+ -> Colour -- ^ specular Colour of light+ -> Vec3 -- ^ direction of light+ -> IO (Light) -- ^ The light object+directionalLight g3ds diffuse specular dir = do+ let schema = Sc.Light diffuse specular (Sc.DirectionalLight dir)+ light <- addLight g3ds schema+ return $ light+++{- -------------------------------------------------------------------------------+ Implemnentation for Platon Geometries+ ------------------------------------------------------------------------------- -}+++vminus = Vec3 (-1.0) (-1.0) (-1.0)++getNormOfFace vertices (a, b, c) = normalize cross+ where + v1 = vertices !! a+ v2 = vertices !! b+ v3 = vertices !! c + cross = (v2 &- v1) `crossprod` (v3 &- v1)+ ++isIn (a, b, c) n = if n == a then True else + if n == b then True else+ if n == c then True else+ False+++_createPlatonObject :: Graphics3DSystem -> Colour -> [Vec3] -> [(Int, Int, Int)] -> Int -> IO HG3DClass+_createPlatonObject g3ds colour vertices faces iColor = do++ let (SceneManager scm) = (g3dsSceneManager g3ds)+ uid <- nextUniqueName (g3dsUniqueName g3ds)++ mo <- SceneManager.createManualObject scm uid+ -- set Dynamic to false+ ManualObject.setDynamic mo False++ let normsOfFaces = map (getNormOfFace vertices) faces+ + let vzero = Vec3 0.0 0.0 0.0 + + let normsOfVertices = map vnorm allVerticesIndexes+ where + allVerticesIndexes = [ i | i <- [0..(length vertices)]] + vnorm = (\i -> normalize $ foldr (&+) vzero (map (\face -> if isIn face i then normsOfFaces !! i else vzero) faces))++ sequence $ map (\((x,y,z), norm) -> do+ ManualObject.begin mo "BaseWhiteNoLightning" OT_TRIANGLE_LIST "General"+ ManualObject.position mo (vertices !! x)+ ManualObject.normal mo norm+ ManualObject.position mo (vertices !! y)+ ManualObject.position mo (vertices !! z)+ ManualObject.triangle mo 0 1 2+ ManualObject.end mo) (zip faces normsOfFaces)++ return mo+ ++-- | create an ikoaeder mesh - from the mesh more objects can be created+ikosaederE :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D+ -> Colour -- ^ colour of the ikosaeder+ -> IO HG3DClass -- ^ created mesh object as entity+ikosaederE g3ds colour = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ uid <- nextUniqueName (g3dsUniqueName g3ds)++ let bodyName = "B" ++ uid+ let meshName = "M" ++ uid+ + let x = 0.525731112119133606+ let z = 0.850650808352039932+ + let vertices = [+ ( Vec3 (-x) 0.0 z),+ ( Vec3 x 0.0 z),+ ( Vec3 (-x) 0.0 (-z)),+ ( Vec3 x 0.0 (-z)),+ ( Vec3 0.0 z x), + ( Vec3 0.0 z (-x)), + ( Vec3 0.0 (-z) x), + ( Vec3 0.0 (-z) (-x)),+ ( Vec3 z x 0.0),+ ( Vec3 (-z) x 0.0), + ( Vec3 z (-x) 0.0),+ ( Vec3 (-z) (-x) 0.0)+ ]+ + let faces = [++ (0,4,1), (0,9,4), (9,5,4), (4,5,8), (4,8,1), + (8,10,1), (8,3,10), (5,3,8), (5,2,3), (2,7,3),+ (7,10,3), (7,6,10), (7,11,6), (11,0,6), (0,1,6),+ (6,1,10), (9,0,11), (9,11,2), (9,2,5), (7,2,11)+ + ]+ + mo <- _createPlatonObject g3ds colour vertices faces 0+ ManualObject.convertToMesh mo meshName "General"+ entity <- SceneManager.createEntity3 scm meshName+ return $ entity+ ++-- | create a dodekaeder mesh+dodekaederE :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D+ -> Colour -- ^ colour of the dodekaeder+ -> IO HG3DClass -- ^ created dodekaeder mesh as entity+dodekaederE g3ds colour = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ uid <- nextUniqueName (g3dsUniqueName g3ds)++ let bodyName = "B" ++ uid+ let meshName = "M" ++ uid+ + let s = 0.618034+ let t = 1.618034++ + let vertices = [+ + (Vec3 1.0 1.0 1.0), + (Vec3 1.0 1.0 (-1.0)), + (Vec3 1.0 (-1.0) 1.0), + (Vec3 1.0 (-1.0) (-1.0)), + (Vec3 (-1.0) 1.0 1.0), + (Vec3 (-1.0) 1.0 (-1.0)), + (Vec3 (-1.0) (-1.0) 1.0), + (Vec3 (-1.0) (-1.0) (-1.0)), + (Vec3 s t 0.0),+ (Vec3 (-s) t 0.0), + (Vec3 s (-t) 0.0),+ (Vec3 (-s) (-t) 0.0), + (Vec3 t 0.0 s), + (Vec3 t 0.0 (-s)),+ (Vec3 (-t) 0.0 s), + (Vec3 (-t) 0.0 (-s)), + (Vec3 0.0 s t),+ (Vec3 0.0 (-s) t), + (Vec3 0.0 s (-t)), + (Vec3 0.0 (-s) (-t))++ ]+ + let faces = [+ +-- (1,8,0,12,13), (4, 9, 5, 15, 14), +-- (2, 10, 3, 13, 12), (7, 11, 6, 14, 15), +-- (2, 12, 0, 16, 17), (1, 13, 3, 19, 18),+-- (4, 14, 6, 17, 16), (7, 15, 5, 18, 19),+-- (4, 16, 0, 8, 9), (2, 17, 6, 11, 10),+-- (1, 18, 5, 9, 8), (7, 19, 3, 10, 11)+ + (1,8,0,12,13), (4, 9, 5, 15, 14), + (2, 10, 3, 13, 12), (7, 11, 6, 14, 15), + (2, 12, 0, 16, 17), (1, 13, 3, 19, 18),+ (4, 14, 6, 17, 16), (7, 15, 5, 18, 19),+ (4, 16, 0, 8, 9), (2, 17, 6, 11, 10),+ (1, 18, 5, 9, 8), (7, 19, 3, 10, 11)+ + ]+ + let faces2 = foldl (++) [] $ map ( \(a, b, c, d, e) -> [ (a, b, e), (b, d, e), (c, d, b) ] ) faces++ mo <- _createPlatonObject g3ds colour vertices faces2 0+ ManualObject.convertToMesh mo meshName "General"+ entity <- SceneManager.createEntity3 scm meshName+ return $ entity++ +{- -------------------------------------------------------------------------------+ EngineItem for Geometry+ ------------------------------------------------------------------------------- -}++-- helper functions++_createGeometry :: Graphics3DSystem -> Sc.Geometry -> IO OEntity+_createGeometry g3ds geo = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ entity <- case geo of+ Sc.ResourceGeometry s -> SceneManager.createEntity3 scm s+ Sc.Cube -> SceneManager.createEntity6 scm PT_CUBE+ Sc.Sphere -> SceneManager.createEntity6 scm PT_SPHERE+ Sc.Ikosaeder -> ikosaederE g3ds white+ Sc.Dodekaeder -> dodekaederE g3ds white+ Sc.Plane -> SceneManager.createEntity6 scm PT_PLANE+ _ -> error "HGamer3D.Graphics3D.Internal.Shapes._createMesh: Geo not implemented"+ let rE = OE entity+ if (geo /= Sc.Dodekaeder) && (geo /= Sc.Ikosaeder) then+ _buildTV rE+ else return ()+ return $ rE++_buildTV :: OEntity -> IO ()+_buildTV (OE entity) = Util.buildTangentVectors entity+++{- -------------------------------------------------------------------------------+ EngineItem for Figure+ ------------------------------------------------------------------------------- -}++_createResourceFigure :: Graphics3DSystem -> String -> IO OEntity+_createResourceFigure g3ds name = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ -- create the entity from the mesh+ entity <- SceneManager.createEntity3 scm name+ return $ OE entity++_setMaterial :: OEntity -> Sc.Material -> IO ()+_setMaterial (OE entity) material = do+ case material of+ (Sc.ResourceMaterial name) -> do+ Entity.setMaterialName entity name "General"+ _ -> error "HGamer3D.Graphics3D.Internal.Shapes._setMaterial: Material not implemented"++_setNodePOS n pos ori siz = do+ setNodePos n pos+ setNodeOri n ori+ setNodeSiz n siz+ +_createFigure :: Graphics3DSystem -> ONode -> Sc.Figure -> IO (EngineData)+_createFigure g3ds parent fig = do+ node <- _createSubNode parent+ case fig of+ Sc.SimpleFigure geo mat -> do+ meshEntity <- _createGeometry g3ds geo+ _setMaterial meshEntity mat+ _addEntityToNode g3ds node meshEntity+ return (EDEntityNode meshEntity node)+ Sc.ResourceFigure name -> do+ meshEntity <- _createResourceFigure g3ds name+ _buildTV meshEntity+ _addEntityToNode g3ds node meshEntity+ return (EDEntityNode meshEntity node)+ Sc.CombinedFigure arrSubs -> do+ resArr <- mapM (\(pos, ori, size, fig) -> do+ newData <- _createFigure g3ds node fig+ _setNodePOS newData pos ori size+ return newData) arrSubs+ return (EDNodeAndSub node resArr)++data UpdateActions = ResetMaterial+ | ResetGeometry+ | ResetResource+ | CompareSub+ | Rebuild+ | DoNothing+ + deriving (Eq, Show)+++_updateFigure :: Graphics3DSystem -> ONode -> EngineData -> Sc.Figure -> Sc.Figure -> IO (EngineData)+_updateFigure g3ds parent edata oldFig newFig = do+ let node = getNode edata++ -- check, which action is needed+ + let action = case oldFig of+ Sc.SimpleFigure oldGeo oldMat -> case newFig of+ Sc.SimpleFigure newGeo newMat -> if newGeo == oldGeo+ then+ if newMat == oldMat+ then DoNothing+ else ResetMaterial+ else ResetGeometry+ Sc.ResourceFigure name -> ResetResource+ Sc.CombinedFigure _ -> Rebuild+ Sc.ResourceFigure oldName -> case newFig of+ Sc.ResourceFigure newName -> if newName == oldName+ then DoNothing+ else ResetResource+ Sc.SimpleFigure newGeo newMat -> ResetGeometry+ Sc.CombinedFigure _ -> Rebuild+ Sc.CombinedFigure oldSubs -> case newFig of+ Sc.SimpleFigure _ _ -> Rebuild+ Sc.ResourceFigure _ -> Rebuild+ Sc.CombinedFigure newSubs -> if (length oldSubs) == (length newSubs)+ then CompareSub+ else Rebuild+ + edataNew <-+ + -- perform the single actions, we can keep existing node and single EngineData item form+ if action == ResetMaterial || action == ResetGeometry || action == ResetResource+ then do+ let (EDEntityNode eOld nOld) = edata+ case action of+ ResetMaterial -> do+ let (Sc.SimpleFigure geo mat) = newFig+ _setMaterial eOld mat+ return edata+ ResetGeometry -> do+ let (Sc.SimpleFigure geo mat) = newFig+ eNew <- _createGeometry g3ds geo+ _setMaterial eNew mat+ _exchangeEntityInNode g3ds nOld eOld eNew+ return (EDEntityNode eNew nOld)+ ResetResource -> do+ let (Sc.ResourceFigure name) = newFig+ eNew <- _createResourceFigure g3ds name+ -- _buildTV eNew+ _exchangeEntityInNode g3ds nOld eOld eNew+ return (EDEntityNode eNew nOld)++ -- perform the actions, we compare two equal length subarrays+ else if action == CompareSub+ then do+ let (Sc.CombinedFigure oldSubs) = oldFig+ let (Sc.CombinedFigure newSubs) = newFig+ let (EDNodeAndSub node' edOldArr) = edata+ outArr <- mapM ( \(oldED, (posO, oriO, sizeO, oldFig), (posN, oriN, sizeN, newFig)) -> do+ newED <- _updateFigure g3ds node' oldED oldFig newFig+ if posO /= posN then setNodePos newED posN else return ()+ if oriO /= oriN then setNodeOri newED oriN else return ()+ if sizeO /= sizeN then setNodeSiz newED sizeN else return ()+ return newED+ ) (zip3 edOldArr oldSubs newSubs)+ return (EDNodeAndSub node' outArr)++ -- perform the actions, do a complete rebuild, since structure does not match+ else if action == Rebuild+ then do+ -- delete old structure (to be done)+ _removeFigure g3ds parent edata+ -- create new structure, this is the easy part+ _createFigure g3ds parent newFig++ -- no action needed, all the same+ else if action == DoNothing+ then return edata++ else return $ error ("HGamer3D.Graphics3D.Internal.Shapes._updateFigure: build action not known " ++ (show action))+ + return edataNew+ +_removeFigure :: Graphics3DSystem -> ONode -> EngineData -> IO ()+_removeFigure g3ds parent edata = do+ case edata of+ EDEntityNode e n -> _removeEntityAndNode g3ds parent e n+ EDNodeAndSub n subs -> (mapM (\edata' -> _removeFigure g3ds n edata') subs) >> return ()+ +instance Graphics3DItem Sc.Figure where+ + object3D g3ds fig = do+ rootNode <- _getRootNode g3ds+ edata <- _createFigure g3ds rootNode fig+ return $ Object3D edata fig++ update3D g3ds ob3d newFig = do+ rootNode <- _getRootNode g3ds+ let (Object3D oldEdata oldFig) = ob3d+ newEdata <- _updateFigure g3ds rootNode oldEdata oldFig newFig+ return $ Object3D newEdata newFig++ remove3D g3ds ob3d = do+ rootNode <- _getRootNode g3ds+ let (Object3D edata fig) = ob3d+ _removeFigure g3ds rootNode edata+ return ()+++{- -------------------------------------------------------------------------------+ intelligent constructors for simple geometries+ ------------------------------------------------------------------------------- -}++sphere :: Graphics3DSystem -> Float -> Sc.Material -> IO (Object3D Sc.Figure)+sphere g3ds radius material = object3D g3ds (Sc.CombinedFigure [+ (zeroVec3, unitU, Vec3 radius radius radius,+ Sc.SimpleFigure Sc.Sphere material) ])++cube :: Graphics3DSystem -> Float -> Sc.Material -> IO (Object3D Sc.Figure)+cube g3ds len material = object3D g3ds (Sc.CombinedFigure [+ (zeroVec3, unitU, Vec3 len len len,+ Sc.SimpleFigure Sc.Cube material) ])++cuboid :: Graphics3DSystem -> Vec3 -> Sc.Material -> IO (Object3D Sc.Figure)+cuboid g3ds vec material = object3D g3ds (Sc.CombinedFigure [+ (zeroVec3, unitU, vec, Sc.SimpleFigure Sc.Cube material) ])+ +dodekaeder :: Graphics3DSystem -> Float -> Sc.Material -> IO (Object3D Sc.Figure)+dodekaeder g3ds len material = object3D g3ds (Sc.CombinedFigure [+ (zeroVec3, unitU, Vec3 len len len, Sc.SimpleFigure Sc.Dodekaeder material) ])+ +ikosaeder :: Graphics3DSystem -> Float -> Sc.Material -> IO (Object3D Sc.Figure)+ikosaeder g3ds len material = object3D g3ds (Sc.CombinedFigure [+ (zeroVec3, unitU, Vec3 len len len, Sc.SimpleFigure Sc.Ikosaeder material) ])+ +instance HasPosition (Object3D Sc.Figure) where+ position obj = Node.getPosition (getNode' obj)+ positionTo obj pos = Node.setPosition (getNode' obj) pos+ +instance HasSize (Object3D Sc.Figure) where+ size obj = Node.getScale (getNode' obj)+ sizeTo obj pos = Node.setScale (getNode' obj) pos+ +instance HasOrientation (Object3D Sc.Figure) where+ orientation obj = do+ q <- Node.getOrientation (getNode' obj)+ let uq = mkNormal q+ return uq+ orientationTo obj uq = do+ Node.setOrientation (getNode' obj) (fromNormal uq)+ return ()+ +++++++{- ----------------------------------------------------------------+ ECS Stuff, is this needed any longer ???+ ---------------------------------------------------------------- -}++++-- | Typed Ogre Classes: Node+data ONode = ON HG3DClass -- this object is an Ogre Node++-- | Typed Ogre Classes: Entity+data OEntity = OE HG3DClass -- this object is an Ogre Entity++-- | Typed Ogre Classes: Light+data OLight = OL HG3DClass -- this object is an Ogre Light++-- | Typed Ogre Classes: Camera+data OCamera = OC HG3DClass -- this object is an Ogre Camera++-- | Typed Ogre Classes: Material+data OMaterial = OM HG3DClass -- this object is an Ogre Material+++-- | Typeclass for types, which have a main Node+class HasNode a where+ getNode :: a -> ONode+ getNode' :: a -> HG3DClass+ getNode' = (\(ON n) -> n) . getNode+ setNodePos :: a -> Position -> IO ()+ setNodePos hn pos = Node.setPosition (getNode' hn) pos+ setNodeOri :: a -> Orientation -> IO ()+ setNodeOri hn ori = Node.setOrientation (getNode' hn) (fromNormal ori)+ setNodeSiz :: a -> Size -> IO ()+ setNodeSiz hn siz = Node.setScale (getNode' hn) siz++instance HasNode ONode where+ getNode n = n++-- | Typeclass for objects which can be attached to Nodes+class NodeContent a where+ attachToNode :: a -> ONode -> IO ()+ detachFromNode :: a -> ONode -> IO ()++instance NodeContent OEntity where+ attachToNode (OE en) (ON n) = SceneNode.attachObject n en+ detachFromNode (OE en) (ON n) = SceneNode.detachObject2 n en++instance NodeContent OCamera where+ attachToNode (OC en) (ON n) = SceneNode.attachObject n en+ detachFromNode (OC en) (ON n) = SceneNode.detachObject2 n en++instance NodeContent OLight where+ attachToNode (OL en) (ON n) = SceneNode.attachObject n en+ detachFromNode (OL en) (ON n) = SceneNode.detachObject2 n en+++-- |+-- For the data driven API, we need an internal representation, which+-- holds state inside the engine for outside defined data items (see Schema).+-- The following data definitions provide the framework for capturing+-- engine state for Figure and Geometry objects.+--+-- The EngineData Type holds a tree of items, corresponding to a Figure schema+-- data item, which also holds a corresponding pure data tree.+data EngineData = EDEntityNode OEntity ONode+ | EDNodeAndSub ONode [EngineData]++-- | A 3D Object represents the state inside the engine for a Schema 3D data item+data Object3D a = Object3D EngineData a++-- |+-- The Graphics3DItem TypeClass provides functions, which create, modify and delete objects in+-- the 3D world by simple data definitions. Instances of this TypeClass provide the implementations+-- behind for various 3D objects in the 3D world.+class Graphics3DItem a where+ object3D :: Graphics3DSystem -> a -> IO (Object3D a)+ update3D :: Graphics3DSystem -> Object3D a -> a -> IO (Object3D a)+ remove3D :: Graphics3DSystem -> (Object3D a) -> IO ()++instance HasNode EngineData where+ getNode (EDEntityNode _ node) = node+ getNode (EDNodeAndSub node _) = node++instance HasNode (Object3D a) where+ getNode (Object3D (EDEntityNode _ node) _) = node+ getNode (Object3D (EDNodeAndSub node _) _) = node++_getRootNode :: Graphics3DSystem -> IO ONode+_getRootNode g3ds = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ rootNode <- SceneManager.getRootSceneNode scm+ return (ON rootNode)++_createSubNode :: ONode -> IO ONode+_createSubNode (ON parent) = SceneNode.createChildSceneNode parent zeroVec3 unitQ >>= (return . ON)++_addEntityToNode :: Graphics3DSystem -> ONode -> OEntity -> IO ()+_addEntityToNode g3ds(ON node) (OE meshEntity) = SceneNode.attachObject node meshEntity ++_exchangeEntityInNode :: Graphics3DSystem -> ONode -> OEntity -> OEntity -> IO ()+_exchangeEntityInNode g3ds (ON meshNode) (OE oldMeshEntity) (OE newMeshEntity) = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ SceneNode.detachObject2 meshNode oldMeshEntity+ SceneManager.destroyEntity scm oldMeshEntity+ SceneNode.attachObject meshNode newMeshEntity++_removeEntityAndNode :: Graphics3DSystem -> ONode -> OEntity -> ONode -> IO ()+_removeEntityAndNode g3ds (ON parent) (OE meshEntity ) (ON meshNode) = do+ let (SceneManager scm) = (g3dsSceneManager g3ds)+ rootNode <- SceneManager.getRootSceneNode scm+ SceneNode.detachObject2 meshNode meshEntity+ SceneManager.destroyEntity scm meshEntity+ Node.removeChild2 parent meshNode+ SceneManager.destroySceneNode2 scm meshNode++setSceneParameter :: Graphics3DSystem -> Sc.SceneParameter -> IO ()+setSceneParameter g3ds scene = do+ let (SceneManager scm) = g3dsSceneManager g3ds+ let (Sc.SceneParameter aLightColour shadow sky) = scene+ -- set ambient Light+ SceneManager.setAmbientLight scm aLightColour+ -- set Shadow Mode to be done++ -- set skybox+ case sky of+ Sc.NoSky -> do+ SceneManager.setSkyBoxEnabled scm False+ SceneManager.setSkyDomeEnabled scm False+ Sc.SkyBox (Sc.ResourceMaterial mname) distance -> do+ SceneManager.setSkyDomeEnabled scm False+ SceneManager.setSkyBox scm True mname distance True unitQ "General"+ Sc.SkyDome (Sc.ResourceMaterial mname) curvature tiling distance -> do+ SceneManager.setSkyBoxEnabled scm False+ SceneManager.setSkyDome scm True mname curvature tiling distance True unitQ 16 16 (-1) "General"++ return ()
+ HGamer3D/Graphics3D/Graphics3DSchema.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveDataTypeable, 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.++-- | Types which describe the Scene, the high level of a Scene Tree+module HGamer3D.Graphics3D.Graphics3DSchema++where++import Data.Typeable+import HGamer3D.Data as Dat++++{- ----------------------------------------------------------------+ Camera+ ---------------------------------------------------------------- -}++-- | The data to specify a camera+data Camera = Camera { + frustum :: Frustum, -- ^ Frustum of the camera ,+ viewport :: Viewport -- ^ Where to draw on the window+ } deriving (Eq, Show, Typeable)+ +-- | The frustum defines the area from which objects are rendered into the camera+data Frustum = Frustum {+ nearDistance :: Float, -- ^ clipping distance near, objects which are nearer are not shown+ farDistance :: Float, -- ^ clipping distance far, objects, which are more away are not shown+ fieldOfViewHorizontal :: Dat.Angle -- ^ The field of view angle horizontally, the vertical direction is automatically determined by the aspect ratio of the final viewport window.+ } deriving (Eq, Show, Typeable)++deriving instance Typeable1 Dat.Rectangle++data Viewport = Viewport {+ vpZOrder :: Int, -- ^ Z order in case of overlapping Viewports, higher ZOrders are on top+ vpPosition :: Dat.Rectangle Float, -- ^ position of viewport in Window, coordinates reaching from 0.0 to 1.0+ vpBackgroundColor :: Colour+} deriving (Eq, Show, Typeable)++{- ----------------------------------------------------------------+ Geometry+ ---------------------------------------------------------------- -}++data Geometry = ++ -- loaded from resources+ ResourceGeometry String++ -- Primitive 3D Geometries+ | Cube+ | Sphere+-- | Cylinder++ -- Platon Geometries+ | Ikosaeder+ | Dodekaeder++ -- 2D Geometries+ | Plane+-- | Line++ deriving (Eq, Show, Typeable)+ +{- ----------------------------------------------------------------+ Material+ ---------------------------------------------------------------- -}++-- | The material itself+data Material = ResourceMaterial String -- ^ the name given the material resource in the resource system+ deriving (Eq, Show, Typeable)++{- ----------------------------------------------------------------+ Figure+ ---------------------------------------------------------------- -}++data Figure = SimpleFigure Geometry Material+ | ResourceFigure String+ | CombinedFigure [(Dat.Position, Dat.Orientation, Dat.Size, Figure)]+ deriving (Eq, Show, Typeable)++{- ----------------------------------------------------------------+ Light+ ---------------------------------------------------------------- -}++-- | The Light data type+++data Light = Light {+ diffuseColour :: Colour,+ specularColour :: Colour,+ lightType :: LightType+ } deriving (Eq, Show, Typeable)++data LightType = PointLight -- ^ A source shining from one location+ | DirectionalLight Vec3 -- ^ A source shining from one direction (like the sun)+ | SpotLight Vec3 Angle Angle -- ^ A source shining from one location into one direction with a cone,+ -- angles are inner angle, outer angle (a flashlight).+ -- Angles should be between 5 and 355 degrees.+ deriving (Eq, Show, Typeable)+ +{- ----------------------------------------------------------------+ Scene+ ---------------------------------------------------------------- -}++data SceneParameter = SceneParameter {+ ambientLight :: Colour,+ shadowType :: ShadowType,+ skyType :: SkyType+ } deriving (Eq, Show, Typeable)++data ShadowType = NoShadows+ | TextureAdditive+ | TextureModulative+ | StencilAdditive+ | StencilModulative+ deriving (Eq, Show, Typeable)++data SkyType = NoSky+ | SkyBox Material Float -- Distance+ | SkyDome Material Float Float Float -- Curvature, Tiling, Distance+ deriving (Eq, Show, Typeable)+
− HGamer3D/Graphics3D/Internal/Base.hs
@@ -1,385 +0,0 @@-{-# 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.---- Graphics3D/Internal/Base.hs--module HGamer3D.Graphics3D.Internal.Base -where--import HGamer3D.Data-import HGamer3D.Data.HG3DClass-import HGamer3D.Data.Window--import HGamer3D.Util--import qualified HGamer3D.Bindings.Ogre.ClassRoot as Root-import HGamer3D.Bindings.Ogre.ClassCamera as Camera-import HGamer3D.Bindings.Ogre.ClassNode as Node-import HGamer3D.Bindings.Ogre.ClassSceneManager as SceneManager-import HGamer3D.Bindings.Ogre.ClassResourceGroupManager as ResourceGroupManager-import HGamer3D.Bindings.Ogre.ClassTextureManager as TextureManager-import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager-import HGamer3D.Bindings.Ogre.ClassViewport as Viewport-import HGamer3D.Bindings.Ogre.ClassFrustum as Frustum-import HGamer3D.Bindings.Ogre.ClassAnimationState as AnimationState-import HGamer3D.Bindings.Ogre.ClassEntity as Entity-import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager-import HGamer3D.Bindings.Ogre.ClassLogManager as LogManager-import HGamer3D.Bindings.Ogre.ClassLog as Log-import HGamer3D.Bindings.Ogre.ClassHG3DUtilities as Util-import HGamer3D.Bindings.Ogre.ClassRenderTarget as RenderTarget-import HGamer3D.Bindings.Ogre.ClassManualObject as ManualObject-import HGamer3D.Bindings.Ogre.EnumRenderOperationOperationType-import HGamer3D.Bindings.Ogre.StructHG3DClass-import HGamer3D.Bindings.Ogre.EnumSceneManagerPrefabType-import HGamer3D.Bindings.Ogre.ClassWindowEventUtilities as WindowEventUtilities-import HGamer3D.Bindings.Ogre.ClassSceneNode as SceneNode--import Control.Monad-import Control.Monad.Trans-import Control.Monad.IO.Class-import Control.Monad.State.Class-import qualified System.Info as SI--import Control.Concurrent-import Data.Maybe--import HGamer3D.Data-import HGamer3D.Util--import HGamer3D.Graphics3D.Schema.Material-import HGamer3D.Graphics3D.Schema.Geometry-import HGamer3D.Graphics3D.Schema.Figure-import qualified HGamer3D.Graphics3D.Schema.Scene as Sc-import qualified HGamer3D.Graphics3D.Schema.Camera as Cam--data SceneManager = SceneManager HG3DClass-data ResourceGroupManager = ResourceGroupManager HG3DClass-data RootObject = RootObject HG3DClass-data TextureManager = TextureManager HG3DClass-data LogManager = LogManager HG3DClass-data RenderTarget = RenderTarget HG3DClass---- | This data type holds the internal pointers to implementation objects and some additional state--- like a unique name generator for implementation purposes.-data Graphics3DSystem = Graphics3DSystem {- g3dsRoot :: RootObject,- g3dsSceneManager :: SceneManager,- g3dsResourceGroupManager :: ResourceGroupManager,- g3dsLogManager :: LogManager,- g3dsTextureManager :: TextureManager,- g3dsRenderTarget :: RenderTarget,- g3dsUniqueName :: UniqueName-}---- | initializes the 3d graphics module-initGraphics3D :: String -- ^ Name of the window, displayed- -> String -- ^ SceneManager type used- -> Bool -- ^ flag, show configuration dialogue- -> Bool -- ^ flag, is logging enabled- -> IO (Graphics3DSystem, Window)- -initGraphics3D windowName sceneManagerType fConfig fLog = do-- -- configuration path can be app user dir or local dir- localDir <- getAppConfigDirectory- appDir <- getExeConfigDirectory- configFile <- findFileInDirs "engine.cfg" [localDir, appDir]- pluginsFile <- findFileInDirs "plugins.cfg" [localDir, appDir]- - -- check both files exists- let config = case configFile of- Just cf -> cf- Nothing -> error $ "HGamer3D - Graphics3D: could not find engine configuration file engine.cfg"- - let plugins = case pluginsFile of- Just pf -> pf- Nothing -> error $ "HGamer3D - Graphics3D: could not find plugins configuration file plugins.cfg"- - root <- Root.new plugins config ""- lmgr <- LogManager.getSingletonPtr- if not fLog then do- newlog <- LogManager.createLog lmgr "SilentLog" True False True- return ()- else do- newlog <- LogManager.createLog lmgr "hgamer3d-engine.log" True False False- return ()- - fOk <- if fConfig then- Root.showConfigDialog root- else do- fLoaded <- Root.restoreConfig root- if not fLoaded then- Root.showConfigDialog root- else- return True- - --- fUAddResourceLocations "resources.cfg"- renderWindow <-Root.initialise root True windowName ""- setupCloseEventHandler renderWindow- windowHandle <- Util.getWindowHandle renderWindow- - -- Suppress logging unless, fLog- - sceneManager <- Root.createSceneManager root sceneManagerType "SceneManager"-{- - camera <- SceneManager.createCamera sceneManager "SimpleCamera"- Frustum.setNearClipDistance camera 5.0- Frustum.setFarClipDistance camera 5000.0- -- viewport <- RenderTarget.addViewport renderWindow camera 0 0.0 0.0 1.0 1.0- let bgColor = Colour 0.0 0.0 0.0 1.0- Viewport.setBackgroundColour viewport bgColor- - height <- Viewport.getActualHeight viewport- width <- Viewport.getActualWidth viewport- - Frustum.setAspectRatio camera ((fromIntegral width) / (fromIntegral height))--} - tm <- TextureManager.getSingletonPtr- TextureManager.setDefaultNumMipmaps tm 20- - -- resource locations, if path given, use this as base, if not use standard locations- - rgm <- ResourceGroupManager.getSingletonPtr- - ResourceGroupManager.createResourceGroup rgm "Schemes" False- ResourceGroupManager.createResourceGroup rgm "Imagesets" False- ResourceGroupManager.createResourceGroup rgm "Fonts" False- ResourceGroupManager.createResourceGroup rgm "Layouts" False- ResourceGroupManager.createResourceGroup rgm "LookNFeel" False- ResourceGroupManager.createResourceGroup rgm "LuaScripts" False- ResourceGroupManager.createResourceGroup rgm "XMLSchemas" False- - mediapath1 <- getAppMediaDirectory- mediapath2 <- getExeMediaDirectory- - mapM (\mediapath -> do- ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "materials") "FileSystem" "General" False- ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "schemes") "FileSystem" "Schemes" False- ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "imagesets") "FileSystem" "Imagesets" False- ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "fonts") "FileSystem" "Fonts" False- ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "layouts") "FileSystem" "Layouts" False- ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "looknfeel") "FileSystem" "LookNFeel" False- ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "lua_scripts") "FileSystem" "LuaScripts" False- ResourceGroupManager.addResourceLocation rgm (mediapath ++ osSep ++ "xml_schemas") "FileSystem" "XMLSchemas" False- return ()) [mediapath1, mediapath2]- -- ResourceGroupManager.initialiseAllResourceGroups rgm- uniqueName <- createUniqueName "HG3DObj"- - return $ (Graphics3DSystem (RootObject root) (SceneManager sceneManager) (ResourceGroupManager rgm) (LogManager lmgr) (TextureManager tm) (RenderTarget renderWindow) uniqueName, (Window windowHandle)) ----- | steps the game loop by one tick, renders a frame and handles system messages-stepGraphics3D :: Graphics3DSystem -- ^ the graphics3d system- -> IO Bool -- ^ quit flag, true if window closed-stepGraphics3D g3ds = do- renderOneFrame g3ds- -- this one is quite tricky, on Linux we need to call the message loop in addition to WinEvent!- if SI.os /= "mingw32" then graphics3DPumpWindowMessages else return ()- graphics3DPumpWindowMessages- i <- checkQuitReceived- return (i == 1)---- | frees resources and shutdown the Graphics3D sub-system-freeGraphics3D :: Graphics3DSystem -> IO ()-freeGraphics3D g3ds = do- let (RootObject root) = g3dsRoot g3ds- let (RenderTarget rt) = g3dsRenderTarget g3ds- Root.destroyRenderTarget root rt- Root.delete root- return ()---- | adds a resource location for 3D media (Ogre)-addResourceLocationMedia :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D- -> String -- ^ path to new resource location, the path should identify a directory- -> IO ()-addResourceLocationMedia g3ds path = do- let (ResourceGroupManager rgm) = (g3dsResourceGroupManager g3ds)- ResourceGroupManager.addResourceLocation rgm path "FileSystem" "General" False- ResourceGroupManager.initialiseResourceGroup rgm "General"---- | adds a resource location for 3D media (Ogre) which is a zip file-addResourceZipfileMedia :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D - -> String -- ^ path to new resource location, the path should identify a zip file- -> IO ()-addResourceZipfileMedia g3ds path = do- let (ResourceGroupManager rgm) = (g3dsResourceGroupManager g3ds)- ResourceGroupManager.addResourceLocation rgm path "Zip" "General" False- ResourceGroupManager.initialiseResourceGroup rgm "General"---- | adds a resource location for GUI media (CEGUI) which is a directory-addResourceLocationGUI :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D- -> String -- ^ path to the directory with the GUI media in it- -> String -- ^ category of GUI media, for example: Layout, Images, ...- -> IO ()-addResourceLocationGUI g3ds path category = do- let (ResourceGroupManager rgm) = (g3dsResourceGroupManager g3ds)- ResourceGroupManager.addResourceLocation rgm path "FileSystem" category False- ResourceGroupManager.initialiseResourceGroup rgm category---- | pump window messages for graphics--- Not to be used, if WinEvent pollWinEvent or pumpWinEvents is used!-graphics3DPumpWindowMessages :: IO ()-graphics3DPumpWindowMessages = do- WindowEventUtilities.messagePump- return ()---- | renders one frame on the screen-renderOneFrame :: Graphics3DSystem -> IO ()-renderOneFrame g3ds = do - let (RootObject root) = g3dsRoot g3ds- Root.renderOneFrame root- return ()----- | Typed Ogre Classes: Node-data ONode = ON HG3DClass -- this object is an Ogre Node---- | Typed Ogre Classes: Entity-data OEntity = OE HG3DClass -- this object is an Ogre Entity---- | Typed Ogre Classes: Light-data OLight = OL HG3DClass -- this object is an Ogre Light---- | Typed Ogre Classes: Camera-data OCamera = OC HG3DClass -- this object is an Ogre Camera---- | Typed Ogre Classes: Material-data OMaterial = OM HG3DClass -- this object is an Ogre Material----- | Typeclass for types, which have a main Node-class HasNode a where- getNode :: a -> ONode- getNode' :: a -> HG3DClass- getNode' = (\(ON n) -> n) . getNode- setNodePos :: a -> Position -> IO ()- setNodePos hn pos = Node.setPosition (getNode' hn) pos- setNodeOri :: a -> Orientation -> IO ()- setNodeOri hn ori = Node.setOrientation (getNode' hn) (fromNormal ori)- setNodeSiz :: a -> Size -> IO ()- setNodeSiz hn siz = Node.setScale (getNode' hn) siz--instance HasNode ONode where- getNode n = n---- | Typeclass for objects which can be attached to Nodes-class NodeContent a where- attachToNode :: a -> ONode -> IO ()- detachFromNode :: a -> ONode -> IO ()--instance NodeContent OEntity where- attachToNode (OE en) (ON n) = SceneNode.attachObject n en- detachFromNode (OE en) (ON n) = SceneNode.detachObject2 n en--instance NodeContent OCamera where- attachToNode (OC en) (ON n) = SceneNode.attachObject n en- detachFromNode (OC en) (ON n) = SceneNode.detachObject2 n en--instance NodeContent OLight where- attachToNode (OL en) (ON n) = SceneNode.attachObject n en- detachFromNode (OL en) (ON n) = SceneNode.detachObject2 n en----- |--- For the data driven API, we need an internal representation, which--- holds state inside the engine for outside defined data items (see Schema).--- The following data definitions provide the framework for capturing--- engine state for Figure and Geometry objects.------ The EngineData Type holds a tree of items, corresponding to a Figure schema--- data item, which also holds a corresponding pure data tree.-data EngineData = EDEntityNode OEntity ONode- | EDNodeAndSub ONode [EngineData]---- | A 3D Object represents the state inside the engine for a Schema 3D data item-data Object3D a = Object3D EngineData a---- |--- The Graphics3DItem TypeClass provides functions, which create, modify and delete objects in--- the 3D world by simple data definitions. Instances of this TypeClass provide the implementations--- behind for various 3D objects in the 3D world.-class Graphics3DItem a where- object3D :: Graphics3DSystem -> a -> IO (Object3D a)- update3D :: Graphics3DSystem -> Object3D a -> a -> IO (Object3D a)- remove3D :: Graphics3DSystem -> (Object3D a) -> IO ()--instance HasNode EngineData where- getNode (EDEntityNode _ node) = node- getNode (EDNodeAndSub node _) = node--instance HasNode (Object3D a) where- getNode (Object3D (EDEntityNode _ node) _) = node- getNode (Object3D (EDNodeAndSub node _) _) = node--_getRootNode :: Graphics3DSystem -> IO ONode-_getRootNode g3ds = do- let (SceneManager scm) = (g3dsSceneManager g3ds)- rootNode <- SceneManager.getRootSceneNode scm- return (ON rootNode)--_createSubNode :: ONode -> IO ONode-_createSubNode (ON parent) = SceneNode.createChildSceneNode parent zeroVec3 unitQ >>= (return . ON)--_addEntityToNode :: Graphics3DSystem -> ONode -> OEntity -> IO ()-_addEntityToNode g3ds(ON node) (OE meshEntity) = SceneNode.attachObject node meshEntity --_exchangeEntityInNode :: Graphics3DSystem -> ONode -> OEntity -> OEntity -> IO ()-_exchangeEntityInNode g3ds (ON meshNode) (OE oldMeshEntity) (OE newMeshEntity) = do- let (SceneManager scm) = (g3dsSceneManager g3ds)- SceneNode.detachObject2 meshNode oldMeshEntity- SceneManager.destroyEntity scm oldMeshEntity- SceneNode.attachObject meshNode newMeshEntity--_removeEntityAndNode :: Graphics3DSystem -> ONode -> OEntity -> ONode -> IO ()-_removeEntityAndNode g3ds (ON parent) (OE meshEntity ) (ON meshNode) = do- let (SceneManager scm) = (g3dsSceneManager g3ds)- rootNode <- SceneManager.getRootSceneNode scm- SceneNode.detachObject2 meshNode meshEntity- SceneManager.destroyEntity scm meshEntity- Node.removeChild2 parent meshNode- SceneManager.destroySceneNode2 scm meshNode--setSceneParameter :: Graphics3DSystem -> Sc.SceneParameter -> IO ()-setSceneParameter g3ds scene = do- let (SceneManager scm) = g3dsSceneManager g3ds- let (Sc.SceneParameter aLightColour shadow sky) = scene- -- set ambient Light- SceneManager.setAmbientLight scm aLightColour- -- set Shadow Mode to be done-- -- set skybox- case sky of- Sc.NoSky -> do- SceneManager.setSkyBoxEnabled scm False- SceneManager.setSkyDomeEnabled scm False- Sc.SkyBox (ResourceMaterial mname) distance -> do- SceneManager.setSkyDomeEnabled scm False- SceneManager.setSkyBox scm True mname distance True unitQ "General"- Sc.SkyDome (ResourceMaterial mname) curvature tiling distance -> do- SceneManager.setSkyBoxEnabled scm False- SceneManager.setSkyDome scm True mname curvature tiling distance True unitQ 16 16 (-1) "General"-- return ()
− HGamer3D/Graphics3D/Internal/Camera.hs
@@ -1,173 +0,0 @@-{-# 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.---- Graphics3D/Internal/Camera.hs--module HGamer3D.Graphics3D.Internal.Camera-where--import HGamer3D.Data-import HGamer3D.Data.HG3DClass-import HGamer3D.Data.Window--import HGamer3D.Util--import qualified HGamer3D.Bindings.Ogre.ClassRoot as Root-import HGamer3D.Bindings.Ogre.ClassCamera as Camera-import HGamer3D.Bindings.Ogre.ClassNode as Node-import HGamer3D.Bindings.Ogre.ClassSceneManager as SceneManager-import HGamer3D.Bindings.Ogre.ClassResourceGroupManager as ResourceGroupManager-import HGamer3D.Bindings.Ogre.ClassTextureManager as TextureManager-import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager-import HGamer3D.Bindings.Ogre.ClassViewport as Viewport-import HGamer3D.Bindings.Ogre.ClassFrustum as Frustum-import HGamer3D.Bindings.Ogre.ClassAnimationState as AnimationState-import HGamer3D.Bindings.Ogre.ClassEntity as Entity-import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager-import HGamer3D.Bindings.Ogre.ClassLogManager as LogManager-import HGamer3D.Bindings.Ogre.ClassLog as Log-import HGamer3D.Bindings.Ogre.ClassHG3DUtilities as Util-import HGamer3D.Bindings.Ogre.ClassRenderTarget as RenderTarget-import HGamer3D.Bindings.Ogre.ClassManualObject as ManualObject-import HGamer3D.Bindings.Ogre.EnumRenderOperationOperationType-import HGamer3D.Bindings.Ogre.StructHG3DClass-import HGamer3D.Bindings.Ogre.EnumSceneManagerPrefabType-import HGamer3D.Bindings.Ogre.ClassWindowEventUtilities as WindowEventUtilities--import Control.Monad-import Control.Monad.Trans-import Control.Monad.IO.Class-import Control.Monad.State.Class-import qualified System.Info as SI--import Control.Concurrent-import Data.Maybe--import HGamer3D.Data-import HGamer3D.Util--import HGamer3D.Graphics3D.Schema.Material-import HGamer3D.Graphics3D.Schema.Geometry-import HGamer3D.Graphics3D.Schema.Figure-import qualified HGamer3D.Graphics3D.Schema.Camera as Cam-import HGamer3D.Graphics3D.Internal.Base---{- ----------------------------------------------------------------- Camera- ---------------------------------------------------------------- -}---- | Camera, internal data object for engine-data Camera = Camera {- cameraCamObject :: HG3DClass,- cameraViewportObject :: HG3DClass,- cameraSchema :: Cam.Camera- }---- | add a camera, you probably want to do this at least once-addCamera :: Graphics3DSystem -- ^ the graphics system- -> Cam.Camera -- ^ the Schema data for the camera- -> IO Camera -- ^ the resulting engine object-addCamera g3ds schema = do- let (SceneManager sceneManager) = g3dsSceneManager g3ds- let uname = g3dsUniqueName g3ds- let (RenderTarget renderWindow) = g3dsRenderTarget g3ds- let Cam.Camera (Cam.Frustum nd fd fov) (Cam.Viewport z pos bgr) = schema- -- create camera- cameraName <- (nextUniqueName uname) >>= (\n -> return ("Camera"++n))- camera <- SceneManager.createCamera sceneManager cameraName- -- add Viewport- viewport <- RenderTarget.addViewport renderWindow camera z (rectX pos) (rectY pos) (rectWidth pos) (rectHeight pos)- -- set Viewport parameters- Viewport.setBackgroundColour viewport bgr- -- set Frustum parameters- Frustum.setNearClipDistance camera nd- Frustum.setFarClipDistance camera fd- Frustum.setFOVy camera (fromAngle fov)- -- create camera return value- let cam = Camera camera viewport schema- -- adapt aspect ratio- cameraAdaptAspectRatio cam-- return cam---- | remove a camera -removeCamera :: Graphics3DSystem -> Camera -> IO ()-removeCamera g3ds (Camera camera viewport schema) = do- let (SceneManager sceneManager) = g3dsSceneManager g3ds- let (RenderTarget renderWindow) = g3dsRenderTarget g3ds- let Cam.Camera (Cam.Frustum nd fd fov) (Cam.Viewport z pos bgr) = schema- RenderTarget.removeViewport renderWindow z- SceneManager.destroyCamera sceneManager camera---- | update an existing camera with new parameters-updateCamera :: Graphics3DSystem -> Camera -> Cam.Camera -> IO Camera-updateCamera g3ds cam@(Camera camera viewport schema) schema' = do- - let Cam.Camera (Cam.Frustum nd fd fov) (Cam.Viewport z pos bgr) = schema- let Cam.Camera (Cam.Frustum nd' fd' fov') (Cam.Viewport z' pos' bgr') = schema'- -- if zorder or position are not equal, we need to rebuild- if (z /= z') || (pos /= pos') then do- removeCamera g3ds cam- addCamera g3ds schema'- else do- -- adapt single values, as needed- if nd /= nd' then Frustum.setNearClipDistance camera nd' else return ()- if fd /= fd' then Frustum.setFarClipDistance camera fd' else return ()- if fov /= fov' then Frustum.setFOVy camera (fromAngle fov') else return ()- if bgr /= bgr' then Viewport.setBackgroundColour viewport bgr' else return ()- return (Camera camera viewport schema')- --- | adapt the aspect ration, in case the window size and aspect ratio changes, this--- is called inside the engine automatically.-cameraAdaptAspectRatio :: Camera -> IO ()-cameraAdaptAspectRatio cam = do- let (Camera camera viewport schema) = cam- height <- Viewport.getActualHeight viewport- width <- Viewport.getActualWidth viewport- Frustum.setAspectRatio camera ((fromIntegral width) / (fromIntegral height))- return ()- -instance HasPosition Camera where- position (Camera c _ _) = Camera.getPosition c- positionTo (Camera c _ _) pos = Camera.setPosition2 c pos- -instance HasOrientation Camera where- orientation (Camera c _ _) = do- q <- Camera.getOrientation c- let uq = mkNormal q- return uq- orientationTo (Camera c _ _) uq = do- Camera.setOrientation c (fromNormal uq)- return ()---- | set the direction in a way, that the camera looks toward a specified point-cameraLookAt :: Camera -> Vec3 -> IO ()-cameraLookAt (Camera c _ _) v = do- Camera.lookAt c v- return ()---- | Background colour of the 3d drawing window-setBackgroundColour :: Graphics3DSystem -> Camera -> Colour -> IO Camera-setBackgroundColour g3ds cam@(Camera camera viewport schema) bgColour = do- let Cam.Camera (Cam.Frustum nd fd fov) (Cam.Viewport z pos bgr) = schema- let schema' = Cam.Camera (Cam.Frustum nd fd fov) (Cam.Viewport z pos bgColour)- updateCamera g3ds cam schema'-
− HGamer3D/Graphics3D/Internal/Light.hs
@@ -1,195 +0,0 @@-{-# LANGUAGE FlexibleContexts #-} -{-# 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. - --- Graphics3D/Internal/Light.hs - --- | Creating and managing Light in Base API. Internal implementation module. Public API is in HGamer3D.Graphics3D. - - -module HGamer3D.Graphics3D.Internal.Light -where - -import Data.Maybe - -import HGamer3D.Data -import HGamer3D.Data.HG3DClass -import HGamer3D.Util - -import GHC.Ptr - -import HGamer3D.Bindings.Ogre.ClassPtr -import HGamer3D.Bindings.Ogre.Utils - -import HGamer3D.Bindings.Ogre.StructColour -import HGamer3D.Bindings.Ogre.StructSharedPtr - -import HGamer3D.Bindings.Ogre.EnumSceneType -import HGamer3D.Bindings.Ogre.EnumNodeTransformSpace -import HGamer3D.Bindings.Ogre.EnumLightType - ---import HGamer3D.Bindings.Ogre.ClassCamera as Camera ---import HGamer3D.Bindings.Ogre.ClassRoot as Root -import HGamer3D.Bindings.Ogre.ClassLight as Light -import HGamer3D.Bindings.Ogre.ClassNode as Node -import HGamer3D.Bindings.Ogre.ClassSceneManager as SceneManager -import HGamer3D.Bindings.Ogre.ClassSceneNode as SceneNode -import HGamer3D.Bindings.Ogre.ClassRenderTarget as RenderTarget -import HGamer3D.Bindings.Ogre.ClassRenderWindow as RenderWindow -import HGamer3D.Bindings.Ogre.ClassResourceGroupManager as ResourceGroupManager -import HGamer3D.Bindings.Ogre.ClassTextureManager as TextureManager -import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager -import HGamer3D.Bindings.Ogre.ClassViewport as Viewport -import HGamer3D.Bindings.Ogre.ClassFrustum as Frustum -import HGamer3D.Bindings.Ogre.ClassAnimationState as AnimationState -import HGamer3D.Bindings.Ogre.ClassEntity as Entity -import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager -import HGamer3D.Bindings.Ogre.ClassWindowEventUtilities as WindowEventUtilities - -import HGamer3D.Bindings.Ogre.ClassManualObject as ManualObject -import HGamer3D.Bindings.Ogre.EnumRenderOperationOperationType -import HGamer3D.Bindings.Ogre.StructHG3DClass -import HGamer3D.Bindings.Ogre.EnumSceneManagerPrefabType - -import HGamer3D.Data.HG3DClass -import HGamer3D.Data.Transform3D -import HGamer3D.Graphics3D.Internal.Base - -import Control.Monad -import Control.Monad.Trans -import Control.Monad.IO.Class -import Control.Monad.State.Class - -import qualified HGamer3D.Graphics3D.Schema.Light as L - - --- | The light. -data Light = Light ONode OLight L.Light - -instance HasNode Light where - getNode (Light node _ _) = node - -instance HasPosition Light where - position obj = Node.getPosition (getNode' obj) - positionTo obj pos = Node.setPosition (getNode' obj) pos - -instance HasOrientation Light where - orientation obj = do - q <- Node.getOrientation (getNode' obj) - let uq = mkNormal q - return uq - orientationTo obj uq = do - Node.setOrientation (getNode' obj) (fromNormal uq) - return () - -addLight :: Graphics3DSystem -> L.Light -> IO Light -addLight g3ds schema = do - let (SceneManager scm) = (g3dsSceneManager g3ds) - let (L.Light diffuse@(Colour r g b _) specular@(Colour r' g' b' _) ltype) = schema - lightName <- nextUniqueName (g3dsUniqueName g3ds) - light <- SceneManager.createLight scm lightName - Light.setDiffuseColour light r g b - Light.setSpecularColour light r' g' b' - case ltype of - L.PointLight -> Light.setType light LT_POINT - L.DirectionalLight dir -> do - Light.setType light LT_DIRECTIONAL - Light.setDirection2 light dir - L.SpotLight dir inner outer -> do - Light.setType light LT_SPOTLIGHT - Light.setDirection2 light dir - Light.setSpotlightInnerAngle light (fromAngle inner) - Light.setSpotlightOuterAngle light (fromAngle outer) - let l = OL light - rn <- _getRootNode g3ds - n <- _createSubNode rn - attachToNode l n - return $ Light n l schema - -removeLight :: Graphics3DSystem -> Light -> IO () -removeLight g3ds (Light n@(ON node) l@(OL light) schema) = do - let (SceneManager scm) = (g3dsSceneManager g3ds) - detachFromNode l n - (ON rn) <- _getRootNode g3ds - Node.removeChild2 rn node - SceneManager.destroyLight2 scm light - -updateLight :: Graphics3DSystem -> Light -> L.Light -> IO Light -updateLight g3ds l schema = do - let (SceneManager scm) = (g3dsSceneManager g3ds) - removeLight g3ds l - addLight g3ds schema - --- | Ambient light is present everywhere, this function creates it and sets the colour of it. --- There is no light object, since movement, rotation, scaling would make no sense anyhow. -setAmbientLight :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D - -> Colour -> IO () -setAmbientLight g3ds colour = do - let (SceneManager scm) = (g3dsSceneManager g3ds) - SceneManager.setAmbientLight scm colour - --- | creates a point light at a specific location -pointLight :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D - -> Colour -- ^ diffuse Color of the light - -> Colour -- ^ specular Color of the light - -> Vec3 -- ^ Position, where light is created - -> IO (Light) -- ^ The light object -pointLight g3ds diffuse specular pos = do - let schema = L.Light diffuse specular L.PointLight - light <- addLight g3ds schema - positionTo light pos - return $ light - --- | creates a spot light at a specific location -spotLight :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D - -> Colour -- ^ diffuse Colour of the light - -> Colour -- ^ specular Colour of the light - -> Vec3 -- ^ Position, where light is created - -> Vec3 -- ^ Direction, where light points - -> Angle -- ^ inner Angle of cone (5..355 degrees) - -> Angle -- ^ outer Angle of cone (5..355 degrees) - -> IO Light -- ^ The light object -spotLight g3ds diffuse specular pos dir inner outer = do - let schema = L.Light diffuse specular (L.SpotLight dir inner outer) - light <- addLight g3ds schema - positionTo light pos - return $ light - --- | sets spotlight direction -spotLightSetDirection :: Graphics3DSystem -> Light -> Vec3 -> IO Light -spotLightSetDirection g3ds light dir' = do - let (Light n l schema) = light - let (L.Light diffuse@(Colour r g b _) specular@(Colour r' g' b' _) ltype) = schema - case ltype of - (L.SpotLight dir inner outer) -> updateLight g3ds light (L.Light diffuse specular (L.SpotLight dir' inner outer)) - _ -> return light - --- | creates a directional light at a specific location -directionalLight :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D - -> Colour -- ^ diffuse Colour of the light - -> Colour -- ^ specular Colour of light - -> Vec3 -- ^ direction of light - -> IO (Light) -- ^ The light object -directionalLight g3ds diffuse specular dir = do - let schema = L.Light diffuse specular (L.DirectionalLight dir) - light <- addLight g3ds schema - return $ light - -
− HGamer3D/Graphics3D/Internal/PlatonShapes.hs
@@ -1,228 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# 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-2013 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.---- Graphics3D/Internal/PlatonShapes.hs---- | Create platonic shapes, ikosaeder and dodekaeder, implementation module. Public API is in HGamer3D.Graphics3D.-module HGamer3D.Graphics3D.Internal.PlatonShapes -where---import GHC.Ptr--import HGamer3D.Data-import HGamer3D.Data.HG3DClass-import HGamer3D.Util--import HGamer3D.Bindings.Ogre.ClassPtr-import HGamer3D.Bindings.Ogre.Utils--import HGamer3D.Bindings.Ogre.StructColour-import HGamer3D.Bindings.Ogre.StructSharedPtr-import HGamer3D.Bindings.Ogre.StructHG3DClass--import HGamer3D.Bindings.Ogre.EnumSceneType-import HGamer3D.Bindings.Ogre.EnumNodeTransformSpace-import HGamer3D.Bindings.Ogre.EnumLightType-import HGamer3D.Bindings.Ogre.EnumRenderOperationOperationType-import HGamer3D.Bindings.Ogre.EnumSceneManagerPrefabType----import HGamer3D.Bindings.Ogre.ClassCamera as Camera---import HGamer3D.Bindings.Ogre.ClassRoot as Root-import HGamer3D.Bindings.Ogre.ClassLight as Light-import HGamer3D.Bindings.Ogre.ClassNode as Node-import HGamer3D.Bindings.Ogre.ClassSceneManager as SceneManager-import HGamer3D.Bindings.Ogre.ClassSceneNode as SceneNode-import HGamer3D.Bindings.Ogre.ClassRenderTarget as RenderTarget-import HGamer3D.Bindings.Ogre.ClassRenderWindow as RenderWindow-import HGamer3D.Bindings.Ogre.ClassResourceGroupManager as ResourceGroupManager-import HGamer3D.Bindings.Ogre.ClassTextureManager as TextureManager-import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager-import HGamer3D.Bindings.Ogre.ClassViewport as Viewport-import HGamer3D.Bindings.Ogre.ClassFrustum as Frustum-import HGamer3D.Bindings.Ogre.ClassAnimationState as AnimationState-import HGamer3D.Bindings.Ogre.ClassEntity as Entity-import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager-import HGamer3D.Bindings.Ogre.ClassWindowEventUtilities as WindowEventUtilities-import HGamer3D.Bindings.Ogre.ClassManualObject as ManualObject--import HGamer3D.Graphics3D.Internal.Base--import Control.Monad-import Control.Monad.Trans-import Control.Monad.IO.Class-import Control.Monad.State.Class--vminus = Vec3 (-1.0) (-1.0) (-1.0)--getNormOfFace vertices (a, b, c) = normalize cross- where - v1 = vertices !! a- v2 = vertices !! b- v3 = vertices !! c - cross = (v2 &- v1) `crossprod` (v3 &- v1)- --isIn (a, b, c) n = if n == a then True else - if n == b then True else- if n == c then True else- False---_createPlatonObject :: Graphics3DSystem -> Colour -> [Vec3] -> [(Int, Int, Int)] -> Int -> IO HG3DClass-_createPlatonObject g3ds colour vertices faces iColor = do-- let (SceneManager scm) = (g3dsSceneManager g3ds)- uid <- nextUniqueName (g3dsUniqueName g3ds)-- mo <- SceneManager.createManualObject scm uid- -- set Dynamic to false- ManualObject.setDynamic mo False-- let normsOfFaces = map (getNormOfFace vertices) faces- - let vzero = Vec3 0.0 0.0 0.0 - - let normsOfVertices = map vnorm allVerticesIndexes- where - allVerticesIndexes = [ i | i <- [0..(length vertices)]] - vnorm = (\i -> normalize $ foldr (&+) vzero (map (\face -> if isIn face i then normsOfFaces !! i else vzero) faces))-- sequence $ map (\((x,y,z), norm) -> do- ManualObject.begin mo "BaseWhiteNoLightning" OT_TRIANGLE_LIST "General"- ManualObject.position mo (vertices !! x)- ManualObject.normal mo norm- ManualObject.position mo (vertices !! y)- ManualObject.position mo (vertices !! z)- ManualObject.triangle mo 0 1 2- ManualObject.end mo) (zip faces normsOfFaces)-- return mo- ---- | create an ikoaeder mesh - from the mesh more objects can be created-ikosaederE :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D- -> Colour -- ^ colour of the ikosaeder- -> IO HG3DClass -- ^ created mesh object as entity-ikosaederE g3ds colour = do- let (SceneManager scm) = (g3dsSceneManager g3ds)- uid <- nextUniqueName (g3dsUniqueName g3ds)-- let bodyName = "B" ++ uid- let meshName = "M" ++ uid- - let x = 0.525731112119133606- let z = 0.850650808352039932- - let vertices = [- ( Vec3 (-x) 0.0 z),- ( Vec3 x 0.0 z),- ( Vec3 (-x) 0.0 (-z)),- ( Vec3 x 0.0 (-z)),- ( Vec3 0.0 z x), - ( Vec3 0.0 z (-x)), - ( Vec3 0.0 (-z) x), - ( Vec3 0.0 (-z) (-x)),- ( Vec3 z x 0.0),- ( Vec3 (-z) x 0.0), - ( Vec3 z (-x) 0.0),- ( Vec3 (-z) (-x) 0.0)- ]- - let faces = [-- (0,4,1), (0,9,4), (9,5,4), (4,5,8), (4,8,1), - (8,10,1), (8,3,10), (5,3,8), (5,2,3), (2,7,3),- (7,10,3), (7,6,10), (7,11,6), (11,0,6), (0,1,6),- (6,1,10), (9,0,11), (9,11,2), (9,2,5), (7,2,11)- - ]- - mo <- _createPlatonObject g3ds colour vertices faces 0- ManualObject.convertToMesh mo meshName "General"- entity <- SceneManager.createEntity3 scm meshName- return $ entity- ---- | create a dodekaeder mesh-dodekaederE :: Graphics3DSystem -- ^ the Graphics3D system object, returned by initGraphics3D- -> Colour -- ^ colour of the dodekaeder- -> IO HG3DClass -- ^ created dodekaeder mesh as entity-dodekaederE g3ds colour = do- let (SceneManager scm) = (g3dsSceneManager g3ds)- uid <- nextUniqueName (g3dsUniqueName g3ds)-- let bodyName = "B" ++ uid- let meshName = "M" ++ uid- - let s = 0.618034- let t = 1.618034-- - let vertices = [- - (Vec3 1.0 1.0 1.0), - (Vec3 1.0 1.0 (-1.0)), - (Vec3 1.0 (-1.0) 1.0), - (Vec3 1.0 (-1.0) (-1.0)), - (Vec3 (-1.0) 1.0 1.0), - (Vec3 (-1.0) 1.0 (-1.0)), - (Vec3 (-1.0) (-1.0) 1.0), - (Vec3 (-1.0) (-1.0) (-1.0)), - (Vec3 s t 0.0),- (Vec3 (-s) t 0.0), - (Vec3 s (-t) 0.0),- (Vec3 (-s) (-t) 0.0), - (Vec3 t 0.0 s), - (Vec3 t 0.0 (-s)),- (Vec3 (-t) 0.0 s), - (Vec3 (-t) 0.0 (-s)), - (Vec3 0.0 s t),- (Vec3 0.0 (-s) t), - (Vec3 0.0 s (-t)), - (Vec3 0.0 (-s) (-t))-- ]- - let faces = [- --- (1,8,0,12,13), (4, 9, 5, 15, 14), --- (2, 10, 3, 13, 12), (7, 11, 6, 14, 15), --- (2, 12, 0, 16, 17), (1, 13, 3, 19, 18),--- (4, 14, 6, 17, 16), (7, 15, 5, 18, 19),--- (4, 16, 0, 8, 9), (2, 17, 6, 11, 10),--- (1, 18, 5, 9, 8), (7, 19, 3, 10, 11)- - (1,8,0,12,13), (4, 9, 5, 15, 14), - (2, 10, 3, 13, 12), (7, 11, 6, 14, 15), - (2, 12, 0, 16, 17), (1, 13, 3, 19, 18),- (4, 14, 6, 17, 16), (7, 15, 5, 18, 19),- (4, 16, 0, 8, 9), (2, 17, 6, 11, 10),- (1, 18, 5, 9, 8), (7, 19, 3, 10, 11)- - ]- - let faces2 = foldl (++) [] $ map ( \(a, b, c, d, e) -> [ (a, b, e), (b, d, e), (c, d, b) ] ) faces-- mo <- _createPlatonObject g3ds colour vertices faces2 0- ManualObject.convertToMesh mo meshName "General"- entity <- SceneManager.createEntity3 scm meshName- return $ entity
− HGamer3D/Graphics3D/Internal/Shapes.hs
@@ -1,314 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# 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-2013 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.---- Graphics3D/Internal/Object3D.hs---- | Creating and managing 3D objects functionality for Graphics3D module, internal implemenatation module. Public API is HGamer3D.Graphics3D.-module HGamer3D.Graphics3D.Internal.Shapes --where--import HGamer3D.Data-import HGamer3D.Data.HG3DClass-import HGamer3D.Util- -import GHC.Ptr--import HGamer3D.Bindings.Ogre.ClassPtr-import HGamer3D.Bindings.Ogre.Utils--import HGamer3D.Bindings.Ogre.StructColour-import HGamer3D.Bindings.Ogre.StructSharedPtr--import HGamer3D.Bindings.Ogre.EnumSceneType-import HGamer3D.Bindings.Ogre.EnumNodeTransformSpace-import HGamer3D.Bindings.Ogre.EnumLightType--import HGamer3D.Bindings.Ogre.ClassLight as Light-import HGamer3D.Bindings.Ogre.ClassNode as Node-import HGamer3D.Bindings.Ogre.ClassSceneManager as SceneManager-import HGamer3D.Bindings.Ogre.ClassSceneNode as SceneNode-import HGamer3D.Bindings.Ogre.ClassRenderTarget as RenderTarget-import HGamer3D.Bindings.Ogre.ClassRenderWindow as RenderWindow-import HGamer3D.Bindings.Ogre.ClassResourceGroupManager as ResourceGroupManager-import HGamer3D.Bindings.Ogre.ClassTextureManager as TextureManager-import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager-import HGamer3D.Bindings.Ogre.ClassViewport as Viewport-import HGamer3D.Bindings.Ogre.ClassFrustum as Frustum-import HGamer3D.Bindings.Ogre.ClassAnimationState as AnimationState-import HGamer3D.Bindings.Ogre.ClassEntity as Entity-import HGamer3D.Bindings.Ogre.ClassControllerManager as ControllerManager-import HGamer3D.Bindings.Ogre.ClassWindowEventUtilities as WindowEventUtilities-import HGamer3D.Bindings.Ogre.ClassHG3DUtilities as HG3DUtils--import HGamer3D.Bindings.Ogre.ClassManualObject as ManualObject-import HGamer3D.Bindings.Ogre.EnumRenderOperationOperationType-import HGamer3D.Bindings.Ogre.StructHG3DClass-import HGamer3D.Bindings.Ogre.EnumSceneManagerPrefabType--import HGamer3D.Data.HG3DClass-import HGamer3D.Data.Transform3D-import HGamer3D.Graphics3D.Internal.Base--import Control.Monad-import Control.Monad.Trans-import Control.Monad.State.Class--import HGamer3D.Graphics3D.Schema.Material-import HGamer3D.Graphics3D.Schema.Geometry-import HGamer3D.Graphics3D.Schema.Figure-import HGamer3D.Graphics3D.Internal.PlatonShapes---{- -------------------------------------------------------------------------------- EngineItem for Geometry- ------------------------------------------------------------------------------- -}---- helper functions--_createGeometry :: Graphics3DSystem -> Geometry -> IO OEntity-_createGeometry g3ds geo = do- let (SceneManager scm) = (g3dsSceneManager g3ds)- entity <- case geo of- ResourceGeometry s -> SceneManager.createEntity3 scm s- Cube -> SceneManager.createEntity6 scm PT_CUBE- Sphere -> SceneManager.createEntity6 scm PT_SPHERE- Ikosaeder -> ikosaederE g3ds white- Dodekaeder -> dodekaederE g3ds white- Plane -> SceneManager.createEntity6 scm PT_PLANE- _ -> error "HGamer3D.Graphics3D.Internal.Shapes._createMesh: Geo not implemented"- let rE = OE entity- if (geo /= Dodekaeder) && (geo /= Ikosaeder) then- _buildTV rE- else return ()- return $ rE--_buildTV :: OEntity -> IO ()-_buildTV (OE entity) = HG3DUtils.buildTangentVectors entity---{- -------------------------------------------------------------------------------- EngineItem for Figure- ------------------------------------------------------------------------------- -}--_createResourceFigure :: Graphics3DSystem -> String -> IO OEntity-_createResourceFigure g3ds name = do- let (SceneManager scm) = (g3dsSceneManager g3ds)- -- create the entity from the mesh- entity <- SceneManager.createEntity3 scm name- return $ OE entity--_setMaterial :: OEntity -> Material -> IO ()-_setMaterial (OE entity) material = do- case material of- (ResourceMaterial name) -> do- Entity.setMaterialName entity name "General"- _ -> error "HGamer3D.Graphics3D.Internal.Shapes._setMaterial: Material not implemented"--_setNodePOS n pos ori siz = do- setNodePos n pos- setNodeOri n ori- setNodeSiz n siz- -_createFigure :: Graphics3DSystem -> ONode -> Figure -> IO (EngineData)-_createFigure g3ds parent fig = do- node <- _createSubNode parent- case fig of- SimpleFigure geo mat -> do- meshEntity <- _createGeometry g3ds geo- _setMaterial meshEntity mat- _addEntityToNode g3ds node meshEntity- return (EDEntityNode meshEntity node)- ResourceFigure name -> do- meshEntity <- _createResourceFigure g3ds name- _buildTV meshEntity- _addEntityToNode g3ds node meshEntity- return (EDEntityNode meshEntity node)- CombinedFigure arrSubs -> do- resArr <- mapM (\(pos, ori, size, fig) -> do- newData <- _createFigure g3ds node fig- _setNodePOS newData pos ori size- return newData) arrSubs- return (EDNodeAndSub node resArr)--data UpdateActions = ResetMaterial- | ResetGeometry- | ResetResource- | CompareSub- | Rebuild- | DoNothing- - deriving (Eq, Show)---_updateFigure :: Graphics3DSystem -> ONode -> EngineData -> Figure -> Figure -> IO (EngineData)-_updateFigure g3ds parent edata oldFig newFig = do- let node = getNode edata-- -- check, which action is needed- - let action = case oldFig of- SimpleFigure oldGeo oldMat -> case newFig of- SimpleFigure newGeo newMat -> if newGeo == oldGeo- then- if newMat == oldMat- then DoNothing- else ResetMaterial- else ResetGeometry- ResourceFigure name -> ResetResource- CombinedFigure _ -> Rebuild- ResourceFigure oldName -> case newFig of- ResourceFigure newName -> if newName == oldName- then DoNothing- else ResetResource- SimpleFigure newGeo newMat -> ResetGeometry- CombinedFigure _ -> Rebuild- CombinedFigure oldSubs -> case newFig of- SimpleFigure _ _ -> Rebuild- ResourceFigure _ -> Rebuild- CombinedFigure newSubs -> if (length oldSubs) == (length newSubs)- then CompareSub- else Rebuild- - edataNew <-- - -- perform the single actions, we can keep existing node and single EngineData item form- if action == ResetMaterial || action == ResetGeometry || action == ResetResource- then do- let (EDEntityNode eOld nOld) = edata- case action of- ResetMaterial -> do- let (SimpleFigure geo mat) = newFig- _setMaterial eOld mat- return edata- ResetGeometry -> do- let (SimpleFigure geo mat) = newFig- eNew <- _createGeometry g3ds geo- _setMaterial eNew mat- _exchangeEntityInNode g3ds nOld eOld eNew- return (EDEntityNode eNew nOld)- ResetResource -> do- let (ResourceFigure name) = newFig- eNew <- _createResourceFigure g3ds name- -- _buildTV eNew- _exchangeEntityInNode g3ds nOld eOld eNew- return (EDEntityNode eNew nOld)-- -- perform the actions, we compare two equal length subarrays- else if action == CompareSub- then do- let (CombinedFigure oldSubs) = oldFig- let (CombinedFigure newSubs) = newFig- let (EDNodeAndSub node' edOldArr) = edata- outArr <- mapM ( \(oldED, (posO, oriO, sizeO, oldFig), (posN, oriN, sizeN, newFig)) -> do- newED <- _updateFigure g3ds node' oldED oldFig newFig- if posO /= posN then setNodePos newED posN else return ()- if oriO /= oriN then setNodeOri newED oriN else return ()- if sizeO /= sizeN then setNodeSiz newED sizeN else return ()- return newED- ) (zip3 edOldArr oldSubs newSubs)- return (EDNodeAndSub node' outArr)-- -- perform the actions, do a complete rebuild, since structure does not match- else if action == Rebuild- then do- -- delete old structure (to be done)- _removeFigure g3ds parent edata- -- create new structure, this is the easy part- _createFigure g3ds parent newFig-- -- no action needed, all the same- else if action == DoNothing- then return edata-- else return $ error ("HGamer3D.Graphics3D.Internal.Shapes._updateFigure: build action not known " ++ (show action))- - return edataNew- -_removeFigure :: Graphics3DSystem -> ONode -> EngineData -> IO ()-_removeFigure g3ds parent edata = do- case edata of- EDEntityNode e n -> _removeEntityAndNode g3ds parent e n- EDNodeAndSub n subs -> (mapM (\edata' -> _removeFigure g3ds n edata') subs) >> return ()- -instance Graphics3DItem Figure where- - object3D g3ds fig = do- rootNode <- _getRootNode g3ds- edata <- _createFigure g3ds rootNode fig- return $ Object3D edata fig-- update3D g3ds ob3d newFig = do- rootNode <- _getRootNode g3ds- let (Object3D oldEdata oldFig) = ob3d- newEdata <- _updateFigure g3ds rootNode oldEdata oldFig newFig- return $ Object3D newEdata newFig-- remove3D g3ds ob3d = do- rootNode <- _getRootNode g3ds- let (Object3D edata fig) = ob3d- _removeFigure g3ds rootNode edata- return ()---{- -------------------------------------------------------------------------------- intelligent constructors for simple geometries- ------------------------------------------------------------------------------- -}--sphere :: Graphics3DSystem -> Float -> Material -> IO (Object3D Figure)-sphere g3ds radius material = object3D g3ds (CombinedFigure [- (zeroVec3, unitU, Vec3 radius radius radius,- SimpleFigure Sphere material) ])--cube :: Graphics3DSystem -> Float -> Material -> IO (Object3D Figure)-cube g3ds len material = object3D g3ds (CombinedFigure [- (zeroVec3, unitU, Vec3 len len len,- SimpleFigure Cube material) ])--cuboid :: Graphics3DSystem -> Vec3 -> Material -> IO (Object3D Figure)-cuboid g3ds vec material = object3D g3ds (CombinedFigure [- (zeroVec3, unitU, vec, SimpleFigure Cube material) ])- -dodekaeder :: Graphics3DSystem -> Float -> Material -> IO (Object3D Figure)-dodekaeder g3ds len material = object3D g3ds (CombinedFigure [- (zeroVec3, unitU, Vec3 len len len, SimpleFigure Dodekaeder material) ])- -ikosaeder :: Graphics3DSystem -> Float -> Material -> IO (Object3D Figure)-ikosaeder g3ds len material = object3D g3ds (CombinedFigure [- (zeroVec3, unitU, Vec3 len len len, SimpleFigure Ikosaeder material) ])- -instance HasPosition (Object3D Figure) where- position obj = Node.getPosition (getNode' obj)- positionTo obj pos = Node.setPosition (getNode' obj) pos- -instance HasSize (Object3D Figure) where- size obj = Node.getScale (getNode' obj)- sizeTo obj pos = Node.setScale (getNode' obj) pos- -instance HasOrientation (Object3D Figure) where- orientation obj = do- q <- Node.getOrientation (getNode' obj)- let uq = mkNormal q- return uq- orientationTo obj uq = do- Node.setOrientation (getNode' obj) (fromNormal uq)- return ()-
− HGamer3D/Graphics3D/Schema/Camera.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}--- 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.---- HGamer3D/Graphics3D/Schema/Camera.hs---- | Types which describe the Scene, the high level of a Scene Tree-module HGamer3D.Graphics3D.Schema.Camera--where--import Data.Typeable-import HGamer3D.Data as Dat---- | The data to specify a camera-data Camera = Camera { - frustum :: Frustum, -- ^ Frustum of the camera ,- viewport :: Viewport -- ^ Where to draw on the window- } deriving (Eq, Show, Typeable)- --- | The frustum defines the area from which objects are rendered into the camera-data Frustum = Frustum {- nearDistance :: Float, -- ^ clipping distance near, objects which are nearer are not shown- farDistance :: Float, -- ^ clipping distance far, objects, which are more away are not shown- fieldOfViewHorizontal :: Dat.Angle -- ^ The field of view angle horizontally, the vertical direction is automatically determined by the aspect ratio of the final viewport window.- } deriving (Eq, Show, Typeable)--deriving instance Typeable1 Dat.Rectangle--data Viewport = Viewport {- zOrder :: Int, -- ^ Z order in case of overlapping Viewports, higher ZOrders are on top- position :: Dat.Rectangle Float, -- ^ position of viewport in Window, coordinates reaching from 0.0 to 1.0- backgroundColor :: Colour-} deriving (Eq, Show, Typeable)- -
− HGamer3D/Graphics3D/Schema/Figure.hs
@@ -1,38 +0,0 @@-{-# Language StandaloneDeriving, DeriveDataTypeable #-}--- 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.---- HGamer3D/Graphics3D/Schema/Figure.hs---- | data types which describe a combined geometry together with materials, a complete figure--module HGamer3D.Graphics3D.Schema.Figure--where--import Data.Typeable-import qualified HGamer3D.Data as D--import HGamer3D.Graphics3D.Schema.Geometry-import HGamer3D.Graphics3D.Schema.Material--data Figure = SimpleFigure Geometry Material- | ResourceFigure String- | CombinedFigure [(D.Position, D.Orientation, D.Size, Figure)]- deriving (Eq, Show, Typeable)-
− HGamer3D/Graphics3D/Schema/Geometry.hs
@@ -1,50 +0,0 @@-{-# Language StandaloneDeriving, DeriveDataTypeable #-}--- 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.---- HGamer3D/Graphics3D/Schema/Geometry.hs---- | data types which describe the Geometry --module HGamer3D.Graphics3D.Schema.Geometry--where--import Data.Typeable-import qualified HGamer3D.Data as D--data Geometry = -- -- loaded from resources- ResourceGeometry String-- -- Primitive 3D Geometries- | Cube- | Sphere--- | Cylinder-- -- Platon Geometries- | Ikosaeder- | Dodekaeder-- -- 2D Geometries- | Plane--- | Line-- deriving (Eq, Show, Typeable)-
− HGamer3D/Graphics3D/Schema/Light.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}--- 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.---- HGamer3D/Graphics3D/Schema/Light.hs---- | Types which describe Light-module HGamer3D.Graphics3D.Schema.Light--where--import Data.Typeable--import HGamer3D.Data as Dat----- | The Light data type---data Light = Light {- diffuseColour :: Colour,- specularColour :: Colour,- lightType :: LightType- } deriving (Eq, Show, Typeable)--data LightType = PointLight -- ^ A source shining from one location- | DirectionalLight Vec3 -- ^ A source shining from one direction (like the sun)- | SpotLight Vec3 Angle Angle -- ^ A source shining from one location into one direction with a cone,- -- angles are inner angle, outer angle (a flashlight).- -- Angles should be between 5 and 355 degrees.- deriving (Eq, Show, Typeable)- ---
− HGamer3D/Graphics3D/Schema/Material.hs
@@ -1,35 +0,0 @@-{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}--- 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.---- HGamer3D/Graphics3D/Schema/Material.hs---- | data types which describe Materials-module HGamer3D.Graphics3D.Schema.Material--where--import qualified HGamer3D.Data as D-import Data.Typeable---- | The material itself-data Material = ResourceMaterial String -- ^ the name given the material resource in the resource system- deriving (Eq, Show, Typeable)-- -
− HGamer3D/Graphics3D/Schema/Scene.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}--- 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.---- HGamer3D/Graphics3D/Schema/Scene.hs---- | Types which describe global Scene Parameters-module HGamer3D.Graphics3D.Schema.Scene--where--import Data.Typeable--import HGamer3D.Data as Dat-import HGamer3D.Graphics3D.Schema.Material--data SceneParameter = SceneParameter {- ambientLight :: Colour,- shadowType :: ShadowType,- skyType :: SkyType- } deriving (Eq, Show, Typeable)--data ShadowType = NoShadows- | TextureAdditive- | TextureModulative- | StencilAdditive- | StencilModulative- deriving (Eq, Show, Typeable)--data SkyType = NoSky- | SkyBox Material Float -- Distance- | SkyDome Material Float Float Float -- Curvature, Tiling, Distance- deriving (Eq, Show, Typeable)
+ HGamer3D/Graphics3D/SystemGraphics3D.hs view
@@ -0,0 +1,514 @@+{-# 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 ()+++-}++
+ HGamer3D/Graphics3D/WinEvent.hs view
@@ -0,0 +1,143 @@+{-# 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.++-- | Windowing and Event functionality for HGamer3D, implementation module. This modules exposes internal data structures, public API is in HGamer3D.WinEvent.+module HGamer3D.Graphics3D.WinEvent+(+ EnumWinEventInit (..),++ SDLSystem,+ initWinEvent,+ freeWinEvent,++ attachToWindow,+ openWindow,+ pollWinEvent,+ showCursor,++ module HGamer3D.Bindings.SDL2.StructSDLEvent,+ module HGamer3D.Bindings.SDL2.EnumSDLEventType,+ module HGamer3D.Bindings.SDL2.EnumSDLKeymod,+ module HGamer3D.Bindings.SDL2.EnumSDLScancode,+ module HGamer3D.Bindings.SDL2.EnumSDLWindowEventID,+ module HGamer3D.Bindings.SDL2.EnumSDLWindowFlags,+)++where++import GHC.Ptr+import HGamer3D.Data+import HGamer3D.Data.Window++import HGamer3D.Bindings.SDL2.ClassPtr+import HGamer3D.Bindings.SDL2.Utils+++import HGamer3D.Bindings.SDL2.EnumSDLEventType+import HGamer3D.Bindings.SDL2.EnumSDLKeymod+import HGamer3D.Bindings.SDL2.EnumSDLScancode+import HGamer3D.Bindings.SDL2.EnumSDLWindowEventID+import HGamer3D.Bindings.SDL2.EnumSDLWindowFlags++import HGamer3D.Bindings.SDL2.StructSDLEvent++import HGamer3D.Bindings.SDL2.HeaderSDL+import HGamer3D.Bindings.SDL2.HeaderSDLVideo+import HGamer3D.Bindings.SDL2.HeaderSDLEvents+import HGamer3D.Bindings.SDL2.EnumSDLWindowFlags+import HGamer3D.Bindings.SDL2.HeaderSDLMouse+import HGamer3D.Bindings.SDL2.ClassHG3DUtilities++import Foreign.Marshal.Utils+import Control.Monad+import Control.Applicative++data SDLSystem = SDLSystem (Ptr SDLWindow)++-- WinEvent Initialization Flags+data EnumWinEventInit = WEV_INIT_VIDEO -- ^ initialize Video subsystem+ | WEV_INIT_TIMER -- ^ initialize Timer subsystem+ | WEV_INIT_EVENTS -- ^ initialize Event subsystem++instance Enum EnumWinEventInit where+ toEnum 0x20 = WEV_INIT_VIDEO+ toEnum 0x4000 = WEV_INIT_EVENTS+ toEnum 0x01 = WEV_INIT_TIMER++ fromEnum WEV_INIT_VIDEO = 0x20+ fromEnum WEV_INIT_EVENTS = 0x4000+ fromEnum WEV_INIT_TIMER = 0x01++-- show instance for SDLEvent+instance Show SDLEvent where+ show (EvtQuit ts) = "Event-Quit"+ show (EvtKeyUp ts window keyscan keycode keymode) = "Event-KeyUp " ++ (show (fromEnum keyscan))+ show (EvtKeyDown ts window keyscan keycode keymode) = "Event-KeyDown " ++ (show (fromEnum keyscan))+ show (EvtText ts window text) = "Event-Text " ++ text+ show (EvtMouseButtonUp ts window mid button x y) = "Event-MouseButtonUp " ++ (show button) ++ " " ++ (show x) ++ " " ++ (show y) + show (EvtMouseButtonDown ts window mid button x y) = "Event-MouseButtonDown " ++ (show button) ++ " " ++ (show x) ++ " " ++ (show y) + show (EvtMouseMotion ts window mid x y rx ry) = "Event-MouseMotion " ++ (show x) ++ " " ++ (show y) ++ " r: " ++ (show rx) ++ " " ++ (show ry)+ show (EvtWindow ts window weid x y) = "Event-Window " ++ (show (fromEnum weid)) ++ " " ++ (show x) ++ " " ++ (show y)+ show _ = "Specific Event is not in show instance"++-- | Initialization of WinEvent+initWinEvent :: [EnumWinEventInit] -- ^ Initialization Flags+ -> IO Int -- ^ result != 0 in case of errors+initWinEvent flags = do+ res <- sdlInit $ sum (fmap fromEnum flags)+ return res+ +-- | Un-initialize WinEvent and free resources+freeWinEvent :: IO ()+freeWinEvent = sdlQuit+++attachToWindow :: Window -> IO (SDLSystem)+attachToWindow (Window handle) = do+ res <- createWindowFromHandle handle+ return $ SDLSystem res++-- | open new window+openWindow :: String -- ^ Window Display Name+ -> Int -- ^ X coordinate of Window+ -> Int -- ^ Y coordinate of Window+ -> Int -- ^ Width of Window+ -> Int -- ^ Height of Window+ -> [EnumSDLWindowFlags] -- ^ initialization flags+ -> IO (SDLSystem)+openWindow title x y w h flags = do+ win <- sdlCreateWindow title x y w h (sum $ fmap fromEnum flags)+ return $ SDLSystem win++-- | query for events from windowing system+pollWinEvent :: IO (Maybe SDLEvent)+pollWinEvent = do+ (sdlevt, res) <- sdlPollEvent+ let r = case res of+ 0 -> Nothing+ 1 -> Just sdlevt+ _ -> Nothing+ return r++-- | show / hide cursor, returns previous state+showCursor :: Bool -> IO Bool+showCursor flag = do+ ival <- sdlShowCursor (fromBool flag)+ return (toBool ival)+
− HGamer3D/Internal/Graphics3D.hs
@@ -1,38 +0,0 @@--- 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) 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.---- Graphics.hs---- | Internal API of Graphics3D (Implementation)-module HGamer3D.Internal.Graphics3D--(- module HGamer3D.Graphics3D.Internal.Base,- module HGamer3D.Graphics3D.Internal.Shapes,- module HGamer3D.Graphics3D.Internal.Light,- module HGamer3D.Graphics3D.Internal.PlatonShapes,- module HGamer3D.Graphics3D.Internal.Camera-)--where--import HGamer3D.Graphics3D.Internal.Base-import HGamer3D.Graphics3D.Internal.Shapes-import HGamer3D.Graphics3D.Internal.Light-import HGamer3D.Graphics3D.Internal.PlatonShapes-import HGamer3D.Graphics3D.Internal.Camera
LICENSE view
@@ -1,42 +1,42 @@-LICENSE -------- - -(c) 2011-2014 Peter Althainz - - -HGamer3D (http://www.hgamer3d.org) ----------------------------------- - -HGamer3D is licensed under the Apache License, Version 2.0 (the "License"); you may not use this software 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. - - -Source Code ------------ -You can obtain the latest version of the source code under http://www.bitbucket.org/althainz/HGamer3D - - -Open Source Software Used - Module HGamer3D -------------------------------------------- - -HGamer3D uses a number of open source software libraries. You are responsible to comply to the licenses of those packages and the licenses of software used by those packages if you use HGamer3D. - -The HGamer3D module uses the following Haskell libraries from Hackage: - -base, license: BSD3 -containers, license: BSD3 -text, license: BSD3 -directory, license: BSD3 -mtl, license: BSD3 -FindBin, license: BSD3 -monad-loops, license: PublicDomain, BSD3 similar -split, license: BSD3 -netwire, license: BSD3 -HGamer3D-Data, license: Apache 2.0 -HGamer3D-Ogre-Binding, license: Apache 2.0 and dependencies see in that module -HGamer3D-SFML-Binding, license: Apache 2.0 and dependencies see in that module -HGamer3D-CEGUI-Binding, license: Apache 2.0 and dependencies see in that module -HGamer3D-Enet-Binding, license: Apache 2.0 and dependencies see in that module +LICENSE+-------++(c) 2011-2014 Peter Althainz+++HGamer3D (http://www.hgamer3d.org)+----------------------------------++HGamer3D is licensed under the Apache License, Version 2.0 (the "License"); you may not use this software 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.+++Source Code+-----------+You can obtain the latest version of the source code under http://www.bitbucket.org/althainz/HGamer3D+++Open Source Software Used - Module HGamer3D+-------------------------------------------++HGamer3D uses a number of open source software libraries. You are responsible to comply to the licenses of those packages and the licenses of software used by those packages if you use HGamer3D. ++The HGamer3D module uses the following Haskell libraries from Hackage:++base, license: BSD3+containers, license: BSD3+text, license: BSD3+directory, license: BSD3+mtl, license: BSD3+FindBin, license: BSD3+monad-loops, license: PublicDomain, BSD3 similar+split, license: BSD3+netwire, license: BSD3+HGamer3D-Data, license: Apache 2.0+HGamer3D-Ogre-Binding, license: Apache 2.0 and dependencies see in that module+HGamer3D-SFML-Binding, license: Apache 2.0 and dependencies see in that module +HGamer3D-CEGUI-Binding, license: Apache 2.0 and dependencies see in that module+HGamer3D-Enet-Binding, license: Apache 2.0 and dependencies see in that module
Setup.hs view
@@ -1,22 +1,22 @@--- 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-2013 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. - --- Setup.hs - -import Distribution.Simple -main = defaultMain +-- 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-2013 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.++-- Setup.hs++import Distribution.Simple+main = defaultMain