module Csound.Typed.Gui.Gui (
Panel(..), Win(..), GuiNode(..), GuiHandle(..), Gui(..),
Elem(..), InitMe(..),
restoreTree, guiMap, mapGuiOnPanel, fromElem, fromGuiHandle,
panelIsKeybdSensitive, defText,
guiStmt,
hor, ver, space, sca, horSca, verSca,
padding, margin, ScaleFactor, resizeGui,
props, forceProps,
Prop(..), BorderType(..), Color,
Rect(..), FontType(..), Emphasis(..),
Material(..), Orient(..), LabelType(..),
setBorder, setLabel, setMaterial, setLabelType,
setColor1, setColor2, setColors, setTextColor,
setFontSize, setFontType, setEmphasis, setOrient,
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(Alternative(..))
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)
import Csound.Dynamic(DepT, depT_, Var(..), VarType(..), Rate(..), noRate, MainExp(..), InstrId(..))
import qualified Text.PrettyPrint.Leijen as P(int, double, vcat, hcat, hsep, punctuate, comma, empty, text, char, (<+>))
import qualified Csound.Typed.Gui.BoxModel as Box
import Csound.Typed.Gui.BoxModel(Rect(..))
import Csound.Typed.Constants(infiniteDur)
import Csound.Typed.Gui.Types
import Csound.Typed.Gui.Pretty
newtype GuiHandle = GuiHandle { unGuiHandle :: Int }
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 }
data InitMe = InitMe
{ initHandle :: Var
, initValue :: Double }
data Elem
= GuiVar GuiHandle
| Count ValDiap ValStep (Maybe ValStep)
| Joy ValSpan ValSpan
| Knob ValSpan
| Roller ValSpan ValStep
| Slider ValSpan
| Text ValDiap ValStep
| Box String
| ButBank Int Int
| Button InstrId
| Toggle
| Value
| Vkeybd
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
hor :: [Gui] -> Gui
hor = onLowGuis Box.hor
ver :: [Gui] -> Gui
ver = onLowGuis Box.ver
space :: Gui
space = Gui Box.space
sca :: Double -> Gui -> Gui
sca d = onLowGui1 (Box.sca d)
horSca :: [(Double, Gui)] -> Gui
horSca ps = hor $ fmap (uncurry sca) ps
verSca :: [(Double, Gui)] -> Gui
verSca ps = ver $ fmap (uncurry sca) ps
padding :: Int -> Gui -> Gui
padding n = onLowGui1 (Box.padding n)
margin :: Int -> Gui -> Gui
margin n = onLowGui1 (Box.margin n)
props :: [Prop] -> Gui -> Gui
props ps = onLowGui1 (Box.appendContext $ def { otherProps = ps })
resizeGui :: ScaleFactor -> Gui -> Gui
resizeGui factorXY = onLowGui1 (Box.appendContext $ def { propsScaleFactor = Just factorXY })
forceProps :: [Prop] -> Gui -> Gui
forceProps = error "forceProps: TODO"
setBorder :: BorderType -> Gui -> Gui
setBorder a = onLowGui1 (Box.appendContext $ def { propsBorder = 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 => ScaleFactor -> [Panel] -> DepT m ()
guiStmt defaultScaleUI panels = depT_ $ noRate (phi defaultScaleUI)
where phi scaleUI
| null panels = EmptyExp
| otherwise = Verbatim $ show $ P.vcat [P.vcat $ fmap (drawGui scaleUI) panels, P.text "FLrun"]
drawGui :: ScaleFactor -> Panel -> Doc
drawGui defaultScaleUI x = case x of
Single w isKeybd -> panel isKeybd boundingRect $ drawWin (withWinMargin boundingRect) w
Tabs _ _ ws isKeybd -> panel isKeybd tabPanelRect $ case ws of
[] -> P.empty
_ -> onTabs mainTabRect $ P.vcat $ fmap (uncurry $ drawTab shift) tabsRs
where boundingRect = panelRect defaultScaleUI (fmap fst tabsRs) x
tabsRs = tabsRects defaultScaleUI 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 = P.vcat
[ ppProc "FLpanel" [ P.text $ show title, P.int $ width rect, P.int $ height rect, P.int (-1), P.int (-1), P.int 0
, P.int $ if isKeybdSensitive then 1 else 0 ]
, body
, ppProc "FLpanelEnd" []]
onTabs rect body = P.vcat
[ ppProc "FLtabs" $ rectToFrame rect
, body
, ppProc "FLtabsEnd" []]
panelTitle :: Panel -> String
panelTitle x = case x of
Single w _ -> winTitle w
Tabs title _ _ _ -> title
panelRect :: ScaleFactor -> [Rect] -> Panel -> Rect
panelRect defaultScaleUI rs x = case x of
Single w _ -> winBoundingRect defaultScaleUI 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 :: ScaleFactor -> Panel -> [(Rect, Win)]
tabsRects defaultScaleUI x = case x of
Single _ _ -> []
Tabs _ _ ws _ -> zip (fmap (winBoundingRect defaultScaleUI) ws) ws
winBoundingRect :: ScaleFactor -> Win -> Rect
winBoundingRect defaultScaleUI w = maybe (shiftBy 50 $ bestRect defaultScaleUI $ 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 = P.vcat
[ ppProc "FLgroup" $ (P.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 P.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 P.empty P.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 = P.vcat
[ ppProc "FLgroup" $ ((P.text $ show "") : frame) ++ [borderAsInt borderType]
, a
, ppProc "FLgroupEnd" []]
where borderAsInt = P.int . fromEnum
frame = rectToFrame rect
drawPrim :: PropCtx -> Rect -> ElemWithOuts -> Doc
drawPrim ctx rect elem = P.vcat
[ drawElemDef ctx rect elem
, drawAppearance ctx elem
, drawInitVal elem ]
drawAppearance :: PropCtx -> ElemWithOuts -> Doc
drawAppearance ctx el = maybe P.empty (flip flSetAll ctx)
$ getPropHandle $ elemOuts el
drawInitVal :: ElemWithOuts -> Doc
drawInitVal = P.vcat . fmap flSetVal_i . elemInits
drawElemDef :: PropCtx -> Rect -> ElemWithOuts -> Doc
drawElemDef ctx rectWithoutLabel el = case elemContent el of
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
Box label -> drawBox label
ButBank xn yn -> drawButBank xn yn
Button instrId -> drawButton instrId
Toggle -> drawToggle
Value -> drawValue
Vkeybd -> drawVkeybd
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 ((P.text $ show $ label) : args)
fNoLabel name args = ppMoOpc (fmap ppVar $ elemOuts el) name args
frame = frameBy rect
frameWithoutLabel = frameBy rectWithoutLabel
frameBy x = fmap P.int [width x, height x, px x, py x]
noDisp = P.int (-1)
noOpc = P.int (-1)
onOpc instrId xs = P.int 0 : P.int (instrIdCeil instrId) : fmap P.double xs
drawSpan (ValSpan diap scale) = [imin diap, imax diap, getScale scale]
imin = P.double . valDiapMin
imax = P.double . valDiapMax
drawCount diap step1 mValStep2 = f "FLcount" $
[ imin diap, imax diap
, P.double step1, P.double step2
, P.int itype ]
++ frame ++ [noOpc]
where (step2, itype) = case mValStep2 of
Just n -> (n, 1)
Nothing -> (step1, 2)
drawJoy (ValSpan dX sX) (ValSpan dY sY) = f "FLjoy" $
[ imin dX, imax dX, imin dY, imax dY
, getScale sX, getScale sY
, noDisp, noDisp
] ++ frame
drawKnob span = f "FLknob" $
drawSpan span ++ [getKnobType ctx, noDisp]
++ fmap P.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
drawRoller (ValSpan d s) step = f "FLroller" $
[ imin d, imax d, P.double step
, getScale s, getRollerType (getDefOrient rect) ctx, noDisp
] ++ frame
drawSlider span = f "FLslider" $
drawSpan span
++ [getSliderType (getDefOrient rect) ctx, noDisp]
++ frame
drawText diap step = f "FLtext" $
[imin diap, imax diap, P.double step, getTextType ctx] ++ frame
drawBox label = fWithLabel label "FLbox" $
[ getBoxType ctx, getFontType ctx, getFontSize ctx ] ++ frameWithoutLabel
drawButBank xn yn = fNoLabel "FLbutBank" $
[getButtonBankType ctx, P.int xn, P.int yn] ++ frameWithoutLabel ++ [noOpc]
drawButton instrId = f "FLbutton" $ [P.int 1, P.int 0, getButtonType ctx] ++ frameWithoutLabel ++ (onOpc instrId [0, infiniteDur])
drawToggle = f "FLbutton" $ [P.int 1, P.int 0, getToggleType ctx] ++ frameWithoutLabel ++ [noOpc]
drawValue = f "FLvalue" frame
drawVkeybd = fWithLabel "" "FLvkeybd" frame
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
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 :: ScaleFactor -> Gui -> Rect
bestRect defaultScaleUI
= appendWinMargin . Box.boundingRect
. mapWithOrientAndScale defaultScaleUI (\curOrient curScaleFactor x -> uncurry noShiftRect $ bestElemSizesRescaled curScaleFactor $ bestElemSizes curOrient $ elemContent x)
. unGui
where noShiftRect w h = Rect { px = 0, py = 0, width = w, height = h }
mapWithOrientAndScale :: ScaleFactor -> (Orient -> ScaleFactor -> a -> b) -> Box.Scene Props a -> Box.Scene Props b
mapWithOrientAndScale defaultScaleUI f = iter Hor defaultScaleUI
where
iter curOrient curScale x = case x of
Box.Prim a -> Box.Prim $ f curOrient curScale a
Box.Space -> Box.Space
Box.Scale d a -> Box.Scale d $ iter curOrient curScale a
Box.Hor offs as -> Box.Hor offs $ fmap (iter Hor curScale) as
Box.Ver offs as -> Box.Ver offs $ fmap (iter Ver curScale) as
Box.Context ctx a -> case propsScaleFactor ctx of
Nothing -> Box.Context ctx $ iter curOrient curScale a
Just newScale -> Box.Context ctx $ iter curOrient (mulFactors curScale newScale) a
where
mulFactors (x1, y1) (x2, y2) = (x1 * x2, y1 * y2)
bestElemSizesRescaled :: ScaleFactor -> (Int, Int) -> (Int, Int)
bestElemSizesRescaled (scaleX, scaleY) (sizeX, sizeY) = (mul scaleX sizeX, mul scaleY sizeY)
where mul d n = round $ d * fromIntegral n
bestElemSizes :: Orient -> Elem -> (Int, Int)
bestElemSizes orient x = case x of
Count _ _ _ -> (120, 30)
Joy _ _ -> (200, 200)
Knob _ -> (80, 80)
Roller _ _ -> inVer (150, 30)
Slider _ -> inVer (150, 25)
Text _ _ -> (100, 35)
Box label ->
let symbolsPerLine = 60
numOfLines = succ $ div (length label) symbolsPerLine
in (xBox 15 symbolsPerLine, yBox 15 numOfLines)
ButBank xn yn -> (xn * 70, yn * 35)
Button _ -> (75, 35)
Toggle -> (75, 35)
Value -> (80, 35)
Vkeybd -> (1080, 240)
GuiVar h -> orphanGuiVar h
where inVer (a, b) = case orient of
Ver -> (a, b)
Hor -> (b, a)
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
flSetAll :: Var -> PropCtx -> Doc
flSetAll handle ctx = P.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 = P.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" [P.double v0, ppVar handle]
getPropHandle :: [Var] -> Maybe Var
getPropHandle xs = case xs of
[] -> Nothing
_ -> Just (last xs)
orphanGuiVar :: GuiHandle -> a
orphanGuiVar (GuiHandle n) = error $ "orphan GuiHandle: " ++ show n