IntervalSets.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wall #-}

module IntervalSets where

import Control.Arrow ((&&&))
import Control.Monad (filterM)
import Control.Monad.State (evalState, get, modify)
import Control.Monad.Trans.State (StateT (StateT), evalStateT)
import Data.Finite (Finite, getFinite, modulo)
import Data.Foldable (traverse_)
import Data.List (uncons, unfoldr)
import Data.Set (Set)
import qualified Data.Set as Set

newtype Interval = Interval {getInterval :: Finite 12}
  deriving (Eq, Ord, Show)

invert :: Interval -> Interval
invert = Interval . modulo . (12 -) . getFinite . getInterval

newtype Pitch = Pitch {getPitch :: Finite 12}
  deriving (Eq, Ord, Enum, Show)

interval :: Pitch -> Pitch -> Interval
interval (Pitch a) (Pitch b) =
  let high = max a b
      low = min a b
   in Interval (modulo (getFinite high - getFinite low))

pitches :: Set Pitch
pitches = Set.fromList [Pitch 0 ..]

unconses :: [a] -> [(a, [a])]
unconses = unfoldr (((id &&& snd) <$>) . uncons)

cartesianProduct :: [a] -> [(a, a)]
cartesianProduct = evalStateT ((,) <$> StateT unconses <*> StateT unconses)

intervals :: Pitch -> Pitch -> Set Interval
intervals a b = Set.fromList [interval a b, invert (interval a b)]

duplicates :: Ord a => [a] -> [a]
duplicates =
  flip evalState Set.empty
    . filterM
      ( \a -> do
          seen <- get
          modify (Set.insert a)
          pure (Set.member a seen)
      )

hasOnlyUniqueIntervals :: Set Pitch -> Bool
hasOnlyUniqueIntervals =
  null
    . duplicates
    . foldMap (Set.toList . uncurry intervals)
    . cartesianProduct
    . Set.toList

pitchSets :: Set (Set Pitch)
pitchSets =
  let candidates = Set.filter hasOnlyUniqueIntervals (Set.powerSet pitches)
   in Set.filter (\s -> not (any (Set.isProperSubsetOf s) candidates)) candidates

main :: IO ()
main = traverse_ (print . Set.toList . Set.map (getFinite . getPitch)) pitchSets

-- [0,1,3,7]
-- [0,1,4,6]
-- [0,1,5]
-- [0,1,6,10]
-- [0,1,7,9]
-- [0,1,8]
-- [0,2,3,8]
-- [0,2,5,6]
-- [0,2,6,11]
-- [0,2,8,9]
-- [0,3,4,10]
-- [0,3,5,11]
-- [0,4,5]
-- [0,4,6,7]
-- [0,4,9,10]
-- [0,4,11]
-- [0,5,6,8]
-- [0,5,9,11]
-- [0,6,7,10]
-- [0,6,8,11]
-- [0,7,8]
-- [0,7,11]
-- [1,2,4,8]
-- [1,2,5,7]
-- [1,2,6]
-- [1,2,7,11]
-- [1,2,8,10]
-- [1,2,9]
-- [1,3,4,9]
-- [1,3,6,7]
-- [1,3,9,10]
-- [1,4,5,11]
-- [1,5,6]
-- [1,5,7,8]
-- [1,5,10,11]
-- [1,6,7,9]
-- [1,7,8,11]
-- [1,8,9]
-- [2,3,5,9]
-- [2,3,6,8]
-- [2,3,7]
-- [2,3,9,11]
-- [2,3,10]
-- [2,4,5,10]
-- [2,4,7,8]
-- [2,4,10,11]
-- [2,6,7]
-- [2,6,8,9]
-- [2,7,8,10]
-- [2,9,10]
-- [3,4,6,10]
-- [3,4,7,9]
-- [3,4,8]
-- [3,4,11]
-- [3,5,6,11]
-- [3,5,8,9]
-- [3,7,8]
-- [3,7,9,10]
-- [3,8,9,11]
-- [3,10,11]
-- [4,5,7,11]
-- [4,5,8,10]
-- [4,5,9]
-- [4,6,9,10]
-- [4,8,9]
-- [4,8,10,11]
-- [5,6,9,11]
-- [5,6,10]
-- [5,7,10,11]
-- [5,9,10]
-- [6,7,11]
-- [6,10,11]