bikoret/shoresh-engine/src/Shoresh/Teamim.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Te'amim — the cantillation mark reader.
--
-- Architecture §3.1:
--   "The marks are RECEIVED from L1 — they are on the text as transmitted.
--    The parse tree is CONSTRUCTED by the reader in the act of reading.
--    This is not pre-computation. This is literacy."
--
-- The te'amim system is hierarchical:
--   - Melakhim (kings/disjunctors) SEPARATE
--   - Meshartim (servants/conjunctors) CONNECT
--
-- The strongest disjunctor (sof-pasuk) ends the verse.
-- The next strongest (etnachta) creates the primary division.
-- Within each half, subordinate disjunctors create further divisions.
-- The result is a binary tree — the verse's own syntactic structure.
--
-- L1 stores the mark names as strings in each word's "teamim" array.
-- This module reads those strings and builds the tree.
module Shoresh.Teamim
  ( -- * Types
    Taam(..)
  , TaamRole(..)
  , AnnotatedWord(..)
  , ParsedVerse(..)
    -- * Classification
  , taamRole
  , taamRank
  , taamFromName
    -- * Parsing
  , readTeamim
  , primaryDivision
  , boundGroups
  ) where

import Data.Text (Text)
import qualified Data.Text as T
import Data.List (maximumBy)
import Data.Ord (comparing)

-- | Cantillation marks.
-- The full system has ~30 marks. We enumerate the ones that appear
-- in L1 data (parsed from WLC Unicode codepoints).
data Taam
  = SofPasuk         -- ^ Verse end (terminal) — strongest disjunctor
  | Etnachta         -- ^ Primary division — second strongest
  | ZakefGadol       -- ^ Secondary division (strong)
  | ZakefKatan       -- ^ Secondary division
  | Segol            -- ^ Tertiary
  | Shalshelet       -- ^ Rare, strong disjunctor
  | Tipcha           -- ^ Tertiary division (near-subordinate to etnachta/zakef)
  | Revia            -- ^ Mid-level disjunctor
  | Zarka            -- ^ Pre-segol disjunctor
  | Pashta           -- ^ Subordinate disjunctor
  | Yetiv            -- ^ Subordinate disjunctor
  | Tevir            -- ^ Subordinate disjunctor
  | Geresh           -- ^ Subordinate disjunctor
  | GershayimMark    -- ^ Double geresh — subordinate disjunctor
  | Pazer            -- ^ Subordinate disjunctor
  | PazerGadol       -- ^ Rare, subordinate disjunctor
  | Telisha_Gedola   -- ^ Subordinate disjunctor
  | Telisha_Qetana   -- ^ Conjunctor
  | Munach           -- ^ Servant — connects to following disjunctor
  | Mercha           -- ^ Servant — connects to following disjunctor
  | MerchaKefula     -- ^ Double mercha — servant
  | Darga            -- ^ Servant
  | Kadma            -- ^ Servant (azla)
  | Mahapakh         -- ^ Servant
  | Yerach_Ben_Yomo  -- ^ Rare servant
  | MetegSiluq       -- ^ Dual identity: siluq (disjunctor on final word) / meteg
  deriving (Eq, Ord, Show)

-- | Role classification: kings separate, servants connect.
data TaamRole
  = Melekh    -- ^ Disjunctor (separator)
  | Mesharet  -- ^ Conjunctor (connector)
  deriving (Eq, Show)

-- | Classify a taam as melekh (disjunctor) or mesharet (conjunctor).
taamRole :: Taam -> TaamRole
taamRole t = case t of
  SofPasuk        -> Melekh
  Etnachta        -> Melekh
  ZakefGadol      -> Melekh
  ZakefKatan      -> Melekh
  Segol           -> Melekh
  Shalshelet      -> Melekh
  Tipcha          -> Melekh
  Revia           -> Melekh
  Zarka           -> Melekh
  Pashta          -> Melekh
  Yetiv           -> Melekh
  Tevir           -> Melekh
  Geresh          -> Melekh
  GershayimMark   -> Melekh
  Pazer           -> Melekh
  PazerGadol      -> Melekh
  Telisha_Gedola  -> Melekh
  MetegSiluq      -> Melekh  -- siluq on final word is a disjunctor
  -- Servants
  Telisha_Qetana  -> Mesharet
  Munach          -> Mesharet
  Mercha          -> Mesharet
  MerchaKefula    -> Mesharet
  Darga           -> Mesharet
  Kadma           -> Mesharet
  Mahapakh        -> Mesharet
  Yerach_Ben_Yomo -> Mesharet

-- | Disjunctive rank — higher means stronger separator.
-- This determines where the tree splits.
-- SofPasuk is strongest (it ends the verse).
-- Etnachta is next (primary division).
-- Then the hierarchy descends.
taamRank :: Taam -> Int
taamRank t = case t of
  SofPasuk        -> 100
  Etnachta        -> 90
  ZakefGadol      -> 70
  ZakefKatan      -> 65
  Segol           -> 60
  Shalshelet      -> 58
  Revia           -> 50
  Tipcha          -> 45
  Zarka           -> 40
  Pashta          -> 35
  Yetiv           -> 33
  Tevir           -> 30
  Geresh          -> 25
  GershayimMark   -> 25
  Pazer           -> 20
  PazerGadol      -> 20
  Telisha_Gedola  -> 15
  MetegSiluq      -> 80  -- siluq ranks just below etnachta
  -- Servants get rank 0 — they do not create divisions
  _               -> 0

-- | Parse a taam name from L1 JSON data.
-- L1 stores these as strings like "tipcha", "etnachta", "munach".
-- Build log correction #1: "meteg_siluq" is in TEAMIM_MAP due to
-- U+05BD dual identity.
taamFromName :: Text -> Maybe Taam
taamFromName name = case T.toLower name of
  "sof_pasuk"        -> Just SofPasuk
  "sof-pasuk"        -> Just SofPasuk
  "sofpasuk"         -> Just SofPasuk
  "etnachta"         -> Just Etnachta
  "etnahta"          -> Just Etnachta
  "zakef_gadol"      -> Just ZakefGadol
  "zakef-gadol"      -> Just ZakefGadol
  "zaqef_gadol"      -> Just ZakefGadol   -- L1 spelling
  "zakef_katan"      -> Just ZakefKatan
  "zakef-katan"      -> Just ZakefKatan
  "zaqef_qatan"      -> Just ZakefKatan   -- L1 spelling
  "segol"            -> Just Segol
  "segol_accent"     -> Just Segol        -- L1 spelling
  "shalshelet"       -> Just Shalshelet
  "tipcha"           -> Just Tipcha
  "tipeha"           -> Just Tipcha
  "revia"            -> Just Revia
  "revi'i"           -> Just Revia
  "zarka"            -> Just Zarka
  "pashta"           -> Just Pashta
  "yetiv"            -> Just Yetiv
  "tevir"            -> Just Tevir
  "geresh"           -> Just Geresh
  "gershayim"        -> Just GershayimMark
  "pazer"            -> Just Pazer
  "pazer_gadol"      -> Just PazerGadol
  "telisha_gedola"   -> Just Telisha_Gedola
  "telisha_qetana"   -> Just Telisha_Qetana
  "munach"           -> Just Munach
  "mercha"           -> Just Mercha
  "mercha_kefula"    -> Just MerchaKefula
  "darga"            -> Just Darga
  "kadma"            -> Just Kadma
  "qadma"            -> Just Kadma        -- L1 spelling
  "azla"             -> Just Kadma
  "mahapakh"         -> Just Mahapakh
  "yerach_ben_yomo"  -> Just Yerach_Ben_Yomo
  "meteg_siluq"      -> Just MetegSiluq
  "siluq"            -> Just MetegSiluq
  "meteg"            -> Just MetegSiluq
  "zinor"            -> Just Zarka        -- L1: zinor is variant name for zarka
  "geresh_muqdam"    -> Just Geresh       -- L1: pre-positioned geresh variant
  _                  -> Nothing


-- | A word annotated with its cantillation mark and role.
-- This is what we receive from L1 after parsing the raw mark names.
data AnnotatedWord = AnnotatedWord
  { awWord :: !Text     -- ^ The Hebrew word text
  , awTaam :: !Taam     -- ^ The primary cantillation mark
  , awRole :: !TaamRole -- ^ King or servant
  } deriving (Show)

-- | A parsed verse: binary tree where branches are te'amim divisions.
-- Leaf: a single annotated word.
-- Branch: a disjunctor splitting the verse into two halves.
--
-- This tree is CONSTRUCTED by readTeamim from the raw marks.
-- It is not stored in L1. This is the act of reading.
data ParsedVerse
  = Leaf !AnnotatedWord
  | Branch !Taam !ParsedVerse !ParsedVerse
  deriving (Show)


-- | Read the te'amim — construct the parse tree from annotated words.
--
-- Algorithm: find the strongest disjunctor, split there,
-- recurse on each half. This mirrors how a human reader
-- parses the verse structure from the cantillation marks.
--
-- The marks are received. The tree is built in the act of reading.
readTeamim :: [AnnotatedWord] -> ParsedVerse
readTeamim [] = error "readTeamim: empty word list — a verse cannot be empty"
readTeamim [w] = Leaf w
readTeamim ws =
  -- Find the word with the strongest disjunctive mark
  let indexed = zip [0..] ws
      disjunctors = [ (i, w) | (i, w) <- indexed
                     , awRole w == Melekh
                     , i < length ws - 1  -- don't split after the last word
                     ]
  in case disjunctors of
    [] ->
      -- No disjunctors found (all servants) — treat as a chain
      -- This shouldn't happen in well-formed verses but we handle it
      buildChain ws
    _ ->
      -- Split at the strongest disjunctor
      let (splitIdx, splitWord) = maximumBy (comparing (taamRank . awTaam . snd)) disjunctors
          (left, right) = splitAt (splitIdx + 1) ws
          splitTaam = awTaam splitWord
      in Branch splitTaam (readTeamim left) (readTeamim right)

-- | Build a linear chain when no disjunctors are present.
buildChain :: [AnnotatedWord] -> ParsedVerse
buildChain []  = error "buildChain: empty"
buildChain [w] = Leaf w
buildChain (w:ws) = Branch (awTaam w) (Leaf w) (buildChain ws)


-- | Find the primary division (etnachta) of a parsed verse.
-- Returns the two halves of the verse.
-- The etnachta divides the verse into its two main parts.
primaryDivision :: ParsedVerse -> (ParsedVerse, ParsedVerse)
primaryDivision (Leaf w) = (Leaf w, Leaf w)
primaryDivision (Branch t left right)
  | t == Etnachta = (left, right)
  | otherwise =
      -- The etnachta might be deeper in the tree.
      -- In a well-formed parse, it should be at the top level.
      -- If not, search left then right.
      let (ll, lr) = primaryDivision left
          (rl, rr) = primaryDivision right
      in if hasEtnachta left
         then (ll, Branch t lr right)
         else if hasEtnachta right
              then (Branch t left rl, rr)
              else (left, right)  -- no etnachta found — use top-level split

-- | Check if a parsed tree contains an etnachta division.
hasEtnachta :: ParsedVerse -> Bool
hasEtnachta (Leaf _) = False
hasEtnachta (Branch t l r) = t == Etnachta || hasEtnachta l || hasEtnachta r


-- | Identify which words are bound together by meshartim (servant chains).
-- Words connected by servants form semantic units.
-- Returns groups of words that are bound together.
boundGroups :: ParsedVerse -> [[Text]]
boundGroups = go []
  where
    go acc (Leaf w) = reverse (addToCurrentGroup (awWord w) acc)
    go acc (Branch t left right)
      | taamRole t == Mesharet =
          -- Servants connect — merge groups
          let leftGroups = go acc left
          in go leftGroups right
      | otherwise =
          -- Kings separate — start new group for right
          let leftGroups = go acc left
              -- Close current group, start fresh for right
              rightGroups = go ([] : leftGroups) right
          in rightGroups

    addToCurrentGroup w [] = [[w]]
    addToCurrentGroup w (g:gs) = (w:g) : gs