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.Default
import Data.Colour.Names(white, gray, black)
import Data.Colour.SRGB
import Data.Text (Text)
import Data.Text qualified as Text
import Text.PrettyPrint.Leijen.Text(Doc, int, hcat, hsep, punctuate, comma, textStrict, char)
import qualified Text.PrettyPrint.Leijen.Text as P((<+>), empty)
import Csound.Dynamic(Var(..), VarType(..), Rate(..))
import Csound.Typed.Gui.Types
-------------------------------------------------------------
-- pretty printers
ppProc :: Text -> [Doc] -> Doc
ppProc name xs = textStrict name P.<+> (hsep $ punctuate comma xs)
ppMoOpc :: [Doc] -> Text -> [Doc] -> Doc
ppMoOpc outs name ins = f outs P.<+> textStrict 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, textStrict (Text.cons (varPrefix ty) name)]
VarVerbatim _ name -> textStrict 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 = textStrict . Text.toLower . Text.pack . show
------------------------------------------------------------------
-- 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 $ (+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