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.KiTov
import Luchot.Firmware

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

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`
      "0ee0020aac6c6beb0e83c0638a861c73d37d9dbd39c30d3cb08c1878b481c844"

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

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


-- ============================================================
-- 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