PageRenderTime 22ms CodeModel.GetById 10ms app.highlight 5ms RepoModel.GetById 0ms app.codeStats 1ms

/exercise2/exercise2.lhs

http://sauce-code.googlecode.com/
Haskell | 1922 lines | 1571 code | 186 blank | 165 comment | 95 complexity | 72f37ed1c3f238f3c98603a4efa9431b MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1%% Literate Haskell script intended for lhs2TeX.
   2
   3\documentclass[10pt]{article}
   4%include polycode.fmt
   5
   6
   7%format union = "\cup"
   8%format `union` = "\cup"
   9%format Hole = "\square"
  10%format MachineTerminate ="\varodot"
  11%format CEKMachineTerminate ="\varodot"
  12%format alpha = "\alpha"
  13%format gamma = "\gamma"
  14%format zeta = "\zeta"
  15%format kappa = "\kappa"
  16%format kappa'
  17%format capGamma = "\Gamma"
  18%format sigma = "\sigma"
  19%format tau = "\tau"
  20%format taus = "\tau s"
  21%format ltaus = "l\tau s"
  22%format tau1
  23%format tau1'
  24%format tau2
  25%format tau11
  26%format tau12
  27%format upsilon = "\upsilon"
  28%format xi = "\xi"
  29%format t12
  30%format t1
  31%format t1'
  32%format t2
  33%format t2'
  34%format t3
  35%format nv1
  36
  37\usepackage{fullpage}
  38\usepackage{mathpazo}
  39\usepackage{verbatim}
  40\usepackage{graphicx}
  41\usepackage{color}
  42\usepackage[centertags]{amsmath}
  43\usepackage{amsfonts}
  44\usepackage{amssymb}
  45\usepackage{mathrsfs}
  46\usepackage{amsthm}
  47\usepackage{stmaryrd}
  48\usepackage{soul}
  49\usepackage{url}
  50
  51\usepackage{vmargin}
  52\setpapersize{USletter}
  53\setmarginsrb{1.1in}{1.0in}{1.1in}{0.6in}{0.3in}{0.3in}{0.0in}{0.2in}
  54\parindent 0in  \setlength{\parindent}{0in}  \setlength{\parskip}{1ex}
  55
  56\usepackage{epsfig}
  57\usepackage{rotating}
  58
  59\usepackage{mathpazo,amsmath,amssymb}
  60\title{Exercise 2, CS 555}
  61\author{\textbf{By:} Sauce Code Team (Dandan Mo, Qi Lu, Yiming Yang)}
  62\date{\textbf{Due:} March 21st, 2012}
  63\begin{document}
  64	\maketitle
  65	\thispagestyle{empty}
  66	\newpage
  67
  68\section{Enriching the Core Lambda Language}
  69
  70\subsection{Lexer and Parser}
  711): We add ``LET",``IN",``END",``FIX" to the Token and add corresponding show Token functions
  72\begin{code}
  73data Token = ARROW
  74	| LPAR
  75	| COMMA
  76	| RPAR
  77	| BOOL
  78	| INT
  79	| ABS
  80	| COLON
  81	| FULLSTOP
  82	| APP
  83	| TRUE
  84	| FALSE
  85	| IF
  86	| THEN
  87	| ELSE
  88	| FI
  89	| PLUS
  90	| SUB
  91	| MUL
  92	| DIV
  93	| NAND
  94	| EQUAL
  95	| LT_keyword
  96	| ID String
  97	| NUM String
  98	| LET
  99	| IN
 100	| END
 101	| FIX
 102	deriving Eq
 103
 104instance Show Token where
 105	show ARROW = "->"
 106	show LPAR = "("
 107	show COMMA = ","
 108	show RPAR = ")"
 109	show BOOL = "Bool"
 110	show INT = "Int"
 111	show ABS = "abs"
 112	show COLON = ":"
 113	show FULLSTOP = "."
 114	show APP = "app"
 115	show TRUE = "true"
 116	show FALSE = "false"
 117	show IF = "if"
 118	show THEN = "then"
 119	show ELSE = "else"
 120	show FI = "fi"
 121	show PLUS = "+"
 122	show SUB = "-"
 123	show MUL = "*"
 124	show DIV = "/"
 125	show NAND = "^"
 126	show EQUAL = "="
 127	show LT_keyword = "<"
 128	show (ID id) = id
 129	show (NUM num) = num
 130	show (LET) = "let"
 131	show (IN) = "in"
 132	show (END) = "end"
 133	show (FIX) = "fix"
 134
 135\end{code}
 136
 137For the Token identifier and decimal number, we use regular expression to recognize them, so we have two corresponding subscan function to deal with them. When we get a identifier, we check if it belongs to the keywords, if so we get the corresponding token, otherwise we get an id.\\
 138
 139\begin{code}
 140--reguar expression
 141ex_num = mkRegex "(0|[1-9][0-9]*)"
 142ex_id = mkRegex "([a-zA-Z][a-zA-Z0-9_]*)"
 143
 144--subscan for id and keywords
 145subscan1 :: String -> Maybe ([Token],String)
 146subscan1 str = case (matchRegexAll ex_id str) of 
 147		Just (a1,a2,a3,a4) -> case a1 of
 148					"" -> case a2 of
 149						"Bool" -> Just ([BOOL],a3)
 150						"Int" -> Just ([INT],a3)
 151						"abs" -> Just ([ABS],a3)
 152						"app" -> Just ([APP],a3)
 153						"true" -> Just ([TRUE],a3)
 154						"false" -> Just ([FALSE],a3)
 155						"if" -> Just ([IF],a3)
 156						"then" -> Just ([THEN],a3)
 157						"else" -> Just ([ELSE],a3)
 158						"fix" -> Just ([FIX],a3)
 159						"fi" -> Just ([FI],a3)
 160						"let" -> Just ([LET],a3)
 161						"in" -> Just ([IN],a3)
 162						"end" -> Just ([END],a3)
 163						_ -> Just ([ID a2],a3)
 164					_  -> Nothing
 165		Nothing -> Nothing
 166
 167--subscan for num
 168subscan2 :: String -> Maybe ([Token],String)
 169subscan2 str = case (matchRegexAll ex_num str) of
 170		Just (a1,a2,a3,a4) -> case a1 of
 171					"" -> Just ([NUM a2],a3)
 172					_  -> Nothing
 173		Nothing -> Nothing
 174\end{code}
 175
 176Function 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.\\
 177
 178
 179\begin{code}
 180--lexer
 181scan :: String -> [Token]
 182scan "" = []
 183
 184--white spase
 185scan (' ':xs) = scan xs
 186scan ('\t':xs) = scan xs
 187scan ('\n':xs) = scan xs
 188
 189--symbol
 190scan (':':xs) = [COLON] ++ scan xs
 191scan ('-':'>':xs) = [ARROW] ++ scan xs
 192scan ('(':xs) = [LPAR] ++ scan xs
 193scan (',':xs) = [COMMA] ++ scan xs
 194scan (')':xs) = [RPAR] ++ scan xs
 195scan ('.':xs) = [FULLSTOP] ++ scan xs
 196--special operator
 197scan ('+':xs) = [PLUS] ++ scan xs
 198scan ('-':xs) = [SUB] ++ scan xs
 199scan ('*':xs) = [MUL] ++ scan xs
 200scan ('/':xs) = [DIV] ++ scan xs
 201scan ('^':xs) = [NAND] ++ scan xs
 202scan ('=':xs) = [EQUAL] ++ scan xs
 203scan ('<':xs) = [LT_keyword] ++ scan xs 
 204
 205--id,keywords and num
 206scan str = case subscan1 str of
 207		Nothing -> case subscan2 str of
 208				Nothing -> error "[Scan]err: unexpected symbols!"
 209				Just (tok,xs) -> tok ++ scan xs
 210		Just (tok,xs) -> tok ++ scan xs
 211str str = error "[Scan]err: unexpected symbols!"
 212 
 213\end{code}
 214
 2152):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.\\
 216parseType function returns a matched Type and the remaining tokens, parseTerm function returns a matched Term and the remaining tokens.\\
 217We add Term ``Let Var Term Term" and ``Fix Term" and their related show functions.\\
 218Data structure:\\
 219\begin{code}
 220data Type = TypeArrow Type Type
 221	| TypeBool
 222	| TypeInt
 223	deriving Eq
 224
 225instance Show Type where
 226	show (TypeArrow tau1 tau2) = "->(" ++ show tau1 ++ "," ++ show tau2 ++ ")"
 227	show TypeBool = "Bool"
 228	show TypeInt = "Int"
 229
 230type Var = String
 231data Term = Var Var
 232	| Abs Var Type Term
 233	| App Term Term
 234	| Tru
 235	| Fls
 236	| If Term Term Term
 237	| IntConst Integer
 238	| IntAdd Term Term
 239	| IntSub Term Term
 240	| IntMul Term Term
 241	| IntDiv Term Term
 242	| IntNand Term Term
 243	| IntEq Term Term
 244	| IntLt Term Term
 245	| Fix Term
 246	| Let Var Term Term
 247	deriving Eq
 248
 249instance Show Term where
 250	show (Var x) = x
 251	show (Abs x tau t) = "abs(" ++ x ++ ":" ++ show tau ++ "." ++ show t ++ ")"
 252	show (App t1 t2) = "app(" ++ show t1 ++ "," ++ show t2 ++ ")"
 253	show Tru = "true"
 254	show Fls = "false"
 255	show (If t1 t2 t3) = "if " ++ show t1 ++ " then " ++ show t2 ++ " else " ++ show t3 ++ " fi"
 256	show (IntConst n) = show n
 257	show (IntAdd t1 t2) = "+(" ++ show t1 ++ "," ++ show t2 ++ ")"
 258	show (IntSub t1 t2) = "-(" ++ show t1 ++ ","  ++ show t2 ++ ")"
 259	show (IntMul t1 t2) = "*(" ++ show t1 ++ "," ++ show t2 ++ ")"
 260	show (IntDiv t1 t2) = "/(" ++ show t1 ++ "," ++ show t2 ++ ")"
 261	show (IntNand t1 t2) = "^(" ++ show t1 ++ "," ++ show t2 ++ ")"
 262	show (IntEq t1 t2) = "=(" ++ show t1 ++ "," ++ show t2 ++ ")"
 263	show (IntLt t1 t2) = "<(" ++ show t1 ++ "," ++ show t2 ++ ")"
 264	show (Fix t) = "fix " ++ show t
 265        show (Let v t1 t2) = "let " ++ v ++ "=" ++ show t1 ++ "in" ++ show t2
 266\end{code}
 267
 268Function parseType, parseTerm and parse:\\
 269In parseTerm, we add new pattern for let-in-end expression and fix-expression.\\
 270\begin{code}
 271--parser
 272
 273--type parser
 274parseType :: [Token] -> Maybe (Type,[Token])
 275parseType (BOOL:ty) = Just (TypeBool,ty)
 276parseType (INT:ty) = Just (TypeInt,ty)
 277parseType (RPAR:ty) = parseType ty
 278parseType (COMMA:ty) = parseType ty
 279parseType (ARROW:LPAR:ty) = 
 280	case parseType ty of
 281		Just (t1,(COMMA:tl)) -> case parseType tl of
 282						Just (t2,(RPAR:tll)) -> Just ((TypeArrow t1 t2),tll)
 283						Nothing -> Nothing
 284				Nothing -> Nothing
 285parseType tok = error "[P]err: type parsing error!"
 286
 287--term parser
 288parseTerm :: [Token] -> Maybe (Term,[Token])
 289----id
 290parseTerm ((ID id):ts) = Just ((Var id),ts)
 291----num
 292parseTerm ((NUM num):ts) = Just ((IntConst (read num::Integer)),ts)
 293----symbol
 294--parseTerm (COMMA:ts) = parseTerm ts
 295--parseTerm (COLON:ts) = parseTerm ts
 296--parseTerm (RPAR:ts) = parseTerm ts
 297--parseTerm (FULLSTOP:ts) = parseTerm ts
 298----keyword
 299parseTerm (THEN:ts) = parseTerm ts
 300parseTerm (ELSE:ts) = parseTerm ts
 301parseTerm (FI:ts) = parseTerm ts
 302parseTerm (TRUE:ts) = Just (Tru,ts)
 303parseTerm (FALSE:ts) = Just (Fls,ts)
 304----(term)
 305parseTerm (LPAR:ts) = case parseTerm ts of
 306			Just (t,(RPAR:tl)) -> Just (t,tl)
 307			Nothing -> Nothing
 308			_ -> error "[P]err: t is not a term in the (t)"
 309----op
 310parseTerm (PLUS:LPAR:ts) = 
 311	case parseTerm ts of
 312		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 313						Just (t2,(RPAR:tll)) -> Just ((IntAdd t1 t2),tll)
 314						Nothing -> Nothing
 315						_ -> error "[P]err: plus term"
 316		Nothing -> Nothing
 317		_ -> error "[P]err: plus term"
 318parseTerm (SUB:LPAR:ts) = 
 319	case parseTerm ts of
 320		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 321						Just (t2,(RPAR:tll)) -> Just ((IntSub t1 t2),tll)
 322						Nothing -> Nothing
 323						_ -> error "[P]err: sub term"
 324		Nothing -> Nothing
 325		_ -> error "[P]err: sub term"
 326parseTerm (MUL:LPAR:ts) = 
 327	case parseTerm ts of
 328		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 329						Just (t2,(RPAR:tll)) -> Just ((IntMul t1 t2),tll)
 330						Nothing -> Nothing
 331						_ -> error "[P]err: mul term"
 332		Nothing -> Nothing
 333		_ -> error "[P]err: mul term"
 334parseTerm (DIV:LPAR:ts) =
 335	 case parseTerm ts of
 336		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 337						Just (t2,(RPAR:tll)) -> Just ((IntDiv t1 t2),tll)
 338						Nothing -> Nothing
 339						_ -> error "[P]err: div term"
 340		Nothing -> Nothing
 341		_ -> error "[P]err: div term"
 342parseTerm (NAND:LPAR:ts) = 
 343	case parseTerm ts of
 344		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 345						Just (t2,(RPAR:tll)) -> Just ((IntNand t1 t2),tll)
 346						Nothing -> Nothing
 347						_ -> error "[P]err: nand term"
 348		Nothing -> Nothing
 349		_ -> error "[P]err: nand term"
 350parseTerm (EQUAL:LPAR:ts) =
 351	 case parseTerm ts of
 352		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 353						Just (t2,(RPAR:tll)) -> Just ((IntEq t1 t2),tll)
 354						Nothing -> Nothing
 355						_ -> error "[P]err: eq term"
 356		Nothing -> Nothing
 357		_ -> error "[P]err: eq term"
 358parseTerm (LT_keyword:LPAR:ts) = 
 359	case parseTerm ts of
 360		Just (t1,(COMMA:tl)) -> case parseTerm tl of
 361						Just (t2,(RPAR:tll)) -> Just ((IntLt t1 t2),tll)
 362						Nothing -> Nothing
 363						_ -> error "[P]err: lt term"
 364		Nothing -> Nothing
 365		_ -> error "[P]err: lt term"
 366----if-then-else
 367parseTerm (IF:ts) = 
 368	case parseTerm ts of
 369		Just (t1,(THEN:tl)) -> case parseTerm tl of
 370					Just (t2,(ELSE:tll)) -> case parseTerm tll of
 371								Just (t3,(FI:tn)) -> Just((If t1 t2 t3),tn)
 372								Nothing -> Nothing
 373								_ -> error "[P]err: if term"
 374					Nothing -> Nothing
 375					_ -> error "[P]err: if term"
 376		Nothing -> Nothing
 377		_ -> error "[P]err: if term"
 378
 379----fix
 380parseTerm (FIX:LPAR:ts) = case parseTerm ts of
 381				Just (t1,(RPAR:tl)) -> Just ((Fix t1),tl)
 382				Nothing -> Nothing
 383				_ -> error "[P]err: fix term"
 384
 385
 386----abs
 387parseTerm (ABS:LPAR:(ID id):COLON:ts) = 
 388	case parseType ts of
 389		Just (ty,(FULLSTOP:tl)) -> case parseTerm tl of
 390						Just (t,(RPAR:tll)) -> Just ((Abs id ty t),tll)
 391						Nothing -> Nothing
 392						_ -> error "[P]err: abs term"
 393		 Nothing -> Nothing
 394		 _ -> error "[P]err: abs term"
 395----app
 396parseTerm (APP:LPAR:ts) = case parseTerm ts of
 397				Just (t1,(COMMA:tl)) -> case parseTerm tl of
 398							  Just (t2,(RPAR:tll)) -> Just ((App t1 t2),tll)
 399							  Nothing -> Nothing
 400							  _ -> error "[P]err: app term"
 401				Nothing -> Nothing
 402				_ -> error "[P]err: app term"
 403----let-in-end
 404parseTerm (LET:(ID id):EQUAL:ts) = case parseTerm ts of
 405				      Just (t1,(IN:tl)) -> case parseTerm tl of
 406						             Just (t2,(END:tll)) -> Just ((Let id t1 t2),tll)
 407							     Nothing -> Nothing
 408							     _ -> error "[P]err: let term"
 409				      Nothing -> Nothing
 410				      _ -> error "[P]err: let term"
 411
 412----otherwise
 413parseTerm tok = Nothing
 414
 415--parser
 416parse :: [Token] -> Term
 417parse t = 
 418	  case parseTerm t of
 419		Just (x,t) -> case t of 
 420				[] -> x
 421				_ -> error "parsing error!"
 422		Nothing -> error "parsing error!"
 423
 424
 425\end{code}
 426
 427If the input string can't match any defined Term, function parser reports an error and the program stops at the parser level.\\
 428
 429\subsection{Auxiliary Functions}
 430
 431\paragraph{}
 432The implementation of the auxiliary functions are in the AbstractSyntax module.
 433\ \\
 434\begin{code}
 435-- list of free variables of a term
 436fv :: Term -> [Var]
 437fv (Var x) = [x]
 438fv (Abs x _ t) = filter (/=x) (fv t)
 439fv (App t1 t2) = (fv t1) ++ (fv t2)
 440fv (If t1 t2 t3) = (fv t1) ++ (fv t2) ++ (fv t3)
 441fv (IntAdd t1 t2) = (fv t1) ++ (fv t2)
 442fv (IntSub t1 t2) = (fv t1) ++ (fv t2)
 443fv (IntMul t1 t2) = (fv t1) ++ (fv t2)
 444fv (IntDiv t1 t2) = (fv t1) ++ (fv t2)
 445fv (IntNand t1 t2) = (fv t1) ++ (fv t2)
 446fv (IntEq t1 t2) = (fv t1) ++ (fv t2)
 447fv (IntLt t1 t2) = (fv t1) ++ (fv t2)
 448fv (Fix t) = fv t
 449fv (Let x t1 t2) = (fv t1) ++ (filter (/=x) (fv t2))
 450fv _ = []
 451
 452
 453subst :: Var -> Term -> Term -> Term
 454subst x s (Var v) = if x == v then s else (Var v)
 455subst x s (Abs y tau t1) = 
 456  if x == y then
 457              Abs y tau t1
 458            else 
 459              Abs y tau (subst x s t1)
 460subst x s (App t1 t2) = App (subst x s t1) (subst x s t2)
 461subst x s (If t1 t2 t3) = If (subst x s t1) (subst x s t2) (subst x s t3)
 462subst x s (IntAdd t1 t2) = IntAdd (subst x s t1) (subst x s t2)
 463subst x s (IntSub t1 t2) = IntSub (subst x s t1) (subst x s t2)
 464subst x s (IntMul t1 t2) = IntMul (subst x s t1) (subst x s t2)
 465subst x s (IntDiv t1 t2) = IntDiv (subst x s t1) (subst x s t2)
 466subst x s (IntNand t1 t2) = IntNand (subst x s t1) (subst x s t2)
 467subst x s (IntEq t1 t2) = IntEq (subst x s t1) (subst x s t2)
 468subst x s (IntLt t1 t2) = IntLt (subst x s t1) (subst x s t2)
 469subst x s (Fix t) = Fix (subst x s t)
 470subst x s (Let y t1 t2) = Let y (subst x s t1) (subst x s t2)
 471subst x s t = t
 472
 473isValue :: Term -> Bool
 474isValue (Abs _ _ _) = True
 475isValue Tru = True
 476isValue Fls = True
 477isValue (IntConst _) = True
 478isValue _ = False
 479\end{code}
 480\ \\
 481\subsection{Arithmetic}
 482
 483\begin{code}
 484
 485module IntegerArithmetic where
 486import Data.Bits
 487
 488intRestrictRangeAddMul :: Integer -> Integer
 489intRestrictRangeAddMul m = m `mod` 4294967296
 490
 491intAdd :: Integer -> Integer -> Integer
 492intAdd m n = intRestrictRangeAddMul (m + n)
 493
 494intSub :: Integer -> Integer -> Integer
 495intSub m n = m - n
 496
 497intMul :: Integer -> Integer -> Integer
 498intMul m n = intRestrictRangeAddMul (m * n)
 499
 500intDiv :: Integer -> Integer -> Integer
 501intDiv m n = if n == 0 then error "integer division by zero" else m `div` n
 502
 503intNand :: Integer -> Integer -> Integer
 504intNand m n = complement (m .&. n)
 505
 506intEq :: Integer -> Integer -> Bool
 507intEq m n = m == n
 508
 509intLt :: Integer -> Integer -> Bool
 510intLt m n = m < n
 511
 512\end{code}
 513
 514\subsection{Structural Operational Semantics}
 515
 516\subsubsection{Formal Rules}
 517
 518\paragraph{}
 519Formally stating the rules that give the structural operational semantics of the core lambda language, the rules are listed below:
 520\[
 521	\text{if true then } t_2 \text{ else } t_3 \rightarrow t_2 \text{\quad (\textsc{E-IfTrue})}
 522\]
 523\ \\
 524\[
 525        \text{if false then } t_2 \text{ else } t_3 \rightarrow t_3 \text{(\quad \textsc{E-IfFalse})}
 526\]
 527\ \\
 528\[
 529	\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})}
 530\]
 531\ \\
 532\[
 533	\frac{t_1 \rightarrow t'_1}{t_1 \text{\ } t_2 \rightarrow t'_1 \text{\ } t_2}\text{\quad {\textsc{E-App1}}}
 534\]
 535\ \\
 536\[
 537	\frac{t_2 \rightarrow t'_2}{t_1 \text{\ } t_2 \rightarrow t_1 \text{\ } t'_2}\text{\quad {\textsc{E-App2}}}
 538\]
 539\ \\
 540\[
 541	(\lambda x: T_{11}.t_{12})v_2 \rightarrow [ x \mapsto v_2 ] _{12} \text{\quad (\textsc{E-AppAbs})}
 542\]
 543\ \\
 544\[
 545	\frac{t_1 \rightarrow t'_1}{+(t_1, t_2) \rightarrow +(t'_1, t_2)} \text{\quad (\textsc{E-IntAdd1})}
 546\]
 547\ \\
 548\[
 549	\frac{t_2 \rightarrow t'_2}{+(t_1, t_2) \rightarrow +(t_1, t'_2)} \text{\quad (\textsc{E-IntAdd2})}
 550\]
 551\ \\
 552\[
 553	+(v_1, v_2) \rightarrow v_1 \widetilde{+} v_2 \text{\quad (\textsc{E-IntAppAdd})}
 554\]
 555\ \\
 556\[
 557	\frac{t_1 \rightarrow t'_1}{\-(t_1, t_2) \rightarrow -(t'_1, t_2)} \text{\quad (\textsc{E-IntSub1})}
 558\]
 559\ \\
 560\[
 561	\frac{t_2 \rightarrow t'_2}{\-(t_1, t_2) \rightarrow -(t_1, t'_2)} \text{\quad (\textsc{E-IntSub2})}
 562\]
 563\ \\
 564\[
 565	-(v_1, v_2) \rightarrow v_1 \widetilde{-} v_2 \text{\quad (\textsc{E-AppIntSub})}
 566\]
 567\ \\
 568\[
 569	\frac{t_1 \rightarrow t'_1}{*(t_1, t_2) \rightarrow *(t'_1, t_2)} \text{\quad (\textsc{E-IntMul1})}
 570\]
 571\ \\
 572\[
 573	\frac{t_2 \rightarrow t'_2}{*(t_1, t_2) \rightarrow *(t_1, t'_2)} \text{\quad (\textsc{E-IntMul2})}
 574\]
 575\ \\
 576\[
 577	*(v_1, v_2) \rightarrow v_1 \widetilde{*} v_2 \text{\quad (\textsc{E-AppIntMul})}
 578\]
 579\ \\
 580\[
 581	\frac{t_1 \rightarrow t'_1}{/(t_1, t_2) \rightarrow /(t'_1, t_2)} \text{\quad (\textsc{E-IntDiv1})}
 582\]
 583\ \\
 584\[
 585	\frac{t_2 \rightarrow t'_2}{/(t_1, t_2) \rightarrow /(t_1, t'_2)} \text{\quad (\textsc{E-IntDiv2})}
 586\]
 587\ \\
 588\[
 589	/(v_1, v_2) \rightarrow v_1 \widetilde{/} v_2 \text{\quad (\textsc{E-AppIntDiv})}
 590\]
 591\ \\
 592\[
 593	\frac{t_1 \rightarrow t'_1}{\wedge(t_1, t_2) \rightarrow \wedge(t'_1, t_2)} \text{\quad (\textsc{E-IntNand1})}
 594\]
 595\ \\
 596\[
 597	\frac{t_2 \rightarrow t'_2}{\wedge(t_1, t_2) \rightarrow \wedge(t_1, t'_2)} \text{\quad (\textsc{E-IntNand2})}
 598\]
 599\ \\
 600\[
 601	\wedge(v_1, v_2) \rightarrow v_1 \widetilde{\wedge} v_2 \text{\quad (\textsc{E-AppIntNand})}
 602\]
 603\ \\
 604\[
 605	\frac{t_1 \rightarrow t'_1}{=(t_1, t_2) \rightarrow =(t'_1, t_2)} \text{\quad (\textsc{E-IntEq1})}
 606\]
 607\ \\
 608\[
 609	\frac{t_2 \rightarrow t'_2}{=(t_1, t_2) \rightarrow =(t_1, t'_2)} \text{\quad (\textsc{E-IntEq2})}
 610\]
 611\ \\
 612\[
 613	=(v_1, v_2) \rightarrow v_1 \widetilde{\equiv} v_2 \text{\quad (\textsc{E-AppIntEq})}
 614\]
 615\ \\
 616\[
 617	\frac{t_1 \rightarrow t'_1}{<(t_1, t_2) \rightarrow <(t'_1, t_2)} \text{\quad (\textsc{E-IntLt1})}
 618\]
 619\ \\
 620\[
 621	\frac{t_2 \rightarrow t'_2}{<(t_1, t_2) \rightarrow <(t_1, t'_2)} \text{\quad (\textsc{E-IntLt2})}
 622\]
 623\ \\
 624\[
 625	<(v_1, v_2) \rightarrow v_1 \widetilde{<} v_2 \text{\quad (\textsc{E-AppIntLt})}
 626\]
 627\ \\
 628where
 629\begin{align*}
 630	\widetilde{+} &\text{\quad \quad is the funtion that adds the two arguments and returns an Integer result}\\
 631	\widetilde{-} &\text{\quad \quad is the function that subtracts the two arguments and returns an Integer result}\\
 632	\widetilde{*} &\text{\quad \quad is the function that times the two arguments and returns an Integer result}\\
 633	\widetilde{/} &\text{\quad \quad is the function that divides the two arguments and returns an Integer result}\\
 634	\widetilde{\wedge} &\text{\quad \quad is the function that gets the nand result of the two arguments and returns it }\\
 635	\widetilde{\equiv} &\text{\quad \quad is the function that judges whether the two values are equal. If so, returns \textbf{true}, otherwise \textbf{false}}\\
 636	\widetilde{<} &\text{\quad \quad is the function that judges whether the first value is less than the second one.} \\
 637        &\text{\quad \quad \ If so, returns \textbf{true}, otherwise \textbf{false}}
 638\end{align*}
 639
 640\[
 641	\text{fix }(\lambda x:T_1.\text{\ }t_2) \rightarrow [x\mapsto \text{fix } (\lambda x:T_1.\text{\ }t_2)]t_2 \text{\quad (\textsc{E-FixBeta})}
 642\]
 643
 644\[
 645	\frac{t_1 \rightarrow t'_1}{\text{fix }t_1 \rightarrow \text{fix } t'_1} \text{\quad (\textsc{E-Fix})}
 646\]
 647
 648\[
 649	\text{let } x=v_1 \text{ in } t_2 \rightarrow [x\mapsto v_1] t_2 \text{\quad (\textsc{E-LetV})}
 650\]
 651
 652\[
 653	\frac{t_1 \rightarrow t'_1}{\text{let } x=t_1 \text{ in } t_2 \rightarrow \text{let } x=t'_1 \text{ in } t_2} \text{\quad (\textsc{E-Let})}
 654\]
 655
 656\subsubsection{Haskell Implementation}
 657\begin{code}
 658
 659module StructuralOperationalSemantics where
 660import List
 661import qualified AbstractSyntax as S
 662import qualified IntegerArithmetic as I
 663
 664eval1 :: S.Term -> Maybe S.Term
 665-- E-IFTRUE
 666eval1 (S.If S.Tru t2 t3) = Just t2
 667
 668-- E-IFFALSE
 669eval1 (S.If S.Fls t2 t3) = Just t3
 670
 671-- E-IF
 672eval1 (S.If t1 t2 t3) = 
 673  case eval1 t1 of
 674    Just t1' -> Just (S.If t1' t2 t3)
 675    Nothing  -> Nothing
 676
 677-- E-APPABS, E-APP1 and E-APP2
 678eval1 (S.App t1 t2) = 
 679  if S.isValue t1
 680     then if S.isValue t2
 681             then case t1 of
 682                    S.Abs x tau11 t12 -> Just (S.subst x t2 t12) -- E-APPABS
 683                    _                 -> Nothing
 684             else case eval1 t2 of
 685                    Just t2' -> Just (S.App t1 t2')    -- E-APP2
 686                    Nothing  -> Nothing
 687     else case eval1 t1 of
 688            Just t1' -> Just (S.App t1' t2)   -- E-APP1
 689            Nothing  -> Nothing
 690
 691eval1 (S.IntAdd t1 t2) = 
 692  if S.isValue t1
 693     then case t1 of
 694            S.IntConst n1 -> if S.isValue t2
 695                              then case t2 of
 696                                     S.IntConst n2 -> Just (S.IntConst (I.intAdd n1 n2))
 697                                     _             -> Nothing
 698                              else case eval1 t2 of
 699                                     Just t2' -> Just (S.IntAdd t1 t2')
 700                                     Nothing  -> Nothing
 701            _           -> Nothing
 702     else case eval1 t1 of
 703            Just t1' -> Just (S.IntAdd t1' t2)
 704            Nothing  -> Nothing
 705
 706eval1 (S.IntSub t1 t2) = 
 707  if S.isValue t1
 708     then case t1 of
 709            S.IntConst n1 -> if S.isValue t2
 710                              then case t2 of
 711                                     S.IntConst n2 -> Just (S.IntConst (I.intSub n1 n2))
 712                                     _             -> Nothing
 713                              else case eval1 t2 of
 714                                     Just t2' -> Just (S.IntSub t1 t2')
 715                                     Nothing  -> Nothing
 716            _             -> Nothing
 717     else case eval1 t1 of
 718            Just t1' -> Just (S.IntSub t1' t2)
 719            Nothing  -> Nothing
 720
 721eval1 (S.IntMul t1 t2) = 
 722  if S.isValue t1
 723     then case t1 of
 724            S.IntConst n1 -> if S.isValue t2
 725                              then case t2 of
 726                                     S.IntConst n2 -> Just (S.IntConst (I.intMul n1 n2))
 727                                     _             -> Nothing
 728                              else case eval1 t2 of
 729                                     Just t2' -> Just (S.IntMul t1 t2')
 730                                     Nothing  -> Nothing
 731            _             -> Nothing
 732     else case eval1 t1 of
 733            Just t1' -> Just (S.IntMul t1' t2)
 734            Nothing  -> Nothing
 735
 736eval1 (S.IntDiv t1 t2) = 
 737  if S.isValue t1
 738     then case t1 of
 739            S.IntConst n1 -> if S.isValue t2
 740                              then case t2 of
 741                                     S.IntConst n2 -> Just (S.IntConst (I.intDiv n1 n2))
 742                                     _             -> Nothing
 743                              else case eval1 t2 of
 744                                     Just t2' -> Just (S.IntDiv t1 t2')
 745                                     Nothing  -> Nothing
 746            _             -> Nothing
 747     else case eval1 t1 of
 748            Just t1' -> Just (S.IntDiv t1' t2)
 749            Nothing  -> Nothing
 750
 751eval1 (S.IntNand t1 t2) = 
 752  if S.isValue t1
 753     then case t1 of
 754            S.IntConst n1 -> if S.isValue t2
 755                              then case t2 of
 756                                     S.IntConst n2 -> Just (S.IntConst (I.intNand n1 n2))
 757                                     _             -> Nothing
 758                              else case eval1 t2 of
 759                                     Just t2' -> Just (S.IntNand t1 t2')
 760                                     Nothing  -> Nothing
 761            _             -> Nothing
 762     else case eval1 t1 of
 763            Just t1' -> Just (S.IntNand t1' t2)
 764            Nothing  -> Nothing
 765
 766eval1 (S.IntEq t1 t2) = 
 767  if S.isValue t1
 768     then case t1 of
 769            S.IntConst n1 -> if S.isValue t2
 770                              then case t2 of
 771                                     S.IntConst n2 -> case I.intEq n1 n2 of
 772                                                      True -> Just S.Tru
 773                                                      _    -> Just S.Fls
 774                                     _             -> Nothing
 775                              else case eval1 t2 of
 776                                     Just t2' -> Just (S.IntEq t1 t2')
 777                                     Nothing  -> Nothing
 778            _             -> Nothing
 779     else case eval1 t1 of
 780            Just t1' -> Just (S.IntEq t1' t2)
 781            Nothing  -> Nothing
 782
 783eval1 (S.IntLt t1 t2) = 
 784  if S.isValue t1
 785     then case t1 of
 786            S.IntConst n1 -> if S.isValue t2
 787                              then case t2 of
 788                                     S.IntConst n2 -> case I.intLt n1 n2 of
 789                                                      True -> Just S.Tru
 790                                                      _    -> Just S.Fls
 791                                     _             -> Nothing
 792                              else case eval1 t2 of
 793                                     Just t2' -> Just (S.IntLt t1 t2')
 794                                     Nothing  -> Nothing
 795            _             -> Nothing
 796     else case eval1 t1 of
 797            Just t1' -> Just (S.IntLt t1' t2)
 798            Nothing  -> Nothing
 799
 800-- E-FIXBETA
 801eval1 (S.Fix (S.Abs x tau1 t2)) = 
 802  Just (S.subst x (S.Fix (S.Abs x tau1 t2)) t2)
 803
 804-- E-FIX
 805eval1 (S.Fix t1) = 
 806  case eval1 t1 of
 807    Just t1' -> Just (S.Fix t1')
 808    Nothing  -> Nothing
 809
 810-- E-LETV and E-LET
 811eval1 (S.Let x t1 t2) = 
 812  if (S.isValue t1)
 813     then Just (S.subst x t1 t2)   -- E-LETV
 814     else case eval1 t1 of
 815            Just t1' -> Just (S.Let x t1' t2)  -- E-LET
 816            Nothing  -> Nothing
 817
 818-- All other cases
 819eval1 _ = Nothing
 820
 821eval :: S.Term -> S.Term
 822eval t = 
 823  case eval1 t of
 824    Just t' -> eval t'
 825    Nothing -> t 
 826
 827\end{code}
 828
 829\subsection{Natural Semantics}
 830
 831\subsubsection{Formal Rules}
 832
 833\paragraph{}
 834The formal rules of the natural semantics for this programming language is as follows:
 835\[
 836	a\Downarrow v \text{\quad (\textsc{B-ClosedForm})}	
 837\]
 838for closed form $a$, and $a$ should have no free variable inside.
 839\[
 840	v \Downarrow v \text{\quad (\textsc{B-Value})}
 841\]
 842\ \\
 843\[
 844	\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})}
 845\]
 846\ \\
 847\[
 848	\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})}
 849\]
 850\ \\
 851\[
 852	\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})}
 853\]
 854\ \\
 855\[
 856	\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})}
 857\]
 858\ \\
 859\[
 860	\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})}
 861\]
 862\ \\
 863\[
 864	\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})}
 865\]
 866\ \\
 867\[
 868	\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})}
 869\]
 870\ \\
 871\[
 872	\frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{\wedge}(v_1, v_2)}{\uparrow(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntNand})}
 873\]
 874\ \\
 875\[
 876	\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})}
 877\]
 878\ \\
 879\[
 880	\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})}
 881\]
 882\ \\
 883\[
 884	\frac{t_1 \Downarrow v_1 \text{\quad} [x\mapsto v_1]t_2 \Downarrow v}{\text{let } x=t_1 \text{ in } t_2 \Downarrow v} \text{\quad (\textsc{B-Let})}
 885\]
 886\ \\
 887\[
 888	\frac{t \Downarrow (\lambda x:T_1.\text{\ }t_{11}) \text{\quad} [x\mapsto \text{fix }(\lambda x:T_1.\text{\ }t_{11})]t_{11} \Downarrow v}{\text{fix } t \Downarrow v} \text{\quad (\textsc{B-Fix})}
 889\]
 890\ \\
 891\subsubsection{Haskell Implementation}
 892
 893\begin{code}
 894module NaturalSemantics where
 895
 896import List
 897import qualified AbstractSyntax as S
 898import qualified IntegerArithmetic as I
 899
 900eval :: S.Term -> S.Term
 901
 902eval (S.If t1 t2 t3) = 
 903  case eval t1 of
 904    S.Tru -> eval t2  -- B-IfTrue
 905    S.Fls -> eval t3  -- B-IfFalse
 906    _     -> S.If t1 t2 t3 
 907
 908-- B-App \& B-AppFix
 909eval (S.App t1 t2) = 
 910  if (S.isValue $ eval t1)
 911     then case eval t1 of
 912            S.Abs x tau t11 -> if ((S.isValue $ eval t2) && ((S.fv (S.Abs x tau t11)) == []))
 913                                  then eval (S.subst x (eval t2) t11)
 914                                  else S.App t1 t2
 915            _               -> S.App t1 t2
 916     else S.App t1 t2
 917
 918-- B-IntAdd
 919eval (S.IntAdd t1 t2) = 
 920  case eval t1 of
 921    S.IntConst v1 -> case eval t2 of
 922                       S.IntConst v2 -> S.IntConst (I.intAdd v1 v2)
 923                       _            -> S.IntAdd t1 t2
 924    _             -> S.IntAdd t1 t2
 925
 926
 927-- B-IntSub
 928eval (S.IntSub t1 t2) = 
 929  case eval t1 of
 930    S.IntConst v1 -> case eval t2 of
 931                       S.IntConst v2 -> S.IntConst (I.intSub v1 v2)
 932                       _             -> S.IntSub t1 t2
 933    _             -> S.IntSub t1 t2
 934
 935-- B-IntMul
 936eval (S.IntMul t1 t2) = 
 937  case eval t1 of
 938    S.IntConst v1 -> case eval t2 of
 939                       S.IntConst v2 -> S.IntConst (I.intMul v1 v2)
 940                       _             -> S.IntSub t1 t2
 941    _             -> S.IntSub t1 t2
 942
 943-- B-IntDiv
 944eval (S.IntDiv t1 t2) =
 945  case eval t1 of
 946    S.IntConst v1 -> case eval t2 of
 947                       S.IntConst v2 -> S.IntConst (I.intDiv v1 v2)
 948                       _             -> S.IntDiv t1 t2
 949    _             -> S.IntDiv t1 t2
 950
 951-- B-IntNand
 952eval (S.IntNand t1 t2) =
 953  case eval t1 of
 954    S.IntConst v1 -> case eval t2 of
 955                       S.IntConst v2 -> S.IntConst (I.intNand v1 v2)
 956                       _             -> S.IntNand t1 t2
 957    _             -> S.IntNand t1 t2
 958
 959-- B-IntEq
 960eval (S.IntEq t1 t2) = 
 961  case eval t1 of
 962    S.IntConst v1 -> case eval t2 of
 963                       S.IntConst v2 -> case I.intEq v1 v2 of
 964                                          True  -> S.Tru
 965                                          False -> S.Fls
 966                       _             -> S.IntEq t1 t2
 967    _             -> S.IntEq t1 t2
 968
 969-- B-IntLt
 970eval (S.IntLt t1 t2) = 
 971  case eval t1 of
 972    S.IntConst v1 -> case eval t2 of
 973                       S.IntConst v2 -> case I.intLt v1 v2 of
 974                                          True  -> S.Tru
 975                                          False -> S.Fls
 976                       _             -> S.IntLt t1 t2
 977    _             -> S.IntLt t1 t2
 978
 979-- B-Let
 980eval (S.Let x t1 t2) = 
 981  if (S.isValue (eval t1))
 982     then if (S.isValue (eval (S.subst x (eval t1) t2)))
 983             then eval (S.subst x (eval t1) t2)
 984             else S.Let x t1 t2
 985     else S.Let x t1 t2
 986
 987-- B-FIX
 988eval (S.Fix t) = 
 989  if S.isValue $ eval t
 990     then case eval t of
 991            S.Abs x tau1 t11 -> if (S.isValue (eval (S.subst x (S.Fix (S.Abs x tau1 t11)) t11)))
 992                                   then eval (S.subst x (S.Fix (S.Abs x tau1 t11)) t11)
 993                                   else S.Fix t
 994            _                -> S.Fix t
 995     else S.Fix t
 996
 997-- B-Value and Exceptions
 998eval t = t
 999
1000\end{code}
1001
1002\subsection{Type Checker}
1003\subsubsection{Formal Rules}
1004It 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. The typing rules are listed below:
1005\[
1006	\frac{x:T\in \Gamma}{\Gamma \vdash x:T} \text{\quad (\textsc{T-Var})}
1007\]
1008\ \\
1009\[
1010	\frac{\Gamma, x:T_1 \vdash t_2: T_2 }{\Gamma \vdash \lambda x:T_1. t_2:T_1 \rightarrow T_2} \text{\quad (\textsc{T-Abs})}
1011\]
1012\ \\
1013\[
1014	\frac{\Gamma \vdash t_1: T_{11} \rightarrow T_{12} \mbox{   } \Gamma \vdash t_2:T_{11}}{\Gamma \vdash t_1\mbox{ } t_2:T_{12}} \text{\quad (\textsc{T-App})}
1015\]
1016\ \\
1017\[
1018	\text{true: Bool}  \text{\quad (\textsc{T-True})}
1019\]
1020\ \\
1021\[
1022        \text{false: Bool} \text{\quad (\textsc{T-False})}
1023\]
1024\ \\
1025\[
1026	\frac{t:Bool\mbox{    } t_2:T \mbox{    } t_3:T}{\text{if } t_1 \text{ then } t_2 \text{ else } t_3:T} \text{\quad (\textsc{T-If})}
1027\]
1028\ \\
1029\[
1030	\frac{\Gamma \vdash [x \mapsto t_1]t_2: T_2\mbox{   } \Gamma \vdash t_1: T_1}{\Gamma \vdash \mbox{ let } x=t_1 \mbox{ in } t_2 : T_2}\text{\quad {(\textsc{T-LetPoly})}}
1031\]
1032\ \\
1033\[
1034	\frac{\Gamma \vdash t_1: T_1\leftarrow T_1}{\Gamma \vdash \mbox{ fix } t_1 : T_1}\text{\quad {(\textsc{T-Fix})}}
1035\]
1036\ \\
1037\[
1038	\frac{t_1:Int \mbox{   } t_2:Int}{+(t_1, t_2):Int}\text{\quad {(\textsc{T-IntAdd})}}
1039\]
1040\ \\
1041\[
1042	\frac{t_1:Int \mbox{   } t_2:Int}{\-(t_1, t_2):Int}\text{\quad {(\textsc{T-IntSub})}}
1043\]
1044\ \\
1045\[
1046	\frac{t_1:Int \mbox{   } t_2:Int}{*(t_1, t_2):Int}\text{\quad {(\textsc{T-IntMul})}}
1047\]
1048\ \\
1049\[
1050	\frac{t_1:Int \mbox{   } t_2:Int}{\wedge(t_1, t_2):Int}\text{\quad {(\textsc{T-IntNand})}}
1051\]
1052\ \\
1053\[
1054	\frac{t_1:Int \mbox{   } t_2:Int}{=(t_1, t_2):Bool}\text{\quad {(\textsc{T-IntEq})}}
1055\]
1056\ \\
1057\[
1058	\frac{t_1:Int \mbox{   } t_2:Int}{<(t_1, t_2):Bool}\text{\quad {(\textsc{T-IntLt})}}
1059\]
1060\ \\
1061\subsubsection{Haskell Implementation}
1062\begin{code}
1063module Typing where
1064import qualified AbstractSyntax as S
1065import List
1066data Context  =  Empty
1067              |  Bind Context S.Var S.Type
1068              deriving Eq
1069instance Show Context where
1070  show Empty                  =  "<>"
1071  show (Bind capGamma x tau)  =  show capGamma ++ "," ++ x ++ ":" ++ show tau
1072
1073contextLookup :: S.Var -> Context -> Maybe S.Type
1074contextLookup x Empty  =  Nothing
1075contextLookup x (Bind capGamma y tau)
1076  | x == y      =  Just tau
1077  | otherwise   =  contextLookup x capGamma
1078
1079typing :: Context -> S.Term -> Maybe S.Type
1080--T-Var
1081typing capGamma (S.Var x) = contextLookup x capGamma
1082--T-Abs
1083typing capGamma (S.Abs x tau_1 t2) = case typing (Bind capGamma x tau_1) t2 of 
1084                         Just(tp0) -> Just (S.TypeArrow tau_1 tp0)
1085			 Nothing -> Nothing
1086typing capGamma (S.App t0 t2)=
1087	case typing capGamma t0 of 
1088		 Just (S.TypeArrow tp tp0) -> case typing capGamma t2 of 
1089						       Just tp' -> if tp==tp' 
1090						                      then Just tp0
1091								      else Nothing
1092						       Nothing  -> Nothing
1093		 _ -> Nothing
1094
1095--T-True
1096typing capGamma S.Tru = Just S.TypeBool
1097
1098--T-False
1099typing capGamma S.Fls = Just S.TypeBool
1100
1101--T-If
1102typing capGamma (S.If t0 t2 t3) 
1103	| (typing capGamma t2 == typing capGamma t3 && typing capGamma t0 == Just S.TypeBool) = typing capGamma t2
1104	| otherwise = Nothing
1105
1106typing capGamma (S.IntConst _) = Just S.TypeInt
1107
1108--T-LetPoly
1109typing capGamma (S.Let x t0 t2) =
1110	case typing capGamma (S.subst x t0 t2) of 
1111		Just tp0 -> case typing capGamma t0 of
1112				    Just tp1 -> Just tp0
1113		                    _	     -> Nothing
1114		_        -> Nothing
1115
1116--T-Fix
1117typing capGamma (S.Fix t) =
1118	case typing capGamma t of
1119		Just (S.TypeArrow tp0 tp2) -> if tp0 == tp2 
1120		                                  then Just tp0
1121						  else Nothing
1122		_			-> Nothing
1123
1124--T-IntAdd 
1125typing capGamma (S.IntAdd t1 t2) =
1126        case typing capGamma t1 of 
1127	         Just S.TypeInt -> case typing capGamma t1 of 
1128		                          Just S.TypeInt -> Just S.TypeInt
1129					  Nothing -> Nothing
1130--T-IntSub 
1131typing capGamma (S.IntSub t1 t2) =
1132        case typing capGamma t1 of 
1133	         Just S.TypeInt -> case typing capGamma t1 of 
1134		                          Just S.TypeInt -> Just S.TypeInt
1135					  Nothing -> Nothing
1136--T-IntMul 
1137typing capGamma (S.IntMul t1 t2) =
1138        case typing capGamma t1 of 
1139	         Just S.TypeInt -> case typing capGamma t1 of 
1140		                          Just S.TypeInt -> Just S.TypeInt
1141					  Nothing -> Nothing
1142--T-IntDiv
1143typing capGamma (S.IntDiv t1 t2) =
1144        case typing capGamma t1 of 
1145	         Just S.TypeInt -> case typing capGamma t1 of 
1146		                          Just S.TypeInt -> Just S.TypeInt
1147					  Nothing -> Nothing
1148--T-IntNand 
1149typing capGamma (S.IntNand t1 t2) =
1150        case typing capGamma t1 of 
1151	         Just S.TypeInt -> case typing capGamma t1 of 
1152		                          Just S.TypeInt -> Just S.TypeInt
1153					  Nothing -> Nothing
1154--T-IntEq
1155typing capGamma (S.IntEq t1 t2) =
1156        case typing capGamma t1 of 
1157	         Just S.TypeBool -> case typing capGamma t1 of 
1158		                          Just S.TypeBool -> Just S.TypeBool
1159					  Nothing -> Nothing
1160--T-IntLt
1161typing capGamma (S.IntLt t1 t2) =
1162        case typing capGamma t1 of 
1163	         Just S.TypeBool -> case typing capGamma t1 of 
1164		                          Just S.TypeBool -> Just S.TypeInt
1165					  Nothing -> Nothing
1166typeCheck :: S.Term -> S.Type
1167typeCheck t =
1168  case typing Empty t of
1169    Just tau -> tau
1170    _ -> error "type error"
1171\end{code}
1172
1173\subsubsection{Formal Rules}
1174
1175\subsubsection{Haskell Implementation}
1176
1177\subsection{Main Program}
1178
1179\begin{code}
1180module Main where
1181
1182import qualified System.Environment
1183import Data.List
1184import IO
1185import qualified AbstractSyntax as S
1186import qualified StructuralOperationalSemantics as E
1187import qualified NaturalSemantics as N
1188import qualified IntegerArithmetic as I
1189import qualified Typing as T
1190
1191main :: IO()
1192main = 
1193    do
1194      args <- System.Environment.getArgs
1195      let [sourceFile] = args
1196      source <- readFile sourceFile
1197      let tokens = S.scan source
1198      let term = S.parse tokens
1199      putStrLn ("----Term----")
1200      putStrLn (show term)
1201      putStrLn ("----Type----")
1202      putStrLn (show (T.typeCheck term))
1203      putStrLn ("----Normal Form in Structureal Operational Semantics----")
1204      putStrLn (show (E.eval term))
1205      putStrLn ("----Normal Form of Natural Semantics----")
1206      putStrLn (show (N.eval term))
1207\end{code}
1208
1209\section{Reduction Semantics}
1210
1211\subsection{Evaluation contexts}
1212
1213\begin{code}
1214
1215module EvaluationContext where
1216import qualified AbstractSyntax as S
1217
1218data Context = Hole
1219             | AppT Context S.Term
1220             | AppV S.Term Context   -- where Term is a value
1221             | If   Context S.Term S.Term
1222	     | IntAddT Context S.Term
1223	     | IntAddV S.Term Context
1224	     | IntSubT Context S.Term
1225	     | IntSubV S.Term Context
1226	     | IntMulT Context S.Term
1227	     | IntMulV S.Term Context
1228	     | IntDivT Context S.Term
1229	     | IntDivV S.Term Context
1230	     | IntNandT Context S.Term
1231	     | IntNandV S.Term Context
1232	     | IntEqT Context S.Term
1233	     | IntEqV S.Term Context
1234	     | IntLtT Context S.Term
1235	     | IntLtV S.Term Context
1236             | Let S.Var Context S.Term
1237	     | Fix Context
1238	     deriving Eq
1239
1240fillWithTerm :: Context -> S.Term -> S.Term
1241fillWithTerm c t = case c of
1242  Hole        -> t
1243  AppT c1 t2  -> S.App (fillWithTerm c1 t) t2
1244  AppV t1 c2  -> S.App t1 (fillWithTerm c2 t)
1245  If c1 t2 t3 -> S.If (fillWithTerm c1 t) t2 t3
1246  IntAddV t1 c2 -> S.IntAdd t1 (fillWithTerm c2 t)
1247  IntAddT c1 t2 -> S.IntAdd (fillWithTerm c1 t) t2
1248  IntSubV t1 c2 -> S.IntSub t1 (fillWithTerm c2 t)
1249  IntSubT c1 t2 -> S.IntSub (fillWithTerm c1 t) t2
1250  IntMulV t1 c2 -> S.IntMul t1 (fillWithTerm c2 t)
1251  IntMulT c1 t2 -> S.IntMul (fillWithTerm c1 t) t2
1252
1253  IntDivV t1 c2 -> S.IntDiv t1 (fillWithTerm c2 t)
1254  IntDivT c1 t2 -> S.IntDiv (fillWithTerm c1 t) t2
1255  IntNandV t1 c2 -> S.IntNand t1 (fillWithTerm c2 t)
1256  IntNandT c1 t2 -> S.IntNand (fillWithTerm c1 t) t2
1257  IntEqV t1 c2 -> S.IntEq t1 (fillWithTerm c2 t)
1258  IntEqT c1 t2 -> S.IntEq (fillWithTerm c1 t) t2
1259  IntLtV t1 c2 -> S.IntLt t1 (fillWithTerm c2 t)
1260  IntLtT c1 t2 -> S.IntLt (fillWithTerm c1 t) t2
1261
1262  Let x c1 t2 -> S.Let x (fillWithTerm c1 t) t2
1263  Fix c -> S.Fix (fillWithTerm c t)
1264
1265fillWithContext :: Context -> Context -> Context
1266fillWithContext c c' = case c of
1267  Hole        -> c'
1268  AppT c1 t2  -> AppT (fillWithContext c1 c') t2
1269  AppV t1 c2  -> AppV t1 (fillWithContext c2 c')
1270  If c1 t2 t3 -> If (fillWithContext c1 c') t2 t3
1271  IntAddV t1 c2 -> IntAddV t1 (fillWithContext c2 c')
1272  IntAddT c1 t2 -> IntAddT (fillWithContext c1 c') t2
1273  IntSubV t1 c2 -> IntSubV t1 (fillWithContext c2 c')
1274  IntSubT c1 t2 -> IntSubT (fillWithContext c1 c') t2
1275  IntMulV t1 c2 -> IntMulV t1 (fillWithContext c2 c')
1276  IntMulT c1 t2 -> IntMulT (fillWithContext c1 c') t2
1277  IntDivV t1 c2 -> IntDivV t1 (fillWithContext c2 c')
1278  IntDivT c1 t2 -> IntDivT (fillWithContext c1 c') t2
1279  IntNandV t1 c2 -> IntNandV t1 (fillWithContext c2 c')
1280  IntNandT c1 t2 -> IntNandT (fillWithContext c1 c') t2
1281  IntEqV t1 c2 -> IntEqV t1 (fillWithContext c2 c')
1282  IntEqT c1 t2 -> IntEqT (fillWithContext c1 c') t2
1283  IntLtV t1 c2 -> IntLtV t1 (fillWithContext c2 c')
1284  IntLtT c1 t2 -> IntLtT (fillWithContext c1 c') t2
1285  Let x c1 t2 -> Let x (fillWithContext c1 c') t2
1286  Fix c -> Fix (fillWithContext c c')
1287\end{code}
1288
1289\subsection{Standard reduction}
1290
1291\begin{code}
1292
1293module ReductionSemantics where
1294import qualified AbstractSyntax as S
1295import qualified EvaluationContext as E
1296import qualified StructuralOperationalSemantics as S
1297import qualified IntegerArithmetic as I
1298
1299makeEvalContext :: S.Term -> Maybe (S.Term, E.Context)
1300makeEvalContext t = case t of
1301  S.App (S.Abs x tau11 t12) t2
1302    | S.isValue t2 -> Just (t, E.Hole)
1303  S.App t1 t2
1304    | S.isValue t1 -> case makeEvalContext t2 of
1305                        Just (t2', c2) -> Just (t2', (E.AppV t1 c2))
1306                        _              -> Nothing
1307    | otherwise -> case makeEvalContext t1 of
1308                        Just(t1', c1) -> Just (t1', (E.AppT c1 t2))
1309                        _             -> Nothing
1310  S.If (S.Tru) t2 t3 -> Just (t, E.Hole)
1311  S.If (S.Fls) t2 t3 -> Just (t, E.Hole)
1312  S.If t1 t2 t3 -> case makeEvalContext t1 of
1313                        Just(t1', c1) -> Just (t1', (E.If c1 t2 t3))
1314                        _             -> Nothing
1315  S.IntAdd t1 t2
1316    | S.isValue t1 -> case makeEvalContext t2 of
1317                           Just(t2', c2) -> Just(t2', (E.IntAddV t1 c2))
1318                           Nothing       -> Just(t, E.Hole)
1319    | otherwise    -> case makeEvalContext t1 of
1320                           Just(t1', c1) -> Just(t1', (E.IntAddT c1 t2))
1321                           _             -> Nothing
1322  S.IntSub t1 t2
1323    | S.isValue t1 -> case makeEvalContext t2 of
1324                           Just(t2', c2) -> Just(t2', (E.IntSubV t1 c2))
1325                           Nothing -> Just(t, E.Hole)
1326    | otherwise -> case makeEvalContext t1 of
1327                        Just(t1', c1) -> Just(t1', (E.IntSubT c1 t2))
1328                        _             -> Nothing
1329  S.IntMul t1 t2
1330    | S.isValue t1 -> case makeEvalContext t2 of
1331                           Just(t2', c2) -> Just(t2', (E.IntMulV t1 c2))
1332                           Nothing       -> Just(t, E.Hole)
1333    | otherwise -> case makeEvalContext t1 of
1334                        Just(t1', c1) -> Just(t1', (E.IntMulT c1 t2))
1335                        _             -> Nothing
1336  S.IntDiv t1 t2
1337    | S.isValue t1 -> case makeEvalContext t2 of
1338                           Just(t2', c2) -> Just(t2', (E.IntDivV t1 c2))
1339                           Nothing -> Just(t, E.Hole)
1340    | otherwise -> case makeEvalContext t1 of
1341                        Just(t1', c1) -> Just(t1', (E.IntDivT c1 t2))
1342                        _             -> Nothing
1343  S.IntNand t1 t2
1344    | S.isValue t1 -> case makeEvalContext t2 of
1345                           Just(t2', c2) -> Just(t2', (E.IntNandV t1 c2))
1346                           Nothing -> Just(t, E.Hole)
1347    | otherwise -> case makeEvalContext t1 of
1348                           Just(t1', c1) -> Just(t1', (E.IntNandT c1 t2))
1349                           _             -> Nothing
1350  S.IntEq t1 t2
1351    | S.isValue t1 -> case makeEvalContext t2 of
1352                           Just(t2', c2) -> Just(t2', (E.IntEqV t1 c2))
1353                           Nothing -> Just(t, E.Hole)
1354    | otherwise -> case makeEvalContext t1 of
1355                        Just(t1', c1) -> Just(t1', (E.IntEqT c1 t2))
1356                        _ -> Nothing
1357  S.IntLt t1 t2
1358    | S.isValue t1 -> case makeEvalContext t2 of
1359                           Just(t2', c2) -> Just(t2', (E.IntLtV t1 c2))
1360                           Nothing -> Just(t, E.Hole)
1361    | otherwise -> case makeEvalContext t1 of
1362                        Just(t1', c1) -> Just(t1', (E.IntLtT c1 t2))
1363                        _             -> Nothing
1364  S.Let x t1 t2
1365    | S.isValue t1 -> Just (t, E.Hole)
1366    | otherwise -> case makeEvalContext t1 of
1367                        Just(t1', c1) -> Just(t1', (E.Let x c1 t2))
1368                        _             -> Nothing
1369  S.Fix (S.Abs x tau1 t2) -> Just (t, E.Hole)
1370  S.Fix t -> case makeEvalContext t of
1371                  Just(t', c) -> Just(t', E.Fix c)
1372                  _           -> Nothing
1373  _ -> Nothing
1374
1375makeContractum :: S.Term -> S.Term
1376makeContractum t = case t of
1377  S.App (S.Abs x tau11 t12) t2 -> S.subst x t2 t12
1378  S.If (S.Tru) t2 t3 -> t2
1379  S.If (S.Fls) t2 t3 -> t3
1380  S.IntAdd (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intAdd n1 n2)
1381  S.IntSub (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intSub n1 n2)
1382  S.IntMul (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intMul n1 n2)
1383  S.IntDiv (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intDiv n1 n2)
1384  S.IntNand (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intNand n1 n2)
1385  S.IntEq (S.IntConst n1) (S.IntConst n2) -> if I.intEq n1 n2 then S.Tru else S.Fls
1386  S.IntLt (S.IntConst n1) (S.IntConst n2) -> if I.intLt n1 n2 then S.Tru else S.Fls
1387  S.Let x t1 t2 -> S.subst x t1 t2
1388  S.Fix (S.Abs x tau1 t2) -> S.subst x (S.Fix (S.Abs x tau1 t2)) t2
1389
1390textualMachineStep :: S.Term -> Maybe S.Term
1391textualMachineStep t =
1392  case makeEvalContext t of
1393       Just(t1, c) -> Just (E.fillWithTerm c (makeContractum t1))
1394       Nothing     -> Nothing
1395
1396textualMachineEval :: S.Term -> S.Term
1397textualMachineEval t =
1398  case textualMachineStep t of
1399       Just t' -> textualMachineEval t'
1400       Nothing -> t
1401
1402\end{code}
1403
1404
1405\section{Abstract Register Machines}
1406
1407\subsection{CC Machine}
1408
1409\begin{code}
1410module CCMachine where
1411
1412import qualified AbstractSyntax as S
1413import qualified EvaluationContext as E
1414import qualified IntegerArithmetic as I
1415
1416lookupHole :: E.Context -> Maybe (E.Context, E.Context)
1417
1418lookupHole (E.AppT c1 t) = case c1 of
1419			     E.Hole -> Just ((E.AppT c1 t), E.Hole)
1420			     _      -> case lookupHole c1 of
1421				        Just (c2, c3) -> Just (c2, (E.AppT c3 t))
1422lookupHole (E.AppV v c1) = case c1 of 
1423                             E.Hole -> Just ((E.AppV v c1), E.Hole)
1424                             _      -> case lookupHole c1 of
1425				        Just(c2, c3) -> Just (c2, (E.AppV v c3))
1426
1427lookupHole (E.If c1 t1 t2) = case c1 of 
1428			       E.Hole -> Just((E.If c1 t1 t2), E.Hole)
1429			       _      -> case lookupHole c1 of
1430					   Just(c2, c3) -> Just (c2, (E.If c3 t1 t2))
1431		  
1432lookupHole (E.IntAddT c1 t) = case c1 of 
1433				E.Hole -> Just((E.IntAddT c1 t), E.Hole)
1434                                _      -> case lookupHole c1 of
1435					    Just(c2, c3) -> Just (c2, (E.IntAddT c3 t))
1436lookupHole (E.IntAddV t c1) = case c1 of
1437                                E.Hole -> Just((E.IntAddV t c1), E.Hole)
1438                                _      -> case lookupHole c1 of
1439                                           Just(c2, c3) -> Just (c2, (E.IntAddV t c3))
1440
1441lookupHole (E.IntSubT c1 t) = case c1 of
1442                                E.Hole -> Just((E.IntSubT c1 t), E.Hole)
1443                                _      -> case lookupHole c1 of
1444                                            Just(c2, c3) -> Just (c2, (E.IntSubT c3 t))
1445lookupHole (E.IntSubV t c1) = case c1 of
1446				E.Hole -> Just((E.IntSubV t c1), E.Hole)
1447				_      -> case lookupHole c1 of
1448					    Just(c2, c3) -> Just (c2, (E.IntSubV t c3))
1449		    
1450lookupHole (E.IntMulT c1 t) = case c1 of 
1451				E.Hole -> Just((E.IntMulT c1 t), E.Hole)
1452				_      -> case lookupHole c1 of
1453					    Just(c2, c3) -> Just (c2, (E.IntMulT c3 t))
1454
1455lookupHole (E.IntMulV t c1) = case c1 of
1456				E.Hole -> Just((E.IntMulV t c1), E.Hole)
1457				_      -> case lookupHole c1 of
1458					    Just(c2, c3) -> Just (c2, (E.IntMulV t c3))
1459
1460lookupHole (E.IntDivT c1 t) = case c1 of
1461				E.Hole -> Just((E.IntDivT c1 t), E.Hole)
1462                                _      -> case lookupHole c1 of
1463					    Just(c2, c3) -> Just (c2, (E.IntDivT c3 t))
1464lookupHole (E.IntDivV t c1) = case c1 of
1465				E.Hole -> Just((E.IntDivV t c1), E.Hole)
1466				_      -> case lookupHole c1 of
1467					    Just(c2, c3) -> Just (c2, (E.IntDivV t c3))
1468
1469lookupHole (E.IntNandT c1 t)= case c1 of
1470				E.Hole -> Just((E.IntNandT c1 t), E.Hole)
1471				_      -> case lookupHole c1 of
1472                                            Just(c2, c3) -> Just (c2, (E.IntNandT c3 t))
1473lookupHole (E.IntNandV t c1)= case c1 of 
1474				E.Hole -> Just((E.IntNandV t c1), E.Hole)
1475				_      -> case lookupHole c1 of
1476					    Just(c2, c3) -> Just (c2, (E.IntNandV t c3))
1477
1478lookupHole (E.IntEqT c1 t)= case c1 of 
1479			      E.Hole -> Just((E.IntEqT c1 t), E.Hole)
1480			      _      -> case lookupHole c1 of
1481				          Just(c2, c3) -> Just (c2, (E.IntEqT c3 t))
1482lookupHole (E.IntEqV t c1)= case c1 of
1483			      E.Hole -> Just((E.IntEqV t c1), E.Hole)
1484			      _   -> case lookupHole c1 of
1485					Just(c2, c3) -> Just (c2, (E.IntEqV t c3))
1486
1487lookupHole (E.IntLtT c1 t)= case c1 of
1488			      E.Hole -> Just((E.IntLtT c1 t), E.Hole)
1489			      _	     -> case lookupHole c1 of
1490					  Just(c2, c3) -> Just (c2, (E.IntLtT c3 t))
1491lookupHole (E.IntLtV t c1)= case c1 of
1492			      E.Hole -> Just((E.IntLtV t c1), E.Hole)
1493			      _      -> case lookupHole c1 of
1494					  Just(c2, c3) -> Just (c2, (E.IntLtV t c3))
1495 
1496lookupHole (E.Let x c1 t1)= case c1 of
1497			      E.Hole -> Just((E.Let x c1 t1), E.Hole)
1498			      _      -> case lookupHole c1 of
1499					  Just(c2, c3) -> Just (c2, (E.Let x c3 t1))
1500		 
1501lookupHole (E.Fix c1) = case c1 of 
1502			  E.Hole -> Just((E.Fix c1), E.Hole)
1503			  _      -> case lookupHole c1 of
1504				      Just(c2, c3) -> Just (c2, (E.Fix c3))
1505
1506lookupHole c1  =  Nothing
1507
1508ccMachineStep :: (S.Term, E.Context) -> Maybe (S.Term, E.Context)
1509ccMachineStep (t, c) = case t of
1510  S.App t1 t2
1511    | not (S.isValue t1)                      ->   Just (t1, E.fillWithContext c (E.AppT E.Hole t2))       {-cc1-}
1512    | S.isValue t1 && not (S.isValue t2)      ->   Just (t2, E.fillWithContext c (E.AppV t1 E.Hole))       {-cc2-}
1513  S.App (S.Abs x _ t12) t2                    ->   Just (S.subst x t2 t12, c)                              {-cc$\beta$-}
1514  
1515  S.IntAdd t1 t2
1516    | not(S.isValue t1)				-> Just (t1, E.fillWithContext c (E.IntAddT E.Hole t2))
1517    | S.isValue t1 && not (S.isValue t2)	-> Just (t2, E.fillWithContext c (E.IntAddV t1 E.Hole))
1518     {-cc3-}
1519    | otherwise	->  case t1 of
1520		      S.IntConst n1 -…

Large files files are truncated, but you can click here to view the full file