Cracking a Lock in Haskell with the De Bruijn sequence, pt. 2

For this post I will rework the Prefer One algorithm from the previous post so that it is much more efficient. We will add words to a Patricia Tree-like dictionary as we see them, passing the tree along in the State monad; to check if a new word has been seen we simply check in the tree, rather than in the array.

First, a little boilerplate…

> module Main
> where
>
> import Data.Array
> import Data.List(isInfixOf, tails)
>
> import Control.Monad.State
> import Control.Arrow

NEW IMPLEMENTATION:

In the previous implementation, to check if the word formed by adding a one has been seen, we had to iterate through each of the previous bits in the array, checking words.

For example for words of length 3, finding the 7th bit (?) by checking if 111 has already been seen:

        /-----\  ==>  111
0 0 0 1 1 1 (1)...
\----/         000 == 111  No
  \----/       001 == 111  No
    \----/     011 == 111  No
      \----/   111 == 111  Yes, so this bit must be (0)

This is extremely inefficient. What we want is to be able to store all the previous words that we’ve encountered in an easily- searchable data structure.

In the example above, we would like the three words that we’ve seen to be stored in what might be called a Trie, so that our search instead looks like the following:

       /\        
      0  1         1 - in tree, go right
     / \  \  
    0   1  1       1 - in tree, go right
   / \   \  \
  0   1   1  1     1 - in tree, we've already seen 111,
                       so the last bit must be 0

Our new data structure will look like this:

> data Tree = Bs Tree Tree -- Bs (zero_bit) (one_bit)
>           | X -- incomplete word
>           | B -- final bit of word
>           deriving Show

  
We'll need to build a new tree from a list of bits, appending a final bit (1,
except for the initial tree):
  
> treeWithFinal1 = mkTree True
> treeWithFinal0 = mkTree False
>
> mkTree :: Bit -> [Bit] -> Tree
> mkTree p = foldr mkBranch (if p then Bs X B else Bs B X)
>     where mkBranch b | b = Bs X --1
>                      | otherwise = flip Bs X --0

  
Finally, here is our new algorithm. The tree is passed in the State monad,
through the use of mapM. The state monad is a little tricky sometimes:

> preferOneV2 :: Int -> [ Bit ]
> preferOneV2 n =
>     let upB = 2^n
>         -- the whole bit sequence (one period):
>         bs = take upB (replicate n False ++ bs')
>         (wp0:wordPrefixes) = [ take (n-1) w | w <- tails bs ]
>
>         -- pass our Tree around in the State monad
>         state0 = treeWithFinal0 wp0
>
>         -- thisBit is partially applied, after which we wrap the
>         -- function in a State constructor to make our :: m a
>         bsM' = mapM (State . thisBit) wordPrefixes
>         (bs',tree) = runState bsM' state0
>
>      -- an infinite stream is returned... because I can:
>      in cycle bs
      

With the following function, after we apply it to the word we're searching
for, it becomes a function :: state -> (val,state), suitable for the State
monad:

Takes a list of the last n-1 Bits (Bools) and traverses a Tree which we've
been using to keep track of the words we've already seen. We fold the Bit list
into the tree. When we get to the endo of the list, we look for a One. We
return the new bit as well as the new Tree:

  
> thisBit :: [ Bit ] -> Tree -> (Bit, Tree)
  
We're at a Zero bit,

> thisBit (False:bs) (Bs X o) = (True, Bs (treeWithFinal1 bs) o) -- last bit must be 1
> thisBit (False:bs) (Bs z o) = (id *** flip Bs o) (thisBit bs z)
  
...a One bit,
  
> thisBit (True:bs) (Bs z X) = (True, Bs z (treeWithFinal1 bs))
> thisBit (True:bs) (Bs z o) = (id *** Bs z) (thisBit bs o)

...or else propose a One for the last bit:

> thisBit [] (Bs _ o) = (b , (Bs z B))
>     -- we know that if the One bit has been seen (B) then we must
>     -- place a zero. we assume then that the Zero bit is (X):
>     where (b, z) = case o of
>                         -- this bit = 1, Zero branch = nil
>                         X -> (True, X) -- 1
>                         -- this bit = 0, Zero branch = last word bit
>                         _ -> (False, B) -- 0

TEST FUNCTIONS:

This code is copied from the previous post:

We use Bool for bits, where False ==> 0, True ==> 1:
  
> type Bit = Bool
  
  
Our garage-door lock model for testing the function:
  
> type Combo = [ Bit ]
> type Receiver = Combo -> Bool


True means access granted:
  
> programReceiver :: Combo -> Receiver
> programReceiver = isInfixOf

  
Test out our function:
  
> main = let secretCode = [True,True,False,False,True,
>                          False,True,False,True,True]
>            receiver = programReceiver secretCode
>            crackingStream = preferOneV2 10
>
>         in if receiver crackingStream
>             then print "WE'RE IN!"
>             else print "...bugs"
>

Stay tuned for one more post on these algorithms.