Difference between revisions of "Anagrams"
From HaskellWiki
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 
+  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 
+  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 

−  [] > 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 
 (c1 < c2) = do rem < xs `minus` r 

return $! lft:rem 
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. 
+  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 
+  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