lambda.ml

(* 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)";;