diff --git a/HGamer3D-Wire.cabal b/HGamer3D-Wire.cabal new file mode 100644 --- /dev/null +++ b/HGamer3D-Wire.cabal @@ -0,0 +1,33 @@ +Name: HGamer3D-Wire +Version: 0.3.0 +Synopsis: Wire Functionality for HGamer3D +Description: + HGamer3D is a game engine for developing 3D games in the programming + language Haskell. This package provides wiring functionality, + based on the package HGamer3D and netwire. HGamer3D-Wire + 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, netwire >= 5, containers, transformers, mtl, HGamer3D-Data >= 0.3.0 && < 0.4.0, HGamer3D >= 0.3.0 && < 0.4.0, HGamer3D-GUI >= 0.3.0 && < 0.4.0, HGamer3D-InputSystem >= 0.3.0 && < 0.4.0, HGamer3D-Audio >= 0.3.0 && < 0.4.0, HGamer3D-WinEvent >= 0.3.0 && < 0.4.0 + + Exposed-modules: HGamer3D.Wire.Types,HGamer3D.Wire.EntityComponentSystem,HGamer3D.Wire.ECSWire,HGamer3D.Wire.GUI,HGamer3D.Wire + Other-modules: + + c-sources: + + ghc-options: + cc-options: -Wno-attributes + hs-source-dirs: . + Include-dirs: . + build-depends: + extra-libraries: diff --git a/HGamer3D/Wire.hs b/HGamer3D/Wire.hs new file mode 100644 --- /dev/null +++ b/HGamer3D/Wire.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE Arrows #-} + +-- Some useful wires for game programming +-- +-- (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. + + +module HGamer3D.Wire ( + + module HGamer3D.Wire.Types, + module HGamer3D.Wire.EntityComponentSystem, + module HGamer3D.Wire.ECSWire, + module HGamer3D.Wire.GUI, + + HGamer3D.Wire.loopHGamer3D, + HGamer3D.Wire.initHGamer3D, + HGamer3D.Wire.exitHGamer3D + + ) where + +import Control.Wire as W +import Control.Wire.Unsafe.Event as U + +import Prelude hiding ((.), id) + +import HGamer3D +import HGamer3D.Audio +import HGamer3D.InputSystem +import HGamer3D.WinEvent hiding (initHGamer3D, loopHGamer3D, exitHGamer3D) +import HGamer3D.GUI + +import Control.Monad.Trans.Maybe + +import HGamer3D.Wire.Types +import HGamer3D.Wire.EntityComponentSystem +import HGamer3D.Wire.ECSWire +import HGamer3D.Wire.GUI + +import Data.IORef +import qualified Data.Map as M +import Data.Maybe + + + +-- event register mechanism + +-- init + +initHGamer3D :: String -- ^ Window Title + -> Bool -- ^ Flag show config dialogue + -> Bool -- ^ Flag logging enabled + -> Bool -- ^ show Graphics Cursor + -> IO (WireSystem, Camera, Viewport) +initHGamer3D windowTitle fConfigDialogue fLog fGraphicsCursor = do + (g3ds, guis, camera, viewport) <- HGamer3D.initHGamer3D windowTitle fConfigDialogue fLog fGraphicsCursor + un <- createUniqueName "wire" + gedm <- newIORef (M.fromList []) + wedm <- newIORef [] + widgetListRef <- newIORef [] + let evtDistMap = (gedm, wedm) + let ws = WireSystem un g3ds guis evtDistMap widgetListRef + return (ws, camera, viewport) + +-- loop + +loopHGamer3D :: WireSystem -> IO Bool +loopHGamer3D ws = do + let g3ds = wsG3d ws + let guis = wsGui ws + let (gedm, wedm) = wsEvtDistMap ws + (mevt, qFlag) <- HGamer3D.loopHGamer3D g3ds guis + qFlag' <- case mevt of + Just (EventWindow sdle) -> do + fm <- readIORef wedm + mapM (\fwin -> fwin sdle) fm + case sdle of + (EvtQuit _) -> return True + _ -> return False + Just (EventGUI gevts) -> do + mapM (\gevt@(GUIEvent tag _ _) -> do + fm <- readIORef gedm + let f = fromJust (M.lookup tag fm) + f gevt + return ()) gevts + return False + _ -> return False + + return (qFlag || qFlag') + +-- exit + +exitHGamer3D = HGamer3D.exitHGamer3D + + + diff --git a/HGamer3D/Wire/ECSWire.hs b/HGamer3D/Wire/ECSWire.hs new file mode 100644 --- /dev/null +++ b/HGamer3D/Wire/ECSWire.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE Arrows #-} + +-- Some useful wires for game programming +-- +-- (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. + +module HGamer3D.Wire.ECSWire where + +import Control.Wire as W +import Control.Wire.Unsafe.Event as U + +import Prelude hiding ((.), id) + +import HGamer3D +import HGamer3D.Audio +import HGamer3D.InputSystem + +import HGamer3D.Wire.Types +import HGamer3D.Wire.EntityComponentSystem + +import Control.Monad.Trans.Maybe + +-- ECS Wires + +-- move position of Entity by a vector (per second) +move :: Entity -> Vec3 -> GameWire (Event a) (Event a) +move e vec = mkGen $ \s evt -> case evt of + Event _ -> do + let t = realToFrac (dtime s) + runMaybeT $ setLocation e (\pos -> pos &+ (vec &* t)) + return (Right evt, move e vec) + _ -> return (Right evt, move e vec) + +rotate :: Entity -> Vec3 -> Float -> GameWire (Event a) (Event a) +rotate e rv a = mkGen $ \s evt -> case evt of + Event _ -> do + let t = realToFrac (dtime s) + runMaybeT $ setOrientation e (\ori -> ori .*. (rotU rv (a*t))) + return (Right evt, rotate e rv a) + _ -> return (Right evt, rotate e rv a) + +accelerate :: Entity -> Vec3 -> GameWire (Event a) (Event a) +accelerate e vec = mkGen $ \s evt -> case evt of + Event _ -> do + runMaybeT $ setVelocity e (\vel -> vel &+ vec) + return $ (Right evt, accelerate e vec) + _ -> return $ (Right evt, accelerate e vec) + + +-- move position to target within specific time +moveTo :: Entity -> Vec3 -> Float -> GameWire a () +moveTo e target dt = let + startAction = do + runMaybeT (do + loc <- getLocation e + let vel = (target &- loc) &* (1.0 / dt) + setVelocity e (\_ -> vel) + return () ) + return $ Left () + endAction = do + runMaybeT (do + setVelocity e (\_ -> (Vec3 0.0 0.0 0.0)) + setLocation e (\_ -> target) + return () ) + return $ Left () + in (mkGen_ (\_ -> startAction)) --> for (realToFrac dt) . pure () --> (mkGen_ (\_ -> endAction)) + + +-- USEFUL WIRES + +-- sends the event one time and then inhibit ! + +sendOnce :: GameWire (W.Event a) (W.Event a) +sendOnce = proc inevt -> do + rec + devt <- delay (U.NoEvent) -< devt' + devt' <- id -< inevt + case devt of + U.NoEvent -> do + returnA -< inevt + U.Event evt -> do + x <- pure U.NoEvent . mkEmpty -< () + returnA -< x + +-- wire to play a sound +soundW :: AudioSource -> Wire s e IO (W.Event a) (W.Event a) +soundW aSource = onEventM (\aIn -> do + playAudioSource aSource + return aIn ) + +-- samples generated keypress +keyW :: EnumKey -> Wire s e IO a (W.Event a) +keyW key = mkGen_ ( \inVal -> do + press <- isKeyPressed key + let evt = if press then U.Event inVal else U.NoEvent + return $ (Right evt) ) + +-- Cycles through a list, stop at end +cycleW :: [b] -> Wire s () IO (W.Event a) (W.Event b) +cycleW lin = if length lin > 0 then + mkPureN (\evt -> case evt of + U.Event _ -> (Right (U.Event (head lin)), cycleW (tail lin)) + _ -> (Right U.NoEvent, cycleW lin) ) + else + mkConst $ Left () + + +printEvt :: Show a => GameWire (W.Event a) (W.Event a) +printEvt = mkGen_ (\evt -> do case evt of + U.Event x -> do + print x + return (Right evt) + _ -> return (Right evt)) + + +-- generic switch, in event is two-fold, left side creates new wire of a -> b +-- right side is a output is b, runs sequentially, first do new wire switched in, then restart switch logic + +-- different types of switching logic, eases up game programming +---------------------------------------------------------------- + +-- this wire creates a wire from a function which creates a wire from an input status +-- the resulting wire switches into the created wire, runs this until it inihibits and then +-- switches back to the switchIntoAndRun semantics + +-- useful for providing game states, which run for a certain amount of time and then wait for a new +-- initializer, during running the created wire additional state input is ignored + +switchIntoAndRunW :: (gst -> GameWire (Event a) (Event b)) -> GameWire (Event gst, Event a) (Event b) +switchIntoAndRunW inWireF = switch $ mkPure_ (\(gsEvt, aEvt) -> case gsEvt of + Event gs -> let + newWire = (inWireF gs) . mkPure_ (\(a, b) -> Right b) --> switchIntoAndRunW inWireF + in Right (NoEvent, Event (newWire)) + _ -> Right (NoEvent, NoEvent) ) + +-- same logic, but does not need to process events during run phase +-- usefule if something needs to happen, but no input processing +switchIntoAndRunW' :: (gst -> GameWire () (Event b)) -> GameWire (Event gst) (Event b) +switchIntoAndRunW' inWireF = switch $ mkPure_ (\gsEvt -> case gsEvt of + Event gs -> let + newWire = (inWireF gs) . pure () --> switchIntoAndRunW' inWireF + in Right (NoEvent, Event (newWire)) + _ -> Right (NoEvent, NoEvent) ) + + + diff --git a/HGamer3D/Wire/EntityComponentSystem.hs b/HGamer3D/Wire/EntityComponentSystem.hs new file mode 100644 --- /dev/null +++ b/HGamer3D/Wire/EntityComponentSystem.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE Arrows #-} + +-- (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. + +module HGamer3D.Wire.EntityComponentSystem where + +import HGamer3D.Wire.Types + +import HGamer3D +import HGamer3D.Audio +import HGamer3D.InputSystem + +import Control.Monad.Trans +import Control.Monad.Trans.Maybe + +import Control.Wire +import Control.Wire.Unsafe.Event + +import Prelude hiding ((.), id) +import Data.List +import Data.IORef +import Data.Dynamic +import Data.Maybe +import qualified Data.Map as M + +createSystem :: SystemData d -> GameWire (Event Command) (Event Command) +createSystem sdata = let + + (SystemData initD addE remE runAction) = sdata + dOut dIn evt = case evt of + (Event (CmdAddEntity ent)) -> (addE ent dIn) + (Event (CmdRemEntity oid)) -> (remE oid dIn) + _ -> dIn + wire dIn = mkGen (\s evt -> do + let out = dOut dIn evt + runAction out s + return (Right evt, wire out) ) + in wire initD + +-- a wire which deconstructs a CmdArr into a sequence of single events +-- single commands will be ignored and not added to the list +-- to be added into a chain of command senders, receivers +cmdFifo :: GameWire (Event Command) (Event Command) +cmdFifo = fifo_ [] where + fifo_ list = mkPureN (\cmdIn -> let + newList = case cmdIn of + (Event (CmdArr addList)) -> list ++ addList + _ -> list -- do not add single command here, intentionally, this will create an infinite loop in a chain + (evtOut, listOut) = case newList of + [] -> (NoEvent,[]) + (e:es) -> (Event e, es) + in (Right evtOut, fifo_ listOut) ) + +readIORef' :: IORef a -> MaybeT IO a +readIORef' ref = MaybeT $ do + val <- readIORef ref + return $ Just val + +writeIORef' :: IORef a -> a -> MaybeT IO () +writeIORef' ref val = MaybeT $ do + writeIORef ref val + return $ Just () + +modifyIORef' :: IORef a -> (a -> a) -> MaybeT IO () +modifyIORef' ref f = MaybeT $ do + x <- readIORef ref + let x' = (f x) + x' `seq` writeIORef ref x' + return $ Just () + +getC :: Typeable a => Entity -> Maybe a +getC entity = case find isJust (map fromDynamic (entComps entity)) of + Just (Just c) -> Just c + _ -> Nothing + +getC' :: Typeable a => Entity -> MaybeT IO a +getC' entity = MaybeT $ + do + let rval = getC entity + return rval + +-- LOCATION + +getLocation :: Entity -> MaybeT IO Vec3 +getLocation e = do + LocationC l <- getC' e + val <- readIORef' l + return val + +setLocation :: Entity -> (Vec3 -> Vec3) -> MaybeT IO () +setLocation e f = do + LocationC l <- getC' e + modifyIORef' l f + return () + +locationSystem :: SystemData (M.Map ObId (IORef Vec3, Object3D)) +locationSystem = let + fInit = M.fromList [] :: M.Map ObId (IORef Vec3, Object3D) + fAdd e mapIn = case (getC e, getC e) of + (Just (LocationC ref), Just (ObjectC o3d)) -> M.insert (entId e) (ref, o3d) mapIn + _ -> mapIn + fRem = M.delete + runAction mapIn _ = do + mapM (\(ref, obj3D) -> do + pos <- readIORef ref + positionTo3D obj3D pos ) (map snd (M.toList mapIn)) + return () + in (SystemData fInit fAdd fRem runAction) + +-- ORIENTATION + +getOrientation :: Entity -> MaybeT IO U +getOrientation e = do + OrientationC o <- getC' e + val <- readIORef' o + return $ val + +setOrientation :: Entity -> (U -> U) -> MaybeT IO () +setOrientation e f = do + OrientationC o <- getC' e + modifyIORef' o f + return () + +orientationSystem :: SystemData (M.Map ObId (IORef UnitQuaternion, Object3D)) +orientationSystem = let + fInit = M.fromList [] :: M.Map ObId (IORef UnitQuaternion, Object3D) + fAdd e mapIn = case (getC e, getC e) of + (Just (OrientationC ref), Just (ObjectC o3d)) -> M.insert (entId e) (ref, o3d) mapIn + _ -> mapIn + fRem = M.delete + runAction mapIn _ = do + mapM (\(ref, obj3D) -> do + ori <- readIORef ref + orientationTo3D obj3D ori) (map snd (M.toList mapIn)) + return () + in (SystemData fInit fAdd fRem runAction) + +-- VELOCITY + +getVelocity :: Entity -> MaybeT IO Vec3 +getVelocity e = do + VelocityC v <- getC' e + val <- readIORef' v + return $ val + +setVelocity :: Entity -> (Vec3 -> Vec3) -> MaybeT IO () +setVelocity e f = do + VelocityC v <- getC' e + modifyIORef' v f + return () + +velocitySystem :: SystemData (M.Map ObId (IORef Vec3, IORef Vec3)) +velocitySystem = let + fInit = M.fromList [] :: M.Map ObId (IORef Vec3, IORef Vec3) + fAdd e mapIn = case (getC e, getC e) of + (Just (VelocityC rV), Just (LocationC rP)) -> M.insert (entId e) (rV, rP) mapIn + _ -> mapIn + fRem = M.delete + runAction mapIn s = do + mapM (\(rV, rP) -> do + vel <- readIORef rV + let t = realToFrac $ dtime s :: Float + runMaybeT (modifyIORef' rP (\pos -> pos &+ (vel &* t))) ) (map snd (M.toList mapIn)) + return () + in (SystemData fInit fAdd fRem runAction) + + +-- ENTITY CREATION + +-- create entity with a graphics object, a location and a velocity +veloEntity :: String -> Object3D -> Vec3 -> IO Entity +veloEntity name obj pos = do + ref <- newIORef pos + vel <- newIORef (Vec3 0.0 0.0 0.0) + let e = Entity name [ + toDyn (LocationC ref), + toDyn (VelocityC vel), + toDyn (ObjectC obj) + ] + return e + +-- create entity with a graphics object and a rotation, only +rotEntity :: String -> Object3D -> UnitQuaternion -> IO Entity +rotEntity name obj ori = do + ref <- newIORef ori + let e = Entity name [ + toDyn (OrientationC ref), + toDyn (ObjectC obj) + ] + return e diff --git a/HGamer3D/Wire/GUI.hs b/HGamer3D/Wire/GUI.hs new file mode 100644 --- /dev/null +++ b/HGamer3D/Wire/GUI.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE Arrows #-} + +-- 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. + +-- Wire/GUI.hs + +-- | The GUI functionality of the FRP API +module HGamer3D.Wire.GUI +( + -- * fundamental and simple Wires + guiEventW, + guiPropertyW, + + buttonW, + staticTextW, + + -- * editable GUI element Wires + -- $EditGUIWire + editBoxW, + doubleBoxW, + checkBoxW, + radioButtonW, + + -- * special elements + sliderW, + spinnerW, + listBoxW +) + +where + +import HGamer3D +import HGamer3D.GUI + +import Control.Monad.Trans + +import Control.Monad.Identity (Identity) +import Control.Wire +import Control.Wire.Unsafe.Event +import Prelude hiding ((.), id) + +import Data.IORef +import HGamer3D.Wire.Types + + +-- functions to put gui events into a list and pop them out again, as well as fire, when there is an event in it +-- + +_gatherGUIEvents :: IORef [evtType] -> evtType -> IO () +_gatherGUIEvents ref event = do + list <- readIORef ref + liftIO $ writeIORef ref (list ++ [event]) + return () + +_popGUIEvent :: IORef [evtType] -> IO (Event evtType) +_popGUIEvent ref = do + list <- readIORef ref + case list of + [] -> return NoEvent + (x : xs) -> do + writeIORef ref xs + return $ Event x + +guiEventW :: WireSystem -> String -> String -> IO (GameWire a (Event a)) +guiEventW ws widgetname eventname = do + let guis = wsGui ws + let un = wsUniqueName ws + widget <- getGuiWidget ws widgetname + tagname <- nextUniqueName un + ref <- liftIO $ newIORef [] + registerGUIEvent guis widget eventname tagname + registerGUIEventFunction ws tagname (_gatherGUIEvents ref) + let wire = mkGen_ (\aval -> do + rval <- _popGUIEvent ref + case rval of + Event _ -> return (Right (Event aval)) + NoEvent -> return (Right NoEvent) ) + return wire + +buttonW :: WireSystem + -> String -- ^ GUI element (which should be a button) + -> IO (GameWire a (Event a)) -- ^ event wire +buttonW ws widgetname = do + wire <- guiEventW ws widgetname "Clicked" + return wire + +guiPropertyW :: WireSystem + -> String + -> String -- ^ property name + -> IO (GameWire (Event a, Event String) (Event String)) +guiPropertyW ws widgetname propname = do + widget <- getGuiWidget ws widgetname + let wire = mkGen_ (\(evtL, evtR) -> do + let rVal = do + case evtL of + Event _ -> do + val <- getGuiElProperty widget propname + return (Right (Event val)) + _ -> return $ Right NoEvent + + case evtR of + Event value -> do + setGuiElProperty widget propname value + r <- rVal + return r + _ -> do + r <- rVal + return r) + return wire + +_createGUIValueW :: WireSystem -> String -> String -> String -> IO (GameWire (Event a, Event String) (Event String)) +_createGUIValueW ws widgetname propname eventchangename = do + widget <- getGuiWidget ws widgetname + propW <- guiPropertyW ws widgetname propname + eventW <- guiEventW ws widgetname eventchangename + let wire = proc (evtL, evtR) -> do + changeEvent <- eventW -< () + let evtLN = fmap (\x -> ()) evtL + inhibitFlag <- pure False . holdFor 0.5 <|> pure True -< evtR + evtL' <- arr (\(l, c, p) -> mergeL l (if p then c else NoEvent) ) -< (evtLN, changeEvent, inhibitFlag) + rVal <- propW -< (evtL', evtR) + returnA -< rVal + return wire + +-- | Constructor for two wires, which in combination provide the functionality of an editable box GUI element. +editBoxW :: WireSystem + -> String -- ^ GUI element (should be an editbox) + -> IO (GameWire (Event a, Event String) (Event String) ) +editBoxW ws widgetname = _createGUIValueW ws widgetname "Text" "TextChanged" + +_strtd :: Double -> GameWire (Event String) (Event Double) +_strtd def = (arr . fmap) (\str -> case (reads str)::[(Double, String)] of + [(a, str)] -> a + _ -> def) +_dtstr :: GameWire (Event Double) (Event String) +_dtstr = (arr . fmap) (\d -> show d) + +doubleBoxW :: WireSystem + -> String -- ^ GUI element (should be an editbox) + -> Double -- ^ Default double in case instring does not produce a value + -> IO (GameWire (Event a, Event Double) (Event Double) ) +doubleBoxW ws widgetname def = do + wire <- editBoxW ws widgetname + let wire' = _strtd def . wire . (second _dtstr) + return wire' + +-- | Constructur for a wire, which can change a static text GUI element (a setter). +staticTextW :: WireSystem + -> String -- ^ GUI element (should be a static text, or any widget with a "Text" property. + -> IO (GameWire (Event a, Event String) (Event String)) -- ^ the returned wire +staticTextW ws widgetname = guiPropertyW ws widgetname "Text" + +_bst = arr (\val -> fmap (\b -> if b then "True" else "False") val) +_stb = arr (\val -> fmap (\st -> if st == "True" then True else False) val) + +-- | Consructor for two wires, which deliver the checkbox GUI element functionality. +checkBoxW :: WireSystem + -> String -- ^ GUI element (should be a checkbox) + -> IO (GameWire (Event a, Event Bool) (Event Bool) ) +checkBoxW ws widgetname = do + wire <- _createGUIValueW ws widgetname "Selected" "CheckStateChanged" + return $ _stb . wire . second _bst + +-- | Constructor for two wires, which deliver the radiobuttion GUI element functionality. +radioButtonW :: WireSystem + -> String -- ^ GUI element (should be a checkbox) + -> IO (GameWire (Event a, Event Bool) (Event Bool) ) +radioButtonW ws widgetname = do + wire <- _createGUIValueW ws widgetname "Selected" "SelectStateChanged" + return $ _stb . wire . second _bst + +-- | Constructor for two wires, which deliver the slider GUI element functionality. +sliderW :: WireSystem + -> String -- ^ GUI element (should be a slider) + -> Double -- ^ Default Double + -> IO (GameWire (Event a, Event Double) (Event Double)) -- ^ the returned wires, a value changed wire and a setter wire +sliderW ws widgetname def = do + wire <- _createGUIValueW ws widgetname "CurrentValue" "ValueChanged" + return $ _strtd def . wire . second _dtstr + +-- | Constructur for two wires, which deliver the spinner GUI element functionality. +spinnerW :: WireSystem + -> String -- ^ GUI element (should be a spinner) + -> Double -- ^ Default Double + -> IO (GameWire (Event a, Event Double) (Event Double)) -- ^ the returned wires, a value changed wire and a setter wire +spinnerW = sliderW + + + + +-- LISTBOX AND COMBOBOX +----------------------- + +_guiPropertyListboxW :: GUIElement + -> IO (GameWire (Event a, Event [(String, Bool, b)]) (Event [(String, Bool, b)])) +_guiPropertyListboxW widget = do + let wire slist = mkGenN (\(evtL, evtR) -> do + let rVal slist' = do + case evtL of + Event _ -> do + val <- listboxStatus widget + let val' = fmap (\( (e', s'), (e, s, n)) -> (e', s', n)) (zip val slist') + return (Right (Event val'), wire slist') + _ -> return (Right NoEvent, wire slist') + + case evtR of + Event value -> do + let value' = fmap (\(e, s, n) -> (e, s)) value + listboxInitialize widget value' + r <- rVal value + return r + _ -> do + r <- rVal slist + return r) + return $ wire [] + +listBoxW :: WireSystem + -> String -- ^ GUI element + -> IO (GameWire (Event a, Event [(String, Bool, b)]) (Event [(String, Bool, b)])) -- ^ In: request val, set list, set choices +listBoxW ws widgetname = do + widget <- getGuiWidget ws widgetname + propW <- _guiPropertyListboxW widget + eventW <- guiEventW ws widgetname "ItemSelectionChanged" + let wire = proc (evtL, evtR) -> do + changeEvent <- eventW -< () + let evtLN = fmap (\x -> ()) evtL + inhibitFlag <- pure False . holdFor 0.5 <|> pure True -< evtR + evtL' <- arr (\(l, c, p) -> mergeL l (if p then c else NoEvent) ) -< (evtLN, changeEvent, inhibitFlag) + rVal <- propW -< (evtL', evtR) + returnA -< rVal + return wire + + + diff --git a/HGamer3D/Wire/Types.hs b/HGamer3D/Wire/Types.hs new file mode 100644 --- /dev/null +++ b/HGamer3D/Wire/Types.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE Arrows, DeriveDataTypeable, StandaloneDeriving #-} + +module HGamer3D.Wire.Types + + +where + +import Data.IORef +import Data.Typeable +import Data.Dynamic +import Data.List +import Data.Maybe +import qualified Data.Map as M + +import HGamer3D +import HGamer3D.Audio +import HGamer3D.InputSystem + +import Control.Wire +import Control.Wire.Unsafe.Event +import Prelude hiding ((.), id) + +-- One type for event map, unique names, guisystem, graphics3Dsystem +-------------------------------------------------------------------- + +data WireSystem = WireSystem { + wsUniqueName :: UniqueName, + wsG3d :: Graphics3DSystem, + wsGui :: GUISystem, + wsEvtDistMap :: (IORef (M.Map String (GUIEvent -> IO ())), IORef [(SDLEvent -> IO ())] ), + wsGuiElList :: IORef [GUIElement] + } + +-- The basic Wire type +---------------------- + +type Time = Double +type RunState = (Timed NominalDiffTime ()) +type GameWire = Wire RunState () IO + +-- Entity Component System +-------------------------- + +-- this is a prototype implementation to show the potential +-- IORef's are solely used in the system data aka components of the engine +-- (reading some ECS literature, I thought implementing components as pure FRP might be a big hassle) + +-- object ids will be simple string +type ObId = String + +-- a component holds the "data", a state with an identity, there are different types of components +-- each component comes with its onwn type of system +data LocationC = LocationC (IORef Vec3) deriving (Typeable) +data OrientationC = OrientationC (IORef UnitQuaternion) deriving (Typeable) +data ObjectC = ObjectC Object3D deriving (Typeable) +data VelocityC = VelocityC (IORef Vec3) deriving (Typeable) + +deriving instance Typeable UnitQuaternion +deriving instance Typeable Vec3 + +type Component = Dynamic + +-- an entity has an object id and components +data Entity = Entity { entId :: ObId, entComps :: [Component] } + +-- SYSTEMS for ECS + +data SystemData d = SystemData { + sdInitialize :: d, + sdAddEntity :: Entity -> d -> d, + sdRemoveEntity :: ObId -> d -> d, + sdRunAction :: d -> RunState -> IO () -- only side effects on the IORef data, but complete set as input! + } + +-- all commands go into one type (for now) +data Command = CmdArr [Command] + | CmdAddEntity Entity + | CmdRemEntity ObId + | CmdMoveTo Vec3 Time + | CmdNoOp + + + +-- administration function +-------------------------- + + +registerGUIEventFunction :: WireSystem -> String -> (GUIEvent -> IO ()) -> IO () +registerGUIEventFunction ws tag gevtF = do + let (gedm, wedm) = wsEvtDistMap ws + modifyIORef gedm (\m -> M.insert tag gevtF m) + return () + +registerWinEventFunction :: WireSystem -> (SDLEvent -> IO ()) -> IO () +registerWinEventFunction ws wevtF = do + let (gedm, wedm) = wsEvtDistMap ws + modifyIORef wedm (\l -> (wevtF : l)) + return () + +loadGuiLayout :: WireSystem -> String -> IO () +loadGuiLayout ws name = do + let guis = wsGui ws + let refList = wsGuiElList ws + mainwidget <- loadGuiLayoutFromFile guis name "" + modifyIORef refList (\l -> (mainwidget : l)) + addGuiElToDisplay guis mainwidget + return () + +getGuiWidget :: WireSystem -> String -> IO GUIElement +getGuiWidget ws name = do + let ref = wsGuiElList ws + lGE <- readIORef ref + rlist <- mapM (\wg -> do + rval <- findChildGuiElRecursive wg name + return rval ) lGE + let rval = case find isJust rlist of + Just (Just val) -> val + Nothing -> undefined + return rval -- we assume, that element is available, otherwise runtime error + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +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