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, ScaleFactor, resizeGui, -- * 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 Data.Default import Data.Maybe(isNothing) import Data.Monoid 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, empty, text) import qualified Csound.Typed.Gui.BoxModel as Box import Csound.Typed.Constants(infiniteDur) import Csound.Typed.Gui.Types import Csound.Typed.Gui.Pretty newtype GuiHandle = GuiHandle { unGuiHandle :: Int } -- | 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 } 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 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 $ def { otherProps = ps }) -- | Rescales the default sizes for the UI elements. resizeGui :: ScaleFactor -> Gui -> Gui resizeGui factorXY = onLowGui1 (Box.appendContext $ def { propsScaleFactor = Just factorXY }) -- | 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 $ 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 -- panel with default position no border and capture of keyboard events [ 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 -- 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 ((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 ----------------------------------------------------------------------- -- valuators -- FLcount 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 -- 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 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 -- FLroller drawRoller (ValSpan d s) step = f "FLroller" $ [ imin d, imax d, P.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, P.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, P.int xn, P.int yn] ++ frameWithoutLabel ++ [noOpc] -- FLbutton's 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] -- FLvalue drawValue = f "FLvalue" frame -- FLvkeybd drawVkeybd = fWithLabel "" "FLvkeybd" frame ----------------------------------------------------------------- -- 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 :: 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 -- valuators Count _ _ _ -> (120, 30) Joy _ _ -> (200, 200) Knob _ -> (80, 80) Roller _ _ -> inVer (150, 30) Slider _ -> inVer (150, 25) Text _ _ -> (100, 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 * 70, yn * 35) Button _ -> (75, 35) Toggle -> (75, 35) Value -> (80, 35) Vkeybd -> (1080, 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 = 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] ------------------------------------------------------------ -- 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