c.ml

open Tree;;

let rec  write_to_string expression =
    let token = expression in
        match token with
            | Application (a,b) ->      "(" ^ (write_to_string a) ^ " " ^ (write_to_string b) ^ ")"

            | Abstraction (a,b) ->      (String.concat "" ["(\\";a;"."]) ^ (write_to_string b) ^ ")"

            | Variable(a)       ->      a;;

module AlgebraMap = Map.Make(String);;

module AbstractVar = Map.Make(String);;

type algebra =  Var of string (* constant *)
            |   Func of string * algebra * algebra (* for expression like -> smth smth *);;

type tmp_derivation =   BuildTypeVar of algebra
                        | BuildTypeAbstr of algebra * algebra * tmp_derivation
                        | BuildTypeAppl of algebra * algebra * algebra * tmp_derivation * tmp_derivation ;;

let common_variable = "a";;

let custom_merge a b = List.rev_append a b;;

let rec algebra_to_string expression =
    let token = expression in
        match token with
            | Var(a) -> a
            | Func(a, b , c) -> String.concat "" ["(" ; (algebra_to_string b) ; a ; (algebra_to_string c); ")"];;



let update_variable var =
    let last = (String.length var) - 1 in
        let symb = String.get var last in
            match symb with
                | 'z'   ->   var ^ "a"
                | _     ->   let new_var = String.sub var 0 last  in
                                let new_var = new_var ^ Char.escaped (Char.chr ((Char.code symb) + 1) ) in
                                    new_var;;

 let rec build_system expression free_var abstaction_name unbound_names =
    let token = expression in
        match token with
            | Application (a, b) ->  let union_a, term_a, last_map_a, last_unbound_map_a, last_var_a, derivation_a =  build_system a free_var abstaction_name unbound_names in
                                        let  union_b, term_b, last_map_b, last_unbound_map_b, last_var_b, derivation_b = build_system b last_var_a abstaction_name last_unbound_map_a in
                                            let new_var = update_variable last_var_b in
                                                let merged_equation = custom_merge union_a union_b in
                                                    let merged_map = AbstractVar.fold AbstractVar.add last_map_a last_map_b in
                                                        let algebra_type = Func ("->", term_b, Var(new_var)) in
                                                            let derivation = BuildTypeAppl(term_a, term_b, Var new_var, derivation_a, derivation_b) in
                                                                let added_equation = merged_equation @ [(term_a, algebra_type)] in
                                                                    (added_equation, Var(new_var), merged_map, last_unbound_map_b, new_var, derivation)

            | Abstraction (a, b) ->     let new_free_var = update_variable free_var in
                                            let updated_map = AbstractVar.add a new_free_var abstaction_name in
                                                let union_b, term_b, last_map_b, last_unbound_map_b, last_var_b, deriavtion_b = build_system b new_free_var updated_map unbound_names in
                                                    let new_var = update_variable last_var_b in
                                                        let algebra_type = Func ("->", Var new_free_var, term_b) in
                                                            let derivation = BuildTypeAbstr(Var new_free_var, term_b, deriavtion_b) in
                                                                (union_b, algebra_type, last_map_b, last_unbound_map_b, new_var, derivation)

            | Variable (a)       ->     let contains_variable = AbstractVar.mem a abstaction_name in
                                            if contains_variable then
                                                let variable_name = AbstractVar.find a abstaction_name in
                                                    let algebra_type = Var(variable_name) in
                                                        ([], algebra_type, abstaction_name, unbound_names, free_var, BuildTypeVar algebra_type)
                                            else
                                                let unbound_var = AbstractVar.mem a unbound_names in
                                                    match unbound_var with
                                                    | true -> let var_name = AbstractVar.find a unbound_names in
                                                                let algebra_type = Var var_name in
                                                                    ([], algebra_type, abstaction_name, unbound_names, free_var, BuildTypeVar algebra_type)
                                                    | false -> let new_var = update_variable free_var in
                                                                    let added_bound_names = AbstractVar.add a new_var unbound_names in
                                                                            let algebra_type = Var(new_var) in
                                                                                ([], algebra_type, abstaction_name, added_bound_names, new_var, BuildTypeVar algebra_type);;

let encure_array eq_system =
    let double_list = List.map (fun x-> (x,(fst x, snd x))) eq_system in
        let la, lb = List.split double_list in
            List.rev_append la lb;;

let is_var equation =
    match  equation with
        | Var(a) -> true
        | _ -> false;;

let second_action item =
    if (not (is_var (fst item))) && (not (is_var (snd item))) then
        match item with
        | Func(a, b, c), Func(d, e, f) ->   [(b, e); (c, f)]
        | _ -> []
    else
        [item];;

let rec num_of_vars equation map_of_vars =
    match equation with
    | Var(a) -> if AbstractVar.mem a map_of_vars then
                            let num  = AbstractVar.find a map_of_vars in
                                    AbstractVar.add a (num + 1) map_of_vars
                        else AbstractVar.add a 1 map_of_vars
    | Func(a, b, c) -> let left_map = num_of_vars b map_of_vars in
                            let right_map = num_of_vars c left_map in
                                right_map;;
let available_map equations =
    List.filter (fun x -> let left, right  = x in
                    match left with
                    | Var(a) -> true
                    | _ -> false) equations;;

let rec replace_var_in_expression expression variable template =
    match expression with
    | Var(a) -> if Var (a) = variable then template else Var(a)
    | Func(a,b,c) -> let left_replace = if b = variable then template else replace_var_in_expression b variable template in
                        let right_replace = if c = variable then template else replace_var_in_expression c variable template in
                               Func(a,left_replace,right_replace)
                               ;;

let rec check_exist_recursion variable equations =
    match equations with
    | Var(a) -> Var(a) = variable
    | Func(a,b,c) -> let left = check_exist_recursion variable b in
                        let right = check_exist_recursion variable c in
                            left || right;;

let rec check_same_derivation equations =
    match equations with
    | [] -> true
    | _ -> let left,right = List.hd equations in
                let tail = List.tl equations in
                    match left with
                    | Var(a) -> let result = check_exist_recursion (Var a) right in
                                    if  result then false else check_same_derivation tail
                    | _ -> check_same_derivation tail;;

let rec help_delete_repeat left right equations =
    match equations with
    | [] -> []
    | _ -> let head_left, head_right =  List.hd equations in
                let tail = List.tl equations in
                    if head_left = left && head_right = right then
                        help_delete_repeat left right tail
                    else
                        [(head_left, head_right)] @ (help_delete_repeat left right tail);;

let rec delete_repeat equations =
    match equations with
    | [] -> []
    | _ -> let head_left, head_right =  List.hd equations in
                let tail = List.tl equations in
                    let result_delete = help_delete_repeat head_left head_right tail in
                        [(head_left, head_right)] @ (delete_repeat result_delete);;

let fourth_action_replace variable template equations =
    List.map (fun item ->
                    let left, right = item in
                        if left = variable && right = template then
                            item
                        else
                            (replace_var_in_expression left variable template,
                             replace_var_in_expression right variable template)
             ) equations;;

let fourth_action equations =
    let current_map = AbstractVar.empty in
        let tmp_map_list = List.map (fun item ->
                                        let em_map = AbstractVar.empty in
                                            let left_map = num_of_vars (fst item) em_map in
                                                let right_map = num_of_vars (snd item) left_map in
                                                        right_map
                                    ) equations in
                let result_map = List.fold_left (fun a b -> AbstractVar.merge (fun _ k1 k2 -> match k1, k2 with
                                                                                | Some v, Some u -> Some(u + v)
                                                                                | None, None -> None
                                                                                | None, k2 -> k2
                                                                                | k1, None -> k1
                                                                              ) a b) (AbstractVar.empty) tmp_map_list in
                    let filtered_map = AbstractVar.filter (fun k v -> v > 1) result_map in
                        let list_of_vars_term = available_map equations in
                            let filtered_list = List.filter (fun item -> let lft, rght = item in
                                                                match lft with
                                                                | Var(a) -> AbstractVar.mem a filtered_map
                                                                | _ -> false
                                                            ) list_of_vars_term in
                                            let num_of_can_vars = List.length filtered_list in
                                                match num_of_can_vars with
                                                | 0 -> equations
                                                | _ -> let var, template = List.hd filtered_list in
                                                            fourth_action_replace var template equations;;

let rec help_calculate_num_of_vars expr mp =
    match expr with
    | Var(a) -> if AbstractVar.mem a mp then
                    let num = AbstractVar.find a mp in
                        AbstractVar.add a (num + 1) mp
                else
                    AbstractVar.add a 1 mp
    | Func(a, b, c) -> let result_b = help_calculate_num_of_vars b mp in
                            let result_c = help_calculate_num_of_vars c result_b in
                                result_c;;


let rec help_is_solved_form expression right_var =
    match expression with
    | Var(a) -> AbstractVar.add a 1 right_var
    | Func(a, b, c) -> let left = help_is_solved_form b right_var in
                            let right = help_is_solved_form c left in
                                right;;

let rec is_solved_form equations var_map num_of_var_in_right =
    match equations with
    | [] -> true
    | _  -> let head = List.hd equations in
                let  tail = List.tl equations in
                    let left, right = head in
                        let calc_right_var = help_is_solved_form right num_of_var_in_right in
                            match left with
                            | Var(a) -> let contains = AbstractVar.mem a var_map in
                                            if contains then
                                                false
                                            else
                                                let exist_in_right = AbstractVar.mem a calc_right_var in
                                                    if exist_in_right then
                                                        false
                                                    else
                                                        is_solved_form tail (AbstractVar.add a 1 var_map) calc_right_var
                            | Func(a, b, c) -> false;;

let rec solve_equations equations =
    (*term = var -> var = term*)
    let first = List.map (fun item -> if (not (is_var (fst item))) && (is_var (snd item)) then ((snd item), (fst item)) else item) equations in
        (*term = term -> [equiv_1..equiv_n]*)
        let second = List.fold_left (fun a b -> a @ b) [] (List.map second_action first) in
            (* if Var(a) = Var(b) -> remove them *)
            let delete_equal = List.filter
                (
                    fun item -> match item with
                        | Var(a), Var(b) -> if a=b then false else true
                        | _ -> true
                ) second in
                    (* replace all occur variable more than one time*)
                    let exist_recursion = check_same_derivation delete_equal in
                        if not exist_recursion then
                            (false, delete_equal)
                        else
                            let deleted_repeat = delete_repeat delete_equal in
                            let fourth = fourth_action deleted_repeat in
                                let compare = is_solved_form fourth (AbstractVar.empty) (AbstractVar.empty) in
                                    match compare with
                                        | false ->  solve_equations fourth
                                        | true ->   (true, fourth);;

let make_map_from_list solved_equations =
    List.fold_left (fun mp it->
                    let left, right = it in
                    match left with
                    | Var(a) -> AbstractVar.add a right mp
                   ) AbstractVar.empty solved_equations;;

let rec replace_in_type map_solved_equations expression_type =
    match expression_type with
    | Var(a) -> if AbstractVar.mem a map_solved_equations then
                    AbstractVar.find a map_solved_equations
                else
                    Var a
    | Func(a, b, c) -> let left = replace_in_type map_solved_equations b in
                            let right = replace_in_type map_solved_equations c in
                                Func (a, left, right);;

let repeat_stars n =
    String.concat "" (Array.to_list (Array.make n "*   "));;


let rec constuct_type map_solved_equations unbounded_names expression derivation bounded_names depth =
    let unbounded = AbstractVar.fold (fun k v lst -> lst @ [(k ^ " : " ^ (algebra_to_string v))] ) unbounded_names [] in
    let bounded = AbstractVar.fold (fun k v lst -> lst @ [(k ^ " : " ^ (algebra_to_string v))] ) bounded_names unbounded in
    let list_of_left = String.concat ", " bounded in
        print_string (repeat_stars depth);
        print_string list_of_left;
        print_string " |- ";
        match expression, derivation with
        | Variable(a), BuildTypeVar(tp) -> (let exist = AbstractVar.mem a unbounded_names in
                                                match exist with
                                                | true ->   let right = AbstractVar.find a unbounded_names in
                                                    print_string (a ^ " : " ^ (algebra_to_string right));
                                                | false ->  let right = replace_in_type map_solved_equations tp in
                                                    print_string (a ^ " : " ^ (algebra_to_string right));
                                            );
                                            print_string " [rule #1]\n"

        | Abstraction(a, b), BuildTypeAbstr(tp_a, tp_b, tp_inner) -> let tp_a_repl = replace_in_type map_solved_equations tp_a in
                                                                        let tp_b_repl = replace_in_type map_solved_equations tp_b in
                                                                            let abstraction = Func("->",tp_a_repl, tp_b_repl) in
                                                                                let abst_string = write_to_string (Abstraction(a,b)) in
                                                                                    print_string (abst_string ^ " : " ^ (algebra_to_string abstraction));
                                                                                    print_string " [rule #3]\n";
                                                                                    constuct_type map_solved_equations unbounded_names b tp_inner (AbstractVar.add a tp_a_repl bounded_names) (depth + 1)
        | Application(a, b), BuildTypeAppl(tp_a, tp_b, tp_c, tp_in_a, tp_in_b)  -> let tp_a_repl = replace_in_type map_solved_equations tp_a in
                                                                                        let tp_b_repl = replace_in_type map_solved_equations tp_b in
                                                                                            let tp_c_repl = replace_in_type map_solved_equations tp_c in
                                                                                                let appl_string = write_to_string (Application (a,b)) in
                                                                                                    print_string (appl_string ^ " : " ^ (algebra_to_string tp_c_repl));
                                                                                                    print_string " [rule #2]\n";
                                                                                                    constuct_type map_solved_equations unbounded_names a tp_in_a bounded_names (depth + 1);
                                                                                                    constuct_type map_solved_equations unbounded_names b tp_in_b bounded_names (depth + 1);;

let e = Lexing.from_channel stdin;;
let d = (Parser.lambdaParser Lexer.main)  e;;


let empty_bounded_names = AbstractVar.empty;;
let emplty_unbounded_names = AbstractVar.empty;;
let my_equitatins, lambda_type, bounded_names, unbounded_names, last_free_name, result_derivation = build_system d common_variable empty_bounded_names emplty_unbounded_names;;

let ok,eq =  solve_equations my_equitatins;;

match ok with
    | true ->
                 let maped_eq = make_map_from_list eq in
                 let solved_unbound_variabes = AbstractVar.map (fun v -> replace_in_type maped_eq (Var v))  unbounded_names in
                    constuct_type maped_eq solved_unbound_variabes d result_derivation (AbstractVar.empty) 0

    | false ->  Printf.printf "Expression has no type\n"
;;