module Csound.Typed.Gui.Gui (
Panel(..), Win(..), GuiNode(..), GuiHandle(..), Gui(..),
Elem(..), InitMe(..),
restoreTree, guiMap, mapGuiOnPanel, fromElem, fromGuiHandle,
panelIsKeybdSensitive, defText,
guiStmt,
-- * Layout
hor, ver, space, sca, horSca, verSca,
padding, margin,
-- * Props
props, forceProps,
Prop(..), BorderType(..), Color,
Rect(..), FontType(..), Emphasis(..),
Material(..), Orient(..), LabelType(..),
-- ** Setters
-- | Handy short-cuts for the function @props@.
setBorder, setLabel, setMaterial, setLabelType,
setColor1, setColor2, setColors, setTextColor,
setFontSize, setFontType, setEmphasis, setOrient,
-- * Widgets
ValDiap(..), ValStep, ValScaleType(..), ValSpan(..),
linSpan, expSpan, uspan, bspan, uspanExp,
KnobType(..), setKnobType,
SliderType(..), setSliderType,
TextType(..), setTextType,
BoxType(..), setBoxType,
ButtonType(..), setButtonType
) where
import Prelude hiding(elem, span)
import Control.Applicative((<|>))
import Data.Default
import Data.Char(toLower)
import Data.Maybe(isNothing)
import Data.Monoid
import Data.Colour
import Data.Colour.Names(white, gray)
import Data.Colour.SRGB
import qualified Data.IntMap as IM
import Text.PrettyPrint.Leijen(Doc, int, double, vcat, hcat, hsep, punctuate, comma, empty, text, char, (<+>))
-- import Csound.Render.Pretty(Doc, int, double, vcat, hcat, punctuate, comma)
import Csound.Dynamic(DepT, depT_, Var(..), VarType(..), Rate(..), noRate, MainExp(..), InstrId(..))
import qualified Csound.Typed.Gui.BoxModel as Box
import Csound.Typed.Gui.BoxModel(Rect(..))
import Csound.Typed.Constants(infiniteDur)
newtype GuiHandle = GuiHandle { unGuiHandle :: Int }
-- | The Csound colours.
type Color = Colour Double
-- | The orientation of the widget (slider, roller). This property is
-- never needs to be set in practice. If this property is not set then
-- default orientation is calculated from the bounding box of the widget.
-- If the width is greater than the height then we need to use a horizontal
-- widget otherwise it should be a vertical one.
data Orient = Hor | Ver
-- | A value span is a diapason of the value and a type
-- of the scale (can be linear or exponential).
data ValSpan = ValSpan
{ valSpanDiap :: ValDiap
, valSpanScale :: ValScaleType }
-- | Makes a linear @ValSpan@ with specified boundaries.
--
-- > linSpan minVal maxVal
linSpan :: Double -> Double -> ValSpan
linSpan a b = ValSpan (ValDiap a b) Linear
-- | Makes an exponential @ValSpan@ with specified boundaries.
--
-- > expSpan minVal maxVal
expSpan :: Double -> Double -> ValSpan
expSpan a b = ValSpan (ValDiap (checkBound a) b) Exponential
where
checkBound x
| x <= 0 = 0.00001
| otherwise = x
-- | Unit span. A special case:
--
-- > uspan = linSpan 0 1
uspan :: ValSpan
uspan = linSpan 0 1
-- | Bipolar unit span. A special case:
--
-- > uspan = linSpan (-1) 1
bspan :: ValSpan
bspan = linSpan (-1) 1
-- | An exponential unit span. A special case:
--
-- > uspan = expSpan 0 1
uspanExp :: ValSpan
uspanExp = linSpan 0 1
-- | The diapason of the continuous value.
data ValDiap = ValDiap
{ valDiapMin :: Double
, valDiapMax :: Double }
data ValScaleType = Linear | Exponential
type ValStep = Double
data FontType = Helvetica | Courier | Times | Symbol | Screen | Dingbats
data Emphasis = NoEmphasis | Italic | Bold | BoldItalic
data KnobType = ThreeD (Maybe Int) | Pie | Clock | Flat
data SliderType = Fill | Engraved | Nice
data TextType = NormalText | NoDrag | NoEdit
-- | The type of the material of the element. It affects sliders and buttons.
data Material = NoPlastic | Plastic
-- | Some values are not implemented on the Csound level.
data LabelType = NormalLabel | NoLabel | SymbolLabel
| ShadowLabel | EngravedLabel | EmbossedLabel
-- | The type of the box. Some values are not implemented on the Csound level.
data BoxType
= FlatBox | UpBox | DownBox | ThinUpBox | ThinDownBox
| EngravedBox | EmbossedBox | BorderBox | ShadowBox
| Roundedbox | RoundedShadowBox | RoundedFlatBox
| RoundedUpBox | RoundedDownBox | DiamondUpBox
| DiamondDownBox | OvalBox | OvalShadowBox | OvalFlatBox
deriving (Enum)
data BorderType
= NoBorder | DownBoxBorder | UpBoxBorder | EngravedBorder
| EmbossedBorder | BlackLine | ThinDown | ThinUp
deriving (Enum)
-- | The type of the button. It affects toggle buttons and button banks.
--
-- In Csound buttons and toggle buttons
-- are constructed with the same function (but with different button types).
-- But in this library they are contructed by different functions (@button@ and @toggle@).
-- Normal button is a plain old button, but other values specify toggle buttons.
-- So this property doesn't affect the buttons (since they could be only normal buttons).
data ButtonType = NormalButton | LightButton | CheckButton | RoundButton
defFontSize :: Int
defFontSize = 15
instance Default FontType where def = Courier
instance Default Emphasis where def = NoEmphasis
instance Default SliderType where def = Fill
instance Default KnobType where def = Flat
instance Default TextType where def = NormalText
instance Default ButtonType where def = NormalButton
instance Default BoxType where def = FlatBox
instance Default Material where def = Plastic
instance Default LabelType where def = NormalLabel
data InitMe = InitMe
{ initHandle :: Var
, initValue :: Double }
data Elem
= GuiVar GuiHandle
-- valuators
| Count ValDiap ValStep (Maybe ValStep)
| Joy ValSpan ValSpan
| Knob ValSpan
| Roller ValSpan ValStep
| Slider ValSpan
| Text ValDiap ValStep
-- other widgets
| Box String
| ButBank Int Int
| Button InstrId
| Toggle
| Value
| Vkeybd
data Props = Props
{ propsBorder :: Maybe BorderType
, otherProps :: [Prop] }
instance Monoid Props where
mempty = Props Nothing []
mappend a b = Props { propsBorder = (propsBorder a) <|> (propsBorder b)
, otherProps = mappend (otherProps a) (otherProps b) }
-- | Properties of the widgets.
data Prop
= SetLabel String
| SetMaterial Material
| SetBoxType BoxType
| SetColor1 Color | SetColor2 Color | SetTextColor Color
| SetFontSize Int | SetFontType FontType | SetEmphasis Emphasis
| SetSliderType SliderType
| SetTextType TextType
| SetButtonType ButtonType
| SetOrient Orient
| SetKnobType KnobType
| SetLabelType LabelType
-- | A visual representation of the GUI-element.
newtype Gui = Gui { unGui :: LowGui }
type LowGui = Box.Scene Props ElemWithOuts
data Panel
= Single
{ singleContent :: Win
, singleIsKeybdSensitive :: Bool }
| Tabs
{ tabsTitle :: String
, tabsRect :: Maybe Rect
, tabsContent :: [Win]
, tabsIsKeybdSensitive :: Bool }
panelIsKeybdSensitive :: Panel -> Bool
panelIsKeybdSensitive x = case x of
Single _ res -> res
Tabs _ _ _ res -> res
data Win = Win
{ winTitle :: String
, winRect :: Maybe Rect
, winGui :: Gui }
data GuiNode = GuiNode
{ guiNodeElem :: Gui
, guiNodeHandle :: GuiHandle }
data ElemWithOuts = ElemWithOuts
{ elemOuts :: [Var]
, elemInits :: [InitMe]
, elemContent :: Elem }
type ElemOuts = [Var]
defText :: String -> Gui
defText str = Gui $ Box.Prim (ElemWithOuts [Var LocalVar Ir "keybd"] [] $ Box str)
fromElem :: ElemOuts -> [InitMe] -> Elem -> Gui
fromElem outs inits el = Gui $ Box.prim (ElemWithOuts outs inits el)
fromGuiHandle :: GuiHandle -> Gui
fromGuiHandle = Gui . Box.prim . ElemWithOuts [] [] . GuiVar
mapGuiOnPanel :: (Gui -> Gui) -> Panel -> Panel
mapGuiOnPanel f x = case x of
Single w isKey -> Single (mapWin w) isKey
Tabs title rect ws isKey -> Tabs title rect (fmap mapWin ws) isKey
where mapWin a = a{ winGui = f $ winGui a }
onLowGuis :: ([LowGui] -> LowGui) -> ([Gui] -> Gui)
onLowGuis f = Gui . f . fmap unGui
onLowGui1 :: (LowGui -> LowGui) -> (Gui -> Gui)
onLowGui1 f = Gui . f . unGui
-- | Horizontal groupping of the elements. All elements are
-- placed in the stright horizontal line and aligned by Y-coordinate
-- and height.
hor :: [Gui] -> Gui
hor = onLowGuis Box.hor
-- | Vertical groupping of the elements. All elements are
-- placed in the stright vertical line and aligned by X-coordinate
-- and width.
ver :: [Gui] -> Gui
ver = onLowGuis Box.ver
-- | An empty space.
space :: Gui
space = Gui Box.space
-- | Scales an element within the group. It depends on the type
-- of the alignment (horizontal or vertical) which side of the bounding
-- box is scaled. If it's a horizontal group then the width is scaled
-- and height is scaled otherwise.
--
-- Every element in the group has a scaling factor. By
-- default it equals to one. During rendering all scaling factors are summed
-- and divided on the sum of all factors. So that factors become weights
-- or proportions. This process is called normalization.
-- Scaling one element affects not only this element but
-- all other elements in the group!
--
-- An example:
--
-- One element is twice as large as the other two:
--
-- > hor [a, b, sca 2 c]
--
-- Why is it so? Let's look at the hidden scaling factors:
--
-- > hor [sca 1 a, sca 1 b, sca 2 c]
--
-- During rendering we scale all the scaling fators so that
-- total sum equals to one:
--
-- > hor [sca 0.25 a, sca 0.25 b, sca 0.5 c]
sca :: Double -> Gui -> Gui
sca d = onLowGui1 (Box.sca d)
-- | Weighted horizontal grouping.
-- It takes a list of scaling factors and elements.
horSca :: [(Double, Gui)] -> Gui
horSca ps = hor $ fmap (uncurry sca) ps
-- | Weighted vertical grouping.
-- It takes a list of scaling factors and elements.
verSca :: [(Double, Gui)] -> Gui
verSca ps = ver $ fmap (uncurry sca) ps
-- | Sets the padding of the element. How much empty space
-- to reserve outside the element.
padding :: Int -> Gui -> Gui
padding n = onLowGui1 (Box.padding n)
-- | Sets the margin of the element. How much empty space
-- to reserve between the elements within the group. It affects
-- only compound elements.
margin :: Int -> Gui -> Gui
margin n = onLowGui1 (Box.margin n)
-- | Sets the properties for a GUI element.
props :: [Prop] -> Gui -> Gui
props ps = onLowGui1 (Box.appendContext (Props Nothing ps))
-- | Sets the properties for a GUI element on all levels.
forceProps :: [Prop] -> Gui -> Gui
forceProps = error "forceProps: TODO"
setBorder :: BorderType -> Gui -> Gui
setBorder a = onLowGui1 (Box.appendContext (Props (Just a) []))
type GuiMap = IM.IntMap Gui
guiMap :: [GuiNode] -> GuiMap
guiMap = IM.fromList . fmap (\(GuiNode elem (GuiHandle n)) -> (n, elem))
restoreTree :: GuiMap -> Gui -> Gui
restoreTree m x = Gui $ (unGui x) >>= rec
where rec elem = case elemContent elem of
GuiVar h -> unGui $ restoreTree m $ m IM.! unGuiHandle h
_ -> return elem
guiStmt :: Monad m => [Panel] -> DepT m ()
guiStmt panels = depT_ $ noRate phi
where phi
| null panels = EmptyExp
| otherwise = Verbatim $ show $ vcat [vcat $ fmap drawGui panels, text "FLrun"]
drawGui :: Panel -> Doc
drawGui x = case x of
Single w isKeybd -> panel isKeybd boundingRect $ drawWin (withWinMargin boundingRect) w
Tabs _ _ ws isKeybd -> panel isKeybd tabPanelRect $ case ws of
[] -> empty
_ -> onTabs mainTabRect $ vcat $ fmap (uncurry $ drawTab shift) tabsRs
where boundingRect = panelRect (fmap fst tabsRs) x
tabsRs = tabsRects x
(mainTabRect, shift) = mainTabRectAndShift boundingRect
tabPanelRect = Rect
{ px = 100
, py = 100
, width = width mainTabRect + 20
, height = height mainTabRect + 20
}
panel = onPanel (panelTitle x)
onPanel title isKeybdSensitive rect body = vcat
-- panel with default position no border and capture of keyboard events
[ ppProc "FLpanel" [ text $ show title, int $ width rect, int $ height rect, int (-1), int (-1), int 0
, int $ if isKeybdSensitive then 1 else 0 ]
, body
, ppProc "FLpanelEnd" []]
onTabs rect body = vcat
[ ppProc "FLtabs" $ rectToFrame rect
, body
, ppProc "FLtabsEnd" []]
panelTitle :: Panel -> String
panelTitle x = case x of
Single w _ -> winTitle w
Tabs title _ _ _ -> title
panelRect :: [Rect] -> Panel -> Rect
panelRect rs x = case x of
Single w _ -> winBoundingRect w
Tabs _ mrect _ _ -> case rs of
[] -> Box.zeroRect
_ -> maybe (foldr boundingRect (head rs) rs) id mrect
where boundingRect a b = Rect { px = x1, py = y1, width = x2 - x1, height = y2 - y1 }
where x1 = min (px a) (px b)
y1 = min (py a) (py b)
x2 = max (px a + width a) (px b + width b)
y2 = max (py a + height a) (py b + height b)
mainTabRectAndShift :: Rect -> (Rect, (Int, Int))
mainTabRectAndShift r = (res, (dx, dy))
where res = Rect
{ px = 5
, py = 5
, width = px r + width r + 10
, height = py r + height r + yBox 15 2 + 10
}
dx = 10
dy = yBox 15 2 + 10
tabsRects :: Panel -> [(Rect, Win)]
tabsRects x = case x of
Single _ _ -> []
Tabs _ _ ws _ -> zip (fmap winBoundingRect ws) ws
winBoundingRect :: Win -> Rect
winBoundingRect w = maybe (shiftBy 50 $ bestRect $ winGui w) id $ winRect w
where shiftBy n r = r { px = n + px r, py = n + py r }
drawTab :: (Int, Int) -> Rect -> Win -> Doc
drawTab shift r w = group (winTitle w) r $ drawWin (withRelWinMargin $ shiftRect shift r) w
where group title rect body = vcat
[ ppProc "FLgroup" $ (text $ show title) : rectToFrame rect
, body
, ppProc "FLgroupEnd" []]
shiftRect (dx, dy) rect = rect
{ px = dx + px rect
, py = dy + py rect }
rectToFrame :: Rect -> [Doc]
rectToFrame rect = fmap int [width rect, height rect, px rect, py rect]
drawWin :: Rect -> Win -> Doc
drawWin rect w = renderAbsScene $ Box.draw rect $ unGui $ winGui w
where
renderAbsScene = Box.cascade drawPrim empty vcat onCtx setProps def
where
setProps ps = appEndo $ mconcat $ fmap (Endo . setPropCtx) (otherProps ps)
onCtx r ps res = maybe res (\borderType -> drawBorder borderType r res) (propsBorder ps)
drawBorder :: BorderType -> Rect -> Doc -> Doc
drawBorder borderType rect a = vcat
[ ppProc "FLgroup" $ ((text $ show "") : frame) ++ [borderAsInt borderType]
, a
, ppProc "FLgroupEnd" []]
where borderAsInt = int . fromEnum
frame = rectToFrame rect
drawPrim :: PropCtx -> Rect -> ElemWithOuts -> Doc
drawPrim ctx rect elem = vcat
[ drawElemDef ctx rect elem
, drawAppearance ctx elem
, drawInitVal elem ]
drawAppearance :: PropCtx -> ElemWithOuts -> Doc
drawAppearance ctx el = maybe empty (flip flSetAll ctx)
$ getPropHandle $ elemOuts el
drawInitVal :: ElemWithOuts -> Doc
drawInitVal = vcat . fmap flSetVal_i . elemInits
drawElemDef :: PropCtx -> Rect -> ElemWithOuts -> Doc
drawElemDef ctx rectWithoutLabel el = case elemContent el of
-- valuators
Count diap step1 step2 -> drawCount diap step1 step2
Joy span1 span2 -> drawJoy span1 span2
Knob span -> drawKnob span
Roller span step -> drawRoller span step
Slider span -> drawSlider span
Text diap step -> drawText diap step
-- other widgets
Box label -> drawBox label
ButBank xn yn -> drawButBank xn yn
Button instrId -> drawButton instrId
Toggle -> drawToggle
Value -> drawValue
Vkeybd -> drawVkeybd
-- error
GuiVar guiHandle -> orphanGuiVar guiHandle
where
rect = clearSpaceForLabel $ rectWithoutLabel
clearSpaceForLabel a
| label == "" = a
| otherwise = a { height = max 20 $ height a - yLabelBox (getIntFontSize ctx) }
where label = getLabel ctx
f = fWithLabel (getLabel ctx)
fWithLabel label name args = ppMoOpc (fmap ppVar $ elemOuts el) name ((text $ show $ label) : args)
fNoLabel name args = ppMoOpc (fmap ppVar $ elemOuts el) name args
frame = frameBy rect
frameWithoutLabel = frameBy rectWithoutLabel
frameBy x = fmap int [width x, height x, px x, py x]
noDisp = int (-1)
noOpc = int (-1)
onOpc instrId xs = int 0 : int (instrIdCeil instrId) : fmap double xs
drawSpan (ValSpan diap scale) = [imin diap, imax diap, getScale scale]
imin = double . valDiapMin
imax = double . valDiapMax
-----------------------------------------------------------------------
-- valuators
-- FLcount
drawCount diap step1 mValStep2 = f "FLcount" $
[ imin diap, imax diap
, double step1, double step2
, int itype ]
++ frame ++ [noOpc]
where (step2, itype) = case mValStep2 of
-- type 1 FLcount with 2 steps
Just n -> (n, 1)
-- type 2 FLcount with a single step
Nothing -> (step1, 2)
-- FLjoy
drawJoy (ValSpan dX sX) (ValSpan dY sY) = f "FLjoy" $
[ imin dX, imax dX, imin dY, imax dY
, getScale sX, getScale sY
, noDisp, noDisp
] ++ frame
-- FLknob
drawKnob span = f "FLknob" $
drawSpan span ++ [getKnobType ctx, noDisp]
++ fmap int knobFrame ++ getKnobCursorSize ctx
where
knobFrame
| w < h = [w, x, y + d]
| otherwise = [h, x + d, y]
h = height rect
w = width rect
x = px rect
y = py rect
d = div (abs $ h - w) 2
-- FLroller
drawRoller (ValSpan d s) step = f "FLroller" $
[ imin d, imax d, double step
, getScale s, getRollerType (getDefOrient rect) ctx, noDisp
] ++ frame
-- FLslider
drawSlider span = f "FLslider" $
drawSpan span
++ [getSliderType (getDefOrient rect) ctx, noDisp]
++ frame
-- FLtext
drawText diap step = f "FLtext" $
[imin diap, imax diap, double step, getTextType ctx] ++ frame
-----------------------------------------------------------------------
-- other widgets
-- FLbox
drawBox label = fWithLabel label "FLbox" $
[ getBoxType ctx, getFontType ctx, getFontSize ctx ] ++ frameWithoutLabel
-- FLbutBank
drawButBank xn yn = fNoLabel "FLbutBank" $
[getButtonBankType ctx, int xn, int yn] ++ frameWithoutLabel ++ [noOpc]
-- FLbutton's
drawButton instrId = f "FLbutton" $ [int 1, int 0, getButtonType ctx] ++ frameWithoutLabel ++ (onOpc instrId [0, infiniteDur])
drawToggle = f "FLbutton" $ [int 1, int 0, getToggleType ctx] ++ frameWithoutLabel ++ [noOpc]
-- FLvalue
drawValue = f "FLvalue" frame
-- FLvkeybd
drawVkeybd = fWithLabel "" "FLvkeybd" frame
-----------------------------------------------------------
-- cascading context, here we group properties by type
data PropCtx = PropCtx
{ ctxLabel :: Maybe String
, ctxMaterial :: Maybe Material
, ctxLabelType :: Maybe LabelType
, ctxBoxType :: Maybe BoxType
, ctxColor1 :: Maybe Color
, ctxColor2 :: Maybe Color
, ctxTextColor :: Maybe Color
, ctxFontSize :: Maybe Int
, ctxFontType :: Maybe FontType
, ctxEmphasis :: Maybe Emphasis
, ctxOrient :: Maybe Orient
, ctxSliderType :: Maybe SliderType
, ctxButtonType :: Maybe ButtonType
, ctxTextType :: Maybe TextType
, ctxKnobType :: Maybe KnobType }
instance Default PropCtx where
def = PropCtx Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing
setPropCtx :: Prop -> PropCtx -> PropCtx
setPropCtx p x = case p of
SetLabel a -> x { ctxLabel = Just a }
SetMaterial a -> x { ctxMaterial = Just a }
SetLabelType a -> x { ctxLabelType = Just a }
SetBoxType a -> x { ctxBoxType = Just a }
SetColor1 a -> x { ctxColor1 = Just a }
SetColor2 a -> x { ctxColor2 = Just a }
SetTextColor a -> x { ctxTextColor = Just a }
SetFontSize a -> x { ctxFontSize = Just a }
SetFontType a -> x { ctxFontType = Just a }
SetEmphasis a -> x { ctxEmphasis = Just a }
SetOrient a -> x { ctxOrient = Just a }
SetSliderType a -> x { ctxSliderType = Just a }
SetButtonType a -> x { ctxButtonType = Just a }
SetTextType a -> x { ctxTextType = Just a }
SetKnobType a -> x { ctxKnobType = Just a }
getLabel :: PropCtx -> String
getLabel = maybe "" id . ctxLabel
------------------------------------------------------------------
-- Converting readable properties to integer codes
maybeDef :: Default a => Maybe a -> a
maybeDef = maybe def id
intProp :: Default a => (PropCtx -> Maybe a) -> (a -> Int) -> (PropCtx -> Doc)
intProp select convert = int . convert . maybeDef . select
getScale :: ValScaleType -> Doc
getScale x = int $ case x of
Linear -> 0
Exponential -> -1
getLabelType :: PropCtx -> Doc
getLabelType = intProp ctxLabelType $ \x -> case x of
NormalLabel -> 0
NoLabel -> 1
SymbolLabel -> 2
ShadowLabel -> 3
EngravedLabel -> 4
EmbossedLabel -> 5
getDefOrient :: Rect -> Orient
getDefOrient r
| height r < width r = Hor
| otherwise = Ver
getOrient :: Orient -> PropCtx -> Orient
getOrient defOrient = maybe defOrient id . ctxOrient
getKnobType :: PropCtx -> Doc
getKnobType = intProp ctxKnobType $ \x -> case x of
Flat -> 4
Pie -> 2
Clock -> 3
ThreeD _ -> 1
getKnobCursorSize :: PropCtx -> [Doc]
getKnobCursorSize ctx = case maybeDef $ ctxKnobType ctx of
ThreeD (Just n) -> [int n]
_ -> []
getRollerType :: Orient -> PropCtx -> Doc
getRollerType defOrient ctx = int $ case getOrient defOrient ctx of
Hor -> 1
Ver -> 2
getSliderType :: Orient -> PropCtx -> Doc
getSliderType defOrient ctx = int $ appMaterial ctx $
case (getOrient defOrient ctx, maybeDef $ ctxSliderType ctx) of
(Hor, Fill) -> 1
(Ver, Fill) -> 2
(Hor, Engraved) -> 3
(Ver, Engraved) -> 4
(Hor, Nice) -> 5
(Ver, Nice) -> 6
getTextType :: PropCtx -> Doc
getTextType = intProp ctxTextType $ \x -> case x of
NormalText -> 1
NoDrag -> 2
NoEdit -> 3
getBoxType :: PropCtx -> Doc
getBoxType = intProp ctxBoxType $ succ . fromEnum
getFontSize :: PropCtx -> Doc
getFontSize = int . getIntFontSize
getIntFontSize :: PropCtx -> Int
getIntFontSize ctx = maybe defFontSize id $ ctxFontSize ctx
getFontType :: PropCtx -> Doc
getFontType ctx = int $
case (maybeDef $ ctxFontType ctx, maybeDef $ ctxEmphasis ctx) of
(Helvetica, NoEmphasis) -> 1
(Helvetica, Bold) -> 2
(Helvetica, Italic) -> 3
(Helvetica, BoldItalic) -> 4
(Courier, NoEmphasis) -> 5
(Courier, Bold) -> 6
(Courier, Italic) -> 7
(Courier, BoldItalic) -> 8
(Times, NoEmphasis) -> 9
(Times, Bold) -> 10
(Times, Italic) -> 11
(Times, BoldItalic) -> 12
(Symbol, _) -> 13
(Screen, Bold) -> 15
(Screen, _) -> 14
(Dingbats, _) -> 16
getButtonType :: PropCtx -> Doc
getButtonType ctx = int $ appMaterial ctx 1
getButtonBankType :: PropCtx -> Doc
getButtonBankType ctx = ($ ctx) $ intProp ctxButtonType $ \x ->
reactOnNoPlasticForRoundBug $ appMaterial ctx $ case x of
NormalButton -> 1
LightButton -> 2
CheckButton -> 3
RoundButton -> 4
where reactOnNoPlasticForRoundBug x = case x of
24 -> 4
_ -> x
getToggleType :: PropCtx -> Doc
getToggleType ctx = ($ ctx) $ intProp ctxButtonType $ \x ->
reactOnNoPlasticForRoundBug $ appMaterial ctx $ case x of
NormalButton -> 2
LightButton -> 2
CheckButton -> 3
RoundButton -> 4
where reactOnNoPlasticForRoundBug x = case x of
24 -> 4
_ -> x
appMaterial :: PropCtx -> Int -> Int
appMaterial ctx = case maybeDef $ ctxMaterial ctx of
Plastic -> (+ 20)
NoPlastic -> id
getColor1, getColor2, getTextColor :: PropCtx -> Doc
getColor1 = genGetColor gray ctxColor1
getColor2 = genGetColor white ctxColor2
getTextColor = genGetColor black ctxTextColor
genGetColor :: Color -> (PropCtx -> Maybe Color) -> PropCtx -> Doc
genGetColor defColor select ctx = colorToDoc $ maybe defColor id $ select ctx
where colorToDoc col = hcat $ punctuate comma
$ fmap (channelToDoc col) [channelRed, channelGreen, channelBlue]
channelToDoc col chn = int $ fromEnum $ chn $ toSRGB24 $ col
-----------------------------------------------------------------
-- handy shortcuts
setProp :: Prop -> Gui -> Gui
setProp p = props [p]
setLabel :: String -> Gui -> Gui
setLabel = setProp . SetLabel
setLabelType :: LabelType -> Gui -> Gui
setLabelType = setProp . SetLabelType
setMaterial :: Material -> Gui -> Gui
setMaterial = setProp . SetMaterial
setBoxType :: BoxType -> Gui -> Gui
setBoxType = setProp . SetBoxType
setColor1 :: Color -> Gui -> Gui
setColor1 = setProp . SetColor1
setColor2 :: Color -> Gui -> Gui
setColor2 = setProp . SetColor2
setColors :: Color -> Color -> Gui -> Gui
setColors primary secondary = setColor1 primary . setColor2 secondary
setTextColor :: Color -> Gui -> Gui
setTextColor = setProp . SetTextColor
setFontSize :: Int -> Gui -> Gui
setFontSize = setProp . SetFontSize
setFontType :: FontType -> Gui -> Gui
setFontType = setProp . SetFontType
setEmphasis :: Emphasis -> Gui -> Gui
setEmphasis = setProp . SetEmphasis
setSliderType :: SliderType -> Gui -> Gui
setSliderType = setProp . SetSliderType
setTextType :: TextType -> Gui -> Gui
setTextType = setProp . SetTextType
setButtonType :: ButtonType -> Gui -> Gui
setButtonType = setProp . SetButtonType
setOrient :: Orient -> Gui -> Gui
setOrient = setProp . SetOrient
setKnobType :: KnobType -> Gui -> Gui
setKnobType = setProp . SetKnobType
------------------------------------------------------------------
-- best rectangles for the elements
--
winMargin :: Int
winMargin = 10
appendWinMargin :: Rect -> Rect
appendWinMargin r = r
{ width = 2 * winMargin + width r
, height = 2 * winMargin + height r
}
withWinMargin :: Rect -> Rect
withWinMargin r = r
{ px = winMargin
, py = winMargin
, height = height r - 2 * winMargin
, width = width r - 2 * winMargin
}
withRelWinMargin :: Rect -> Rect
withRelWinMargin r = r
{ px = winMargin + px r
, py = winMargin + py r
, height = height r - 2 * winMargin
, width = width r - 2 * winMargin
}
bestRect :: Gui -> Rect
bestRect
= appendWinMargin . Box.boundingRect
. mapWithOrient (\curOrient x -> uncurry noShiftRect $ bestElemSizes curOrient $ elemContent x)
. unGui
where noShiftRect w h = Rect { px = 0, py = 0, width = w, height = h }
mapWithOrient :: (Orient -> a -> b) -> Box.Scene ctx a -> Box.Scene ctx b
mapWithOrient f = iter Hor
where
iter curOrient x = case x of
Box.Prim a -> Box.Prim $ f curOrient a
Box.Space -> Box.Space
Box.Scale d a -> Box.Scale d $ iter curOrient a
Box.Hor offs as -> Box.Hor offs $ fmap (iter Hor) as
Box.Ver offs as -> Box.Ver offs $ fmap (iter Ver) as
Box.Context ctx a -> Box.Context ctx $ iter curOrient a
bestElemSizes :: Orient -> Elem -> (Int, Int)
bestElemSizes orient x = case x of
-- valuators
Count _ _ _ -> (150, 35)
Joy _ _ -> (350, 350)
Knob _ -> (170, 170)
Roller _ _ -> inVer (250, 35)
Slider _ -> inVer (300, 35)
Text _ _ -> (120, 35)
-- other widgets
Box label ->
let symbolsPerLine = 60
numOfLines = succ $ div (length label) symbolsPerLine
in (xBox 15 symbolsPerLine, yBox 15 numOfLines)
ButBank xn yn -> (xn * 80, yn * 35)
Button _ -> (80, 35)
Toggle -> (80, 35)
Value -> (100, 35)
Vkeybd -> (1280, 240)
-- error
GuiVar h -> orphanGuiVar h
where inVer (a, b) = case orient of
Ver -> (a, b)
Hor -> (b, a)
------------------------------------------------------------
-- FLbox font coefficients
xBox, yBox :: Int -> Int -> Int
xBox fontSize xn = round $ fromIntegral fontSize * (0.6 :: Double) * fromIntegral (1 + xn)
yBox fontSize yn = (fontSize + 12) * (1 + yn)
yLabelBox :: Int -> Int
yLabelBox fontSize = fontSize - 5
------------------------------------------------------------
-- set properties
flSetAll :: Var -> PropCtx -> Doc
flSetAll handle ctx = vcat $ fmap (\f -> f handle ctx)
[ flSetColor, flSetColor2, flSetTextColor
, flSetTextSize, flSetTextType, flSetFont ]
flSetColor, flSetColor2, flSetTextColor, flSetTextSize, flSetTextType,
flSetFont :: Var -> PropCtx -> Doc
flSetProp :: String
-> (PropCtx -> Maybe a)
-> (PropCtx -> Doc)
-> Var -> PropCtx -> Doc
flSetProp name isDef select handle ctx
| isNothing $ isDef ctx = empty
| otherwise = ppProc name [select ctx, ppVar handle]
flSetColor = flSetProp "FLsetColor" ctxColor1 getColor1
flSetColor2 = flSetProp "FLsetColor2" ctxColor2 getColor2
flSetTextColor = flSetProp "FLsetTextColor" ctxTextColor getTextColor
flSetTextSize = flSetProp "FLsetTextSize" (const $ Just (15 :: Int)) getFontSize
flSetTextType = flSetProp "FLsetTextType" ctxLabelType getLabelType
flSetFont = flSetProp "FLsetFont" ctxFontType getFontType
flSetVal_i :: InitMe -> Doc
flSetVal_i (InitMe handle v0) = ppProc "FLsetVal_i" [double v0, ppVar handle]
------------------------------------------------------------
-- extract handle.Hor
getPropHandle :: [Var] -> Maybe Var
getPropHandle xs = case xs of
[] -> Nothing
_ -> Just (last xs)
------------------------------------------------------------
-- error messages
orphanGuiVar :: GuiHandle -> a
orphanGuiVar (GuiHandle n) = error $ "orphan GuiHandle: " ++ show n
-------------------------------------------------------------
-- pretty printers
ppProc :: String -> [Doc] -> Doc
ppProc name xs = text name <+> (hsep $ punctuate comma xs)
ppMoOpc :: [Doc] -> String -> [Doc] -> Doc
ppMoOpc outs name ins = f outs <+> text name <+> f ins
where f = hsep . punctuate comma
ppVar :: Var -> Doc
ppVar v = case v of
Var ty rate name -> hcat [ppVarType ty, ppRate rate, text (varPrefix ty : name)]
VarVerbatim _ name -> text name
varPrefix :: VarType -> Char
varPrefix x = case x of
LocalVar -> 'l'
GlobalVar -> 'g'
ppVarType :: VarType -> Doc
ppVarType x = case x of
LocalVar -> empty
GlobalVar -> char 'g'
ppRate :: Rate -> Doc
ppRate x = case x of
Sr -> char 'S'
_ -> phi x
where phi = text . map toLower . show