Hello
In the course of this thread mention of programming task from
Lutz Prechelt has been made (for the purposes of language
comparison..)
http://www.ipd.uka.de/~prechelt/phonecode/
AFAIK there's no data for Haskell solutions for this problem so
here's my effort (about 4 years too late:-) for the benefit of
those folk gathering hard data on this topic. (Code attached
to the bottom of this post)
$ghc -O -o phonecode Main.hs
$strip phonecode
$time ./phonecode woerter2 z1000.t > results.txt
real 0m6.330s
user 0m5.110s
sys 0m0.090s
This is using ghc 6.0 on 1.2 GHz Athlon running redhat 9.
This seems to compare quite favourably to the C solutions
mentioned in Lutz paper (albeit on a completely different
machine).
I count 63 lines of real Haskell here.
BTW, all type annotation has been commented out for the
convenience of lispers :-)
module Main (main) where
import System (getArgs)
import IO (stdout)
import Directory (doesFileExist)
import Char (toUpper,ord)
import Array (Array,array,(!),(//))
import Data.List (foldl')
import Data.PackedString (PackedString,packString,hPutPS)
-- Type Synonyms
type Key = Int
type Keys = [Key]
-- main :: IO ()
main = do
-- Get command line arguments and check they're legit
args <- getArgs
case args of
[wordz,numz] -> do wordzExists <- doesFileExist wordz
if wordzExists
then do numzExists <- doesFileExist numz
if numzExists
then do ws <- readFile wordz
ns <- readFile numz
process (lines ws) (lines ns)
else error ("Can't find " ++ numz)
else error ("Can't find " ++ wordz)
_ -> error "Invalid Command Line"
-- Process the input words and numbers
-- process :: [String] -> [String] -> IO ()
process ws ns = mapM_ (encodeNum (encodings (makeSTree ws))) ns
-- Output all encodings of a number
-- encodeNum :: (Keys -> [[Match]]) -> String -> IO ()
encodeNum lookUp cs = mapM_ printEnc (lookUp rawKeys)
where rawKeys = [ord c - ord '0' | c <- cs, c /='/', c /= '-' ]
printEnc ms = putStr cs >> putChar ':' >>
mapM_ printMatch ms >> putStrLn ""
printMatch (MatchK k) = putChar ' ' >> putStr (show k)
printMatch (MatchW w) = putChar ' ' >> hPutPS stdout w
-- Get the Key for a character (upper case only!)
-- getKey :: Char -> Key
getKey c = getKey' ckMap
where getKey' [] = error ("getKey: " ++ [c])
getKey' ((k,cs):xs) = if elem c cs then k else getKey' xs
ckMap = [(0,"E") ,(1,"JNQ"),(2,"RWX"),(3,"DSY"),(4,"FT")
,(5,"AM"),(6,"CIV"),(7,"BKU"),(8,"LOP"),(9,"GHZ")]
-- Match data type (either a single key or a word)
data Match = MatchK Key | MatchW !PackedString
-- Search Tree data type
newtype STree = STree (Array Key (STree,[Match]))
-- Initial value for Search Tree
-- sTree0 :: STree
sTree0 = STree (array (0,9) [(n,(sTree0,[]))| n <- [0..9]])
-- Make the search tree from a list of words
-- makeSTree :: [String] -> STree
makeSTree ws = foldl' putWord sTree0 pairs where
pairs = [let ps = packString w in ps `seq` (word2keys w, MatchW ps) | w<-
ws]
word2keys cs = [getKey (toUpper c) | c <- cs, c /= '"' , c /= '-' ]
putWord stree (keys,m) = put keys stree
where put [] _ = error "makeSTree: empty Keys"
put [k] (STree a) = let (t,ms) = a ! k
a' = a // [(k,(t,m:ms))]
in a' `seq` STree a'
put (k:ks) (STree a) = let (t,ms) = a ! k
t' = put ks t
a' = a // [(k,(t',ms))]
in t' `seq` a' `seq` STree a'
-- Get all matching word prefixes and key suffixes for list of keys
-- getWPrefixes :: STree -> Keys -> [([Match],Keys)]
getWPrefixes _ [] = []
getWPrefixes (STree a) (k:ks) = let (t,ms) = a ! k
in case ms of
[] -> getWPrefixes t ks
_ -> (ms,ks) : getWPrefixes t ks
-- Get all encodings for a number (list of keys)
-- encodings :: STree -> Keys -> [[Match]]
encodings top = enc where
enc [] = [[]]
enc ยทยท@(k:ks') = case getWPrefixes top ks of
[] -> [MatchK k : e | e <- enc' ks']
xs -> combine xs
-- This version does not allow key prefixes
enc' [] = [[]]
enc' ks = combine (getWPrefixes top ks)
-- Combine all prefixes/(encoded suffix) pairs
combine xs = concat [[p:e | p<-ps, e <- enc ks] | (ps,ks)<-xs]
Regards
--
Adrian Hey