Data commit

Task/Teacup-rim-text/Haskell/teacup-rim-text-1.hs

@@ -0,0 +1,31 @@
+import Data.List (groupBy, intercalate, sort, sortBy)
+import qualified Data.Set as S
+import Data.Ord (comparing)
+import Data.Function (on)
+
+main :: IO ()
+main =
+  readFile "mitWords.txt" >>= (putStrLn . showGroups . circularWords . lines)
+
+circularWords :: [String] -> [String]
+circularWords ws =
+  let lexicon = S.fromList ws
+  in filter (isCircular lexicon) ws
+
+isCircular :: S.Set String -> String -> Bool
+isCircular lex w = 2 < length w && all (`S.member` lex) (rotations w)
+
+rotations :: [a] -> [[a]]
+rotations = fmap <$> rotated <*> (enumFromTo 0 . pred . length)
+
+rotated :: [a] -> Int -> [a]
+rotated [] _ = []
+rotated xs n = zipWith const (drop n (cycle xs)) xs
+
+showGroups :: [String] -> String
+showGroups xs =
+  unlines $
+  intercalate " -> " . fmap snd <$>
+  filter
+    ((1 <) . length)
+    (groupBy (on (==) fst) (sortBy (comparing fst) (((,) =<< sort) <$> xs)))

Task/Teacup-rim-text/Haskell/teacup-rim-text-2.hs

@@ -0,0 +1,47 @@
+import Data.Function (on)
+import Data.List (groupBy, intercalate, sort, sortOn)
+import Data.Ord (comparing)
+
+main :: IO ()
+main =
+  readFile "mitWords.txt"
+    >>= ( putStrLn
+            . unlines
+            . fmap (intercalate " -> ")
+            . (circularOnly =<<)
+            . anagrams
+            . lines
+        )
+
+anagrams :: [String] -> [[String]]
+anagrams ws =
+  let harvest group px
+        | px = [fmap snd group]
+        | otherwise = []
+   in groupBy
+        (on (==) fst)
+        (sortOn fst (((,) =<< sort) <$> ws))
+        >>= (harvest <*> ((> 2) . length))
+
+circularOnly :: [String] -> [[String]]
+circularOnly ws
+  | (length h - 1) > length rs = []
+  | otherwise = [h : rs]
+  where
+    h = head ws
+    rs = filter (isRotation h) (tail ws)
+
+isRotation :: String -> String -> Bool
+isRotation xs ys =
+  xs
+    /= until
+      ( (||)
+          . (ys ==)
+          <*> (xs ==)
+      )
+      rotated
+      (rotated xs)
+
+rotated :: [a] -> [a]
+rotated [] = []
+rotated (x : xs) = xs <> [x]