fragmentary ideas ䷿ intellectual what-nots ䷷ and haskell programming ䷴

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…

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:

We’ll need to build a new tree from a list of bits, appending
a final bit (1, except for the initial tree):

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:

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:

We’re at a Zero bit,

…a One bit,

…or else propose a One for the last bit:

TEST FUNCTIONS:

———————————————————————-

This code is copied from the previous post:

We use Bool for bits, where False ==> 0, True ==> 1:

Our garage-door lock model for testing the function:

True means access granted:

Test out our function:

Stay tuned for one more post on these algorithms.

Update: a more efficient variation is implemented in Part 2.

A De Bruijn sequence is (for example) a cyclical list of characters such that every word of a given length appears once and only once in the sequence. Instead of using letters, you can have a De Bruijn sequence of bits. For example here is one possibility for a sequence in which every 3-bit word appears somewhere (you have to wrap around from the end for the final “words”):

00011101

In a sense we compress a dictionary of 2^3 = 8 3-bit words (or 24 bits) to a sequence of only 2^3 = 8 bits. There are some very simple algorithms for generating these kinds of sequences of bits, and I will implement two here: the “prefer one” algorithm and a subtle variation called “prefer opposite[PDF] by Alhakim“. Here is the author’s excellent description of the traditional Prefer One algorithm from the linked paper:

” The prefer-one algorithm is a very simple method amazingly capable of generating a full cycle. For any positive integer n ≥ 1, the algorithm puts n zeroes, and proceeds after this by proposing 1 for the next bit and accepting it when the word formed by the last n bits has not been encountered previously in the sequence, otherwise 0 is placed. The algorithm stops when both 0 and 1 do not bring a new word.”

And here is my haskell implementation. It works by creating a lazy array which we build from a list being generated by searching the earlier portions of the array that already have been defined. It’s very similar to the method I used in modeling the LZ77 algorithm.:

module Main
    where

import Data.Array
import Data.List(isInfixOf)


type Bit = Bool

preferOne :: Int -> [ Bit ]
preferOne n = 
    let upB = 2^n
        arr =  listArray (1, upB) (replicate n False ++ rest)
        
        -- since we use Bool for bits, we can say (not.alreadySeen):
        rest  =  map (not . alreadySeen) [n+1 .. upB]

        alreadySeen i = or $
              do let range = [ arr!i' | i' <- [i-n+1 .. i-1]] ++ [True] 
            
                 i1 <- [1..i-n] 
                 let rangeP = [ arr!i' | i' <- [i1 .. i1+n-1] ]
            
                 return (range == rangeP)

       -- an infinite stream is returned... because I can:          
    in cycle (elems arr)

The Prefer Opposite algorithm works on the same principle, but with a couple twists. In my words it is as follows:

Start with n zeros. Search for successive bits as follows:

propose to place the bit that is different from the previous bit: if the word formed by this bit has not been seen already, then choose it, else choose the same bit as the last. When 2^3-1 bit have been written, write a 1 for the final bit. and you’re done. (you can also keep track of how long a string of ones has been written; the sequence will always end with n ones)

Here is my implementation:

preferOpposite :: Int -> [ Bit ]
preferOpposite n = 
    let upB = 2^n
        arr =  array (1, upB) (final : inits ++ rest)
        
        -- we must specify the very last element of the sequence
        -- which will always be a One:
        final = (upB,True)
        inits = [ (i,False) | i<-[1..n] ]
        rest  =  map seqBit [n+1 .. upB-1]
        
        -- if the word generated by making the current bit the opposite
        -- of the previous has already been seen, we make the bit the
        -- same as the previous:
        seqBit i =  (i, nextB)
            where bP = arr!(i-1)  --previous bit
                  nextB | or (alreadySeen i bP) = bP --same as previous
                        | otherwise         = not bP --choose opposite

        --checks if the n-length string we would form by choosing the
        --opposite for the next bit is already present in the array:
        alreadySeen i bP = do
             let range = [ arr!i' | i' <- [i-n+1 .. i-1]] ++ [not bP] 
            
             i1 <- [1..i-n] 
             let rangeP = [ arr!i' | i' <- [i1 .. i1+n-1] ]
            
             return (range == rangeP)
                
    in cycle (elems arr)

Enough code for now, let’s talk about applications of the sequence. The most easily-approachable and interesting application to me applies to those keyed entry systems, such as electronic door locks, which accept a stream of keys (i.e. they unlock as soon as the correct key sequence is input, without any need to press an “enter” key). These mechanisms are very susceptible to attack with a De Bruijn sequence of key presses.

Since the above algorithms use a binary alphabet, as opposed to say a decimal one found on electronic keypads (check out Jonas Elfström’s blog post dealing with keypads with worn out letters for more on that), I will choose as my target an old-fashined garage door opener.

An old-style garage door opener remote has 8 binary DIP switches allowing 256 different code combinations. We will imagine the garage door is susceptible to a stream-based attack like the electronic lock we described.

We can model the garage door receiver as follows:

type Combo = [ Bit ]
type Receiver = Combo -> Bool

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

Now let’s test out our model with this main function:

main =  let secretCode = [False,False,True,False,True,False,True,True]
            receiver = programReceiver secretCode
            crackingStream = preferOne 8

         in if receiver crackingStream
            then print "WE'RE IN!"
            else print "...bugs"

Looks good!:

*Main> :main
“WE’RE IN!”

In the next couple posts I’ll explore improvements to the performance of these algorithms and maybe a few other things.

In Data.Array the function array :: (IArray a e, Ix i) => (i, i) -> [(i, e)] -> a i e takes the array bounds and an association list, and it produces an Array. The function allows you to build an Array by providing the elements in whatever order you choose, rather than from the first index to the last.

The function listArray is similar except that it assumes that the list is already ordered by index so there is no need to provide tuples of (index, value). Becase listArray actually uses zip internally to produce the tupled list, so the programmer can pass a list to listArray which exceeds the declared bounds of the array and the function will quietly drop the extra list tail:

Prelude Data.Array> listArray (1,3) ['a','b','c',undefined]
array (1,3) [(1,'a'),(2,'b'),(3,'c')]

But when a list that exceeds the specified bound is passed to array, it dies a horrible death:

Prelude Data.Array> array (1,3) [(1,'a'),(2,'b'),(3,'c'),(4,'d')]
array *** Exception: Error in array index

I think the array function should be modified by adding a simple take to automatically drop any excess list elements:

array (l,u) ies
    = let n = safeRangeSize (l,u)
      in unsafeArray (l,u)
                     [(safeIndex (l,u) n i, e) | (i, e) <- take n ies]

This change would bring the function into better alignment with other prelude functions which expect infinite lists and drop tails as needed. It can be argued that the programmer might want to know that he is passing too long a list to his function, in which case I think the safeRangeSize function, etc. should be eliminated.