module Harmonic.Framework.Builder.Modifiers
( defaultGenConfig
, gen, gen', gen''
, genGrid
, genGrid'
, genGrid''
, genE, genE', genE''
, genJ, genJ', genJ''
, genFrom, genFrom', genFrom''
, cue
, len
, entropy
, steer
, attempt
, viability
, tonal
, relStrata
, absStrata
, sameBoost, flipBoost, triBoost
, genP, genP', genP''
, genI, genII, genIII, genIV, genV, genVI, genVII, genVIII, genIX, genX, genXI
, genI', genII', genIII', genIV', genV', genVI', genVII', genVIII', genIX', genX', genXI'
, genI'', genII'', genIII'', genIV'', genV'', genVI'', genVII'', genVIII'', genIX'', genX'', genXI''
) where
import System.Random.MWC (createSystemRandom, uniformRM)
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as P
import qualified Harmonic.Rules.Types.Progression as Prog
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import qualified Harmonic.Rules.Types.Scale as Sc
import Harmonic.Framework.Builder.Types
defaultGenConfig :: GenConfig
defaultGenConfig :: GenConfig
defaultGenConfig = GenConfig
{ _gcCue :: IO CadenceState
_gcCue = IO CadenceState
defaultCue
, _gcCueExplicit :: Bool
_gcCueExplicit = Bool
False
, _gcLen :: Int
_gcLen = Int
4
, _gcSeek :: String
_gcSeek = String
"*"
, _gcEntropy :: Double
_gcEntropy = Double
0.2
, _gcTonal :: HarmonicContext
_gcTonal = HarmonicContext
hContext
, _gcVerbosity :: Verbosity
_gcVerbosity = Verbosity
Silent
, _gcMode :: GenMode
_gcMode = GenMode
Fresh
, _gcLenOverride :: Maybe Int
_gcLenOverride = Maybe Int
forall a. Maybe a
Nothing
, _gcRelStrata :: Maybe [Int]
_gcRelStrata = Maybe [Int]
forall a. Maybe a
Nothing
, _gcAbsStrata :: Maybe [StrataLabel]
_gcAbsStrata = Maybe [StrataLabel]
forall a. Maybe a
Nothing
, _gcBoostSame :: Double
_gcBoostSame = Double
0.90
, _gcBoostFlip :: Double
_gcBoostFlip = Double
0.80
, _gcBoostTri :: Double
_gcBoostTri = Double
0.70
, _gcSteer :: Double
_gcSteer = Double
3.0
, _gcMaxAttempts :: Int
_gcMaxAttempts = Int
1
, _gcViableTarget :: Int
_gcViableTarget = Int
1
, _gcViabilityFloor :: Double
_gcViabilityFloor = Double
0.5
}
where
defaultCue :: IO CadenceState
defaultCue = do
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
rootIdx <- uniformRM (0 :: Int, 11) rng
let rootName = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
H.FlatSpelling (Int -> PitchClass
P.mkPitchClass Int
rootIdx)
pure $ H.initCadenceState 0 (show rootName) [0, 4, 7]
gen :: GenConfig
gen :: GenConfig
gen = GenConfig
defaultGenConfig
gen' :: GenConfig
gen' :: GenConfig
gen' = GenConfig
defaultGenConfig { _gcVerbosity = Standard }
gen'' :: GenConfig
gen'' :: GenConfig
gen'' = GenConfig
defaultGenConfig { _gcVerbosity = Verbose }
genGrid :: GenConfig
genGrid :: GenConfig
genGrid = GenConfig
defaultGenConfig { _gcMode = GridMode }
genGrid' :: GenConfig
genGrid' :: GenConfig
genGrid' = GenConfig
genGrid { _gcVerbosity = Standard }
genGrid'' :: GenConfig
genGrid'' :: GenConfig
genGrid'' = GenConfig
genGrid { _gcVerbosity = Verbose }
genE :: GenConfig
genE :: GenConfig
genE = GenConfig
defaultGenConfig { _gcMode = PolyMode }
genE' :: GenConfig
genE' :: GenConfig
genE' = GenConfig
genE { _gcVerbosity = Standard }
genE'' :: GenConfig
genE'' :: GenConfig
genE'' = GenConfig
genE { _gcVerbosity = Verbose }
genJ :: GenConfig
genJ :: GenConfig
genJ = GenConfig
defaultGenConfig { _gcMode = JazzMode }
genJ' :: GenConfig
genJ' :: GenConfig
genJ' = GenConfig
genJ { _gcVerbosity = Standard }
genJ'' :: GenConfig
genJ'' :: GenConfig
genJ'' = GenConfig
genJ { _gcVerbosity = Verbose }
genFrom :: PC.ProgressionContext -> Int -> Int -> GenConfig
genFrom :: ProgressionContext -> Int -> Int -> GenConfig
genFrom ProgressionContext
pc Int
s Int
e = GenConfig
defaultGenConfig
{ _gcCue = inferCue
, _gcLen = rSize
, _gcMode = case PC.pcFamily pc of
Family
PC.FStrata -> ProgressionContext -> Int -> Int -> GenMode
FromProgPC ProgressionContext
pc Int
s Int
e
Family
PC.FJazz -> ProgressionContext -> Int -> Int -> GenMode
FromProgJ ProgressionContext
pc Int
s Int
e
Family
PC.FPoly -> ProgressionContext -> Int -> Int -> GenMode
FromProgPoly ProgressionContext
pc Int
s Int
e
Family
_ -> Progression -> Int -> Int -> GenMode
FromProg (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc) Int
s Int
e
}
where
triad :: Progression
triad = ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc
n0 :: Int
n0 = Progression -> Int
Prog.progLength Progression
triad
n :: Int
n = if Int
n0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then String -> Int
forall a. HasCallStack => String -> a
error String
"genFrom: source progression is empty (a failed generation?) — nothing to regenerate"
else Int
n0
rSize :: Int
rSize = if Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
e then Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e
cuePos :: Int
cuePos = ((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
inferCue :: IO CadenceState
inferCue = case Progression -> Int -> Maybe CadenceState
Prog.getCadenceState Progression
triad Int
cuePos of
Just CadenceState
cs -> CadenceState -> IO CadenceState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CadenceState
cs
Maybe CadenceState
Nothing -> GenConfig -> IO CadenceState
_gcCue GenConfig
defaultGenConfig
genFrom' :: PC.ProgressionContext -> Int -> Int -> GenConfig
genFrom' :: ProgressionContext -> Int -> Int -> GenConfig
genFrom' ProgressionContext
pc Int
s Int
e = (ProgressionContext -> Int -> Int -> GenConfig
genFrom ProgressionContext
pc Int
s Int
e) { _gcVerbosity = Standard }
genFrom'' :: PC.ProgressionContext -> Int -> Int -> GenConfig
genFrom'' :: ProgressionContext -> Int -> Int -> GenConfig
genFrom'' ProgressionContext
pc Int
s Int
e = (ProgressionContext -> Int -> Int -> GenConfig
genFrom ProgressionContext
pc Int
s Int
e) { _gcVerbosity = Verbose }
cue :: H.CadenceState -> GenConfig -> GenConfig
cue :: CadenceState -> GenConfig -> GenConfig
cue CadenceState
start GenConfig
gc = GenConfig
gc { _gcCue = pure start, _gcCueExplicit = True }
len :: Int -> GenConfig -> GenConfig
len :: Int -> GenConfig -> GenConfig
len Int
n GenConfig
gc = GenConfig
gc { _gcLen = n, _gcLenOverride = Nothing }
entropy :: Double -> GenConfig -> GenConfig
entropy :: Double -> GenConfig -> GenConfig
entropy Double
e GenConfig
gc = GenConfig
gc { _gcEntropy = e }
steer :: Double -> GenConfig -> GenConfig
steer :: Double -> GenConfig -> GenConfig
steer Double
x GenConfig
gc = GenConfig
gc { _gcSteer = max 0 x }
attempt :: Int -> Int -> GenConfig -> GenConfig
attempt :: Int -> Int -> GenConfig -> GenConfig
attempt Int
viableTarget Int
maxAttempts GenConfig
gc = GenConfig
gc
{ _gcViableTarget = max 1 viableTarget
, _gcMaxAttempts = max 1 maxAttempts
}
viability :: Double -> GenConfig -> GenConfig
viability :: Double -> GenConfig -> GenConfig
viability Double
t GenConfig
gc = GenConfig
gc { _gcViabilityFloor = max 0 t }
tonal :: HarmonicContext -> GenConfig -> GenConfig
tonal :: HarmonicContext -> GenConfig -> GenConfig
tonal HarmonicContext
ctx GenConfig
gc = GenConfig
gc { _gcTonal = ctx }
relStrata :: String -> GenConfig -> GenConfig
relStrata :: String -> GenConfig -> GenConfig
relStrata String
s GenConfig
gc =
let ns :: [Int]
ns = String -> [Int]
Sc.parseRelStrata String
s
in GenConfig
gc { _gcRelStrata = Just ns
, _gcLenOverride = if null ns then Nothing else Just (length ns)
}
absStrata :: String -> GenConfig -> GenConfig
absStrata :: String -> GenConfig -> GenConfig
absStrata String
s GenConfig
gc =
let ss :: [StrataLabel]
ss = String -> [StrataLabel]
Sc.parseAbsStrata String
s
in GenConfig
gc { _gcAbsStrata = Just ss
, _gcLenOverride = if null ss then Nothing else Just (length ss)
}
sameBoost :: Double -> GenConfig -> GenConfig
sameBoost :: Double -> GenConfig -> GenConfig
sameBoost Double
x GenConfig
gc = GenConfig
gc { _gcBoostSame = x }
flipBoost :: Double -> GenConfig -> GenConfig
flipBoost :: Double -> GenConfig -> GenConfig
flipBoost Double
x GenConfig
gc = GenConfig
gc { _gcBoostFlip = x }
triBoost :: Double -> GenConfig -> GenConfig
triBoost :: Double -> GenConfig -> GenConfig
triBoost Double
x GenConfig
gc = GenConfig
gc { _gcBoostTri = x }
genP :: Sc.StrataLabel -> GenConfig
genP :: StrataLabel -> GenConfig
genP StrataLabel
s = GenConfig
defaultGenConfig { _gcMode = StrataMode s }
genP' :: Sc.StrataLabel -> GenConfig
genP' :: StrataLabel -> GenConfig
genP' StrataLabel
s = (StrataLabel -> GenConfig
genP StrataLabel
s) { _gcVerbosity = Standard }
genP'' :: Sc.StrataLabel -> GenConfig
genP'' :: StrataLabel -> GenConfig
genP'' StrataLabel
s = (StrataLabel -> GenConfig
genP StrataLabel
s) { _gcVerbosity = Verbose }
genI, genII, genIII, genIV, genV, genVI, genVII, genVIII, genIX, genX, genXI :: GenConfig
genI :: GenConfig
genI = StrataLabel -> GenConfig
genP StrataLabel
Sc.I
genII :: GenConfig
genII = StrataLabel -> GenConfig
genP StrataLabel
Sc.II
genIII :: GenConfig
genIII = StrataLabel -> GenConfig
genP StrataLabel
Sc.III
genIV :: GenConfig
genIV = StrataLabel -> GenConfig
genP StrataLabel
Sc.IV
genV :: GenConfig
genV = StrataLabel -> GenConfig
genP StrataLabel
Sc.V
genVI :: GenConfig
genVI = StrataLabel -> GenConfig
genP StrataLabel
Sc.VI
genVII :: GenConfig
genVII = StrataLabel -> GenConfig
genP StrataLabel
Sc.VII
genVIII :: GenConfig
genVIII = StrataLabel -> GenConfig
genP StrataLabel
Sc.VIII
genIX :: GenConfig
genIX = StrataLabel -> GenConfig
genP StrataLabel
Sc.IX
genX :: GenConfig
genX = StrataLabel -> GenConfig
genP StrataLabel
Sc.X
genXI :: GenConfig
genXI = StrataLabel -> GenConfig
genP StrataLabel
Sc.XI
genI', genII', genIII', genIV', genV', genVI', genVII', genVIII', genIX', genX', genXI' :: GenConfig
genI' :: GenConfig
genI' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.I
genII' :: GenConfig
genII' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.II
genIII' :: GenConfig
genIII' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.III
genIV' :: GenConfig
genIV' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.IV
genV' :: GenConfig
genV' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.V
genVI' :: GenConfig
genVI' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.VI
genVII' :: GenConfig
genVII' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.VII
genVIII' :: GenConfig
genVIII' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.VIII
genIX' :: GenConfig
genIX' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.IX
genX' :: GenConfig
genX' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.X
genXI' :: GenConfig
genXI' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.XI
genI'', genII'', genIII'', genIV'', genV'', genVI'', genVII'', genVIII'', genIX'', genX'', genXI'' :: GenConfig
genI'' :: GenConfig
genI'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.I
genII'' :: GenConfig
genII'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.II
genIII'' :: GenConfig
genIII'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.III
genIV'' :: GenConfig
genIV'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.IV
genV'' :: GenConfig
genV'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.V
genVI'' :: GenConfig
genVI'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.VI
genVII'' :: GenConfig
genVII'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.VII
genVIII'' :: GenConfig
genVIII'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.VIII
genIX'' :: GenConfig
genIX'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.IX
genX'' :: GenConfig
genX'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.X
genXI'' :: GenConfig
genXI'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.XI