{-# 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 = triliteral Bet Resh Aleph radicals sh `shouldBe` [Bet, Resh, Aleph] it "renders as Hebrew text" $ do shoreshToText (triliteral Bet Resh Aleph) `shouldBe` "ברא" shoreshToText (triliteral Qof Dalet Shin) `shouldBe` "קדש" it "parses from Hebrew text (3 consonants)" $ do textToShoresh "ברא" `shouldBe` Just (triliteral Bet Resh Aleph) textToShoresh "קדש" `shouldBe` Just (triliteral Qof Dalet Shin) it "a two-letter root stays two letters — nothing is added" $ do -- L1 has roots of two consonants (בן, יד). This type once held -- exactly three and padded these with He: בן became בנה. fmap radicals (textToShoresh "בן") `shouldBe` Just [Bet, Nun] fmap shoreshToText (textToShoresh "בן") `shouldBe` Just "בנ" fmap gematriaRoot (textToShoresh "בן") `shouldBe` Just 52 it "a root of four or more is held whole" $ do -- שמאל — once rejected as "too long". fmap radicals (textToShoresh "שמאל") `shouldBe` Just [Shin, Mem, Aleph, Lamed] fmap gematriaRoot (textToShoresh "שמאל") `shouldBe` Just 371 it "mkShoresh needs at least two consonants" $ do mkShoresh [] `shouldBe` Nothing mkShoresh [Aleph] `shouldBe` Nothing mkShoresh [Bet, Nun] `shouldSatisfy` isJust it "rejects invalid input" $ do textToShoresh "" `shouldBe` Nothing textToShoresh "א" `shouldBe` Nothing -- one letter is not a root textToShoresh "abc" `shouldBe` Nothing textToShoresh "בר1" `shouldBe` Nothing 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 = triliteral 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 = triliteral 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 = triliteral 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 (triliteral Bet Resh Aleph) `shouldBe` 203 -- קדש = Qof(100) + Dalet(4) + Shin(300) = 404 gematriaRoot (triliteral Qof Dalet Shin) `shouldBe` 404 -- שלם = Shin(300) + Lamed(30) + Mem(40) = 370 gematriaRoot (triliteral 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 = triliteral Bet Resh Aleph -- 203 let other = triliteral 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 = triliteral Bet Resh Aleph -- ברא let barak = triliteral Bet Resh Kaf -- ברך (shares ב,ר) let garaEnt = triliteral Gimel Resh Aleph -- גרא (shares ר,א) let unrelated = triliteral 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 "compares only roots of the same length" $ do let Just ben = textToShoresh "בן" let Just bat = textToShoresh "בת" let bana = triliteral Bet Nun He sharedConsonants ben bat `shouldBe` 1 sharedConsonants ben bana `shouldBe` 0 let lex = Map.fromList [ (ben, ShoreshEntry ben Creation [] [] Map.empty) , (bat, ShoreshEntry bat Creation [] [] Map.empty) , (bana, ShoreshEntry bana Creation [] [] Map.empty) ] map seShoresh (neighbors ben lex) `shouldBe` [bat] map fst (neighborsByPosition ben lex) `shouldBe` ["c1"] it "labels a triliteral neighbor by the positions it shares" $ do let bara = triliteral Bet Resh Aleph let barak = triliteral Bet Resh Kaf let lex = Map.fromList [ (bara, ShoreshEntry bara Creation [] [] Map.empty) , (barak, ShoreshEntry barak Blessing [] [] Map.empty) ] map fst (neighborsByPosition bara lex) `shouldBe` ["c1c2"] it "counts shared consonants correctly" $ do let sh1 = triliteral Bet Resh Aleph let sh2 = triliteral Bet Resh Kaf sharedConsonants sh1 sh2 `shouldBe` 2 let sh3 = triliteral 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 = triliteral 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 = triliteral 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` "9e1abe4edabac825d8a7037606ff247c3e8f8167650f04553f46c34e4f3c3086" 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