Data commit

Task/Textonyms/Haskell/textonyms-1.hs

@@ -0,0 +1,71 @@
+import Data.Char (toUpper)
+import Data.Function (on)
+import Data.List (groupBy, sortBy)
+import Data.Maybe (fromMaybe, isJust, isNothing)
+
+toKey :: Char -> Maybe Char
+toKey ch
+  | ch < 'A' = Nothing
+  | ch < 'D' = Just '2'
+  | ch < 'G' = Just '3'
+  | ch < 'J' = Just '4'
+  | ch < 'M' = Just '5'
+  | ch < 'P' = Just '6'
+  | ch < 'T' = Just '7'
+  | ch < 'W' = Just '8'
+  | ch <= 'Z' = Just '9'
+  | otherwise = Nothing
+
+toKeyString :: String -> Maybe String
+toKeyString st
+  | any isNothing mch = Nothing
+  | otherwise = Just $ map (fromMaybe '!') mch
+  where
+    mch = map (toKey . toUpper) st
+
+showTextonym :: [(String, String)] -> String
+showTextonym ts =
+  fst (head ts)
+    ++ " => "
+    ++ concat
+      [ w ++ " "
+        | (_, w) <- ts
+      ]
+
+main :: IO ()
+main = do
+  let src = "unixdict.txt"
+  contents <- readFile src
+  let wordList = lines contents
+      keyedList =
+        [ (key, word)
+          | (Just key, word) <-
+              filter (isJust . fst) $
+                zip (map toKeyString wordList) wordList
+        ]
+      groupedList =
+        groupBy ((==) `on` fst) $
+          sortBy (compare `on` fst) keyedList
+      textonymList = filter ((> 1) . length) groupedList
+  mapM_ putStrLn $
+    [ "There are "
+        ++ show (length keyedList)
+        ++ " words in "
+        ++ src
+        ++ " which can be represented by the digit key mapping.",
+      "They require "
+        ++ show (length groupedList)
+        ++ " digit combinations to represent them.",
+      show (length textonymList) ++ " digit combinations represent Textonyms.",
+      "",
+      "Top 5 in ambiguity:"
+    ]
+      ++ fmap
+        showTextonym
+        ( take 5 $
+            sortBy (flip compare `on` length) textonymList
+        )
+      ++ ["", "Top 5 in length:"]
+      ++ fmap
+        showTextonym
+        (take 5 $ sortBy (flip compare `on` (length . fst . head)) textonymList)

Task/Textonyms/Haskell/textonyms-2.hs

@@ -0,0 +1,90 @@
+import Data.Function (on)
+import Data.List (groupBy, maximum, sortBy, sortOn)
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe)
+import Data.Ord (comparing)
+
+------------------------ TEXTONYMS -----------------------
+
+digitEncoded ::
+  M.Map Char Char ->
+  [String] ->
+  [(String, String)]
+digitEncoded dict =
+  mapMaybe $
+    ((>>=) . traverse (`M.lookup` dict))
+      <*> curry Just
+
+charDict :: M.Map Char Char
+charDict =
+  M.fromList $
+    concat $
+      zipWith
+        (fmap . flip (,))
+        (head . show <$> [2 ..])
+        (words "abc def ghi jkl mno pqrs tuv wxyz")
+
+definedSamples ::
+  Int ->
+  [[(String, String)]] ->
+  [[(String, String)] -> Int] ->
+  [[[(String, String)]]]
+definedSamples n xs fs =
+  [take n . flip sortBy xs] <*> (flip . comparing <$> fs)
+
+--------------------------- TEST -------------------------
+main :: IO ()
+main = do
+  let fp = "unixdict.txt"
+  s <- readFile fp
+  let encodings = digitEncoded charDict $ lines s
+      codeGroups =
+        groupBy
+          (on (==) snd)
+          . sortOn snd
+          $ encodings
+      textonyms = filter ((1 <) . length) codeGroups
+  mapM_
+    putStrLn
+    [ "There are "
+        <> show (length encodings)
+        <> " words in "
+        <> fp
+        <> " which can be represented\n"
+        <> "by the digit key mapping.",
+      "\nThey require "
+        <> show (length codeGroups)
+        <> " digit combinations to represent them.",
+      show (length textonyms)
+        <> " digit combinations represent textonyms.",
+      ""
+    ]
+  let codeLength = length . snd . head
+      [ambiguous, longer] =
+        definedSamples
+          5
+          textonyms
+          [length, codeLength]
+      [wa, wl] =
+        maximum . fmap codeLength
+          <$> [ambiguous, longer]
+  mapM_ putStrLn $
+    "Five most ambiguous:" :
+    fmap (showTextonym wa) ambiguous
+      <> ( "" :
+           "Five longest:" :
+           fmap
+             (showTextonym wl)
+             longer
+         )
+
+------------------------- DISPLAY ------------------------
+showTextonym :: Int -> [(String, String)] -> String
+showTextonym w ts =
+  concat
+    [ rjust w ' ' (snd (head ts)),
+      " -> ",
+      unwords $ fmap fst ts
+    ]
+  where
+    rjust n c = (drop . length) <*> (replicate n c <>)