# Anagrams

### From HaskellWiki

(Difference between revisions)

DonStewart (Talk | contribs) m (category) |
(updated to for 6.6.. minor cleanups.) |
||

Line 4: | Line 4: | ||

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

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

− | import Control.Monad (liftM) |
+ | import Data.Ord (comparing) |

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

− | + | ||

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

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

− | + | ||

− | main :: IO () |
+ | main = do |

− | main = |
+ | [n] <- getArgs |

− | do n <- head `fmap` getArgs |
+ | wl <- B.readFile n |

− | wl <- liftM makeWordList $ B.readFile n |
+ | user <- B.getLine |

− | user <- liftM countChars B.getLine |
+ | let results = findAnagrams (makeWordList wl) (countChars user) |

− | case (findAnagrams wl user) of |
+ | B.putStr . B.unlines . map B.unwords $ results |

− | [] -> print "No anagrams." |
||

− | x -> B.putStr . B.unlines . map B.unwords $ x |
||

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

Line 25: | Line 25: | ||

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

where remaining = findAnagrams rest qcc |
where remaining = findAnagrams rest qcc |
||

− | + | ||

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

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

Line 33: | Line 33: | ||

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

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

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

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

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

return $! lft:rem |
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" |
| otherwise = error "Bad condition" |
||

− | + | ||

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

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

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

− | + | ||

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

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

− | where bsLenCmp x y = compare (B.length y) (B.length x) |
||

</haskell> |
</haskell> |

## Latest revision as of 11:08, 25 October 2006

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