DeBruijn Sequences pt.3 - The "Prefer Opposite" algorithm

This is the third post of mine on DeBruijn sequences, and is in preparation for another post to come which I hope should be an interesting investigation into a possible parallel algorithm. The first two posts are here and here.

This algorithm works identically to the Prefer One algorithm, however rather than choose a 1-bit if possible, we instead choose the opposite bit from the previous bit, if possible.

This has the effect of evening out the locations of the zeros and ones throughout the sequence. We will exploit this in a later post where I will explore a possible parallel algorithm, which should be interesting I hope!

Here’s the code…

> module Main
>     where
>
> import Data.List(tails)
> import Control.Monad.State
> import Control.Arrow
  
We use Bool for bits, where False ==> 0, True ==> 1:
  
> type Bit = Bool
  
  
We use a tree to search for the words already created in our bit stream:
  
> 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:

> treeWithFinal :: Bit -> [Bit] -> Tree
> treeWithFinal 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 which we use to search for
previously-seen words is passed in the State monad, behind the scenes,
with 'zipWithM', which in our case looks like:
  
    zipWithM :: (Bit -> [Bit] -> State Tree Bit) ->
                [Bit] ->
                [[Bit]] ->
                State Tree [Bit]
  
The state monad is a little tricky sometimes:
  
> preferOpposite :: Int -> [ Bit ]
> preferOpposite n =
>
>     -- the whole bit sequence, except for the final 1:
>     let bs = take (2^n-1) (replicate n False ++ bs')
>
>         -- list of (n-1)-bit words:
>         (wp0:wordPrefixes) = map (take (n-1)) (tails bs)
>
>         -- we know the first word is n 0's so we create our initial
>         -- tree from (n-1) 0's with a zero at the end:
>         state0 = treeWithFinal False wp0
>
>         -- we zipWith a word with it's previous bit (so that we
>         -- can know which bit is the opposite) passing along the
>         -- Tree with help from the State monad:
>         bsM' = zipWithM thisBit (False:bs') wordPrefixes
>         bs' = evalState bsM' state0
>
>      -- we place a 1 for the final bit:
>      in bs ++ [True]
  
If we wanted to be clever, we would have made the last line:
  
    in cycle (bs ++ [True])
  
...as the sequence is actually cyclic.
  
This helper function takes the previous bit and an n-1 bit word and returns
a function :: Tree -> (Bit,Tree), which takes the current search tree and
checks the current word to see if the last bit of the word should be one
or zero. The function :: Tree -> (Bit,Tree) is wrapped in the State
constructor, which is all you have to do to turn it into :: State Tree Bit
  
> thisBit :: Bit -> [ Bit ] -> State Tree Bit
  
The wrapper function splits up the input tuple and tuples up the returned
bit to make a proper St so that we can pass the last bit through the state
monad.

> thisBit bP = State . thisBit' where
>     bOpp = not bP
  
We start checking a word, moving down the tree:
  
>     thisBit' (False:bs) (Bs z o) = second (flip Bs o) (thisBit' bs z)
>     thisBit' (True:bs) (Bs z o) = second (Bs z) (thisBit' bs o)
  
...or we walked off end of branch, so return opposite bit, and attach
the rest of word to the tree:

>     thisBit' bs X = (bOpp, treeWithFinal bOpp bs)
      
...or we reached the end of our word, so we prefer the opposite for the last
bit, and check if it was seen:

>     thisBit' [] (Bs z o)
>         | bOpp = case o of -- opposite bit is 1 (True)
>                       X -> (bOpp,Bs z B)
>                       _ -> (bP ,Bs B B)
>         | otherwise = case z of
>                            X -> (bOpp,Bs B o)
>                            _ -> (bP ,Bs B B)
  
Finally, here are some functions to generate the actual sequences
in 0s and 1s:

> test = map (\x->if x then '1' else '0') . preferOpposite
>
> main = print $ test 10