Phonecodes in Haskell (was Re: Python from Wise Guy's Viewpoint)

From: Adrian Hey (ahey_at_NoSpicedHam.iee.org)
Date: 10/26/03 

Date: Sun, 26 Oct 2003 10:53:17 +0000

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 ks@(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
Quantcast