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
> type AbsChord = [Int]
> type Prog = [AbsChord]
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