Personal tools

Anagrams

From HaskellWiki

(Difference between revisions)
Jump to: navigation, search
 
(updated to for 6.6.. minor cleanups.)
 
(One intermediate revision by one user not shown)
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) = do rem <- xs `minus` r
  +
return $! lft:rem
 
| (c1 == c2) && (i2 > i1) = fail "right has more chars than left"
 
| (c1 == c2) && (i2 > i1) = fail "right has more chars than left"
 
| (c1 > c2) = fail "right has chars not in left"
 
| (c1 > c2) = fail "right has chars not in left"
| (c1 < c2) = do rem <- xs `minus` r
 
return $! lft:rem
 
 
| 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>
  +
  +
[[Category:Code]]

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