(*
 * Copyright 2021 Damien Guichard
 *
 * Licensed under the EUPL-1.2-or-later
 *)

module Dictionary
:
sig
	type ('a,'b) t
	val empty : ('a,'b) t
	val singleton : 'a -> 'b -> ('a,'b) t
	val top : ('a,'b) t -> 'b
	val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t  (* failwith "duplicate identifier" *)
	val member : 'a -> ('a,'b) t -> 'b	(* raise Not_found *)
end
=
struct
	type ('a,'b) t =
		| Empty
		| Fork of ('a,'b) t * 'a * 'b * ('a,'b) t
	let empty =
		Empty
	let singleton key item =
		Fork(Empty,key,item,Empty)
	let top = function
		| Empty -> assert false
		| Fork(_,_,item,_) -> item
	let rec add k x = function 
		| Empty -> singleton k x
		| Fork(l,key,item,r) ->
			match compare k key with
			| -1 -> Fork(add k x l,key,item,r)
			| +1 -> Fork(l,key,item,add k x r)
			| _  -> failwith "duplicate identifier"
	let rec member k = function
		| Empty -> raise Not_found
		| Fork(l,key,item,r) ->
			match compare k key with
			| -1 -> member k l
			| +1 -> member k r
			| _  -> item
end


module REPL
	( ER:ERicTypes.Graph
	with type concept=ERicData.Vocabulary.t
	with type role=ERicData.Vocabulary.t
	with type label=String.t
	)
:
sig
end
=
struct
	module Dict =
		Dictionary
	module Lex = 
		ERicLex.Lex
	module Vocabulary = 
		ERicData.Vocabulary
	let print_entity = function 
		| ER.EntityC(c) ->
			Vocabulary.print c; print_string ":*"
		| ER.EntityR(c,s) ->
			assert false
		| ER.EntityI(c,i) ->
			Vocabulary.print c; print_char ':'; print_int i
		| ER.EntityF(c,x) ->
			Vocabulary.print c; print_char ':'; print_float x
		| ER.EntityS(c,s) ->
			Vocabulary.print c; print_char ':';
			print_char '"'; print_string s; print_char '"' 
	let print_vertex e label = function
		| ER.Vertex ->
			( match e with 
			| ER.EntityR(c,s) ->
				if label = ER.no_label then 
					print_string s
				else begin 
					print_char '[';
					print_string s; print_string " *"; print_string label;
					print_char ']';
				end 
			| _ ->
				print_char '[';
				print_entity e;
				if label <> ER.no_label then print_string label;
				print_char ']' )
		| ER.Argument e -> print_char '?'; print_string e.ER.arg_lab
		| ER.Source e -> print_char '?'; print_string e.ER.src_lab
		| ER.Destination e -> print_char '?'; print_string e.ER.dst_lab
		| ER.Tic e -> print_char '?'; print_string e.ER.tic_lab
		| ER.Tac e -> print_char '?'; print_string e.ER.tac_lab
		| ER.Toe e -> print_char '?'; print_string e.ER.toe_lab
		| ER.Ga e ->  print_char '?'; print_string e.ER.ga_lab
		| ER.Bu e ->  print_char '?'; print_string e.ER.bu_lab
		| ER.Zo e ->  print_char '?'; print_string e.ER.zo_lab
		| ER.Meu e ->  print_char '?'; print_string e.ER.meu_lab
	let rec print_relations = function
		| ER.Select0 ->
			print_char '.'; print_newline ()
		| ER.Select1(e,v1,tl) ->
			print_char '(';
			Vocabulary.print e.ER.r1; print_char ' ';
			print_vertex e.ER.arg e.ER.arg_lab v1; print_char ')';
			print_relations tl
		| ER.Select2(e,v1,v2,tl) ->
			print_char '(';
			Vocabulary.print e.ER.r2; print_char ' ';
			print_vertex e.ER.src e.ER.src_lab v1; print_char ' ';
			print_vertex e.ER.dst e.ER.dst_lab v2; print_char ')';
			print_relations tl
		| ER.Select3(e,v1,v2,v3,tl) ->
			print_char '(';
			Vocabulary.print e.ER.r3; print_char ' ';
			print_vertex e.ER.tic e.ER.tic_lab v1; print_char ' ';
			print_vertex e.ER.tac e.ER.tac_lab v2; print_char ' ';
			print_vertex e.ER.toe e.ER.toe_lab v3; print_char ')';
			print_relations tl
		| ER.Select4(e,v1,v2,v3,v4,tl) ->
			print_char '(';
			Vocabulary.print e.ER.r4; print_char ' ';
			print_vertex e.ER.ga e.ER.ga_lab v1; print_char ' ';
			print_vertex e.ER.bu e.ER.bu_lab v2; print_char ' ';
			print_vertex e.ER.zo e.ER.zo_lab v3; print_char ' ';
			print_vertex e.ER.meu e.ER.meu_lab v4; print_char ')';
			print_relations tl
	let print_graph cg () =
		print_relations cg
	let _ =
		let dict_singleton s =
			let name = s in
			Dict.singleton name (Vocabulary.make name)
		in
		object
			val mutable dict_hv	= dict_singleton "entity" 
			val mutable dict_he1 = dict_singleton "relation1"
			val mutable dict_he2 = dict_singleton "relation2"
			val mutable dict_he3 = dict_singleton "relation3"
			val mutable dict_he4 = dict_singleton "relation4"
			val mutable dict_lv1 = Dict.empty
			val mutable dict_lv2 = Dict.empty
			val mutable dict_env = Dict.empty
			val mutable dict_vtx = Dict.empty
			val mutable top_hv  = Vocabulary.empty
			val mutable top_he1 = Vocabulary.empty
			val mutable top_he2 = Vocabulary.empty
			val mutable top_he3 = Vocabulary.empty
			val mutable top_he4 = Vocabulary.empty
			val mutable kb = ER.make ()
		initializer
			print_endline "Entity-Relationship interactive calculator.";
			print_endline "version 0.3 by Damien Guichard.";
			top_hv  <- Dict.top dict_hv;
			top_he1 <- Dict.top dict_he1;
			top_he2 <- Dict.top dict_he2;
			top_he3 <- Dict.top dict_he3;	
			top_he4 <- Dict.top dict_he4;	
			while true do
				print_string  "# ";flush stdout; 
				let lex = new Lex.make stdin in
				let demand_derive dict =
					let parent = Dict.member lex#demand_name dict in
					try
						Vocabulary.backup parent;
						let rec loop t =
							if lex#promised_mono '.' then t
							else let n = lex#demand_name in
								let child = Vocabulary.make_child_of n parent
								in loop (Dict.add n child t)
						in loop dict
					with
					| exc -> Vocabulary.restore parent; raise exc
				and demand_insert_entity () =
					if lex#granted_mono '[' then begin
						let entity = Dict.member lex#demand_name dict_hv in
						lex#demand_mono ':';
						let result =
							if lex#promised_int then
								ER.EntityI(entity,lex#demand_int)
							else if lex#promised_float then
								ER.EntityF(entity,lex#demand_float)
							else if lex#promised_mono '"' then
								ER.EntityS(entity,lex#demand_string)
							else if lex#granted_mono '*' then
								if lex#promised_mono ']' then
									ER.EntityC entity
								else let label = lex#demand_name in
									dict_env <- Dict.add label entity dict_env;
									ER.EntityC entity
							else let referent = lex#demand_name in
								let uname = ER.EntityR(entity,referent) in 
								dict_lv2 <- Dict.add referent uname dict_lv2;
								uname
						in 
						lex#demand_mono ']';
						result						
					end else if lex#granted_mono '?' then
						ER.EntityC(Dict.member lex#demand_name dict_env)
					else
						Dict.member lex#demand_name dict_lv2
				in
				let demand_insert () =
					let l1=ER.no_label and l2=ER.no_label and l3=ER.no_label and l4=ER.no_label in
					let rec loop acc =
						if lex#promised_mono '.' then acc else
						if lex#granted_mono '[' then begin 
							let entity = Dict.member lex#demand_name dict_hv in
							lex#demand_mono ':';
							let referent = lex#demand_name in
							dict_lv2 <- Dict.add referent (ER.EntityR(entity,referent)) dict_lv2;
							lex#demand_mono ']';
							loop acc
						end
						else begin
						lex#demand_mono '(';
						let role = lex#demand_name in
						let e1 = demand_insert_entity () in
						if lex#granted_mono ')' then
							loop (ER.Insert1(ER.star1 (Dict.member role dict_he1) e1 l1,acc))
						else
						let e2 = demand_insert_entity () in
						if lex#granted_mono ')' then
							loop (ER.Insert2(ER.star2 (Dict.member role dict_he2) e1 l1 e2 l2,acc))
						else 
						let e3 = demand_insert_entity () in
						if lex#granted_mono ')' then
							loop (ER.Insert3(ER.star3 (Dict.member role dict_he3) e1 l1 e2 l2 e3 l3,acc))
						else 
						let e4 = demand_insert_entity () in
							lex#demand_mono ')';
							loop (ER.Insert4(ER.star4 (Dict.member role dict_he4) e1 l1 e2 l2 e3 l3 e4 l4,acc))
						end
					in loop ER.Insert0
				in
				let demand_select_entity () =
					if lex#granted_mono '[' then begin
						let entity = Dict.member lex#demand_name dict_hv in
						lex#demand_mono ':';
						let result =
							if lex#promised_int then
								ER.EntityI(entity,lex#demand_int),ER.no_label,ER.Vertex
							else if lex#promised_float then
								ER.EntityF(entity,lex#demand_float),ER.no_label,ER.Vertex
							else if lex#promised_mono '"' then
								ER.EntityS(entity,lex#demand_string),ER.no_label,ER.Vertex
							else begin
								lex#demand_mono '*';
								if lex#promised_mono ']' then
									ER.EntityC entity,ER.no_label,ER.Vertex
								else
									ER.EntityC entity,lex#demand_name,ER.Vertex
							end
						in 
						lex#demand_mono ']';
						result		 
					end else if lex#granted_mono '?' then
						ER.EntityC top_hv,ER.no_label,Dict.member lex#demand_name dict_vtx
					else
						Dict.member lex#demand_name dict_lv1,ER.no_label,ER.Vertex
				in
				let rec demand_select () =
					if lex#promised_mono '.' then ER.Select0
					else begin
						lex#demand_mono '(';
						let role = lex#demand_name in
						let e1,l1,v1 = demand_select_entity () in
						if lex#granted_mono ')' then
							let edge1 = ER.star1 (Dict.member role dict_he1) e1 l1 in
							if l1 <> ER.no_label then
								dict_vtx <- Dict.add l1 (ER.Argument edge1) dict_vtx;
							ER.Select1(edge1,v1,demand_select ())
						else
						let e2,l2,v2 = demand_select_entity () in
						if lex#granted_mono ')' then
							let edge2 = ER.star2 (Dict.member role dict_he2) e1 l1 e2 l2 in 
							if l1 <> ER.no_label then
								dict_vtx <- Dict.add l1 (ER.Source edge2) dict_vtx;
							if l2 <> ER.no_label then
								dict_vtx <- Dict.add l2 (ER.Destination edge2) dict_vtx;
							ER.Select2(edge2,v1,v2,demand_select ())
						else				
						let e3,l3,v3 = demand_select_entity () in
						if lex#granted_mono ')' then
							let edge3 = ER.star3 (Dict.member role dict_he3) e1 l1 e2 l2 e3 l3 in 
							if l1 <> ER.no_label then
								dict_vtx <- Dict.add l1 (ER.Tic edge3) dict_vtx;
							if l2 <> ER.no_label then
								dict_vtx <- Dict.add l2 (ER.Tac edge3) dict_vtx;
							if l3 <> ER.no_label then
								dict_vtx <- Dict.add l3 (ER.Toe edge3) dict_vtx;
							ER.Select3(edge3,v1,v2,v3,demand_select ())
						else
						let e4,l4,v4 = demand_select_entity () in
						lex#demand_mono ')';
						let edge4 = ER.star4 (Dict.member role dict_he4) e1 l1 e2 l2 e3 l3 e4 l4 in 
						if l1 <> ER.no_label then
							dict_vtx <- Dict.add l1 (ER.Ga edge4) dict_vtx;
						if l2 <> ER.no_label then
							dict_vtx <- Dict.add l2 (ER.Bu edge4) dict_vtx;
						if l3 <> ER.no_label then
							dict_vtx <- Dict.add l3 (ER.Zo edge4) dict_vtx;
						if l4 <> ER.no_label then
							dict_vtx <- Dict.add l3 (ER.Meu edge4) dict_vtx;
						ER.Select4(edge4,v1,v2,v3,v4,demand_select ())
					end
				in
				let assert_mono c =
					if not (lex#promised_mono c) then lex#demand_mono c
				in
				try
					dict_env <- Dict.empty;
					dict_vtx <- Dict.empty;
					dict_lv2 <- Dict.empty;
					( match () with
					| _ when lex#granted_word "untyped" ->
						lex#demand_word "hierarchy";
						let entity = lex#demand_name in
						let relation = lex#demand_name in
						assert_mono '.';
						dict_hv <-  dict_singleton entity;
						dict_he1 <- dict_singleton (relation ^ "1");
						dict_he2 <- dict_singleton (relation ^ "2");
						dict_he3 <- dict_singleton (relation ^ "3");
						dict_he4 <- dict_singleton (relation ^ "4");
						dict_lv1 <- Dict.empty;
						top_hv  <- Dict.top dict_hv;
						top_he1 <- Dict.top dict_he1;
						top_he2 <- Dict.top dict_he2;
						top_he3 <- Dict.top dict_he3;	
						top_he4 <- Dict.top dict_he4;
						kb <- ER.make ()						
					| _ when lex#granted_word "typed" ->
						lex#demand_word "hierarchy";
						failwith "not yet implemented" 
					| _ when lex#granted_word "derive" ->
						dict_hv <- demand_derive dict_hv;
						Vocabulary.preorder_hierarchy top_hv						
					| _ when lex#granted_word "derive1" ->
						dict_he1 <- demand_derive dict_he1;
						Vocabulary.preorder_hierarchy top_he1						
					| _ when lex#granted_word "derive2" ->
						dict_he2 <- demand_derive dict_he2;
						Vocabulary.preorder_hierarchy top_he2						
					| _ when lex#granted_word "derive3" ->
						dict_he3 <- demand_derive dict_he3;
						Vocabulary.preorder_hierarchy top_he3						
					| _ when lex#granted_word "derive4" ->
						dict_he4 <- demand_derive dict_he4;
						Vocabulary.preorder_hierarchy top_he4						
					| _ when lex#granted_word "insert" ->
						dict_lv2 <- dict_lv1;
						let cg = demand_insert () in
						assert_mono '.';
						ER.insert_all cg kb;
						dict_lv1 <- dict_lv2
					| _ when lex#granted_word "select" ->
						let cg = demand_select () in
						assert_mono '.';
						ER.select_all (print_graph cg) cg kb
					| _ when lex#granted_word "load" ->
						assert_mono '"';
						let str = lex#demand_string in
						assert_mono '.';
						let ch = open_in_bin str in
						let hv,he1,he2,he3,he4,lv1,k = Marshal.from_channel ch in
						dict_he1 <- he1; dict_he2 <- he2; dict_he3 <- he3; dict_he4 <- he4;
						dict_hv <- hv; dict_lv1 <- lv1; kb <- k;
						top_hv  <- Dict.top dict_hv;
						top_he1 <- Dict.top dict_he1;
						top_he2 <- Dict.top dict_he2;
						top_he3 <- Dict.top dict_he3;	
						top_he4 <- Dict.top dict_he4;	
						close_in ch
					| _ when lex#granted_word "save" ->
						assert_mono '"';
						let str = lex#demand_string in
						assert_mono '.';
						let ch = open_out_bin str in
						Marshal.to_channel ch
						(dict_hv,dict_he1,dict_he2,dict_he3,dict_he4,dict_lv1,kb)
						[];
						close_out ch
					| _ when lex#granted_word "quit" ->
						assert_mono '.'; exit 0
					| _ -> failwith "command expected" )
				with
				| Lex.Demand_denied (p,d) ->
					Lex.print_position p;
					Lex.print_denied d
				| Failure msg | Sys_error msg ->
					Lex.print_position lex#demand_position;
					print_endline msg
				| End_of_file ->
					Lex.print_position lex#demand_position;
					print_endline "unexpected end of text"
				| Not_found ->
					Lex.print_position lex#demand_position;
					print_endline "unkown identifier"
			done (* while *)
		end (* object *)
end

module Main = REPL(ERicData.Graph(ERicData.Vocabulary))