Guess the number (#17)

* does this fix it?

* debug

* more debug

* record the duration my damn self

* fix type

* no sleep

* back up less

* better number lookup

* fix export

* advance the offset

* sdg

* asdfg

* back up a bit

* say it don't mail it

* fix question logging

* cleanup

Author: ludflu

app/Actions.hs

@@ -36,7 +36,7 @@ import Data.Traversable
 import Guess (guessingGame)
 import Listener (ListenerMonad, ListenerState (dbPool, mailbox), quitNow, readMail, say, speak, writeToMailBox)
 import MatchHelper (dropNonLetters, fuzzyMatch, isMatch, lowerCase)
-import OllamaApi (answerQuestion, writeToMailBox')
+import OllamaApi (answerQuestion)
 import RecordNote (readNote, recordNote)
 import Reminders (setReminder)
 import SayDateTime (currentDay, currentTime)

app/Listener.hs

@@ -162,7 +162,9 @@ listenPatiently = listenWithThreshold 0.70
 listen :: ListenerMonad String
 listen = do
   env <- ask
-  listenWithThreshold (activationThreshold env)
+  words <- listenWithThreshold (activationThreshold env)
+  liftIO $ print $ "words: " ++ words
+  return words
 
 -- repeatedly reads from the capture file, looking for voice boundaries (start and stop)
 -- when we find a voice boundary, we splice off that chunk of audio
@@ -195,7 +197,7 @@ listenWithThreshold threshold = do
       liftIO $ do
         let se = getStartEnd (voiceStart boundary) (voiceEnd boundary)
             (start, end) = fromMaybe (0.0, 0.0) se -- this default should never happen
-        writeBoundedWave (path listener) capfilepath (start - 0.25) end (audioRate env) -- back up a 1/4 second to make sure we don't lose anything
+        writeBoundedWave (path listener) capfilepath (start - 0.2) end (audioRate env) -- maybe ? back up a 2/10 second to make sure we don't lose anything
         transcript <- sendAudio ("http://" ++ whisperHost env ++ "/") (whisperPort env) capfilepath
         when (debug env) (liftIO $ print transcript)
         return transcript
@@ -263,14 +265,17 @@ say msg =
     config <- ask
     dur <- liftIO $ sayText (sileroHost config) (sileroPort config) msg
     endTime <- liftIO getCurrentTime
-    let offset = timeOffset listenerState + dur + sleepSeconds config -- advance the offset to skip over the time when the computer was talking
+    let dur = diffUTCTime endTime startTime
+        durSeconds = realToFrac $ nominalDiffTimeToSeconds dur
+        offset = timeOffset listenerState + durSeconds + sleepSeconds config -- advance the offset to skip over the time when the computer was talking
+    liftIO $ print $ "duration: " ++ (show durSeconds)
     put
       listenerState
         { timeOffset = offset,
           voiceStartTime = Nothing,
           voiceEndTime = Nothing
         }
-    return dur
+    return durSeconds
 
 trim :: String -> String
 trim s = T.unpack $ T.strip $ T.pack s

app/Main.hs

@@ -65,7 +65,7 @@ runJob config startState = do
   runListenerMonad commandLoop config startState
   print "ending program, killing recorder thread"
   killThread recorderThread
-  run config -- dirty hack because things sometimes crash
+  runJob config startState -- dirty hack because things sometimes crash
 
 makeDbConfig :: EnvConfig -> Maybe PostgresConf
 makeDbConfig config = do

app/MatchHelper.hs

@@ -27,34 +27,9 @@ isMatch s r = not (null (scan r s))
 dropNonNumbers :: String -> String
 dropNonNumbers = filter isNumber
 
--- nums :: [String]
--- nums = ["", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", "twenty"]
-
--- teens :: [String]
--- teens = ["", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety", "hundred"]
-
--- numsToString :: Int -> String
--- numsToString i
---   | i <= 20 = nums !! i
---   | i < 100 = teens !! ((i `div` 10) - 1) ++ " " ++ nums !! (i `mod` 10)
-
--- numsToString' :: Integer -> String
--- numsToString' i =
---   let ii = fromInteger i
---    in numsToString ii
-
 strip :: String -> String
 strip s = T.unpack $ T.strip (T.pack s) -- I know this shouldn't be required due to OverloadedStrings, and yet
 
-nummap :: M.Map String Integer
-nummap =
-  let numnum = map toInteger [1 .. 99]
-      numstrs = map (strip . convertNumber) numnum
-   in M.fromList (zip numstrs numnum)
-
-lookupNum :: String -> Maybe Integer
-lookupNum i = M.lookup i nummap
-
 parseInt :: String -> Maybe Integer
 parseInt str = readMaybe $ dropNonNumbers str
 

app/SpokenNumbers.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE QuasiQuotes #-}
 
-module SpokenNumbers (convertNumber, convertNString, convertAllNumbers, readUnit) where
+module SpokenNumbers (convertNumber, convertNString, convertAllNumbers, readUnit, lookupNum) where
 
+import Data.Char
+import qualified Data.Map as M
 import qualified Data.Text as T
 import Text.Numerals
 import Text.Regex.PCRE.Heavy (Regex, gsub, re)
@@ -32,3 +34,26 @@ convertNString nstr =
 
 convertAllNumbers :: String -> String
 convertAllNumbers = gsub [re|([0-9,]+)|] convertNString
+
+punctToSpace :: String -> String
+punctToSpace str = gsub [re|([^a-z,]+)|] " " str
+
+makeLower :: String -> String
+makeLower = map toLower
+
+trim :: String -> String
+trim = f . f
+  where
+    f = reverse . dropWhile isSpace
+
+nummap :: M.Map String Integer
+nummap =
+  let nm = map convertNumber [0 .. 100]
+      nmLower = map makeLower nm
+      regnums = map punctToSpace nmLower
+   in M.fromList $ zip regnums [0 .. 100]
+
+lookupNum :: String -> Maybe Integer
+lookupNum s =
+  let needle = trim $ punctToSpace $ makeLower s
+   in M.lookup needle nummap

lib/Guess.hs

@@ -6,35 +6,36 @@ module Guess where
 import Control.Concurrent (threadDelay)
 import Control.Monad.State (liftIO)
 import Data.Char (isNumber, toLower)
-import Listener (ListenerMonad, listen, writeToMailBox)
+import Listener (ListenerMonad, listen, listenPatiently, say, writeToMailBox)
 import MatchHelper (parseInt, readInt)
 import System.Random (Random (randomRs), newStdGen)
 
 listenForInteger :: ListenerMonad (Maybe Integer)
-listenForInteger = readInt <$> listen
+listenForInteger = readInt <$> listenPatiently
 
 guess :: Integer -> ListenerMonad ()
 guess secret = do
-  writeToMailBox "Guess the number: "
+  say "Guess the number: "
   liftIO $ threadDelay 250000
   guessedNumber <- listenForInteger
   case guessedNumber of
     Nothing -> do
-      writeToMailBox "I couldn't understand you."
+      say "I couldn't understand you."
       guess secret
     Just gnum ->
       if gnum > secret
         then do
-          writeToMailBox "Too high."
+          say "Too high."
           guess secret
         else
           if gnum < secret
             then do
-              writeToMailBox "Too low."
+              say "Too low."
               guess secret
             else do
-              writeToMailBox "You got it!"
-              writeToMailBox "Thanks for playing!"
+              say "You got it!"
+              say "Thanks for playing!"
+              return ()
 
 guessingGame :: ListenerMonad ()
 guessingGame = do

lib/OllamaApi.hs

@@ -5,11 +5,27 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module OllamaApi (writeToMailBox', answerQuestion, extractAnswer, makeResponseChunk, jsonChunks, chunker) where
+module OllamaApi (answerQuestion, extractAnswer, makeResponseChunk, jsonChunks, chunker) where
 
 import ChatLogger
-import Conduit (ConduitM, ConduitT, MonadResource, awaitForever, concatC, concatMapAccumC, concatMapC, concatMapCE, filterC, leftover, mapAccumWhileC, mapC, mapCE, mapM_C, runConduit, runConduitRes, sinkLazy, sourceLazy, yield, (.|))
+import Conduit
+  ( ConduitM,
+    ConduitT,
+    MonadIO (liftIO),
+    MonadResource,
+    awaitForever,
+    filterC,
+    leftover,
+    mapC,
+    mapM_C,
+    runConduit,
+    runResourceT,
+    yield,
+    (.|),
+  )
 import ConfigParser
+  ( EnvConfig (ollamaHost, ollamaPort, sileroHost, sileroPort),
+  )
 import Control.Concurrent (forkIO)
 import Control.Concurrent.STM (STM, TQueue, atomically, readTVar, writeTQueue, writeTVar)
 import Control.Exception (throwIO)
@@ -40,11 +56,10 @@ import Database.Persist.Postgresql (ConnectionPool, Entity (Entity))
 import GHC.Generics (Generic)
 import Listener
 import Network.HTTP.Conduit
-  ( Request (method, port, requestBody, requestHeaders, responseTimeout, secure),
-    RequestBody (RequestBodyBS, RequestBodyLBS),
+  ( Request (method, port, requestBody),
+    RequestBody (RequestBodyLBS),
     Response (responseBody),
     http,
-    httpLbs,
     newManager,
     parseRequest,
     responseTimeoutMicro,
@@ -99,25 +114,14 @@ isPunct c =
 makeResponseChunk :: B.ByteString -> Maybe OllamaResponse
 makeResponseChunk = decode . BLS.fromStrict
 
-writeToMailBox' :: MonadResource m => TQueue String -> Maybe ConnectionPool -> Maybe QueryId -> String -> m ()
-writeToMailBox' mbox dbPool queryId msg =
-  liftResourceT $
-    liftIO $ do
-      mapM_ (\qid -> addAnswer dbPool (Answer qid msg)) queryId
-      atomically $ writeTQueue mbox msg
-
-talker :: MonadResource m => String -> Int -> String -> m ()
-talker sileroHost sileroPort mesg = do
+talker :: MonadResource m => String -> Int -> Maybe ConnectionPool -> Maybe QueryId -> String -> m ()
+talker sileroHost sileroPort connectionPool qid mesg = do
   liftResourceT $ do
-    liftIO $ sayText sileroHost sileroPort mesg -- TODO: return a list of the durations somewhere so we can advance the time in the listener
+    liftIO $ do
+      mapM_ (\qid -> addAnswer connectionPool (Answer qid mesg)) qid
+      sayText sileroHost sileroPort mesg -- TODO: return a list of the durations somewhere so we can advance the time in the listener
     return ()
 
-getDbStuff :: Maybe QueryId -> Maybe ConnectionPool -> Maybe (QueryId, ConnectionPool)
-getDbStuff q d = do
-  q' <- q
-  d' <- d
-  return (q', d')
-
 chunker :: Monad m => (String -> m ()) -> ConduitT B.ByteString c m ()
 chunker chunkAction =
   jsonChunks '}'
@@ -140,7 +144,7 @@ answerQuestion qid question = do
         body = RequestBodyLBS $ encode payload
         request' = request {method = "POST", requestBody = body, port = apiPort}
         request'' = setRequestResponseTimeout (responseTimeoutMicro (500 * 1000000)) request'
-        talker' = talker (sileroHost env) (sileroPort env)
+        talker' = talker (sileroHost env) (sileroPort env) (dbPool st) qid
     manager <- newManager tlsManagerSettings
     runResourceT $ do
       rsp <- http request'' manager