HGamer3D-Wire-0.3.0: HGamer3D/Wire/GUI.hs
{-# 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