Data commit

Task/De-Bruijn-sequences/Haskell/de-bruijn-sequences-1.hs

@@ -0,0 +1,26 @@
+import Data.List
+import Data.Map ((!))
+import qualified Data.Map as M
+
+-- represents a permutation in a cycle notation
+cycleForm :: [Int] -> [[Int]]
+cycleForm p = unfoldr getCycle $ M.fromList $ zip [0..] p
+  where
+    getCycle p
+      | M.null p = Nothing
+      | otherwise =
+          let Just ((x,y), m) = M.minViewWithKey p
+              c = if x == y then [] else takeWhile (/= x) (iterate (m !) y)
+          in Just (c ++ [x], foldr M.delete m c)
+
+-- the set of Lyndon words generated by inverse Burrows—Wheeler transform
+lyndonWords :: Ord a => [a] -> Int -> [[a]]
+lyndonWords s n = map (ref !!) <$> cycleForm perm
+  where
+    ref = concat $ replicate (length s ^ (n - 1)) s
+    perm = s >>= (`elemIndices` ref)
+
+-- returns the de Bruijn sequence of order n for an alphabeth s
+deBruijn :: Ord a => [a] -> Int -> [a]
+deBruijn s n = let lw = concat $ lyndonWords n s
+               in lw ++ take (n-1) lw

Task/De-Bruijn-sequences/Haskell/de-bruijn-sequences-2.hs

@@ -0,0 +1,15 @@
+import Control.Monad (replicateM)
+
+main = do
+  let symbols = ['0'..'9']
+  let db = deBruijn symbols 4
+  putStrLn $ "The length of de Bruijn sequence: " ++ show (length db)
+  putStrLn $ "The first 130 symbols are:\n" ++ show (take 130 db)
+  putStrLn $ "The last 130 symbols are:\n" ++ show (drop (length db - 130) db)
+
+  let words = replicateM 4 symbols
+  let validate db  = filter (not . (`isInfixOf` db)) words
+  putStrLn $ "Words not in the sequence: " ++ unwords (validate db)
+
+  let db' = a ++ ('.': tail b) where (a,b) = splitAt 4444 db
+  putStrLn $ "Words not in the corrupted sequence: " ++ unwords (validate db')

Task/De-Bruijn-sequences/Haskell/de-bruijn-sequences-3.hs

@@ -0,0 +1,29 @@
+import Control.Monad.State
+import Data.Array (Array, listArray, (!), (//))
+import qualified Data.Array as A
+
+deBruijn :: [a] -> Int -> [a]
+deBruijn s n =
+  let
+    k = length s
+
+    db :: Int -> Int -> State (Array Int Int) [Int]
+    db t p =
+      if t > n
+      then
+        if n `mod` p == 0
+        then get >>= \a -> return [ a ! k | k <- [1 .. p]]
+        else return []
+      else do
+        a <- get
+        x <- setArray t (a ! (t-p)) >> db (t+1) p
+        a <- get
+        y <- sequence [ setArray t j >> db (t+1) t
+                      | j <- [a ! (t-p) + 1 .. k - 1] ]
+        return $ x ++ concat y
+
+    setArray i x = modify (// [(i, x)])
+
+    seqn = db 1 1 `evalState` listArray (0, k*n-1) (repeat 0)
+
+  in [ s !! i | i <- seqn ++ take (n-1) seqn ]