/exercise2/exercise2.lhs
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