tag:blogger.com,1999:blog-41558328999912200462024-03-08T08:39:35.785-08:00Liang's BlogY. Lianghttp://www.blogger.com/profile/14752853638197350267noreply@blogger.comBlogger7125tag:blogger.com,1999:blog-4155832899991220046.post-37994151451621054742009-05-04T21:11:00.000-07:002009-05-04T21:19:32.348-07:00A Lambda Calculus Interpreter in Haskell<div>I will present a Lambda Calculus interpreter in this post. It is an (almost) exact translation from the ML code in chapter 9 of <span class="Apple-style-span" style="font-style: italic;">ML for the Working Programmer</span> by Lawrence C. Paulson. This program incorporates a parser to convert string to an internal represenation of lambda expression, a pretty printer to reconvert the internal represenation to a formatted string in a human-readable form, and two evaluation functions (lazy and strict respectively) to reduce a given lambda expression to its normal form.</div><div><br /></div><div>Enjoy.</div><div><br /></div><div>Code below:</div><div>------------</div><div><br /></div><div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">module Lci (</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,reader -- String -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,pr -- Lambda -> String</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,byValue -- Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,byName -- Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,evalV -- String -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,evalN -- String -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,tryV -- String -> IO ()</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,tryN -- String -> IO ()</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ) where</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Parser</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">import Text.ParserCombinators.Parsec</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">import qualified Text.ParserCombinators.Parsec.Token as T</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">import Text.ParserCombinators.Parsec.Language (emptyDef)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Pretty Printing</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">import qualified Text.PrettyPrint as PP</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">import Text.PrettyPrint (Doc, (<>), (<+>))</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Environment</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">import qualified Data.Map as Map</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">import Data.Maybe</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Data</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">data Lambda = Free String</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> | Bound Int</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> | Abs String Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> | App Lambda Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> deriving (Eq, Show, Read)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">type Env = Map.Map String Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> </span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Parser</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">abstract :: Int -> String -> Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">abstract i s (Free s') | s == s' = Bound i</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> | otherwise = Free s'</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">abstract _ _ (Bound i) = Bound i</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">abstract i s (Abs s' t) = Abs s' (abstract (i+1) s t)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">abstract i s (App t1 t2) = App (abstract i s t1) (abstract i s t2)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Abstraction over several free variables</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">absList :: [String] -> Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">absList xs t = foldr (\x acc -> Abs x (abstract 0 x acc)) t xs</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Application of t to several terms </span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">appList :: Lambda -> [Lambda] -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">appList = foldl (\acc x -> App acc x)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Shift a term's non-local indices by i</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">shift :: Int -> Int -> Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">shift 0 _ u = u</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">shift i d u@(Free s) = u</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">shift i d u@(Bound j) = if j >= d then Bound (j+i) else Bound j</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">shift i d (Abs s t) = Abs s (shift i (d+1) t)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">shift i d (App t1 t2) = App (shift i d t1) (shift i d t2)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Substitution for bound variable</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">subst :: Int -> Lambda -> Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">subst _ _ t@(Free _) = t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">subst i u t@(Bound i') | i' <></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> | i' == i = shift i 0 u</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> | otherwise = Bound (i' - 1) -- non-local to t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">subst i u (Abs s t') = Abs s (subst (i+1) u t')</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">subst i u (App t1 t2) = App (subst i u t1) (subst i u t2)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Lexer & Parser</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">lexer :: T.TokenParser ()</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">lexer = T.makeTokenParser emptyDef</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">whiteSpace= T.whiteSpace lexer</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">lexeme = T.lexeme lexer</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">symbol = T.symbol lexer</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">parens = T.parens lexer</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">identifier= T.identifier lexer</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">p_term :: Parser Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">p_term = do{ symbol "^"</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; ids <- many1 identifier</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; symbol "."</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; t <- p_term</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; return $ absList ids t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> }</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> <|> do{ t <- p_atom</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; ts <- many p_atom</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; return $ appList t ts</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> }</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">p_atom :: Parser Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">p_atom = do{ s <- identifier</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; return $ Free s</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> }</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> <|> parens p_term</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">p_top :: Parser Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">p_top = do{ whiteSpace</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; t <- p_term</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; eof</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ; return t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> }</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">reader :: String -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">reader input = case (parse p_top "" input) of</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> Left err -> error $ show err</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> Right x -> x</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Pretty Printing</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Free variables in a term</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">vars :: Lambda -> [String]</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">vars (Free s) = [s]</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">vars (Bound _) = []</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">vars (Abs s t) = vars t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">vars (App t u) = vars t ++ vars u</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Rename variable "a" to avoid clashes</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">rename bs a = if a `elem` bs then rename bs (a ++ "'") else a</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Remove leading lambdas, return bound variable names</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">stripAbs t = strip [] t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> where strip bs (Abs s t) =</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> let b = rename (vars t) s</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> in strip (b:bs) (subst 0 (Free b) t)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> strip bs u = (reverse bs, u)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_term :: Lambda -> Doc</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_term (Free s) = PP.text s</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_term (Bound i) = PP.text "??UNMATCHED INDEX??"</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_term t@(Abs _ _) = </span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> let (b:bs, u) = stripAbs t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> spaceJoin b z = " " ++ b ++ z</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> binder = "^" ++ b ++ (foldr spaceJoin ". " bs)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> in PP.sep [PP.text binder, pr_term u]</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_term t = PP.sep (pr_app t)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> </span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_app (App t u) = pr_app t ++ [PP.nest 1 (pr_atom u)]</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_app t = [pr_atom t]</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_atom (Free s) = PP.text s</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr_atom t = PP.nest 1 $ PP.parens $ pr_term t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr :: Lambda -> String</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">pr = PP.render . pr_term</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Reduction</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">eval (App t1 t2) =</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> case eval t1 of</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> (Abs a u) -> eval (subst 0 (eval t2) u)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> t -> App t (eval t2)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">eval t = t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">byValue :: Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">byValue t = bodies (eval t)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> where bodies (Abs a t) = Abs a (byValue t)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> bodies (App t u) = App (bodies t) (bodies u)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> bodies t = t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">headNF (Abs a t) = Abs a (headNF t)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">headNF (App t u) = </span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> case headNF t of</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> (Abs a t') -> headNF (subst 0 u t')</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> u' -> App u' u</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">headNF t = t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">byName :: Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">byName = args . headNF</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> where args (Abs a t) = Abs a (args t)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> args (App t u) = App (args t) (byName u)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> args t = t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-----------------------------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Standard Environment (Lambda Prelude)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-----------------------------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Substitution for free variables from environment</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">inst :: Env -> Lambda -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">inst env t@(Free s) = fromMaybe t (Map.lookup s env)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">inst env t@(Bound i) = t</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">inst env (Abs s t') = Abs s (inst env t')</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">inst env (App t1 t2) = App (inst env t1) (inst env t2)</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">insertEnv :: Env -> (String, String) -> Env</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">insertEnv env (a, s) = Map.insert a (reader s) env</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">stdEnv = foldl insertEnv Map.empty [</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> -- booleans</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ("true", "^x y. x"), ("false", "^x y. y")</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,("if", "^p x y. p x y")</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> -- pairs</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,("pair", "^x y f. f x y")</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ,("fst", "^p. p true"), ("snd", "^p. p false")</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> ]</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-- Evaluators</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">-------------------</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">evalWith :: (Lambda -> Lambda) -> Env -> String -> Lambda</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">evalWith fn env = fn . inst env . reader</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"> </span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">evalV = evalWith byValue stdEnv</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">evalN = evalWith byName stdEnv</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';"><br /></span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">tryV = putStrLn . pr . evalV</span></span></div><div><span class="Apple-style-span" style="color: rgb(51, 51, 153);"><span class="Apple-style-span" style="font-family: 'courier new';">tryN = putStrLn . pr . evalN</span></span></div></div>Y. Lianghttp://www.blogger.com/profile/14752853638197350267noreply@blogger.com1tag:blogger.com,1999:blog-4155832899991220046.post-8007478563278140882009-02-06T05:49:00.000-08:002009-02-06T05:53:57.181-08:00Delayed-Branch-Slot Optimization and the Result<h2><span class="Apple-style-span" style="font-size: 19px; ">Background</span><br /></h2> <p class="MsoNormal"><o:p> An Instruction Set Simulator (ISS) is a program that takes stream of target instructions and simulates the effects of execution of the code stream on a host machine. Usually the target and the host are of different architectures, but nothing prevents you from running a, say, x86 simulator on a PC. Base on this definition, an ISS is nothing but an ordinary interpreter, and from the fact that it interprets machine code instead of high level languages, hence freeing from lexical analysis, parsing, byte-code compilation, garbage collection…, etc., all sorts of complications one normally finds in modern high level language interpreters, it seems that an ISS is a trivial (often labor-intensive though) construct to make.</o:p></p> <p class="MsoNormal"><o:p> Well, not quite so…</o:p></p> <p class="MsoNormal"><o:p> The tricky thing is that you want your simulator runs fast, really fast. A naive implementation with a central “read-evaluate-loop” structure could hardly exceed the speed of interpreting over 10 million target instructions per second (MIPS). While 10 MIPS may be okay for running standalone, user-mode applications, it is hardly enough for running an OS, which easily takes billions of instructions just to boot up.</o:p></p> <p class="MsoNormal"><o:p> Threaded-code is an elegant control structure that strike at a sweet point of balance between implementation complexity and run-time efficiency. A threaded-code ISS with is capable of running system level code at about 100 MIPS with full accuracy at the instruction level.</o:p></p> <p class="MsoNormal"><o:p> This is the technique we actually adopted in developing an ISS for a RISC processor. While happy with the end performance, we want to see if we can squeeze more runtime efficiency out of it. One thing that made me feel less satisfactory in our implementation was the way we coped with <i style="mso-bidi-font-style:normal">branch delay slot</i>.</o:p></p> <p class="MsoNormal"><o:p> Conceptually, processor executes instructions sequentially, one following another, until it reaches a branch or jump instruction, where it branches to an effective address other than the one following it. However, in some RISC machines, to better use of the pipeline structure, branching is delayed <i style="mso-bidi-font-style:normal">after</i> the execution of the instruction immediately following it. The position following the branch instruction is called the <i style="mso-bidi-font-style:normal">branch delay slot</i>. This is one of the few occasions where hardware natures becoming visible to programmers.</o:p></p> <p class="MsoNormal"><o:p> One way to simulate this behavior -- perhaps the most obvious one -- is to keep a Boolean valued flag, whose value is set by every branch/jump instruction (if the branch/jump is taken), and cleared otherwise. This flag is checked at the end of the service routine of every normal instruction. If it is set, we jump to a pre-calculated target address; if it is not, we simple increase the instruction pointer and move on to the next instruction.</o:p></p> <p class="MsoNormal"><o:p> A slightly better solution that can do away with the conditional statement associated with the Boolean flag is to maintain two instruction pointers, <span style="font-family:"Courier New"">ip</span> and <span style="font-family:"Courier New"">next_ip</span> at the same time, so that we always jump to the address pointed to by <span style="font-family:"Courier New"">next_ip</span> after the execution of every instruction.</o:p></p> <p class="MsoNormal"><o:p> Both of these two solutions use an auxiliary variable to simulate the correct execution flow of the processor in the presence of branch delay slot. In either case, a runtime overhead is added for <i style="mso-bidi-font-style: normal">every</i> normal instruction, even though <i style="mso-bidi-font-style: normal">most</i> instructions do not locate in the delay slot.</o:p></p> <p class="MsoNormal"><o:p> Can we do better?</o:p></p> <h3>Idea for Optimization</h3> <p class="MsoNormal"><o:p> It did not take long before I realized that whether an instruction locates in a delayed slot is a matter that can be resolved in the decoding phase, e.g., it is independent of the state of the processor. Hence for each instruction that may possibly reside in the delayed slot, we create two specialized intermediate form instructions. The instruction service routines of the two specialized forms have most of their interpretative code in common but have different dispatching semantics. Instructions that do not locate in delayed slot will simply increase the instruction pointer and jumping to the instruction service routine of the next instruction. Instructions that locates in the delayed slot in general must check if the branch was taken (for conditional branch/jump instructions) and if so, set the instruction pointer to the target address calculated by the previous branch/jump instruction and transfer control to the service routine of the instruction at that address. If the branch is not taken, the behavior is the same as those that do not locates in the delayed slot.</o:p></p> <p class="MsoNormal"><o:p> In essence, this is another application of the <i style="mso-bidi-font-style:normal">instruction specialization</i> optimization technique typically found in instruction set simulators where an intermediate form of decoded instructions are utilized to avoid decoding the same stream of instructions over and over again. The difference is, in this case, instead of specializing on the bit pattern of an individual instruction group, we specialize over the spatial position of individual instructions relative to special (branch/jump) instructions.</o:p></p> <h3>Implementation</h3> <p class="MsoNormal"><o:p> Once the idea is clear, the implementation is quite straight forward.</o:p></p> <p class="MsoNormal"><o:p> We translate raw instruction stream into the decoded form on a page-by-page basis. A page is the smallest unit (normally 4KB, but may vary in modern architectures) that the Memory Management Unit (MMU) of the processor breaks up the memory address space for critical OS-related operations such as address translation, protection, etc., as a whole. Doing so has the extra benefit that in-page branching, which is predominately the usual case against off-page branching, does not need to go through the MMU – an expensive operation that could degrade the performance of the simulation significantly.</o:p></p> <p class="MsoNormal"><o:p> While decoding the raw instructions of a certain page, we maintain a local flag that is set when the instruction under decoding is a branch/jump instruction and is cleared otherwise. This flag is checked for every instruction: if it is set, we choose the delayed-slot version of the interpretive code of that instruction; if it is clear, we use the normal version of the interpretive code of that instruction. Note that this is very much the same as we did in the pre-optimization implementation, only this time it is done in the decoding phase instead of run time.</o:p></p> <p class="MsoNormal"><o:p> The only problem of that scheme is what to do with the first instruction on a page. Where does the initial value of that flag come from? While cross-page branch delay slot is uncommon, the architecture does not exclude this from happening, so we must handle this in our interpreter.</o:p></p> <p class="MsoNormal"><o:p> The answer is that we maintain a similar, but non-local flag in each of the decoded page, whose value is determined by the last instruction on that page. The local flag then gets its initial value from that state flag of its previous page. If its previous page does not exist when this page is decoded, then the initial value is by default set to false.</o:p></p> <p class="MsoNormal"><o:p> The correctness of this algorithm is based on the following reasoning: if the first instruction on a page is in delayed slot, then we must get here from executing instructions of its immediate previous page, which must have its decoded page in memory with the in-slot flag being correctly set.</o:p></p> <p class="MsoNormal"><o:p> <span class="Apple-style-span" style="font-size: 19px; font-weight: bold; ">Result</span></o:p></p> <p class="MsoNormal"><o:p> Happy with this discovery (I am not aware of anyone coming up with a similar idea to the best of my knowledge. This is a very specific domain of application anyway.), I re-implemented the original threaded-code instruction set simulator with the new algorithm and expect a somewhere close to 20% performance improvement.</o:p></p> <p class="MsoNormal"><o:p> How did I come up with this 20% number? Simple. The intrinsic figure of merit of the performance of an instruction set simulator is the average number of host instructions executed to interpret one target instruction. This number is independent of the clock frequency of the host processor. While it certainly depends on the instruction set architecture of the host processor, we have reason to believe that it does not vary significantly from architectures to architectures. I estimate that on average our original simulator executes 20 host instructions to interrupt one target instruction, and by specializing non-branching instructions with regard on their relative position in the code stream, I could at least reduce 3 host instructions on average. One does not need to be particularly good at math to compute the final result then. It is a very rough, but nevertheless valid estimation.</o:p></p> <p class="MsoNormal"><span style="mso-spacerun:yes"> To my surprise, the benchmark shows that the new simulator executes at 105 MIPS (Millions Instructions per Second) against 115 MIPS of the original one. The delayed-slot “optimization” I have labored with actually brings down the performance by almost ten percent!</span></p> <p class="MsoNormal"><o:p> How do I explain the seemingly contradictory result?</o:p></p> <p class="MsoNormal"><o:p> It could be that the time the simulator spends on decoding is not negligible comparing with the time it spends on executing. In this case, the overhead incurred in the new simulator in the decoding phase could offset what it gains in the execution phase. But a more likely reason that I suspect is that the interpretive code has been restructured inadvertently in the new simulator for a less-optimal memory layout for utilizing the cache system of the host machine. This is just a guess. I don’t have a definite answer to this puzzle yet.</o:p></p> <p class="MsoNormal"><o:p> <span class="Apple-style-span" style="font-size: 19px; font-weight: bold; ">Conclusion</span></o:p></p> <p class="MsoNormal"><o:p> So what is the lesson of this story?</o:p></p> <p class="MsoNormal"><o:p> While not directly relevant, and by no means did I regret for this small adventure to optimize an already fast simulator, I could not help but thinking of the famous remark D. Knuth made many years ago: “premature optimization is the root of all evil”.</o:p></p> <p class="MsoNormal"><o:p> Optimization is hard, harder than most of us would expect. A simple solution is often the best solution. When optimization is necessary, we should try to optimize “in the large”. For example, by replacing the simple, classic read-evaluate-loop control structure with direct-threaded code, we get an order of magnitude performance boost. Surely it is worth the effort for a performance critical application. But don’t waste your time on tiny piece optimizations that you thought would work. Even when it works, it may take its penalty on something else, say, code clarity, which is more important in an engineering sense than a, say, 5% increase of runtime efficiency.</o:p></p> <p class="MsoNormal"><o:p> Let me end up here by quoting from another great mind: “keep things simple, but no simpler.”</o:p></p> <p class="MsoNormal"><br /></p>Y. Lianghttp://www.blogger.com/profile/14752853638197350267noreply@blogger.com0tag:blogger.com,1999:blog-4155832899991220046.post-36688559236779971502009-01-04T21:28:00.000-08:002009-01-04T21:30:47.477-08:00Useful Shell Shortcuts<span class="Apple-style-span" style="font-family: 'times new roman'; "><p>Here are some small, simple, but surprisingly useful shell commands that I use everyday. Hopefully, you may find it useful too.</p><h2>Change Directory and List Content</h2><pre><code>alias cd..='cd ..' alias cd...='cd ../..' cl() { cd $1 && ls } </code></pre><p>The functions of these commands are self-explanatory and may seem trivial on the first sight. But since <code>ls</code> and <code>cd</code> are the most common shell commands we use everyday, these shortcuts will save you a tremendously amount of key stokes in the long run.</p><h2>List Sub-directories Only</h2><pre><code>alias lsd=alias lsd='ls -F | grep / | sed -e '\''s/\///g'\'' | column' </code></pre><p>Say that you are in a large code base (for instance, the Linux kernel) and you want to see if a particular sub-directory exists but do not want to clutter the output from the <code>ls</code> command with all the ordinary files, then this shortcut comes in handy.</p><h2>Trash instead of Delete</h2><pre><code>alias trash="mv -t ~/.Trash --backup=t" </code></pre><p>This command moves files into a specific location instead of delete them permanently. It is the shell version t<em><span class="Apple-style-span" style="font-family: georgia;"><span class="Apple-style-span" style="font-style: normal;"><span class="Apple-style-span" style="font-size: small;">rash can</span></span></span></em> utility usually found in a GUI environment. Note that in Ubuntu, you might want to replace <code>~/.Trash</code> with<code>~/.local/share/Trash/files</code>, the standard location for trashed objects.</p><p><br /></p></span>Y. Lianghttp://www.blogger.com/profile/14752853638197350267noreply@blogger.com0tag:blogger.com,1999:blog-4155832899991220046.post-91564359523176074002008-12-16T20:21:00.000-08:002008-12-16T21:06:11.154-08:00A Simple Symbolic Differentiation Program in Haskell<pre><span class="comment"><span class="Apple-style-span" style="color: rgb(0, 0, 0); font-family: Georgia; font-size: 16px; white-space: normal;">This program is inspired from, again, <a href="http://mitpress.mit.edu/sicp/">SICP</a>. Comparing to the Scheme code (section 2.3.2 of SICP), my program has a front-end parser that converts external representation (a String) of an expression to its internal representation (AST). The purpose of writing this program is to get familiar with the <a href="http://legacy.cs.uu.nl/daan/parsec.html">Parsec</a> library in particular and to gain a better understanding of monadic parsers in general.</span></span></pre><pre><span class="comment"><span class="Apple-style-span" style="color: rgb(0, 0, 0); font-family: Georgia; font-size: 16px; white-space: normal;">Loading the program in Hugs, a simple session go like this:</span></span></pre><pre><span class="Apple-style-span" style="font-family: Georgia; font-size: 16px; white-space: normal;"><pre><span class="Apple-style-span" style="white-space: normal; "><span class="Apple-style-span" style="font-family: 'courier new';"><span class="Apple-style-span" style="font-size: small;">Main> deriv_x "x+3"</span></span></span></pre><pre><span class="Apple-style-span" style="white-space: normal; "><span class="Apple-style-span" style="font-family: 'courier new';"><span class="Apple-style-span" style="font-size: small;">1</span></span></span></pre><pre><span class="Apple-style-span" style="white-space: normal; "><span class="Apple-style-span" style="font-family: 'courier new';"><span class="Apple-style-span" style="font-size: small;">Main> deriv_x "x*y"</span></span></span></pre><pre><span class="Apple-style-span" style="white-space: normal; "><span class="Apple-style-span" style="font-family: 'courier new';"><span class="Apple-style-span" style="font-size: small;">y</span></span></span></pre><pre><span class="Apple-style-span" style="white-space: normal; "><span class="Apple-style-span" style="font-family: 'courier new';"><span class="Apple-style-span" style="font-size: small;">Main> deriv_x "(x+3)*x*y"</span></span></span></pre><pre><span class="Apple-style-span" style="white-space: normal; "><span class="Apple-style-span" style="font-family: 'courier new';"><span class="Apple-style-span" style="font-size: small;">((x)+((x)+(3)))*(y)</span></span></span></pre><pre><span class="Apple-style-span" style="white-space: normal; "><span class="Apple-style-span" style="font-family: 'courier new';"><span class="Apple-style-span" style="font-size: small;">Main> deriv_x "(x+3)^2"</span></span></span></pre><pre><span class="Apple-style-span" style="white-space: normal; "><span class="Apple-style-span" style="font-family: 'courier new';"><span class="Apple-style-span" style="font-size: small;">(2)*((x)+(3))</span></span></span></pre></span></pre><pre><span class="Apple-style-span" style="font-family: Georgia; font-size: 16px; white-space: normal;"><pre><span class="Apple-style-span" style="font-family: Georgia; white-space: normal;">The output is unfortunately cluttered with a lot of unnecessary parenthesizes. This can be solved by writing a specific function that normalize expressions to a canonical form. I am sure there is well-defined algorithm to do this but as I said above, writing a well-polished program doing differentiations really is not the purpose here. The complete program is list below:</span></pre></span></pre><pre><span class="comment">-- Simple symbolic differentiation program</span><span class="keyword"><br /></span></pre><pre><span class="keyword"><span class="Apple-style-span" style="color: rgb(0, 0, 0);">module</span></span> <span class="conid">Main</span> <span class="keyword">where</span><br /><br /><span class="keyword">import</span> <span class="conid">Text</span><span class="varop">.</span><span class="conid">ParserCombinators</span><span class="varop">.</span><span class="conid">Parsec</span><br /><span class="keyword">import</span> <span class="conid">Text</span><span class="varop">.</span><span class="conid">ParserCombinators</span><span class="varop">.</span><span class="conid">Parsec</span><span class="varop">.</span><span class="conid">Expr</span><br /><span class="keyword">import</span> <span class="keyword">qualified</span> <span class="conid">Text</span><span class="varop">.</span><span class="conid">ParserCombinators</span><span class="varop">.</span><span class="conid">Parsec</span><span class="varop">.</span><span class="conid">Token</span> <span class="keyword">as</span> <span class="conid">T</span><br /><span class="keyword">import</span> <span class="conid">Text</span><span class="varop">.</span><span class="conid">ParserCombinators</span><span class="varop">.</span><span class="conid">Parsec</span><span class="varop">.</span><span class="conid">Language</span><br /><br /><span class="comment">-- Symbolic Expression</span><br /><br /><span class="keyword">type</span> <span class="conid">Symbol</span> <span class="keyglyph">=</span> <span class="conid">Char</span><br /><br /><span class="keyword">data</span> <span class="conid">Expr</span> <span class="keyglyph">=</span> <span class="conid">Add</span> <span class="conid">Expr</span> <span class="conid">Expr</span><br /> <span class="keyglyph">|</span> <span class="conid">Mul</span> <span class="conid">Expr</span> <span class="conid">Expr</span><br /> <span class="keyglyph">|</span> <span class="conid">Exp</span> <span class="conid">Expr</span> <span class="conid">Integer</span><br /> <span class="keyglyph">|</span> <span class="conid">Var</span> <span class="conid">Symbol</span><br /> <span class="keyglyph">|</span> <span class="conid">Num</span> <span class="conid">Integer</span><br /> <span class="keyword">deriving</span> <span class="layout">(</span><span class="conid">Eq</span><span class="layout">)</span><br /><br /><span class="keyword">instance</span> <span class="conid">Show</span> <span class="conid">Expr</span> <span class="keyword">where</span><br /> <span class="varid">show</span> <span class="varid">e</span> <span class="keyglyph">=</span> <span class="keyword">case</span> <span class="varid">e'</span> <span class="keyword">of</span><br /> <span class="conid">Num</span> <span class="varid">x</span> <span class="keyglyph">-></span> <span class="varid">show</span> <span class="varid">x</span><br /> <span class="conid">Var</span> <span class="varid">x</span> <span class="keyglyph">-></span> <span class="keyglyph">[</span><span class="varid">x</span><span class="keyglyph">]</span><br /> <span class="conid">Add</span> <span class="varid">u</span> <span class="varid">v</span> <span class="keyglyph">-></span> <span class="str">"("</span> <span class="varop">++</span> <span class="varid">show</span> <span class="varid">u</span> <span class="varop">++</span> <span class="str">")"</span> <span class="varop">++</span> <span class="str">"+"</span> <span class="varop">++</span> <span class="str">"("</span> <span class="varop">++</span> <span class="varid">show</span> <span class="varid">v</span> <span class="varop">++</span> <span class="str">")"</span><br /> <span class="conid">Mul</span> <span class="varid">u</span> <span class="varid">v</span> <span class="keyglyph">-></span> <span class="str">"("</span> <span class="varop">++</span> <span class="varid">show</span> <span class="varid">u</span> <span class="varop">++</span> <span class="str">")"</span> <span class="varop">++</span> <span class="str">"*"</span> <span class="varop">++</span> <span class="str">"("</span> <span class="varop">++</span> <span class="varid">show</span> <span class="varid">v</span> <span class="varop">++</span> <span class="str">")"</span><br /> <span class="conid">Exp</span> <span class="varid">u</span> <span class="varid">n</span> <span class="keyglyph">-></span> <span class="str">"("</span> <span class="varop">++</span> <span class="varid">show</span> <span class="varid">u</span> <span class="varop">++</span> <span class="str">")"</span> <span class="varop">++</span> <span class="str">"^"</span> <span class="varop">++</span> <span class="varid">show</span> <span class="varid">n</span><br /> <span class="keyword">where</span> <span class="varid">e'</span> <span class="keyglyph">=</span> <span class="varid">simplify</span> <span class="varid">e</span><br /><br /><span class="comment">-- Deriving</span><br /><br /><span class="definition">deriv_</span> <span class="keyglyph">::</span> <span class="conid">Symbol</span> <span class="keyglyph">-></span> <span class="conid">Expr</span> <span class="keyglyph">-></span> <span class="conid">Expr</span><br /><span class="definition">deriv_</span> <span class="varid">x</span> <span class="varid">e</span> <span class="keyglyph">=</span> <span class="varid">simplify</span> <span class="varop">$</span> <span class="varid">deriv__</span> <span class="varid">x</span> <span class="varid">e</span><br /> <span class="keyword">where</span> <span class="varid">deriv__</span> <span class="keyword">_</span> <span class="layout">(</span><span class="conid">Num</span> <span class="keyword">_</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="num">0</span><br /> <span class="varid">deriv__</span> <span class="varid">x</span> <span class="layout">(</span><span class="conid">Var</span> <span class="varid">s</span><span class="layout">)</span> <span class="keyglyph">|</span> <span class="layout">(</span><span class="varid">s</span> <span class="varop">==</span> <span class="varid">x</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="num">1</span><br /> <span class="keyglyph">|</span> <span class="varid">otherwise</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="num">0</span><br /> <span class="varid">deriv__</span> <span class="varid">x</span> <span class="layout">(</span><span class="conid">Add</span> <span class="varid">u</span> <span class="varid">v</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Add</span> <span class="layout">(</span><span class="varid">deriv__</span> <span class="varid">x</span> <span class="varid">u</span><span class="layout">)</span> <span class="layout">(</span><span class="varid">deriv__</span> <span class="varid">x</span> <span class="varid">v</span><span class="layout">)</span><br /> <span class="varid">deriv__</span> <span class="varid">x</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="varid">u</span> <span class="varid">v</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Add</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="layout">(</span><span class="varid">deriv__</span> <span class="varid">x</span> <span class="varid">u</span><span class="layout">)</span> <span class="varid">v</span><span class="layout">)</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="varid">u</span> <span class="layout">(</span><span class="varid">deriv__</span> <span class="varid">x</span> <span class="varid">v</span><span class="layout">)</span><span class="layout">)</span><br /> <span class="varid">deriv__</span> <span class="varid">x</span> <span class="layout">(</span><span class="conid">Exp</span> <span class="varid">u</span> <span class="varid">n</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Mul</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="layout">(</span><span class="conid">Num</span> <span class="varid">n</span><span class="layout">)</span> <span class="layout">(</span><span class="conid">Exp</span> <span class="varid">u</span> <span class="layout">(</span><span class="varid">n</span><span class="comment">-</span><span class="num">1</span><span class="layout">)</span><span class="layout">)</span><span class="layout">)</span> <span class="layout">(</span><span class="varid">deriv__</span> <span class="varid">x</span> <span class="varid">u</span><span class="layout">)</span><br /><br /><span class="comment">-- Expression Simplifier</span><br /><br /><span class="definition">simplify</span> <span class="keyglyph">::</span> <span class="conid">Expr</span> <span class="keyglyph">->;</span> <span class="conid">Expr</span><br /><span class="definition">simplify</span> <span class="varid">e</span> <span class="keyglyph">=</span> <span class="keyword">let</span> <span class="varid">e'</span> <span class="keyglyph">=</span> <span class="varid">simplify'</span> <span class="varid">e</span><br /> <span class="keyword">in</span> <span class="keyword">if</span> <span class="varid">e</span> <span class="varop">==</span> <span class="varid">e'</span> <span class="keyword">then</span> <span class="varid">e</span> <span class="keyword">else</span> <span class="varid">simplify</span> <span class="varid">e'</span><br /> <span class="keyword">where</span><br /> <span class="varid">simplify'</span> <span class="varid">e</span><span class="keyglyph">@</span><span class="layout">(</span><span class="conid">Num</span> <span class="varid">n</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="varid">e</span><br /> <span class="varid">simplify'</span> <span class="varid">e</span><span class="keyglyph">@</span><span class="layout">(</span><span class="conid">Var</span> <span class="varid">x</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="varid">e</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Add</span> <span class="layout">(</span><span class="conid">Num</span> <span class="num">0</span><span class="layout">)</span> <span class="varid">u</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="varid">u</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Add</span> <span class="varid">u</span> <span class="layout">(</span><span class="conid">Num</span> <span class="num">0</span><span class="layout">)</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="varid">u</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Add</span> <span class="layout">(</span><span class="conid">Num</span> <span class="varid">n</span><span class="layout">)</span> <span class="layout">(</span><span class="conid">Num</span> <span class="varid">m</span><span class="layout">)</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="layout">(</span><span class="varid">n</span> <span class="varop">+</span> <span class="varid">m</span><span class="layout">)</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Add</span> <span class="varid">u</span> <span class="varid">v</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Add</span> <span class="layout">(</span><span class="varid">simplify'</span> <span class="varid">u</span><span class="layout">)</span> <span class="layout">(</span><span class="varid">simplify'</span> <span class="varid">v</span><span class="layout">)</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="layout">(</span><span class="conid">Num</span> <span class="num">0</span><span class="layout">)</span> <span class="varid">v</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="num">0</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="varid">u</span> <span class="layout">(</span><span class="conid">Num</span> <span class="num">0</span><span class="layout">)</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="num">0</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="layout">(</span><span class="conid">Num</span> <span class="num">1</span><span class="layout">)</span> <span class="varid">v</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="varid">v</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="varid">u</span> <span class="layout">(</span><span class="conid">Num</span> <span class="num">1</span><span class="layout">)</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="varid">u</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="layout">(</span><span class="conid">Num</span> <span class="varid">n</span><span class="layout">)</span> <span class="layout">(</span><span class="conid">Num</span> <span class="varid">m</span><span class="layout">)</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="layout">(</span><span class="varid">n</span> <span class="varop">*</span> <span class="varid">m</span><span class="layout">)</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Mul</span> <span class="varid">u</span> <span class="varid">v</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Mul</span> <span class="layout">(</span><span class="varid">simplify'</span> <span class="varid">u</span><span class="layout">)</span> <span class="layout">(</span><span class="varid">simplify'</span> <span class="varid">v</span><span class="layout">)</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Exp</span> <span class="varid">u</span> <span class="num">0</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="num">1</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Exp</span> <span class="varid">u</span> <span class="num">1</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="varid">simplify</span> <span class="varid">u</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Exp</span> <span class="layout">(</span><span class="conid">Num</span> <span class="varid">m</span><span class="layout">)</span> <span class="varid">n</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Num</span> <span class="layout">(</span><span class="varid">m</span> <span class="varop">^</span> <span class="varid">n</span><span class="layout">)</span><br /> <span class="varid">simplify'</span> <span class="layout">(</span><span class="conid">Exp</span> <span class="varid">u</span> <span class="varid">n</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Exp</span> <span class="layout">(</span><span class="varid">simplify</span> <span class="varid">u</span><span class="layout">)</span> <span class="varid">n</span><br /><br /><span class="comment">-- Parser</span><br /><br /><span class="definition">lang</span> <span class="keyglyph">=</span> <span class="conid">T</span><span class="varop">.</span><span class="varid">makeTokenParser</span> <span class="varid">emptyDef</span><br /><br /><span class="definition">natural</span> <span class="keyglyph">=</span> <span class="conid">T</span><span class="varop">.</span><span class="varid">natural</span> <span class="varid">lang</span><br /><span class="definition">operator</span> <span class="varid">c</span> <span class="keyglyph">=</span> <span class="conid">T</span><span class="varop">.</span><span class="varid">lexeme</span> <span class="varid">lang</span> <span class="layout">(</span><span class="varid">char</span> <span class="varid">c</span><span class="layout">)</span><br /><span class="definition">variable</span> <span class="keyglyph">=</span> <span class="conid">T</span><span class="varop">.</span><span class="varid">lexeme</span> <span class="varid">lang</span> <span class="varid">lower</span><br /><br /><br /><span class="definition">expr</span> <span class="keyglyph">=</span> <span class="varid">buildExpressionParser</span> <span class="varid">table</span> <span class="varid">factor</span><br /> <?> <span class="str">"expression"</span><br /><br /><span class="definition">mkNode</span> <span class="keyglyph">::</span> <span class="layout">(</span><span class="conid">Expr</span> <span class="keyglyph">-></span> <span class="conid">Expr</span> <span class="keyglyph">-></span> <span class="conid">Expr</span><span class="layout">)</span> <span class="keyglyph">-></span> <span class="conid">Expr</span> <span class="keyglyph">-></span> <span class="conid">Expr</span> <span class="keyglyph">-></span> <span class="conid">Expr</span><br /><span class="definition">mkNode</span> <span class="varid">op</span> <span class="varid">t1</span> <span class="varid">t2</span> <span class="keyglyph">=</span> <span class="varid">op</span> <span class="varid">t1</span> <span class="varid">t2</span><br /><br /><span class="definition">mkAdd</span> <span class="keyglyph">=</span> <span class="varid">mkNode</span> <span class="conid">Add</span><br /><span class="definition">mkMul</span> <span class="keyglyph">=</span> <span class="varid">mkNode</span> <span class="conid">Mul</span><br /><br /><span class="definition">mkExp</span> <span class="keyglyph">::</span> <span class="conid">Expr</span> <span class="keyglyph">-></span> <span class="conid">Expr</span> <span class="keyglyph">-></span> <span class="conid">Expr</span><br /><span class="definition">mkExp</span> <span class="varid">e</span> <span class="layout">(</span><span class="conid">Num</span> <span class="varid">n</span><span class="layout">)</span> <span class="keyglyph">=</span> <span class="conid">Exp</span> <span class="varid">e</span> <span class="varid">n</span><br /><span class="definition">mkExp</span> <span class="varid">e</span> <span class="keyword">_</span> <span class="keyglyph">=</span> <span class="varid">error</span> <span class="str">"exponent must be a number"</span><br /><br /><span class="definition">table</span> <span class="keyglyph">=</span> <span class="keyglyph">[</span><span class="keyglyph">[</span><span class="varid">op</span> <span class="chr">'^'</span> <span class="layout">(</span><span class="varid">mkExp</span><span class="layout">)</span> <span class="conid">AssocRight</span><span class="keyglyph">]</span><br /> <span class="layout">,</span><span class="keyglyph">[</span><span class="varid">op</span> <span class="chr">'*'</span> <span class="layout">(</span><span class="varid">mkMul</span><span class="layout">)</span> <span class="conid">AssocLeft</span><span class="keyglyph">]</span><br /> <span class="layout">,</span><span class="keyglyph">[</span><span class="varid">op</span> <span class="chr">'+'</span> <span class="layout">(</span><span class="varid">mkAdd</span><span class="layout">)</span> <span class="conid">AssocLeft</span><span class="keyglyph">]</span><br /> <span class="keyglyph">]</span><br /> <span class="keyword">where</span><br /> <span class="varid">op</span> <span class="varid">c</span> <span class="varid">f</span> <span class="varid">assoc</span><br /> <span class="keyglyph">=</span> <span class="conid">Infix</span> <span class="layout">(</span><span class="keyword">do</span><span class="layout">{</span> <span class="varid">operator</span> <span class="varid">c</span><span class="layout">;</span> <span class="varid">return</span> <span class="varid">f</span><span class="layout">}</span> <<span class="varop">?></span> <span class="str">"operator"</span><span class="layout">)</span> <span class="varid">assoc</span><br /><br /><span class="definition">factor</span> <span class="keyglyph">=</span> <span class="conid">T</span><span class="varop">.</span><span class="varid">parens</span> <span class="varid">lang</span> <span class="varid">expr</span><br /> <<span class="varop">|></span> <span class="keyword">do</span> <span class="layout">{</span><span class="varid">v</span> <span class="keyglyph"><-</span> <span class="varid">natural</span><span class="layout">;</span> <span class="varid">return</span> <span class="varop">$</span> <span class="conid">Num</span> <span class="varid">v</span> <span class="layout">}</span><br /> <<span class="varop">|></span> <span class="keyword">do</span> <span class="layout">{</span><span class="varid">v</span> <span class="keyglyph"><-</span> <span class="varid">variable</span><span class="layout">;</span> <span class="varid">return</span> <span class="varop">$</span> <span class="conid">Var</span> <span class="varid">v</span><span class="layout">}</span><br /> <<span class="varop">?></span> <span class="str">"factor"</span><br /><br /><span class="comment">-- Driver</span><br /><br /><span class="definition">parseExpr</span> <span class="keyglyph">::</span> <span class="conid">String</span> <span class="keyglyph">-></span> <span class="conid">Expr</span><br /><span class="definition">parseExpr</span> <span class="varid">input</span> <span class="keyglyph">=</span> <span class="keyword">case</span> <span class="varid">parse</span> <span class="varid">expr</span> <span class="str">""</span> <span class="varid">input</span> <span class="keyword">of</span><br /> <span class="conid">Left</span> <span class="varid">err</span> <span class="keyglyph">-></span> <span class="varid">error</span> <span class="varop">$</span> <span class="str">"parse error at "</span> <span class="varop">++</span> <span class="varid">show</span> <span class="varid">err</span><br /> <span class="conid">Right</span> <span class="varid">out</span> <span class="keyglyph">-></span> <span class="varid">out</span><br /><br /><span class="definition">deriv_x</span> <span class="keyglyph">=</span> <span class="varid">deriv_</span> <span class="chr">'x'</span> <span class="varop">.</span> <span class="varid">parseExpr</span><br /></pre>Y. Lianghttp://www.blogger.com/profile/14752853638197350267noreply@blogger.com1tag:blogger.com,1999:blog-4155832899991220046.post-68373391314030406822008-12-11T21:31:00.000-08:002008-12-11T21:39:48.781-08:00"Game of Life" in Haskell<p>This post includes a Haskell implementation of Conway’s <a href="http://en.wikipedia.org/wiki/Conway%27s_Game_of_Life"><em>game of life</em></a>. There is nothing particularly fancy here and the implementation is not of the most efficient one either but, hi, this is my first interactive Haskell program (and it is not hard at all).</p><br /><pre><span style="color:Green;"><u>type</u></span> Size <span style="color:Red;">=</span> Int<br /><span style="color:Green;"><u>type</u></span> Cell <span style="color:Red;">=</span> <span style="color:Cyan;">(</span>Int<span style="color:Cyan;">,</span> Int<span style="color:Cyan;">)</span><br /><br /><span style="color:Green;"><u>type</u></span> Board <span style="color:Red;">=</span> <span style="color:Red;">[</span>Cell<span style="color:Red;">]</span><br /><span style="color:Green;"><u>data</u></span> Life <span style="color:Red;">=</span> Life Size Board<br /> <br /><span style="color:Green;"><u>instance</u></span> Show Life <span style="color:Green;"><u>where</u></span><br /><br /> show <span style="color:Cyan;">(</span>Life size board<span style="color:Cyan;">)</span> <span style="color:Red;">=</span><br /> <span style="color:Red;">[</span><span style="color:Green;"><u>if</u></span> c <span style="color:Cyan;">==</span> size <span style="color:Green;"><u>then</u></span> <span style="color:Magenta;">'\n'</span><br /><br /> <span style="color:Green;"><u>else</u></span> <span style="color:Green;"><u>if</u></span> <span style="color:Cyan;">(</span>r<span style="color:Cyan;">,</span> c<span style="color:Cyan;">)</span> <span style="color:Cyan;">`elem`</span> board <span style="color:Green;"><u>then</u></span> <span style="color:Magenta;">'@'</span><br /><br /> <span style="color:Green;"><u>else</u></span> <span style="color:Magenta;">'-'</span> <span style="color:Red;">|</span> r <span style="color:Red;"><-</span> <span style="color:Red;">[</span><span style="color:Magenta;">0</span><span style="color:Red;">..</span>size<span style="color:Blue;">-</span><span style="color:Magenta;">1</span><span style="color:Red;">]</span><span style="color:Cyan;">,</span><br /><br /> c <span style="color:Red;"><-</span> <span style="color:Red;">[</span><span style="color:Magenta;">0</span><span style="color:Red;">..</span>size<span style="color:Red;">]</span><span style="color:Red;">]</span><br /><br /><span style="color:Blue;">next_life</span> <span style="color:Red;">::</span> Life <span style="color:Red;">-></span> Life<br /><br /><span style="color:Blue;">next_life</span> <span style="color:Cyan;">(</span>Life size board<span style="color:Cyan;">)</span> <span style="color:Red;">=</span> Life size new_board <span style="color:Green;"><u>where</u></span><br /> new_board <span style="color:Red;">=</span> survivors <span style="color:Cyan;">++</span> births<br /> survivors <span style="color:Red;">=</span> <span style="color:Red;">[</span>cell <span style="color:Red;">|</span> cell <span style="color:Red;"><-</span> board<span style="color:Cyan;">,</span><br /><br /> <span style="color:Green;"><u>let</u></span> n <span style="color:Red;">=</span> living_neighbors cell<br /> <span style="color:Green;"><u>in</u></span> n <span style="color:Cyan;">==</span> <span style="color:Magenta;">2</span> <span style="color:Cyan;">||</span> n <span style="color:Cyan;">==</span> <span style="color:Magenta;">3</span><span style="color:Red;">]</span><br /><br /> births <span style="color:Red;">=</span> <span style="color:Red;">[</span><span style="color:Cyan;">(</span>r<span style="color:Cyan;">,</span>c<span style="color:Cyan;">)</span> <span style="color:Red;">|</span> r <span style="color:Red;"><-</span> <span style="color:Red;">[</span><span style="color:Magenta;">0</span><span style="color:Red;">..</span>size<span style="color:Blue;">-</span><span style="color:Magenta;">1</span><span style="color:Red;">]</span><span style="color:Cyan;">,</span><br /><br /> c <span style="color:Red;"><-</span> <span style="color:Red;">[</span><span style="color:Magenta;">0</span><span style="color:Red;">..</span>size<span style="color:Blue;">-</span><span style="color:Magenta;">1</span><span style="color:Red;">]</span><span style="color:Cyan;">,</span><br /> <span style="color:Green;"><u>let</u></span> cell <span style="color:Red;">=</span> <span style="color:Cyan;">(</span>r<span style="color:Cyan;">,</span> c<span style="color:Cyan;">)</span><br /><br /> <span style="color:Green;"><u>in</u></span> <span style="color:Cyan;">(</span>not <span style="color:Cyan;">(</span>cell <span style="color:Cyan;">`elem`</span> board<span style="color:Cyan;">)</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">&&</span> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>living_neighbors cell<span style="color:Cyan;">)</span> <span style="color:Cyan;">==</span> <span style="color:Magenta;">3</span><span style="color:Cyan;">)</span><span style="color:Red;">]</span><br /><br /> living_neighbors cell <span style="color:Red;">=</span> length <span style="color:Cyan;">$</span> filter is_living <span style="color:Cyan;">$</span> neighbors cell<br /> is_living cell <span style="color:Red;">=</span> cell <span style="color:Cyan;">`elem`</span> board<br /> neighbors <span style="color:Cyan;">(</span>r<span style="color:Cyan;">,</span> c<span style="color:Cyan;">)</span> <span style="color:Red;">=</span> <span style="color:Red;">[</span><span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>r <span style="color:Blue;">-</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">,</span> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>c <span style="color:Blue;">-</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">)</span><span style="color:Cyan;">)</span><span style="color:Cyan;">,</span><br /><br /> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>r <span style="color:Blue;">-</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">,</span> c<span style="color:Cyan;">)</span><span style="color:Cyan;">,</span><br /><br /> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>r <span style="color:Blue;">-</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">,</span> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>c <span style="color:Cyan;">+</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">)</span><span style="color:Cyan;">)</span><span style="color:Cyan;">,</span><br /><br /> <span style="color:Cyan;">(</span>r <span style="color:Cyan;">,</span> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>c <span style="color:Blue;">-</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">)</span><span style="color:Cyan;">)</span><span style="color:Cyan;">,</span><br /><br /> <span style="color:Cyan;">(</span>r <span style="color:Cyan;">,</span> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>c <span style="color:Cyan;">+</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">)</span><span style="color:Cyan;">)</span><span style="color:Cyan;">,</span><br /><br /> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>r <span style="color:Cyan;">+</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">,</span> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>c <span style="color:Blue;">-</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">)</span><span style="color:Cyan;">)</span><span style="color:Cyan;">,</span><br /><br /> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>r <span style="color:Cyan;">+</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">,</span> c<span style="color:Cyan;">)</span><span style="color:Cyan;">,</span><br /><br /> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>r <span style="color:Cyan;">+</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">,</span> <span style="color:Cyan;">(</span><span style="color:Cyan;">(</span>c <span style="color:Cyan;">+</span> <span style="color:Magenta;">1</span><span style="color:Cyan;">)</span> <span style="color:Cyan;">`mod`</span> size<span style="color:Cyan;">)</span><span style="color:Cyan;">)</span><span style="color:Red;">]</span><br /><br /><span style="color:Blue;">interactive</span> <span style="color:Red;">::</span> Life <span style="color:Red;">-></span> IO ()<br /><span style="color:Blue;">interactive</span> life<br /> <span style="color:Red;">=</span> <span style="color:Green;"><u>do</u></span> print life<br /> c <span style="color:Red;"><-</span> getChar<br /> <span style="color:Green;"><u>if</u></span> c <span style="color:Cyan;">==</span> <span style="color:Magenta;">'q'</span> <span style="color:Green;"><u>then</u></span><br /><br /> return ()<br /> <span style="color:Green;"><u>else</u></span><br /> interactive <span style="color:Cyan;">$</span> next_life life<br /><br /><br /></pre><br /><br /><p>Loading the above program into Hugs and an interactive session goes like this:</p><pre><code>Main> interactive $ Life 5 [(1,3), (2,1), (2,3), (3,2), (3,3)]<br />-----<br />---@-<br />-@-@-<br />--@@-<br />-----<br /><br /><br />-----<br />--@--<br />---@@<br />--@@-<br />-----<br /><br /><br />-----<br />---@-<br />----@<br />--@@@<br />-----<br /><br /><br />-----<br />-----<br />--@-@<br />---@@<br />---@-<br /><br />q<br /><br />Main><br /></code></pre><p>Have fun!</p>Y. Lianghttp://www.blogger.com/profile/14752853638197350267noreply@blogger.com0tag:blogger.com,1999:blog-4155832899991220046.post-58790225718466130142008-12-06T02:23:00.000-08:002008-12-09T04:50:43.256-08:00Huffman Tree Decoder<p class="MsoNormal"><o:p>Section 2.3.3 of <a href="http://mitpress.mit.edu/sicp/">SICP</a> contains a program that decodes messages from a pre-built Huffman tree.</o:p></p> <p class="MsoNormal"><o:p> </o:p></p> <p class="MsoNormal">The Scheme code:</p> <p class="MsoNormal"><o:p> </o:p></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">(define (make-leaf symbol weight)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(list 'leaf symbol weight))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">(define (leaf? object)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(eq? (car object) 'leaf))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">(define (symbol-leaf x) (cadr x))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p>(define (weight-leaf x) (caddr x))</o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">(define (make-code-tree left right)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(list left<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>right<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(append (symbols left) (symbols right))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(+ (weight left) (weight right))))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">(define (left-branch tree) (car tree))<o:p></o:p></span></p> <p class="MsoNormal"><span class="Apple-style-span" style=" ;font-family:'Courier New';font-size:15px;">(define (right-branch tree) (cadr tree)) </span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">(define (symbols tree)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(if (leaf? tree)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(list (symbol-leaf tree))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(caddr tree)))<o:p></o:p></span></p> <p class="MsoNormal"><span class="Apple-style-span" style=" ;font-family:'Courier New';font-size:15px;"><br /></span></p><p class="MsoNormal"><span class="Apple-style-span" style=" ;font-family:'Courier New';font-size:15px;">(define (weight tree)</span><br /></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(if (leaf? tree)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(weight-leaf tree)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(cadddr tree))) </span></p> <p class="MsoNormal"><span class="Apple-style-span" style=" ;font-family:'Courier New';font-size:15px;"><br /></span></p><p class="MsoNormal"><span class="Apple-style-span" style=" ;font-family:'Courier New';font-size:15px;">(define (decode bits tree)</span><br /></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(define (decode-1 bits current-branch)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(if (null? bits)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>'()<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(let ((next-branch<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(choose-branch (car bits) current-branch)))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(if (leaf? next-branch)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(cons (symbol-leaf next-branch)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(decode-1 (cdr bits) tree))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(decode-1 (cdr bits) next-branch)))))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(decode-1 bits tree))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">(define (choose-branch bit branch)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(cond ((= bit 0) (left-branch branch))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>((= bit 1) (right-branch branch))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(else (error "bad bit -- CHOOSE-BRANCH" bit))))<o:p></o:p></span></p> <p class="MsoNormal"><o:p> </o:p></p> <p class="MsoNormal">The Haskell code that does the same thing:</p><p class="MsoNormal"> </p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">data Bit = B0 | B1<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>deriving (Eq, Ord)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">instance Show Bit where<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>show B0 = "0"<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>show B1 = "1"<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">type Symbol = Char<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">type Weight = Int<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">data Tree = Leaf Symbol Weight<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span><span style="mso-spacerun:yes"> </span>| Node [Symbol] Weight Tree Tree<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">decode :: Tree -> [Bit] -> [Symbol]<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">decode tree [] = []<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">decode tree bits = s : decode tree rest<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>where (s, rest) = decode1 tree bits<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">decode1 :: Tree -> [Bit] -> (Symbol, [Bit])<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">decode1 (Node _ _ (Leaf sym _) _<span style="mso-spacerun:yes"> </span><span style="mso-spacerun:yes"> </span>) (B0:rest) = (sym, rest)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">decode1 (Node _ _ left<span style="mso-spacerun:yes"> </span>_<span style="mso-spacerun:yes"> </span>) (B0:rest) = decode1 left rest<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">decode1 (Node _ _ _<span style="mso-spacerun:yes"> </span>(Leaf sym _)) (B1:rest) = (sym, rest)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">decode1 (Node _ _ _<span style="mso-spacerun:yes"> </span>right<span style="mso-spacerun:yes"> </span>) (B1:rest) = decode1 right rest<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">-- Test<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">sample_message :: [Bit]<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">sample_message = [B0, B1, B1, B0, B0, B1, B0, B1, B0, B1, B1, B1, B0]<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">sample_tree :: Tree<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">sample_tree = Node ['A', 'B', 'C', 'D'] 8<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(Leaf 'A' 4)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(Node ['B', 'C', 'D'] 4<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span><span style="mso-spacerun:yes"> </span>(Leaf 'B' 2)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(Node ['C', 'D'] 2<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(Leaf 'C' 1)<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><span style="mso-spacerun:yes"> </span>(Leaf 'D' 1)))<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;"><o:p> </o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">-- decode sample_tree sample_message<o:p></o:p></span></p> <p class="MsoNormal"><span style="Courier New"font-family:";font-size:11.0pt;">-- "ACABBDA"<o:p></o:p></span></p> <p class="MsoNormal"><o:p> </o:p></p> <p class="MsoNormal"><span class="Apple-style-span" style="font-weight: bold;">Comments:</span></p> <p class="MsoNormal">I think everybody will agree that the Haskell code is much cleaner and more concise than the corresponding Scheme code. I attribute the cleanness and conciseness to Haskell's algebraic data type and pattern matching structure: where in Scheme one express any data structure in lists in Haskell one defines data structures more naturally in data types; where in Scheme one fetch fields of data structures using <span class="Apple-style-span" style="font-style: italic;">ca(d*)r</span>, in Haskell one binds fields of data structures to formal parameters via pattern matching.<br /></p> <p class="MsoNormal"><o:p> </o:p></p> <p class="MsoNormal">During the course of learning Haskell, I come to the feeling that Scheme is the assembly language for functional programming comparing with Haskell (or ML and the like) in the sense that assembly languages are low-level comparing to C or even C++ in the imperative languages world. </p> <p class="MsoNormal"><o:p> </o:p></p> <p class="MsoNormal">Saying Scheme is a low-level language by no means implies that Scheme is a bad functional language. No. I thought and still believe that Scheme is the one of the most elegant programming language in the world. Just as learning an assembly language will help make one a better C programmer, learning Scheme will get one closer to the underlying computation model (Lambda Calculus) that underpins all functional programming languages, so that one can distinguish the essentials from the non-essentials and don't get lost in the complex constructs offered by a modern language like Haskell (However, I do think typing is something essential but totally missing in Scheme). </p> <p class="MsoNormal"><o:p> </o:p></p> <p class="MsoNormal">All I am saying is that Scheme remains as a good (perhaps the best) programming language for educational purpose, but for real-world product development, Haskell (or the ML family) is probably a better candidate.</p> <p class="MsoNormal"><o:p> </o:p></p> <p class="MsoNormal">P.S.:</p> <p class="MsoNormal"><a href="http://homepages.inf.ed.ac.uk/wadler/">Philip Walder</a> has a <a href="http://www.cs.kent.ac.uk/people/staff/dat/miranda/wadler87.pdf">paper </a><span class="Apple-style-span" style=" font-weight: bold; -webkit-border-horizontal-spacing: 2px; -webkit-border-vertical-spacing: 2px; font-family:Arial;"><span class="Apple-style-span" style=" font-weight: normal; -webkit-border-horizontal-spacing: 0px; -webkit-border-vertical-spacing: 0px; font-family:Georgia;">discussing the merit of statically typed, lazy functional programming languages (KRC/Miranda) over dynamically typed, eager evaluation languages (Scheme/Lisp). An enlightening reading.</span></span></p> <p class="MsoNormal"><br /></p> <p class="MsoNormal"><o:p> </o:p></p>Y. Lianghttp://www.blogger.com/profile/14752853638197350267noreply@blogger.com0tag:blogger.com,1999:blog-4155832899991220046.post-4717657254398704302008-11-30T20:42:00.000-08:002008-12-09T04:57:58.776-08:00Probabilistic Primitivity Testing<div>I have been learning Haskell and as an exercise once in a while I will pick up <a href="http://mitpress.mit.edu/sicp/">SICP</a> and try to implement some of the programs in Haskell. </div><div><br /></div><div>Section 1.2.6 of SICP contains the definition of a function that probabilistically tests if a given natural number <span class="Apple-style-span" style="font-style: italic;">n</span> is a prime based on Fermat's Little Theorem. Below is the Scheme code:</div><div><br /></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">(define (expmod base exp m)</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (cond ((= exp 0) 1)</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> ((even? exp)</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (remainder (square (expmod base (/ exp 2) m))</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> m))</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (else</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (remainder (* base (expmod base (- exp 1) m))</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> m)))) </span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"><br /></span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">(define (fermat-test n)</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (define (try-it a)</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (= (expmod a n n) a))</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (try-it (+ 1 (random (- n 1)))))</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"><br /></span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">(define (fast-prime? n times)</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (cond ((= times 0) true)</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> ((fermat-test n) (fast-prime? n (- times 1)))</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;"> (else false)))</span></span></div><div><br /></div><div>And here is the equivalent Haskell code that I wrote:</div><div><br /></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> import System.Random</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> import System.IO.Unsafe</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">></span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> fast_prime :: Integer -> Int -> Bool</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> fast_prime n times = and $ map fermat_test (mkRandomList n times)</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> where fermat_test a = expmod a n n == a</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> expmod base exp m </span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> | (exp == 0) = 1</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> | (even exp) = (square (expmod base (exp `div` 2) m)) `mod` m</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> | otherwise = (base * (expmod base (exp -1) m)) `mod` m</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> square a = a * a</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> </span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> mkRandomList :: Integer -> Int -> [Integer]</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> mkRandomList n len = </span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> take len $ </span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> unsafePerformIO $ </span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> do g <- getStdGen</span></span></div><div><span class="Apple-style-span" style="font-family:'courier new';"><span class="Apple-style-span" style="font-size:small;">> return $ randomRs (1, n - 1) g</span></span></div><div><br /></div><div>The major difference between the Haskell code and the Scheme code is the part dealing with the random number generator. Where in Scheme a simple call to <span class="Apple-style-span" style="font-style: italic;">random</span>() can do, in Haskell, I have to resort to monad, which makes the Haskell code less cleaner than its Scheme counterpart (which is usually not the case in my experience). But the part that makes me feel most uncomfortable is the call to <span class="Apple-style-span" style="font-style: italic;">unsafePerformIO </span>whose very existence implies something "incorrect" here. </div><div><br /></div><div>But I have my reasons: I do not want <span class="Apple-style-span" style="font-style: italic;">mkRandomList </span>itself to be a monad because that would force all the functions along the calling chain to be inside a monad which is way too clumsy from the point of view of the callers of that function (<span class="Apple-style-span" style="font-style: italic;">fast_prime </span>in this case). After all, conceptually <span class="Apple-style-span" style="font-style: italic;">mkRandomList </span>is a pure function whose very responsibility is to return a list of seemingly non-related numbers in a certain range. It is supposed to be used just once so it does not matter that subsequent call to it produce the same list.</div><div><br /></div><div>Or maybe there are better approaches that did not occur to me?</div><div><br /></div>Y. Lianghttp://www.blogger.com/profile/14752853638197350267noreply@blogger.com0