module Csound.Typed.Gui.Pretty (
ppProc, ppMoOpc, ppVar, varPrefix, ppVarType, ppRate,
intProp, getScale, getLabelType, getDefOrient, getOrient, getKnobType,
getKnobCursorSize, getRollerType, getSliderType, getTextType, getBoxType,
getFontSize, getIntFontSize, getFontType, getButtonType, getButtonBankType,
getToggleType, appMaterial, getColor1, getColor2, getTextColor, genGetColor
) where
import Data.Char
import Data.Default
import Data.Colour.Names(white, gray, black)
import Data.Colour.SRGB
import Text.PrettyPrint.Leijen(Doc, int, hcat, hsep, punctuate, comma, text, char)
import qualified Text.PrettyPrint.Leijen as P((<+>), empty)
import Csound.Dynamic(Var(..), VarType(..), Rate(..))
import Csound.Typed.Gui.Types
ppProc :: String -> [Doc] -> Doc
ppProc name xs = text name P.<+> (hsep $ punctuate comma xs)
ppMoOpc :: [Doc] -> String -> [Doc] -> Doc
ppMoOpc outs name ins = f outs P.<+> text name P.<+> 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 -> P.empty
GlobalVar -> char 'g'
ppRate :: Rate -> Doc
ppRate x = case x of
Sr -> char 'S'
_ -> phi x
where phi = text . map toLower . show
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 $ (+1) . 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
getToggleType :: PropCtx -> Doc
getToggleType ctx = ($ ctx) $ intProp ctxButtonType $ \x ->
reactOnNoPlasticForRoundBug $ appMaterial ctx $ case x of
NormalButton -> 2
LightButton -> 2
CheckButton -> 3
RoundButton -> 4
reactOnNoPlasticForRoundBug :: Int -> Int
reactOnNoPlasticForRoundBug x
| x == 24 = 4
| otherwise = x
appMaterial :: PropCtx -> Int -> Int
appMaterial ctx = case maybeDef $ ctxMaterial ctx of
Plastic -> (+ 20)
NoPlastic -> id
getColor1 :: PropCtx -> Doc
getColor1 = genGetColor gray ctxColor1
getColor2 :: PropCtx -> Doc
getColor2 = genGetColor white ctxColor2
getTextColor :: PropCtx -> Doc
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