engine: a word's root is what L1 records for it (tablet 33)

The Shoresh Engine never opened L1 to find a root. extractRoots called
every word of two or three letters a root and dropped every longer one:
את → א-ת-ה (padded with a He the text never wrote), ואת → ו-א-ת,
בכל → ב-כ-ל; ויאמר, ואהבת, אלהים → nothing. Handed all of Devarim 6:5
it found no א-ה-ב. Binyan was "Qal" for everything, nouns included.

shoresh-engine:
- Shoresh.Roots: an index over all of L1 (5853 verses, built once at
  server start, <1 s). A word resolves, in order: from the verse in
  scope (its own shoresh, with the binyan read from the verb's
  morphology; else its lemma's shoresh — לבבך → לבב); else the way Torah
  most often reads that surface form (its commonest lemma decides, so
  אשר the particle has no root); else a root the asker named, if Torah
  knows it. A word in the verse that L1 gives no root has none, whatever
  a homograph elsewhere carries. Unknown words yield nothing.
- Roots are rendered as L1 records them: two letters stay two letters.
- binyan is null unless a verb stands in the scoped verse.
- L1 is found via L1_MOUNT_POINT, not the literal l1/ relative to cwd —
  which is why parse_tree was null on the pod.
- Adds "surface" and "derivation" to each root (verse|lemma|torah|
  named_root). 22 new HSpec examples; 55 examples, 0 failures.

vav_pipeline:
- normalize_root places a lemma-derived root at the word it was heard
  from (L1 has no shoresh on לבבך to search by).
- A binyan is printed only where there is one; "binyan unknown" on a
  noun claimed a question that does not exist.
- test/tablet33_engine_roots_test.exs: the new shape through the router.
- liveness_test: clear a halt leaked by halt_monitor_test (the seed
  0/191243 flake, present since before tablet 30).
  461 tests, 0 failures on seeds 0 42 191243.

Verified before push with BOTH built images, the real engine binary and
a local PostgreSQL 16 (SSL): Devarim 6:5 → א-ה-ב (Qal, word 1), י-ה-ו,
א-ל-ה, כ-ל (words 5,7,9), ל-ב-ב, נ-פ-ש, מ-א-ד; 4 interpretations
written to L3, 0 L3_WRITE_FAILED, health healthy.

NOT repaired here: the quality of L1's own shoresh field, which the
engine is now faithful to — ויהי is recorded as יהי, שמים as שמ, יהוה
as יהו, הבאתי as בא. That is the quarry's tablet (scripts/build_l1.py)
and it changes the L1 hash; a decision, not a patch.

Co-Authored-By: Claude Fable 5.1 <noreply@anthropic.com>

shoresh-engine/src/Shoresh/Roots.hs

@@ -0,0 +1,274 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Roots — hearing the shoresh of a word from L1.
+--
+-- Broken tablet 33 (2026-10-04). Until now the server's @extractRoots@
+-- called every word of two or three letters a root and dropped every
+-- longer word: את became א-ת-ה (padded with a He the text never wrote),
+-- ואת became ו-א-ת, בכל became ב-כ-ל, and ויאמר, ואהבת, אלהים produced
+-- nothing at all. Handed the whole of Devarim 6:5 it found no א-ה-ב.
+-- It never opened L1.
+--
+-- "The lexicon is read from L1. It is not hardcoded. The system reads
+-- Torah and learns what roots are there." (Shoresh.Lexicon) — so this
+-- module does that. A word's root is what L1 records for that word:
+--
+--   1. 'FromVerse'  — the word stands in the verse in scope; L1's
+--                     @shoresh@ for that very word (and its binyan, if it
+--                     is a verb, from the morphology).
+--   2. 'FromLemma'  — the word stands in L1 without a @shoresh@ of its
+--                     own (לבבך, נפשך), but shares its lemma with words
+--                     that have one (לבב, נפש).
+--   3. 'FromTorah'  — the word is not in the verse in scope but appears
+--                     elsewhere in Torah; the root it most often carries.
+--   4. 'NamedRoot'  — the asker wrote a root itself (ברא) and Torah
+--                     knows it as a root.
+--
+-- A word L1 does not know yields nothing. A particle L1 gives no root
+-- (את) yields nothing. The engine does not invent a root to have
+-- something to say.
+--
+-- What this does NOT repair: the quality of L1's own @shoresh@ field,
+-- which is derived (ויהי is recorded as יהי, שמים as שמ). That is the
+-- quarry's tablet, not the mason's; this module is faithful to L1.
+module Shoresh.Roots
+  ( RootIndex
+  , emptyIndex
+  , indexVerse
+  , buildIndex
+  , loadIndex
+  , indexStats
+  , Derivation(..)
+  , ResolvedRoot(..)
+  , resolveText
+  , tokenize
+  , binyanFromMorph
+  ) where
+
+import Control.Exception (SomeException, try)
+import Control.Monad (foldM, guard)
+import Data.Char (isDigit)
+import Data.List (foldl', sort, sortOn)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (listToMaybe, mapMaybe)
+import Data.Ord (Down(..))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Directory (doesDirectoryExist, listDirectory)
+import System.FilePath ((</>), takeExtension)
+import Text.Read (readMaybe)
+
+import Shoresh.Lexicon (L1Verse(..), L1Word(..), loadL1Verse)
+import Shoresh.Types (Binyan(..))
+
+
+-- | What L1 teaches about its words, gathered once.
+data RootIndex = RootIndex
+  { riSurface      :: !(Map (Text, Text) (Map Text Int))
+                                                  -- ^ (consonants, lemma) → shoresh → count
+  , riSurfaceLemma :: !(Map Text (Map Text Int))  -- ^ consonants → lemma → count
+  , riLemma        :: !(Map Text (Map Text Int))  -- ^ lemma → shoresh → count
+  , riRoots        :: !(Set Text)                 -- ^ every shoresh L1 records
+  , riVerses       :: !Int
+  }
+
+emptyIndex :: RootIndex
+emptyIndex = RootIndex Map.empty Map.empty Map.empty Set.empty 0
+
+-- | (verses, distinct surface forms, distinct roots)
+indexStats :: RootIndex -> (Int, Int, Int)
+indexStats ix = (riVerses ix, Map.size (riSurfaceLemma ix), Set.size (riRoots ix))
+
+bump :: Ord k => k -> Text -> Map k (Map Text Int) -> Map k (Map Text Int)
+bump k v = Map.insertWith (Map.unionWith (+)) k (Map.singleton v 1)
+
+-- | Add one verse's words to the index.
+indexVerse :: RootIndex -> L1Verse -> RootIndex
+indexVerse ix verse =
+  let ix' = foldl' addWord ix (l1vWords verse)
+  in ix' { riVerses = riVerses ix' + 1 }
+  where
+    addWord acc w =
+      let lemma    = l1wLemma w
+          surfaces = splitMaqaf (l1wConsonants w)
+          withLemma a s = a { riSurfaceLemma = bump s lemma (riSurfaceLemma a) }
+          acc1 = foldl' withLemma acc surfaces
+      in case l1wShoresh w of
+           Nothing -> acc1
+           Just sh | T.null sh -> acc1
+                   | otherwise ->
+             let withSurface a s = a { riSurface = bump (s, lemma) sh (riSurface a) }
+                 acc2 = foldl' withSurface acc1 surfaces
+             in acc2 { riLemma = if realLemma lemma
+                                   then bump lemma sh (riLemma acc2)
+                                   else riLemma acc2
+                     , riRoots = Set.insert sh (riRoots acc2)
+                     }
+
+buildIndex :: [L1Verse] -> RootIndex
+buildIndex = foldl' indexVerse emptyIndex
+
+-- | A lemma that names a lexeme (a Strong's number), as opposed to the
+-- bare prefix letters L1 records for pronominal forms (@l@, @b@).
+realLemma :: Text -> Bool
+realLemma l = case T.uncons l of
+  Just (c, _) -> isDigit c
+  Nothing     -> False
+
+-- | Read every verse under @<l1root>/torah@ into an index. A missing or
+-- unreadable L1 gives an empty index: the engine then finds no roots and
+-- says so, rather than guessing.
+loadIndex :: FilePath -> IO RootIndex
+loadIndex l1root = do
+  let torah = l1root </> "torah"
+  ok <- doesDirectoryExist torah
+  if not ok then return emptyIndex else do
+    books <- sort <$> listDirectory torah
+    foldM (loadBook torah) emptyIndex books
+  where
+    loadBook torah ix book = do
+      let bdir = torah </> book
+      isDir <- doesDirectoryExist bdir
+      if not isDir then return ix else do
+        chapters <- numbered <$> listDirectory bdir
+        foldM (loadChapter bdir) ix chapters
+
+    loadChapter bdir ix ch = do
+      let cdir = bdir </> show ch
+      isDir <- doesDirectoryExist cdir
+      if not isDir then return ix else do
+        files <- listDirectory cdir
+        let verses = sort (mapMaybe verseNumber files)
+        foldM (loadVerse cdir) ix verses
+
+    loadVerse cdir ix v = do
+      r <- try (loadL1Verse (cdir </> (show v ++ ".json")))
+             :: IO (Either SomeException (Maybe L1Verse))
+      return $! case r of
+        Right (Just verse) -> indexVerse ix verse
+        _                  -> ix
+
+    numbered :: [FilePath] -> [Int]
+    numbered = sort . mapMaybe readMaybe
+
+    verseNumber :: FilePath -> Maybe Int
+    verseNumber f
+      | takeExtension f == ".json" = readMaybe (takeWhile (/= '.') f)
+      | otherwise                  = Nothing
+
+
+-- | How a root was heard.
+data Derivation = FromVerse | FromLemma | FromTorah | NamedRoot
+  deriving (Eq, Show)
+
+data ResolvedRoot = ResolvedRoot
+  { rrShoresh    :: !Text           -- ^ exactly as L1 records it (2 or 3 letters)
+  , rrSurface    :: !Text           -- ^ the word it was heard from
+  , rrBinyan     :: !(Maybe Binyan) -- ^ only for a verb standing in the scoped verse
+  , rrDerivation :: !Derivation
+  } deriving (Eq, Show)
+
+
+-- | The Hebrew words of a text as bare consonants, in order.
+-- Maqaf is split BEFORE the marks are stripped: it sits inside the
+-- combining-mark range and would otherwise fuse two words (tablet 30a).
+tokenize :: Text -> [Text]
+tokenize =
+    filter (not . T.null)
+  . T.split (not . isHebrewLetter)
+  . T.filter (not . isMark)
+  . T.map (\c -> if c == '\x05BE' then ' ' else c)
+  where
+    isMark c = c >= '\x0591' && c <= '\x05C7'
+
+isHebrewLetter :: Char -> Bool
+isHebrewLetter c = c >= '\x05D0' && c <= '\x05EA'
+
+splitMaqaf :: Text -> [Text]
+splitMaqaf = filter (not . T.null) . T.splitOn "\x05BE"
+
+
+-- | Resolve every Hebrew word of a text to its root, in order, each root
+-- once. The verse in scope, when there is one, is consulted first.
+resolveText :: RootIndex -> Maybe L1Verse -> Text -> [ResolvedRoot]
+resolveText ix mverse =
+  dedupe . mapMaybe (resolveWord ix mverse) . tokenize
+  where
+    dedupe = go Set.empty
+    go _ [] = []
+    go seen (r:rs)
+      | rrShoresh r `Set.member` seen = go seen rs
+      | otherwise                     = r : go (Set.insert (rrShoresh r) seen) rs
+
+resolveWord :: RootIndex -> Maybe L1Verse -> Text -> Maybe ResolvedRoot
+resolveWord ix mverse w = case here of
+    (_:_) -> inVerse
+    []    -> case Map.lookup w (riSurfaceLemma ix) of
+               Just lemmas -> inTorah lemmas
+               Nothing     -> named
+  where
+    verseWords = maybe [] l1vWords mverse
+    here = filter (\lw -> w `elem` splitMaqaf (l1wConsonants lw)) verseWords
+
+    -- The word stands in the verse in scope. What L1 says of it THERE is
+    -- the whole answer: its own shoresh, else its lemma's; and if L1 gives
+    -- it neither (את, אל, אשר), it has no root here — whatever a homograph
+    -- elsewhere in Torah may carry.
+    inVerse = firstJust
+      [ listToMaybe
+          [ ResolvedRoot sh w (binyanFromMorph (l1wMorph lw)) FromVerse
+          | lw <- here, Just sh <- [l1wShoresh lw], not (T.null sh) ]
+      , firstJust [ viaLemma (l1wLemma lw) | lw <- here ]
+      ]
+
+    -- The word is not in the verse in scope but Torah has it. Read it
+    -- the way Torah most often does: its most common lemma decides.
+    -- אשר is the relative particle 1649 times and a name 14 times; the
+    -- particle wins, and a particle has no root.
+    inTorah lemmas = do
+      lemma <- mostCommon lemmas
+      firstJust
+        [ do sh <- mostCommon =<< Map.lookup (w, lemma) (riSurface ix)
+             return (ResolvedRoot sh w Nothing FromTorah)
+        , viaLemma lemma
+        ]
+
+    -- No shoresh of its own, but a lemma whose other words have one.
+    viaLemma lemma = do
+      guard (realLemma lemma)
+      sh <- mostCommon =<< Map.lookup lemma (riLemma ix)
+      return (ResolvedRoot sh w Nothing FromLemma)
+
+    -- Torah has no such word, but knows it as a root: the asker named one.
+    named
+      | w `Set.member` riRoots ix = Just (ResolvedRoot w w Nothing NamedRoot)
+      | otherwise                 = Nothing
+
+firstJust :: [Maybe a] -> Maybe a
+firstJust = listToMaybe . mapMaybe id
+
+-- | The key with the highest count; ties go to the lesser key, so the
+-- answer does not depend on map traversal accidents.
+mostCommon :: Map Text Int -> Maybe Text
+mostCommon m = fmap fst . listToMaybe $ sortOn (\(k, n) -> (Down n, k)) (Map.toList m)
+
+
+-- | The binyan a verb stands in, from its OSHB morphology code
+-- (e.g. @HC/Vqw3ms@ → Qal, @HVhp1cs@ → Hifil). 'Nothing' for a word
+-- that is not a verb, or a stem outside the seven.
+binyanFromMorph :: Text -> Maybe Binyan
+binyanFromMorph morph =
+  listToMaybe (mapMaybe stem (T.splitOn "/" (T.dropWhile (== 'H') morph)))
+  where
+    stem seg = case T.unpack (T.take 2 seg) of
+      ['V', 'q'] -> Just Qal
+      ['V', 'N'] -> Just Nifal
+      ['V', 'p'] -> Just Piel
+      ['V', 'P'] -> Just Pual
+      ['V', 'h'] -> Just Hifil
+      ['V', 'H'] -> Just Hofal
+      ['V', 't'] -> Just Hitpael
+      _          -> Nothing

shoresh-engine/src/Shoresh/Server.hs

@@ -16,6 +16,8 @@
 module Shoresh.Server
   ( runServer
   , handleRequest
+  , Env(..)
+  , loadEnv
   ) where
 
 import qualified Data.ByteString.Char8 as BS8
@@ -29,13 +31,15 @@ import Data.Maybe (mapMaybe)
 import System.IO (hSetBuffering, stdin, stdout, stderr,
                   BufferMode(..), hFlush, hIsEOF)
 import System.Directory (doesFileExist)
+import System.Environment (lookupEnv)
+import System.FilePath ((</>))
 import Control.Exception (catch, SomeException)
 
 import Shoresh.Types
 import Shoresh.Gematria
-import Shoresh.Binyanim
 import Shoresh.Teamim
 import Shoresh.Lexicon
+import Shoresh.Roots
 
 
 -- | Run the JSON-line server loop.
@@ -48,37 +52,59 @@ runServer = do
   hSetBuffering stdin  LineBuffering
   hSetBuffering stdout LineBuffering
   hSetBuffering stderr LineBuffering
-  serverLoop
+  env <- loadEnv
+  serverLoop env
+
+
+-- | What the server holds for its whole life: where L1 is, and what L1
+-- teaches about its words.
+data Env = Env
+  { envL1Root :: FilePath
+  , envRoots  :: RootIndex
+  }
+
+-- | Find L1 and read it once. The pipeline sets @L1_MOUNT_POINT@
+-- (/mnt/torah on the pod); a bare checkout has @l1/@ beside it. Until
+-- tablet 33 the path was the literal @l1/torah/…@ relative to the
+-- working directory, which on the pod is not where the scroll is — so
+-- @parse_tree@ was null there and nobody had noticed.
+loadEnv :: IO Env
+loadEnv = do
+  l1root <- maybe "l1" id <$> lookupEnv "L1_MOUNT_POINT"
+  ix <- loadIndex l1root
+  -- Force the index before the first request is read.
+  let (nVerses, nSurfaces, nRoots) = indexStats ix
+  nVerses `seq` nSurfaces `seq` nRoots `seq` return (Env l1root ix)
 
 
 -- | Main server loop: read line, process, write line, repeat.
-serverLoop :: IO ()
-serverLoop = do
+serverLoop :: Env -> IO ()
+serverLoop env = do
   eof <- hIsEOF stdin
   if eof
     then return ()
     else do
       line <- BL.fromStrict <$> BS8.getLine
-      response <- processLine line
+      response <- processLine env line
       BLC.putStrLn (encode response)
       hFlush stdout
-      serverLoop
+      serverLoop env
 
 
 -- | Process a single JSON line and return a response.
-processLine :: BL.ByteString -> IO Value
-processLine line = case eitherDecode line of
+processLine :: Env -> BL.ByteString -> IO Value
+processLine env line = case eitherDecode line of
   Left err -> return $ errorResponse "PARSE_ERROR" (T.pack err)
-  Right req -> handleRequest req
+  Right req -> handleRequest env req
     `catch` \e -> return $ errorResponse "INTERNAL_ERROR"
                     (T.pack $ show (e :: SomeException))
 
 
 -- | Handle a parsed request and produce a response.
-handleRequest :: Value -> IO Value
-handleRequest val = case parseOperation val of
+handleRequest :: Env -> Value -> IO Value
+handleRequest env val = case parseOperation val of
   Nothing -> return $ errorResponse "INVALID_OPERATION" "Missing or invalid 'operation' field"
-  Just "process"  -> handleProcess val
+  Just "process"  -> handleProcess env val
   Just "separate" -> handleSeparate val
   Just "name"     -> handleName val
   Just "evaluate" -> handleEvaluate val
@@ -103,36 +129,29 @@ parseOperation _ = Nothing
 -- | Handle "process" operation — root activation, te'amim parse, gematria.
 -- Construction spec §3.1: Takes text + scope, returns roots_activated,
 -- parse_tree, dual_readings.
-handleProcess :: Value -> IO Value
-handleProcess val = do
+handleProcess :: Env -> Value -> IO Value
+handleProcess env val = do
   let reqText = extractText val
       mscope = extractScope val
 
-  -- Parse roots from input text
-  let roots = extractRoots reqText
-
-  -- Build activated roots with gematria and binyanim
-  let activatedRoots = map activateRoot roots
-
-  -- If scope is provided, load verse from L1 and parse te'amim
-  (parseTree, dualReadings) <- case mscope of
-    Nothing -> return (Null, toJSON ([] :: [Value]))
+  -- The verse in scope, if one was named and L1 has it.
+  mverse <- case mscope of
+    Nothing -> return Nothing
     Just (book, ch, vs) -> do
-      let path = "l1/torah/" ++ T.unpack (bookToText book)
-                 ++ "/" ++ show ch ++ "/" ++ show vs ++ ".json"
+      let path = envL1Root env </> "torah" </> T.unpack (bookToText book)
+                 </> show ch </> (show vs ++ ".json")
       exists <- doesFileExist path
-      if not exists
-        then return (Null, toJSON ([] :: [Value]))
-        else do
-          mverse <- loadL1Verse path
-          case mverse of
-            Nothing -> return (Null, toJSON ([] :: [Value]))
-            Just verse -> do
-              let annotated = mapMaybe annotateL1Word (l1vWords verse)
-                  tree = readTeamim annotated
-                  ptJson = treeToJson tree
-                  drJson = toJSON ([] :: [Value])  -- Phase 3: extract ketiv/qere
-              return (ptJson, drJson)
+      if exists then loadL1Verse path else return Nothing
+
+  -- Each Hebrew word of the input, heard through L1 (Shoresh.Roots).
+  let activatedRoots = map activateRoot (resolveText (envRoots env) mverse reqText)
+
+  let (parseTree, dualReadings) = case mverse of
+        Nothing    -> (Null, toJSON ([] :: [Value]))
+        Just verse ->
+          let annotated = mapMaybe annotateL1Word (l1vWords verse)
+              -- Phase 3: extract ketiv/qere
+          in (treeToJson (readTeamim annotated), toJSON ([] :: [Value]))
 
   return $ object
     [ "status" .= ("ok" :: Text)
@@ -226,41 +245,40 @@ extractScope (Object obj) = do
 extractScope _ = Nothing
 
 
--- | Extract Hebrew roots from input text.
-extractRoots :: Text -> [Shoresh]
-extractRoots t =
-  let words' = T.words t
-      -- Try each word as a potential root
-      candidates = mapMaybe textToShoresh words'
-      -- Also try the whole text as a single root
-      wholeRoot = textToShoresh (T.filter (\c -> c >= '\x05D0' && c <= '\x05EA') t)
-  in case candidates of
-    [] -> case wholeRoot of
-      Just r  -> [r]
-      Nothing -> []
-    rs -> rs
-
-
--- | Activate a root: expand through binyanim, compute gematria, find neighbors.
-activateRoot :: Shoresh -> Value
-activateRoot sh =
-  let expanded = expand sh
-      gv = gematriaRoot sh
-      consonantNames = map consonantName [c1 sh, c2 sh, c3 sh]
-      defaultBinyan = case Map.lookup Qal expanded of
-        Just p  -> T.pack (show (Shoresh.Types.binyan p))
-        Nothing -> "Qal"
+-- | Render a root heard from L1 in the port's contract shape
+-- (Construction spec §3.1), plus where it was heard from.
+--
+-- The shoresh is rendered exactly as L1 records it. A two-letter root
+-- (כל, שמ) stays two letters: the old path padded it with He to fit the
+-- triliteral type and reported a root — and a gematria — the text does
+-- not contain.
+--
+-- @binyan@ is the stem the verb actually stands in, read from the
+-- verse's morphology. It is null for a noun and for a word that is not
+-- in the verse in scope: the old path answered "Qal" for everything.
+activateRoot :: ResolvedRoot -> Value
+activateRoot r =
+  let sh = rrShoresh r
   in object
-    [ "shoresh"          .= consonantNames
-    , "shoresh_hebrew"   .= shoreshToText sh
-    , "binyan"           .= defaultBinyan
+    [ "shoresh"          .= mapMaybe (fmap consonantName . charToConsonant) (T.unpack sh)
+    , "shoresh_hebrew"   .= sh
+    , "binyan"           .= fmap (T.pack . show) (rrBinyan r)
     , "domain"           .= ("unknown" :: Text)  -- Phase 3: domain lookup
     , "torah_refs"       .= ([] :: [Value])       -- Phase 3: lexicon lookup
-    , "gematria_value"   .= gv
+    , "gematria_value"   .= gematriaWord sh
     , "gematria_neighbors" .= ([] :: [Value])     -- Phase 3: lexicon needed
     , "neighbors"        .= ([] :: [Value])       -- Phase 3: lexicon needed
+    , "surface"          .= rrSurface r
+    , "derivation"       .= derivationName (rrDerivation r)
     ]
 
+derivationName :: Derivation -> Text
+derivationName d = case d of
+  FromVerse -> "verse"
+  FromLemma -> "lemma"
+  FromTorah -> "torah"
+  NamedRoot -> "named_root"
+
 
 -- | Convert an L1 word to an AnnotatedWord for te'amim parsing.
 annotateL1Word :: L1Word -> Maybe AnnotatedWord