module TScore.MidiPlus where
import TScore.Midi
import Data.Word.Odd
import GHC.Float
import Tile.Tile
import System.IO.Unsafe
import System.Random
import Data.List
import Debug.Trace
data Pattern = Pattern {
lval:: [Int],
minV:: Int,
maxV :: Int
} deriving (Show,Eq,Read)
rescale :: Pattern -> Int -> Int -> Pattern
rescale (Pattern lv min max) nmin nmax
= if (nmin >= nmax) then (Pattern (fmap (const nmin) lv) nmin nmin) else
let nrange = int2Float (nmax nmin)
rescaleV v = let ratio = int2Float (v min) / int2Float (max min)
in nmin + round (ratio*nrange)
in (Pattern (fmap rescaleV lv) nmin nmax)
density :: Integer -> Pattern -> Pattern
density n' (Pattern lv min max)
= let n = maximum[ 1,n']
in (Pattern (fmap (interpolate n lv) [0..(n1)]) min max)
interpolate :: Integer -> [Int] -> Integer -> Int
interpolate 1 l x = l!!0
interpolate n l x'
= let x = max 0 (min x' (n1))
sp = toRational ((length l) 1) / fromInteger (n 1)
h = toRational x * sp
h1 = floor h
h2 =ceiling h
delta = fromRational$ h toRational h1
in round $ (1 delta)*(toRational $ l!!h1) + delta*(toRational $ l!!(h2))
makeRythmPattern :: Fractional d => Pattern -> d -> [d]
makeRythmPattern p length
= let p1 = lval (rescale p 1 4) :: [Int]
p2 = map (\x -> 1/x) $ fmap (fromIntegral) p1
d = 10
p3 = map (\x -> (length)*x/d) p2
in p3
randomPermute :: [t] -> [t]
randomPermute [] = []
randomPermute l = let n = unsafePerformIO (randomRIO (1,length l))
in l!!(n1): randomPermute (take (n1) l ++ drop n l)
dodecaphonicMode :: Num t => () -> [t]
dodecaphonicMode () = randomPermute [0,1,2,3,4,5,6,7,8,9,10,11]
larUpdate :: Eq a => [a] -> a -> [a]
larUpdate l p =
let (l1,l2) = span ( /= p) l
in case l2 of
(p:l2') -> (p:l1)++ l2'
_ -> p:l
cutLast [] = []
cutLast [x] = []
cutLast (x:l) = x:(cutLast l)
larPc :: (Integral a, Num a, Eq a) => [a] -> [a] -> [a]
larPc l0 l = foldl larUpdate l0 (fmap (\x -> mod x 12) l)
data ScaleS a = ScaleS [a] (a,ScaleType) deriving (Show,Eq)
instance Functor ScaleS where
fmap f (ScaleS l (a,st)) = ScaleS (fmap f l) (f a,st)
instance Ord a => Ord (ScaleS a) where
compare (ScaleS l1 (a1,st1)) (ScaleS l2 (a2,st2))
= case compare st1 st2 of
LT -> LT
GT -> GT
EQ -> compare (a1,l1) (a2,l2)
majorC = ScaleS [0, 2, 4, 5, 7, 9, 11] (0,Major)
pentatonicC = ScaleS [0, 2, 4, 7, 9] (0,Pentatonic)
minorC = ScaleS [0, 2, 3, 5, 7, 8, 11] (0,Minor)
indianC = ScaleS [0, 1, 4, 5, 7, 8, 11] (0,Altered)
toneC = ScaleS [0,2,4,6,8,10] (0,Tone)
betweenC = ScaleS [0,2,4,7,9] (0,Between)
diminished1C = ScaleS [0,1,3,4,6,7,9,10] (0,Diminished)
diminished2C = ScaleS [0,2,3,5,6,8,9,11] (1,Diminished)
chromaticC = ScaleS [0,1,2,3,4,5,6,7,8,9,10,11] (0,Chromatic)
scaleS :: (Integral a, Num a) => a -> ScaleS a -> ScaleS a
scaleS p s = let (ScaleS l (a,st)) = fmap (\x -> mod (x + p) 12) s
in ScaleS (sort l) (a,st)
generateAllKeys k = fmap (\s -> (fmap (\p -> scaleS p s) [0..11])) k
allKeys = []
++ (sort $ concat $ generateAllKeys [majorC])
getCompatibleKeys l =
let filter (ScaleS l0 (a,st)) l =
isSubsequenceOf (sort l) l0
in fmap (\(ScaleS _ (a,s)) -> (a, s)) $ sort [m | m <- allKeys, filter m l]
changeKey (pc,st, []) = (pc,st)
changeKey (pc,st, l)
= let filter (ScaleS l0 (a,st)) l =
isSubsequenceOf l l0
sp = [m | m <- allKeys, filter m (sort l)]
leastWeight w lo l [] = (w,lo)
leastWeight w lo l (s@(ScaleS sl _):sp) =
let nw = scaleDist l sl
in case (compare nw w) of
LT -> leastWeight nw [s] l sp
EQ -> leastWeight w (s:lo) l sp
GT -> leastWeight w lo l sp
(w,lo) =
leastWeight 15 [] (sort l) allKeys
(w1,lo1) =
leastWeight 15 [] (take 3 $ sort l) lo
in case (w <= 6) of
False -> (pc,st)
True -> case lo1 of
[] -> error "change Key: this should not happen"
(ScaleS _ (a,st):_) -> (pitchToPitchClass a, st)
scaleDist :: [MidiPitch] -> [MidiPitch] -> Int
scaleDist [] l = length l
scaleDist l [] = length l
scaleDist (x:xs) (y:ys) =
case (compare x y) of
LT -> 1 + scaleDist xs (y:ys)
EQ -> scaleDist xs ys
GT -> 1 + scaleDist (x:xs) ys
pcDist :: PitchClass -> PitchClass -> Int
pcDist pc1 pc2 =
let p1 = fromEnum . pitchToPitchClass . pitchClassToPitch $ pc1
p2 = fromEnum . pitchToPitchClass . pitchClassToPitch $ pc2
in min (mod (p2 p1) 12) (12 (mod (p2 p1) 12))
pcstDist :: (PitchClass, ScaleType)
-> (PitchClass, ScaleType) -> Int
pcstDist (pc1,st1) (pc2,st2) =
case (st1 == st2) of
True -> 2*(pcDist pc1 pc2)
False -> case st1 of
Major -> 1+2*(pcDist (toEnum(3+fromEnum pc1)) pc2)
_ -> 1+2*(pcDist (toEnum(3+fromEnum pc2)) pc1)
pcstOrd (pc,st) (pc1,st1) (pc2,st2)
= let d1 = pcstDist (pc,st) (pc1,st1)
d2 = pcstDist (pc,st) (pc2,st2)
in case (compare st1 st2) of
LT -> LT
GT -> GT
_ -> compare d1 d2