Writing an Aaronson Oracle

The Aaronson Oracle is a game where you type f and d at random and the Oracle tries to guess which you’re gonna type next. It looks at your input history and tries to find patterns.

import Data.Map as M
import Data.Maybe
import Numeric

We use a Map [Bool] Double structure (called a brain here for no good reason) to store sequences and how often they occur. Instead of storing f and d, we store Booleans True and False (True = "f").

We improve the brain with learn, which takes the history of sequences and uses it to increment subsequence occurrence counts. We store sequences between three and five characters long, and simultaneously create and/or update them with:

• Map.insertwithKey f key newValue, where
• f key oldValue newValue = oldValue + newValue, which can be written
• f _ = (+) or
• f = const (+)

We fold this learn' operation across the brain a few times and return the new brain.

learn :: [Bool] -> Map [Bool] Double -> Map [Bool] Double
learn hist brain = Prelude.foldr learn' brain [3..5]
  where learn' n = M.insertWithKey (const (+)) (take n hist) 1.0

We want to use the brain to “guess” how likely an f or d will be. This will be a weighted average, where the value is how likely a given lookback period would indicate, and the weight is how many datapoints we have for a given lookback period.

For example, take a brain with key/value pairs:

[ T T ]   -> 2  
[ F T ]   -> 3  
[ T T F ] -> 3  
[ F T F ] -> 1

Imagine we’ve just typed F and then T. Looking back only one character (just at the T) would indicate that F will follow 3 out of 5 times, but looking back two characters would indicate that T will follow 3 out of 4 times. We can weight those values by certainty to get a pretty good prediction.

guess :: Map [Bool] Double -> [Bool] -> Bool
guess brain hist = wAvg (Prelude.map guess' [2..4]) >= 0.5
  where wAvg xs = sum (Prelude.map (uncurry (*)) xs) / sum (Prelude.map snd xs)
        guess' n = (occ True / (occ True + occ False), occ True + occ False)
          where occ val = fromMaybe 0.0 $ M.lookup (val : take n hist) brain

M.lookup key map returns a Maybe val, so we wrap it in a fromMaybe default to ensure some real number gets returned.

Then it’s time to play a turn! Each turn needs to be aware of what turn number it is (turn), how many games were won and held before it (wons, total), the prior history (hist), and the prior brain (brain).

We get the keypress, judge it against the guess brain hist, and print a message to the user.

Then we kick off a new round with an incremented turn number, potential incremented win number, incremented total games number, augmented history, and new and improved brain.

play :: Int -> (Double, Double) -> [Bool] -> Map [Bool] Double -> IO a
play turn (wons, total) hist brain = do
  press <- getLine
  let key   = press == "f"
  let right = key == guess brain hist
  let wins  = (if right then succ else id) wons
  print $ "I guessed " ++ (if right then "RIGHT!" else "wrong.") 
    ++ " My avg: " ++ showFFloat (Just 2) (wins / succ total) "" 
  play (succ turn) (wins, succ total) (key:hist) (learn (key:hist) brain)

The main block prints instructions and kicks off the game at round zero, with zero wins for zero total games, an empty history array, and an empty brain.

main = do
  print "aaronson oracle | Press 'f' or 'd' over and over (followed by enter)"
  print "                | and we'll try to predict which you'll press next."
  play 0 (0.0, 0.0) [] M.empty

You can see the full code here, in a gist.