{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Harmonic.Rules.Constraints.Filter
-- Description : Pitch class set filtering using legacy notation
--
-- This module implements the parsing and filtering system from the legacy
-- Overtone.hs, providing compatibility with the original command line app
-- and TidalCycles integration.
--
-- == Academic Lineage
--
-- /The Harmonic Algorithm/ (South, 2016), Section One: the three tuning
-- systems EAeGB (Electric Contrabass Cittern), EAeGC (with B\/C re-tuner),
-- and EADG (standard bass). The overtone series mapping
-- @[0, 7, 4, 10, 2]@ (root, P5, M3, m7, M2) is the equal-temperament
-- approximation of the first five unique partials.
--
-- == Filter Notation
--
-- === Overtones\/Pitch Set Filter
-- Limits harmonic choices to pitches within a specified set.
--
-- * Fundamental pitches (derives overtones): @"E A D G"@ (bass tuning)
-- * Individual pitches with prime: @"E'"@ @"A'"@ @"A#'"@
-- * Combined: @"G E' A' A#'"@ (G overtones + E, A, A# pitches)
-- * Wildcard: @"*"@ (all pitches)
--
-- === Key Filter
-- Removes pitches not in the specified key.
-- Note names yield a /single pitch class/; numbered key sigs yield a /major scale/.
--
-- * Note name: @"C"@ = only pitch C, @"Bb"@ = only pitch Bb (PC 10)
-- * Numbered key sig: @"0#"@ = C major, @"1#"@ = G major, @"2b"@ = Bb major, @"4b"@
-- * Wildcard: @"*"@ (no key filtering)
--
-- === Root Notes Filter
-- Limits bass notes to specified pitch classes or key.
-- Uses the same unified rules as the key filter.
--
-- * Note name: @"E"@ @"F#"@ @"Bb"@ → individual pitches @[4, 6, 10]@
-- * Numbered key sig: @"1b"@ = F major roots, @"2#"@ = D major roots
-- * Wildcard: @"*"@ (all roots)
--
-- == Pitch Removal with '-' Operator
--
-- All parsing functions support pitch removal using the @-@ prefix:
--
-- * @"C E -E'"@ → (C overtones ∪ E overtones) \\ {E pitch}
-- * @"1b 2# -G"@ → (F major ∪ D major) \\ {G}
-- * @"* -C' -F#'"@ → All pitches except C and F#
--
-- === Context-Specific Behavior
--
-- * __Overtones__: note name generates overtone series; prime notation gives single pitch
-- * __Key__: note name = single pitch; numbered sig = major key scale
-- * __Roots__: same as Key (unified rules)
--
-- === Order of Operations
--
-- 1. Union all positive tokens
-- 2. Union all negative tokens
-- 3. Subtract: positive \\ negative
--
-- === Edge Cases
--
-- * @"*"@ → all pitches (wildcard shortcut)
-- * @"* -C'"@ → all except C
-- * @"-*"@ → empty set (no includes)
-- * @"-C -D"@ → empty set (no includes)
-- * @"C -C"@ → empty set (self-cancellation)

module Harmonic.Rules.Constraints.Filter
  ( -- * Parsing Functions (Text versions)
    parseOvertones
  , parseKey
  , parseFunds
  , parseTuning
  , resolveRoots

    -- * Parsing Functions (String versions for Tidal)
  , overtones
  , key
  , funds
  , tuning
  , wildcard

    -- * High-level API
  , filterPitchSet
  , filterByKey
  , filterRoots

    -- * Filtering Predicates
  , isWildcard
  , matchesPitchSet
  , matchesKey
  , matchesRoots

    -- * Bass Direction
  , BassDirection(..)
  , BassDirectionSpec(..)
  , BDKind(..)
  , BDSelector(..)
  , parseBassDirectionSpec
  , stripDirectionToken
  , closestAbove
  , closestBelow
  , nthAbove
  , nthBelow

    -- * Internal (for testing)
  , parseOvertones'
  , parseKey'
  , parseFunds'
  , parseTuning'
  , partitionTokens
  , keyToPitchClasses
  , noteNameToPitchClass

    -- * Overtone Annotation Support
  , parseTuningNamed
  ) where

import qualified Data.Char as Char
import qualified Data.Text as T
import           Data.Text (Text)
import           Data.List (nub, sort, sortBy, partition, (\\))
import           Data.Maybe (mapMaybe)
import qualified Data.IntSet as IntSet

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

type PitchClass = Int  -- 0-11

-------------------------------------------------------------------------------
-- Wildcard Handling
-------------------------------------------------------------------------------

-- |Check if a filter string is a wildcard (matches everything)
isWildcard :: Text -> Bool
isWildcard :: Text -> Bool
isWildcard Text
t = Text
t' Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"*", Text
"all", Text
"chr"]
  where t' :: Text
t' = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
t

-- |The chromatic set (all 12 pitch classes)
chromaticSet :: [PitchClass]
chromaticSet :: [Int]
chromaticSet = [Int
0..Int
11]

-------------------------------------------------------------------------------
-- Overtone Generation
-------------------------------------------------------------------------------

-- |Generate first n overtones from a fundamental pitch class.
-- Uses the overtone series: root, P5, M3, m7, M2 (first 5 partials mapped to octave)
--
-- For example, C (0) generates: [0, 7, 4, 10, 2] = C, G, E, Bb, D
-- Default n=3 gives root, P5, M3 — the distinct pitch classes of the
-- playable tapped-harmonic domain (sounding partials 1-5: root, root,
-- fifth, root, third)
overtoneSeriesFrom :: Int -> PitchClass -> [PitchClass]
overtoneSeriesFrom :: Int -> Int -> [Int]
overtoneSeriesFrom Int
n Int
root = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
n ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
root)) [Int
0, Int
7, Int
4, Int
10, Int
2]

-- |Generate pitches from a major key (Ionian mode)
-- Given a position on the circle of fifths (0 = C, 1 = G, -1 = F, etc.)
keyPitches :: Int -> [PitchClass]
keyPitches :: Int -> [Int]
keyPitches Int
fifths = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fifths Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
7)) [Int
0, Int
2, Int
4, Int
5, Int
7, Int
9, Int
11]

-------------------------------------------------------------------------------
-- Parsing: Tuning\/Overtones
-------------------------------------------------------------------------------

-- |Parse a tuning string into pitch class set (overtones of fundamentals).
-- 
-- Examples:
--   * @"E A D G"@ → overtones of E, A, D, G (bass tuning)
--   * @"C"@ → overtones of C
--   * @"*"@ → all pitch classes
parseTuning' :: Int -> Text -> [PitchClass]
parseTuning' :: Int -> Text -> [Int]
parseTuning' Int
n Text
input
  | Text -> Bool
isWildcard Text
input = [Int]
chromaticSet
  | Bool
otherwise = [Int] -> [Int]
unique ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [Int]) -> [Text] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Bool -> Text -> [Int]
parseToken Int
n Bool
False) [Text]
tokens
  where
    tokens :: [Text]
tokens = Text -> [Text]
T.words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower Text
input
    
-- |Parse a tuning string preserving string names for overtone annotation.
-- Case is preserved for string identification (uppercase = lower octave,
-- lowercase = higher octave per thesis convention).
--
-- Examples:
--   @"E A D G"@ → @[("E",4), ("A",9), ("D",2), ("G",7)]@
--   @"E A e G B"@ → @[("E",4), ("A",9), ("e",4), ("G",7), ("B",11)]@
--   @"*"@ → @[]@ (wildcard has no named strings)
parseTuningNamed :: Text -> [(String, Int)]
parseTuningNamed :: Text -> [(String, Int)]
parseTuningNamed Text
input
  | Text -> Bool
isWildcard Text
input = []
  | Bool
otherwise = (Text -> Maybe (String, Int)) -> [Text] -> [(String, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (String, Int)
parseNamedToken (Text -> [Text]
T.words Text
input)
  where
    parseNamedToken :: Text -> Maybe (String, Int)
parseNamedToken Text
tok =
      case Text -> Maybe Int
noteNameToPitchClass (Text -> Text
T.toLower Text
tok) of
        Just Int
pc -> (String, Int) -> Maybe (String, Int)
forall a. a -> Maybe a
Just (Text -> String
T.unpack Text
tok, Int
pc)
        Maybe Int
Nothing -> Maybe (String, Int)
forall a. Maybe a
Nothing

-- |Parse a single token in tuning context
parseToken :: Int -> Bool -> Text -> [PitchClass]
parseToken :: Int -> Bool -> Text -> [Int]
parseToken Int
n Bool
isPrime Text
token
  | Text -> Bool
T.null Text
token = []
  | Text
"'" Text -> Text -> Bool
`T.isSuffixOf` Text
token = 
      -- Prime notation: single pitch class only (legacy behavior)
      case Text -> Maybe Int
noteNameToPitchClass (HasCallStack => Text -> Text
Text -> Text
T.init Text
token) of
        Just Int
pc -> [Int
pc]
        Maybe Int
Nothing -> []
  | Bool
otherwise = case Text -> Maybe Int
noteNameToPitchClass Text
token of
      Just Int
pc -> if Bool
isPrime then [Int
pc] else Int -> Int -> [Int]
overtoneSeriesFrom Int
n Int
pc
      Maybe Int
Nothing -> []  -- Invalid token ignored

-- |Map note names to pitch classes
-- Handles: c, c#, db, d, d#, eb, e, f, f#, gb, g, g#, ab, a, a#, bb, b
-- Also: b# = c, cb = b, etc.
noteNameToPitchClass :: Text -> Maybe PitchClass
noteNameToPitchClass :: Text -> Maybe Int
noteNameToPitchClass Text
t = case Text -> Text
T.toLower Text
t of
  Text
"c"   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0;  Text
"b#"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0;  Text
"dbb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  Text
"c#"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1;  Text
"db"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1;  Text
"b##" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  Text
"d"   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2;  Text
"c##" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2;  Text
"ebb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
  Text
"d#"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3;  Text
"eb"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3;  Text
"fbb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3
  Text
"e"   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4;  Text
"d##" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4;  Text
"fb"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
  Text
"f"   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
5;  Text
"e#"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
5;  Text
"gbb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
5
  Text
"f#"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
6;  Text
"gb"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
6;  Text
"e##" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
6
  Text
"g"   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
7;  Text
"f##" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
7;  Text
"abb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
7
  Text
"g#"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8;  Text
"ab"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
  Text
"a"   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
9;  Text
"g##" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
9;  Text
"bbb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
9
  Text
"a#"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
10; Text
"bb"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
10; Text
"cbb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
10
  Text
"b"   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
11; Text
"a##" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
11; Text
"cb"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
11
  Text
_     -> Maybe Int
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- Parsing: Key Signatures
-------------------------------------------------------------------------------

-- |Parse a key filter string.
--
-- Formats:
--   * Note name: @"C"@, @"Bb"@, @"F#"@ → single pitch class
--   * Numbered key sig: @"0#"@ = C major, @"1#"@ = G major, @"2b"@ = Bb major
--   * Wildcard: @"*"@
--   * Removal: @"1b -G"@ (F major minus G), @"* -C'"@ (all minus C)
parseKey' :: Int -> Text -> [PitchClass]
parseKey' :: Int -> Text -> [Int]
parseKey' Int
_ Text
input
  | Text -> Bool
isWildcard Text
input = [Int]
chromaticSet
  | Bool
otherwise =
      let ([Text]
includes, [Text]
excludes) = Text -> ([Text], [Text])
partitionTokens Text
input
          includePcs :: [Int]
includePcs = [Int] -> [Int]
unique ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [Int]) -> [Text] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Int]
parseKeyToken [Text]
includes
          excludePcs :: [Int]
excludePcs = [Int] -> [Int]
unique ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [Int]) -> [Text] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Int]
parseKeyToken [Text]
excludes
      in [Int]
includePcs [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Int]
excludePcs

-- |Convert a key specification to pitch classes
keyToPitchClasses :: Text -> [PitchClass]
keyToPitchClasses :: Text -> [Int]
keyToPitchClasses Text
input =
  let t :: Text
t = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
input
  in case Text -> Maybe Int
parseKeySignature Text
t of
       Just Int
fifths -> Int -> [Int]
keyPitches Int
fifths
       Maybe Int
Nothing -> case Text -> Maybe Int
parseNamedKey Text
t of
         Just Int
fifths -> Int -> [Int]
keyPitches Int
fifths
         Maybe Int
Nothing -> [Int]
chromaticSet  -- Fallback to chromatic if unparseable

-- |Unified token parser for both key and roots contexts.
-- Note names always yield a single pitch class; numbered key signatures yield scales.
-- Prime notation is not supported in this context (returns empty).
parseUnifiedToken :: Text -> [PitchClass]
parseUnifiedToken :: Text -> [Int]
parseUnifiedToken Text
token
  | Text -> Bool
T.null Text
token = []
  | Text
token Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"*" Bool -> Bool -> Bool
|| Text
token Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"all" Bool -> Bool -> Bool
|| Text
token Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"chr" = [Int]
chromaticSet
  | Just Int
pc <- Text -> Maybe Int
noteNameToPitchClass Text
token = [Int
pc]
  | Just Int
fifths <- Text -> Maybe Int
parseKeySignature Text
token = Int -> [Int]
keyPitches Int
fifths
  | Bool
otherwise = []

-- |Parse a single token in key context.
-- Note name: single pitch class. Numbered key sig: major key scale.
parseKeyToken :: Text -> [PitchClass]
parseKeyToken :: Text -> [Int]
parseKeyToken = Text -> [Int]
parseUnifiedToken

-- |Parse key signature notation: numbered form only: "1#", "2b", "4b", "0#", etc.
parseKeySignature :: Text -> Maybe Int
parseKeySignature :: Text -> Maybe Int
parseKeySignature = Text -> Maybe Int
parseNumberedKeySig

-- |Parse numbered key signature: "1#", "2b", "0#", "11b", etc.
parseNumberedKeySig :: Text -> Maybe Int
parseNumberedKeySig :: Text -> Maybe Int
parseNumberedKeySig Text
t
  | Text
"#" Text -> Text -> Bool
`T.isSuffixOf` Text
t = 
      let numPart :: Text
numPart = HasCallStack => Text -> Text
Text -> Text
T.init Text
t
      in case ReadS Int
forall a. Read a => ReadS a
reads (Text -> String
T.unpack Text
numPart) :: [(Int, String)] of
           [(Int
n, String
"")] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
           [(Int, String)]
_ -> Maybe Int
forall a. Maybe a
Nothing
  | Text
"b" Text -> Text -> Bool
`T.isSuffixOf` Text
t =
      let numPart :: Text
numPart = HasCallStack => Text -> Text
Text -> Text
T.init Text
t  
      in case ReadS Int
forall a. Read a => ReadS a
reads (Text -> String
T.unpack Text
numPart) :: [(Int, String)] of
           [(Int
n, String
"")] -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Num a => a -> a
negate Int
n)
           [(Int, String)]
_ -> Maybe Int
forall a. Maybe a
Nothing
  | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

-- |Parse named key: "C", "G", "F#", "Bb", "Am", "F#m", etc.
-- Returns position on circle of fifths (C=0, G=1, D=2, F=-1, Bb=-2)
parseNamedKey :: Text -> Maybe Int
parseNamedKey :: Text -> Maybe Int
parseNamedKey Text
t =
  let t' :: Text
t' = Text -> Text
T.toLower Text
t
      isMinor :: Bool
isMinor = Text
"m" Text -> Text -> Bool
`T.isSuffixOf` Text
t'
      rootPart :: Text
rootPart = if Bool
isMinor then HasCallStack => Text -> Text
Text -> Text
T.init Text
t' else Text
t'
  in case Text
rootPart of
       Text
"c"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
       Text
"g"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
       Text
"d"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
       Text
"a"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3
       Text
"e"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
       Text
"b"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
5
       Text
"f#" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
6
       Text
"gb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
6)
       Text
"db" -> Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
5)
       Text
"ab" -> Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
4)
       Text
"eb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
3)
       Text
"bb" -> Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
2)
       Text
"f"  -> Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
1)
       -- Also handle c#, etc.
       Text
"c#" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
7
       Text
_    -> Maybe Int
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- Parsing: Fundamentals\/Roots
-------------------------------------------------------------------------------

-- |Parse fundamentals (root notes) filter.
--
-- Formats:
--   * Note names: @"E F# G"@ → individual pitches [4,6,7]
--   * Numbered key sig: @"1b"@ = F major roots, @"2#"@ = D major roots
--   * Wildcard: @"*"@
--   * Removal: @"C G -G"@ (C and G minus G), @"* -E -A"@ (all except E,A)
parseFunds' :: Int -> Text -> [PitchClass]
parseFunds' :: Int -> Text -> [Int]
parseFunds' Int
_ Text
input
  | Text -> Bool
isWildcard Text
input = [Int]
chromaticSet
  | Bool
otherwise =
      let ([Text]
includes, [Text]
excludes) = Text -> ([Text], [Text])
partitionTokens Text
input
          includePcs :: [Int]
includePcs = [Int] -> [Int]
unique ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [Int]) -> [Text] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Int]
parseFundsToken [Text]
includes
          excludePcs :: [Int]
excludePcs = [Int] -> [Int]
unique ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [Int]) -> [Text] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Int]
parseFundsToken [Text]
excludes
      in [Int]
includePcs [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Int]
excludePcs

-- |Parse a single token in fundamentals\/roots context.
-- Same unified rules as key context: note name = single pitch, numbered sig = scale.
parseFundsToken :: Text -> [PitchClass]
parseFundsToken :: Text -> [Int]
parseFundsToken = Text -> [Int]
parseUnifiedToken

-- |Resolve roots with special options "key" and "tones".
-- 
-- This function allows root selection to be derived from other filter values:
--   * @"key"@: Use the same pitch classes as the key filter produces
--   * @"tones"@: Use the key-filtered overtones (effective upper structure)
--   * Other values: Parsed via parseFunds as normal
--
-- Arguments:
--   * overtoneFilter: The overtones\/tuning filter string
--   * keyFilter: The key filter string  
--   * rootsFilter: The roots filter string (may be "key" or "tones")
--
-- Examples:
--   resolveRoots "E A D G" "#" "key"   -> G major scale degrees [0,2,4,6,7,9,11]
--   resolveRoots "E A D G" "#" "tones" -> key-filtered overtones from E A D G
--   resolveRoots "E A D G" "#" "C G"   -> [0, 7]
resolveRoots :: Text -> Text -> Text -> [PitchClass]
resolveRoots :: Text -> Text -> Text -> [Int]
resolveRoots Text
overtoneFilter Text
keyFilter Text
rootsFilter
  | Text -> Text
T.toLower (Text -> Text
T.strip Text
rootsFilter) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"key" = Text -> [Int]
parseKey Text
keyFilter
  | Text -> Text
T.toLower (Text -> Text
T.strip Text
rootsFilter) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"tones" = 
      let overtones :: [Int]
overtones = Int -> Text -> [Int]
parseOvertones' Int
3 Text
overtoneFilter
          keyPcs :: [Int]
keyPcs = Text -> [Int]
parseKey Text
keyFilter
      in if Text -> Bool
isWildcard Text
keyFilter
         then [Int]
overtones
         else (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
keyPcs) [Int]
overtones
  | Bool
otherwise = Int -> Text -> [Int]
parseFunds' Int
4 Text
rootsFilter

-------------------------------------------------------------------------------
-- Generalized Parsing (combines all notations)
-------------------------------------------------------------------------------

-- |Parse an overtones filter with full notation support.
-- This is the most general parser, combining tuning notation with individual pitches.
-- Supports removal with '-' prefix: "C E -E'" removes E pitch from (C ∪ E) overtones
parseOvertones' :: Int -> Text -> [PitchClass]
parseOvertones' :: Int -> Text -> [Int]
parseOvertones' Int
n Text
input
  | Text -> Bool
isWildcard Text
input = [Int]
chromaticSet
  | Bool
otherwise =
      let ([Text]
includes, [Text]
excludes) = Text -> ([Text], [Text])
partitionTokens Text
input
          includePcs :: [Int]
includePcs = [Int] -> [Int]
unique ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [Int]) -> [Text] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Text -> [Int]
parseGeneralToken Int
n) [Text]
includes
          excludePcs :: [Int]
excludePcs = [Int] -> [Int]
unique ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [Int]) -> [Text] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Text -> [Int]
parseGeneralToken Int
n) [Text]
excludes
      in [Int]
includePcs [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Int]
excludePcs

-- |Parse a general token (could be note name, prime notation, or key signature)
parseGeneralToken :: Int -> Text -> [PitchClass]
parseGeneralToken :: Int -> Text -> [Int]
parseGeneralToken Int
n Text
token
  | Text -> Bool
T.null Text
token = []
  | Text
token Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"*" Bool -> Bool -> Bool
|| Text
token Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"all" Bool -> Bool -> Bool
|| Text
token Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"chr" = [Int]
chromaticSet
  | Text
"'" Text -> Text -> Bool
`T.isSuffixOf` Text
token =
      -- Prime notation: single pitch class only (legacy behavior)
      case Text -> Maybe Int
noteNameToPitchClass (HasCallStack => Text -> Text
Text -> Text
T.init Text
token) of
        Just Int
pc -> [Int
pc]
        Maybe Int
Nothing -> []
  | Bool
otherwise =
      -- Try as note name (generates overtones)
      case Text -> Maybe Int
noteNameToPitchClass Text
token of
        Just Int
pc -> Int -> Int -> [Int]
overtoneSeriesFrom Int
n Int
pc
        Maybe Int
Nothing -> 
          -- Try as key signature
          case Text -> Maybe Int
parseKeySignature Text
token of
            Just Int
fifths -> Int -> [Int]
keyPitches Int
fifths
            Maybe Int
Nothing -> []

-------------------------------------------------------------------------------
-- Shortcut Functions (n=3 default, matching legacy)
-------------------------------------------------------------------------------

-- |Parse tuning with 3 overtones (default: root, P5, M3 — the distinct
-- pitch classes of the playable tapped-harmonic domain)
parseTuning :: Text -> [PitchClass]
parseTuning :: Text -> [Int]
parseTuning = Int -> Text -> [Int]
parseTuning' Int
3

-- |Parse key (overtone count not used for keys)
parseKey :: Text -> [PitchClass]
parseKey :: Text -> [Int]
parseKey = Int -> Text -> [Int]
parseKey' Int
3

-- |Parse fundamentals with 3 overtones (default)
parseFunds :: Text -> [PitchClass]
parseFunds :: Text -> [Int]
parseFunds = Int -> Text -> [Int]
parseFunds' Int
3

-- |Parse overtones with 3 overtones (default: root, P5, M3)
parseOvertones :: Text -> [PitchClass]
parseOvertones :: Text -> [Int]
parseOvertones = Int -> Text -> [Int]
parseOvertones' Int
3

-------------------------------------------------------------------------------
-- String-Friendly Versions (for Tidal live coding)
-- These accept String instead of Text for seamless REPL use
-------------------------------------------------------------------------------

-- |Parse overtones from a String (Tidal-friendly)
-- Example: overtones "E A D G" -> bass tuning overtones
overtones :: String -> [PitchClass]
overtones :: String -> [Int]
overtones = Text -> [Int]
parseOvertones (Text -> [Int]) -> (String -> Text) -> String -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- |Parse key from a String (Tidal-friendly)
-- Example: key "#" -> G major, key "bb" -> Bb major
key :: String -> [PitchClass]
key :: String -> [Int]
key = Text -> [Int]
parseKey (Text -> [Int]) -> (String -> Text) -> String -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- |Parse fundamentals from a String (Tidal-friendly)
-- Example: funds "E F# G" -> [4, 6, 7]
funds :: String -> [PitchClass]
funds :: String -> [Int]
funds = Text -> [Int]
parseFunds (Text -> [Int]) -> (String -> Text) -> String -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- |Parse tuning from a String (Tidal-friendly)
tuning :: String -> [PitchClass]
tuning :: String -> [Int]
tuning = Text -> [Int]
parseTuning (Text -> [Int]) -> (String -> Text) -> String -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- |Check if a string is a wildcard (Tidal-friendly)
wildcard :: String -> Bool
wildcard :: String -> Bool
wildcard = Text -> Bool
isWildcard (Text -> Bool) -> (String -> Text) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-------------------------------------------------------------------------------
-- High-Level Filtering API
-------------------------------------------------------------------------------

-- |Filter a pitch class set by overtones\/tuning filter
filterPitchSet :: Text -> [PitchClass] -> [PitchClass]
filterPitchSet :: Text -> [Int] -> [Int]
filterPitchSet Text
filterStr [Int]
pcs
  | Text -> Bool
isWildcard Text
filterStr = [Int]
pcs
  | Bool
otherwise = 
      let allowed :: [Int]
allowed = Text -> [Int]
parseOvertones Text
filterStr
      in (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
allowed) [Int]
pcs

-- |Filter a pitch class set by key
filterByKey :: Text -> [PitchClass] -> [PitchClass]
filterByKey :: Text -> [Int] -> [Int]
filterByKey Text
keyFilter [Int]
pcs
  | Text -> Bool
isWildcard Text
keyFilter = [Int]
pcs
  | Bool
otherwise =
      let keyPcs :: [Int]
keyPcs = Text -> [Int]
parseKey Text
keyFilter
      in (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
keyPcs) [Int]
pcs

-- |Filter root candidates by roots filter
filterRoots :: Text -> [PitchClass] -> [PitchClass]
filterRoots :: Text -> [Int] -> [Int]
filterRoots Text
rootsFilter [Int]
pcs
  | Text -> Bool
isWildcard Text
rootsFilter = [Int]
pcs
  | Bool
otherwise =
      let allowed :: [Int]
allowed = Text -> [Int]
parseFunds Text
rootsFilter
      in (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
allowed) [Int]
pcs

-------------------------------------------------------------------------------
-- Matching Predicates (for Builder.hs integration)
-------------------------------------------------------------------------------

-- |Check if a pitch class set matches the overtones filter
matchesPitchSet :: Text -> [PitchClass] -> Bool
matchesPitchSet :: Text -> [Int] -> Bool
matchesPitchSet Text
filterStr [Int]
pcs
  | Text -> Bool
isWildcard Text
filterStr = Bool
True
  | Bool
otherwise =
      let allowed :: [Int]
allowed = Text -> [Int]
parseOvertones Text
filterStr
      in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
allowed) [Int]
pcs

-- |Check if a pitch class set matches the key filter
matchesKey :: Text -> [PitchClass] -> Bool
matchesKey :: Text -> [Int] -> Bool
matchesKey Text
keyFilter [Int]
pcs
  | Text -> Bool
isWildcard Text
keyFilter = Bool
True
  | Bool
otherwise =
      let keyPcs :: [Int]
keyPcs = Text -> [Int]
parseKey Text
keyFilter
      in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
keyPcs) [Int]
pcs

-- |Check if a root pitch class matches the roots filter
matchesRoots :: Text -> PitchClass -> Bool
matchesRoots :: Text -> Int -> Bool
matchesRoots Text
rootsFilter Int
rootPc
  | Text -> Bool
isWildcard Text
rootsFilter = Bool
True
  | Bool
otherwise =
      let allowed :: [Int]
allowed = Text -> [Int]
parseFunds Text
rootsFilter
      in Int
rootPc Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
allowed

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

-- |Remove duplicates and sort
unique :: [PitchClass] -> [PitchClass]
unique :: [Int] -> [Int]
unique = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub

-- |Partition input tokens into positive and negative (those prefixed with '-')
-- Returns (positive tokens, negative tokens with '-' prefix stripped)
partitionTokens :: Text -> ([Text], [Text])
partitionTokens :: Text -> ([Text], [Text])
partitionTokens Text
input =
  let tokens :: [Text]
tokens = Text -> [Text]
T.words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower Text
input
      ([Text]
negTokens, [Text]
posTokens) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Text -> Text -> Bool
T.isPrefixOf Text
"-") [Text]
tokens
      negTokens' :: [Text]
negTokens' = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
T.drop Int
1) [Text]
negTokens
  in ([Text]
posTokens, [Text]
negTokens')

-------------------------------------------------------------------------------
-- Bass Direction
-------------------------------------------------------------------------------

-- |Concrete direction action resolved for a single generation step.
-- When active, the bass\/root at the next step is forced to the Nth note
-- above (Rise) or below (Fall) in the allowed set, with mod-12 wrapping.
-- Step size 1 = closest note, 2 = skip one, etc.
data BassDirection = Rise !Int | Fall !Int
  deriving (Int -> BassDirection -> ShowS
[BassDirection] -> ShowS
BassDirection -> String
(Int -> BassDirection -> ShowS)
-> (BassDirection -> String)
-> ([BassDirection] -> ShowS)
-> Show BassDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BassDirection -> ShowS
showsPrec :: Int -> BassDirection -> ShowS
$cshow :: BassDirection -> String
show :: BassDirection -> String
$cshowList :: [BassDirection] -> ShowS
showList :: [BassDirection] -> ShowS
Show, BassDirection -> BassDirection -> Bool
(BassDirection -> BassDirection -> Bool)
-> (BassDirection -> BassDirection -> Bool) -> Eq BassDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BassDirection -> BassDirection -> Bool
== :: BassDirection -> BassDirection -> Bool
$c/= :: BassDirection -> BassDirection -> Bool
/= :: BassDirection -> BassDirection -> Bool
Eq)

-- |Whether a parsed direction rises or falls.
data BDKind = RiseK | FallK
  deriving (Int -> BDKind -> ShowS
[BDKind] -> ShowS
BDKind -> String
(Int -> BDKind -> ShowS)
-> (BDKind -> String) -> ([BDKind] -> ShowS) -> Show BDKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BDKind -> ShowS
showsPrec :: Int -> BDKind -> ShowS
$cshow :: BDKind -> String
show :: BDKind -> String
$cshowList :: [BDKind] -> ShowS
showList :: [BDKind] -> ShowS
Show, BDKind -> BDKind -> Bool
(BDKind -> BDKind -> Bool)
-> (BDKind -> BDKind -> Bool) -> Eq BDKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BDKind -> BDKind -> Bool
== :: BDKind -> BDKind -> Bool
$c/= :: BDKind -> BDKind -> Bool
/= :: BDKind -> BDKind -> Bool
Eq)

-- |How to pick a step size from 'bdsChoices' at each generation step.
data BDSelector
  = BDFixed       -- ^ single value (bare @rise@, @rise2@, or @rise\<n\>@)
  | BDRotate      -- ^ cycle choices by step index (space-delimited @\<…\>@)
  | BDRandomPick  -- ^ uniform random per step (comma-delimited @\<…\>@)
  deriving (Int -> BDSelector -> ShowS
[BDSelector] -> ShowS
BDSelector -> String
(Int -> BDSelector -> ShowS)
-> (BDSelector -> String)
-> ([BDSelector] -> ShowS)
-> Show BDSelector
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BDSelector -> ShowS
showsPrec :: Int -> BDSelector -> ShowS
$cshow :: BDSelector -> String
show :: BDSelector -> String
$cshowList :: [BDSelector] -> ShowS
showList :: [BDSelector] -> ShowS
Show, BDSelector -> BDSelector -> Bool
(BDSelector -> BDSelector -> Bool)
-> (BDSelector -> BDSelector -> Bool) -> Eq BDSelector
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BDSelector -> BDSelector -> Bool
== :: BDSelector -> BDSelector -> Bool
$c/= :: BDSelector -> BDSelector -> Bool
/= :: BDSelector -> BDSelector -> Bool
Eq)

-- |Parsed specification for a rise\/fall direction token. Resolved per step
-- at generation time to a concrete 'BassDirection' (or 'Nothing' when the
-- optional @?@ flag causes the direction to be skipped for that step).
data BassDirectionSpec = BassDirectionSpec
  { BassDirectionSpec -> BDKind
bdsKind     :: !BDKind
  , BassDirectionSpec -> [Int]
bdsChoices  :: ![Int]       -- ^ non-empty, each in @1..6@
  , BassDirectionSpec -> BDSelector
bdsSelector :: !BDSelector
  , BassDirectionSpec -> Bool
bdsOptional :: !Bool        -- ^ @True@ when the token ended in @?@
  } deriving (Int -> BassDirectionSpec -> ShowS
[BassDirectionSpec] -> ShowS
BassDirectionSpec -> String
(Int -> BassDirectionSpec -> ShowS)
-> (BassDirectionSpec -> String)
-> ([BassDirectionSpec] -> ShowS)
-> Show BassDirectionSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BassDirectionSpec -> ShowS
showsPrec :: Int -> BassDirectionSpec -> ShowS
$cshow :: BassDirectionSpec -> String
show :: BassDirectionSpec -> String
$cshowList :: [BassDirectionSpec] -> ShowS
showList :: [BassDirectionSpec] -> ShowS
Show, BassDirectionSpec -> BassDirectionSpec -> Bool
(BassDirectionSpec -> BassDirectionSpec -> Bool)
-> (BassDirectionSpec -> BassDirectionSpec -> Bool)
-> Eq BassDirectionSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BassDirectionSpec -> BassDirectionSpec -> Bool
== :: BassDirectionSpec -> BassDirectionSpec -> Bool
$c/= :: BassDirectionSpec -> BassDirectionSpec -> Bool
/= :: BassDirectionSpec -> BassDirectionSpec -> Bool
Eq)

-- |Split input on whitespace, but keep substrings inside matching
-- angle brackets as a single token. Used by the bass-direction parser
-- so that @rise\<1 2\>@ survives tokenization.
splitBracketed :: Text -> [Text]
splitBracketed :: Text -> [Text]
splitBracketed = Int -> String -> [Text] -> String -> [Text]
forall {t}.
(Eq t, Num t) =>
t -> String -> [Text] -> String -> [Text]
go (Int
0 :: Int) String
"" [] (String -> [Text]) -> (Text -> String) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
  where
    flushTok :: [Text] -> String -> [Text]
flushTok [Text]
acc String
cur = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cur then [Text]
acc else String -> Text
T.pack (ShowS
forall a. [a] -> [a]
reverse String
cur) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc
    go :: t -> String -> [Text] -> String -> [Text]
go t
_ String
cur [Text]
acc [] = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> String -> [Text]
flushTok [Text]
acc String
cur)
    go t
0 String
cur [Text]
acc (Char
c:String
cs)
      | Char -> Bool
Char.isSpace Char
c = t -> String -> [Text] -> String -> [Text]
go t
0 String
"" ([Text] -> String -> [Text]
flushTok [Text]
acc String
cur) String
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<'       = t -> String -> [Text] -> String -> [Text]
go t
1 (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cur) [Text]
acc String
cs
      | Bool
otherwise      = t -> String -> [Text] -> String -> [Text]
go t
0 (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cur) [Text]
acc String
cs
    go t
d String
cur [Text]
acc (Char
c:String
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' = t -> String -> [Text] -> String -> [Text]
go (t
d t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cur) [Text]
acc String
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' = t -> String -> [Text] -> String -> [Text]
go (t
d t -> t -> t
forall a. Num a => a -> a -> a
- t
1) (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cur) [Text]
acc String
cs
      | Bool
otherwise = t -> String -> [Text] -> String -> [Text]
go t
d (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cur) [Text]
acc String
cs

-- |Try to parse a single token (already bracket-aware) as a direction spec.
-- Returns 'Nothing' for non-direction tokens and for malformed directions.
parseDirectionToken :: Text -> Maybe BassDirectionSpec
parseDirectionToken :: Text -> Maybe BassDirectionSpec
parseDirectionToken Text
tok =
  let low :: Text
low = Text -> Text
T.toLower Text
tok
      (Text
core, Bool
optional) =
        if Text -> Text -> Bool
T.isSuffixOf Text
"?" Text
low
          then (HasCallStack => Text -> Text
Text -> Text
T.init Text
low, Bool
True)
          else (Text
low, Bool
False)
      validStep :: a -> Bool
validStep a
n = a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
1 Bool -> Bool -> Bool
&& a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
6
      parseDigit :: Text -> Maybe Int
parseDigit Text
t = case Text -> String
T.unpack Text
t of
        [Char
c] | Char -> Bool
Char.isDigit Char
c ->
          let n :: Int
n = Char -> Int
Char.digitToInt Char
c
          in if Int -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
validStep Int
n then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n else Maybe Int
forall a. Maybe a
Nothing
        String
_ -> Maybe Int
forall a. Maybe a
Nothing
      stripKind :: Text -> Maybe (BDKind, Text)
stripKind Text
t
        | Just Text
r <- Text -> Text -> Maybe Text
T.stripPrefix Text
"rise" Text
t = (BDKind, Text) -> Maybe (BDKind, Text)
forall a. a -> Maybe a
Just (BDKind
RiseK, Text
r)
        | Just Text
r <- Text -> Text -> Maybe Text
T.stripPrefix Text
"fall" Text
t = (BDKind, Text) -> Maybe (BDKind, Text)
forall a. a -> Maybe a
Just (BDKind
FallK, Text
r)
        | Bool
otherwise                        = Maybe (BDKind, Text)
forall a. Maybe a
Nothing
  in do
       (BDKind
kind, Text
rest) <- Text -> Maybe (BDKind, Text)
stripKind Text
core
       ([Int]
choices, BDSelector
selector) <-
         if Text -> Bool
T.null Text
rest
           then ([Int], BDSelector) -> Maybe ([Int], BDSelector)
forall a. a -> Maybe a
Just ([Int
1], BDSelector
BDFixed)
           else if Text -> Text -> Bool
T.isPrefixOf Text
"<" Text
rest Bool -> Bool -> Bool
&& Text -> Text -> Bool
T.isSuffixOf Text
">" Text
rest
             then
               let inner :: Text
inner      = Int -> Text -> Text
T.drop Int
1 (HasCallStack => Text -> Text
Text -> Text
T.init Text
rest)
                   hasComma :: Bool
hasComma   = (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') Text
inner
                   pieces :: [Text]
pieces     =
                     if Bool
hasComma
                       then (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
T.words (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," Text
inner)
                       else Text -> [Text]
T.words Text
inner
                   parsed :: Maybe [Int]
parsed     = (Text -> Maybe Int) -> [Text] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Maybe Int
parseDigit [Text]
pieces
               in case Maybe [Int]
parsed of
                    Just ns :: [Int]
ns@(Int
_:[Int]
_) ->
                      ([Int], BDSelector) -> Maybe ([Int], BDSelector)
forall a. a -> Maybe a
Just ([Int]
ns, if Bool
hasComma then BDSelector
BDRandomPick else BDSelector
BDRotate)
                    Maybe [Int]
_ -> Maybe ([Int], BDSelector)
forall a. Maybe a
Nothing
             else
               case Text -> Maybe Int
parseDigit Text
rest of
                 Just Int
n  -> ([Int], BDSelector) -> Maybe ([Int], BDSelector)
forall a. a -> Maybe a
Just ([Int
n], BDSelector
BDFixed)
                 Maybe Int
Nothing -> Maybe ([Int], BDSelector)
forall a. Maybe a
Nothing
       BassDirectionSpec -> Maybe BassDirectionSpec
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BDKind -> [Int] -> BDSelector -> Bool -> BassDirectionSpec
BassDirectionSpec BDKind
kind [Int]
choices BDSelector
selector Bool
optional)

-- |Extract a bass-direction spec from a roots filter string.
-- Returns the first token that parses as a direction; 'Nothing' otherwise.
--
-- Examples:
--   parseBassDirectionSpec "* fall"            -- Just (fixed Fall 1)
--   parseBassDirectionSpec "* rise1"           -- Just (fixed Rise 1) -- alias for "rise"
--   parseBassDirectionSpec "* rise3"           -- Just (fixed Rise 3)
--   parseBassDirectionSpec "* fall2?"          -- Just (fixed Fall 2, optional)
--   parseBassDirectionSpec "* fall\<3 2 1\>"     -- Just (rotate Fall [3,2,1])
--   parseBassDirectionSpec "* rise\<1,2\>"       -- Just (random Rise [1,2])
--   parseBassDirectionSpec "* rise\<1 2,3\>?"    -- Just (random Rise [1,2,3], optional)
--   parseBassDirectionSpec "C E G"             -- Nothing
parseBassDirectionSpec :: Text -> Maybe BassDirectionSpec
parseBassDirectionSpec :: Text -> Maybe BassDirectionSpec
parseBassDirectionSpec Text
input =
  case (Text -> Maybe BassDirectionSpec) -> [Text] -> [BassDirectionSpec]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe BassDirectionSpec
parseDirectionToken (Text -> [Text]
splitBracketed Text
input) of
    (BassDirectionSpec
s:[BassDirectionSpec]
_) -> BassDirectionSpec -> Maybe BassDirectionSpec
forall a. a -> Maybe a
Just BassDirectionSpec
s
    []    -> Maybe BassDirectionSpec
forall a. Maybe a
Nothing

-- |Strip the direction token from a roots filter string,
-- leaving only the pitch set specification for normal parsing.
--
-- Examples:
--   stripDirectionToken "* fall"               == "*"
--   stripDirectionToken "0# rise1"              == "0#"
--   stripDirectionToken "0# rise?"              == "0#"
--   stripDirectionToken "C E G fall\<2,3\>"      == "C E G"
--   stripDirectionToken "C E G"                 == "C E G"
stripDirectionToken :: Text -> Text
stripDirectionToken :: Text -> Text
stripDirectionToken Text
input =
  let tokens :: [Text]
tokens    = Text -> [Text]
splitBracketed Text
input
      isDir :: Text -> Bool
isDir Text
t   = case Text -> Maybe BassDirectionSpec
parseDirectionToken Text
t of
                    Just BassDirectionSpec
_  -> Bool
True
                    Maybe BassDirectionSpec
Nothing -> Bool
False
      filtered :: [Text]
filtered  = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isDir) [Text]
tokens
  in [Text] -> Text
T.unwords [Text]
filtered

-- |Find the Nth pitch class ABOVE the current one in the allowed set,
-- sorted by ascending circular distance. Step 1 = closest, 2 = skip one, etc.
-- When N exceeds the set size, wraps around using modular indexing.
-- If the set has only the current note, returns it (pedal).
--
-- Examples (with C major = {0,2,4,5,7,9,11}):
--   nthAbove 1 7 cMaj == 9   (G → A, closest)
--   nthAbove 3 0 cMaj == 5   (C → F, 3rd above)
--   nthAbove 1 11 cMaj == 0  (B → C, wraps mod-12)
--   nthAbove 1 0 {0} == 0    (pedal)
nthAbove :: Int -> Int -> IntSet.IntSet -> Int
nthAbove :: Int -> Int -> IntSet -> Int
nthAbove Int
n Int
current IntSet
allowed =
  let others :: IntSet
others = Int -> IntSet -> IntSet
IntSet.delete Int
current IntSet
allowed
  in if IntSet -> Bool
IntSet.null IntSet
others
     then Int
current  -- pedal: single-element set
     else let sorted :: [Int]
sorted = (Int -> Int -> Ordering) -> [Int] -> [Int]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\Int
a Int
b -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
current) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) ((Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
current) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12))
                              (IntSet -> [Int]
IntSet.toList IntSet
others)
          in [Int]
sorted [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
sorted)

-- |Find the Nth pitch class BELOW the current one in the allowed set,
-- sorted by ascending circular distance downward. Step 1 = closest, etc.
-- When N exceeds the set size, wraps around using modular indexing.
-- If the set has only the current note, returns it (pedal).
--
-- Examples (with C major = {0,2,4,5,7,9,11}):
--   nthBelow 1 7 cMaj == 5   (G → F, closest)
--   nthBelow 3 7 cMaj == 2   (G → D, 3rd below)
--   nthBelow 1 0 cMaj == 11  (C → B, wraps mod-12)
--   nthBelow 1 5 {5} == 5    (pedal)
nthBelow :: Int -> Int -> IntSet.IntSet -> Int
nthBelow :: Int -> Int -> IntSet -> Int
nthBelow Int
n Int
current IntSet
allowed =
  let others :: IntSet
others = Int -> IntSet -> IntSet
IntSet.delete Int
current IntSet
allowed
  in if IntSet -> Bool
IntSet.null IntSet
others
     then Int
current  -- pedal: single-element set
     else let sorted :: [Int]
sorted = (Int -> Int -> Ordering) -> [Int] -> [Int]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\Int
a Int
b -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int
current Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) ((Int
current Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12))
                              (IntSet -> [Int]
IntSet.toList IntSet
others)
          in [Int]
sorted [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
sorted)

-- |Find the closest pitch class above. Equivalent to @nthAbove 1@.
closestAbove :: Int -> IntSet.IntSet -> Int
closestAbove :: Int -> IntSet -> Int
closestAbove = Int -> Int -> IntSet -> Int
nthAbove Int
1

-- |Find the closest pitch class below. Equivalent to @nthBelow 1@.
closestBelow :: Int -> IntSet.IntSet -> Int
closestBelow :: Int -> IntSet -> Int
closestBelow = Int -> Int -> IntSet -> Int
nthBelow Int
1