{-# 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