(* ========================================================================= *) (* Simple algebraic expression example from the introductory chapter. *) (* *) (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) (* ========================================================================= *) type expression = Var of string | Const of int | Add of expression * expression | Mul of expression * expression;; (* ------------------------------------------------------------------------- *) (* Trivial example of using the type constructors. *) (* ------------------------------------------------------------------------- *) START_INTERACTIVE;; Add(Mul(Const 2,Var "x"),Var "y");; END_INTERACTIVE;; (* ------------------------------------------------------------------------- *) (* Simplification example. *) (* ------------------------------------------------------------------------- *) let simplify1 expr = match expr with Add(Const(m),Const(n)) -> Const(m + n) | Mul(Const(m),Const(n)) -> Const(m * n) | Add(Const(0),x) -> x | Add(x,Const(0)) -> x | Mul(Const(0),x) -> Const(0) | Mul(x,Const(0)) -> Const(0) | Mul(Const(1),x) -> x | Mul(x,Const(1)) -> x | _ -> expr;; let rec simplify expr = match expr with Add(e1,e2) -> simplify1(Add(simplify e1,simplify e2)) | Mul(e1,e2) -> simplify1(Mul(simplify e1,simplify e2)) | _ -> simplify1 expr;; (* ------------------------------------------------------------------------- *) (* Example. *) (* ------------------------------------------------------------------------- *) START_INTERACTIVE;; let e = Add(Mul(Add(Mul(Const(0),Var "x"),Const(1)),Const(3)), Const(12));; simplify e;; END_INTERACTIVE;; (* ------------------------------------------------------------------------- *) (* Lexical analysis. *) (* ------------------------------------------------------------------------- *) let matches s = let chars = explode s in fun c -> mem c chars;; let space = matches " \t\n\r" and punctuation = matches "()[]{}," and symbolic = matches "~`!@#\$%^&*-+=|\\:;<>.?/" and numeric = matches "0123456789" and alphanumeric = matches "abcdefghijklmnopqrstuvwxyz_'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";; let rec lexwhile prop inp = match inp with c::cs when prop c -> let tok,rest = lexwhile prop cs in c^tok,rest | _ -> "",inp;; let rec lex inp = match snd(lexwhile space inp) with [] -> [] | c::cs -> let prop = if alphanumeric(c) then alphanumeric else if symbolic(c) then symbolic else fun c -> false in let toktl,rest = lexwhile prop cs in (c^toktl)::lex rest;; START_INTERACTIVE;; lex(explode "2*((var_1 + x') + 11)");; lex(explode "if (*p1-- == *p2++) then f() else g()");; END_INTERACTIVE;; (* ------------------------------------------------------------------------- *) (* Parsing. *) (* ------------------------------------------------------------------------- *) let rec parse_expression i = match parse_product i with e1,"+"::i1 -> let e2,i2 = parse_expression i1 in Add(e1,e2),i2 | e1,i1 -> e1,i1 and parse_product i = match parse_atom i with e1,"*"::i1 -> let e2,i2 = parse_product i1 in Mul(e1,e2),i2 | e1,i1 -> e1,i1 and parse_atom i = match i with [] -> failwith "Expected an expression at end of input" | "("::i1 -> (match parse_expression i1 with e2,")"::i2 -> e2,i2 | _ -> failwith "Expected closing bracket") | tok::i1 -> if forall numeric (explode tok) then Const(int_of_string tok),i1 else Var(tok),i1;; (* ------------------------------------------------------------------------- *) (* Generic function to impose lexing and exhaustion checking on a parser. *) (* ------------------------------------------------------------------------- *) let make_parser pfn s = let expr,rest = pfn (lex(explode s)) in if rest = [] then expr else failwith "Unparsed input";; (* ------------------------------------------------------------------------- *) (* Our parser. *) (* ------------------------------------------------------------------------- *) let default_parser = make_parser parse_expression;; START_INTERACTIVE;; default_parser "x + 1";; (* ------------------------------------------------------------------------- *) (* Demonstrate automatic installation. *) (* ------------------------------------------------------------------------- *) <<(x1 + x2 + x3) * (1 + 2 + 3 * x + y)>>;; END_INTERACTIVE;; (* ------------------------------------------------------------------------- *) (* Conservatively bracketing first attempt at printer. *) (* ------------------------------------------------------------------------- *) let rec string_of_exp e = match e with Var s -> s | Const n -> string_of_int n | Add(e1,e2) -> "("^(string_of_exp e1)^" + "^(string_of_exp e2)^")" | Mul(e1,e2) -> "("^(string_of_exp e1)^" * "^(string_of_exp e2)^")";; (* ------------------------------------------------------------------------- *) (* Examples. *) (* ------------------------------------------------------------------------- *) START_INTERACTIVE;; string_of_exp <>;; END_INTERACTIVE;; (* ------------------------------------------------------------------------- *) (* Somewhat better attempt. *) (* ------------------------------------------------------------------------- *) let rec string_of_exp pr e = match e with Var s -> s | Const n -> string_of_int n | Add(e1,e2) -> let s = (string_of_exp 3 e1)^" + "^(string_of_exp 2 e2) in if 2 < pr then "("^s^")" else s | Mul(e1,e2) -> let s = (string_of_exp 5 e1)^" * "^(string_of_exp 4 e2) in if 4 < pr then "("^s^")" else s;; (* ------------------------------------------------------------------------- *) (* Install it. *) (* ------------------------------------------------------------------------- *) let print_exp e = Format.print_string ("<<"^string_of_exp 0 e^">>");; #install_printer print_exp;; (* ------------------------------------------------------------------------- *) (* Examples. *) (* ------------------------------------------------------------------------- *) START_INTERACTIVE;; <>;; <<(x + 3) * y>>;; <<1 + 2 + 3>>;; <<((1 + 2) + 3) + 4>>;; END_INTERACTIVE;; (* ------------------------------------------------------------------------- *) (* Example shows the problem. *) (* ------------------------------------------------------------------------- *) START_INTERACTIVE;; <<(x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10) * (y1 + y2 + y3 + y4 + y5 + y6 + y7 + y8 + y9 + y10)>>;; END_INTERACTIVE;;