immutaball-core-0.1.0.4.1: Immutaball/Share/GUI.hs
{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces .
-- Enable warnings:
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
-- State.hs.
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE TemplateHaskell, Arrows, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ExplicitForAll, InstanceSigs, ScopedTypeVariables, FlexibleContexts, RankNTypes #-}
module Immutaball.Share.GUI
(
-- * widgets
HasWid(..),
HasWparent(..),
HasFill(..),
HasText(..),
HasRect(..),
Root(..), rootWid,
Space(..), spaceWid, spaceWparent, spaceFill,
Vstack(..), vstackWid, vstackWparent,
Hstack(..), hstackWid, hstackWparent,
Label(..), labelWid, labelWparent, labelText, labelRect,
Button(..), buttonWid, buttonWparent, buttonText, buttonRect,
Widget(..), AsWidget(..),
-- * wires
SetTextOptions,
SetTextOptionsBuilder,
SetTextOptions'(..), stoHoldCache,
defaultSetTextOptions,
buildSetTextOptions,
defaultSetTextOptionsBuilder,
WidgetRequest(..), AsWidgetRequest(..),
WidgetResponse(..), AsWidgetResponse(..),
mkGUI,
mkWidgetsAnalysis,
mkWidgetBy,
mkWidgetIdx,
mkWidgetToIdx,
mkGetChildren,
mkGeometry,
nextWidgetDirect,
prevWidgetDirect,
nextWidgetHier,
prevWidgetHier,
isSelectable,
guiPaint,
guiPaintWidgetsChunk,
guiPaintWidgets,
focusDecayTime,
focusScale,
focusWaveAmplitude
) where
import Prelude ()
import Immutaball.Prelude
import Control.Applicative
import Control.Arrow
--import Data.Functor.Identity
import Control.Monad
import Control.Monad.ST
import Data.Function hiding (id, (.))
import Data.List
import Data.Maybe
import Foreign.Storable (sizeOf, Storable)
import Control.Lens
--import Data.Array
import Data.Array.Base
--import Data.Array.MArray
import Data.Array.ST
import Data.Array.Storable
import qualified Data.Map.Lazy as M
import qualified Data.Text as T
import Graphics.GL.Compatibility45
--import Graphics.GL.Core45
import Graphics.GL.Types
import qualified SDL.Raw.Enum as Raw
import Immutaball.Share.Config
import Immutaball.Share.Context
import Immutaball.Share.ImmutaballIO
import Immutaball.Share.ImmutaballIO.BasicIO
import Immutaball.Share.ImmutaballIO.GLIO
import Immutaball.Share.Math
import Immutaball.Share.SDLManager
import Immutaball.Share.State
import Immutaball.Share.State.Context
import Immutaball.Share.Utils
import Immutaball.Share.Video
import Immutaball.Share.Wire
-- * widgets
data Root id = Root {
_rootWid :: id
}
deriving (Eq, Ord, Show)
makeLenses ''Root
makeFields ''Root
data Space id = Space {
_spaceWid :: id,
_spaceWparent :: id,
-- | Max space to anchor at bottom.
_spaceFill :: Bool
}
deriving (Eq, Ord, Show)
makeLenses ''Space
makeFields ''Space
instance HasWparent (Root id) id where wparent = wid
data Vstack id = Vstack {
_vstackWid :: id,
_vstackWparent :: id
}
deriving (Eq, Ord, Show)
makeLenses ''Vstack
makeFields ''Vstack
data Hstack id = Hstack {
_hstackWid :: id,
_hstackWparent :: id
}
deriving (Eq, Ord, Show)
makeLenses ''Hstack
makeFields ''Hstack
data Label id = Label {
_labelWid :: id,
_labelWparent :: id,
_labelText :: String,
_labelRect :: Maybe (Rect Double)
}
deriving (Eq, Ord, Show)
makeLenses ''Label
makeFields ''Label
data Button id = Button {
_buttonWid :: id,
_buttonWparent :: id,
_buttonText :: String,
_buttonRect :: Maybe (Rect Double)
}
deriving (Eq, Ord, Show)
makeLenses ''Button
makeFields ''Button
data Widget id =
RootWidget (Root id)
| SpaceWidget (Space id)
| VstackWidget (Vstack id)
| HstackWidget (Hstack id)
| LabelWidget (Label id)
| ButtonWidget (Button id)
deriving (Eq, Ord, Show)
makeClassyPrisms ''Widget
instance HasWid (Widget id) id where
wid :: forall f. Functor f => (id -> f id) -> Widget id -> f (Widget id)
wid accessor (RootWidget root) = RootWidget <$> wid accessor root
wid accessor (SpaceWidget space) = SpaceWidget <$> wid accessor space
wid accessor (VstackWidget vstack) = VstackWidget <$> wid accessor vstack
wid accessor (HstackWidget hstack) = HstackWidget <$> wid accessor hstack
wid accessor (LabelWidget label) = LabelWidget <$> wid accessor label
wid accessor (ButtonWidget button) = ButtonWidget <$> wid accessor button
instance HasWparent (Widget id) id where
wparent :: forall f. Functor f => (id -> f id) -> Widget id -> f (Widget id)
wparent accessor (RootWidget root) = RootWidget <$> wparent accessor root
wparent accessor (SpaceWidget space) = SpaceWidget <$> wparent accessor space
wparent accessor (VstackWidget vstack) = VstackWidget <$> wparent accessor vstack
wparent accessor (HstackWidget hstack) = HstackWidget <$> wparent accessor hstack
wparent accessor (LabelWidget label) = LabelWidget <$> wparent accessor label
wparent accessor (ButtonWidget button) = ButtonWidget <$> wparent accessor button
-- * wires
type SetTextOptions = SetTextOptions' Identity
type SetTextOptionsBuilder = SetTextOptions' Maybe
data SetTextOptions' f = SetTextOptions {
-- | Request the cache of the old text is not cleared.
_stoHoldCache :: f Bool
}
--deriving (Eq, Ord, Show)
makeLenses ''SetTextOptions'
defaultSetTextOptions :: SetTextOptions
defaultSetTextOptions = SetTextOptions {
_stoHoldCache = Identity False
}
buildSetTextOptions :: SetTextOptionsBuilder -> SetTextOptions
buildSetTextOptions sto = SetTextOptions {
_stoHoldCache = orDef stoHoldCache defaultSetTextOptions sto
}
where
orDef :: (forall f. Lens' (SetTextOptions' f) (f a)) -> SetTextOptions -> SetTextOptionsBuilder -> Identity a
orDef l def opt = fromMaybe (def^.l) $ Identity <$> (opt^.l)
instance Semigroup SetTextOptionsBuilder where
a <> b = SetTextOptions {
_stoHoldCache = (a^.stoHoldCache) <|> (b^.stoHoldCache)
}
instance Monoid SetTextOptionsBuilder where
mempty = defaultSetTextOptionsBuilder
defaultSetTextOptionsBuilder :: SetTextOptionsBuilder
defaultSetTextOptionsBuilder = SetTextOptions {
_stoHoldCache = Nothing
}
data WidgetRequest id =
GUIDrive Request
| GUISetText id String SetTextOptions
| GUISetFocus id
| ResetGUI [Widget id]
--deriving (Eq, Ord, Show)
makeClassyPrisms ''WidgetRequest
data WidgetResponse id =
NoWidgetAction
| WidgetAction id
deriving (Eq, Ord, Show)
makeClassyPrisms ''WidgetResponse
mkGUI :: forall id. (Eq id, Ord id) => [Widget id] -> Wire ImmutaballM (WidgetRequest id, IBStateContext) (WidgetResponse id, IBStateContext)
mkGUI initialWidgets = proc (request, cxtn) -> do
-- Set up widgets.
rec
directResetWidgets <- returnA -< const Nothing ||| Just $ matching _ResetGUI request
msetText <- returnA -< const Nothing ||| Just $ matching _GUISetText request
lastWidgets <- delay initialWidgets -< widgets
let setTextResetWidgets' = flip fmap msetText $ \(setTextId, setTextText, sto) ->
-- (This is just a simple map, but the form can be a useful pattern for more complicated processing.)
-- (Also, for more advanced GUIs with lots af widgets, it would
-- likely be useful to have a separate map overlay layer of override
-- texts or other more efficient and better performing structures than
-- a direct list we reconstruct in its entirety on text update, but
-- our GUIs are probably simple enough that is probably good enough
-- for us.)
let
setText (LabelWidget w) val = LabelWidget $ w & (text .~ val)
setText (ButtonWidget w) val = ButtonWidget $ w & (text .~ val)
setText w _val = w
getText (LabelWidget w) = w^.text
getText (ButtonWidget w) = w^.text
getText _w = "" in
(\f -> f lastWidgets []) . fix $ \process remaining oldTexts_ -> case remaining of
[] -> ([], oldTexts_)
(w:ws) ->
let (w', oldTexts') = if' ((w^.wid) /= setTextId) (w, oldTexts_) $
(setText w setTextText, if' (not . runIdentity $ sto^.stoHoldCache) oldTexts_ $ getText w : oldTexts_) in
--w' : process ws
first (w' :) $ process ws oldTexts'
let setTextResetWidgets = fmap fst setTextResetWidgets'
let oldTexts = fromMaybe [] $ fmap snd setTextResetWidgets'
let resetWidgets = directResetWidgets <|> setTextResetWidgets
widgets <- hold initialWidgets -< resetWidgets
-- On direct reset, clear the text cache; we're the only user.
cxtnp1 <- returnA ||| clearTextCache -< const cxtn +++ const cxtn $ matching _ResetGUI request
-- On the first step, clear the text cache; we're the only user.
isFirst <- delay True -< returnA False
cxtnp2 <- returnA ||| clearTextCache -< if' (not isFirst) Left Right cxtnp1
-- On clearing old texts, remove the old text. (We could hold onto an
-- S.Set of currently active texts, but if there's still another text texture
-- referring to it, it'll simply be regenerated, so it's a small cost we can
-- handle.)
cxtnp3 <- foldrA uncacheText -< (cxtnp2, T.pack <$> oldTexts)
-- Analyze widgets.
widgetsReq <- returnA -< resetWidgets
widgetBy <- mkWidgetsAnalysis' mkWidgetBy -< widgetsReq
widgetIdx <- mkWidgetsAnalysis' mkWidgetIdx -< widgetsReq
widgetToIdx <- mkWidgetsAnalysis' mkWidgetToIdx -< widgetsReq
getChildren <- mkWidgetsAnalysis' mkGetChildren -< widgetsReq
geometry <- mkWidgetsAnalysis' mkGeometry -< widgetsReq
nextWidgetHier' <- returnA -< nextWidgetHier widgetBy getChildren
prevWidgetHier' <- returnA -< prevWidgetHier widgetBy getChildren
-- Handle mouse movement.
--mousePos <- hold ((-1.1), (1.1)) -< (const Nothing) ||| matching _Point $ matching _GUIDrive request
let
convertPoint :: (Integral i) => IBStateContext -> (i, i, i, i) -> Vec2 Double
convertPoint cxt_ (x, y, _dx, _dy) =
Vec2
( lerp (-1.0) (1.0) ( ilerp (0.0 :: Double) (fromIntegral (cxt_^.ibNeverballrc.width ) :: Double) (fromIntegral x)) )
( lerp (-1.0) (1.0) (flip ilerp (0.0 :: Double) (fromIntegral (cxt_^.ibNeverballrc.height) :: Double) (fromIntegral y)) )
let newMousePos = (const Nothing ||| Just . convertPoint cxtnp3) . matching (_GUIDrive . _Point) $ request
(_mousePos, mouseFocus) <- hold (Vec2 (-1.1) (1.1), Nothing) -< flip fmap newMousePos $ \pos ->
let widgetsUnderMouse = M.keys . M.filterWithKey (\wid_ r -> ((isSelectable <$> flip M.lookup widgetBy wid_) == Just True) && isInRect r pos) $ geometry in
let mwidgetUnderMouse = safeHead widgetsUnderMouse in
(pos, mwidgetUnderMouse >>= flip M.lookup widgetBy >>= flip M.lookup widgetToIdx)
-- Manage focus.
rec
initialFocus <- returnA -< maybe 0 id $ flip M.lookup widgetIdx 0 >>= flip M.lookup widgetBy . nextWidgetHier' . prevWidgetHier' . (^.wid) >>= flip M.lookup widgetToIdx
currentFocus <- holdWith -< (newFocus, initialFocus)
lastFocus <- delayWith -< (currentFocus, initialFocus)
newFocus0 <- case request of
GUISetFocus wid_ -> returnA -< flip M.lookup widgetBy wid_ >>= flip M.lookup widgetToIdx
GUIDrive (Keybd char True) -> returnA -<
if' (char == fromIntegral Raw.SDLK_DOWN) (Just $ nextWidgetDirect widgetIdx lastFocus) .
if' (char == fromIntegral Raw.SDLK_UP ) (Just $ prevWidgetDirect widgetIdx lastFocus) $
Nothing
_ -> returnA -< Nothing
newFocus <- returnA -< newFocus0 <|> (join (mouseFocus <$ newMousePos) >>= \mouseFocus_ -> if' (mouseFocus_ == lastFocus) Nothing $ Just mouseFocus_)
-- Find 'widgetsFocusedSinceLastPaintIdx'.
isPaint <- returnA -< case request of (GUIDrive (Paint _t)) -> True; _ -> False
lastIsPaint <- delay False -< isPaint
lastWidgetsFocusedSinceLastPaintIdx <- delay [] -< widgetsFocusedSinceLastPaintIdx
(widgetsFocusedSinceLastPaintIdx :: [Integer]) <- returnA -<
catMaybes [newFocus] ++ if' lastIsPaint [] lastWidgetsFocusedSinceLastPaintIdx
(widgetsFocusedSinceLastPaint :: [id]) <- returnA -<
flip mapMaybe widgetsFocusedSinceLastPaintIdx $ \idx -> (^.wid) <$> flip M.lookup widgetIdx idx
-- Paint.
currentFocusWid <- returnA -< fromMaybe (error "Internal error: mkGUI: currentFocus not in widgetIdx.") $ (^.wid) <$> flip M.lookup widgetIdx currentFocus
cxtnp4 <- case request of
GUIDrive (Paint t) -> guiPaint -< (widgets, geometry, widgetBy, widgetsFocusedSinceLastPaint, currentFocusWid, t, cxtnp3)
_ -> returnA -< cxtnp3
-- Set up response.
let responseOnAction = (maybe NoWidgetAction id $ WidgetAction . (^.wid) <$> flip M.lookup widgetIdx currentFocus)
response <- returnA -< case request of
GUIDrive (Keybd char True) ->
if' (char == fromIntegral Raw.SDLK_RETURN) responseOnAction $
NoWidgetAction
GUIDrive (Click Raw.SDL_BUTTON_LEFT True) ->
if' (mouseFocus == Just currentFocus) responseOnAction $
NoWidgetAction
_ -> NoWidgetAction
returnA -< (response, cxtnp4)
where
mkWidgetsAnalysis' = mkWidgetsAnalysis initialWidgets
_warn :: String -> Wire ImmutaballM () ()
_warn msg = proc () -> do
() <- monadic -< liftIBIO . BasicIBIOF $ PutStrLn msg ()
returnA -< ()
-- | Only recalculates the analysis on reset.
mkWidgetsAnalysis :: [Widget id] -> ([Widget id] -> a) -> Wire ImmutaballM (Maybe [Widget id]) a
mkWidgetsAnalysis initialWidgets analyzer = proc resetWidgets -> do
hold (analyzer initialWidgets) -< analyzer <$> resetWidgets
mkWidgetBy :: (Eq id, Ord id) => [Widget id] -> M.Map id (Widget id)
mkWidgetBy widgets = M.fromList . flip map widgets $ \w -> ((w^.wid), w)
mkWidgetIdx :: [Widget id] -> M.Map Integer (Widget id)
mkWidgetIdx widgets = M.fromList $ zip [0..] widgets
mkWidgetToIdx :: (Eq id, Ord id) => [Widget id] -> M.Map (Widget id) Integer
mkWidgetToIdx widgets = M.fromList $ zip widgets [0..]
mkGetChildren :: (Eq id) => [Widget id] -> id -> [Widget id]
mkGetChildren widgets parent = filter (\w -> (w^.wparent) == parent) widgets
-- TODO: make a more sophisticated geometry.
-- For now I'll just specify the rect by hand.
mkGeometry :: forall id. (Eq id, Ord id) => [Widget id] -> M.Map id (Rect Double)
--mkGeometry widgets = M.fromList . flip mapMaybe widgets . (\(a,b)->(a,)<$>b) . (id &&&) $ \w -> case w of
mkGeometry widgets = M.fromList . map (first (^.wid)) . flip mapMaybe widgets . (uncurry fmap .) . ((,) &&&) $ \w -> case w of
(LabelWidget label) -> label^.labelRect
(ButtonWidget button) -> button^.buttonRect
_ -> Nothing
-- | The order is the order reflected in the input widgets.
nextWidgetDirect :: (Eq id, Ord id) => M.Map Integer (Widget id) -> Integer -> Integer
nextWidgetDirect widgetIdx idx = tryNextWidget (idx+1)
where tryNextWidget idx_
| idx_ == idx = idx_
| idx_ >= (fromIntegral $ M.size widgetIdx) = tryNextWidget 0
| maybe False isSelectable $ M.lookup idx_ widgetIdx = idx_
| otherwise = tryNextWidget (idx_+1)
prevWidgetDirect :: (Eq id, Ord id) => M.Map Integer (Widget id) -> Integer -> Integer
prevWidgetDirect widgetIdx idx = tryNextWidget (idx-1)
where tryNextWidget idx_
| idx_ == idx = idx_
| idx_ < 0 = tryNextWidget ((fromIntegral $ M.size widgetIdx)-1)
| maybe False isSelectable $ M.lookup idx_ widgetIdx = idx_
| otherwise = tryNextWidget (idx_-1)
-- | The order is input order except container hierarchy takes precedence.
-- Does not check for cycles.
nextWidgetHier :: (Eq id, Ord id) => M.Map id (Widget id) -> (id -> [Widget id]) -> id -> id
nextWidgetHier widgetBy getChildren wid0 = maybe wid0 (nextWidgetUnder True wid0 . (^.wparent)) $ M.lookup wid0 widgetBy
where
wBy = flip M.lookup widgetBy
nextWidgetUnder isFirst wid_ parent
| not isFirst && wid_ == wid0 = wid0
| wid_ == parent = withRemaining . filter (\w -> (w^.wid) /= wid_) $ getChildren parent
| otherwise = withRemaining . drop 1 . dropWhile (\w -> (w^.wid) /= wid_) $ getChildren parent
where
withRemaining [] = maybe wid0 (\parent_ -> nextWidgetUnder False (parent_^.wid) (parent_^.wparent)) $ wBy parent
withRemaining ( w:_remaining) | (w^.wid) == wid0 = w^.wid
withRemaining ( w:_remaining) | isSelectable w = w^.wid
withRemaining (_w: remaining) | otherwise = withRemaining remaining
prevWidgetHier :: (Eq id, Ord id) => M.Map id (Widget id) -> (id -> [Widget id]) -> id -> id
prevWidgetHier widgetBy getChildren wid0 = maybe wid0 (prevWidgetUnder True wid0 . (^.wparent)) $ M.lookup wid0 widgetBy
where
wBy = flip M.lookup widgetBy
prevWidgetUnder isFirst wid_ parent
| not isFirst && wid_ == wid0 = wid0
| wid_ == parent = withRemaining . filter (\w -> (w^.wid) /= wid_) . reverse $ getChildren parent
| otherwise = withRemaining . drop 1 . dropWhile (\w -> (w^.wid) /= wid_) . reverse $ getChildren parent
where
withRemaining [] = maybe wid0 (\parent_ -> prevWidgetUnder False (parent_^.wid) (parent_^.wparent)) $ wBy parent
withRemaining ( w:_remaining) | (w^.wid) == wid0 = w^.wid
withRemaining ( w:_remaining) | isSelectable w = w^.wid
withRemaining (_w: remaining) | otherwise = withRemaining remaining
isSelectable :: Widget id -> Bool
isSelectable (ButtonWidget {}) = True
isSelectable _ = False
guiPaint :: forall id. (Eq id, Ord id) => Wire ImmutaballM ([Widget id], M.Map id (Rect Double), M.Map id (Widget id), [id], id, Double, IBStateContext) IBStateContext
guiPaint = proc (widgets, geometry, widgetBy, widgetsFocusedSinceLastPaint, currentFocusWid, t, cxtn) -> do
rec
(widgetLastFocusLast :: M.Map id Double) <- delay M.empty -< widgetLastFocus
widgetLastFocus <- returnA -< M.filter (> t - focusDecayTime) $ foldr (\wid_ -> M.insert wid_ t) widgetLastFocusLast widgetsFocusedSinceLastPaint
chunks' <- returnA -< chunksOf (cxtn^.ibContext.ibStaticConfig.x'cfgMaxPassTextures)
cxtnp1 <- foldrA guiPaintWidgetsChunk -< (cxtn, flip map (chunks' widgets) $ \ws -> (ws, widgetLastFocus, geometry, widgetBy, currentFocusWid, t))
returnA -< cxtnp1
guiCachingRenderText :: forall id. (Eq id, Ord id) => Wire ImmutaballM (Widget id, IBStateContext) (Maybe (WidthHeightI, GLuint), IBStateContext)
guiCachingRenderText = proc (widget, cxtn) -> do
let mtext' = case widget of
(ButtonWidget button) -> Just (button^.text)
(LabelWidget label) -> Just (label^.text)
_ -> Nothing
let mtext | mtext' == Just "" = Nothing | otherwise = mtext' -- sdl2-ttf fails on an nempty string (zero width error).
(mdimName, cxtnp1) <- returnA ||| (first Just) <$> cachingRenderText -< maybe (Left (Nothing, cxtn)) (\text_ -> Right (T.pack $ text_, cxtn)) $ mtext
returnA -< (mdimName, cxtnp1)
-- | Just process 16 at a time, the number of textures our shader can handle at a time.
guiPaintWidgetsChunk :: forall id. (Eq id, Ord id) => Wire ImmutaballM (([Widget id], M.Map id Double, M.Map id (Rect Double), M.Map id (Widget id), id, Double), IBStateContext) IBStateContext
guiPaintWidgetsChunk = proc ((widgets, widgetLastFocus, geometry, widgetBy, currentFocusWid, t), cxtn) -> do
-- let guiCacheRenderText' = guiCacheRenderText that accumulates on its left input.
--guiCacheRenderText' <- returnA -< guiCacheRenderText …
(mdimNames :: [Maybe (WidthHeightI, GLuint)], cxtnp1) <- foldrA guiCacheRenderText' -< (([], cxtn), widgets)
let (mRects :: [Maybe (Rect Double)]) = flip map widgets $ \w -> M.lookup (w^.wid) geometry
let (wids :: [Maybe id]) = flip map widgets $ \w -> Just (w^.wid)
--let paintWidgets = catMaybes $ zipWith (liftA2 (,)) mdimNames mRects
let paintWidgets = catMaybes . zipWith (liftA2 (,)) wids $ zipWith (liftA2 (,)) mdimNames mRects
cxtnp2 <- guiPaintWidgets -< (paintWidgets, widgetLastFocus, widgetBy, currentFocusWid, t, cxtnp1)
returnA -< cxtnp2
where
-- let guiCacheRenderText' = guiCacheRenderText that accumulates on its left input.
guiCacheRenderText' = proc (w, (mdimNames, icxtn)) -> do
(mdimName, icxtnp1) <- guiCachingRenderText -< (w, icxtn)
returnA -< (mdimName : mdimNames, icxtnp1)
-- | OpenGL paint the GUI widgets.
--
-- BUild vertex data to upload to the GPU, set the texture name
-- shader-variables (aka uniforms), and then issue the GL draw commands. The
-- higher order callbacks (aka shaders) we installed on the GPU will procses it.
guiPaintWidgets :: forall id. (Eq id, Ord id) => Wire ImmutaballM ([(id, ((WidthHeightI, GLuint), Rect Double))], M.Map id Double, M.Map id (Widget id), id, Double, IBStateContext) IBStateContext
guiPaintWidgets = proc (paintWidgets, widgetLastFocus, _widgetBy, currentFocusWid, t, cxtn) -> do
-- let sdlGL1' = sdlGL1 h
sdlGL1' <- returnA -< liftIBIO . sdlGL1 (cxtn^.ibContext.ibSDLManagerHandle)
-- Animate grow and shrinking on focus.
let widgetLastFocus' = M.filter (> t - focusDecayTime) $ widgetLastFocus
rec
lastFocusGrow <- delay M.empty -< focusGrow
focusGrow <- returnA -< M.union ((\lastFocusTime -> lerp focusScale 1.00 (ilerp lastFocusTime (lastFocusTime + focusDecayTime) t)) <$> widgetLastFocus') lastFocusGrow
let wfocusScale wid_ = fromMaybe (1.00 :: Double) $ M.lookup wid_ focusGrow
-- Also add a subtle wave on the currently selected widget.
dt <- differentiate -< t
smallWave <- wave focusWaveAmplitude 1.0 0.0 -< dt
let wfocusScale' wid_ = if' (wid_ == currentFocusWid) ((1+smallWave)*) id $ wfocusScale wid_
-- Shared info.
let ( sd :: Integer) = fromIntegral $ sizeOf (0.0 :: GLdouble)
let (_si :: Integer) = fromIntegral $ sizeOf (0 :: GLint)
let fi = fromIntegral
--let (vertexStride :: Integer) = 9*sd + 1*si
let (vertexStride :: Integer) = 10*sd
let (vertexStride' :: GLsizei) = fromIntegral vertexStride
let (vertexStrideByDoubles :: Integer) = 10
-- Build vertex data (and element data) to upload to the GPU.
-- Note that while most of the elements are 8-byte doubles, we want the
-- texture layers to be interpreted as 4-byte ints, so when constructing these
-- arrays we do a cast to build the texture layer ints.
let numWidgets = genericLength (paintWidgets)
let trianglesPerWidget = 3
let verticesPerWidget = 2 * trianglesPerWidget
let numVertices = numWidgets * verticesPerWidget
let (vertexArray :: UArray Integer GLdouble) = runSTUArray $ do
array_ <- newArray (0, numVertices * vertexStrideByDoubles - 1) 0.0
when (numWidgets > 0) $ do
arrayAsGLuint <- castSTUArray' array_
-- Specify the element type for arrayAsGLuint
(_firstElem :: GLuint) <- readArray arrayAsGLuint 0
-- Write the array elements for each widget.
-- > "layout(location = 0) in vec3 position;",
-- > "layout(location = 1) in vec4 modulateColor;",
-- > "layout(location = 2) in vec2 texCoords;",
-- > "layout(location = 3) in int texLayer;",
forM_ (zip [0..] paintWidgets) $ \(idx, (wid_, ((((_w, _h), _texture)), wrect))) -> do
let (Vec3 vp1 vp2 vp3, Vec3 vp4 vp5 vp6) = rectToTriangles $ wrect & rectAvgSideAboutCenter %~ (wfocusScale' wid_ *)
let (Vec3 vt1 vt2 vt3, Vec3 vt4 vt5 vt6) = rectToTriangles $ (Rect (Vec2 0.0 0.0) (Vec2 1.0 1.0))
let withVertex vp vt vidx = do
-- Position.
writeArray array_ (vidx*10 + 0) $ vp^.x2
writeArray array_ (vidx*10 + 1) $ vp^.y2
writeArray array_ (vidx*10 + 2) $ 0.0
-- Color.
if wid_ /= currentFocusWid
then do
writeArray array_ (vidx*10 + 3) $ 0.3
writeArray array_ (vidx*10 + 4) $ 0.3
writeArray array_ (vidx*10 + 5) $ 0.7
writeArray array_ (vidx*10 + 6) $ 1.0
else do
writeArray array_ (vidx*10 + 3) $ 0.6
writeArray array_ (vidx*10 + 4) $ 0.6
writeArray array_ (vidx*10 + 5) $ 0.9
writeArray array_ (vidx*10 + 6) $ 1.0
-- Tex coords.
writeArray array_ (vidx*10 + 7) $ vt^.x2
writeArray array_ (vidx*10 + 8) $ vt^.y2
-- Tex layer (double indices since from this view elements are half as long).
-- (See note near glActiveTexture on the valeu OpenGL uses.)
--writeArray arrayAsGLuint (2*(vidx*10 + 9) + 0) $ texture
writeArray arrayAsGLuint (2*(vidx*10 + 9) + 0) $ (fromIntegral idx :: GLuint)
withVertex vp1 vt1 (verticesPerWidget * idx + 0)
withVertex vp2 vt2 (verticesPerWidget * idx + 1)
withVertex vp3 vt3 (verticesPerWidget * idx + 2)
withVertex vp4 vt4 (verticesPerWidget * idx + 3)
withVertex vp5 vt5 (verticesPerWidget * idx + 4)
withVertex vp6 vt6 (verticesPerWidget * idx + 5)
return array_
--let (elementArray :: UArray Integer GLuint) = runSTUArray $ do
let (elementArray :: UArray Integer GLuint) =
Data.Array.Base.listArray (0, numVertices - 1) [0..(fromIntegral numVertices) - 1]
(vertexStorableArray :: StorableArray Integer GLdouble) <- monadic -< liftIBIO $ ThawIO (vertexArray :: UArray Integer GLdouble) id
(elementStorableArray :: StorableArray Integer GLuint) <- monadic -< liftIBIO $ ThawIO (elementArray :: UArray Integer GLuint) id
(vertexData :: GLData) <- monadic -< liftIBIO $ bsToGLData <$> ArrayToBS vertexStorableArray id
(elementData :: GLData) <- monadic -< liftIBIO $ bsToGLData <$> ArrayToBS elementStorableArray id
let (numElements_ :: Integer) = fromIntegral $ numElements (elementArray :: UArray Integer GLuint)
() <- monadic -< sdlGL1' $ do
-- Disable depth testing.
GLDisable GL_DEPTH_TEST ()
-- Before the paint, disable scene data.
GLUniform1i shaderEnableSceneDataLocation falseAsIntegral ()
-- Tell the shaders we are not drawing the ball right now.
GLUniform1i shaderEnableBallDataLocation falseAsIntegral ()
-- First set the 16 texture name uniforms, and make them active.
forM_ (zip [0..] $ map (^._2._1._2) paintWidgets) $ \(idx, texture) -> do
case flip M.lookup numToGL_TEXTUREi idx of
Nothing -> return ()
Just gl_TEXTUREi -> do
-- Apparently actually we set GL_TEXTUREi for the texture()
-- GLSL call, not the texture name. So set the i used in
-- GL_TEXTUREi as the value, not the texture identifier.
--GLUniform1i (fromIntegral idx) (fromIntegral texture) ()
GLUniform1i (fromIntegral idx) (fromIntegral idx) ()
--GLActiveTexture GL_TEXTUREi ()
GLActiveTexture gl_TEXTUREi ()
GLBindTexture GL_TEXTURE_2D texture ()
-- Now upload the vertex data and draw.
vao <- unSingleton <$> GLGenVertexArrays 1 id
vertexBuf <- unSingleton <$> GLGenBuffers 1 id
elementBuf <- unSingleton <$> GLGenBuffers 1 id
GLBindVertexArray vao ()
GLBindBuffer GL_ARRAY_BUFFER vertexBuf ()
GLBufferData GL_ARRAY_BUFFER vertexData GL_DYNAMIC_DRAW ()
GLBindBuffer GL_ELEMENT_ARRAY_BUFFER elementBuf ()
GLBufferData GL_ELEMENT_ARRAY_BUFFER elementData GL_DYNAMIC_DRAW ()
-- … stride offset ()
-- location 0: vec3 positions.
GLVertexAttribPointer 0 3 GL_DOUBLE GL_FALSE vertexStride' (fi$sum[]*sd) ()
GLEnableVertexAttribArray 0 ()
-- location 1: vec4 modulateColors.
GLVertexAttribPointer 1 4 GL_DOUBLE GL_FALSE vertexStride' (fi$sum[3]*sd) ()
GLEnableVertexAttribArray 1 ()
-- location 2: vec2 texCoords.
GLVertexAttribPointer 2 2 GL_DOUBLE GL_FALSE vertexStride' (fi$sum[3,4]*sd) ()
GLEnableVertexAttribArray 2 ()
-- location 3: vec1 texLayers.
GLVertexAttribIPointer 3 1 GL_INT vertexStride' (fi$sum[3,4,2]*sd) ()
GLEnableVertexAttribArray 3 ()
GLDrawElementsRaw GL_TRIANGLES (fromIntegral numElements_) GL_UNSIGNED_INT 0 ()
GLDeleteBuffers [vertexBuf] ()
GLDeleteBuffers [elementBuf] ()
GLDeleteVertexArrays [vao] ()
returnA -< cxtn
where
unSingleton [me] = me
unSingleton _ = error "Internal error: guiPaintWidgets expected a single result from GLGenVertexArrays or GLGenBuffers."
rectToTriangles :: Rect Double -> (Vec3 (Vec2 Double), Vec3 (Vec2 Double))
rectToTriangles r = (Vec3 (r'^.rectLowerLeft) (r'^.rectLowerRight) (r'^.rectUpperRight), Vec3 (r'^.rectLowerLeft) (r'^.rectUpperLeft) (r'^.rectUpperRight))
where r' = rectNormalize r
-- | 'castSTUArray' doesn't update the range.
-- This version does. Thus it prevents out of index errors when casting from one array type to another with a different element size.
-- This version only handles single-dimensional indices.
castSTUArray' :: forall ix a b s. (Num ix, Integral ix, Storable a, Storable b) => STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray' (STUArray l u _n marr) = return (STUArray l' u' n' marr)
where
btm = error "Internal error: castSTUArray': sizeOf value accessed."
len = u - l + 1
len' = ((sa * len) + (sa-1)) `div` sb
where
sb = fromIntegral $ sizeOf (btm :: b)
sa = fromIntegral $ sizeOf (btm :: a)
-- l and u are actually lower and upper, not length and start.
u' = l + len' - 1
l' = l
n' = fromIntegral $ len'
-- Optionally this could be moved to static config.
focusDecayTime :: Double
focusDecayTime = 0.250
focusScale :: Double
focusScale = 1.100
focusWaveAmplitude :: Double
focusWaveAmplitude = 0.020