{-# LANGUAGE ImplicitParams, Rank2Types, ScopedTypeVariables, BangPatterns #-}
module Transformations where
import Data.List (sortOn)
import Data.Semigroup
import Data.Functor.Contravariant hiding ((>$<), (>$), ($<))
import Types
newtype Check a = Check { getCheck :: a -> a -> Bool }
(<=>) :: a -> a -> Check a -> Bool
(x <=> y) p = getCheck p x y
instance Semigroup (Check a) where
p <> q = Check $ \x y -> and (x <=> y `map` [p, q])
instance Contravariant Check where
contramap f p = Check $ \x y -> (f x <=> f y) p
infix 7 >$<
(>$<) :: (a -> b) -> Check b -> Check a
(>$<) = contramap
infix 8 >$, $<
(>$), ($<) :: (a -> a) -> Check a -> Check a
f >$ p = Check $ \x y -> (f x <=> y) p
f $< p = Check $ \x y -> (x <=> f y) p
type ApproxCheck a = (?p :: Float) => Check a
(~~) :: ((?p::Float) => r) -> Float -> r
(~~) thing f = let ?p = f in thing
exactOf :: ApproxCheck Pattern
exactOf = rhythm >$< approxEq2
<> pitch >$< approxEq
transpositionOf :: ApproxCheck Pattern
transpositionOf = rhythm >$< approxEq2
<> intervals >$< approxEq2
transpositionOfPitchOnly :: ApproxCheck Pattern
transpositionOfPitchOnly = intervals >$< approxEq2
inversionOf :: ApproxCheck Pattern
inversionOf = basePitch >$< equal
<> rhythm >$< approxEq2
<> intervals >$< (inverse $< approxEq2)
retrogradeOf :: ApproxCheck Pattern
retrogradeOf = rhythm >$< (reverse $< approxEq2)
<> pitch >$< (reverse $< approxEq)
rotationOf :: ApproxCheck Pattern
rotationOf = rhythm >$< (reverse $< approxEq2)
<> intervals >$< (reverse $< approxEq2)
augmentationOf :: ApproxCheck Pattern
augmentationOf = normalRhythm >$< approxEq2
<> pitch >$< approxEq
tonalTranspOf :: ApproxCheck Pattern
tonalTranspOf = rhythm >$< approxEq2
<> Check (\xs ys -> (xs <=> ys) (applyScale (guessScale $ xs ++ ys)
>$< approxEq2))
tonalTranspOfCan :: ApproxCheck Pattern
tonalTranspOfCan = rhythm >$< approxEq2
<> Check (\xs ys -> foldr (||) True (map (xs <=> ys) [checks >$< approxEq2 | checks <- (map applyScale (guessScaleCandidates 3 $ xs ++ ys))]))
tonalTransCanOfCore :: Check Pattern
tonalTransCanOfCore = Check (\xs ys -> foldr (||) True (map (xs <=> ys)
[checks >$< equal | checks <- (map applyScale (guessScaleCandidates 3 $ xs ++ ys))]))
tonalInversionOfCan :: ApproxCheck Pattern
tonalInversionOfCan = rhythm >$< approxEq2
<> Check (\xs ys -> foldr (||) True (map (xs <=> ys) [checks >$< (inverse $< approxEq2) | checks <- (map applyScale (guessScaleCandidates 3 $ xs ++ ys))]))
trInversionOf :: ApproxCheck Pattern
trInversionOf = rhythm >$< approxEq2
<> intervals >$< (inverse $< approxEq2)
trAugmentationOf :: ApproxCheck Pattern
trAugmentationOf = normalRhythm >$< approxEq2
<> intervals >$< approxEq2
trRetrogradeOf :: ApproxCheck Pattern
trRetrogradeOf = rhythm >$< (reverse $< approxEq2)
<> intervals >$< (reverse . inverse $< approxEq2)
trtonRotationOf :: ApproxCheck Pattern
trtonRotationOf = rhythm >$< (reverse $< approxEq2)
<> Check (\xs ys -> (xs <=> ys) (applyScale (guessScale xs)
>$< approxEq2))
trtonAugmentationOf :: ApproxCheck Pattern
trtonAugmentationOf = normalRhythm >$< approxEq2
<> Check (\xs ys -> (xs <=> ys) (applyScale (guessScale xs)
>$< approxEq2))
equal :: Eq a => Check a
equal = Check (==)
maxLookahead :: Int
maxLookahead = 5
approxEqWith :: forall b. (Show b, Num b, Eq b)
=> ( b
-> [b]
-> Int
-> Maybe (Int, [b])
)
-> ApproxCheck [b]
approxEqWith del1
| ?p == 1.0 = equal
| otherwise = Check go
where
go xs' ys' =
let [xs, ys] = sortOn length [xs', ys']
[n, m] = length <$> [xs, ys]
maxIgnored = floor $ (1 - ?p) * fromIntegral n
maxAdded = floor $ (1 - ?p) * fromIntegral m
in del ys xs (maxIgnored, maxAdded)
del :: [b] -> [b] -> (Int , Int ) -> Bool
del ys [] (maxI, maxA) = 0 <= maxI && length ys <= maxA
del [] xs (maxI, maxA) = length xs <= maxI && 0 <= maxA
del ys (x:xs) (maxI, maxA)
| maxI < 0 || maxA < 0
= False
| maxI + maxA == 0
= ys == x:xs
| Just (maxA', ys') <- del1 x ys maxA
, maxA' >= 0
, maxA - maxA' <= maxLookahead
= del ys' xs (maxI, maxA')
| maxI > 0
= del ys xs (maxI - 1, maxA)
| otherwise
= False
approxEq :: (Show a, Num a, Eq a) => ApproxCheck [a]
approxEq = approxEqWith del1
where
del1 _ [] _ = Nothing
del1 x (y:ys) maxA
| maxA < 0 = Nothing
| x == y = Just (maxA, ys)
| otherwise = del1 x ys $! (maxA - 1)
approxEq2 :: (Show a, Ord a, Num a, Eq a) => ApproxCheck [a]
approxEq2 = approxEqWith del1
where
del1 _ [] _ = Nothing
del1 x (y:ys) maxA
| maxA < 0 = Nothing
| x == y = Just (maxA, ys)
| Just i <- findIndex 0 x (y:ys) maxLookahead
, maxA >= i
= Just (maxA - i, snd $ splitAt i ys)
| otherwise
= del1 x ys $! (maxA - 1)
findIndex i 0 _ _ = Just i
findIndex _ _ _ 0 = Nothing
findIndex _ _ [] _ = Nothing
findIndex i acc (y:ys) maxAc
| acc >= y = findIndex (i + 1) (acc - y) ys (maxAc - 1)
| otherwise = Nothing