PageRenderTime 35ms CodeModel.GetById 27ms app.highlight 3ms RepoModel.GetById 1ms app.codeStats 0ms

/exercise1/exercise1.lhs

http://sauce-code.googlecode.com/
Haskell | 1133 lines | 786 code | 90 blank | 257 comment | 63 complexity | e9c759ede1181a1f5fcc222e4334c667 MD5 | raw file
   1\documentclass[11pt]{article}
   2%% Literate Haskell script intended for lhs2TeX.
   3
   4%include polycode.fmt
   5%format `union` = "\cup"
   6%format alpha = "\alpha"
   7%format gamma "\gamma"
   8%format capGamma = "\Gamma"
   9%format tau = "\tau"
  10%format tau1 = "\tau_{1}"
  11%format tau2 = "\tau_{2}"
  12%format t1 = "t_{1}"
  13%format t2 = "t_{2}"
  14%format t3 = "t_{3}"
  15
  16\usepackage{fullpage}
  17\usepackage{verbatim}
  18\usepackage{mathpazo}
  19\usepackage{graphicx}
  20\usepackage{color}
  21\usepackage[centertags]{amsmath}
  22\usepackage{amsfonts}
  23\usepackage{amsthm}
  24\usepackage{soul}
  25\usepackage{listings}
  26\usepackage{stmaryrd}
  27
  28\title{Exercise 1, CS 555}
  29\author{\textbf{By:} Sauce Code Team (Dandan Mo, Qi Lu, Yiming Yang)}
  30\date{\textbf{Due:} February 27th, 2012}
  31\begin{document}
  32	\maketitle
  33	\thispagestyle{empty}
  34	\newpage
  35
  36\section{Concrete Lambda Language}
  37
  38We start the project with a small core lambda language, consisting of the lambda calculus with booleans
  39and integers.
  40Here is the concrete syntax in BNF:
  41
  42\begin{verbatim}
  43Type --> arr lpar Type comma Type rpar
  44       | Bool_keyword
  45       | Int_keyword
  46
  47Term --> identifier
  48       | abs_keyword lpar identifier colon Type fullstop Term rpar
  49       | app_keyword lpar Term comma Term rpar
  50       | true_keyword
  51       | false_keyword
  52       | if_keyword Term then_keyword Term else_keyword Term fi_keyword
  53       | inliteral
  54       | plus lpar Term comma Term rpar
  55       | minus lpar Term comma Term rpar
  56       | div lpar Term comma Term rpar
  57       | nand lpar Term comma Term rpar
  58       | equal lpar Term comma Term rpar
  59       | lt lpar Term comma Term rpar
  60       | lpar Term rpar
  61\end{verbatim}
  62
  63Here are the terminal symbols used in the grammar above: 
  64\newpage
  65
  66\begin{verbatim}
  67arrow		->
  68lpar		(
  69comma		,
  70rpar		)
  71Bool_keyword	Bool
  72Int_keyword	Int
  73identifier	an identifier, as in Haskell
  74abs_keyword	abs
  75colon		:
  76fullstop	.
  77app_keyword	app
  78true_keyword	true
  79false_keyword	false
  80if_keyword	if
  81then_keyword	then
  82else_keyword	else
  83fi_keyword	fi
  84inliteral	a non-negative decimal numeral
  85plus		+
  86minus		-
  87mul		*
  88div		/
  89nand		^
  90equal		=
  91lt		<
  92\end{verbatim}
  93
  94White space, such as space, tab, and newline characters, is permitted between tokens. White space is
  95required between adjacent keyword tokens.
  96
  97Here are some example programs:
  98\\ \\
  99    
 100    app (abs (x: Int . 1234), 10)
 101
 102-------------------------------------------------------------------------\\
 103    
 104    if true then true else false fi
 105
 106-------------------------------------------------------------------------\\
 107    
 108    if =(0,0) then 8 else 9 fi
 109
 110-------------------------------------------------------------------------\\
 111
 112    /(4294967295,76)
 113
 114-------------------------------------------------------------------------\\
 115
 116\section{Lexer and Parser}
 117
 1181):Lexer takes input string, returns a list of tokens. We define a data structure called Token as the followings,together with the show functions:\\
 119\begin{code}
 120data Token = ARROW
 121	| LPAR
 122	| COMMA
 123	| RPAR
 124	| BOOL
 125	| INT
 126	| ABS
 127	| COLON
 128	| FULLSTOP
 129	| APP
 130	| TRUE
 131	| FALSE
 132	| IF
 133	| THEN
 134	| ELSE
 135	| FI
 136	| PLUS
 137	| SUB
 138	| MUL
 139	| DIV
 140	| NAND
 141	| EQUAL
 142	| LT_keyword
 143	| ID String
 144	| NUM String
 145	deriving Eq
 146
 147instance Show Token where
 148	show ARROW = "->"
 149	show LPAR = "("
 150	show COMMA = ","
 151	show RPAR = ")"
 152	show BOOL = "Bool"
 153	show INT = "Int"
 154	show ABS = "abs"
 155	show COLON = ":"
 156	show FULLSTOP = "."
 157	show APP = "app"
 158	show TRUE = "true"
 159	show FALSE = "false"
 160	show IF = "if"
 161	show THEN = "then"
 162	show ELSE = "else"
 163	show FI = "fi"
 164	show PLUS = "+"
 165	show SUB = "-"
 166	show MUL = "*"
 167	show DIV = "/"
 168	show NAND = "^"
 169	show EQUAL = "="
 170	show LT_keyword = "<"
 171	show (ID id) = id
 172	show (NUM num) = num
 173\end{code}
 174
 175For the Token identifier and decimal number, we use regular expression to recognize them, so we have two corresponding subscan function to deal with them.\\
 176
 177\begin{code}
 178--reguar expresiion
 179ex_num = mkRegex "(0|[1-9][0-9]*)"
 180ex_id = mkRegex "([a-zA-Z][a-zA-Z0-9_]*)"
 181
 182--subscan for id
 183subscan1 :: String -> Maybe ([Token],String)
 184subscan1 str = case (matchRegexAll ex_id str) of 
 185		Just (a1,a2,a3,a4) -> case a1 of
 186					"" -> Just ([ID a2],a3)
 187					_  -> Nothing
 188		Nothing -> Nothing
 189
 190--subscan for num
 191subscan2 :: String -> Maybe ([Token],String)
 192subscan2 str = case (matchRegexAll ex_num str) of
 193		Just (a1,a2,a3,a4) -> case a1 of
 194					"" -> Just ([NUM a2],a3)
 195					_  -> Nothing
 196		Nothing -> Nothing
 197\end{code}
 198
 199Function scan takes an input string and returns a list tokens. If unexpected symbols exists,or the input string cannot mactch any defined token, the function reports errors and the program stops at the lexer level.\\
 200
 201\begin{code}
 202--lexer
 203scan :: String -> [Token]
 204scan "" = []
 205----white spase
 206scan (' ':xs) = scan xs
 207scan ('\t':xs) = scan xs
 208scan ('\n':xs) = scan xs
 209----keyword
 210scan (':':xs) = [COLON] ++ scan xs
 211scan ('-':'>':xs) = [ARROW] ++ scan xs
 212scan ('(':xs) = [LPAR] ++ scan xs
 213scan (',':xs) = [COMMA] ++ scan xs
 214scan (')':xs) = [RPAR] ++ scan xs
 215scan ('B':'o':'o':'l':xs) = [BOOL] ++ scan xs
 216scan ('I':'n':'t':xs) = [INT] ++ scan xs
 217scan ('a':'b':'s':xs) = [ABS] ++ scan xs
 218scan ('a':'p':'p':xs) = [APP] ++ scan xs
 219scan ('.':xs) = [FULLSTOP] ++ scan xs
 220scan ('t':'r':'u':'e':xs) = [TRUE] ++ scan xs
 221scan ('f':'a':'l':'s':'e':xs) = [FALSE] ++ scan xs
 222scan ('i':'f':xs) = [IF] ++ scan xs
 223scan ('t':'h':'e':'n':xs) = [THEN] ++ scan xs
 224scan ('e':'l':'s':'e':xs) = [ELSE] ++ scan xs
 225scan ('f':'i':xs) = [FI] ++ scan xs
 226scan ('+':xs) = [PLUS] ++ scan xs
 227scan ('-':xs) = [SUB] ++ scan xs
 228scan ('*':xs) = [MUL] ++ scan xs
 229scan ('/':xs) = [DIV] ++ scan xs
 230scan ('^':xs) = [NAND] ++ scan xs
 231scan ('=':xs) = [EQUAL] ++ scan xs
 232scan ('<':xs) = [LT_keyword] ++ scan xs 
 233----id and num
 234scan str = case subscan1 str of
 235		Nothing -> case subscan2 str of
 236				Nothing -> error "[Scan]err: unexpected symbols!"
 237				Just (tok,xs) -> tok ++ scan xs
 238		Just (tok,xs) -> tok ++ scan xs
 239str str = error "[Scan]err: unexpected symbols!"
 240\end{code}
 241
 2422):Parser takes a list of tokens, returns a term. We define the two data structures Type and Term, and two functions parseType and parseTerm to deal with them.\\
 243parseType function returns a matched Type and the remaining tokens, parseTerm function returns a matched Term and the remaining tokens.\\
 244
 245Data structure:\\
 246\begin{code}
 247data Type = TypeArrow Type Type
 248	| TypeBool
 249	| TypeInt
 250	deriving Eq
 251
 252instance Show Type where
 253	show (TypeArrow tau1 tau2) = "->(" ++ show tau1 ++ "," ++ show tau2 ++ ")"
 254	show TypeBool = "Bool"
 255	show TypeInt = "Int"
 256
 257type Var = String
 258data Term = Var Var
 259	| Abs Var Type Term
 260	| App Term Term
 261	| Tru
 262	| Fls
 263	| If Term Term Term
 264	| IntConst Integer
 265	| IntAdd Term Term
 266	| IntSub Term Term
 267	| IntMul Term Term
 268	| IntDiv Term Term
 269	| IntNand Term Term
 270	| IntEq Term Term
 271	| IntLt Term Term
 272	deriving Eq
 273
 274instance Show Term where
 275	show (Var x) = x
 276	show (Abs x tau t) = "abs(" ++ x ++ ":" ++ show tau ++ "." ++ show t ++ ")"
 277	show (App t1 t2) = "app(" ++ show t1 ++ "," ++ show t2 ++ ")"
 278	show Tru = "true"
 279	show Fls = "false"
 280	show (If t1 t2 t3) = "if " ++ show t1 ++ " then " ++ show t2 ++ " else " ++ show t3 ++ " fi"
 281	show (IntConst n) = show n
 282	show (IntAdd t1 t2) = "+(" ++ show t1 ++ "," ++ show t2 ++ ")"
 283	show (IntSub t1 t2) = "-(" ++ show t1 ++ ","  ++ show t2 ++ ")"
 284	show (IntMul t1 t2) = "*(" ++ show t1 ++ "," ++ show t2 ++ ")"
 285	show (IntDiv t1 t2) = "/(" ++ show t1 ++ "," ++ show t2 ++ ")"
 286	show (IntNand t1 t2) = "^(" ++ show t1 ++ "," ++ show t2 ++ ")"
 287	show (IntEq t1 t2) = "=(" ++ show t1 ++ "," ++ show t2 ++ ")"
 288	show (IntLt t1 t2) = "<(" ++ show t1 ++ "," ++ show t2 ++ ")"
 289
 290\end{code}
 291
 292Function parseType, parseTerm and parse:\\
 293\begin{code}
 294--parser
 295
 296--type parser
 297parseType :: [Token] -> Maybe (Type,[Token])
 298parseType (BOOL:ty) = Just (TypeBool,ty)
 299parseType (INT:ty) = Just (TypeInt,ty)
 300parseType (RPAR:ty) = parseType ty
 301parseType (COMMA:ty) = parseType ty
 302parseType (ARROW:LPAR:ty) = 
 303	case parseType ty of
 304		Just (t1,(COMMA:tl)) -> case parseType tl of
 305						Just (t2,(RPAR:tll)) -> Just ((TypeArrow t1 t2),tll)
 306						Nothing -> Nothing
 307				Nothing -> Nothing
 308parseType tok = error "[P]err: type parsing error!"
 309
 310--term parser
 311parseTerm :: [Token] -> Maybe (Term,[Token])
 312----id
 313parseTerm ((ID id):ts) = Just ((Var id),ts)
 314----num
 315parseTerm ((NUM num):ts) = Just ((IntConst (read num::Integer)),ts)
 316----symbol
 317--parseTerm (COMMA:ts) = parseTerm ts
 318--parseTerm (COLON:ts) = parseTerm ts
 319--parseTerm (RPAR:ts) = parseTerm ts
 320--parseTerm (FULLSTOP:ts) = parseTerm ts
 321----keyword
 322parseTerm (THEN:ts) = parseTerm ts
 323parseTerm (ELSE:ts) = parseTerm ts
 324parseTerm (FI:ts) = parseTerm ts
 325parseTerm (TRUE:ts) = Just (Tru,ts)
 326parseTerm (FALSE:ts) = Just (Fls,ts)
 327----(term)
 328parseTerm (LPAR:ts) = case parseTerm ts of
 329			Just (t,(RPAR:tl)) -> Just (t,tl)
 330			Nothing -> Nothing
 331			_ -> error "[P]err: t is not a term in the (t)"
 332----op
 333parseTerm (PLUS:LPAR:ts) = 
 334	case parseTerm ts of
 335		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 336						Just (t2,(RPAR:tll)) -> Just ((IntAdd t1 t2),tll)
 337						Nothing -> Nothing
 338						_ -> error "[P]err: plus term"
 339		Nothing -> Nothing
 340		_ -> error "[P]err: plus term"
 341parseTerm (SUB:LPAR:ts) = 
 342	case parseTerm ts of
 343		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 344						Just (t2,(RPAR:tll)) -> Just ((IntSub t1 t2),tll)
 345						Nothing -> Nothing
 346						_ -> error "[P]err: sub term"
 347		Nothing -> Nothing
 348		_ -> error "[P]err: sub term"
 349parseTerm (MUL:LPAR:ts) = 
 350	case parseTerm ts of
 351		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 352						Just (t2,(RPAR:tll)) -> Just ((IntMul t1 t2),tll)
 353						Nothing -> Nothing
 354						_ -> error "[P]err: mul term"
 355		Nothing -> Nothing
 356		_ -> error "[P]err: mul term"
 357parseTerm (DIV:LPAR:ts) =
 358	 case parseTerm ts of
 359		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 360						Just (t2,(RPAR:tll)) -> Just ((IntDiv t1 t2),tll)
 361						Nothing -> Nothing
 362						_ -> error "[P]err: div term"
 363		Nothing -> Nothing
 364		_ -> error "[P]err: div term"
 365parseTerm (NAND:LPAR:ts) = 
 366	case parseTerm ts of
 367		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 368						Just (t2,(RPAR:tll)) -> Just ((IntNand t1 t2),tll)
 369						Nothing -> Nothing
 370						_ -> error "[P]err: nand term"
 371		Nothing -> Nothing
 372		_ -> error "[P]err: nand term"
 373parseTerm (EQUAL:LPAR:ts) =
 374	 case parseTerm ts of
 375		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 376						Just (t2,(RPAR:tll)) -> Just ((IntEq t1 t2),tll)
 377						Nothing -> Nothing
 378						_ -> error "[P]err: eq term"
 379		Nothing -> Nothing
 380		_ -> error "[P]err: eq term"
 381parseTerm (LT_keyword:LPAR:ts) = 
 382	case parseTerm ts of
 383		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 384						Just (t2,(RPAR:tll)) -> Just ((IntLt t1 t2),tll)
 385						Nothing -> Nothing
 386						_ -> error "[P]err: lt term"
 387		Nothing -> Nothing
 388		_ -> error "[P]err: lt term"
 389----if-then-else
 390parseTerm (IF:ts) = 
 391	case parseTerm ts of
 392		Just (t1,(THEN:tl)) -> case parseTerm tl of
 393					Just (t2,(ELSE:tll)) -> case parseTerm tll of
 394								Just (t3,(FI:tn)) -> Just((If t1 t2 t3),tn)
 395								Nothing -> Nothing
 396								_ -> error "[P]err: if term"
 397					Nothing -> Nothing
 398					_ -> error "[P]err: if term"
 399		Nothing -> Nothing
 400		_ -> error "[P]err: if term"
 401
 402----abs
 403parseTerm (ABS:LPAR:(ID id):COLON:ts) = 
 404	case parseType ts of
 405		Just (ty,(FULLSTOP:tl)) -> case parseTerm tl of
 406						Just (t,(RPAR:tll)) -> Just ((Abs id ty t),tll)
 407						Nothing -> Nothing
 408						_ -> error "[P]err: abs term"
 409		 Nothing -> Nothing
 410		 _ -> error "[P]err: abs term"
 411----app
 412parseTerm (APP:LPAR:ts) = case parseTerm ts of
 413				Just (t1,(COMMA:tl)) -> case parseTerm tl of
 414							  Just (t2,(RPAR:tll)) -> Just ((App t1 t2),tll)
 415							  Nothing -> Nothing
 416							  _ -> error "[P]err: app term"
 417				Nothing -> Nothing
 418				_ -> error "[P]err: app term"
 419----otherwise
 420parseTerm tok = Nothing
 421
 422--parser
 423parse :: [Token] -> Term
 424parse t = 
 425	  case parseTerm t of
 426		Just (x,t) -> case t of 
 427				[] -> x
 428				_ -> error "parsing error!"
 429		Nothing -> error "parsing error!"
 430
 431
 432\end{code}
 433
 434If the input string can't match any defined Term, function parser reports an error and the program stops at the parser level.\\
 435
 436\section{Binding and Free Variables}
 437Define functions to manipulate the abstract syntax. Place them together with the above type definitions
 438in a module \textit{AbstractSyntax}.
 439
 440Enumerate the free variables of a term:
 441\begin{code}
 442fv :: Term -> [Var]
 443fv (Var x) = [x]
 444fv (Abs x _ t) = filter (/=x) (fv t)
 445fv (App t1 t2) = (fv t1) ++ (fv t2)
 446fv (If t1 t2 t3) = (fv t1) ++ (fv t2) ++ (fv t3)
 447fv (IntAdd t1 t2) = (fv t1) ++ (fv t2)
 448fv (IntSub t1 t2) = (fv t1) ++ (fv t2)
 449fv (IntMul t1 t2) = (fv t1) ++ (fv t2)
 450fv (IntDiv t1 t2) = (fv t1) ++ (fv t2)
 451fv (IntNand t1 t2) = (fv t1) ++ (fv t2)
 452fv (IntEq t1 t2) = (fv t1) ++ (fv t2)
 453fv (IntLt t1 t2) = (fv t1) ++ (fv t2)
 454fv _ = []
 455\end{code}
 456
 457Substitution: subst $x$ $s$ $t$, or in writing $[x 7 \rightarrow s]t$, is the result of substituting $s$ for $x$ in $t$.
 458\begin{code}
 459subst :: Var -> Term -> Term -> Term
 460subst x s (Var v) = if x == v then s else (Var v)
 461subst x s (Abs y tau t1) = 
 462  if x == y then
 463              Abs y tau t1
 464            else 
 465              Abs y tau (subst x s t1)
 466subst x s (App t1 t2) = App (subst x s t1) (subst x s t2)
 467subst x s (If t1 t2 t3) = If (subst x s t1) (subst x s t2) (subst x s t3)
 468subst x s (IntAdd t1 t2) = IntAdd (subst x s t1) (subst x s t2)
 469subst x s (IntSub t1 t2) = IntSub (subst x s t1) (subst x s t2)
 470subst x s (IntMul t1 t2) = IntMul (subst x s t1) (subst x s t2)
 471subst x s (IntDiv t1 t2) = IntDiv (subst x s t1) (subst x s t2)
 472subst x s (IntNand t1 t2) = IntNand (subst x s t1) (subst x s t2)
 473subst x s (IntEq t1 t2) = IntEq (subst x s t1) (subst x s t2)
 474subst x s (IntLt t1 t2) = IntLt (subst x s t1) (subst x s t2)
 475subst x s t = t
 476\end{code}
 477
 478Syntactic values: primitive constants and abstractions are values.
 479\begin{code}
 480isValue :: Term -> Bool
 481isValue (Abs _ _ _) = True
 482isValue Tru = True
 483isValue Fls = True
 484isValue (IntConst _) = True
 485isValue _ = False
 486\end{code}
 487\section{Structural Operational Semantics}
 488
 489\paragraph{}
 490Express the small-step semantics, as defined in class, in Haskell code. The completed source code is as follows:
 491
 492\begin{code}
 493
 494module StructuralOperationalSemantics where
 495import List
 496import qualified AbstractSyntax as S
 497import qualified IntegerArithmetic as I
 498
 499eval1 :: S.Term -> Maybe S.Term
 500-- E-IFTRUE
 501eval1 (S.If S.Tru t2 t3) = Just t2
 502
 503-- E-IFFALSE
 504eval1 (S.If S.Fls t2 t3) = Just t3
 505
 506-- E-IF
 507eval1 (S.If t1 t2 t3) = 
 508  case eval1 t1 of
 509    Just t1' -> Just (S.If t1' t2 t3)
 510    Nothing  -> Nothing
 511
 512-- E-APPABS, E-APP1 and E-APP2
 513eval1 (S.App t1 t2) = 
 514  if S.isValue t1
 515     then if S.isValue t2
 516             then case t1 of
 517                    S.Abs x tau11 t12 -> Just (S.subst x t2 t12) -- E-APPABS
 518                    _                 -> Nothing
 519             else case eval1 t2 of
 520                    Just t2' -> Just (S.App t1 t2')    -- E-APP2
 521                    Nothing  -> Nothing
 522     else case eval1 t1 of
 523            Just t1' -> Just (S.App t1' t2)   -- E-APP1
 524            Nothing  -> Nothing
 525
 526eval1 (S.IntAdd t1 t2) = 
 527  if S.isValue t1
 528     then case t1 of
 529            S.IntConst n1 -> if S.isValue t2
 530                              then case t2 of
 531                                     S.IntConst n2 -> Just (S.IntConst (I.intAdd n1 n2))
 532                                     _             -> Nothing
 533                              else case eval1 t2 of
 534                                     Just t2' -> Just (S.IntAdd t1 t2')
 535                                     Nothing  -> Nothing
 536            _           -> Nothing
 537     else case eval1 t1 of
 538            Just t1' -> Just (S.IntAdd t1' t2)
 539            Nothing  -> Nothing
 540
 541eval1 (S.IntSub t1 t2) = 
 542  if S.isValue t1
 543     then case t1 of
 544            S.IntConst n1 -> if S.isValue t2
 545                              then case t2 of
 546                                     S.IntConst n2 -> Just (S.IntConst (I.intSub n1 n2))
 547                                     _             -> Nothing
 548                              else case eval1 t2 of
 549                                     Just t2' -> Just (S.IntSub t1 t2')
 550                                     Nothing  -> Nothing
 551            _             -> Nothing
 552     else case eval1 t1 of
 553            Just t1' -> Just (S.IntSub t1' t2)
 554            Nothing  -> Nothing
 555
 556eval1 (S.IntMul t1 t2) = 
 557  if S.isValue t1
 558     then case t1 of
 559            S.IntConst n1 -> if S.isValue t2
 560                              then case t2 of
 561                                     S.IntConst n2 -> Just (S.IntConst (I.intMul n1 n2))
 562                                     _             -> Nothing
 563                              else case eval1 t2 of
 564                                     Just t2' -> Just (S.IntMul t1 t2')
 565                                     Nothing  -> Nothing
 566            _             -> Nothing
 567     else case eval1 t1 of
 568            Just t1' -> Just (S.IntMul t1' t2)
 569            Nothing  -> Nothing
 570
 571eval1 (S.IntDiv t1 t2) = 
 572  if S.isValue t1
 573     then case t1 of
 574            S.IntConst n1 -> if S.isValue t2
 575                              then case t2 of
 576                                     S.IntConst n2 -> Just (S.IntConst (I.intDiv n1 n2))
 577                                     _             -> Nothing
 578                              else case eval1 t2 of
 579                                     Just t2' -> Just (S.IntDiv t1 t2')
 580                                     Nothing  -> Nothing
 581            _             -> Nothing
 582     else case eval1 t1 of
 583            Just t1' -> Just (S.IntDiv t1' t2)
 584            Nothing  -> Nothing
 585
 586eval1 (S.IntNand t1 t2) = 
 587  if S.isValue t1
 588     then case t1 of
 589            S.IntConst n1 -> if S.isValue t2
 590                              then case t2 of
 591                                     S.IntConst n2 -> Just (S.IntConst (I.intNand n1 n2))
 592                                     _             -> Nothing
 593                              else case eval1 t2 of
 594                                     Just t2' -> Just (S.IntNand t1 t2')
 595                                     Nothing  -> Nothing
 596            _             -> Nothing
 597     else case eval1 t1 of
 598            Just t1' -> Just (S.IntNand t1' t2)
 599            Nothing  -> Nothing
 600
 601eval1 (S.IntEq t1 t2) = 
 602  if S.isValue t1
 603     then case t1 of
 604            S.IntConst n1 -> if S.isValue t2
 605                              then case t2 of
 606                                     S.IntConst n2 -> case I.intEq n1 n2 of
 607                                                      True -> Just S.Tru
 608                                                      _    -> Just S.Fls
 609                                     _             -> Nothing
 610                              else case eval1 t2 of
 611                                     Just t2' -> Just (S.IntEq t1 t2')
 612                                     Nothing  -> Nothing
 613            _             -> Nothing
 614     else case eval1 t1 of
 615            Just t1' -> Just (S.IntEq t1' t2)
 616            Nothing  -> Nothing
 617
 618eval1 (S.IntLt t1 t2) = 
 619  if S.isValue t1
 620     then case t1 of
 621            S.IntConst n1 -> if S.isValue t2
 622                              then case t2 of
 623                                     S.IntConst n2 -> case I.intLt n1 n2 of
 624                                                      True -> Just S.Tru
 625                                                      _    -> Just S.Fls
 626                                     _             -> Nothing
 627                              else case eval1 t2 of
 628                                     Just t2' -> Just (S.IntLt t1 t2')
 629                                     Nothing  -> Nothing
 630            _             -> Nothing
 631     else case eval1 t1 of
 632            Just t1' -> Just (S.IntLt t1' t2)
 633            Nothing  -> Nothing
 634
 635-- All other cases
 636eval1 _ = Nothing
 637
 638eval :: S.Term -> S.Term
 639eval t = 
 640  case eval1 t of
 641    Just t' -> eval t'
 642    Nothing -> t 
 643
 644\end{code}
 645\section{Arithmetic}
 646The module $\mathit{IntegerArithmetic}$ formalizes the $\mathit{primitive}$ operators for integer arithmetic. In a nutshell, even though we use the Haskell infinite-precision type Integer to store integers, the numbers are really only using the 32-bit 2's complement range, and arithmetic operations must work accordingly. Roughly speaking, arithmetic is as in C on a 32-bit machine. Complete the code.
 647
 648\begin{code}
 649
 650module IntegerArithmetic where
 651import Data.Bits
 652
 653intRestrictRangeAddMul :: Integer -> Integer
 654intRestrictRangeAddMul m = m `mod` 4294967296
 655
 656intAdd :: Integer -> Integer -> Integer
 657intAdd m n = intRestrictRangeAddMul (m + n)
 658
 659intSub :: Integer -> Integer -> Integer
 660intSub m n = m - n
 661
 662intMul :: Integer -> Integer -> Integer
 663intMul m n = intRestrictRangeAddMul (m * n)
 664
 665intDiv :: Integer -> Integer -> Integer
 666intDiv m n = if n == 0 then error "integer division by zero" else m `div` n
 667
 668intNand :: Integer -> Integer -> Integer
 669intNand m n = complement (m .&. n)
 670
 671intEq :: Integer -> Integer -> Bool
 672intEq m n = m == n
 673
 674intLt :: Integer -> Integer -> Bool
 675intLt m n = m < n
 676
 677\end{code}
 678
 679
 680\section{Type Checker}
 681It is always good to be sure a program is well-typed before we try to evaluate it. You can use the following type checker or write your own.
 682
 683\begin{code}
 684module Typing where
 685import qualified AbstractSyntax as S
 686import List
 687data Context  =  Empty
 688              |  Bind Context S.Var S.Type
 689              deriving Eq
 690instance Show Context where
 691  show Empty                  =  "<>"
 692  show (Bind capGamma x tau)  =  show capGamma ++ "," ++ x ++ ":" ++ show tau
 693
 694contextLookup :: S.Var -> Context -> Maybe S.Type
 695contextLookup x Empty  =  Nothing
 696contextLookup x (Bind capGamma y tau)
 697  | x == y      =  Just tau
 698  | otherwise   =  contextLookup x capGamma
 699
 700typing :: Context -> S.Term -> Maybe S.Type
 701--T-Var
 702typing capGamma (S.Var x) = contextLookup x capGamma
 703--T-Abs
 704typing capGamma (S.Abs x tau_1 t2) = case typing (Bind capGamma x tau_1) t2 of 
 705                         Just(tp0) -> Just (S.TypeArrow tau_1 tp0)
 706			 Nothing -> Nothing
 707typing capGamma (S.App t0 t2)=
 708	case typing capGamma t0 of 
 709		 Just (S.TypeArrow tp tp0) -> case typing capGamma t2 of 
 710						       Just tp' -> if tp==tp' 
 711						                      then Just tp0
 712								      else Nothing
 713						       Nothing  -> Nothing
 714		 _ -> Nothing
 715
 716--T-True
 717typing capGamma S.Tru = Just S.TypeBool
 718
 719--T-False
 720typing capGamma S.Fls = Just S.TypeBool
 721
 722--T-If
 723typing capGamma (S.If t0 t2 t3) 
 724	| (typing capGamma t2 == typing capGamma t3 && typing capGamma t0 == Just S.TypeBool) = typing capGamma t2
 725	| otherwise = Nothing
 726
 727typing capGamma (S.IntConst _) = Just S.TypeInt
 728
 729--T-IntAdd 
 730typing capGamma (S.IntAdd t1 t2) =
 731        case typing capGamma t1 of 
 732	         Just S.TypeInt -> case typing capGamma t1 of 
 733		                          Just S.TypeInt -> Just S.TypeInt
 734					  Nothing -> Nothing
 735--T-IntSub 
 736typing capGamma (S.IntSub t1 t2) =
 737        case typing capGamma t1 of 
 738	         Just S.TypeInt -> case typing capGamma t1 of 
 739		                          Just S.TypeInt -> Just S.TypeInt
 740					  Nothing -> Nothing
 741--T-IntMul 
 742typing capGamma (S.IntMul t1 t2) =
 743        case typing capGamma t1 of 
 744	         Just S.TypeInt -> case typing capGamma t1 of 
 745		                          Just S.TypeInt -> Just S.TypeInt
 746					  Nothing -> Nothing
 747--T-IntDiv
 748typing capGamma (S.IntDiv t1 t2) =
 749        case typing capGamma t1 of 
 750	         Just S.TypeInt -> case typing capGamma t1 of 
 751		                          Just S.TypeInt -> Just S.TypeInt
 752					  Nothing -> Nothing
 753--T-IntNand 
 754typing capGamma (S.IntNand t1 t2) =
 755        case typing capGamma t1 of 
 756	         Just S.TypeInt -> case typing capGamma t1 of 
 757		                          Just S.TypeInt -> Just S.TypeInt
 758					  Nothing -> Nothing
 759--T-IntEq
 760typing capGamma (S.IntEq t1 t2) =
 761        case typing capGamma t1 of 
 762	         Just S.TypeBool -> case typing capGamma t1 of 
 763		                          Just S.TypeBool -> Just S.TypeBool
 764					  Nothing -> Nothing
 765--T-IntLt
 766typing capGamma (S.IntLt t1 t2) =
 767        case typing capGamma t1 of 
 768	         Just S.TypeBool -> case typing capGamma t1 of 
 769		                          Just S.TypeBool -> Just S.TypeInt
 770					  Nothing -> Nothing
 771typeCheck :: S.Term -> S.Type
 772typeCheck t =
 773  case typing Empty t of
 774    Just tau -> tau
 775    _ -> error "type error"
 776\end{code}
 777
 778\section{Main Program}
 779Write a main program which will (1) read the program text from a file into a string, (2) invoke the parser
 780to produce an abstract syntax tree for the program, (3) type-check the program, and (4) evaluate the
 781program using the small-step evaluation relation.
 782
 783\begin{code}
 784module Main where
 785
 786import qualified System.Environment
 787import Data.List
 788import IO
 789import qualified AbstractSyntax as S
 790import qualified StructuralOperationalSemantics as E
 791import qualified NaturalSemantics as N
 792import qualified IntegerArithmetic as I
 793import qualified Typing as T
 794
 795main :: IO()
 796main = 
 797    do
 798      args <- System.Environment.getArgs
 799      let [sourceFile] = args
 800      source <- readFile sourceFile
 801      let tokens = S.scan source
 802      let term = S.parse tokens
 803      putStrLn ("----Term----")
 804      putStrLn (show term)
 805      putStrLn ("----Type----")
 806      putStrLn (show (T.typeCheck term))
 807      putStrLn ("----Normal Form in Structureal Operational Semantics----")
 808      putStrLn (show (E.eval term))
 809      putStrLn ("----Normal Form of Natural Semantics----")
 810      putStrLn (show (N.eval term))
 811\end{code}
 812
 813\section{Structural Operational Semantics}
 814
 815\paragraph{}
 816Formally stating the rules that give the structural operational semantics of the core lambda language, the rules are listed below:
 817\[
 818	\text{if true then } t_2 \text{ else } t_3 \rightarrow t_2 \text{\quad (\textsc{E-IfTrue})}
 819\]
 820\ \\
 821\[
 822        \text{if false then } t_2 \text{ else } t_3 \rightarrow t_3 \text{(\quad \textsc{E-IfFalse})}
 823\]
 824\ \\
 825\[
 826	\frac{t_1 \rightarrow t'_1}{\text{if } t_1 \text{ then } t_2 \text{ else } t_3 \rightarrow \text{if } t'_1 \text{ then } t_2 \text{ else} t_3} \text{\quad (\textsc{E-If})}
 827\]
 828\ \\
 829\[
 830	\frac{t_1 \rightarrow t'_1}{t_1 \text{\ } t_2 \rightarrow t'_1 \text{\ } t_2}\text{\quad {\textsc{E-App1}}}
 831\]
 832\ \\
 833\[
 834	\frac{t_2 \rightarrow t'_2}{t_1 \text{\ } t_2 \rightarrow t_1 \text{\ } t'_2}\text{\quad {\textsc{E-App2}}}
 835\]
 836\ \\
 837\[
 838	(\lambda x: T_{11}.t_{12})v_2 \rightarrow [ x \mapsto v_2 ] _{12} \text{\quad (\textsc{E-AppAbs})}
 839\]
 840\ \\
 841\[
 842	\frac{t_1 \rightarrow t'_1}{+(t_1, t_2) \rightarrow +(t'_1, t_2)} \text{\quad (\textsc{E-IntAdd1})}
 843\]
 844\ \\
 845\[
 846	\frac{t_2 \rightarrow t'_2}{+(t_1, t_2) \rightarrow +(t_1, t'_2)} \text{\quad (\textsc{E-IntAdd2})}
 847\]
 848\ \\
 849\[
 850	+(v_1, v_2) \rightarrow v_1 \widetilde{+} v_2 \text{\quad (\textsc{E-IntAppAdd})}
 851\]
 852\ \\
 853\[
 854	\frac{t_1 \rightarrow t'_1}{-(t_1, t_2) \rightarrow -(t'_1, t_2)} \text{\quad (\textsc{E-IntSub1})}
 855\]
 856\ \\
 857\[
 858	\frac{t_2 \rightarrow t'_2}{-(t_1, t_2) \rightarrow -(t_1, t'_2)} \text{\quad (\textsc{E-IntSub2})}
 859\]
 860\ \\
 861\[
 862	-(v_1, v_2) \rightarrow v_1 \widetilde{-} v_2 \text{\quad (\textsc{E-AppIntSub})}
 863\]
 864\ \\
 865\[
 866	\frac{t_1 \rightarrow t'_1}{*(t_1, t_2) \rightarrow *(t'_1, t_2)} \text{\quad (\textsc{E-IntMul1})}
 867\]
 868\ \\
 869\[
 870	\frac{t_2 \rightarrow t'_2}{*(t_1, t_2) \rightarrow *(t_1, t'_2)} \text{\quad (\textsc{E-IntMul2})}
 871\]
 872\ \\
 873\[
 874	*(v_1, v_2) \rightarrow v_1 \widetilde{*} v_2 \text{\quad (\textsc{E-AppIntMul})}
 875\]
 876\ \\
 877\[
 878	\frac{t_1 \rightarrow t'_1}{/(t_1, t_2) \rightarrow /(t'_1, t_2)} \text{\quad (\textsc{E-IntDiv1})}
 879\]
 880\ \\
 881\[
 882	\frac{t_2 \rightarrow t'_2}{/(t_1, t_2) \rightarrow /(t_1, t'_2)} \text{\quad (\textsc{E-IntDiv2})}
 883\]
 884\ \\
 885\[
 886	/(v_1, v_2) \rightarrow v_1 \widetilde{/} v_2 \text{\quad (\textsc{E-AppIntDiv})}
 887\]
 888\ \\
 889\[
 890	\frac{t_1 \rightarrow t'_1}{\wedge(t_1, t_2) \rightarrow \wedge(t'_1, t_2)} \text{\quad (\textsc{E-IntNand1})}
 891\]
 892\ \\
 893\[
 894	\frac{t_2 \rightarrow t'_2}{\wedge(t_1, t_2) \rightarrow \wedge(t_1, t'_2)} \text{\quad (\textsc{E-IntNand2})}
 895\]
 896\ \\
 897\[
 898	\wedge(v_1, v_2) \rightarrow v_1 \widetilde{\wedge} v_2 \text{\quad (\textsc{E-AppIntNand})}
 899\]
 900\ \\
 901\[
 902	\frac{t_1 \rightarrow t'_1}{=(t_1, t_2) \rightarrow =(t'_1, t_2)} \text{\quad (\textsc{E-IntEq1})}
 903\]
 904\ \\
 905\[
 906	\frac{t_2 \rightarrow t'_2}{=(t_1, t_2) \rightarrow =(t_1, t'_2)} \text{\quad (\textsc{E-IntEq2})}
 907\]
 908\ \\
 909\[
 910	=(v_1, v_2) \rightarrow v_1 \widetilde{\equiv} v_2 \text{\quad (\textsc{E-AppIntEq})}
 911\]
 912\ \\
 913\[
 914	\frac{t_1 \rightarrow t'_1}{<(t_1, t_2) \rightarrow <(t'_1, t_2)} \text{\quad (\textsc{E-IntLt1})}
 915\]
 916\ \\
 917\[
 918	\frac{t_2 \rightarrow t'_2}{<(t_1, t_2) \rightarrow <(t_1, t'_2)} \text{\quad (\textsc{E-IntLt2})}
 919\]
 920\ \\
 921\[
 922	<(v_1, v_2) \rightarrow v_1 \widetilde{<} v_2 \text{\quad (\textsc{E-AppIntLt})}
 923\]
 924\ \\
 925where
 926\begin{align*}
 927	\widetilde{+} &\text{\quad \quad is the funtion that adds the two arguments and returns an Integer result}\\
 928	\widetilde{-} &\text{\quad \quad is the function that subtracts the two arguments and returns an Integer result}\\
 929	\widetilde{*} &\text{\quad \quad is the function that times the two arguments and returns an Integer result}\\
 930	\widetilde{/} &\text{\quad \quad is the function that divides the two arguments and returns an Integer result}\\
 931	\widetilde{\wedge} &\text{\quad \quad is the function that gets the nand result of the two arguments and returns it }\\
 932	\widetilde{\equiv} &\text{\quad \quad is the function that judges whether the two values are equal. If so, returns \textbf{true}, otherwise \textbf{false}}\\
 933	\widetilde{<} &\text{\quad \quad is the function that judges whether the first value is less than the second one.} \\
 934                      &\text{\quad \quad \ If so, returns \textbf{true}, otherwise \textbf{false}}
 935\end{align*}
 936
 937
 938
 939
 940
 941\section{Natural Semantics}
 942
 943\paragraph{}
 944Formally state the rules that give the natural semantics (big-step operational semantics) of the core lambda language. (Note: here we mean the version of natural semantics that operates on terms and performs substitutions, rather than the version with environments.)
 945
 946\paragraph{}
 947The formal rules of the natural semantics for this programming language is as follows:
 948\[
 949	a\Downarrow v \text{\quad (\textsc{B-ClosedForm})}	
 950\]
 951for closed form $a$, and $a$ should have no free variable inside.
 952\[
 953	v \Downarrow v \text{\quad (\textsc{B-Value})}
 954\]
 955\ \\
 956\[
 957	\frac{a\Downarrow \lambda x.a'\text{\quad} b\Downarrow v'\text{\quad} [x\mapsto v']a'\Downarrow v}{a\text{\ }b \Downarrow v}\text{\quad (\textsc{B-App})}
 958\]
 959\ \\
 960\[
 961	\frac{t_1 \Downarrow \text{ true\quad } t_2 \Downarrow v_2}{\text{if } t_1 \text{ then } t_2 \text{ else } t_3 \Downarrow v_2}\text{\quad (\textsc{B-IfTrue})}
 962\]
 963\ \\
 964\[
 965	\frac{t_1 \Downarrow \text{ false\quad} t_3 \Downarrow v_3}{\text{if } t_1 \text{ then } t_2 \text{ else } t_3 \Downarrow v_3}\text{\quad (\textsc{B-IfFalse})}
 966\]
 967\ \\
 968\[
 969	\frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{+}(v_1, v_2)}{+(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntAdd})}
 970\]
 971\ \\
 972\[
 973	\frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{-}(v_1, v_2)}{-(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntSub})}
 974\]
 975\ \\
 976\[
 977	\frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{*}(v_1, v_2)}{*(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntMul})}
 978\]
 979\ \\
 980\[
 981	\frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{/}(v_1, v_2)}{/(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntDiv})}
 982\]
 983\ \\
 984\[
 985	\frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{\wedge}(v_1, v_2)}{\wedge(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntNand})}
 986\]
 987\ \\
 988\[
 989	\frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{=}(v_1, v_2)}{=(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntEq})}
 990\]
 991\ \\
 992\[
 993	\frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{<}(v_1, v_2)}{<(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntLt})}
 994\]
 995\ \\
 996\section{Natural Semantics}
 997
 998\paragraph{}
 999Express the natural semantics in Haskell code, as an interpreter for lambda terms given by the Haskell function \textit{eval::Term $\rightarrow$ Term} in a module \textit{NaturalSemantics}. The completed module source code is as follows:
1000
1001\begin{code}
1002module NaturalSemantics where
1003
1004import List
1005import qualified AbstractSyntax as S
1006import qualified IntegerArithmetic as I
1007
1008eval :: S.Term -> S.Term
1009
1010eval (S.If t1 t2 t3) = 
1011  case eval t1 of
1012    S.Tru -> eval t2  -- B-IfTrue
1013    S.Fls -> eval t3  -- B-IfFalse
1014    _     -> S.If t1 t2 t3 
1015
1016-- B-App
1017eval (S.App t1 t2) = 
1018  if (S.isValue $ eval t1)
1019     then case eval t1 of
1020            S.Abs x tau t11 -> if ((S.isValue $ eval t2) && ((S.fv (S.Abs x tau t11)) == []))
1021                                  then eval (S.subst x (eval t2) t11)
1022                                  else S.App t1 t2
1023            _               -> S.App t1 t2
1024     else S.App t1 t2
1025
1026-- B-IntAdd
1027eval (S.IntAdd t1 t2) = 
1028  case eval t1 of
1029    S.IntConst v1 -> case eval t2 of
1030                       S.IntConst v2 -> S.IntConst (I.intAdd v1 v2)
1031                       _            -> S.IntAdd t1 t2
1032    _             -> S.IntAdd t1 t2
1033
1034
1035-- B-IntSub
1036eval (S.IntSub t1 t2) = 
1037  case eval t1 of
1038    S.IntConst v1 -> case eval t2 of
1039                       S.IntConst v2 -> S.IntConst (I.intSub v1 v2)
1040                       _             -> S.IntSub t1 t2
1041    _             -> S.IntSub t1 t2
1042
1043-- B-IntMul
1044eval (S.IntMul t1 t2) = 
1045  case eval t1 of
1046    S.IntConst v1 -> case eval t2 of
1047                       S.IntConst v2 -> S.IntConst (I.intMul v1 v2)
1048                       _             -> S.IntSub t1 t2
1049    _             -> S.IntSub t1 t2
1050
1051-- B-IntDiv
1052eval (S.IntDiv t1 t2) =
1053  case eval t1 of
1054    S.IntConst v1 -> case eval t2 of
1055                       S.IntConst v2 -> S.IntConst (I.intDiv v1 v2)
1056                       _             -> S.IntDiv t1 t2
1057    _             -> S.IntDiv t1 t2
1058
1059-- B-IntNand
1060eval (S.IntNand t1 t2) =
1061  case eval t1 of
1062    S.IntConst v1 -> case eval t2 of
1063                       S.IntConst v2 -> S.IntConst (I.intNand v1 v2)
1064                       _             -> S.IntNand t1 t2
1065    _             -> S.IntNand t1 t2
1066
1067-- B-IntEq
1068eval (S.IntEq t1 t2) = 
1069  case eval t1 of
1070    S.IntConst v1 -> case eval t2 of
1071                       S.IntConst v2 -> case I.intEq v1 v2 of
1072                                          True  -> S.Tru
1073                                          False -> S.Fls
1074                       _             -> S.IntEq t1 t2
1075    _             -> S.IntEq t1 t2
1076
1077-- B-IntLt
1078eval (S.IntLt t1 t2) = 
1079  case eval t1 of
1080    S.IntConst v1 -> case eval t2 of
1081                       S.IntConst v2 -> case I.intLt v1 v2 of
1082                                          True  -> S.Tru
1083                                          False -> S.Fls
1084                       _             -> S.IntLt t1 t2
1085    _             -> S.IntLt t1 t2
1086
1087-- B-Value and Exceptions
1088eval t = t
1089
1090\end{code}
1091
1092\section{Test Cases}
1093
1094\subsection{Test 1}
1095\verbatiminput{test1.TLBN}
1096\verbatiminput{test1.out}
1097
1098\subsection{Test 2}
1099\verbatiminput{test2.TLBN}
1100\verbatiminput{test2.out}
1101
1102\subsection{Test 3}
1103\verbatiminput{test3.TLBN}
1104\verbatiminput{test3.out}
1105
1106\subsection{Test 4}
1107\verbatiminput{test4.TLBN}
1108\verbatiminput{test4.out}
1109
1110\subsection{Test 5}
1111\verbatiminput{test5.TLBN}
1112\verbatiminput{test5.out}
1113
1114\subsection{Test 6}
1115\verbatiminput{test6.TLBN}
1116\verbatiminput{test6.out}
1117
1118\subsection{Test 7}
1119\verbatiminput{test7.TLBN}
1120\verbatiminput{test7.out}
1121
1122\subsection{Test 8}
1123\verbatiminput{test8.TLBN}
1124\verbatiminput{test8.out}
1125
1126\subsection{Test 9}
1127\verbatiminput{test9.TLBN}
1128\verbatiminput{test9.out}
1129
1130\subsection{Test 10}
1131\verbatiminput{test10.TLBN}
1132\verbatiminput{test10.out}
1133\end{document}