(* ML code from the notes for "Introduction to Functional Programming" *) (* -------------------------------------------------------------------- *) 2+3; it; (* -------------------------------------------------------------------- *) val x=2*3; it=x; (* -------------------------------------------------------------------- *) val y=10 and z=x; val (x,y) = (y,x); (* -------------------------------------------------------------------- *) let val x=2 in x*y end; x; (* -------------------------------------------------------------------- *) tr(* comments can't go in the middle of names *)ue; 1 (* this comment is ignored *) < 2; (* Inside this comment (* another one is nested *) ! *) (* -------------------------------------------------------------------- *) fun f x = 2*x; f 4; (* -------------------------------------------------------------------- *) fun add (x:int) (y:int) = x+y; add 3 4; val f = add 3; f 4; (* -------------------------------------------------------------------- *) fun add(x,y):int = x+y; add(3,4); let val z = (3,4) in add z end; add 3; (* -------------------------------------------------------------------- *) fun sumdiff(x:int,y:int) = (x+y,x-y); sumdiff(3,4); (* -------------------------------------------------------------------- *) type intpair = int * int; fun addpair ((x,y):intpair) = x+y; (3,5); (3,5):intpair; addpair(3,5); (* -------------------------------------------------------------------- *) infix op1; infixr op2; (* -------------------------------------------------------------------- *) fun (x:int) op1 (y:int) = x + y; 1 op1 2; fun (x:int) op2 (y:int) = x * y; 2 op2 3; (* -------------------------------------------------------------------- *) op1; op op1; (* -------------------------------------------------------------------- *) 1 + 2; nonfix +; 1 + 2; (* -------------------------------------------------------------------- *) infix 6 +; (* -------------------------------------------------------------------- *) val m = [1,2,(2+1),4]; (hd m , tl m); (null m , null []); 0::m; [1, 2] @ [3, 4, 5, 6]; [1,true,2]; (* -------------------------------------------------------------------- *) "this is a string"; ""; (* -------------------------------------------------------------------- *) explode; explode "this is a string"; implode it; (* -------------------------------------------------------------------- *) val MikeData = {userid = "mjcg", sex = "male", married = true, children = 2}; (* -------------------------------------------------------------------- *) val MikeData' = {sex = "male", userid = "mjcg", children = 2, married = true}; MikeData = MikeData'; (* -------------------------------------------------------------------- *) #children MikeData; (* -------------------------------------------------------------------- *) fun Sex p = #sex p; type persondata = {userid:string, children:int, married:bool, sex:string}; fun Sex(p:persondata) = #sex p; (* -------------------------------------------------------------------- *) {1 = "Hello", 2 = true, 3 = 0}; #2 it; (* -------------------------------------------------------------------- *) hd [1,2,3]; hd [true,false,true]; hd [(1,2),(3,4)]; (* -------------------------------------------------------------------- *) hd; (* -------------------------------------------------------------------- *) map; fun add1 (x:int) = x+1; map add1 [1,2,3,4,5]; (* -------------------------------------------------------------------- *) map null [[1,2], [], [3], []]; (* -------------------------------------------------------------------- *) op o; fun add1 n = n+1 and add2 n = n+2; (add1 o add2) 5; (* -------------------------------------------------------------------- *) fn x => x+1; it 3; (* -------------------------------------------------------------------- *) map (fn x => x*x) [1,2,3,4]; val doubleup = map (fn x => x@x); doubleup [ [1,2], [3,4,5] ]; doubleup []; (* -------------------------------------------------------------------- *) if true then 1 else 2; if 2<1 then 1 else 2; (* -------------------------------------------------------------------- *) fun fact n = if n=0 then 1 else n*fact(n-1); fact 5; (* -------------------------------------------------------------------- *) fun f n : int = n+1; fun f n = if n=0 then 1 else n*f(n-1); f 3; (* -------------------------------------------------------------------- *) fun f n : int = n+1; val f = fn n => if n=0 then 1 else n*f(n-1); f 3; (* -------------------------------------------------------------------- *) fun f n : int = n + 1; val rec f = fn n => if n=0 then 1 else n*f(n-1); f 3; (* -------------------------------------------------------------------- *) fun Eq x y = (x = y); fun EqualHd l1 l2 = (hd l1 = hd l2); (* -------------------------------------------------------------------- *) hd = hd; EqualHd [hd] [hd]; (* -------------------------------------------------------------------- *) fun fact 0 = 1 | fact n = n * (fact(n-1)); (* -------------------------------------------------------------------- *) fun fib 0 = 0 | fib 1 = 1 | fib n = fib(n-1) + fib(n-2); (* -------------------------------------------------------------------- *) fun \(f p\sb{1} = e\sb{1}\) | \(f p\sb{2} = e\sb{2}\) \(\vdots\) | \(f p\sb{n} = e\sb{n}\) (* -------------------------------------------------------------------- *) fib 8; (* -------------------------------------------------------------------- *) fun hd(x::l) = x; fun tl(x::l) = l; (* -------------------------------------------------------------------- *) fun null [] = true | null _ = false; (* -------------------------------------------------------------------- *) fun RemoveDuplicates[] = [] | RemoveDuplicates[x] = [x] | RemoveDuplicates(x1::x2::l) = if x1=x2 then RemoveDuplicates(x2::l) else x1::RemoveDuplicates(x2::l); RemoveDuplicates[1,1,1,2,3,4,5,5,5,5,5,6,7,8,8,8]; (* -------------------------------------------------------------------- *) fun RemoveDuplicates[] = [] | RemoveDuplicates(l as [x]) = l | RemoveDuplicates(x1::(l as x2::_)) = if x1=x2 then RemoveDuplicates l else x1::RemoveDuplicates l; (* -------------------------------------------------------------------- *) fun RemoveDuplicates[] = [] | RemoveDuplicates(l as [x]) = l | RemoveDuplicates(x::(l as x::_)) = RemoveDuplicates l | RemoveDuplicates(x::l) = x::RemoveDuplicates l; (* -------------------------------------------------------------------- *) fn [] => "none" | [_] => "one" | [_,_] => "two" | _ => "many"; (it [], it[true], it[1,2], it[1,2,3]); (* -------------------------------------------------------------------- *) fun IsMale({sex="male",...}:persondata) = true | IsMale _ = false; IsMale MikeData; (* -------------------------------------------------------------------- *) fun IsMale({sex=x,...}:persondata) = (x = "male"); (* -------------------------------------------------------------------- *) fun IsMale({sex,...}:persondata) = (sex = "male"); (* -------------------------------------------------------------------- *) hd(tl[2]); 1 div 0; (1 div 0)+1000; (* -------------------------------------------------------------------- *) exception Ex3 of string; Ex3; raise Ex3 "foo"; (* -------------------------------------------------------------------- *) hd[1,2,3] handle _ => 0; hd[] handle _ => 0; hd(tl[2]) handle _ => 0; 1 div 0 handle _ => 1000; (* -------------------------------------------------------------------- *) exception Zero; exception Odd; fun half n = if n=0 then raise Zero else let val m = n div 2 in if n=2*m then m else raise Odd end; (* -------------------------------------------------------------------- *) half 4; half 0; half 3; half 3 handle _ => 1000; (* -------------------------------------------------------------------- *) half(0) handle Zero => 1000; half(1) handle Zero => 1000; half(0) handle Zero => 1000 | Odd => 1001; half(3) handle Zero => 1000 | Odd => 1001; (* -------------------------------------------------------------------- *) exception Half of string; fun half n = if n=0 then raise Half "Zero" else let val m = n div 2 in if n=2*m then m else raise Half "Odd" end; (* -------------------------------------------------------------------- *) half 0; half 3; half(0) handle Half "Zero" => 1000 | Half "Odd" => 1001; half(3) handle Half "Zero" => 1000 | Half "Odd" => 1001; (* -------------------------------------------------------------------- *) half(0) handle Half s => (if s="Zero" then 1000 else 1001); half(3) handle Half s => (if s="Zero" then 1000 else 1001); (* -------------------------------------------------------------------- *) datatype card = king | queen | jack | other of int; (* -------------------------------------------------------------------- *) king; other(4+5); (* -------------------------------------------------------------------- *) val value = fn king => 500 | queen => 200 | jack => 100 | (other n) => 5*n; (* -------------------------------------------------------------------- *) fun value king = 500 | value queen = 200 | value jack = 100 | value (other n) = 5*n; (* -------------------------------------------------------------------- *) datatype bool = true | false; (* -------------------------------------------------------------------- *) datatype int = zero | suc of int; (* -------------------------------------------------------------------- *) datatype sexp = litatom of string | numatom of int | cons of sexp * sexp; fun car (cons(x,y)) = x and cdr (cons(x,y)) = y; val a1 = litatom "Foo" and a2 = numatom 1; car(cons(a1,a2)); cdr(cons(a1,a2)); (* -------------------------------------------------------------------- *) car (litatom "foo"); (* -------------------------------------------------------------------- *) exception BadTime; abstype time = time of int * int with fun maketime(hrs,mins) = if hrs<0 orelse 23 0 do (result := !count * !result; count := !count-1); !result end; fact 6; (* -------------------------------------------------------------------- *) fun IsDigit x = "0" <= x andalso x <= "9"; (* -------------------------------------------------------------------- *) fun IsLetter x = ("a" <= x andalso x <= "z") orelse ("A" <= x andalso x <= "Z"); (* -------------------------------------------------------------------- *) fun IsSeparator x = (x = " " orelse x = "\n" orelse x = "\t"); (* -------------------------------------------------------------------- *) fun GetNumAux buf [] = (implode(rev buf), []) | GetNumAux buf (l as (x::l')) = if IsDigit x then GetNumAux (x::buf) l' else (implode(rev buf),l); GetNumAux ["a","b","c"] ["1","2","3"," ","4","5"]; (* -------------------------------------------------------------------- *) val GetNum = GetNumAux []; GetNum ["1","2","3"," ","4","5"]; (* -------------------------------------------------------------------- *) GetNum ["a","0","1"]; (* -------------------------------------------------------------------- *) fun GetIdentAux buf [] = (implode(rev buf), []) | GetIdentAux buf (l as (x::l')) = if IsLetter x orelse IsDigit x then GetIdentAux (x::buf) l' else (implode(rev buf),l); GetIdentAux ["a","b","c"] ["e","f","g","4","5"," ","6","7"]; (* -------------------------------------------------------------------- *) exception GetIdentErr; fun GetIdent (x::l) = if IsLetter x then GetIdentAux [x] l else raise GetIdentErr; (* -------------------------------------------------------------------- *) fun GetTail p buf [] = (implode(rev buf),[]) | GetTail p buf (l as x::l') = if p x then GetTail p (x::buf) l' else (implode(rev buf),l); (* -------------------------------------------------------------------- *) fun GetNextToken [x] = (x,[]) | GetNextToken (x::l) = if IsLetter x then GetTail (fn x => IsLetter x orelse IsDigit x) [x] l else if IsDigit x then GetTail IsDigit [x] l else (x,l); (* -------------------------------------------------------------------- *) fun Tokenise [] = [] | Tokenise (l as x::l') = if IsSeparator x then Tokenise l' else let val (t,l'') = GetNextToken l in t::(Tokenise l'') end; Tokenise (explode "123abcde1][ ] 56a"); (* -------------------------------------------------------------------- *) [("<", ["=","<"]), ("=", [">","="]), ("-", [">"]), ("==", [">"])] (* -------------------------------------------------------------------- *) fun Mem x [] = false | Mem x (x'::l) = (x=x') orelse Mem x l; Mem 3 [1,2,3,4,5,6,7]; Mem 9 [1,2,3,4,5,6,7]; (* -------------------------------------------------------------------- *) fun Get x [] = [] | Get x ((x',l)::rest) = if x=x' then l else Get x rest; Get "=" [("<",["=","<"]), ("=",[">","="]), ("-",[">"]), ("==",[">"])]; Get "?" [("<",["=","<"]), ("=",[">","="]), ("-",[">"]), ("==",[">"])]; (* -------------------------------------------------------------------- *) fun GetSymbol spectab tok [] = (tok,[]) | GetSymbol spectab tok (l as x::l') = if Mem x (Get tok spectab) then GetSymbol spectab (tok^x) l' else (tok,l); (* -------------------------------------------------------------------- *) fun GetNextToken spectab [x] = (x,[]) | GetNextToken spectab (x::(l as x'::l')) = if IsLetter x then GetTail (fn x => IsLetter x orelse IsDigit x) [x] l else if IsDigit x then GetTail IsDigit [x] l else if Mem x' (Get x spectab) then GetSymbol spectab (implode[x,x']) l' else (x,l); (* -------------------------------------------------------------------- *) fun Tokenise spectab [] = [] | Tokenise spectab (l as x::l') = if IsSeparator x then Tokenise spectab l' else let val (t,l'') = GetNextToken spectab l in t::(Tokenise spectab l'') end; (* -------------------------------------------------------------------- *) val SpecTab = [("=", ["<",">","="]), ("<", ["<",">"]), (">", ["<",">"]), ("==", [">"])]; Tokenise SpecTab (explode "a==>b c5 d5==ff+gg7"); (* -------------------------------------------------------------------- *) val Lex = Tokenise SpecTab o explode; Lex "a==>b c5 d5==ff+gg7"; (* -------------------------------------------------------------------- *) datatype tree = Atom of string | Comb of tree * tree; (* -------------------------------------------------------------------- *) fun Parse [next] = Atom next | Parse (next::rest) = Comb(Atom next, Parse rest); Parse["f", "x", "y", "z"]; (* -------------------------------------------------------------------- *) fun Parser t [] = t | Parser t (next::rest) = Parser (Comb(t, Atom next)) rest; fun Parse [next] = Atom next | Parse (next::rest) = Parser (Atom next) rest; Parse["f", "x", "y", "z"]; (* -------------------------------------------------------------------- *) datatype tree = Nil | Atom of string | Comb of tree * tree; (* -------------------------------------------------------------------- *) exception MissingClosingBracket; fun Parse [] = (Nil,[]) | Parse (rest as ")"::_) = (Nil,rest) | Parse ("("::rest) = (case Parse rest of (t, ")"::rest') => let val (t',rest'') = Parse rest' in (Comb(t,t'), rest'') end | _ => raise MissingClosingBracket) | Parse (next::rest) = let val (t,rest') = Parse rest in (Comb(Atom next,t),rest') end; (* -------------------------------------------------------------------- *) Parse ["x"]; Parse ["x","y","z"]; Parse ["x","y",")","z"]; (Comb (Atom "x",Comb (Atom "y",Nil)),[")","z"]) : tree * string list (* -------------------------------------------------------------------- *) fun MkComb(t,Nil) = t | MkComb p = Comb p; (* -------------------------------------------------------------------- *) fun Parse [] = (Nil,[]) | Parse (rest as ")"::_) = (Nil,rest) | Parse ("("::rest) = (case Parse rest of (t, ")"::rest') => let val (t',rest'') = Parse rest' in (MkComb(t,t'), rest'') end | _ => raise MissingClosingBracket) | Parse (next::rest) = let val (t,rest') = Parse rest in (MkComb(Atom next,t),rest') end; (* -------------------------------------------------------------------- *) Parse ["x"]; Parse ["x","y","z"]; Parse ["x","y",")","z"]; val it = (Comb (Atom "x",Atom "y"),[")","z"]) : tree * string list (* -------------------------------------------------------------------- *) Parse ["(",")"]; Parse ["(",")","a"]; Parse ["(",")","(",")"]; Parse [")","x"]; (* -------------------------------------------------------------------- *) fun Parse [] = (Nil,[]) | Parse ("("::")"::rest) = let val (t,rest') = Parse rest in (MkComb(Atom "",t),rest') end | Parse (rest as ")"::_) = (Nil,rest) | Parse ("("::rest) = (case Parse rest of (t, ")"::rest') => let val (t',rest'') = Parse rest' in (MkComb(t,t'), rest'') end | _ => raise MissingClosingBracket) | Parse (next::rest) = let val (t,rest') = Parse rest in (MkComb(Atom next,t),rest') end; (* -------------------------------------------------------------------- *) Parse ["(",")"]; Parse ["(",")","a"]; Parse ["(",")","(",")"]; (* -------------------------------------------------------------------- *) fun BuildComb parse t inp = let val (t', rest) = parse inp in (MkComb(t,t'), rest) end; fun Parse [] = (Nil,[]) | Parse ("("::")"::rest) = BuildComb Parse (Atom "") rest | Parse (rest as ")"::_) = (Nil,rest) | Parse ("("::rest) = (case Parse rest of (t, ")"::rest') => BuildComb Parse t rest' | _ => raise MissingClosingBracket) | Parse (next::rest) = BuildComb Parse (Atom next) rest; (* -------------------------------------------------------------------- *) fun CheckSym parse sym exn inp = case Parse inp of (t, next::rest) => if next=sym then BuildComb parse t rest else raise exn | _ => raise exn; fun Parse [] = (Nil,[]) | Parse ("("::")"::rest) = BuildComb Parse (Atom "") rest | Parse (rest as ")"::_) = (Nil,rest) | Parse ("("::rest) = CheckSym Parse ")" MissingClosingBracket rest | Parse (next::rest) = BuildComb Parse (Atom next) rest; (* -------------------------------------------------------------------- *) fun Parser t [] = (t, []) | Parser t ("("::")"::rest) = Parser (Comb(Atom "",t)) rest | Parser t (inp as ")"::_) = (t, inp) | Parser t [next] = (Comb(t,Atom next), []) | Parser t ("("::rest) = (case Parser Nil rest of (t', ")"::rest') => Parser (Comb(t,t')) rest' | _ => raise MissingClosingBracket) | Parser t (next::rest) = Parser (Comb(t,Atom next)) rest; val Parse = Parser Nil; (* -------------------------------------------------------------------- *) Parse ["x"]; Parse ["x","(","y","z",")","w"]; (* -------------------------------------------------------------------- *) fun MkComb(Nil,t2) = t2 | MkComb p = Comb p; fun Parser t [] = (t, []) | Parser t ("("::")"::rest) = Parser (Comb(Atom "",t)) rest | Parser t (inp as ")"::_) = (t, inp) | Parser t [next] = (MkComb(t,Atom next), []) | Parser t ("("::rest) = (case Parser Nil rest of (t', ")"::rest') => Parser (MkComb(t,t')) rest' | _ => raise MissingClosingBracket) | Parser t (next::rest) = Parser (MkComb(t,Atom next)) rest; val Parse = Parser Nil; (* -------------------------------------------------------------------- *) Parse ["x"]; Parse ["x","(","y","z",")","w"]; (* -------------------------------------------------------------------- *) datatype tree = Nil | Atom of string | BinOp of string * tree * tree; (* -------------------------------------------------------------------- *) val BinopTable = [("*", 7), ("+", 6)]; (* -------------------------------------------------------------------- *) fun Lookup ((s,n)::tab) x = if x=s then n else Lookup tab x; (* -------------------------------------------------------------------- *) fun InTable [] x = false | InTable ((s,n)::tab) x = (x=s orelse InTable tab x); (* -------------------------------------------------------------------- *) fun Parser tab m t [] = (t, []) | Parser tab m t (inp as next::rest) = if InTable tab next then let val n = Lookup tab next in if (m:int) > n then (t, inp) else let val (t',rest') = Parser tab n Nil rest in Parser tab m (BinOp(next,t, t')) rest' end end else Parser tab m (Atom next) rest; val Parse = Parser BinopTable 0 Nil; (* -------------------------------------------------------------------- *) Parse ["x","*","y","+","z"]; Parse ["x","+","y","*","z"]; Parse ["x","+","y","+","z"]; (* -------------------------------------------------------------------- *) Parse ["x","y","z"]; (* -------------------------------------------------------------------- *) datatype tree = Nil | Atom of string | Comb of tree * tree | BinOp of string * tree * tree; (* -------------------------------------------------------------------- *) fun Parser tab m t [] = (t, []) | Parser tab m t (inp as next::rest) = if InTable tab next then let val n = Lookup tab next in if (m:int) > n then (t, inp) else let val (t',rest') = Parser tab n Nil rest in Parser tab m (BinOp(next,t, t')) rest' end end else Parser tab m (Comb(t, Atom next)) rest; val Parse = Parser BinopTable 0 Nil; (* -------------------------------------------------------------------- *) Parse ["x","y","z"]; (* -------------------------------------------------------------------- *) fun MkComb(Nil,t2) = t2 | MkComb p = Comb p; fun Parser tab m t [] = (t, []) | Parser tab m t (inp as next::rest) = if InTable tab next then let val n = Lookup tab next in if (m:int) > n then (t, inp) else let val (t',rest') = Parser tab n Nil rest in Parser tab m (BinOp(next,t, t')) rest' end end else Parser tab m (MkComb(t, Atom next)) rest; val Parse = Parser BinopTable 0 Nil; (* -------------------------------------------------------------------- *) Parse ["x","y","z"]; Parse ["x","y","+","z"]; (* -------------------------------------------------------------------- *) datatype tree = Nil | Atom of string | Comb of tree * tree | Unop of string * tree | BinOp of string * tree * tree; fun MkComb(Nil,t2) = t2 | MkComb p = Comb p; (* -------------------------------------------------------------------- *) val UnopTable = [("~", 8), ("!", 5)]; (* -------------------------------------------------------------------- *) fun Parser (tab as (utab,btab)) m t [] = (t, []) | Parser (tab as (utab,btab)) m t (inp as next::rest) = if InTable utab next then let val n = Lookup utab next in let val (t',rest') = Parser tab n Nil rest in Parser tab m (MkComb(t, Unop(next,t'))) rest' end end else if InTable btab next then let val n = Lookup btab next in if (m:int) > n then (t, inp) else let val (t',rest') = Parser tab n Nil rest in Parser tab m (BinOp(next,t, t')) rest' end end else Parser tab m (MkComb(t, Atom next)) rest; (* -------------------------------------------------------------------- *) Parse ["x"]; Parse ["~","x"]; val it = (Unop ("~",Atom "x"),[]) : tree * string list Parse ["~","x","+","y"]; Parse ["!","x","+","y"]; (* -------------------------------------------------------------------- *) fun Parser (tab as (utab,btab)) m t [] = (t, []) | Parser tab m t ("("::")"::rest) = Parser tab m (Comb(Atom "",t)) rest | Parser tab m t (inp as ")"::_) = (t, inp) | Parser tab m t ("("::rest) = (case Parser tab 0 Nil rest of (t', ")"::rest') => Parser tab m (MkComb(t,t')) rest' | _ => raise MissingClosingBracket) | Parser (tab as (utab,btab)) m t (inp as next::rest) = if InTable utab next then let val n = Lookup utab next in let val (t',rest') = Parser tab n Nil rest in Parser tab m (MkComb(t, Unop(next,t'))) rest' end end else if InTable btab next then let val n = Lookup btab next in if (m:int) > n then (t, inp) else let val (t',rest') = Parser tab n Nil rest in Parser tab m (BinOp(next,t, t')) rest' end end else Parser tab m (MkComb(t, Atom next)) rest; val Parse = Parser (UnopTable,BinopTable) 0 Nil; (* -------------------------------------------------------------------- *) fun P s = Parse(explode s); P "~(x+y)"; P "(~x)+y"; P "(x+y)(zw)"; (* -------------------------------------------------------------------- *) datatype tree = Nil | Atom of string | Comb of tree * tree | Node of string * tree list; (* -------------------------------------------------------------------- *) exception NilRightArg; fun MkComb(Nil,t2) = t2 | MkComb(t1,Nil) = raise NilRightArg | MkComb(t1, t2) = Comb(t1,t2); (* -------------------------------------------------------------------- *) type parser = int -> tree -> string list -> tree * string list; (* -------------------------------------------------------------------- *) type symtab = string -> int * (parser -> parser); (* -------------------------------------------------------------------- *) fun Parser symtab (m:int) t [] = (t,[]) | Parser symtab m t (inp as next::rest) = let val (n,parsefn) = symtab next in if m>=n then (t,inp) else parsefn (Parser symtab) m t inp end; (* -------------------------------------------------------------------- *) fun Parser (tab:symtab) : parser = fn m => fn t => fn [] => (t,[]) | (inp as next::rest) => let val (n,parsefn) = tab next in if m>=n then (t,inp) else parsefn (Parser tab) m t inp end; (* -------------------------------------------------------------------- *) fun ParseAtom parse p t (next::rest) = parse p (MkComb(t,Atom next)) rest; (* -------------------------------------------------------------------- *) exception MissingClosingBracket; fun ParseBracket close parse p t (_::rest) = let val (t', next'::rest') = parse 0 Nil rest in if close=next' then parse p (MkComb(t,t')) rest' else raise MissingClosingBracket end; (* -------------------------------------------------------------------- *) exception TerminatorParseErr; fun Terminator parse _ = raise TerminatorParseErr; (* -------------------------------------------------------------------- *) fun Id x = x; (* -------------------------------------------------------------------- *) exception ChkAftErr; fun ChkAft s parse m t inp = case parse m t inp of (t', s'::rest) => if s=s' then (t',rest) else raise ChkAftErr; (* -------------------------------------------------------------------- *) fun MkUnop unop (t,tl) = MkComb(t,Node(unop,tl)); (* -------------------------------------------------------------------- *) fun MkBinop bnop (t,tl) = Node(bnop,t::tl); (* -------------------------------------------------------------------- *) fun ParseSeqAux m [f:parser->parser] (parse:parser) n inp = let val (t, rest1) = f parse m Nil inp in ([t], rest1) end | ParseSeqAux m (f::fl : (parser->parser)list) parse n inp = let val (t, rest1) = f parse 0 Nil inp in let val (l,rest2) = ParseSeqAux m fl parse 0 rest1 in (t::l, rest2) end end; fun ParseSeq mktree m (fl:(parser->parser)list) (parse:parser) : parser = fn n => fn t => fn (_::rest) => let val (l,rest1) = ParseSeqAux m fl parse n rest in parse n (mktree(t,l)) rest1 end; (* -------------------------------------------------------------------- *) fun SymTab "*" = (7, ParseSeq (MkBinop "MULT") 8 [Id]) | SymTab "+" = (6, ParseSeq (MkBinop "ADD") 5 [Id]) | SymTab "~" = (10, ParseSeq (MkUnop "MINUS") 9 [Id]) | SymTab "if" = (10, ParseSeq (MkUnop "COND") 0 [ChkAft "then", ChkAft "else", Id]) | SymTab "(" = (10, ParseBracket ")") | SymTab ")" = (0, Terminator) | SymTab "then" = (0, Terminator) | SymTab "else" = (0, Terminator) | SymTab x = (10, ParseAtom); (* -------------------------------------------------------------------- *) use "Lex.ml"; val P = Parser SymTab 0 Nil o Lex; P "f if x then y + z else y * z"; (* -------------------------------------------------------------------- *) datatype atom = Num of int | Op1 of string * (int->int) | Op2 of string * (int*int->int); (* -------------------------------------------------------------------- *) fun StringOfNum 0 = "0" | StringOfNum 1 = "1" | StringOfNum 2 = "2" | StringOfNum 3 = "3" | StringOfNum 4 = "4" | StringOfNum 5 = "5" | StringOfNum 6 = "6" | StringOfNum 7 = "7" | StringOfNum 8 = "8" | StringOfNum 9 = "9" | StringOfNum n = (StringOfNum(n div 10)) ^ (StringOfNum(n mod 10)); StringOfNum 1574; (* -------------------------------------------------------------------- *) fun ConApply(Op1(_,f1), Num m) = Num(f1 m) | ConApply(Op2(x,f2), Num m) = Op1((StringOfNum m^x), fn n => f2(m,n)); ConApply(Op2("+",op +), Num 2); ConApply(it, Num 3); (* -------------------------------------------------------------------- *) datatype lam = Var of string | Con of atom | App of (lam * lam) | Abs of (string * lam); (* -------------------------------------------------------------------- *) use "Parser.ml"; (* -------------------------------------------------------------------- *) fun LamSymTab "*" = (7, ParseSeq (MkBinop "MULT") 7 [Id]) | LamSymTab "+" = (6, ParseSeq (MkBinop "ADD") 6 [Id]) | LamSymTab "." = (0, Terminator) | LamSymTab "\\" = (10, ParseSeq(MkUnop "Abs") 0 [ChkAft ".", Id]) | LamSymTab "(" = (10, ParseBracket ")") | LamSymTab ")" = (0, Terminator) | LamSymTab x = (10, ParseAtom); (* -------------------------------------------------------------------- *) fun ParseLam s = let val (t,[]) = Parser LamSymTab 0 Nil (Lex s) in t end; ParseLam "(\\x.x+1) 200"; (* -------------------------------------------------------------------- *) fun IsNumber s = let fun TestDigList [] = true | TestDigList (x::l) = IsDigit x andalso TestDigList l in TestDigList(explode s) end; (* -------------------------------------------------------------------- *) fun DigitVal "0" = 0 | DigitVal "1" = 1 | DigitVal "2" = 2 | DigitVal "3" = 3 | DigitVal "4" = 4 | DigitVal "5" = 5 | DigitVal "6" = 6 | DigitVal "7" = 7 | DigitVal "8" = 8 | DigitVal "9" = 9; fun NumOfString s = let fun ListVal [] = 0 | ListVal (x::l) = DigitVal x + 10 * (ListVal l) in ListVal(rev(explode s)) end; NumOfString "2001"; (* -------------------------------------------------------------------- *) ParseLam "\\x y z. w"; (* -------------------------------------------------------------------- *) fun Convert (Atom x) = if IsNumber x then Con(Num(NumOfString x)) else Var x | Convert (Comb(a,b)) = App(Convert a, Convert b) | Convert (Node("Abs",[Atom x, a])) = Abs(x,Convert a) | Convert (Node("Abs",[Comb(a1, Atom x), a2])) = Convert(Node("Abs",[a1, Node("Abs",[Atom x,a2])])) | Convert (Node("ADD",[a,b])) = App(App(Con(Op2("+",(op+))), Convert a), Convert b); (* -------------------------------------------------------------------- *) val PL = Convert o ParseLam; PL "x+y"; PL "(\\x.x+y) y"; (* -------------------------------------------------------------------- *) PL "\\f. (\\x f.(\\z.x x f)) (\\x f.(\\z.x x f))"; (* -------------------------------------------------------------------- *) fun UPL (Var x) = x | UPL (Con(Num n)) = StringOfNum n | UPL (Con(Op1(x,_))) = x | UPL (Con(Op2(x,_))) = x | UPL (App(Con(Op1(x,_)),e)) = x ^ " " ^ BUPL e | UPL (App(App(Con(Op2(x,_)),e1),e2)) = BUPL e1 ^ x ^ BUPL e2 | UPL (App(e1,e2)) = UPL e1 ^ " " ^ BUPL e2 | UPL (Abs(x,e)) = "(\\" ^ x ^ ". " ^ UPL e ^ ")" and BUPL(Var x) = x | BUPL(Con(Num n)) = StringOfNum n | BUPL e = "(" ^ UPL e ^ ")"; (* -------------------------------------------------------------------- *) fun Mem x [] = false | Mem x (x'::s) = (x=x') orelse Mem x s; (* -------------------------------------------------------------------- *) fun Union [] l = l | Union (x::l1) l2 = if Mem x l2 then Union l1 l2 else x::(Union l1 l2); Union [1,2,3,4,5] [2,3,4,5,6,7]; (* -------------------------------------------------------------------- *) fun Subtract [] l = [] | Subtract (x::l1) l2 = if Mem x l2 then Subtract l1 l2 else x::(Subtract l1 l2); Subtract [1,2,3,4,5] [3,4,5,6]; (* -------------------------------------------------------------------- *) fun Frees (Var x) = [x] | Frees (Con c) = [] | Frees (App(e1,e2)) = Union (Frees e1) (Frees e2) | Frees (Abs(x,e)) = Subtract (Frees e) [x]; PL "\\x.x+y"; Frees it; (* -------------------------------------------------------------------- *) fun Prime x = x^"'"; Prime "x"; (* -------------------------------------------------------------------- *) fun Variant xl x = if Mem x xl then Variant xl (Prime x) else x; Variant ["x","y","z","y'","w"] "y"; (* -------------------------------------------------------------------- *) fun Subst (e as Var x') e' x = if x=x' then e' else e | Subst (e as Con c) e' x = e | Subst (App(e1, e2)) e' x = App(Subst e1 e' x, Subst e2 e' x) | Subst (e as Abs(x',e1)) e' x = if x=x' then e else if Mem x' (Frees e') then let val x'' = Variant (Frees e' @ Frees e1) x' in Abs(x'', Subst(Subst e1 (Var x'') x') e' x) end else Abs(x', Subst e1 e' x); (* -------------------------------------------------------------------- *) Subst (PL"(\\x.x+y) x") (PL"1") "x"; UPL it; UPL(Subst (PL"\\x.x+y") (PL"x+1") "y"); (* -------------------------------------------------------------------- *) fun EvalN (e as Var _ ) = e | EvalN (e as Con _) = e | EvalN (Abs(x,e)) = Abs(x, e) | EvalN (App(Con a1, Con a2)) = Con(ConApply(a1,a2)) | EvalN (App(e1,e2)) = case EvalN e1 of (Abs(x,e3)) => EvalN(Subst e3 e2 x) | (e1' as Con a1) => (case EvalN e2 of (Con a2) => Con(ConApply(a1,a2)) | e2' => App(e1',e2')) | e1' => App(e1', EvalN e2); (* -------------------------------------------------------------------- *) EvalN (PL"(\\x.1) ((\\x. x x) (\\x. x x))"); (* -------------------------------------------------------------------- *) fun EvalV (e as Var _) = e | EvalV (e as Con _) = e | EvalV (e as Abs(_,_)) = e | EvalV (App(e1,e2)) = let val e2' = EvalV e2 in (case EvalV e1 of (Abs(x,e3)) => EvalV(Subst e3 e2' x) | (e1' as Con a) => (case e2' of (Con a2) => Con(ConApply(a1,a2)) | _ => App(e1',e2')) | e1' => App(e1',e2')) end; (* -------------------------------------------------------------------- *) datatype item = Atomic of atom | Closure of (lam * env) and env = EmptyEnv | Env of string * item * env; (* -------------------------------------------------------------------- *) exception LookupErr; fun Lookup(s,EmptyEnv) = raise LookupErr | Lookup(s,Env(s',i,env)) = if s=s' then i else Lookup(s,env); (* -------------------------------------------------------------------- *) datatype instruction = Ap | Exp of lam; (* -------------------------------------------------------------------- *) type stack = item list and control = instruction list; datatype state = NullState | State of (stack * env * control * state); (* -------------------------------------------------------------------- *) fun Step(State(v::S, E, [], State(S',E',C',D'))) = State(v::S', E', C', D') | Step(State(S, E, Exp(Var x)::C, D)) = State(Lookup(x,E)::S, E, C, D) | Step(State(S, E, Exp(Con v)::C, D)) = State(Atomic v::S, E, C, D) | Step(State(S, E, Exp(Abs(x,e))::C, D )) = State(Closure(Abs(x,e),E)::S, E, C, D) | Step(State(Closure(Abs(x,e),E')::(v::S), E, Ap::C, D)) = State([], Env(x,v,E'), [Exp e], State(S,E,C,D)) | Step(State(Atomic v1::(Atomic v2::S), E, Ap::C, D )) = State(Atomic(ConApply(v1,v2))::S, E, C, D) | Step(State(S, E, Exp(App(e1,e2))::C, D)) = State(S, E, Exp e2::(Exp e1::(Ap::C)), D); (* -------------------------------------------------------------------- *) fun Run(state as State([_],EmptyEnv,[],NullState)) = [state] | Run state = state::Run(Step state); (* -------------------------------------------------------------------- *) fun Eval e = let fun EvalAux(State([v],EmptyEnv,[],NullState)) = v | EvalAux state = EvalAux(Step state) in EvalAux(State([],EmptyEnv,[Exp e],NullState)) end; (* -------------------------------------------------------------------- *) fun Load e = State([],EmptyEnv,[Exp e],NullState); (* -------------------------------------------------------------------- *) fun SECDRun s = Run(Load s); fun SECDEval s = Eval(PL s); SECDEval "(\\x.\\y. x+y) 1 2";