(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-04-28
- Frederic Blanqui, 2005-01-28

terms whose variable indexes are bounded
*)

Set Implicit Arguments.

From CoLoR Require Import ATerm VecUtil AInterpretation LogicUtil NatUtil.

Section S.

Variable Sig : Signature.

Notation term := (term Sig). Notation terms := (vector term).

Section bterm.

Variable k : nat.

(*COQ: we do not use the induction principle generated by Coq since it
     is not good because the argument of Fun is a vector *)

Unset Elimination Schemes.

Inductive bterm : Type :=
  | BVar : forall x : nat, x<=k -> bterm
  | BFun : forall f : Sig, vector bterm (arity f) -> bterm.

Set Elimination Schemes.

(***********************************************************************)
(** induction principles *)

Notation bterms := (vector bterm).

Section bterm_rect_def.

Variables
  (P : bterm -> Type)
  (Q : forall n : nat, bterms n -> Type).

Hypotheses
  (H1 : forall x (h : x<=k), P (BVar h))
  (H2 : forall (f : Sig) (v : bterms (arity f)), Q v -> P (BFun f v))
  (H3 : Q Vnil)
  (H4 : forall (t : bterm) n (v : bterms n), P t -> Q v -> Q (Vcons t v)).

Fixpoint bterm_rect (t : bterm) : P t :=
  match t as t return P t with
    | BVar h => H1 h
    | BFun f v =>
      let fix bterms_rect n (v : bterms n) : Q v :=
        match v as v return Q v with
          | Vnil => H3
          | Vcons t' v' => H4 (bterm_rect t') (bterms_rect _ v')
        end
	in H2 f (bterms_rect (arity f) v)
  end.

End bterm_rect_def.

Definition bterm_ind (P : bterm -> Prop) (Q : forall n, bterms n -> Prop) :=
  bterm_rect P Q.

(***********************************************************************)
(** injection of bterm into term *)

Fixpoint term_of_bterm (bt : bterm) : term :=
  match bt with
    | @BVar v _ => Var v
    | BFun f bts => Fun f (Vmap term_of_bterm bts)
  end.

(***********************************************************************)
(** injection of term into bterm *)

Notation max_le := (maxvar_le k).

Fixpoint inject_term (t : term) : max_le t -> bterm :=
  match t as t0 return max_le t0 -> bterm with
    | Var x => fun H => BVar (maxvar_var H)
    | Fun f ts => fun H =>
      let fix inject_terms n (ts : terms n) :
        Vforall max_le ts -> bterms n :=
	match ts as v in vector _ n0
	  return Vforall max_le v -> bterms n0 with
          | Vnil => fun _ => Vnil
          | Vcons t' ts' => fun H =>
	    Vcons (inject_term (proj1 H)) (inject_terms _ ts' (proj2 H))
	end
      in BFun f (inject_terms (arity f) ts (maxvar_le_fun H))
  end.

Fixpoint inject_terms (n : nat) (ts : terms n) :
  Vforall max_le ts -> bterms n :=
  match ts as v in vector _ n0
    return Vforall max_le v -> bterms n0 with
    | Vnil => fun _ => Vnil
    | Vcons t' ts' => fun H =>
      Vcons (inject_term (proj1 H)) (inject_terms ts' (proj2 H))
  end.

Arguments inject_terms [n ts] _.

Lemma inject_term_eq : forall f ts (H : max_le (Fun f ts)),
  inject_term H = BFun f (inject_terms (maxvar_le_fun H)).

Proof.
intros. simpl. auto.
Qed.

Lemma inject_terms_nth : forall i n (ts : terms n) (H : Vforall max_le ts)
  (ip : i < n), Vnth (inject_terms H) ip = inject_term (Vforall_nth ip H).

Proof.
  induction i; intros.
  destruct ts. lia. simpl.
  match goal with |- inject_term ?Hl = inject_term ?Hr =>
    rewrite (le_unique Hl Hr) end. refl.
  destruct ts. lia.
  simpl. rewrite IHi.
  match goal with |- inject_term ?Hl = inject_term ?Hr =>
    rewrite (le_unique Hl Hr) end. refl.
Qed.

(***********************************************************************)
(** interpretation of bterm's *)

Variables (I : interpretation Sig) (xint : valuation I).

Notation D := (domain I).
Notation fint := (fint I).

Fixpoint bterm_int (t : bterm) { struct t } : D :=
  match t with
    | @BVar x _ => xint x
    | BFun f v => fint f (Vmap bterm_int v)
  end.

End bterm.

Arguments inject_terms [k n ts] _.

(***********************************************************************)
(** relation between bterm_int and term_int *)

Section term_int.

Variables (I : interpretation Sig) (xint : valuation I).

Notation D := (domain I).

Let P (t : term) := forall (k : nat) (H : maxvar_le k t),
  bterm_int xint (inject_term H) = term_int xint t.

Let Q (n1 : nat) (ts : terms n1) :=
  forall (k : nat) (H : Vforall (maxvar_le k) ts),
    Vmap (bterm_int xint) (inject_terms H) = Vmap (term_int xint) ts.

Lemma term_int_eq_bterm_int : forall t, P t.

Proof.
intro t. apply (term_ind P Q).
 intro x. unfold P. simpl. intros. refl.

 intros f ts. unfold Q. intro H. unfold P.
 intros n Hn.
 rewrite inject_term_eq. simpl.
 f_equal.
 gen (maxvar_le_fun Hn). intro H0.
 gen (H _ H0). intro H1. hyp.

 unfold Q, P. simpl. auto.

 intros t' n' v'. unfold P, Q. intros H1 H2. intros n H3.
 simpl in H3. gen H3. clear H3.
 intro H3.
 gen (H1 _ (proj1 H3)). clear H1. intro H1.
 gen (H2 _ (proj2 H3)). clear H2. intro H2.
 simpl. rewrite <-H1, <-H2. refl.
Qed.

End term_int.

Arguments inject_terms [k n ts] _.

(***********************************************************************)
(** lemmas about bterm *)

Fixpoint bterm_le k (bt : bterm k) l (h0 : k <= l) : bterm l :=
  match bt with
    | BVar h => BVar (le_trans h h0)
    | BFun f bts => BFun f (Vmap (fun bt => @bterm_le k bt l h0) bts)
  end.

Fixpoint bterms_le k n (bts : vector (bterm k) n) l (h0 : k <= l)
  : vector (bterm l) n :=
  match bts in vector _ n return vector (bterm l) n with
    | Vnil => Vnil
    | Vcons bt bts' => Vcons (bterm_le bt h0) (bterms_le bts' h0)
  end.

Definition bterm_plus k bt l := bterm_le bt (le_plus_r k l).

Definition bterms_plus k n (bts : vector (bterm k) n) l
  := bterms_le bts (le_plus_r k l).

End S.

Arguments BVar [Sig k x] _.
Arguments BFun [Sig k] _ _.
Arguments inject_terms [Sig k n ts] _.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* COUNTING *)

(* decomptes des parametres de la machine*)
Require Export DistributedReferenceCounting.machine0.machine.

Section CONTROL.

(* decompte des messages dans une file d'attente, puis sommation sur
toutes les files d'attente issues ou arrivant sur un site *)

Variable s0 : Site.

Definition ctrl_copy (s1 : Site) (bom : Bag_of_message) :=
  card_mess copy (bom s0 s1).

Definition ctrl_dec (s1 : Site) (bom : Bag_of_message) :=
  card_mess dec (bom s1 s0).

Definition ctrl_inc (s1 : Site) (bom : Bag_of_message) :=
  card_mess (inc_dec s0) (bom s1 owner).

Definition sigma_ctrl_copy (bom : Bag_of_message) :=
  sigma Site LS (fun si : Site => ctrl_copy si bom).

Definition sigma_ctrl_dec (bom : Bag_of_message) :=
  sigma Site LS (fun si : Site => ctrl_dec si bom).

Definition sigma_ctrl_inc (bom : Bag_of_message) :=
  sigma Site LS (fun si : Site => ctrl_inc si bom).

Definition sigma_ctrl (bom : Bag_of_message) :=
  (sigma_ctrl_copy bom + sigma_ctrl_dec bom + sigma_ctrl_inc bom)%Z.

End CONTROL.

Section CONTROL_POS.

(* preuves que ces decomptes sont positifs (ils sont fait dans Z) *)

Variable bom : Bag_of_message.

Lemma ctrl_copy_pos : forall s0 s1 : Site, (ctrl_copy s0 s1 bom >= 0)%Z.
Proof.
 intros; unfold ctrl_copy in |- *; apply pos_card_mess.
Qed.

Lemma ctrl_dec_pos : forall s0 s1 : Site, (ctrl_dec s0 s1 bom >= 0)%Z.
Proof.
 intros; unfold ctrl_dec in |- *; apply pos_card_mess.
Qed.

Remark ctrl_inc_pos : forall s0 s1 : Site, (ctrl_inc s0 s1 bom >= 0)%Z.
Proof.
 intros; unfold ctrl_inc in |- *; apply pos_card_mess.
Qed.

Remark ctrl_inc_strct_pos :
 forall s0 s1 : Site,
 In_queue Message (inc_dec s0) (bom s1 owner) -> (ctrl_inc s0 s1 bom > 0)%Z.
Proof.
 unfold ctrl_inc in |- *; intros; apply strct_pos_card_mess; trivial.
Qed.

Remark sigma_ctrl_copy_pos :
 forall s0 : Site, (sigma_ctrl_copy s0 bom >= 0)%Z.
Proof.
 intro; unfold sigma_ctrl_copy in |- *; apply sigma_pos; intro;
  apply ctrl_copy_pos.
Qed.

Remark sigma_ctrl_dec_pos : forall s0 : Site, (sigma_ctrl_dec s0 bom >= 0)%Z.
Proof.
 intro; unfold sigma_ctrl_dec in |- *; apply sigma_pos; intro;
  apply ctrl_dec_pos.
Qed.

Remark sigma_ctrl_inc_strct_pos :
 forall s0 s1 : Site,
 In_queue Message (inc_dec s0) (bom s1 owner) ->
 (sigma_ctrl_inc s0 bom > 0)%Z.
Proof.
 intros; unfold sigma_ctrl_inc in |- *.
 generalize
  (le_sigma Site LS (fun si : Site => ctrl_inc s0 si bom) s1
     (ctrl_inc_pos s0) (in_s_LS s1)); intros.
 generalize (ctrl_inc_strct_pos s0 s1 H); intro; omega.
Qed.

Lemma sigma_ctrl_strct_pos :
 forall s0 s1 : Site,
 In_queue Message (inc_dec s0) (bom s1 owner) -> (sigma_ctrl s0 bom > 0)%Z.
Proof.
 intros; unfold sigma_ctrl in |- *.
 generalize (sigma_ctrl_copy_pos s0); intro.
 generalize (sigma_ctrl_dec_pos s0); intro.
 generalize (sigma_ctrl_inc_strct_pos s0 s1 H); intro.
 omega.
Qed.

End CONTROL_POS.

Section XY.

(* definition des variables xi et yi relative a un site et sommations
*)

Variable c0 : Config.

Definition xi (s0 : Site) :=
  (Int (rt c0 s0) + ctrl_copy owner s0 (bm c0) + ctrl_dec owner s0 (bm c0))%Z.

Definition yi (s0 : Site) :=
  sigma Site LS (fun s' : Site => ctrl_inc s' s0 (bm c0)).

Definition sigma_xi := sigma Site LS (fun s' : Site => xi s').

Definition sigma_yi := sigma Site LS (fun s' : Site => yi s').

End XY.

Section ALT_CTRL.

(* decompte des messages sur une file d'attente alternee *)

Remark S_card_mess :
 forall (q0 : queue Message) (m : Message),
 card_mess m (input Message m q0) = (card_mess m q0 + 1)%Z.
Proof.
 intros; unfold card_mess in |- *; apply input_S_card; trivial.
Qed.

Remark card_mess_diff :
 forall (q0 : queue Message) (m m' : Message),
 m <> m' -> card_mess m (input Message m' q0) = card_mess m q0.
Proof.
 intros; unfold card_mess in |- *; apply input_diff_card; trivial.
Qed.

Remark S_sigma_card_inc :
 forall (s0 : Site) (q0 : queue Message),
 sigma Site LS
   (fun s' : Site => card_mess (inc_dec s') (input Message (inc_dec s0) q0)) =
 (sigma Site LS (fun s' : Site => card_mess (inc_dec s') q0) + 1)%Z.
Proof.
 intros; apply sigma__S with (eq_E_dec := eq_site_dec) (x0 := s0).
 exact finite_site.

 apply S_card_mess.

 intros; apply card_mess_diff; injection; auto.
Qed.

Remark diff_sigma_card_inc :
 forall q0 : queue Message,
 sigma Site LS
   (fun s' : Site => card_mess (inc_dec s') (input Message dec q0)) =
 sigma Site LS (fun s' : Site => card_mess (inc_dec s') q0).
Proof.
 intros; apply sigma_simpl.
 intros; apply card_mess_diff.
 discriminate.
Qed.

Lemma alt_dec_inc :
 forall q0 : queue Message,
 alternate q0 ->
 (card_mess dec q0 + 1 >=
  sigma Site LS (fun s' : Site => card_mess (inc_dec s') q0))%Z.
Proof.
 intros; elim H; intros.
 simpl in |- *; rewrite sigma_null; omega.

 rewrite card_mess_diff.
 rewrite S_sigma_card_inc.
 simpl in |- *; rewrite sigma_null; omega.

 discriminate.

 rewrite S_card_mess.
 rewrite diff_sigma_card_inc.
 omega.

 rewrite card_mess_diff.
 rewrite S_card_mess.
 rewrite S_sigma_card_inc.
 rewrite diff_sigma_card_inc.
 omega.

 discriminate.
Qed.

Lemma D_dec_inc :
 forall q0 : queue Message,
 alternate q0 ->
 D_queue q0 ->
 (card_mess dec q0 >=
  sigma Site LS (fun s' : Site => card_mess (inc_dec s') q0))%Z.
Proof.
 intros q0 H; elim H; intros.
 simpl in |- *; rewrite sigma_null; omega.

 absurd (D_queue (input Message (inc_dec s0) (empty Message))).
 apply not_D_queue.

 trivial.

 rewrite S_card_mess.
 rewrite diff_sigma_card_inc.
 apply alt_dec_inc; trivial.

 absurd (D_queue (input Message (inc_dec s0) (input Message dec qm))).
 apply not_D_queue.

 trivial.
Qed.

End ALT_CTRL.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Cprime P T : Universe, ((wd_ A B /\ (wd_ P T /\ (wd_ C A /\ (wd_ C B /\ (wd_ C T /\ (wd_ C P /\ (wd_ Cprime P /\ (col_ A B P /\ (col_ T A B /\ (col_ C P T /\ col_ P C Cprime)))))))))) -> col_ C A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import String.
Require Import StringGraph.
Require Import ListUtil.
Require Import Bool.Bool.
Require Import ZArith.
Require Import Coq.Lists.List.
Import ListNotations.

Section Collapse.

Definition Double (S : list StringGraphEdge) : list StringGraphEdge :=
	S ++ S.

Fixpoint FindInEdgesFrom (L : list StringGraphEdge) (A : String) {struct L} : list StringGraphEdge :=
	match L with
	| [] => []
	| e :: R =>
		if str_eq_dec (To e) A then
			e :: FindInEdgesFrom R A
		else
			FindInEdgesFrom R A
	end.

(* H : connected components of the same level as A *)
Fixpoint CollapseNodeAtLevel' (H : list list String) (S L : list StringGraphEdge) (A : String) {struct L} : list StringGraphEdge) :=
	match L with
	| [] => S
	| e :: R =>
		if str_eq_dec (To e) A then (* L is sorted so no more edges will be removed *)
			S
		else
			match FindInEdgesFrom L A with
			| [] => CollapseNodeAtLevel' S R A
			| [u] => (* ... *)
			| u :: U =>
				let eCollapsed := pair (pref (suff (From e))) (To e) in
					let uCollapsed := pair (From u) (suff (pref (To u))) in
						CollapseNodeAtLevel' (eCollapsed :: uCollapsed :: (RemoveList StringGraphEdge edge_eq_dec S [e; u])) R A
			end
	end.

Fixpoint CollapseLevel' (S B : list StringGraphEdge) (l : nat) {struct S} : list StringGraphEdge :=
	match S with
	| [] => []
	| e :: R => S (* ... *)
		(*if (length ())*)
	end.

Definition CollapseLevel (S : list StringGraphEdge) (l : nat) : list StringGraphEdge :=
	CollapseLevel' S [] l.

Fixpoint RemoveLowerPairsFor' (S B : list StringGraphEdge) (V : String) {struct S} : list StringGraphEdge :=
	match S with
	| [] => []
	| e :: R =>
		if Contains StringGraphEdge edge_eq_dec B e then (* B: edges marked for removal *)
			RemoveLowerPairsFor' R (RemoveFirst StringGraphEdge edge_eq_dec B e) V
		else
			let eInv := pair (To e) (From e) in
				let eInvBlacklisted := Count StringGraphEdge edge_eq_dec B eInv in
					let eInvRemaining := Count StringGraphEdge edge_eq_dec R eInv in
						let eRemaining := Count StringGraphEdge edge_eq_dec R e in
							if str_eq_dec (From e) [] then
								if (eInvBlacklisted + 2) <=? eInvRemaining then
									RemoveLowerPairsFor' R (eInv :: B) V
								else
									if (0 <? eRemaining) && ((1 + eInvBlacklisted) <=? eInvRemaining) then
										RemoveLowerPairsFor' R (eInv :: B) V
									else
										e :: RemoveLowerPairsFor' R B V
							else
								if str_eq_dec (To e) [] then
									if (eInvBlacklisted + 2) <=? eInvRemaining then
										RemoveLowerPairsFor' R (eInv :: B) V
									else
										if (0 <? eRemaining) && ((1 + eInvBlacklisted) <=? eInvRemaining) then
											RemoveLowerPairsFor' R (eInv :: B) V
										else
											e :: RemoveLowerPairsFor' R B V
								else
									e :: RemoveLowerPairsFor' R B V
	end.

Definition RemoveLowerPairsFor (S : list StringGraphEdge) (V : String) : list StringGraphEdge :=
	RemoveLowerPairsFor' S [] V.

Fixpoint RemoveLowerPairs' (S : list StringGraphEdge) (V : list String) {struct V} : list StringGraphEdge :=
	match V with
	| [] => S
	| v :: R => RemoveLowerPairs' (RemoveLowerPairsFor S v) R
	end.

Definition RemoveLowerPairs (S : list StringGraphEdge) :=
	RemoveLowerPairs' S (FilterVertexLevel S 1).

Fixpoint Collapse' (S : list StringGraphEdge) (l : nat) {struct l} : list StringGraphEdge :=
	match l with
	| 0 | 1 => RemoveLowerPairs S
	| S k => Collapse' (CollapseLevel S l) k
	end.

Definition Collapse (S : list StringGraphEdge) : list StringGraphEdge :=
	Collapse' S (GraphHeight S).

Definition DoubleAndCollapse (S : list String) : String :=
	GenerateSuperstring (Collapse (Double (FindTrivialSolution S (ConstructFullGraph S)))).

End Collapse.