bikoret/shoresh-engine/test/Spec.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Shoresh Engine test suite.
--
-- Tests the three Step 7 verification requirements:
--   1. Root activation through all 7 binyanim
--   2. Te'amim parse tree construction
--   3. Gematria computation
--
-- Plus structural tests for types, lexicon, ketiv/qere, graph.
module Main where

import Test.Hspec
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import Data.Maybe (isJust, isNothing, mapMaybe)

import Shoresh.Types
import Shoresh.Gematria
import Shoresh.Binyanim
import Shoresh.Teamim
import Shoresh.KetivQere
import Shoresh.Lexicon
import Shoresh.Graph
import Shoresh.Roots
import Shoresh.KiTov
import Luchot.Firmware

main :: IO ()
main = hspec $ do
  consonantSpec
  shoreshSpec
  binyanSpec
  gematriaSpec
  teamimSpec
  ketivQereSpec
  graphSpec
  kiTovSpec
  firmwareSpec
  rootsSpec

consonantSpec :: Spec
consonantSpec = describe "Consonant" $ do
  it "has exactly 22 consonants" $
    length [minBound .. maxBound :: Consonant] `shouldBe` 22

  it "round-trips through char conversion" $ do
    mapM_ (\c ->
      charToConsonant (consonantToChar c) `shouldBe` Just c
      ) [minBound .. maxBound :: Consonant]

  it "handles final forms (sofit)" $ do
    charToConsonant 'ך' `shouldBe` Just Kaf
    charToConsonant 'ם' `shouldBe` Just Mem
    charToConsonant 'ן' `shouldBe` Just Nun
    charToConsonant 'ף' `shouldBe` Just Pe
    charToConsonant 'ץ' `shouldBe` Just Tsade

  it "rejects non-Hebrew characters" $ do
    charToConsonant 'a' `shouldBe` Nothing
    charToConsonant '1' `shouldBe` Nothing


shoreshSpec :: Spec
shoreshSpec = describe "Shoresh" $ do
  it "constructs a triliteral root" $ do
    let sh = mkShoresh Bet Resh Aleph
    c1 sh `shouldBe` Bet
    c2 sh `shouldBe` Resh
    c3 sh `shouldBe` Aleph

  it "renders as Hebrew text" $ do
    shoreshToText (mkShoresh Bet Resh Aleph) `shouldBe` "ברא"
    shoreshToText (mkShoresh Qof Dalet Shin) `shouldBe` "קדש"

  it "parses from Hebrew text (3 consonants)" $ do
    textToShoresh "ברא" `shouldBe` Just (mkShoresh Bet Resh Aleph)
    textToShoresh "קדש" `shouldBe` Just (mkShoresh Qof Dalet Shin)

  it "parses from Hebrew text (2 consonants — biconsonantal)" $ do
    -- Build log: some roots in L1 are 2-consonant (e.g. "שמ")
    let result = textToShoresh "שמ"
    result `shouldSatisfy` isJust
    -- Bicons pad with He
    case result of
      Just sh -> c3 sh `shouldBe` He
      Nothing -> expectationFailure "Should have parsed"

  it "rejects invalid input" $ do
    textToShoresh "" `shouldBe` Nothing
    textToShoresh "א" `shouldBe` Nothing  -- too short
    textToShoresh "אבגד" `shouldBe` Nothing  -- too long


binyanSpec :: Spec
binyanSpec = describe "Binyanim" $ do
  it "has exactly 7 binyanim" $
    length allBinyanim `shouldBe` 7

  it "activates a root through all 7 binyanim" $ do
    let sh = mkShoresh Bet Resh Aleph
    let expanded = expand sh
    Map.size expanded `shouldBe` 7
    -- Each binyan should produce a peulah with the same root
    mapM_ (\(b, p) -> root p `shouldBe` sh) (Map.toList expanded)

  it "activate produces correct grammatical features" $ do
    let sh = mkShoresh Shin Mem Resh  -- שמר = guard
    let p = activate Qal Third Singular Masculine Perfect sh
    root p `shouldBe` sh
    binyan p `shouldBe` Qal
    person p `shouldBe` Third
    number p `shouldBe` Singular
    gender p `shouldBe` Masculine
    aspect p `shouldBe` Perfect

  it "activateDefault uses 3ms perfect citation form" $ do
    let sh = mkShoresh Kaf Tav Bet  -- כתב = write
    let p = activateDefault Qal sh
    person p `shouldBe` Third
    number p `shouldBe` Singular
    gender p `shouldBe` Masculine
    aspect p `shouldBe` Perfect


gematriaSpec :: Spec
gematriaSpec = describe "Gematria" $ do
  it "assigns correct values to individual letters" $ do
    letterValue Aleph `shouldBe` 1
    letterValue Yod `shouldBe` 10
    letterValue Qof `shouldBe` 100
    letterValue Tav `shouldBe` 400

  it "computes root gematria correctly" $ do
    -- ברא = Bet(2) + Resh(200) + Aleph(1) = 203
    gematriaRoot (mkShoresh Bet Resh Aleph) `shouldBe` 203
    -- קדש = Qof(100) + Dalet(4) + Shin(300) = 404
    gematriaRoot (mkShoresh Qof Dalet Shin) `shouldBe` 404
    -- שלם = Shin(300) + Lamed(30) + Mem(40) = 370
    gematriaRoot (mkShoresh Shin Lamed Mem) `shouldBe` 370

  it "computes word gematria correctly" $ do
    -- תורה = Tav(400) + Vav(6) + Resh(200) + He(5) = 611
    gematriaWord "תורה" `shouldBe` 611
    -- שלום = Shin(300) + Lamed(30) + Vav(6) + Mem(40) = 376
    gematriaWord "שלום" `shouldBe` 376

  it "ignores non-consonant characters in word gematria" $ do
    -- Word with vowels and cantillation should give same value
    -- as consonants only
    gematriaWord "בְּרֵאשִׁ֖ית" `shouldBe` gematriaWord "בראשית"

  it "finds gematria neighbors" $ do
    let bara = mkShoresh Bet Resh Aleph  -- 203
    let other = mkShoresh Resh Gimel Gimel  -- 200+3+3 = 206, not 203
    let lex = Map.fromList
                [ (bara, ShoreshEntry bara Creation [] [] Map.empty)
                , (other, ShoreshEntry other Creation [] [] Map.empty)
                ]
    -- bara's neighbors at 203 should not include 'other' (206)
    gematriaNeighbors 203 lex `shouldBe`
      [ShoreshEntry bara Creation [] [] Map.empty]


teamimSpec :: Spec
teamimSpec = describe "Te'amim" $ do
  it "classifies taam roles correctly" $ do
    taamRole Etnachta `shouldBe` Melekh
    taamRole SofPasuk `shouldBe` Melekh
    taamRole Tipcha `shouldBe` Melekh
    taamRole Munach `shouldBe` Mesharet
    taamRole Mercha `shouldBe` Mesharet

  it "parses taam names from L1 format" $ do
    taamFromName "tipcha" `shouldBe` Just Tipcha
    taamFromName "etnachta" `shouldBe` Just Etnachta
    taamFromName "munach" `shouldBe` Just Munach
    taamFromName "mercha" `shouldBe` Just Mercha
    -- Build log correction #1: meteg_siluq
    taamFromName "meteg_siluq" `shouldBe` Just MetegSiluq

  it "ranks disjunctors by strength" $ do
    taamRank SofPasuk `shouldSatisfy` (> taamRank Etnachta)
    taamRank Etnachta `shouldSatisfy` (> taamRank ZakefKatan)
    taamRank ZakefKatan `shouldSatisfy` (> taamRank Tipcha)
    taamRank Tipcha `shouldSatisfy` (> taamRank Munach)

  it "builds a parse tree from Bereishit 1:1 words" $ do
    -- Bereishit 1:1: 7 words with these te'amim:
    --   בראשית(tipcha) ברא(munach) אלהים(etnachta)
    --   את(mercha) השמים(tipcha) ואת(mercha) הארץ(meteg_siluq)
    let words =
          [ AnnotatedWord "בְּרֵאשִׁ֖ית" Tipcha Melekh
          , AnnotatedWord "בָּרָ֣א" Munach Mesharet
          , AnnotatedWord "אֱלֹהִ֑ים" Etnachta Melekh
          , AnnotatedWord "אֵ֥ת" Mercha Mesharet
          , AnnotatedWord "הַשָּׁמַ֖יִם" Tipcha Melekh
          , AnnotatedWord "וְאֵ֥ת" Mercha Mesharet
          , AnnotatedWord "הָאָֽרֶץ" MetegSiluq Melekh
          ]
    let tree = readTeamim words
    -- The tree should exist and have branches
    treeDepth tree `shouldSatisfy` (> 1)

  it "finds primary division at etnachta" $ do
    let words =
          [ AnnotatedWord "בְּרֵאשִׁ֖ית" Tipcha Melekh
          , AnnotatedWord "בָּרָ֣א" Munach Mesharet
          , AnnotatedWord "אֱלֹהִ֑ים" Etnachta Melekh
          , AnnotatedWord "אֵ֥ת" Mercha Mesharet
          , AnnotatedWord "הַשָּׁמַ֖יִם" Tipcha Melekh
          , AnnotatedWord "וְאֵ֥ת" Mercha Mesharet
          , AnnotatedWord "הָאָֽרֶץ" MetegSiluq Melekh
          ]
    let tree = readTeamim words
    let (left, right) = primaryDivision tree
    -- Left of etnachta should have: בראשית ברא אלהים
    collectAllWords left `shouldBe`
      ["בְּרֵאשִׁ֖ית", "בָּרָ֣א", "אֱלֹהִ֑ים"]
    -- Right of etnachta should have: את השמים ואת הארץ
    collectAllWords right `shouldBe`
      ["אֵ֥ת", "הַשָּׁמַ֖יִם", "וְאֵ֥ת", "הָאָֽרֶץ"]


ketivQereSpec :: Spec
ketivQereSpec = describe "KetivQere" $ do
  it "single reading returns same text for both" $ do
    bothReadings (Single "שלום") `shouldBe` ("שלום", "שלום")

  it "dual reading preserves both" $ do
    let ref = Reference Bereishit 1 1
    let dr = DualReading "הוא" "היא" ref
    bothReadings (DualVal dr) `shouldBe` ("הוא", "היא")

  it "isDual distinguishes correctly" $ do
    isDual (Single "test") `shouldBe` False
    isDual (DualVal (DualReading "a" "b" (Reference Bereishit 1 1))) `shouldBe` True


graphSpec :: Spec
graphSpec = describe "Graph" $ do
  it "finds roots sharing 2 consonants" $ do
    let bara = mkShoresh Bet Resh Aleph    -- ברא
    let barak = mkShoresh Bet Resh Kaf     -- ברך (shares ב,ר)
    let garaEnt = mkShoresh Gimel Resh Aleph -- גרא (shares ר,א)
    let unrelated = mkShoresh Shin Lamed Mem -- שלם (shares nothing)
    let lex = Map.fromList
                [ (bara, ShoreshEntry bara Creation [] [] Map.empty)
                , (barak, ShoreshEntry barak Blessing [] [] Map.empty)
                , (garaEnt, ShoreshEntry garaEnt Movement [] [] Map.empty)
                , (unrelated, ShoreshEntry unrelated Covenant [] [] Map.empty)
                ]
    let ns = neighbors bara lex
    length ns `shouldBe` 2  -- barak and gara, not unrelated

  it "counts shared consonants correctly" $ do
    let sh1 = mkShoresh Bet Resh Aleph
    let sh2 = mkShoresh Bet Resh Kaf
    sharedConsonants sh1 sh2 `shouldBe` 2
    let sh3 = mkShoresh Shin Lamed Mem
    sharedConsonants sh1 sh3 `shouldBe` 0


kiTovSpec :: Spec
kiTovSpec = describe "KiTov" $ do
  it "returns Tov when all roots exist in lexicon" $ do
    let sh = mkShoresh Bet Resh Aleph
    let entry = ShoreshEntry sh Creation [] [Reference Bereishit 1 1] Map.empty
    let lex = Map.fromList [(sh, entry)]
    let result = ProcessedResult [] [entry]
    kiTov result lex `shouldBe` Tov

  it "returns LoTov when roots are missing" $ do
    let sh = mkShoresh Bet Resh Aleph
    let entry = ShoreshEntry sh Creation [] [Reference Bereishit 1 1] Map.empty
    let emptyLex = Map.empty
    let result = ProcessedResult [] [entry]
    case kiTov result emptyLex of
      LoTov _ -> return ()
      other   -> expectationFailure $ "Expected LoTov, got " ++ show other


firmwareSpec :: Spec
firmwareSpec = describe "Firmware" $ do
  it "has correct L1 hash" $
    l1ExpectedHash `shouldBe`
      "156b1d2724a4bf9999aa45c83ebd0794792f5aa4d524e8a7a898c871c1d8c9d5"

  it "has correct counts" $ do
    torahBookCount `shouldBe` 5
    torahVerseCount `shouldBe` 5853
    torahWordCount `shouldBe` 79982
    uniqueRootCount `shouldBe` 1378

  it "dibrot exist" $
    dibrot `shouldBe` Dibrot () () () () () () () () () ()


-- ============================================================
-- Roots — tablet 33: a word's root is what L1 records for it
-- ============================================================

-- | An L1 word as build_l1.py writes it (position, text and te'amim are
-- irrelevant to root resolution).
l1w :: Text -> Text -> Text -> Maybe Text -> L1Word
l1w cons lemma morph sh = L1Word
  { l1wPosition = 0, l1wText = cons, l1wConsonants = cons, l1wLemma = lemma
  , l1wMorph = morph, l1wTeamim = [], l1wPrefix = Nothing, l1wShoresh = sh }

l1v :: Text -> Int -> Int -> [L1Word] -> L1Verse
l1v book ch vs ws = L1Verse
  { l1vRef = "", l1vBook = book, l1vChapter = ch, l1vVerse = vs
  , l1vTextHebrew = "", l1vWords = ws }

-- Devarim 6:5, as L1 holds it: three suffixed nouns carry no shoresh.
devarim65 :: L1Verse
devarim65 = l1v "devarim" 6 5
  [ l1w "ואהבת" "157"  "HC/Vqq2ms"      (Just "אהב")
  , l1w "את"    "853"  "HTo"            Nothing
  , l1w "יהוה"  "3068" "HNp"            (Just "יהו")
  , l1w "אלהיך" "430"  "HNcmpc/Sp2ms"   Nothing
  , l1w "בכל"   "3605" "HR/Ncmsc"       (Just "כל")
  , l1w "לבבך"  "3824" "HNcmsc/Sp2ms"   Nothing
  , l1w "ובכל"  "3605" "HC/R/Ncmsc"     (Just "כל")
  , l1w "נפשך"  "5315" "HNcbsc/Sp2ms"   Nothing
  ]

-- Elsewhere in Torah: the same lemmas with a shoresh of their own.
elsewhere :: [L1Verse]
elsewhere =
  [ l1v "bereishit" 1 1
      [ l1w "בראשית" "7225" "HR/Ncfsa"  (Just "ראש")
      , l1w "ברא"    "1254" "HVqp3ms"   (Just "ברא")
      , l1w "אלהים"  "430"  "HNcmpa"    (Just "אלה")
      , l1w "את"     "853"  "HTo"       Nothing
      ]
  , l1v "bereishit" 1 3
      [ l1w "ויאמר" "559"  "HC/Vqw3ms"  (Just "אמר")
      , l1w "אור"   "216"  "HNcbsa"     (Just "אור")
      , l1w "ויהי־אור" "1961" "HC/Vqw3ms" (Just "יהי")
      ]
  , l1v "bereishit" 1 4
      [ l1w "ויבדל" "914"  "HC/Vhw3ms"  (Just "בדל") ]
  , l1v "devarim" 4 29
      [ l1w "לבב"   "3824" "HNcmsa"     (Just "לבב")
      , l1w "נפש"   "5315" "HNcbsa"     (Just "נפש")
      ]
    -- Homographs. אשר: the relative particle twice, the name Asher once.
    -- את: the object marker everywhere, but אתה yields the root את.
  , l1v "shemot" 3 14
      [ l1w "אשר"   "834 a" "HTr"       Nothing
      , l1w "אהיה"  "1961"  "HVqi1cs"   (Just "היה")
      , l1w "אשר"   "834 a" "HTr"       Nothing
      ]
  , l1v "bereishit" 30 13
      [ l1w "אשר"   "836"   "HNp"       (Just "אשר")
      , l1w "אתה"   "859 a" "HPp2ms"    (Just "את")
      ]
  ]

testIndex :: RootIndex
testIndex = buildIndex (devarim65 : elsewhere)

shoreshim :: [ResolvedRoot] -> [Text]
shoreshim = map rrShoresh

rootsSpec :: Spec
rootsSpec = describe "Roots (tablet 33)" $ do
  describe "what the old engine did, and must not do again" $ do
    it "a particle is not a root — את yields nothing, never א-ת-ה" $
      resolveText testIndex Nothing "את" `shouldBe` []

    it "a three-letter word is not a root because it has three letters" $
      -- בכל was reported as ב-כ-ל; L1 says its root is כל.
      shoreshim (resolveText testIndex (Just devarim65) "בכל") `shouldBe` ["כל"]

    it "a long word is not dropped — ויאמר is א-מ-ר" $
      shoreshim (resolveText testIndex Nothing "ויאמר") `shouldBe` ["אמר"]

    it "a word Torah does not contain yields nothing" $
      resolveText testIndex Nothing "מחשב" `shouldBe` []

    it "non-Hebrew input yields nothing" $
      resolveText testIndex Nothing "Test query 1" `shouldBe` []

  describe "the whole of Devarim 6:5" $ do
    let roots = resolveText testIndex (Just devarim65)
                  "ואהבת את יהוה אלהיך בכל לבבך ובכל נפשך"

    it "finds א-ה-ב, and the heart and the soul" $
      shoreshim roots `shouldBe` ["אהב", "יהו", "אלה", "כל", "לבב", "נפש"]

    it "a word in the verse with its own shoresh is heard from the verse" $
      map rrDerivation (take 2 roots) `shouldBe` [FromVerse, FromVerse]

    it "a suffixed noun with no shoresh is heard through its lemma" $
      [ rrDerivation r | r <- roots, rrShoresh r `elem` ["לבב", "נפש", "אלה"] ]
        `shouldBe` [FromLemma, FromLemma, FromLemma]

    it "כל appears once though the verse says it twice" $
      length (filter (== "כל") (shoreshim roots)) `shouldBe` 1

  describe "binyan" $ do
    it "is read from the verb's morphology in the verse" $ do
      let v = elsewhere !! 2
      map rrBinyan (resolveText testIndex (Just v) "ויבדל") `shouldBe` [Just Hifil]
      map rrBinyan (resolveText testIndex (Just devarim65) "ואהבת") `shouldBe` [Just Qal]

    it "is not claimed for a noun" $
      map rrBinyan (resolveText testIndex (Just devarim65) "בכל") `shouldBe` [Nothing]

    it "is not claimed for a word outside the verse in scope" $
      map rrBinyan (resolveText testIndex (Just devarim65) "ויבדל") `shouldBe` [Nothing]

    it "parses OSHB stems" $ do
      binyanFromMorph "HC/Vqw3ms" `shouldBe` Just Qal
      binyanFromMorph "HVhp1cs"   `shouldBe` Just Hifil
      binyanFromMorph "HVNp3ms"   `shouldBe` Just Nifal
      binyanFromMorph "HVtw3ms"   `shouldBe` Just Hitpael
      binyanFromMorph "HNcmsa"    `shouldBe` Nothing

  describe "homographs" $ do
    it "a particle in the verse has no root, though Torah knows את as a root" $ do
      resolveText testIndex (Just devarim65) "את" `shouldBe` []
      resolveText testIndex Nothing "את" `shouldBe` []

    it "out of scope, a word is read the way Torah most often reads it" $
      -- אשר: particle ×2, the name ×1. The particle wins; no root.
      resolveText testIndex Nothing "אשר" `shouldBe` []

    it "in scope, the verse decides — אשר the particle in Shemot 3:14" $
      shoreshim (resolveText testIndex (Just (elsewhere !! 4)) "אהיה אשר אהיה")
        `shouldBe` ["היה"]

  describe "other ways a root is heard" $ do
    it "from elsewhere in Torah when the word is not in the verse in scope" $
      map (\r -> (rrShoresh r, rrDerivation r))
          (resolveText testIndex (Just devarim65) "ויאמר")
        `shouldBe` [("אמר", FromTorah)]

    it "a root the asker names, if Torah knows it as a root" $
      map (\r -> (rrShoresh r, rrDerivation r)) (resolveText testIndex Nothing "אמר")
        `shouldBe` [("אמר", NamedRoot)]

    it "a three-letter string Torah does not know as a root is not one" $
      resolveText testIndex Nothing "קטל" `shouldBe` []

  describe "tokenize" $ do
    it "strips nikud and te'amim" $
      tokenize "וַיֹּ֥אמֶר אֱלֹהִ֖ים" `shouldBe` ["ויאמר", "אלהים"]

    it "splits maqaf before stripping marks (tablet 30a)" $
      tokenize "וַֽיְהִי־אֽוֹר ׃" `shouldBe` ["ויהי", "אור"]

    it "indexes both halves of a maqaf-joined L1 word" $
      shoreshim (resolveText testIndex Nothing "ויהי") `shouldBe` ["יהי"]


-- ============================================================
-- Helpers
-- ============================================================

treeDepth :: ParsedVerse -> Int
treeDepth (Leaf _) = 1
treeDepth (Branch _ l r) = 1 + max (treeDepth l) (treeDepth r)

collectAllWords :: ParsedVerse -> [Text]
collectAllWords (Leaf w) = [awWord w]
collectAllWords (Branch _ l r) = collectAllWords l ++ collectAllWords r