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

module Vocabulary
:
sig
	include ERicTypes.Hierarchy
	type result = Less | Equal | More | Left | Right 
	val empty : t
	val relate : t -> t -> result
	val preorder_hierarchy : t -> unit 
	val backup  : t -> unit 
	val restore : t -> unit 	
end
=
struct
	type t =
		{alt:t option; mutable sub:t option; mutable old:t option;
		key:string; mutable mini:int; mutable maxi:int}
	type result =
		| Less | Equal | More | Left | Right
	let relate ta tb = 
		if ta.maxi <= tb.mini then Left
		else if ta.mini >= tb.maxi then Right
		else if ta.mini >= tb.mini && ta.maxi < tb.maxi then Less
		else if tb.mini <= ta.mini && tb.maxi > ta.maxi then More
		else Equal 
	let empty =
		{key="";alt=None;sub=None;old=None;mini=0;maxi=0}
	let make k =
		{key=k;alt=None;sub=None;old=None;mini=0;maxi=1}
	let make_child_of key p =
		let sub={key;alt=p.sub;sub=None;old=None;mini=0;maxi=1}
		in p.sub <- Some sub; sub 
	let rec preorder_hierarchy n = function
		| None -> n
		| Some t ->
			t.mini <- n;
			t.maxi <- 1 + preorder_hierarchy t.mini t.sub;
			preorder_hierarchy t.maxi t.alt
	let preorder_hierarchy t =
		ignore(preorder_hierarchy 0 (Some t))
	let backup t =
		t.old <- t.sub
	let restore t =	
		t.sub <- t.old 
	let print t =
		print_string t.key
end


module Graph
	(
	Hierarchy
	:
	sig
		type t
		type result = Less | Equal | More | Left | Right
		val  relate : t -> t -> result
	end
	)
	:
	ERicTypes.Graph
	with type concept = Hierarchy.t
	with type role = Hierarchy.t
	with type label = String.t
=
struct
	(* types *)
	type concept = Hierarchy.t
	type entity =
		| EntityC of concept             (* concept            *)
		| EntityR of concept * string    (* concept & referent *)
		| EntityI of concept * int       (* concept & integer  *)
		| EntityF of concept * float     (* concept & float    *)
		| EntityS of concept * string    (* concept & string   *)
	let concept = function
		| EntityC c
		| EntityR (c,_)
		| EntityI (c,_)
		| EntityF (c,_)
		| EntityS (c,_) -> c
	let entity_equal ea eb =
		ea == eb ||
		match ea,eb with
		| EntityI(ca,ra),EntityI(cb,rb) -> ca == cb && ra = rb
		| EntityF(ca,ra),EntityF(cb,rb) -> ca == cb && ra = rb
		| EntityS(ca,ra),EntityS(cb,rb) -> ca == cb && ra = rb
		| _ -> false
	let entity_relate ea eb =
		let open Hierarchy in
		match ea,eb with
		| _ when entity_equal ea eb -> Equal
		| EntityC ca,EntityC cb -> relate ca cb 
		| EntityR(ca,_),EntityC cb when relate ca cb < More -> Less
		| EntityI(ca,_),EntityC cb when relate ca cb < More -> Less
		| EntityF(ca,_),EntityC cb when relate ca cb < More -> Less
		| EntityS(ca,_),EntityC cb when relate ca cb < More -> Less
		| _ ->
			match relate (concept ea) (concept eb) with
			| Left -> Left
			| Right -> Right
			| _ -> More
	type role = Hierarchy.t
	type label = String.t
	let no_label = ""
	(* unary edges *)
	type edge1 =
		{
		mutable r1: role;
		mutable arg: entity; arg_lab: label;
		}
	let star1 r1 arg arg_lab =
		{r1;arg;arg_lab}
	type t1 =
		| Empty1
		| Split1 of split1
	and split1 =
		{
		mutable left1  : t1;
		mutable right1 : t1;
		mutable other1 : t1;
		mutable mark1 : bool;
		t_r1: role;
		t_arg: entity;
		}
	let singleton1 e =
		Split1
		{left1=Empty1;right1=Empty1;other1=Empty1;mark1=false;t_r1=e.r1;t_arg=e.arg}
	let insert k e g =
		let open Hierarchy in function
		| Left -> g.left1 <- k e g.left1
		| Right -> g.right1 <- k e g.right1
		| Less | Equal | More -> g.other1 <- k e g.other1
	let rec insert_r1 e t =
		match t with
		| Empty1 -> singleton1 e
		| Split1 g -> insert insert_arg e g (Hierarchy.relate e.r1 g.t_r1); t
	and insert_arg e t =
		match t with
		| Empty1 -> singleton1 e
		| Split1 g -> insert insert_r1 e g (entity_relate e.arg g.t_arg); t
	(* binary edges *)
	type edge2 = 
		{
		mutable r2: role;
		mutable src: entity; src_lab: label;
		mutable dst: entity; dst_lab: label;
		}
	let star2 r2 src src_lab dst dst_lab =
		{r2;src;src_lab;dst;dst_lab}
	type t2 =
		| Empty2
		| Split2 of split2
	and split2 =
		{
		mutable left2  : t2;
		mutable right2 : t2;
		mutable other2 : t2;
		mutable mark2 : bool;
		t_r2: role;
		t_src: entity;
		t_dst: entity;
		}
	let singleton2 e =
		Split2
		{left2=Empty2;right2=Empty2;other2=Empty2;mark2=false;t_r2=e.r2;t_src=e.src;t_dst=e.dst}
	let insert k e g =
		let open Hierarchy in function
		| Left -> g.left2 <- k e g.left2
		| Right -> g.right2 <- k e g.right2
		| Less | Equal | More -> g.other2 <- k e g.other2
	let rec insert_r2 e t =
		match t with
		| Empty2 -> singleton2 e
		| Split2 g -> insert insert_src e g (Hierarchy.relate e.r2 g.t_r2); t
	and insert_src e t =
		match t with
		| Empty2 -> singleton2 e
		| Split2 g -> insert insert_dst e g (entity_relate e.src g.t_src); t
	and insert_dst e t =
		match t with
		| Empty2 -> singleton2 e
		| Split2 g -> insert insert_r2 e g (entity_relate e.dst g.t_dst); t
	(* ternary edges *)
	type edge3 = 
		{
		mutable r3: role;
		mutable tic: entity; tic_lab: label;
		mutable tac: entity; tac_lab: label;
		mutable toe: entity; toe_lab: label;
		}
	let star3 r3 tic tic_lab tac tac_lab toe toe_lab =
		{r3;tic;tic_lab;tac;tac_lab;toe;toe_lab}
	type t3 =
		| Empty3
		| Split3 of split3
	and split3 =
		{
		mutable left3  : t3;
		mutable right3 : t3;
		mutable other3 : t3;
		mutable mark3 : bool;
		t_r3: role;
		t_tic: entity;
		t_tac: entity;
		t_toe: entity;
		}
	let singleton3 e =
		Split3
		{
		left3=Empty3;right3=Empty3;other3=Empty3;mark3=false;
		t_r3=e.r3;
		t_tic=e.tic;t_tac=e.tac;t_toe=e.toe;
		}
	let insert k e g =
		let open Hierarchy in function
		| Left -> g.left3 <- k e g.left3
		| Right -> g.right3 <- k e g.right3
		| Less | Equal | More -> g.other3 <- k e g.other3
	let rec insert_r3 e t =
		match t with
		| Empty3 -> singleton3 e
		| Split3 g -> insert insert_tic e g (Hierarchy.relate e.r3 g.t_r3); t
	and insert_tic e t =
		match t with
		| Empty3 -> singleton3 e
		| Split3 g -> insert insert_tac e g (entity_relate e.tic g.t_tic); t
	and insert_tac e t =
		match t with
		| Empty3 -> singleton3 e
		| Split3 g -> insert insert_toe e g (entity_relate e.tac g.t_tac); t
	and insert_toe e t =
		match t with
		| Empty3 -> singleton3 e
		| Split3 g -> insert insert_r3 e g (entity_relate e.toe g.t_toe); t
	(* quaternary edges *)
	type edge4 = 
		{
		mutable r4: role;
		mutable ga: entity; ga_lab: label;
		mutable bu: entity; bu_lab: label;
		mutable zo: entity; zo_lab: label;
		mutable meu: entity; meu_lab: label;
		}
	let star4 r4 ga ga_lab bu bu_lab zo zo_lab meu meu_lab =
		{r4;ga;ga_lab;bu;bu_lab;zo;zo_lab;meu;meu_lab}
	type t4 =
		| Empty4
		| Split4 of split4
	and split4 =
		{
		mutable left4  : t4;
		mutable right4 : t4;
		mutable other4 : t4;
		mutable mark4 : bool;
		t_r4: role;
		t_ga: entity;
		t_bu: entity;
		t_zo: entity;
		t_meu: entity;
		}
	let singleton4 e =
		Split4
		{
		left4=Empty4;right4=Empty4;other4=Empty4;mark4=false;
		t_r4=e.r4;
		t_ga=e.ga;t_bu=e.bu;t_zo=e.zo; t_meu=e.meu;
		}
	let insert k e g =
		let open Hierarchy in function
		| Left -> g.left4 <- k e g.left4
		| Right -> g.right4 <- k e g.right4
		| Less | Equal | More -> g.other4 <- k e g.other4
	let rec insert_r4 e t =
		match t with
		| Empty4 -> singleton4 e
		| Split4 g -> insert insert_ga e g (Hierarchy.relate e.r4 g.t_r4); t
	and insert_ga e t =
		match t with
		| Empty4 -> singleton4 e
		| Split4 g -> insert insert_bu e g (entity_relate e.ga g.t_ga); t
	and insert_bu e t =
		match t with
		| Empty4 -> singleton4 e
		| Split4 g -> insert insert_zo e g (entity_relate e.bu g.t_bu); t
	and insert_zo e t =
		match t with
		| Empty4 -> singleton4 e
		| Split4 g -> insert insert_meu e g (entity_relate e.zo g.t_zo); t
	and insert_meu e t =
		match t with
		| Empty4 -> singleton4 e
		| Split4 g -> insert insert_r4 e g (entity_relate e.meu g.t_meu); t
	(* graph *)
	type graph =
		{mutable g1 : t1; mutable g2 : t2; mutable g3 : t3; mutable g4 : t4}	
	let make () = 
		{g1 = Empty1; g2 = Empty2; g3 = Empty3; g4 = Empty4;}	
	let insert1 e g =
		g.g1 <- insert_r1 e g.g1
	let insert2 e g =
		g.g2 <- insert_r2 e g.g2
	let insert3 e g =
		g.g3 <- insert_r3 e g.g3
	let insert4 e g =
		g.g4 <- insert_r4 e g.g4
	(* select *)
	let less1 a b =
		let open Hierarchy in	
		entity_relate a.t_arg b.arg < More &&
		relate a.t_r1 b.r1 < More
	let iterate1 e f t =
		let iterate k g =
			let open Hierarchy in function
			| Left -> k g.left1
			| Right -> k g.right1
			| Less -> k g.other1
			| Equal ->
				if not g.mark1 && less1 g e then
					(g.mark1 <- true; f g; g.mark1 <- false);
				k g.other1
			| More ->
				if not g.mark1 && less1 g e then
					(g.mark1 <- true; f g; g.mark1 <- false);
				k g.left1; k g.other1; k g.right1
		in			
		let rec iterate_r1 = function
			| Empty1 -> ()
			| Split1 g -> iterate iterate_arg g (Hierarchy.relate e.r1 g.t_r1)
		and iterate_arg = function
			| Empty1 -> ()
			| Split1 g -> iterate iterate_r1 g (entity_relate e.arg g.t_arg)
		in iterate_r1 t
	let less2 a b =
		let open Hierarchy in	
		entity_relate a.t_src b.src < More &&
		entity_relate a.t_dst b.dst < More &&
		relate a.t_r2 b.r2 < More
	let iterate2 e f t =
		let iterate k g =
			let open Hierarchy in function
			| Left -> k g.left2
			| Right -> k g.right2
			| Less -> k g.other2
			| Equal ->
				if not g.mark2 && less2 g e then
					(g.mark2 <- true; f g; g.mark2 <- false);
				k g.other2
			| More ->
				if not g.mark2 && less2 g e then
					(g.mark2 <- true; f g; g.mark2 <- false);
				k g.left2; k g.other2; k g.right2
		in			
		let rec iterate_r2 = function
			| Empty2 -> ()
			| Split2 g -> iterate iterate_src g (Hierarchy.relate e.r2 g.t_r2)
		and iterate_src = function
			| Empty2 -> ()
			| Split2 g -> iterate iterate_dst g (entity_relate e.src g.t_src)
		and iterate_dst = function
			| Empty2 -> ()
			| Split2 g -> iterate iterate_r2  g (entity_relate e.dst g.t_dst)
		in iterate_r2 t
	let less3 a b =
		let open Hierarchy in	
		entity_relate a.t_tic b.tic < More &&
		entity_relate a.t_tac b.tac < More &&
		entity_relate a.t_toe b.toe < More &&
		relate a.t_r3 b.r3 < More
	let iterate3 e f t =
		let iterate k g =
			let open Hierarchy in function
			| Left -> k g.left3
			| Right -> k g.right3
			| Less -> k g.other3
			| Equal ->
				if not g.mark3 && less3 g e then
					(g.mark3 <- true; f g; g.mark3 <- false);
				k g.other3
			| More ->
				if not g.mark3 && less3 g e then
					(g.mark3 <- true; f g; g.mark3 <- false);
				k g.left3; k g.other3; k g.right3
		in			
		let rec iterate_r3 = function
			| Empty3 -> ()
			| Split3 g -> iterate iterate_tic g (Hierarchy.relate e.r3 g.t_r3)
		and iterate_tic = function
			| Empty3 -> ()
			| Split3 g -> iterate iterate_tac g (entity_relate e.tic g.t_tic)
		and iterate_tac = function
			| Empty3 -> ()
			| Split3 g -> iterate iterate_toe g (entity_relate e.tac g.t_tac)
		and iterate_toe = function
			| Empty3 -> ()
			| Split3 g -> iterate iterate_r3  g (entity_relate e.toe g.t_toe)
		in iterate_r3 t
	let less4 a b =
		let open Hierarchy in	
		entity_relate a.t_ga b.ga < More &&
		entity_relate a.t_bu b.bu < More &&
		entity_relate a.t_zo b.zo < More &&
		entity_relate a.t_meu b.meu < More &&
		relate a.t_r4 b.r4 < More
	let iterate4 e f t =
		let iterate k g =
			let open Hierarchy in function
			| Left -> k g.left4
			| Right -> k g.right4
			| Less -> k g.other4
			| Equal ->
				if not g.mark4 && less4 g e then
					(g.mark4 <- true; f g; g.mark4 <- false);
				k g.other4
			| More ->
				if not g.mark4 && less4 g e then
					(g.mark4 <- true; f g; g.mark4 <- false);
				k g.left4; k g.other4; k g.right4
		in			
		let rec iterate_r4 = function
			| Empty4 -> ()
			| Split4 g -> iterate iterate_ga g (Hierarchy.relate e.r4 g.t_r4)
		and iterate_ga = function
			| Empty4 -> ()
			| Split4 g -> iterate iterate_bu g (entity_relate e.ga g.t_ga)
		and iterate_bu = function
			| Empty4 -> ()
			| Split4 g -> iterate iterate_zo g (entity_relate e.bu g.t_bu)
		and iterate_zo = function
			| Empty4 -> ()
			| Split4 g -> iterate iterate_meu g (entity_relate e.zo g.t_zo)
		and iterate_meu = function
			| Empty4 -> ()
			| Split4 g -> iterate iterate_r4  g (entity_relate e.meu g.t_meu)
		in iterate_r4 t
	(* vertices *)
	type vertex =
		| Vertex
		| Argument of edge1
		| Source of edge2
		| Destination of edge2
		| Tic of edge3
		| Tac of edge3
		| Toe of edge3		
		| Ga of edge4		
		| Bu of edge4		
		| Zo of edge4		
		| Meu of edge4		
	let assign def = function
		| Vertex -> def
		| Argument e -> e.arg
		| Source e -> e.src
		| Destination e -> e.dst
		| Tic e -> e.tic
		| Tac e -> e.tac
		| Toe e -> e.toe
		| Ga e -> e.ga
		| Bu e -> e.bu
		| Zo e -> e.zo
		| Meu e -> e.meu
	(* insert roles *)
	type insert =
		| Insert0
		| Insert1 of edge1 * insert
		| Insert2 of edge2 * insert
		| Insert3 of edge3 * insert
		| Insert4 of edge4 * insert
	(* insert all *)
	let rec insert_all i g =
		match i with
		| Insert0 -> ()
		| Insert1(e,t) -> insert_all t g; insert1 e g 
		| Insert2(e,t) -> insert_all t g; insert2 e g
		| Insert3(e,t) -> insert_all t g; insert3 e g
		| Insert4(e,t) -> insert_all t g; insert4 e g
	(* select roles *)
	type select =
		| Select0
		| Select1 of edge1 * vertex * select
		| Select2 of edge2 * vertex * vertex * select
		| Select3 of edge3 * vertex * vertex * vertex * select
		| Select4 of edge4 * vertex * vertex * vertex * vertex * select
	(* select all *)
	let nothing () =
		()
	let printer =
		ref nothing
	let rec select_all pat t =
		let range1 tl a b =
			a.r1  <- b.t_r1;
			a.arg <- b.t_arg;
			select_all tl t
		and range2 tl a b =
			a.r2  <- b.t_r2;
			a.src <- b.t_src;
			a.dst <- b.t_dst;
			select_all tl t
		and range3 tl a b =
			a.r3  <- b.t_r3;
			a.tic <- b.t_tic;
			a.tac <- b.t_tac;
			a.toe <- b.t_toe;
			select_all tl t
		and range4 tl a b =
			a.r4  <- b.t_r4;
			a.ga  <- b.t_ga;
			a.bu  <- b.t_bu;
			a.zo  <- b.t_zo;
			a.meu <- b.t_meu;
			select_all tl t
		in match pat with
		| Select0 ->
			!printer ()
		| Select1(e1,v,tl) ->
			let memo1 =
				{e1 with arg = assign e1.arg v}
			in
				iterate1 memo1 (range1 tl memo1) t.g1;
				e1.r1  <- memo1.r1;
				e1.arg <- memo1.arg
		| Select2(e2,va,vb,tl) ->
			let memo2 =
				{e2 with src = assign e2.src va; dst = assign e2.dst vb}
			in
				iterate2 memo2 (range2 tl e2) t.g2;
				e2.r2  <- memo2.r2;
				e2.src <- memo2.src;
				e2.dst <- memo2.dst
		| Select3(e3,va,vb,vc,tl) ->
			let memo3 =
				{e3 with tic = assign e3.tic va; tac = assign e3.tac vb; toe = assign e3.toe vc}
			in
				iterate3 memo3 (range3 tl e3) t.g3;
				e3.r3  <- memo3.r3;
				e3.tic <- memo3.tic;
				e3.tac <- memo3.tac;
				e3.toe <- memo3.toe
		| Select4(e4,va,vb,vc,vd,tl) ->
			let memo4 =
				{e4 with
				ga = assign e4.ga va; bu = assign e4.bu vb; zo = assign e4.zo vc; meu = assign e4.meu vd}
			in
				iterate4 memo4 (range4 tl e4) t.g4;
				e4.r4  <- memo4.r4;
				e4.ga  <- memo4.ga;
				e4.bu  <- memo4.bu;
				e4.zo  <- memo4.zo;
				e4.meu <- memo4.meu
	let select_all print g t =
		printer := print; select_all g t; printer := nothing
end