# Difference between revisions of "Anagrams"

From HaskellWiki

Tomjaguarpaw (talk | contribs) (Deleting page that hasn't been updated for over 10 years) |
m (Reverted edits by Tomjaguarpaw (talk) to last revision by Ptolomy) |
||

Line 1: | Line 1: | ||

+ | <haskell> | ||

+ | module Main (main) where | ||

+ | import System.Environment (getArgs) | ||

+ | import Data.Char (toUpper,isAlpha) | ||

+ | import Data.List (sortBy) | ||

+ | import Data.Ord (comparing) | ||

+ | import qualified Data.ByteString.Char8 as B | ||

+ | |||

+ | data CharCount = CharCount !Char !Int deriving (Show, Eq) | ||

+ | data WordData = WordData B.ByteString [CharCount] deriving (Show, Eq) | ||

+ | |||

+ | main = do | ||

+ | [n] <- getArgs | ||

+ | wl <- B.readFile n | ||

+ | user <- B.getLine | ||

+ | let results = findAnagrams (makeWordList wl) (countChars user) | ||

+ | B.putStr . B.unlines . map B.unwords $ results | ||

+ | |||

+ | findAnagrams :: [WordData] -> [CharCount] -> [[B.ByteString]] | ||

+ | findAnagrams [] _ = [] | ||

+ | findAnagrams lst@((WordData bs cc):rest) qcc = | ||

+ | case (qcc `minus` cc) of | ||

+ | Nothing -> remaining | ||

+ | Just [] -> [bs]:remaining | ||

+ | Just x -> map ((:) bs) (findAnagrams lst x) ++ remaining | ||

+ | where remaining = findAnagrams rest qcc | ||

+ | |||

+ | minus :: (Monad m) => [CharCount] -> [CharCount] -> m [CharCount] | ||

+ | minus x [] = return x | ||

+ | minus [] _ = fail "can't subtract from empty" | ||

+ | minus (lft@(CharCount c1 i1):xs) r@((CharCount c2 i2):ys) | ||

+ | | (c1 == c2) && (i2 == i1) = xs `minus` ys | ||

+ | | (c1 == c2) && (i2 < i1) = do rem <- xs `minus` ys | ||

+ | return $! (CharCount c1 (i1 - i2)):rem | ||

+ | | (c1 < c2) = do rem <- xs `minus` r | ||

+ | return $! lft:rem | ||

+ | | (c1 == c2) && (i2 > i1) = fail "right has more chars than left" | ||

+ | | (c1 > c2) = fail "right has chars not in left" | ||

+ | | otherwise = error "Bad condition" | ||

+ | |||

+ | countChars :: B.ByteString -> [CharCount] | ||

+ | countChars = map counts . B.group . B.sort . B.map toUpper . B.filter isAlpha | ||

+ | where counts x = CharCount (B.head x) (B.length x) | ||

+ | |||

+ | makeWordList :: B.ByteString -> [WordData] | ||

+ | makeWordList = map (\w -> WordData w (countChars w)) . sortBy (flip (comparing B.length)) . B.words | ||

+ | </haskell> | ||

+ | |||

+ | [[Category:Code]] |

## Latest revision as of 15:19, 6 February 2021

```
module Main (main) where
import System.Environment (getArgs)
import Data.Char (toUpper,isAlpha)
import Data.List (sortBy)
import Data.Ord (comparing)
import qualified Data.ByteString.Char8 as B
data CharCount = CharCount !Char !Int deriving (Show, Eq)
data WordData = WordData B.ByteString [CharCount] deriving (Show, Eq)
main = do
[n] <- getArgs
wl <- B.readFile n
user <- B.getLine
let results = findAnagrams (makeWordList wl) (countChars user)
B.putStr . B.unlines . map B.unwords $ results
findAnagrams :: [WordData] -> [CharCount] -> [[B.ByteString]]
findAnagrams [] _ = []
findAnagrams lst@((WordData bs cc):rest) qcc =
case (qcc `minus` cc) of
Nothing -> remaining
Just [] -> [bs]:remaining
Just x -> map ((:) bs) (findAnagrams lst x) ++ remaining
where remaining = findAnagrams rest qcc
minus :: (Monad m) => [CharCount] -> [CharCount] -> m [CharCount]
minus x [] = return x
minus [] _ = fail "can't subtract from empty"
minus (lft@(CharCount c1 i1):xs) r@((CharCount c2 i2):ys)
| (c1 == c2) && (i2 == i1) = xs `minus` ys
| (c1 == c2) && (i2 < i1) = do rem <- xs `minus` ys
return $! (CharCount c1 (i1 - i2)):rem
| (c1 < c2) = do rem <- xs `minus` r
return $! lft:rem
| (c1 == c2) && (i2 > i1) = fail "right has more chars than left"
| (c1 > c2) = fail "right has chars not in left"
| otherwise = error "Bad condition"
countChars :: B.ByteString -> [CharCount]
countChars = map counts . B.group . B.sort . B.map toUpper . B.filter isAlpha
where counts x = CharCount (B.head x) (B.length x)
makeWordList :: B.ByteString -> [WordData]
makeWordList = map (\w -> WordData w (countChars w)) . sortBy (flip (comparing B.length)) . B.words
```