{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Harmonic.Framework.Builder.Portmanteau
-- Description : Portmanteau name generation from composer blend strings
--
-- Generates blended composer display names by extracting weighted
-- portions from beginning\/middle\/end of each composer name based
-- on their position and weight in the blend string.

module Harmonic.Framework.Builder.Portmanteau
  ( parseComposersWithOrder
  , makePortmanteau
  , extractByPosition
  , takeFromBeginning
  , takeFromEnd
  , takeFromMiddle
  ) where

import qualified Data.Text as T
import           Data.Text (Text)
import           Data.Maybe (mapMaybe)

-- | Parse composer string preserving input order
-- Returns list of (name, normalized weight) tuples in order of appearance
parseComposersWithOrder :: Text -> [(Text, Double)]
parseComposersWithOrder :: Text -> [(Text, Double)]
parseComposersWithOrder Text
input
  | Text -> Bool
T.null Text
input Bool -> Bool -> Bool
|| Text
input Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"*" = []
  | Bool
otherwise = [(Text, Double)] -> [(Text, Double)]
normalizeList [(Text, Double)]
parsed
  where
    tokens :: [Text]
tokens = (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
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split Char -> Bool
isSeparator Text
input
    parsed :: [(Text, Double)]
parsed = (Text -> Maybe (Text, Double)) -> [Text] -> [(Text, Double)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (Text, Double)
parseToken [Text]
tokens

    isSeparator :: Char -> Bool
isSeparator Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
','

    parseToken :: Text -> Maybe (Text, Double)
    parseToken :: Text -> Maybe (Text, Double)
parseToken Text
tok =
      case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
":" Text
tok of
        [Text
name]       -> (Text, Double) -> Maybe (Text, Double)
forall a. a -> Maybe a
Just (Text -> Text
T.strip Text
name, Double
1.0)
        [Text
name, Text
wStr] ->
          let weight :: Double
weight = Text -> Double
forall {a}. (Read a, Fractional a) => Text -> a
parseWeight (Text -> Text
T.strip Text
wStr)
           in (Text, Double) -> Maybe (Text, Double)
forall a. a -> Maybe a
Just (Text -> Text
T.strip Text
name, Double
weight)
        [Text]
_            -> Maybe (Text, Double)
forall a. Maybe a
Nothing

    parseWeight :: Text -> a
parseWeight Text
wStr =
      case ReadS a
forall a. Read a => ReadS a
reads (Text -> String
T.unpack Text
wStr) of
        [(a
d, String
"")] -> a
d
        [(a, String)]
_         -> a
1.0

    -- Normalize weights to sum to 1.0, preserving order
    normalizeList :: [(Text, Double)] -> [(Text, Double)]
    normalizeList :: [(Text, Double)] -> [(Text, Double)]
normalizeList [(Text, Double)]
pairs
      | Double
total Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 = [(Text, Double)]
pairs
      | Bool
otherwise  = ((Text, Double) -> (Text, Double))
-> [(Text, Double)] -> [(Text, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
n, Double
w) -> (Text
n, Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
total)) [(Text, Double)]
pairs
      where
        total :: Double
total = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Text, Double) -> Double) -> [(Text, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Double) -> Double
forall a b. (a, b) -> b
snd [(Text, Double)]
pairs)

-- | Generate portmanteau from composer string (preserving input order)
-- Takes weighted portions from beginning\/middle\/end based on POSITION
-- Returns Nothing for "*", empty input, or "none" (offline mode)
makePortmanteau :: Text -> Maybe Text
makePortmanteau :: Text -> Maybe Text
makePortmanteau Text
input
  | Text -> Text
T.toLower Text
input Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"none" = Maybe Text
forall a. Maybe a
Nothing
  | Bool
otherwise = case Text -> [(Text, Double)]
parseComposersWithOrder Text
input of
      []               -> Maybe Text
forall a. Maybe a
Nothing
      [(Text
name, Double
_)]      -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
T.toTitle Text
name)
      [(Text, Double)]
composers
        | ((Text, Double) -> Bool) -> [(Text, Double)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"*") (Text -> Bool)
-> ((Text, Double) -> Text) -> (Text, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Double) -> Text
forall a b. (a, b) -> a
fst) [(Text, Double)]
composers -> Maybe Text
forall a. Maybe a
Nothing
        | Bool
otherwise -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> ([Text] -> Text) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toTitle (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [(Text, Double)] -> [Text]
buildFragments [(Text, Double)]
composers
  where
    buildFragments :: [(Text, Double)] -> [Text]
buildFragments [(Text, Double)]
composers = (Int -> (Text, Double) -> Text)
-> [Int] -> [(Text, Double)] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Text, Double) -> Text
extractPart [Int
0..] [(Text, Double)]
composers
      where
        total :: Int
total = [(Text, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Double)]
composers
        extractPart :: Int -> (Text, Double) -> Text
extractPart Int
idx (Text
name, Double
weight) = Int -> Int -> Text -> Double -> Text
extractByPosition Int
idx Int
total Text
name Double
weight

-- | Extract characters from name based on position in list
extractByPosition :: Int -> Int -> Text -> Double -> Text
extractByPosition :: Int -> Int -> Text -> Double -> Text
extractByPosition Int
idx Int
total Text
name Double
weight
  | Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0           = Text -> Double -> Text
takeFromBeginning Text
name Double
weight  -- First
  | Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1   = Text -> Double -> Text
takeFromEnd Text
name Double
weight        -- Last
  | Bool
otherwise          = Text -> Double -> Text
takeFromMiddle Text
name Double
weight     -- Middle

-- | Take a leading fragment of a name, sized by the composer's blend weight.
-- Used for the first name in a blend. Always yields at least one character.
takeFromBeginning :: Text -> Double -> Text
takeFromBeginning :: Text -> Double -> Text
takeFromBeginning Text
name Double
weight =
  let chars :: Int
chars = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length Text
name) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
weight))
   in Int -> Text -> Text
T.take Int
chars Text
name

-- | Take a trailing fragment, sized by blend weight. Used for the last name
-- in a blend, so the portmanteau ends on a real word ending.
takeFromEnd :: Text -> Double -> Text
takeFromEnd :: Text -> Double -> Text
takeFromEnd Text
name Double
weight =
  let len :: Int
len = Text -> Int
T.length Text
name
      chars :: Int
chars = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
weight))
   in Int -> Text -> Text
T.drop (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
chars) Text
name

-- | Take a centred fragment, sized by blend weight. Used for names between
-- the first and last in a blend. Ties favour earlier characters.
takeFromMiddle :: Text -> Double -> Text
takeFromMiddle :: Text -> Double -> Text
takeFromMiddle Text
name Double
weight =
  let len :: Int
len = Text -> Int
T.length Text
name
      chars :: Int
chars = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
weight))
      start :: Int
start = (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
chars) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2  -- Center, favor earlier chars
   in Int -> Text -> Text
T.take Int
chars (Int -> Text -> Text
T.drop Int
start Text
name)