#use "pc.ml";;
open PC;;

exception X_not_yet_implemented;;
exception X_this_should_not_happen;;

type number =
  | Int of int
  | Float of float;;

type sexpr =
  | Bool of bool
  | Nil
  | Number of number
  | Char of char
  | String of string
  | Symbol of string
  | Pair of sexpr * sexpr
  | TaggedSexpr of string * sexpr
  | TagRef of string

let rec sexpr_eq s1 s2 =
  match s1, s2 with
  | Bool(b1), Bool(b2) -> b1 = b2
  | Nil, Nil -> true
  | Number(Float f1), Number(Float f2) -> abs_float(f1 -. f2) < 0.001
  | Number(Int n1), Number(Int n2) -> n1 = n2
  | Char(c1), Char(c2) -> c1 = c2
  | String(s1), String(s2) -> s1 = s2
  | Symbol(s1), Symbol(s2) -> s1 = s2
  | Pair(car1, cdr1), Pair(car2, cdr2) -> (sexpr_eq car1 car2) && (sexpr_eq cdr1 cdr2)
  | TaggedSexpr(name1, expr1), TaggedSexpr(name2, expr2) -> (name1 = name2) && (sexpr_eq expr1 expr2)
  | TagRef(name1), TagRef(name2) -> name1 = name2
  | _ -> false;;

module Reader: sig
  val read_sexpr : string -> sexpr
  val read_sexprs : string -> sexpr list
end
= struct
let normalize_scheme_symbol str =
  let s = string_to_list str in
  if (andmap
    (fun ch -> (ch = (lowercase_ascii ch)))
    s) then str
  else Printf.sprintf "|%s|" str;;

let read_sexpr string = raise X_not_yet_implemented ;;

let read_sexprs string = raise X_not_yet_implemented;;
end;; (* struct Reader *)


let all_letters_no_space = (range (char_of_int 33) (char_of_int 127));;

let bool_parser = pack (disj (word_ci "#t") (word_ci "#f"))  (
  function
  | ['#';'t'] -> Bool true
  | ['#';'T'] -> Bool true
  | ['#';'f'] -> Bool false
  | ['#';'F'] -> Bool false
  | _ -> raise X_no_match
);;

let digit = range '0' '9';;

let tok_num=
  (let digits= (plus digit) in
  pack digits (fun (ds) -> Int (int_of_string(list_to_string ds))));;

let string_literal_char = diff nt_any (disj (char '"') (char '\\')) ;;

let string_meta_char = disj_list[
(pack (word_ci "\\n")(fun (x)-> '\n'));
(pack (word_ci "\\t")(fun (x)-> '\t'));
(pack (word_ci "\\f")(fun (x)->'\012'));
(pack (word_ci "\\r")(fun (x)->'\r'));
(pack (word_ci "\\\\")(fun (x)->'\\'));
(pack (word_ci "\\\"")(fun (x)->'\"'));
];;

let letters = disj string_meta_char string_literal_char;;

let string_parser = pack (caten (caten (char '"') (star letters)) (char '"'))(
function
| (('"',s),'"') -> String (list_to_string s)
| _ -> raise X_no_match
);;

let char_prefix = word "#\\";;
let visible_simple_char = range (char_of_int 33) (char_of_int 127);;
let named_char = disj_list[
(pack (word_ci "newline")(fun (x)-> char_of_int 10));
(pack (word_ci "nul")(fun (x)-> char_of_int 0));
(pack (word_ci "page")(fun (x)-> char_of_int 12));
(pack (word_ci "return")(fun (x)-> char_of_int 13));
(pack (word_ci "space")(fun (x)-> char_of_int 32));
(pack (word_ci "tab")(fun (x)-> char_of_int 9));
];;
let char_profix = disj named_char visible_simple_char;;

let char_parser = pack (caten char_prefix char_profix)(
function
| (['#';'\\'],s) -> Char s
| _ -> raise X_no_match
);;

let natural = plus digit;;

let integer = caten (maybe (disj (char '+') (char '-'))) natural;;

let float_parser = pack (caten (caten integer (char '.')) natural)(
function
| (((Some '+',s1),'.'),s2) -> Float (float_of_string ((list_to_string s1) ^ "." ^ (list_to_string s2)))
| (((Some '-',s1),'.'),s2) -> Float ((-1.0) *. float_of_string ((list_to_string s1) ^ "." ^ (list_to_string s2)))
| (((None,s1),'.'),s2) -> Float (float_of_string ((list_to_string s1) ^ "." ^ (list_to_string s2)))
| _ -> raise X_no_match
);;

let integer_parser = pack integer(
function
| (Some '+',s1) -> Int (int_of_string (list_to_string s1))
| (Some '-',s1) -> Int ((-1) * int_of_string (list_to_string s1))
| (None , s1) -> Int (int_of_string (list_to_string s1))
| _ -> raise X_no_match
);;

let float_scientific = pack (caten (disj float_parser integer_parser) (caten (char_ci 'e') (diff integer_parser float_parser)))(
function
| (Int(s1),('e',Int(s2))) -> Float ((float_of_int s1) *. (10.0 ** (float_of_int s2)))
| (Float(s1),('e',Int(s2))) -> Float (s1 *. (10.0 ** (float_of_int s2)))
| (Int(s1),('E',Int(s2))) ->  Float ((float_of_int s1) *. (10.0 ** (float_of_int s2)))
| (Float(s1),('E',Int(s2))) -> Float (s1 *. (10.0 ** (float_of_int s2)))
| _ -> raise X_no_match
);;

let radix_r = pack (char_ci 'r')(
function
| ('R') -> 'r'
| ('r') -> 'r'
| _ -> raise X_no_match
);;

let radix_converter = pack (all_letters_no_space)(
function
| (s) -> (lowercase_ascii s)
);;

let char_converter2 c =
if (c >= '0' && c <= '9') then float_of_int ((int_of_char c) - 48) else
float_of_int((int_of_char c) - 87);;

let rest base s = List.fold_right
(fun a b -> ((a /. base) +. (b /. base)))
(List.map char_converter2 (string_to_list s))
0.;;

let char_converter c =
if (c >= '0' && c <= '9') then (int_of_char c) - 48 else
(int_of_char c) - 87;;
(* ((String.index nt '.') - length + 1) *)
let radix_to_dec length base nt=
  let first_num = ref 0. in
  let pow = ref 1 in
  let s  = (String.sub nt ((String.index nt '.')) ((String.length nt)-(String.index nt '.')))in
  let n = (String.sub s 1 ((String.length s)-1)) in
  for i = (String.index nt '.') downto 0 do
    if (char_converter (String.get nt i)) >= base then raise X_no_match;
    if (String.get nt i) != '.' then(
      first_num := !first_num +. (float_of_int ((char_converter (String.get nt i)) * !pow));
    pow := !pow * base)
done;
!first_num +. (rest (float_of_int base) n);;

let radix_to_int length base nt=
  let first_num = ref 0 in
  let pow = ref 1 in
  for i = length - 1 downto 0 do
    if (char_converter (String.get nt i)) >= base then raise X_no_match;
    if (String.get nt i) != '.' then(
      first_num := !first_num + ((char_converter (String.get nt i)) * !pow);
    pow := !pow * base)
done;
!first_num;;





let radix_parser = pack (caten integer_parser (caten radix_r (plus radix_converter)))(
function
| (Int(s1),('r',s2)) -> if (String.contains (list_to_string s2) '.') then Float(radix_to_dec (String.length (list_to_string s2)) s1 (list_to_string s2))
                        else Int(radix_to_int (String.length (list_to_string s2)) s1 (list_to_string s2))
| _ -> raise X_no_match
);;

let nt_whitespaces = star (char ' ');;

let number_parser = pack (disj_list[
radix_parser;
float_scientific;
float_parser;
integer_parser;
])(
function
| s -> Number(s)
);;

let line_comment_parser = pack (caten (caten (char ';') (star (diff letters (char '\n')))) (disj (word "\n") nt_end_of_input))
(
function
| ((';',s),['\n']) -> Nil
| _ -> raise X_no_match
);;
let symbol_char = disj_list[
  range '0' '9';
  range 'a' 'z';
  range 'A' 'Z';
  char ':';
  char '!';
  char '=';
  char '<';
  char '>';
  char '$';
  char '*';
  char '+';
  char '^';
  char '-';
  char '_';
  char '/';
  char '?';
  ];;

let symbol_parser = pack (plus symbol_char)(
  function
  | s -> Symbol (list_to_string s)
);;

let make_paired nt_left nt_right nt =
let nt = caten nt_left nt in
let nt = pack nt (function (_, e) -> e) in
let nt = caten nt nt_right in
let nt = pack nt (function (e, _) -> e) in
  nt;;

let make_spaced nt = make_paired nt_whitespaces nt_whitespaces nt;;

let tok_lparen = make_spaced ( char '(');;

let tok_rparen = make_spaced ( char ')');;

let tok_dotted = make_spaced ( char '.');;

let tok_comment = make_spaced ( word "#;");;




let rec list_parser s = (disj dottted_list_parser undottted_list_parser) s
and undottted_list_parser s=
  pack (caten (caten tok_lparen (star sexp)) tok_rparen)(
    function
    | ((l, e), r) -> pairfunc_undotted e
  ) s
and pairfunc_undotted s= (
  function
  | [] -> Nil
  | a :: b -> Pair (a, pairfunc_undotted b)
) s
and dottted_list_parser s=
pack (caten (caten (caten (caten tok_lparen (plus sexp)) tok_dotted) sexp) tok_rparen)(
  function
  | ((((l, e1),'.'),e2), r) ->  pairfunc_dotted (e1,e2)
  | _ -> raise X_no_match
) s

and pairfunc_dotted s= (
function
| ([] , b) -> b
| ((a::c) , b) -> Pair (a, pairfunc_dotted (c,b))
) s
and sexp s = make_spaced (disj (disj (disj (disj (disj bool_parser number_parser) string_parser) char_parser) list_parser) symbol_parser) s;;

let sexp =(disj (disj (disj (disj (disj bool_parser number_parser) string_parser) char_parser) list_parser) symbol_parser);;

let quote_maker = pack(disj (disj (disj (word "`") (word "'")) (word ",@")) (word ","))(
  fun (x) -> match x with
  | ['`'] -> "Quoted"
  | ['\''] -> "QQuoted"
  | [',';'@'] -> "UnquotedSpliced"
  | [','] -> "Unquoted"
  | _ -> raise X_no_match
);;

let quote_parser = pack (caten quote_maker sexp)(
  function
  (x,y) -> Pair (Symbol x, Pair (y, Nil))
);;

(* let rec sexp_comment = pack (caten (caten (caten tok_comment (star tok_comment)) sexp) (star nt_any))
(function
| (((a,[]), c),d) -> " "
| (((a, [b]), c),d) -> sexp_comment ((list_to_string b) ^ (list_to_string d))
| _ -> raise X_no_match
);; *)

(* let rec sexp_comment = pack (caten (caten tok_comment (star tok_comment)) (plus sexp))
(function
| ((a,[]), c) -> " "
| ((a, [b::d]), c) -> sexp_comment ()
| _ -> raise X_no_match
);; *)

(* let sexp_comment' =
  let rec make_comment () =
    let nt = caten (caten (make_spaced (word "#;"))
              (delayed make_comment))
           (make_spaced sexp) in
    let nt = pack nt (fun _ -> ' ') in
    let nt' = star nt_whitespace in
    let nt' = pack nt' (fun _ -> ' ') in
    let nt = disj nt nt' in
    nt in
  make_comment ();; *)