{-# 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` "99bbd07a5406e8acfc9d77ace277fe3e3ccee379a7fc4e48c61cc7c4ab7ea377" it "has correct counts" $ do torahBookCount `shouldBe` 5 torahVerseCount `shouldBe` 5853 torahWordCount `shouldBe` 79982 uniqueRootCount `shouldBe` 2608 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