deforested bitstring generator

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
expand :: Int -> [Bool] -> [Bool]
expand n bs = take n $ go False (length bs) where
	bs' = map not (reverse bs)
	go b m | m >= n    = if b then bs' else bs
	       | otherwise = let m' = 2*m+1 in go False m' ++ [b] ++ go True m'

checksum :: Int -> [Bool] -> [Bool]
checksum n = go where
	go [] = []
	go other = let (b, rest) = extractBit (countTrailingZeros n) other
	           in b : go rest

	extractBit 0 (b:bs) = (b, bs)
	extractBit n bs = let (l, bs' ) = extractBit (n-1) bs
	                      (r, bs'') = extractBit (n-1) bs'
	                  in (l == r, bs'')

topLevel :: Int -> String -> String
topLevel n
	= map (\b -> if b then '1' else '0')
	. checksum n
	-- `take n . infinite` is a bit faster than `expand n`, but more memory-hungry
	. expand n
	. map ('1'==)

main = do
	putStrLn $ topLevel 20 "10000"
	putStrLn $ topLevel 272 "10001110011110000"
	putStrLn $ topLevel 35651584 "10001110011110000"