Chord Spaces Implementation
Donya Quick and Paul Hudak
Last modified: 13-Jan-2016


> module Kulitta.ChordSpaces.OPTIC where
> import Kulitta.QuotientSpaces
> import Data.List
> import System.Random
> import Control.DeepSeq
> import Data.Maybe

Type definitions:

> type PitchNum = Int -- same as Euterpea's AbsPitch
> type AbsChord = [Int]
> type Prog = [AbsChord] -- Chord progression

The makeRange function will generate Z^n for user-specified ranges.

> makeRange :: [(PitchNum, PitchNum)] -> [AbsChord]
> makeRange = foldr (\(l,u) xs -> [(a:b) | a<-[l..u], b<-xs]) [[]]


A version of makeRange for use with sorted spaces:

> makeRange' :: [(PitchNum, PitchNum)] -> [AbsChord]
> makeRange' = foldr (\(l,u) xs -> [(a:b) | a<-[l..u], b<-xs, psort (a:b)]) [[]] where
>     psort (a:b:t) = a<b
>     psort _ = True 


========= O, P, & T IMPLEMENTATION =========

First we will define the octave and transposition operations. 
For f(x)=y with f in {o, t, p}, x~y for the corresponding 
equivalence relation (O, T, and P respectively).

> o,p :: [Int] -> AbsChord -> AbsChord
> o = zipWith (\i x -> x + 12 * i)
> p s xs = map (xs !!) s

> t :: Int -> AbsChord -> AbsChord
> t c = map (+c)

Note: "inv" below is just called "i" in the dissertation. It 
is called "inv" here for clarity.

> inv :: Bool -> AbsChord -> AbsChord
> inv neg = if neg then map (*(-1)) else id

We define normalizations for O, P, T, OP, OT, and PT.
We also add a new definition, OPC.

> normO, normT, normP, normOP, normPT, normPC, normOPC :: Norm AbsChord
> normO = map (`mod` 12)
> normT x = map (subtract $ head x) x
> normP = sort
> normOP = sort . normO
> normPT = normT . sort
> normOT = normO . normT
> normPC = nub . normP
> normOPC = nub . normOP
> normOC = normC . normO

> normC :: AbsChord -> AbsChord
> normC (x1:x2:xs) = 
>     if x1 == x2 then normC (x2:xs) else x1 : normC (x2:xs)
> normC x = x

Given a normalization, it can be turned into an 
equivalence relation.

> normToEqRel :: (Eq a) => Norm a -> EqRel a
> normToEqRel f a b = f a == f b

> oEq, pEq, tEq, opEq, ptEq, opcEq :: EqRel AbsChord
> [oEq, pEq, tEq, opEq, ptEq, otEq, opcEq] = 
>     map normToEqRel [normO, normT, normP, normOP, normPT, normOT, normOPC]

Old version of optEq that checks all octave stacks:

> optEq' :: EqRel AbsChord
> optEq' a b = 
>     let (a', b') = (normT $ normOP a, normT $ normOP b)
>         s = map (normT . normP) $ octStacks b'
>     in  or (map (==a') s)

New version that only checks rotations:

> optEq :: EqRel AbsChord
> optEq a b = 
>     let n = length b
>         (a', b') = (normT $ normOP a, normT $ normOP b)
>         is = map (\k -> take k (repeat 1) ++ take (n - k) (repeat 0)) [0..n]
>         s = map (normT . normP) $ map (\i -> o i b') is
>     in  or (map (==a') s)

> octStacks :: AbsChord -> [AbsChord]
> octStacks x = zipWith o (makeRange $ take (length x) $ repeat (0,1)) (repeat x)

> normOPT :: Norm AbsChord
> normOPT x = 
>     let x' = normT $ normOP x
>         s = map (normT . normP) $ octStacks x'
>     in  head $ sort s

The above can also use "sortBy optComp" instead of "sort" to achieve a
slightly different normalization approach that is more similar to 
the fundamental domain for OPT given by Callender et al.

> optComp a b = 
>     let (a',b') = (toIntervals a, toIntervals b)
>     in  if a' == b' then compare a b else compare a' b' 

> toIntervals x = zipWith subtract x (tail x)
  
OPTC-equivalence can be implemented similarly to OPT-equivalence.  
  
> optcEq :: EqRel AbsChord
> optcEq a b = optEq (normOPC a) (normOPC b)

> normOPTC :: AbsChord -> AbsChord
> normOPTC = normOPT . normOPC