Skip to content

Instantly share code, notes, and snippets.

@stoffie
Last active August 29, 2015 14:05
Show Gist options
  • Save stoffie/89d06bf94365a436d90b to your computer and use it in GitHub Desktop.
Save stoffie/89d06bf94365a436d90b to your computer and use it in GitHub Desktop.
(* Damiano Stoffie 2014, public domain *)
type lambda_token =
OpeningBracketToken |
ClosingBracketToken |
LambdaToken |
DotToken |
NameToken of char
type lambda_expression =
LambdaName of char |
LambdaApplication of lambda_expression * lambda_expression |
LambdaFunction of char * lambda_expression
exception TokenizerException of string
exception ParserException of string
exception ParserError
let print expression =
let rec print_rec = function
| LambdaName(c) -> print_char c
| LambdaFunction(c, exp) ->
print_string "(\\";
print_char c;
print_char '.';
print_rec exp;
print_char ')';
| LambdaApplication(l, LambdaName(c)) ->
print_rec l;
print_rec (LambdaName (c));
| LambdaApplication(l, LambdaFunction(c, r)) ->
print_rec l;
print_rec (LambdaFunction (c, r));
| LambdaApplication(l, r) ->
print_rec l;
print_char '(';
print_rec r;
print_char ')'
in print_rec expression;
print_char '\n'
let rec tokenize s =
let char_is_lower_alpha c =
(Char.code c) >= (Char.code 'a') && (Char.code c) <= (Char.code 'z')
in
let remove_first_char s =
String.sub s 1 ((String.length s) - 1)
in
let s = String.trim s in
if s = "" then []
else if char_is_lower_alpha s.[0] then
[NameToken s.[0]] @ (tokenize (remove_first_char s))
else match s.[0] with
| '\\' -> [LambdaToken] @ (tokenize (remove_first_char s))
| '(' -> [OpeningBracketToken] @ (tokenize (remove_first_char s))
| ')' -> [ClosingBracketToken] @ (tokenize (remove_first_char s))
| '.' -> [DotToken] @ (tokenize (remove_first_char s))
| _ -> raise (TokenizerException "found an unknown token")
let parse tokens =
let count_brackets_length tokens =
let rec count_brakets_length_rec tokens depth i =
match tokens with
| [] -> raise (ParserException "missing one or more closing brackets")
| OpeningBracketToken::t ->
(count_brakets_length_rec t (depth + 1) (i + 1))
| ClosingBracketToken::t ->
if depth = 1 then i + 1
else (count_brakets_length_rec t (depth - 1) (i + 1))
| _::t ->
count_brakets_length_rec t depth (i + 1)
in count_brakets_length_rec tokens 0 0
in
let list_sub l start len =
let rec list_sub_rec l start len i =
if i >= List.length l then []
else if i >= start && i < start + len then
[List.nth l i] @ list_sub_rec l start len (i + 1)
else list_sub_rec l start len (i + 1)
in list_sub_rec l start len 0
in
let inner_expression tokens =
list_sub tokens 1 ((count_brackets_length tokens) - 2)
in
let outer_expression tokens =
let brakets_length = count_brackets_length tokens in
list_sub tokens brakets_length ((List.length tokens) - brakets_length)
in
let inner_lambda tokens =
list_sub tokens 4 ((count_brackets_length tokens) - 5)
in
let expression_is_lambda tokens =
(List.length tokens) >= 6 &&
match
(List.nth tokens 0,
List.nth tokens 1,
List.nth tokens 2,
List.nth tokens 3)
with
| (OpeningBracketToken, LambdaToken, NameToken (_), DotToken) -> true
| _ -> false
in
let lambda_function_name tokens =
match List.nth tokens 2 with
| NameToken(c) -> c
| _ -> raise ParserError
in
let rec parse_without_parent tokens =
if expression_is_lambda tokens then
let inner_exp = inner_lambda tokens in
let lambda_name = lambda_function_name tokens in
let outer_exp = outer_expression tokens in
(* print_string "found a lambda without parent\n"; *)
let lambda_function = LambdaFunction
(lambda_name,
parse_without_parent inner_exp) in
(* print_string "parsed lambda without parent: ";
print lambda_function; *)
parse_with_parent outer_exp lambda_function
else begin match tokens with
| (NameToken(c))::t ->
parse_with_parent t (LambdaName c)
| OpeningBracketToken::_ ->
let outer_exp = outer_expression tokens in
let inner_exp = inner_expression tokens in
parse_with_parent outer_exp (parse_without_parent inner_exp)
| _ -> raise ParserError
end
and parse_with_parent tokens parent =
if expression_is_lambda tokens then
let inner_exp = inner_lambda tokens in
let lambda_name = lambda_function_name tokens in
let outer_exp = outer_expression tokens in
(* print_string "found a lambda with parent, parent is: ";
print parent; *)
let lambda_function = LambdaFunction
(lambda_name,
parse_without_parent inner_exp) in
(* print_string "parsed lambda with parent: ";
print lambda_function; *)
parse_with_parent outer_exp (LambdaApplication (parent, lambda_function))
else begin match tokens with
| [] -> parent
| (NameToken (c))::t ->
parse_with_parent t (LambdaApplication (parent, LambdaName c))
| OpeningBracketToken::_ ->
let inner_exp = inner_expression tokens in
let outer_exp = outer_expression tokens in
let lambda_application = LambdaApplication
(parent,
parse_without_parent inner_exp) in
parse_with_parent outer_exp lambda_application
| _ -> raise ParserError
end
in parse_without_parent tokens
let rec normal_form = function
| LambdaName (_) -> true
| LambdaFunction (_, exp) -> normal_form exp
| LambdaApplication(LambdaFunction (_,_), _) -> false
| LambdaApplication(l, r) -> normal_form l && normal_form r
let rec eval expression =
let rec apply name left right =
match left with
| LambdaName(_) ->
if left = name then right
else left
| LambdaFunction (c, inner_exp) ->
LambdaFunction (c, (apply name inner_exp right))
| LambdaApplication (inner_l, inner_r) ->
LambdaApplication (apply name inner_l right, apply name inner_r right)
in match expression with
| LambdaName (c) -> LambdaName (c)
| LambdaFunction (c, exp) -> LambdaFunction (c, eval exp)
| LambdaApplication (LambdaFunction (c, l), r) -> apply (LambdaName c) l r
| LambdaApplication (l, r) ->
if normal_form l then LambdaApplication(l, eval r)
else LambdaApplication(eval l, r)
(* main *)
let run code =
let rec run_rec expression =
if normal_form expression then ()
else let expression = eval expression in
print expression;
run_rec expression
in let expression = parse (tokenize code) in
print_string ("Parsing and solving " ^ code ^ "\n");
print expression;
run_rec expression;;
(* run "(\\t.tx)((\\z.y(zx))(\\x.xx))";;
run "(\\z.zx)(\\x.y(xx))";;
run "(\\x.(\\z.z)x)(\\x.zx)";;
run "(\\x.x)(\\y.xy)x";;
run "(\\z.z(yx))((\\y.yz)(\\x.xyx))";;
run "(\\t.x(tt))((\\x.txy)(\\y.t(yt)))";;
run "(\\y.(y(yx)))(\\z.z)(\\t.ttx)";;
run "(\\y.xy)x((\\z.xzz)x)";;
run "(\\x.(\\y.yx))(\\z.zt)(\\x.xt)";; *)
run "(\\z.zz)(\\x.xyx)(\\z.t)";;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment