1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
| > 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
|