Require Import ho_proof_until_gen.

Set Implicit Arguments.

Section until_all.

Variables (cfg : Type) (cstep : cfg -> cfg -> Prop).
Definition Spec : Type := cfg -> (cfg -> cfg -> Prop) -> (cfg -> Prop) -> Prop.

(* Soundness *)
CoInductive until (k : cfg) (R : cfg -> cfg -> Prop) (P : cfg -> Prop) : Prop :=
  | rdone : P k -> until k R P
  | rstep : (exists k', cstep k k') ->
            (forall k', cstep k k' -> R k k' /\ until k' R P) -> until k R P.

Definition sound (Rules : Spec) : Prop := subspec Rules until.

Inductive step (X : Spec) (k : cfg) (R : cfg -> cfg -> Prop) (P : cfg -> Prop) : Prop :=
  | sdone : P k -> step X k R P
  | sstep : (exists k', cstep k k') ->
            (forall k', cstep k k' -> R k k' /\ X k' R P) -> step X k R P.

Lemma step_mono : mono step.
Proof.
  destruct 2. constructor. assumption.
  apply sstep. assumption. intros. split. Focus 2. apply H.
  eapply H1. assumption. eapply H1. assumption.
Qed.

Lemma until_stable : subspec until (step until).
Proof. destruct 1; econstructor(assumption). Qed.

CoFixpoint stable_sound (Rules : Spec)
  (Hstable : forall x R P, Rules x R P -> step Rules x R P)
  : sound Rules := fun x R P H =>
match Hstable _ _ _ H with
    | sdone pf => rdone _ _ _ pf
    | sstep not_stuck Hsteps => rstep not_stuck (fun k' Hstep =>
        let (Hpres, Hk') := Hsteps k' Hstep
        in conj Hpres (stable_sound Hstable k' R P Hk'))
end.

Lemma proof_by_t : forall (Rules : Spec), subspec Rules (step (t step Rules)) -> sound Rules.
  intros. apply t_ext in H. apply stable_sound in H. revert H.
  unfold sound, subspec. intros. apply H. apply t_id. trivial. apply step_mono.
Qed.

Definition trans (X:Spec) : Spec :=
  fun k R P => exists Q, X k R Q /\ (forall k', Q k' -> X k' R P).
Print trans.

Lemma mono_trans : mono trans.
Proof.
  destruct 2. inversion H0. econstructor; split. apply H. eassumption.
  intros. apply H. apply H2. trivial.
Qed.

Lemma trans_ok_rule : forall X, subspec (trans X) (t step X).
  apply rule_by_T. apply step_mono. apply mono_trans.
  unfold subspec. intros. destruct H as [Q' [HQ' H]].
  destruct HQ'. specialize (H _ H0). revert H. apply step_mono. apply Tf_id.
  eapply sstep;eauto. intros. split. apply H1. assumption.
  apply Tf_idem. apply step_mono. apply mono_trans.
  apply T_id. exists Q'. split. apply Tf_id. apply H1. assumption.
  intros. specialize (H k'0 H3). apply Tf_base. apply step_mono. assumption.
Qed.

Lemma use_trans : forall A, subspec (trans (t step A)) (t step A).
apply t_rule. firstorder. apply step_mono. apply trans_ok_rule.
Qed.

Lemma tstep: forall F, mono F -> forall A x R P,
      (exists x', cstep x x') ->
      (forall x', cstep x x' -> R x x' /\ T step F A x' R P) -> T step F A x R P.
Proof.
  intros. apply use_step. apply step_mono. assumption. eapply sstep. assumption. assumption.
Qed.

Lemma tdone: forall F, mono F -> forall A x R (P:cfg->Prop), P x -> T step F A x R P.
Proof.
  intros. apply use_step. apply step_mono. assumption. eapply sdone;eassumption.
Qed.

Print t_coind.

Lemma tcoind: forall F,
    mono F -> forall X Y x R (P:cfg->Prop), T step F Y x R P -> T step F X x R P.
Proof.
  intros.
  pose proof (@t_coind cfg step X Y).
  admit.
Qed.

Lemma ttrans: forall F, mono F -> forall A x R Q P,
    T step F A x R Q -> (forall y, Q y -> T step F A y R P) -> T step F A x R P.
Proof.
  intros. apply Tf_idem. apply step_mono. assumption. apply Tf_t. assumption.
  apply trans_ok_rule. unfold trans. exists Q.
  split;assumption.
Qed.

(* X <= step(t X) ==> X <= gfp step *)
(* X <= Step (T X) *)
(* X (step A) <= step ((T X) A) ==> X <= t
   ==> X reaches <= reaches, other stuff *)

(* t_|_ = gfp step ==> t (gfp step) = t (t _|_) = t bot = gfp step *)

(* F : higher order spec  *)
(* F(A) <= step((T F) A)  *)
(* gfp F <= reaches *)
Lemma ok : forall F, mono F ->
    (forall A, subspec (F A) (step (T step F A))) ->
    (forall X, subspec X (F X) -> subspec X until)
    (* == subspec (gfp F) reaches *).
  intros.
  assert (forall A, subspec (F A) (t step A)).
  intros. apply rule_by_T. apply step_mono. apply H.
  unfold subspec;intros. apply H0 in H2. revert H2. apply step_mono.
  unfold subspec;intros. apply Tf_idem. apply step_mono. assumption.
  revert H2. apply T_mono. assumption. apply Tf_base. apply step_mono.
  apply proof_by_t. intro;intros.
  apply H1 in H3. apply H0 in H3.
  revert H3. apply step_mono. apply T_rule_f. apply step_mono. assumption. assumption.
Qed.

End until_all.


(* 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                                                     *)

Require Export distance_euclidienne.
Set Implicit Arguments.
Unset Strict Implicit.

Lemma carre_scalaire_somme :
 forall A B C D : PO,
 scalaire (add_PP (vec A B) (vec C D)) (add_PP (vec A B) (vec C D)) =
 2 * scalaire (vec A B) (vec C D) +
 (scalaire (vec A B) (vec A B) + scalaire (vec C D) (vec C D)) :>R.
intros.
VReplace (add_PP (vec A B) (vec C D))
 (add_PP (mult_PP 1 (vec A B)) (mult_PP 1 (vec C D))).
Simplscal.
rewrite (scalaire_sym C D A B); ring.
Qed.

Lemma difference_Pythagore :
 forall A B C : PO,
 scalaire (vec B C) (vec B C) =
 scalaire (vec A B) (vec A B) + scalaire (vec A C) (vec A C) +
 -2 * scalaire (vec A B) (vec A C) :>R.
intros.
VReplace (vec B C) (add_PP (mult_PP (-1) (vec A B)) (mult_PP 1 (vec A C))).
Simplscal.
rewrite (scalaire_sym A C A B); ring.
Qed.

Lemma triangle_Pythagore :
 forall A B C : PO,
 scalaire (vec A B) (vec A C) = 0 <->
 scalaire (vec B C) (vec B C) =
 scalaire (vec A B) (vec A B) + scalaire (vec A C) (vec A C) :>R.
intros; red in |- *.
rewrite (difference_Pythagore A B C).
split; [ intros H; try assumption | idtac ].
rewrite H.
ring.
intros H; try assumption.
cut (2 * scalaire (vec A B) (vec A C) = 0); intros.
elim Rmult_integral with (r1 := 2) (r2 := scalaire (vec A B) (vec A C));
 [ intros H1; try clear without_div_Od
 | intros H1; try clear without_div_Od; try exact H1
 | try assumption ].
absurd (2 = 0); try assumption.
discrR.
replace 0 with
 (scalaire (vec A B) (vec A B) + scalaire (vec A C) (vec A C) +
  -1 * (scalaire (vec A B) (vec A B) + scalaire (vec A C) (vec A C))).
pattern (scalaire (vec A B) (vec A B) + scalaire (vec A C) (vec A C)) at 2
 in |- *.
rewrite <- H.
ring.
ring.
Qed.

Theorem Pythagore :
 forall A B C : PO,
 orthogonal (vec A B) (vec A C) <->
 Rsqr (distance B C) = Rsqr (distance A B) + Rsqr (distance A C) :>R.
intros.
unfold Rsqr in |- *; repeat rewrite <- carre_scalaire_distance.
elim (triangle_Pythagore A B C); intros.
red in |- *; split; intros.
apply H; auto with geo.
apply def_orthogonal2; auto.
Qed.

Lemma longueur_mediane :
 forall A B C I : PO,
 I = milieu B C ->
 Rsqr (distance A B) + Rsqr (distance A C) =
 R2 * (Rsqr (distance A I) + Rsqr (distance I B)) :>R.
intros.
unfold Rsqr, R2 in |- *; repeat rewrite <- carre_scalaire_distance.
replace (vec A B) with (add_PP (mult_PP 1 (vec A I)) (mult_PP 1 (vec I B))).
replace (vec A C) with
 (add_PP (mult_PP 1 (vec A I)) (mult_PP (-1) (vec I B))).
Simplscal.
replace (vec I B) with (mult_PP (-1) (vec I C)).
Ringvec.
rewrite <- (milieu_vecteur H).
Ringvec.
Ringvec.
Qed.

Lemma demi_longueur :
 forall A B I : PO,
 I = milieu A B -> Rsqr (distance A B) = R4 * Rsqr (distance A I) :>R.
intros.
unfold Rsqr, R4 in |- *; repeat rewrite <- carre_scalaire_distance.
replace (vec A B) with (mult_PP 2 (vec A I)).
Simplscal.
rewrite <- (milieu_vecteur_double H); auto.
Qed.

Theorem mediane :
 forall A B C I : PO,
 I = milieu B C ->
 R4 * Rsqr (distance A I) =
 R2 * (Rsqr (distance A B) + Rsqr (distance A C)) - Rsqr (distance B C) :>R.
unfold R2, R4 in |- *; intros.
rewrite (longueur_mediane A (B:=B) (C:=C) (I:=I)); auto.
rewrite (demi_longueur (A:=B) (B:=C) (I:=I)); unfold R2, R4 in |- *; auto.
rewrite (distance_sym B I); auto.
ring.
Qed.

Lemma rectangle_Pythagore :
 forall A B C : PO,
 orthogonal (vec A B) (vec A C) <->
 scalaire (vec B C) (vec B C) =
 scalaire (vec A B) (vec A B) + scalaire (vec A C) (vec A C) :>R.
intros.
generalize (triangle_Pythagore A B C); unfold iff in |- *; intros.
elim H; intros H0 H1; try clear H; try exact H0.
split; [ intros H; try assumption | idtac ].
apply H0; auto with geo.
intros H; try assumption.
apply def_orthogonal2; auto.
Qed.
Require Export projection_orthogonale.

Lemma Pythagore_projete_orthogonal :
 forall A B C H : PO,
 A <> B :>PO ->
 H = projete_orthogonal A B C :>PO ->
 Rsqr (distance A C) = Rsqr (distance H A) + Rsqr (distance H C) :>R /\
 Rsqr (distance B C) = Rsqr (distance H B) + Rsqr (distance H C) :>R.
intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := C) (H := H);
 [ intros; auto | auto | auto ].
halignes H2 k.
split; [ try assumption | idtac ].
elim (Pythagore H A C); intros.
apply H5.
replace (vec H A) with (mult_PP (-1) (vec A H)).
rewrite H4.
replace (mult_PP (-1) (mult_PP k (vec A B))) with (mult_PP (- k) (vec A B)).
Simplortho.
Ringvec.
Ringvec.
elim (Pythagore H B C); intros.
apply H5.
replace (vec H B) with
 (add_PP (mult_PP 1 (vec A B)) (mult_PP (- k) (vec A B))).
Simplortho.
replace (mult_PP (- k) (vec A B)) with (mult_PP (-1) (mult_PP k (vec A B))).
rewrite <- H4.
Ringvec.
Ringvec.
Qed.

Lemma scalaire_difference_carre :
 forall A B I M : PO,
 I = milieu A B ->
 scalaire (vec M A) (vec M B) = Rsqr (distance M I) + - Rsqr (distance I A).
intros.
unfold Rsqr in |- *; repeat rewrite <- carre_scalaire_distance.
VReplace (vec M B) (add_PP (mult_PP 1 (vec M I)) (mult_PP 1 (vec I B))).
rewrite <- (milieu_vecteur H); auto.
VReplace (mult_PP 1 (vec A I)) (mult_PP (-1) (vec I A)).
VReplace (vec M A) (add_PP (mult_PP 1 (vec M I)) (mult_PP 1 (vec I A))).
Simplscal.
rewrite (scalaire_sym M I I A); ring.
Qed.

Lemma egalite_scalaire_deux_projetes :
 forall A B C H K : PO,
 A <> B ->
 A <> C ->
 H = projete_orthogonal A B C ->
 K = projete_orthogonal A C B ->
 scalaire (vec A B) (vec A H) = scalaire (vec A K) (vec A C).
intros.
elim scalaire_deux_projetes with (A := A) (B := B) (C := C) (H := H) (K := K);
 [ intros H4 H5; try clear scalaire_deux_projetes; try exact H5
 | auto
 | auto
 | auto
 | auto ].
rewrite <- H4; auto.
Qed.

Lemma projete_distance_Rlt :
 forall A B C H : PO,
 A <> B ->
 H <> B -> H = projete_orthogonal A B C -> distance C H < distance C B.
intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := C) (H := H);
 [ intros | auto | auto ].
elim (Pythagore H B C); intros.
assert (Rsqr (distance C H) < Rsqr (distance C B)).
rewrite (distance_sym C B).
rewrite H5; auto.
RReplace (Rsqr (distance C H)) (Rsqr (distance C H) + 0).
assert (0 < Rsqr (distance H B)).
assert (distance H B <> 0); auto with geo.
cut (0 <= distance H B); auto with geo real.
RReplace (Rsqr (distance H B) + Rsqr (distance H C))
 (Rsqr (distance H C) + Rsqr (distance H B)).
rewrite distance_sym; auto with real.
halignes H3 k.
VReplace (vec H B) (add_PP (vec A B) (mult_PP (-1) (vec A H))).
rewrite H7.
VReplace (add_PP (vec A B) (mult_PP (-1) (mult_PP k (vec A B))))
 (mult_PP (1 + - k) (vec A B)).
auto with geo.
apply Rsqr_incrst_0; auto with real geo.
Qed.
Parameter distance_droite : PO -> DR -> R.

Axiom
  distance_droite_def :
    forall A B C H : PO,
    A <> B ->
    H = projete_orthogonal A B C ->
    distance_droite C (droite A B) = distance C H.

Lemma existence_distance_droite :
 forall A B C : PO,
 A <> B -> exists d : R, d = distance_droite C (droite A B).
intros A B C H0; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := C);
 [ intros H H1; try clear existence_projete_orthogonal; try exact H1 | auto ].
exists (distance C H).
rewrite (distance_droite_def (A:=A) (B:=B) (C:=C) (H:=H)); auto.
Qed.


Require Export SpecSemantics.
Require Export BoilerplateSemantics.
Set Implicit Arguments.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with try (subst; eauto using red).
  depind wt; simpl; auto.
  - inversion H.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - inversion wt1; eauto using subst_evar_typing.
Qed.


(* Top-level noninterference
   Author: Aslan Askarov
   Created: 2016-07-28
 *)

Require Import Bool Arith List CpdtTactics SfLib LibTactics.
Require Import Coq.Program.Equality.
Require Import Omega.

Set Implicit Arguments.

Require Import Identifier Environment Imperative Types Augmented Bridge.
Require Import WellFormedness LowEq.
Require Import InductionPrinciple.
Require Import UtilTactics.
Require Import BridgeTactics.
Require Import BridgeProperties.
Require Import Adequacy.
Require Import NIBridge.

Definition TINI_idx (n: nat): Prop :=
  forall Γ c m m_end s s_end pc k,
    〈c, m 〉 ⇒/+ n +/ 〈STOP, m_end 〉 ->
    -{ Γ, pc ⊢ c }- ->
    state_low_eq Γ m s ->
    〈c, s 〉 ⇒/+ k +/ 〈STOP, s_end 〉 ->
    state_low_eq Γ m_end s_end.

(** We apply bridge noninterference iteratively
    for as long as there are bridge events. *)
Lemma tini_idx: forall n, TINI_idx (n).

Proof.
  apply strongind.
  (* base case *)
  { unfolds.
    intros.
    inverts H.
    inverts H0.
  }
  (* inductive case *)
  {

    unfold TINI_idx.
    intros n IH Γ c m m_end s s_end pc k H_m H_wt H_leq H_s.

    forwards* H_bridge_m: bridge_adequacy H_m.
    {
      inverts~ H_leq.
    }

    forwards* H_bridge_s: bridge_adequacy H_s.
    {
      inverts~ H_leq.
    }

    destruct H_bridge_m as [? | ?H_bridge_m];
      subst ;
      try  (solve [inverts H_wt]).
    destruct H_bridge_s as [? | ?H_bridge_s];
      subst;
      try  (solve [inverts H_wt]).

    lets  (?ev1 & ?n1 &  ?cfg1 & ?k1 & ?H_bridge_IH1 & H_multi_IH1 & ?): H_bridge_m.
    lets  (?ev2 & ?n2 &  ?cfg2 & ?k2 & ?H_bridge_IH2 & H_multi_IH2 & ?): H_bridge_s.

    (* TODO: earlier : add stop non-typability into hints *)

    clear H_bridge_m H_bridge_s.

    destruct cfg1 as [c1 m'].
    destruct cfg2 as [c2 s'].

    assert (k1 <= n) as H_k1 by omega.

    (* replace n1 with (S (n1 - 1)) in * by (inverts* H_bridge_IH1; omega ).
    replace n2 with (S (n2 - 1)) in * by (inverts* H_bridge_IH2; omega ).
     *)

    lets NI_bridge: ni_bridge_num n1; unfold NI_idx in NI_bridge.

    specializes~ NI_bridge (>>Γ c m s ev1  c1  m' s' n2 ___).

    forwards* (? & ?H_wt'): preservation_bridge.
    {
      inversion H_leq; auto.
    }
    lets (H_leq' & cmd_eq & ? ) : NI_bridge.
    clear NI_bridge.
    subst.

    compare c2 STOP; intros; subst.
    - assert (m' = m_end) by eauto.
      assert (s' = s_end) by eauto.
      subst*.
    - specializes* H_wt'.
  }
Qed.

(** Standard termination-insensitive noninterference *)

Theorem TINI:
  forall Γ c m s m_end s_end pc,
    -{ Γ, pc ⊢ c }- ->
    state_low_eq Γ m s ->
    〈c, m 〉 ⇒* 〈STOP, m_end 〉 ->
    〈c, s 〉 ⇒* 〈STOP, s_end 〉 ->
    state_low_eq Γ m_end s_end.
Proof.
  intros Γ c m s m_end s_end pc H_wt H_leq H_m H_s.
  forwards (?n & ?H'_m) : from_multi_to_multi_idx H_m; clear H_m.
  forwards (?k & ?H'_s) : from_multi_to_multi_idx H_s; clear H_s.

  applys tini_idx H'_m H_wt H_leq H'_s.
Qed.


From iris.proofmode Require Import tactics.
From iris.base_logic Require Import iprop.

Section foo.
  Context `(Σ : gFunctors).
  Definition foo : iProp Σ := ∃ (x : nat), x ≡ 0.
End foo.
Opaque foo.

Lemma bar Σ : ⊢ foo Σ .
Proof.
  by iExists 0. Restart.
  iStartProof.
  eapply coq_tactics.tac_exist.
  Fail apply (class_instances_bi.from_exist_exist _).
  apply: (class_instances_bi.from_exist_exist _).
  (* notypeclasses refine (class_instances_bi.from_exist_exist _). *)
  by eexists 0.
Qed.


(******************************************************************************)
(*   Copyright (c) 2019--2022 - Paulo Torrens <paulotorrens AT gnu DOT org>   *)
(******************************************************************************)

Require Export List.
Require Import Arith.
Require Import Local.Prelude.
Export ListNotations.

(** ** Syntax

    Inspired by the lambda cube, we use [type] and [prop] as our universes, and
    we keep [base] as our only base type. We also use [void] as the type of
    commands, though it won't appear on any actual terms. As standard, we use de
    Bruijn indexes on the [bound] constructor for variables. Types are simple;
    our only type constructor is [negation], a polyadic type which represents
    the negation of an N-tuple of types.

    The commands in our language are either a [jump], written as k<x, ...>, or a
    [bind], written as b { k<x: t, ...> = c }. *)

Inductive pseudoterm: Set :=
  | type
  | prop
  | base
  | void
  | bound (n: nat)
  | negation (ts: list pseudoterm)
  | jump (f: pseudoterm) (xs: list pseudoterm)
  | bind (b: pseudoterm) (ts: list pseudoterm) (c: pseudoterm).

Coercion bound: nat >-> pseudoterm.

(** A simple example. We use a lambda syntax to bind the name of free variables
    for illustration purposes. Notice that, in the list notation used by Coq,
    the head of the list appears at the leftmost position, while in the CPS term
    syntax, the most recent binding will appear at the rightmost position.

    As such, [ex1] is equivalent to the following term:

    \j.\x.\y.\z.
      h@1<y@3, k@0, x@4>
      { k<a, b> =
          h@2<b@0, j@6, a@1> }
      { h<c, d, e> =
          d@1<e@0, z@3> }
*)

Example ex1: pseudoterm :=
  (bind (bind
    (jump 1 [bound 4; bound 0; bound 3])
    [base; base]
      (jump 2 [bound 1; bound 6; bound 0]))
    [base; negation [base; base]; base]
      (jump 1 [bound 3; bound 0])).

(** As we have lists inside our pseudoterms, we'll need a stronger induction
    principle for it, stating that propositions are kept inside those lists. *)

Definition pseudoterm_deepind:
  forall P: pseudoterm -> Prop,
  forall f1: P type,
  forall f2: P prop,
  forall f3: P base,
  forall f4: P void,
  forall f5: (forall n, P (bound n)),
  forall f6: (forall ts, Forall P ts -> P (negation ts)),
  forall f7: (forall f xs, P f -> Forall P xs -> P (jump f xs)),
  forall f8: (forall b ts c, P b -> Forall P ts -> P c -> P (bind b ts c)),
  forall e, P e.
Proof.
  do 9 intro; fix H 1.
  destruct e.
  (* Case: type. *)
  - apply f1.
  (* Case: prop. *)
  - apply f2.
  (* Case: base. *)
  - apply f3.
  (* Case: void. *)
  - apply f4.
  (* Case: bound. *)
  - apply f5.
  (* Case: negation. *)
  - apply f6.
    induction ts; auto.
  (* Case: jump. *)
  - apply f7; auto.
    induction xs; auto.
  (* Case: bind. *)
  - apply f8; auto.
    induction ts; auto.
Defined.

(** Equality on pseudoterms is decidable. *)

Lemma pseudoterm_eq_dec:
  forall a b: pseudoterm,
  { a = b } + { a <> b }.
Proof.
  fix H 1.
  destruct a; destruct b; try (right; intro; discriminate).
  (* Case: type. *)
  - left; reflexivity.
  (* Case: prop. *)
  - left; reflexivity.
  (* Case: base. *)
  - left; reflexivity.
  (* Case: void. *)
  - left; reflexivity.
  (* Case: bound. *)
  - destruct Nat.eq_dec with n n0.
    + left; congruence.
    + right; congruence.
  (* Case negation. *)
  - destruct list_eq_dec with pseudoterm ts ts0.
    + exact H.
    + left; congruence.
    + right; congruence.
  (* Case: jump. *)
  - destruct list_eq_dec with pseudoterm xs xs0.
    + exact H.
    + destruct H with a b; try (right; congruence).
      left; congruence.
    + right; congruence.
  (* Case: bind. *)
  - destruct list_eq_dec with pseudoterm ts ts0.
    + exact H.
    + destruct H with a1 b1; try (right; congruence).
      destruct H with a2 b2; try (right; congruence).
      left; congruence.
    + right; congruence.
Qed.

Definition traverse_list f k: list pseudoterm -> list pseudoterm :=
  fold_right (fun t ts =>
    f (length ts + k) t :: ts) [].

Fixpoint traverse f k e: pseudoterm :=
  match e with
  | type =>
    type
  | prop =>
    prop
  | base =>
    base
  | void =>
    void
  | bound n =>
    f k n
  | negation ts =>
    negation (traverse_list (traverse f) k ts)
  | jump x xs =>
    jump (traverse f k x) (map (traverse f k) xs)
  | bind b ts c =>
    bind (traverse f (S k) b) (traverse_list (traverse f) k ts)
      (traverse f (k + length ts) c)
  end.

Definition lift i: nat -> pseudoterm -> pseudoterm :=
  traverse (fun k n =>
    if le_gt_dec k n then
      bound (i + n)
    else
      bound n).

Arguments lift i k e: simpl nomatch.

Definition subst y: nat -> pseudoterm -> pseudoterm :=
  traverse (fun k n =>
    match lt_eq_lt_dec k n with
    | inleft (left _) => bound (pred n)
    | inleft (right _) => lift k 0 y
    | inright _ => bound n
    end).

Arguments subst y k e: simpl nomatch.

Fixpoint apply_parameters ys k e: pseudoterm :=
  match ys with
  | [] => e
  | y :: ys => apply_parameters ys k (subst y (k + length ys) e)
  end.

Global Hint Unfold apply_parameters: cps.

Definition switch_bindings k e: pseudoterm :=
  subst 1 k (lift 1 (2 + k) e).

Global Hint Unfold switch_bindings: cps.

Fixpoint sequence (high: bool) (i: nat): list pseudoterm :=
  match i with
  | 0 => []
  | S j => bound (if high then i else j) :: sequence high j
  end.

Global Hint Unfold sequence: cps.

Notation high_sequence := (sequence true).
Notation low_sequence := (sequence false).

Definition right_cycle (i: nat) (k: nat) e: pseudoterm :=
  apply_parameters (bound 0 :: high_sequence i) k (lift (S i) (S i + k) e).

Global Hint Unfold right_cycle: cps.

Definition remove_binding k e: pseudoterm :=
  subst 0 k e.

Inductive not_free: nat -> pseudoterm -> Prop :=
  | not_free_type:
    forall n,
    not_free n type
  | not_free_prop:
    forall n,
    not_free n prop
  | not_free_base:
    forall n,
    not_free n base
  | not_free_void:
    forall n,
    not_free n void
  | not_free_bound:
    forall n m,
    n <> m -> not_free n m
  | not_free_negation:
    forall n ts,
    not_free_list n ts ->
    not_free n (negation ts)
  | not_free_jump:
    forall n x ts,
    not_free n x ->
    Forall (not_free n) ts -> not_free n (jump x ts)
  | not_free_bind:
    forall n b ts c,
    not_free (S n) b ->
    not_free_list n ts ->
    not_free (length ts + n) c ->
    not_free n (bind b ts c)

with not_free_list: nat -> list pseudoterm -> Prop :=
  | not_free_list_nil:
    forall n,
    not_free_list n []
  | not_free_list_cons:
    forall n t ts,
    not_free (length ts + n) t ->
    not_free_list n ts ->
    not_free_list n (t :: ts).

Global Hint Constructors not_free: cps.
Global Hint Constructors not_free_list: cps.

Definition free n e: Prop :=
  ~not_free n e.

Global Hint Unfold free: cps.


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

- Frederic Blanqui, 2005-02-17
- Adam Koprowski and Hans Zantema, 2007-03
- Joerg Endrullis and Dimitri Hendriks, 2008-07

General definitions and results about relations.
*)

Set Implicit Arguments.

From Coq Require Import Setoid Basics Morphisms List Lia.
From Coq Require Export Relations.

From CoLoR Require Import LogicUtil.
From CoLoR Require Export RelMidex.

Arguments inclusion {A} R1 R2.
Arguments same_relation {A} R1 R2.
Arguments transp {A} R x y.
Arguments clos_refl_trans {A} R x y.
Arguments clos_trans {A} R x y.
Arguments reflexive {A} R.
Arguments transitive {A} R.
Arguments antisymmetric {A} R.
Arguments symmetric {A} R.
Arguments equiv {A} R.
Arguments union {A} R1 R2 x y.
Arguments lexprod [A B] _ _ _ _.
Arguments symprod [A B] _ _ _ _.

Declare Scope relation_scope.

(***********************************************************************)
(** Notations for some relations and operations on relations. *)

Notation rel := relation.

Notation incl := inclusion.
Infix "<<" := incl (at level 50) : relation_scope.

Notation same := same_relation.
Infix "==" := same (at level 70).

Infix "U" := union (at level 45) : relation_scope.
Notation "x #" := (clos_refl_trans x) (at level 35) : relation_scope.
Notation "x !" := (clos_trans x) (at level 35) : relation_scope.

Open Scope relation_scope.

(***********************************************************************)
(** Properties of [incl]. *)

Global Instance incl_refl A : Reflexive (@incl A).

Proof. fo. Qed.

Ltac incl_refl := apply incl_refl.

Global Instance incl_trans A : Transitive (@incl A).

Proof. fo. Qed.

Ltac incl_trans S := apply incl_trans with S; try incl_refl.

Global Instance incl_same A : Proper (same ==> same ==> impl) (@incl A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Lemma incl_elim A (R S : rel A) : R << S -> forall x y, R x y -> S x y.

Proof. auto. Qed.

Arguments incl_elim [A R S] _ [x y] _.

(***********************************************************************)
(** Properties of [same]. *)

Lemma rel_eq A (R S : rel A) : R == S <-> forall x y, R x y <-> S x y.

Proof. fo. Qed.

Global Instance same_equiv A : Equivalence (@same A).

Proof. fo. Qed.

(***********************************************************************)
(** Basic meta-theorems. *)

Lemma eq_incl_refl_rel A (R : rel A) : Reflexive R -> eq << R.

Proof. intros hR x y xy. subst y. apply hR. Qed.

Lemma sym A (R : rel A) x y : Symmetric R -> (R x y <-> R y x).

Proof. split_all. Qed.

(***********************************************************************)
(** Morphisms wrt [incl] and [same]. *)

Global Instance refl_same A : Proper (same ==> impl) (@Reflexive A).

Proof. fo. Qed.

Global Instance sym_same A : Proper (same ==> impl) (@Symmetric A).

Proof. fo. Qed.

Global Instance trans_same A : Proper (same ==> impl) (@Transitive A).

Proof.
  intros R S e h x y z xy yz. rewrite rel_eq in e. rewrite <- e in *.
  apply h with y; hyp.
Qed.

Global Instance equiv_same A : Proper (same ==> impl) (@Equivalence A).

Proof. intros R S RS [hr hs ht]. constructor; rewrite <- RS; hyp. Qed.

(***********************************************************************)
(** Properties of [Proper]. *)

Lemma prop2_incl A B C (f : A -> B -> C) :
  Proper (incl --> incl --> incl ==> impl)
         (fun R S T => Proper (R ==> S ==> T) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' hf x x' xx' y y' yy'.
  apply TT'. apply hf; fo.
Qed.

Lemma prop3_incl A B C D (f : A -> B -> C -> D) :
  Proper (incl --> incl --> incl --> incl ==> impl)
         (fun R S T V => Proper (R ==> S ==> T ==> V) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' V V' VV' hf x x' xx' y y' yy' z z' zz'.
  apply VV'. apply hf; fo.
Qed.

Lemma prop4_incl A B C D E (f : A -> B -> C -> D -> E) :
  Proper (incl --> incl --> incl --> incl --> incl ==> impl)
         (fun R S T V W => Proper (R ==> S ==> T ==> V ==> W) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' V V' VV' W W' WW'
         hf x x' xx' y y' yy' z z' zz' a a' aa'.
  apply WW'. apply hf; fo.
Qed.

Global Instance prop_rel_same A (E : rel A) :
  Proper (same ==> impl) (Proper (E ==> E ==> impl)).

Proof.
  intros R S [RS SR] h x x' xx' y y' yy' xy.
  apply RS. eapply h. apply xx'. apply yy'. apply SR. hyp.
Qed.

Lemma prop_subrel A (R S : rel A) :
  Equivalence S -> subrelation R S -> Proper (R ==> R ==> impl) S.

Proof.
  intros S_eq RS u u' uu' v v' vv' uv. apply RS in uu'. apply RS in vv'.
  rewrite <- uu', <- vv'. hyp.
Qed.

Lemma prop_rel_sym A B (f : A -> B -> Prop) R S :
  Symmetric R -> Symmetric S
  -> Proper (R ==> S ==> impl) f -> Proper (R ==> S ==> iff) f.

Proof.
  intros R_sym S_sym f_prop x x' xx' y y' yy'. split; intro h.
  eapply f_prop. apply xx'. apply yy'. hyp.
  eapply f_prop. sym. apply xx'. sym. apply yy'. hyp.
Qed.

Global Instance equiv_prop A (R : rel A) :
  Transitive R -> Symmetric R -> Proper (R ==> R ==> impl) R.

Proof. intros R_trans R_sym t t' tt' u u' uu' tu. trans t. hyp. trans u; hyp. Qed.

(***********************************************************************)
(** Empty relation. *)

Definition empty_rel {A} : rel A := fun x y => False.

(***********************************************************************)
(** Relation associated to a boolean function. *)

Definition rel_of_bool A (f : A->A->bool) : rel A :=
  fun x y => f x y = true.

(***********************************************************************)
(** Boolean function associated to a decidable relation. *)

Section bool_of_rel.

  Variables (A : Type) (R : rel A) (R_dec : rel_dec R).

  Definition bool_of_rel t u := if R_dec t u then true else false.

  Lemma bool_of_rel_true x y : bool_of_rel x y = true <-> R x y.

  Proof.
    unfold bool_of_rel. split; destruct (R_dec x y).
    auto. discr. refl. tauto.
  Qed.

  Lemma bool_of_rel_false x y : bool_of_rel x y = false <-> ~R x y.

  Proof.
    unfold bool_of_rel. split; destruct (R_dec x y).
    discr. auto. tauto. refl.
  Qed.

  Lemma bool_of_rel_refl x : Reflexive R -> bool_of_rel x x = true.

  Proof.
    intro R_refl. unfold bool_of_rel. destruct (R_dec x x). refl.
    exfalso. apply n. refl.
  Qed.

  Global Instance bool_of_rel_prop :
    Symmetric R -> Transitive R -> Proper (R ==> R ==> Logic.eq) bool_of_rel.

  Proof.
    intros R_sym R_trans x x' xx' y y' yy'. unfold bool_of_rel.
    destruct (R_dec x y); destruct (R_dec x' y'); try refl.
    exfalso. apply n. trans x. hyp. trans y; hyp.
    exfalso. apply n. trans x'. hyp. trans y'; hyp.
  Qed.

End bool_of_rel.

(*Arguments bool_of_rel_true [A R] _ [x y].
Arguments bool_of_rel_false [A R] _ [x y].*)

(***********************************************************************)
(** Definition of some properties on relations. *)

Definition classic_left_total A B (R : A -> B -> Prop) :=
  forall x, exists y, R x y.

Definition left_total A B (R : A -> B -> Prop) :=
  forall x, {y | R x y}.

Definition functional A B (R : A -> B -> Prop) :=
  forall x y z, R x y -> R x z -> y = z.

Definition finitely_branching A B (R : A -> B -> Prop) :=
  forall x, {l | forall y, R x y <-> In y l}.

Definition irreflexive A (R : rel A) := forall x, ~R x x.

Definition asymmetric A (R : rel A) := forall x y, R x y -> ~R y x.

(** Predicate saying that [f] is an infinite sequence of [R]-steps. *)
Definition IS A (R : rel A) f := forall i, R (f i) (f (S i)).

Definition EIS A (R : rel A) := exists f, IS R f.

Definition NT A (R : rel A) x := exists f, f 0 = x /\ IS R f.

(** Predicate saying that [f] and [g] describe an infinite sequence
  of R-steps modulo E: for all i, f(i) E g(i) R f(i+1). *)
Definition ISMod A (E R : rel A) (f g : nat -> A) :=
  forall i, E (f i) (g i) /\ R (g i) (f (S i)).

(* Called PreOrder in Coq. *)
Definition quasi_ordering A (R : rel A) := reflexive R /\ transitive R.

Definition ordering A (R : rel A) :=
  reflexive R /\ transitive R /\ antisymmetric R.

Definition strict_ordering A (R : rel A) := irreflexive R /\ transitive R.

(***********************************************************************)
(** Strict part. *)

Definition strict_part A (R : rel A) : rel A := fun x y => R x y /\ ~R y x.

(***********************************************************************)
(** Intersection. *)

Definition intersection A (R S : rel A) : rel A := fun x y => R x y /\ S x y.

Lemma intersection_dec A (R S : rel A) (Rdec : rel_dec R) (Sdec : rel_dec S) :
  rel_dec (intersection R S).

Proof.
  intros x y. unfold intersection. case (Rdec x y); case (Sdec x y); intuition.
Defined.

(***********************************************************************)
(** Finitely branching relations. *)

Section finitely_branching.

  Variables (A : Type) (R : rel A) (FB : finitely_branching R).

  Definition sons x := proj1_sig (FB x).

  Lemma in_sons_R : forall x y, In y (sons x) -> R x y.

  Proof. intros x y. exact (proj2 (proj2_sig (FB x) y)). Qed.

  Lemma R_in_sons : forall x y, R x y -> In y (sons x).

  Proof. intros x y. exact (proj1 (proj2_sig (FB x) y)). Qed.

End finitely_branching.

Arguments in_sons_R [A R] _ [x y] _.
Arguments R_in_sons [A R] _ [x y] _.

(***********************************************************************)
(** Equivalence relation associated to a PreOrder. *)

Definition inter_transp A (R : rel A) : rel A := fun x y => R x y /\ R y x.

(*COQ: declaring these Lemma's as Instance's creates problems in
FSetUtil and FGraph *)

Lemma inter_transp_refl A (R : rel A) :
  Reflexive R -> Reflexive (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_sym A (R : rel A) : Symmetric (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_trans A (R : rel A) :
  Transitive R -> Transitive (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_incl A (R : rel A) : inter_transp R << R.

Proof. fo. Qed.

(***********************************************************************)
(** Properties of [IS]. *)

Global Instance IS_incl A : Proper (incl ==> Logic.eq ==> impl) (@IS A).

Proof. intros R S RS f g fg h i. subst. fo. Qed.

Global Instance IS_same A : Proper (same ==> Logic.eq ==> impl) (@IS A).

Proof. intros R S RS f g fg h. subst. fo. Qed.

Global Instance EIS_same A : Proper (same ==> impl) (@EIS A).

Proof. intros R S RS h. destruct h as [f h]. exists f. rewrite <- RS. hyp. Qed.

Lemma NT_IS_elt A (R : rel A) f k : IS R f -> NT R (f k).

Proof. intro hf. exists (fun i => f (i+k)). fo. Qed.

Lemma red_NT A (R : rel A) t u : R t u -> NT R u -> NT R t.

Proof.
  intros tu [f [f0 hf]]. subst.
  exists (fun k => match k with 0 => t | S k' => f k' end).
  intuition. intro k. destruct k. hyp. apply hf.
Qed.

(***********************************************************************)
(** Properties of [irreflexive]. *)

Global Instance irreflexive_incl A : Proper (incl --> impl) (@irreflexive A).

Proof. fo. Qed.

(***********************************************************************)
(** Monotony. *)

Definition monotone A B (R : rel A) (S : rel B) f :=
  forall x y, R x y -> S (f x) (f y).

Lemma monotone_transp A B (R : rel A) (S : rel B) f :
  monotone R S f -> monotone (transp R) (transp S) f.

Proof. unfold monotone, transp. auto. Qed.

(***********************************************************************)
(** Composition. *)

Definition compose A (R S : rel A) : rel A :=
  fun x y => exists z, R x z /\ S z y.

Infix "@" := compose (at level 40) : relation_scope.

Global Instance compose_incl A : Proper (incl ==> incl ==> incl) (@compose A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Ltac comp := apply compose_incl; try incl_refl.

Global Instance compose_same A : Proper (same ==> same ==> same) (@compose A).

Proof. fo. Qed.

Definition absorbs_right A (R S : rel A) := R @ S << R.

Definition absorbs_left A (R S : rel A) := S @ R << R.

Lemma comp_assoc A (R S T : rel A) : (R @ S) @ T << R @ (S @ T).

Proof.
  unfold incl. intros. do 4 destruct H. exists x1; split. hyp.
  exists x0; split; hyp.
Qed.

Lemma comp_assoc' A (R S T : rel A) : R @ (S @ T) << (R @ S) @ T.

Proof.
  unfold incl. intros. do 2 destruct H. do 2 destruct H0.
  exists x1; split. exists x0; split; hyp. exact H1.
Qed.

Ltac assoc :=
  match goal with
    | |- (?s @ ?t) @ ?u << _ => incl_trans (s @ (t @ u)); try apply comp_assoc
    | |- ?s @ (?t @ ?u) << _ => incl_trans ((s @ t) @ u); try apply comp_assoc'
    | |- _ << (?s @ ?t) @ ?u => incl_trans (s @ (t @ u)); try apply comp_assoc'
    | |- _ << ?s @ (?t @ ?u) => incl_trans ((s @ t) @ u); try apply comp_assoc
  end.

Lemma absorbs_left_rtc A (R S : rel A) : R @ S << S -> R# @ S << S.

Proof.
  intro. unfold incl, compose. intros. do 2 destruct H0.
  gen H1. clear H1. elim H0; intros; auto. apply H. exists y0. auto.
Qed.

Lemma absorbs_right_rtc A (R S : rel A) : S @ R << S -> S @ R# << S.

Proof. intros h t v [u [tu uv]]. induction uv; fo. Qed.

(***********************************************************************)
(** Properties of [union]. *)

Global Instance union_incl A : Proper (incl ==> incl ==> incl) (@union A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Ltac union := apply union_incl; try incl_refl.

Global Instance union_same A : Proper (same ==> same ==> same) (@union A).

Proof. fo. Qed.

Lemma union_commut A (R S : rel A) : R U S == S U R.

Proof. fo. Qed.

Lemma union_assoc A (R S T : rel A) : (R U S) U T == R U (S U T).

Proof. fo. Qed.

Lemma comp_union_l A (R S T : rel A) : (R U S) @ T == (R @ T) U (S @ T).

Proof. fo. Qed.

Lemma comp_union_r A (R S T : rel A) : T @ (R U S) == (T @ R) U (T @ S).

Proof. fo. Qed.

Lemma union_empty_r A (R : rel A) : R U empty_rel == R.

Proof. fo. Qed.

Lemma union_empty_l A (R : rel A) : empty_rel U R == R.

Proof. fo. Qed.

Lemma incl_union_l A (R S T : rel A) : R << S -> R << S U T.

Proof. fo. Qed.

Lemma incl_union_r A (R S T : rel A) : R << T -> R << S U T.

Proof. fo. Qed.

Lemma union_incl_eq A (R R' S : rel A) : R U R' << S <-> R << S /\ R' << S.

Proof. fo. Qed.

(***********************************************************************)
(** Reflexive closure. *)

Definition clos_refl A (R : rel A) : rel A := eq U R.

Notation "x %" := (clos_refl x) (at level 35) : relation_scope.

Global Instance rc_incl A : Proper (incl ==> incl) (@clos_refl A).

Proof. fo. Qed.

Global Instance rc_same A : Proper (same ==> same) (@clos_refl A).

Proof. fo. Qed.

Global Instance rc_refl A (R : rel A) : Reflexive (R%).

Proof. fo. Qed.

Global Instance rc_trans A (R : rel A) : Transitive R -> Transitive (R%).

Proof.
  intro. unfold Transitive, clos_refl, union. intros. decomp H0. subst y. hyp.
  decomp H1. subst z. auto. right. apply H with (y := y); hyp.
Qed.

Lemma incl_rc A (R : rel A) : R << R%.

Proof. fo. Qed.

(***********************************************************************)
(** Compatibility closure. *)

Section comp_clos.

  Variables (A : Type) (E : rel A) (E_eq : Equivalence E).

  Inductive comp_clos (R : rel A) : rel A :=
  | comp_clos_intro u u' v v' : E u u' -> E v v' -> R u' v' -> comp_clos R u v.

  Lemma comp_clos_intro_refl (R : rel A) t u : R t u -> comp_clos R t u.

  Proof. intro tu. eapply comp_clos_intro. refl. refl. hyp. Qed.

  Lemma comp_clos_eq R : same (comp_clos R) (E @ (R @ E)).

  Proof.
    split.
    intros t u tu. inversion_clear tu; subst. ex u'. intuition. ex v'. intuition.
    intros t u [t' [tt' [u' [t'u' u'u]]]]. eapply comp_clos_intro.
    apply tt'. sym. apply u'u. hyp.
  Qed.

  Lemma incl_comp_clos R : R << comp_clos R.

  Proof.
    intros u v uv. apply comp_clos_intro with (u':=u) (v':=v).
    refl. refl. hyp.
  Qed.

  Global Instance comp_clos_incl : Proper (incl ==> incl) comp_clos.

  Proof.
    intros R S RS u v uv. inversion uv; subst.
    apply comp_clos_intro with (u':=u') (v':=v'); fo.
  Qed.

  Global Instance comp_clos_same : Proper (same ==> same) comp_clos.

  Proof. intros R S [RS SR]. split. rewrite RS. refl. rewrite SR. refl. Qed.

  Lemma comp_clos_union R S :
    same (comp_clos (R U S)) (comp_clos R U comp_clos S).

  Proof.
    split.
    (* << *)
    induction 1.
    destruct H1 as [h|h]; [left|right];
      (eapply comp_clos_intro; [apply H | apply H0 | hyp]).
    (* >> *)
    intros t u [h|h].
    eapply comp_clos_incl. apply incl_union_l. refl. hyp.
    eapply comp_clos_incl. apply incl_union_r. refl. hyp.
  Qed.

  Global Instance comp_clos_prop R : Proper (E ==> E ==> impl) (comp_clos R).

  Proof.
    intros u u' uu' v v' vv' h. inversion h; subst.
    eapply comp_clos_intro.
    trans u. hyp. apply H.
    trans v. hyp. apply H0.
    hyp.
  Qed.

End comp_clos.

(***********************************************************************)
(** Properties of [clos_trans]. *)

Global Instance tc_trans A (R : rel A) : Transitive (R!).

Proof. unfold Transitive. intros. apply t_trans with y; hyp. Qed.

Global Instance tc_incl A : Proper (incl ==> incl) (@clos_trans A).

Proof.
  intros R R' H t u H0. elim H0; intros.
  apply t_step. apply H. hyp. trans y; hyp.
Qed.

Global Instance tc_same A : Proper (same ==> same) (@clos_trans A).

Proof. intros R S [RS SR]. split; apply tc_incl; hyp. Qed.

Lemma incl_tc A (R S : rel A) : R << S -> R << S!.

Proof. firstorder with sets. Qed.

Lemma trans_tc_incl A (R : rel A) : Transitive R -> R! << R.

Proof.
  unfold transitive, incl. intros. induction H0. hyp.
  apply H with y; hyp.
Qed.

Lemma trans_comp_incl A (R : rel A) : Transitive R -> R @ R << R.

Proof. fo. Qed.

Lemma absorbs_left_tc A (R S : rel A) : R @ S << S -> R! @ S << S.

Proof.
  intro. unfold incl, compose. intros. do 2 destruct H0.
  gen H1. clear H1. elim H0; intros; auto. apply H. exists y0. auto.
Qed.

Lemma tc_absorbs_left A (R S : rel A) : R @ S << S -> R @ S! << S!.

Proof.
  intro. unfold incl. intros. do 2 destruct H0. generalize x0 y H1 H0.
  induction 1; intros. apply t_step. apply H. exists x1; split; hyp.
  trans y0; auto.
Qed.

Lemma trans_intro A (R : rel A) : R @ R << R <-> Transitive R.

Proof.
  split. unfold Transitive. intros. apply H. exists y. intuition.
  intros h x z [y [xy yz]]. apply (h _ _ _ xy yz).
Qed.

Lemma comp_tc_idem A (R : rel A) : R! @ R! << R!.

Proof.
  unfold incl. intros. do 2 destruct H. trans x0; hyp.
Qed.

Lemma tc_min A (R S : rel A) : R << S -> Transitive S -> R! << S.

Proof.
  intros RS Strans. intros x y. induction 1. apply RS. hyp. trans y; hyp.
Qed.

Lemma trans_tc A (R : rel A) : Transitive R -> R! == R.

Proof. intro t. split. apply tc_min. refl. hyp. apply incl_tc. refl. Qed.

Lemma tc_idem A (R : rel A) : R!! == R!.

Proof.
  split. intros x y. induction 1. hyp. trans y; hyp.
  apply incl_tc. refl.
Qed.

Lemma tc_eq A (R S : rel A) : S << R -> R << S! -> R! == S!.

Proof.
  intros SR RSt. split; apply tc_min. hyp. apply tc_trans.
  trans R. hyp. apply incl_tc. refl. apply tc_trans.
Qed.

Lemma tc_incl_trans A (R S : rel A) : Transitive S -> R << S -> R! << S.

Proof. intros S_trans RS. intros t u tu; revert t u tu. induction 1; fo. Qed.

Global Instance tc_prop A (E R : rel A) : Reflexive E ->
  Proper (E ==> E ==> impl) R -> Proper (E ==> E ==> impl) (R!).

Proof.
  intros E_refl RE x x' xx' y y' yy' xy. revert x y xy x' xx' y' yy'.
  induction 1; intros x' xx' y' yy'.
  apply t_step. eapply RE. apply xx'. apply yy'. hyp.
  trans y. apply IHxy1. hyp. refl. apply IHxy2. refl. hyp.
Qed.

Lemma tc_prop_iff A (R E : rel A) : Equivalence E
  -> Proper (E ==> E ==> iff) R -> Proper (E ==> E ==> iff) (clos_trans R).

Proof.
  intros E_eq R_prop. apply prop_rel_sym; class. apply tc_prop; class.
  intros x x' xx' y y' yy' xy. rewrite <- xx', <- yy'. hyp.
Qed.

Lemma tc_step_l A (R : rel A) x y :
  R! x y -> R x y \/ (exists2 z, R x z & R! z y).

Proof.
  compute; intro xy; induction xy.
  left; trivial.
  inversion IHxy1; inversion IHxy2; right; solve [eauto |
    inversion H; try inversion H0; exists x0;
    [trivial | constructor 2 with y; auto]].
Qed.

Lemma tc_step_r A (R : rel A) x y :
  R! x y -> R x y \/ (exists2 z, R! x z & R z y).

Proof.
  compute; intro xy; induction xy.
  left; trivial.
  inversion_clear IHxy1; inversion_clear IHxy2; right;
    solve [eauto | inversion H0; exists x0;
    [constructor 2 with y; auto | trivial]].
Qed.

Lemma tc_transp A (R : rel A) : transp (R!) == (transp R)!.

Proof.
  intros; split; compute.
  induction 1.
  constructor; trivial.
  constructor 2 with y; auto.
  induction 1.
  constructor; trivial.
  constructor 2 with y; auto.
Qed.

(***********************************************************************)
(** Symmetric closure of a relation. *)

Section clos_sym.

  Variable (A : Type) (R : rel A).

  Inductive clos_sym : rel A :=
  | s_step : forall x y, R x y -> clos_sym x y
  | s_sym : forall x y, clos_sym y x -> clos_sym x y.

  Global Instance sc_sym : Symmetric clos_sym.

  Proof. intros x y xy. apply s_sym. hyp. Qed.

End clos_sym.

(***********************************************************************)
(** Reflexive, transitive and symmetric closure of a relation. *)

Section clos_equiv.

  Variable (A : Type) (R : rel A).

  Inductive clos_equiv : rel A :=
  | e_step : forall x y, R x y -> clos_equiv x y
  | e_refl : forall x, clos_equiv x x
  | e_trans : forall x y z, clos_equiv x y -> clos_equiv y z -> clos_equiv x z
  | e_sym : forall x y, clos_equiv x y -> clos_equiv y x.

  Global Instance ec_equiv : Equivalence clos_equiv.

  Proof. exact (Build_Equivalence _ e_refl e_sym e_trans). Qed.

End clos_equiv.

Global Instance ec_incl A : Proper (incl ==> incl) (@clos_equiv A).

Proof.
  intros R S RS x y; revert x y; induction 1.
  apply e_step. fo. refl. trans y; fo. sym. fo.
Qed.

Lemma ec_min A (R S : rel A) : Equivalence S -> R << S -> clos_equiv R << S.

Proof.
  intros S_eq RS. intros u v; revert u v; induction 1.
  fo. refl. trans y; hyp. hyp.
Qed.

(***********************************************************************)
(** Properties of [clos_refl_trans]. *)

Global Instance rtc_refl A (R : rel A) : Reflexive (R#).

Proof. firstorder with sets. Qed.

Global Instance rtc_trans A (R : rel A) : Transitive (R#).

Proof. unfold Transitive. intros. eapply rt_trans. apply H. hyp. Qed.

Global Instance rtc_incl A : Proper (incl ==> incl) (@clos_refl_trans A).

Proof.
  intro. unfold incl. intros. elim H0; intros.
  apply rt_step. apply H. hyp. refl. trans y1; hyp.
Qed.

Global Instance rtc_same A : Proper (same ==> same) (@clos_refl_trans A).

Proof. intros R S [RS SR]. split; apply rtc_incl; hyp. Qed.

Lemma incl_rtc A (R : rel A) : R << R#.

Proof. firstorder with sets. Qed.

Lemma tc_incl_rtc A (R : rel A) : R! << R#.

Proof. induction 1. apply rt_step. hyp. trans y; hyp. Qed.

Lemma tc_split A (R : rel A) : R! << R @ R#.

Proof.
  unfold incl. induction 1. exists y. split. hyp. refl.
  destruct IHclos_trans1. destruct H1. exists x0. split. hyp.
  trans y. hyp. apply incl_elim with (R:=R!). apply tc_incl_rtc. hyp.
Qed.

Lemma rc_incl_rtc A (R : rel A) : R% << R#.

Proof.
  unfold incl, clos_refl. intros. destruct H.
  subst y. refl. apply rt_step. exact H.
Qed.

Lemma rtc_split A (R : rel A) : R# << eq U R!.

Proof.
  unfold incl, union. intros. elim H.
  intros. right. apply t_step. hyp.
  intro. left. refl.
  intros. destruct H1; destruct H3.
  left. trans y0; hyp.
  subst y0. right. hyp.
  subst y0. right. hyp.
  right. trans y0; hyp.
Qed.

Lemma rtc_split_eq A (R : rel A) : R# == eq U R!.

Proof.
  split. apply rtc_split. rewrite union_incl_eq. split.
  intros x y h. subst. refl. apply tc_incl_rtc.
Qed.

Lemma rtc_split2 A (R : rel A) : R# << eq U R @ R#.

Proof.
  unfold incl, union. intros. elim H; clear H x y; intros.
  right. exists y; split. exact H. refl. auto. destruct H0.
  subst y. destruct H2. auto. destruct H0. right. exists x0. auto.
  do 2 destruct H0. right. exists x0. split. exact H0.
  trans y; auto.
Qed.

Lemma tc_split_inv A (R : rel A) : R# @ R << R!.

Proof.
  intros x y RRxy. destruct RRxy as [z [Rxz Rzy]].
  destruct (rtc_split Rxz).
  rewrite H. intuition.
  constructor 2 with z. hyp.
  constructor 1. hyp.
Qed.

Lemma tc_merge A (R : rel A) : R @ R# << R!.

Proof.
  unfold incl. intros. destruct H. destruct H.
  ded (rtc_split H0). destruct H1; subst.
  apply t_step; hyp. trans x0. apply t_step. hyp. hyp.
Qed.

Lemma rtc_transp A (R : rel A) : transp (R#) << (transp R)#.

Proof.
  unfold incl. induction 1. apply rt_step. hyp. refl. trans y; hyp.
Qed.

Lemma incl_rtc_rtc A (R S : rel A) : R << S# -> R# << S#.

Proof. unfold incl. induction 2. apply H. hyp. refl. trans y; hyp. Qed.

Lemma comp_rtc_idem A (R : rel A) : R# @ R# << R#.

Proof. unfold incl. intros. do 2 destruct H. trans x0; hyp. Qed.

Lemma trans_rtc_incl A (R : rel A) : Reflexive R -> Transitive R -> R# << R.

Proof. intros R_refl R_trans x y. induction 1. hyp. refl. trans y; hyp. Qed.

Lemma rtc_invol A (R : rel A) : R # # == R #.

Proof.
  split. intros x y. induction 1. hyp. refl. trans y; hyp. apply incl_rtc.
Qed.

Lemma rtc_intro_seq A (R : rel A) f i : forall j, i <= j ->
  (forall k, i <= k < j -> R (f k) (f (1+k))) -> R# (f i) (f j).

Proof.
  cut (forall n, (forall k, i <= k < i + n -> R (f k) (f (1+k))) ->
    R# (f i) (f (n+i))).
  intros h j ij hij. assert (j = (j-i) + i). lia.
  rewrite H. apply h.
  intros k hk. apply hij. lia.
  induction n; intro h. refl. trans (f (n+i)).
  apply IHn. intros k hk. apply h. lia.
  apply rt_step. apply h. lia.
Qed.

Lemma rtc_min A (R S : rel A) : PreOrder S -> R << S -> R# << S.

Proof.
  intros S_PO RS. intros u v; revert u v; induction 1.
  fo. refl. trans y; hyp.
Qed.

Global Instance rtc_sym A (R : rel A) : Symmetric R -> Symmetric (R#).

Proof.
  intros R_sym x; revert x; induction 1.
  apply rt_step. hyp. refl. trans y; hyp.
Qed.

(***********************************************************************)
(** Quasi-ordering closure. *)

Section qo_clos.

  Variables (A : Type) (E : rel A) (E_eq : Equivalence E).

  Inductive qo_clos (R : rel A) : rel A :=
  | qo_step : R << qo_clos R
  | qo_refl : E << qo_clos R
  | qo_trans : Transitive (qo_clos R).

  Variable R : rel A.

  Global Instance qo_clos_preorder : PreOrder (qo_clos R).

  Proof. split. intro x. apply qo_refl. refl. apply qo_trans. Qed.

  Variable R_prop : Proper (E ==> E ==> impl) R.

  Global Instance qo_clos_prop : Proper (E ==> E ==> impl) (qo_clos R).

  Proof.
    intros x x' xx' y y' yy' h. revert x y h x' xx' y' yy'.
    induction 1; intros x' xx' y' yy'.
    apply qo_step. rewrite <- xx', <- yy'. hyp.
    apply qo_refl. rewrite <- xx', <- yy'. hyp.
    trans y. apply IHh1. hyp. refl. apply IHh2. refl. hyp.
  Qed.

  (*COQ: if removed, Coq fails in LComp*)
  Global Instance qo_clos_prop_iff : Proper (E ==> E ==> iff) (qo_clos R).

  Proof. apply prop_rel_sym; class. Qed.

  Lemma qo_clos_inv : forall t u,
      qo_clos R t u -> E t u \/ exists v, R t v /\ qo_clos R v u.

  Proof.
    induction 1.
    right. ex y. intuition. auto.
    destruct IHqo_clos1 as [h1|[a [i1 i2]]];
      destruct IHqo_clos2 as [h2|[b [j1 j2]]].
    left. trans y; hyp.
    right. ex b. rewrite h1. auto.
    right. ex a. rewrite <- h2. auto.
    right. ex a. intuition. trans b. trans y. hyp. apply qo_step. hyp. hyp.
  Qed.

End qo_clos.

(***********************************************************************)
(** Properties of [transp]. *)

Global Instance transp_incl A : Proper (incl ==> incl) (@transp A).

Proof. fo. Qed.

Global Instance transp_same A : Proper (same ==> same) (@transp A).

Proof. fo. Qed.

(*COQ: declaring these lemmas as Global Instance makes Coq loop
  later in some other files *)

Lemma transp_refl A (R : rel A) : Reflexive R -> Reflexive (transp R).

Proof. auto. Qed.

Lemma transp_trans A (R : rel A) : Transitive R -> Transitive (transp R).

Proof. fo. Qed.

Lemma transp_sym A (R : rel A) : Symmetric R -> Symmetric (transp R).

Proof. fo. Qed.

Lemma transp_invol A (R : rel A) : transp (transp R) == R.

Proof. fo. Qed.

Lemma transp_union A (R S : rel A) : transp (R U S) == transp R U transp S.

Proof. fo. Qed.

(***********************************************************************)
(** Relations between closures, union and composition. *)

Lemma rtc_comp_permut A (R S : rel A) : R# @ (R# @ S)# << (R# @ S)# @ R#.

Proof.
  unfold incl. intros. do 2 destruct H. ded (rtc_split2 H0). destruct H1.
  subst x0. exists x; split. refl. exact H.
  do 4 destruct H1. exists y; split. trans x1.
  apply rt_step. exists x2; split. trans x0; hyp.
  hyp. hyp. refl.
Qed.

Lemma rtc_union A (R S : rel A) : (R U S)# << (R# @ S)# @ R#.

Proof.
  unfold incl. intros. elim H; intros.
  (* step *)
  destruct H0. exists x0; split. refl. apply rt_step. exact H0.
  exists y0; split. apply rt_step. exists x0; split. refl. exact H0.
  refl.
  (* refl *)
  exists x0; split; refl.
  (* trans *)
  do 2 destruct H1. do 2 destruct H3.
  assert (h : ((R# @ S)# @ clos_refl_trans R) x1 x2).
  apply incl_elim with (R := (R# @ clos_refl_trans (R# @ S))).
  apply rtc_comp_permut. exists y0; split; hyp.
  destruct h. destruct H6. exists x3; split.
  trans x1; hyp. trans x2; hyp.
Qed.

Lemma rtc_comp A (R S : rel A) : R# @ S << S U R! @ S.

Proof.
  unfold incl. intros. do 2 destruct H. ded (rtc_split H). destruct H1.
  subst x0. left. exact H0. right. exists x0; split; hyp.
Qed.

Lemma union_fact A (R S : rel A) : R U R @ S << R @ S%.

Proof.
  unfold incl. intros. destruct H.
  exists y; split; unfold clos_refl, union; auto.
  do 2 destruct H. exists x0; split; unfold clos_refl, union; auto.
Qed.

Lemma union_fact2 A (R S : rel A) : R @ S U R << R @ S%.

Proof. incl_trans (R U R @ S). apply union_commut. apply union_fact. Qed.

Lemma incl_rc_rtc A (R S : rel A) : R << S! -> R% << S#.

Proof.
  intro. unfold incl. intros. destruct H0. subst y. refl.
  apply incl_elim with (R := S!). apply tc_incl_rtc. apply H. exact H0.
Qed.

Lemma incl_tc_rtc A (R S : rel A) : R << S# -> R! << S#.

Proof. intro. unfold incl. induction 1. apply H. hyp. trans y; hyp. Qed.

Lemma rtc_comp_modulo A (R S : rel A) : R# @ (R# @ S)! << (R# @ S)!.

Proof.
  unfold incl. intros. do 2 destruct H.
  ded (tc_split H0). do 2 destruct H1. do 2 destruct H1.
  ded (rtc_split H2). destruct H4. subst x1.
  apply t_step. exists x2. intuition. trans x0; hyp.
  trans x1. apply t_step. exists x2. intuition.
  trans x0; hyp. exact H4.
Qed.

Lemma tc_union A (R S : rel A) : (R U S)! << R! U (R# @ S)! @ R#.

Proof.
  unfold incl. induction 1. destruct H. left. apply t_step. exact H.
  right. exists y. intuition. apply t_step. exists x. intuition.
  destruct IHclos_trans1. destruct IHclos_trans2.
  left. trans y; hyp.
  right. do 2 destruct H2. exists x0. intuition.
  apply rtc_comp_modulo. exists y. intuition. apply tc_incl_rtc. exact H1.
  right. do 2 destruct H1. destruct IHclos_trans2. exists x0.
  intuition. trans y. exact H2. apply tc_incl_rtc. exact H3.
  do 2 destruct H3. exists x1. intuition. trans x0. exact H1.
  apply rtc_comp_modulo. exists y. intuition.
Qed.

(***********************************************************************)
(** Commutation properties. *)

Section commut.

  Variables (A : Type) (R S : rel A) (commut : R @ S << S @ R).

  Lemma commut_rtc : R# @ S << S @ R#.

  Proof.
    unfold incl. intros. do 2 destruct H. generalize x x0 H y H0.
    clear H0 y H x0 x. induction 1; intros.
    assert ((S @ R) x y0). apply commut. exists y. intuition.
    do 2 destruct H1. exists x0. intuition.
    exists y. intuition.
    ded (IHclos_refl_trans2 _ H1). do 2 destruct H2.
    ded (IHclos_refl_trans1 _ H2). do 2 destruct H4.
    exists x1. intuition. trans x0; hyp.
  Qed.

  Lemma commut_rtc_inv : R @ S# << S# @ R.

  Proof.
    unfold incl. intros. do 2 destruct H. generalize x0 y H0 x H.
    clear H x x0 H0 y. induction 1; intros.
    assert ((S @ R) x0 y). apply commut. exists x. intuition.
    do 2 destruct H1. exists x1. intuition.
    exists x0. intuition.
    ded (IHclos_refl_trans1 _ H). do 2 destruct H0.
    ded (IHclos_refl_trans2 _ H1). do 2 destruct H2.
    exists x2. intuition. apply rtc_trans with x1; hyp.
  Qed.

  Lemma commut_tc : R! @ S << S @ R!.

  Proof.
    intros x y H. destruct H as [z Hxy].
    destruct (tc_split (proj1 Hxy)) as [z' Hz'].
    assert (SE : (S @ R#) z' y). apply commut_rtc. exists z. intuition.
    destruct SE as [x' Rx'].
    assert (SRx : (S @ R) x x'). apply commut. exists z'. intuition.
    destruct SRx as [y' Sy']. exists y'. split. intuition.
    apply tc_merge. exists x'. intuition.
  Qed.

  Lemma commut_tc_inv : R @ S! << S! @ R.

  Proof.
    intros x y H. destruct H as [z Hxy].
    destruct (tc_split (proj2 Hxy)) as [z' Hz'].
    assert (SRx : (S @ R) x z'). apply commut. exists z. intuition.
    destruct SRx as [y' Sy'].
    assert (SE : (S# @ R) y' y). apply commut_rtc_inv. exists z'. intuition.
    destruct SE as [x' Sx']. exists x'. split; try intuition.
    apply tc_merge. exists y'. intuition.
  Qed.

  Lemma commut_comp T : R @ (S @ T) << (S @ R) @ T.

  Proof. rewrite comp_assoc', commut. refl. Qed.

  Lemma comp_incl_assoc T V : R @ S << T -> R @ (S @ V) << T @ V.

  Proof. intro h. rewrite comp_assoc', h. refl. Qed.

End commut.

(***********************************************************************)
(** Inverse image. *)

Section inverse_image.

  Variables (A B : Type) (R : rel B) (f : A->B).

  Definition Rof : rel A := fun a a' => R (f a) (f a').

  (*COQ: declaring these lemmas as Global Instance makes Coq loop
  later in some other files *)

  Lemma Rof_refl : Reflexive R -> Reflexive Rof.

  Proof. fo. Qed.

  Lemma Rof_trans : Transitive R -> Transitive Rof.

  Proof. fo. Qed.

  Lemma Rof_sym : Symmetric R -> Symmetric Rof.

  Proof. fo. Qed.

  Lemma Rof_preorder : PreOrder R -> PreOrder Rof.

  Proof. fo. Qed.

  Lemma Rof_equiv : Equivalence R -> Equivalence Rof.

  Proof. fo. Qed.

  Variable F : A -> B -> Prop.

  Definition RoF : rel A :=
    fun a a' => exists b', F a' b' /\ forall b, F a b -> R b b'.

End inverse_image.

Global Instance Rof_incl A B : Proper (incl ==> Logic.eq ==> incl) (@Rof A B).

Proof. intros R S RS f g fg. subst g. fo. Qed.

(***********************************************************************)
(** Alternative definition of the transitive closure, more convenient
for some inductive proofs. *)

Inductive clos_trans1 A (R : rel A) : rel A :=
| t1_step : forall x y, R x y -> clos_trans1 R x y
| t1_trans : forall x y z, R x y -> clos_trans1 R y z -> clos_trans1 R x z.

Notation "x !1" := (clos_trans1 x) (at level 35) : relation_scope.

Global Instance tc1_trans A (R : rel A) : Transitive (R!1).

Proof.
  induction 1; intro H1.
  exact (t1_trans x H H1).
  exact (t1_trans x H (IHclos_trans1 H1)).
Qed.

Lemma tc1_eq A (R : rel A) x y : R!1 x y <-> R! x y.

Proof.
  split; induction 1.
  apply t_step. hyp. trans y. apply t_step. hyp. hyp.
  apply t1_step. hyp. trans y; hyp.
Qed.

(***********************************************************************)
(** Alternative definition of the reflexive and transitive closure,
more convenient for some inductive proofs. *)

Inductive clos_refl_trans1 A (R : rel A) : rel A :=
| rt1_refl : forall x, clos_refl_trans1 R x x
| rt1_trans : forall x y z,
  R x y -> clos_refl_trans1 R y z -> clos_refl_trans1 R x z.

Notation "x #1" := (clos_refl_trans1 x) (at level 9) : relation_scope.

Global Instance rtc1_preorder A (R : rel A) : PreOrder (R#1).

Proof.
  split; intro x. apply rt1_refl.
  induction 1; intro H1. hyp.
  exact (rt1_trans x H (IHclos_refl_trans1 H1)).
Qed.

Lemma rtc1_eq A (R : rel A) x y : R#1 x y <-> R# x y.

Proof.
  split; induction 1.
  refl. trans y. apply rt_step. hyp. hyp.
  eapply rt1_trans. apply H. refl. refl. trans y; hyp.
Qed.

Lemma tc1_incl_rtc1 A (R : rel A) : R!1 << R#1.

Proof.
  induction 1.
  eapply rt1_trans. apply H. refl.
  eapply rt1_trans. apply H. hyp.
Qed.

Lemma rtc1_union A (R S : rel A) : (R U S)#1 << (S#1 @ R)#1 @ S#1.

Proof.
  intros x y xRSy. induction xRSy as [ | x y z xRSy yRSz].
  exists x. split; refl.
  destruct IHyRSz as [m [ym mz]].
  destruct ym as [m | m n o mn no].
  induction xRSy as [xRy | xSy].
  exists m. split; trivial. apply rt1_trans with m.
  exists x. split; trivial. refl. refl.
  exists x. split. refl. apply rt1_trans with m; trivial.
  exists o. split; trivial.
  induction xRSy as [xRy | xSy].
  apply rt1_trans with m.
  exists x. split. refl. hyp.
  apply rtc1_preorder with n; trivial.
  apply rt1_trans with n; trivial. refl.
  apply rt1_trans with n.
  destruct mn as [q [mq qn]]. exists q. split; trivial.
  apply rt1_trans with m; hyp. hyp.
Qed.

Lemma union_rel_rt1_left A (R S : rel A) : R#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rt1_trans with y. left. hyp. hyp.
Qed.

Lemma union_rel_rt1_right A (R S : rel A) : S#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rt1_trans with y. right. hyp. hyp.
Qed.

Lemma incl_rt1_union_union A (R S : rel A) : (R!1 U S!1)#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rtc1_preorder with y; trivial.
  destruct H.
  apply union_rel_rt1_left. apply tc1_incl_rtc1. hyp.
  apply union_rel_rt1_right. apply tc1_incl_rtc1. hyp.
Qed.

Lemma incl_union_rt1_union A (R S : rel A) : (R U S)#1 << (R!1 U S!1)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rtc1_preorder with y; trivial.
  destruct H.
  apply union_rel_rt1_left. apply rt1_trans with y.
  apply t1_step. hyp. refl.
  apply union_rel_rt1_right. apply rt1_trans with y.
  apply t1_step. hyp. refl.
Qed.

Lemma comm_s_rt1 A (R S : rel A) :
  S@(R!1) << (R!1)@(S!1) -> (S!1)@(R!1) << (R!1)@(S!1).

Proof.
  intros comm x y [z [H1 H2]].
  induction H1 as [x z H | x y' z H H0 IH].
  apply comm.
  exists z; split; hyp.
  assert (H1 := IH H2); clear IH H2.
  destruct H1 as [u [H2 H3]].
  assert ((R!1 @ S!1) x u).
  apply comm. exists y'; split; hyp.
  destruct H1 as [m [xRm mSu]].
  exists m; split. hyp.
  exact (tc1_trans mSu H3).
Qed.

Lemma comm_s_r A (R S : rel A) :
  S@R << (R!1)@(S#1) -> (R U S)#1 @ R @ (R U S)#1 << (R!1) @ (R U S)#1.

Proof.
  intros comm x y [z2 [[z1 [xRSz1 z1Rz2]] z2RSy]].
  induction xRSz1 as [ | m n z1 mRSn nRSz1 IH].
  exists z2. split. apply t1_step. hyp. hyp.
  (* m RUS n RUS# z1 R z2 RUS# y *)
  assert (((R!1) @ (R U S)#1) n y) as mRedy. apply IH. hyp.
  (* m RUS n R!1@RUS#1 y *)
  clear nRSz1 z1Rz2 z2RSy IH z1 z2.
  destruct mRedy as [o [nRo oRSy]].
  (* m RUS n R!1 o RUS#1 y *)
  induction mRSn.
  (* m R n *)
  exists o. split; auto. apply t1_trans with n; hyp.
  (* m S n *)
  destruct nRo as [o p oRp | o p q oRp pRq ];

  assert (((R!1)@(S#1)) m p) as mRedp. apply comm; exists o; split; hyp.
  destruct mRedp as [x [mRx xSp]].
  exists x. split. hyp.
  apply rtc1_preorder with p.
  apply union_rel_rt1_right. hyp. hyp.

  assert (((R!1)@(S#1)) m p) as mRedp. apply comm; exists o; split; hyp.
  destruct mRedp as [x [mRx xSp]].
  exists x. split. hyp. hyp.
  destruct mRedp as [n [mRn sSp]].
  exists n; split. hyp.
  apply rtc1_preorder with q.
  apply rtc1_preorder with p.
  apply union_rel_rt1_right. hyp.
  apply union_rel_rt1_left. apply tc1_incl_rtc1. hyp.
  hyp.
Qed.

(***********************************************************************)
(** Extension to [option A] of a relation on [A] so that it is
reflexive on [None]. *)

Section opt_r.

  Variables (A : Type) (R : rel A).

  Inductive opt_r : rel (option A) :=
  | opt_r_None : opt_r None None
  | opt_r_Some : forall a b, R a b -> opt_r (Some a) (Some b).

  Global Instance opt_r_refl : Reflexive R -> Reflexive opt_r.

  Proof. intros h [x|]. apply opt_r_Some. refl. apply opt_r_None. Qed.

  Global Instance opt_r_sym : Symmetric R -> Symmetric opt_r.

  Proof.
    intros h x y xy. inversion xy; subst. hyp. apply opt_r_Some. sym. hyp.
  Qed.

  Global Instance opt_r_trans : Transitive R -> Transitive opt_r.

  Proof.
    intros h x y z xy yz. inversion xy; inversion yz; subst; try discr.
    apply opt_r_None. inversion H3; subst. apply opt_r_Some. trans b; hyp.
  Qed.

  Global Instance Some_prop : Proper (R ==> opt_r) (@Some A).

  Proof. intros x y xy. apply opt_r_Some. hyp. Qed.

End opt_r.

(****************************************************************************)
(** Extension of a relation on [A] to [option A] so that it is
irreflexive on [None]. *)

Section opt.

  Variables (A : Type) (R : rel A).

  Inductive opt : rel (option A) :=
  | opt_intro : forall x y, R x y -> opt (Some x) (Some y).

  Global Instance opt_trans : Transitive R -> Transitive opt.

  Proof.
    intros R_trans x y z xy yz. inversion xy; inversion yz; clear xy yz; subst.
    inversion H3; clear H3; subst. apply opt_intro. trans y0; hyp.
  Qed.

  Global Instance opt_sym : Symmetric R -> Symmetric opt.

  Proof.
    intros R_sym x y xy. inversion xy; clear xy; subst. apply opt_intro. hyp.
  Qed.

  Global Instance opt_opt_r E : Proper (E ==> E ==> impl) R ->
    Proper (opt_r E ==> opt_r E ==> impl) opt.

  Proof.
    intros R_E x x' xx' y y' yy' xy.
    inversion xy; inversion xx'; inversion yy'; clear xy xx' yy'; subst;
      try discr. inversion H6; inversion H3; clear H6 H3; subst.
    apply opt_intro. eapply R_E. apply H2. apply H5. hyp.
  Qed.

  Lemma opt_absorbs_right_opt_r E : R @ E << R -> opt @ opt_r E << opt.

  Proof.
    intros RE x z [y [xy yz]].
    inversion xy; clear xy; subst. inversion yz; clear yz; subst.
    apply opt_intro. apply RE. exists y0. fo.
  Qed.

  Lemma opt_absorbs_left_opt_r E : E @ R << R -> opt_r E @ opt << opt.

  Proof.
    intros ER x z [y [xy yz]].
    inversion yz; clear yz; subst. inversion xy; clear xy; subst.
    apply opt_intro. apply ER. exists x0. fo.
  Qed.

End opt.

Global Instance opt_incl A : Proper (incl ==> incl) (@opt A).

Proof.
  intros R S RS x y xy. inversion xy; clear xy; subst. apply opt_intro. fo.
Qed.

Global Instance opt_prop A (E1 E2 R : rel A) :
  Proper (E1 ==> E2 ==> impl) R -> Proper (opt E1 ==> opt E2 ==> impl) (opt R).

Proof.
  intros h x x' xx' y y' yy' xy. inversion xx'; clear xx'; subst.
  inversion yy'; clear yy'; subst. inversion xy; clear xy; subst.
  apply opt_intro. eapply h. apply H. apply H0. hyp.
Qed.

Lemma opt_absorbs_right A (R E : rel A) :
  R @ E << R -> opt R @ opt E << opt R.

Proof.
  intros RE x z [y [xy yz]].
  inversion xy; clear xy; subst. inversion yz; clear yz; subst.
  apply opt_intro. apply RE. exists y0. fo.
Qed.

Lemma opt_absorbs_left A (R E : rel A) :
  E @ R << R -> opt E @ opt R << opt R.

Proof.
  intros ER x z [y [xy yz]].
  inversion yz; clear yz; subst. inversion xy; clear xy; subst.
  apply opt_intro. apply ER. exists x0. fo.
Qed.

(***********************************************************************)
(** Restriction of a relation to some set. *)

Section restrict.

  Variables (A : Type) (P : A -> Prop) (R : rel A).

  Definition restrict : rel A := fun x y => P x /\ R x y.

  Global Instance restrict_prop E :
    Proper (E ==> impl) P -> Proper (E ==> E ==> impl) R ->
    Proper (E ==> E ==> impl) restrict.

  Proof.
    intros PE RE x x' xx' y y' yy' [hxy xy]. split.
    rewrite <- xx'. hyp. eapply RE. apply xx'. apply yy'. hyp.
  Qed.

End restrict.

Lemma restrict_union A (P : A -> Prop) R S :
  restrict P (R U S) == restrict P R U restrict P S.

Proof. fo. Qed.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep pred prelude idynamic ordtype pcm finmap unionmap heap coding.
Require Import Hgraphs Logs.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*******************************************************************************)
(* Definitions of wavefronts and indexed log prefixes with a number of
   lemmas about them. *)
(*******************************************************************************)

Section Wavefronts.

(* Default log entry *)
Variable e0 : LogEntry.

Definition prefixes l :=
  map (fun n => (take n l, nth e0 l n)) (iota 0 (size l)).

(* Some properties of our selector function "prefixes". *)
Lemma take_nth_drop (n : nat) s:
  n < size s ->
  take n s ++ (nth e0 s n) :: drop n.+1 s = s.
Proof.
elim: s n => [|x s IHs] [|n]=>//=[_|]; first by rewrite drop0.
rewrite -[n.+1]addn1 -[(size s).+1]addn1 ltn_add2r=>/IHs=>H.
by rewrite addn1 -{4}H.
Qed.

(* Adequacy of prefixes *)

Lemma in_prefixes_full l e pr: (pr, e) \in prefixes l ->
  exists i, [/\ i < size l, nth e0 l i = e & pr = take i l].
Proof.
case/mapP=>n H; case=>Z2 Z3; subst e pr; exists n; split=>//.
by rewrite mem_iota add0n in H; case/andP: H.
Qed.

Lemma in_prefixes l e pr: (pr, e) \in prefixes l -> e \in l.
Proof.
case/in_prefixes_full=>n [H1]H2 H3.
have X: exists2 j, j < size l & nth e0 l j = e by exists n=>//.
by move/nthP: X.
Qed.

Lemma prefixes_in l e: e \in l ->
  exists i, (take i l, e) \in prefixes l.
Proof.
move=>D; case/(nthP e0): (D)=>j H1 H2; exists j.
apply/mapP; exists j; first by rewrite mem_iota add0n.
by rewrite H2.
Qed.

Lemma prefixes_num l n  :
  n < size l -> exists e, (take n l, e) \in prefixes l.
Proof.
move=>D; exists (nth e0 l n); apply/mapP; exists n=>//.
by rewrite mem_iota add0n.
Qed.

Lemma prefV l pr e :
  (pr, e) \in prefixes l -> exists n,
  [/\ pr = take n l,
      e = (nth e0 l n) &
      l = pr ++ e :: drop n.+1 l].
Proof.
move=>H; case: (in_prefixes_full H)=>n[G1] G2 G3.
exists n; rewrite G2; split=>//; rewrite G3.
by move: (take_nth_drop G1); rewrite G2=>->.
Qed.

Lemma prefix_rev l1 l2 l et e :
  e \in l2 -> l = l1 ++ et :: l2  ->
  exists i, (take i l, e) \in prefixes l /\ et \in take i l.
Proof.
case/splitP=>{l2}l2 l3.
rewrite -cat_cons -cats1 cat_cons -catA cat1s -cat_cons catA.
set i := size (l1 ++ et :: l2); move=>E; exists i.
have X1 : e \in l by rewrite E mem_cat inE eqxx orbC.
have X2: i < size l
  by rewrite/i E!size_cat -addnA ltn_add2l -{1}[size (_::l2)]addn0 ltn_add2l.
have Y: forall a, a - a = 0 by elim.
have X3: nth e0 l i = e by rewrite E nth_cat /i ltnn Y/=.
split; last by rewrite E take_size_cat /i// mem_cat inE eqxx orbC.
apply/mapP; exists i; last by rewrite X3.
by rewrite mem_iota add0n.
Qed.

(* A helper lemma abot prefixes *)

Lemma in_prefix_cons l e pre pi :
  (pre, pi) \in prefixes (e :: l) ->
  (pre, pi) = ([::], e) \/ exists l1, pre = e :: l1.
Proof.
case/mapP=>n H1 H2; rewrite /= inE in H1.
case/orP: H1=>[|H1]; [by move/eqP=>Z; subst n; left|right].
rewrite mem_iota in H1; case/andP: H1=>H G.
have S: exists m, n = m.+1 by clear G H2; case: n H=>//n _; exists n.
by case: S=>[m]Z; subst n; case: H2=>/=-> _; exists (take m l).
Qed.

(* More helper lemmas *)

Lemma seq_iota_add {A : Type } (f g : nat -> A) m n : (forall i, f (i + m) = g i) ->
  [seq f i | i <- iota m n] = [seq g i | i <- iota 0 n].
Proof.
move=>H.
elim: n=>//n Hi.
rewrite -![n.+1]addn1 !iota_add !map_cat; congr (_ ++ _)=>//={Hi}.
by rewrite add0n addnC H.
Qed.

Lemma seq_iota_inc {A : Type } (f g : nat -> A) n : (forall i, f i.+1 = g i) ->
  [seq f i | i <- iota 1 n] = [seq g i | i <- iota 0 n].
Proof. by move=>H; apply: seq_iota_add=>i; rewrite addn1. Qed.

Lemma prefix_cons e l  :
  prefixes (e :: l) =
  ([::], e) :: [seq (e :: pe.1, pe.2) | pe <- prefixes l].
Proof.
congr (_ :: _); rewrite /prefixes -seq.map_comp.
by apply: seq_iota_inc.
Qed.

Lemma prefix_catl l1 l2  :
  prefixes (l1 ++ l2) =
  prefixes l1 ++ [seq (l1 ++ pe.1, pe.2) | pe <- prefixes l2].
Proof.
rewrite /prefixes size_cat iota_add add0n map_cat; congr (_ ++ _).
- apply/eq_in_map=>i; rewrite mem_iota add0n=>/andP[]_ N.
  by rewrite take_cat nth_cat !N/=.
rewrite -seq.map_comp; apply: seq_iota_add=>i/=.
have X a : a - a = 0 by elim: a.
case: i=>[|i]; first by rewrite add0n take_cat nth_cat !ltnn !X.
have Y: i.+1 + size l1 < size l1 = false
     by rewrite -[i.+1]addn1 addnC -{2}[size l1]addn0 ltn_add2l.
by rewrite take_cat nth_cat !Y -!addnBA ?X ?addn0=>//.
Qed.

Lemma prefix_snd l : map snd (prefixes l) = l.
Proof.
rewrite /prefixes -seq.map_comp/=.
suff X: l = [seq nth e0 l i | i <- iota 0 (size l)]
        by rewrite {4}X; apply/eq_in_map=>i D/=.
elim: l=>//e l/= Hi; congr (_ :: _).
by rewrite {1}Hi; apply/sym; apply:(seq_iota_inc).
Qed.

Lemma count_comp {A B : eqType} (f : B -> bool) g (l : seq A) :
  count (f \o g) l = count f (map g l).
Proof. by rewrite count_map. Qed.

Lemma find_first {A: eqType} (l : seq A) f : has f l ->
  exists e l1 l2, [/\ l = l1 ++ e :: l2, f e & ~~ has f l1].
Proof.
elim:l=>//= e l Hi; case X : (f e)=>/=.
- by move=> _; exists e, [::], l; rewrite cat0s.
case/Hi=>e'[l1][l2][E1]H1 H2.
by exists e', (e:: l1), l2; rewrite E1/= X H2/= H1.
Qed.

(***************************************************************************)
(*                              Wavefronts                                 *)
(***************************************************************************)

(* Definition of a wavefront *)
Definition wavefront (l : log) :=
  [seq (source pi, fld pi) | pi <- l & kind pi == T].

Lemma prefix_wavefront l1 l2 l et e :
  e \in l2 -> l = l1 ++ et :: l2  -> kind et == T ->
  exists pre, (pre, e) \in prefixes l /\
              (source et, fld et) \in (wavefront pre).
Proof.
move=>H1 H2 T; case:(prefix_rev H1 H2)=>i[H3 H4].
exists (take i l); split=>//.
by apply/mapP; exists et=>//; rewrite mem_filter T.
Qed.

Lemma wavefront_trace l o : o \in wavefront l ->
   exists (e : LogEntry) (l1 l2 : seq LogEntry),
     [/\ l = l1 ++ e :: l2, kind e == T, source e = o.1 & fld e = o.2].
Proof.
case/mapP=>e; rewrite mem_filter=>/andP[H1].
by case/in_split=>l1[l2][E]->/=; exists e, l1, l2.
Qed.

Lemma wavefront_filterT et l f o g :
  kind et = T -> fld et = f ->  source et = o ->
  count (fun pe : log * LogEntry =>
      (g pe.2) && ((o, f) \in wavefront pe.1))
      [seq (et :: pe.1, pe.2) | pe <- prefixes l] =
  count (fun pe => g pe.2) (prefixes l).
Proof.
move=>H1 H2 H3; rewrite count_map; apply: eq_in_count=>/=pe H.
by rewrite andbC /wavefront /= H1 /= H2 H3/= inE eqxx.
Qed.

End Wavefronts.


(** * Binary tries wrapped in a sigma type to enforce extensionality *)

(* Author: Xavier Leroy, Collège de France and Inria.
   Copyright: Inria.
   License: BSD-3-Clause. *)

From Coq Require Import PArith Program.Equality.
From Tries Require Original.

Set Implicit Arguments.

Module PTree.

Import Original.PTree.

(** ** Representation of tries *)

(** We start with the two-constructor representation of binary tries
    from module [Original] and work out a well-formedness criterion
    that, in the end, suffices to ensures extensionality. *)

(** A trivially empty node is the subtree [Node Leaf None Leaf].
    It contains no values, and is extensionally equivalent to [Leaf],
    but structurally different.  Well-formed trees are those that
    contain no trivially empty nodes. *)

Definition not_trivially_empty {A} (l: tree A) (o: option A) (r: tree A) :=
  match l, o, r with
  | Leaf, None, Leaf => False
  | _, _, _ => True
  end.

Lemma not_trivially_empty_left: forall A (l: tree A) (o: option A) (r: tree A),
  l <> Leaf -> not_trivially_empty l o r.
Proof.
  intros; red. destruct l; auto. congruence.
Qed.

Lemma not_trivially_empty_val: forall A (l: tree A) (a: A) (r: tree A),
  not_trivially_empty l (Some a) r.
Proof.
  intros; red. destruct l; auto.
Qed.

Lemma not_trivially_empty_right: forall A (l: tree A) (o: option A) (r: tree A),
  r <> Leaf -> not_trivially_empty l o r.
Proof.
  intros; red. destruct l; auto. destruct o; auto. destruct r; auto.
Qed.

(** The [wf m] predicate states that the tree [m] is well formed,
    in the sense that all nodes it contains are not trivially empty. *)

Inductive wf {A} : tree A -> Prop :=
  | wf_leaf: wf Leaf
  | wf_node: forall l o r,
      wf l -> wf r -> not_trivially_empty l o r ->
      wf (Node l o r).

(** Our type [t A] of extensional tries is a sigma type:
    it consists of pairs of an original trie [m] and a proof of [wf m]. *)

Definition t (A: Type) := { m : tree A | wf m }.

(** ** Basic operations: [empty], [get], [set], [remove] *)

(** The operations over the sigma type [t A] are derived from those of the
    original implementation of binary tries, complemented with proofs
    of well-formedness. *)

Definition empty (A: Type) : t A :=
  exist _ (Original.PTree.empty A) wf_leaf.

Definition get (A: Type) (i: positive) (m: t A) : option A :=
  Original.PTree.get i (proj1_sig m).

(** We prove that well-formedness is preserved by the [set] operation:
    it cannot create a trivially empty node. *)

Lemma set_not_leaf: forall (A: Type) (v: A) i m, Original.PTree.set i v m <> Leaf.
Proof.
  destruct i, m; simpl; congruence.
Qed.

Lemma wf_set: forall (A: Type) (v: A) i m, wf m -> wf (Original.PTree.set i v m).
Proof.
  induction i; destruct 1; simpl;
  auto using wf_leaf, wf_node, not_trivially_empty_left, not_trivially_empty_right, not_trivially_empty_val, set_not_leaf.
Qed.

Definition set (A: Type) (i: positive) (v: A) (m: t A) : t A :=
  exist _ (Original.PTree.set i v (proj1_sig m))
          (wf_set v i (proj2_sig m)).

(** The [Node'] smart constructor never creates a trivially empty node
    either. *)

Lemma wf_Node': forall A (l: tree A) (o: option A) (r: tree A),
  wf l -> wf r -> wf (Node' l o r).
Proof.
  destruct l, o, r; intros; simpl; constructor; simpl; auto.
Qed.

(** It follows that the [remove] operation preserves well-formedness. *)

Lemma wf_remove:
  forall (A: Type) (m: tree A), wf m -> forall i, wf (Original.PTree.remove i m).
Proof.
  induction 1; intros; simpl.
- constructor.
- destruct i; auto using wf_Node'.
Qed.

Definition remove (A: Type) (i: positive) (m: t A) : t A :=
  exist _ (Original.PTree.remove i (proj1_sig m))
          (wf_remove (proj2_sig m) i).

(** ** Good variable properties for the basic operations *)

(** The characterizations of [empty], [set] and [remove] in terms of
    [get] queries carry over directly from those of the
    original implementation. *)

Theorem gempty:
  forall (A: Type) (i: positive), get i (empty A) = None.
Proof. reflexivity. Qed.

Theorem gss:
  forall (A: Type) (i: positive) (x: A) (m: t A), get i (set i x m) = Some x.
Proof.
  intros; destruct m as [m wf]. apply Original.PTree.gss.
Qed.

Theorem gso:
  forall (A: Type) (i j: positive) (x: A) (m: t A),
  i <> j -> get i (set j x m) = get i m.
Proof.
  intros; destruct m as [m wf]. apply Original.PTree.gso; auto.
Qed.

Theorem grs:
  forall (A: Type) (i: positive) (m: t A), get i (remove i m) = None.
Proof.
  intros; destruct m as [m wf]. apply Original.PTree.grs.
Qed.

Theorem gro:
  forall (A: Type) (i j: positive) (m: t A),
  i <> j -> get i (remove j m) = get i m.
Proof.
  intros; destruct m as [m wf]. apply Original.PTree.gro; auto.
Qed.

(** ** Extensionality property *)

(** We first show that for well-formed tries, equivalence implies equality.
    In other words, the well-formedness criterion rules out all the cases
    where the original implementation of tries fails the extensionality property. *)

Lemma extensionality_empty:
  forall A (m: tree A),
  wf m -> (forall i, Original.PTree.get i m = None) -> m = Leaf.
Proof.
  induction 1; simpl; intros E.
- auto.
- assert (l = Leaf). { apply IHwf1. intros. apply (E (xO i)). }
  assert (r = Leaf). { apply IHwf2. intros. apply (E (xI i)). }
  destruct o eqn:O.
  specialize (E xH). discriminate.
  subst l r. simpl in H1. tauto.
Qed.

Lemma extensionality_rec:
  forall A (m1: tree A), wf m1 -> forall (m2: tree A), wf m2 ->
  (forall i, Original.PTree.get i m1 = Original.PTree.get i m2) ->
  m1 = m2.
Proof.
  induction 1.
- intros m2 WF2 E. symmetry. apply extensionality_empty; auto.
  intros. symmetry. apply E.
- destruct 1; intros E.
  + apply extensionality_empty. constructor; auto.
    intros. apply E.
  + f_equal.
    * apply IHwf1; auto. intros. apply (E (xO i)).
    * apply (E xH).
    * apply IHwf2; auto. intros. apply (E (xI i)).
Qed.

(** To show that two values of type [t A] are equal, it is not enough to show that
    their data parts (first projections [proj1_sig]) are equal, which follows
    from the [extensionality_rec] lemma above: we must also show that their proof parts
    (second projections [proj2_sig]) are equal too.

    To this end, we need to show the unique proof property for the [wf m] predicate:
    two proofs of [wf m] are always equal.  We could just assert
    the proof irrelevance axiom and the result would follow trivially.
    However, we also have a proof without axioms. *)

Lemma not_trivially_empty_unique_proofs:
  forall A (l: tree A) (o: option A) (r: tree A) (p1 p2: not_trivially_empty l o r),
  p1 = p2.
Proof.
  unfold not_trivially_empty; intros.
  destruct l, o, r, p1, p2; auto.
Qed.

Lemma wf_unique_proofs:
  forall A (m: tree A) (p1 p2: wf m), p1 = p2.
Proof.
  induction m; intros; dependent destruction p1; dependent destruction p2.
- auto.
- f_equal; auto using not_trivially_empty_unique_proofs.
Qed.

(** The desired extensionality property follows. *)

Theorem extensionality:
  forall A (m1 m2: t A),
  (forall i, get i m1 = get i m2) -> m1 = m2.
Proof.
  intros A [m1 p1] [m2 p2] E.
  assert (m1 = m2) by (apply extensionality_rec; auto).
  subst m2.
  assert (p1 = p2) by (apply wf_unique_proofs).
  subst p2.
  auto.
Qed.

End PTree.


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 O B P Pprime T : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ Pprime O /\ (wd_ A T /\ (wd_ A B /\ (wd_ O P /\ (wd_ A P /\ (wd_ T O /\ (col_ O A T /\ (col_ A T B /\ col_ O T Pprime)))))))))) -> col_ A O B)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Copyright (c) 2008-2009, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Three-clause BSD Licence
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

(* Dependent list types presented in Chapter 9 *)

Require Import Arith List CpdtTactics.
Import ListNotations.

Set Implicit Arguments.
Set Asymmetric Patterns.

Section ilist.
  Variable A : Type.

  Inductive ilist : nat -> Type :=
  | INil : ilist O
  | ICons : forall n, A -> ilist n -> ilist (S n).

  Definition hd n (ls : ilist (S n)) :=
    match ls in ilist n' return match n' with
                                  | O => unit
                                  | S _ => A
                                end with
      | INil => tt
      | ICons _ x _ => x
    end.
  Definition tl n (ls : ilist (S n)) :=
    match ls in ilist n' return match n' with
                                  | O => unit
                                  | S n => ilist n
                                end with
      | INil => tt
      | ICons _ _ ls' => ls'
    end.

  Fixpoint iapp {n m} (l : ilist n) : ilist m -> ilist (n + m).
  refine(
  match l with
  | INil => fun l' => _
  | ICons _ x xs => fun l' => _
  end).
  - simpl. exact l'.
  - simpl.
    pose (iapp _ _ xs l').
    exact (ICons x i).
  Defined.

Check List.app.

  Inductive fin : nat -> Set :=
  | First : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | INil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | ICons _ x ls' => fun idx =>
        match idx in fin n' return (fin (pred n') -> A) -> A with
          | First _ => fun _ => x
          | Next _ idx' => fun get_ls' => get_ls' idx'
        end (get ls')
    end.

  Section everywhere.
    Variable x : A.

    Fixpoint everywhere (n : nat) : ilist n :=
      match n with
        | O => INil
        | S n' => ICons x (everywhere n')
      end.
  End everywhere.

  Section singleton.
    Variables x default : A.

    Fixpoint singleton (n m : nat) : ilist n :=
      match n with
        | O => INil
        | S n' =>
          match m with
            | O => ICons x (everywhere default n')
            | S m' => ICons default (singleton n' m')
          end
      end.
  End singleton.

  Section map2.
    Variable f : A -> A -> A.

    Fixpoint map2 n (il1 : ilist n) : ilist n -> ilist n :=
      match il1 in ilist n return ilist n -> ilist n with
        | INil => fun _ => INil
        | ICons _ x il1' => fun il2 => ICons (f x (hd il2)) (map2 il1' (tl il2))
      end.
  End map2.

  Section fold.
    Variable B : Type.
    Variable f : A -> B -> B.
    Variable i : B.

    Fixpoint foldr n (il : ilist n) : B :=
      match il with
        | INil => i
        | ICons _ x il' => f x (foldr il')
      end.
  End fold.
End ilist.

Implicit Arguments INil [A].
Implicit Arguments First [].

Section imap.
  Variables A B : Type.
  Variable f : A -> B.

  Fixpoint imap n (il : ilist A n) : ilist B n :=
    match il with
      | INil => INil
      | ICons _ x il' => ICons (f x) (imap il')
    end.
End imap.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  Definition hhd ls (hl : hlist ls) :=
    match hl in hlist ls return match ls with
                                  | nil => unit
                                  | x :: _ => B x
                                end with
      | HNil => tt
      | HCons _ _ v _ => v
    end.

  Definition htl ls (hl : hlist ls) :=
    match hl in hlist ls return match ls with
                                  | nil => unit
                                  | _ :: ls' => hlist ls'
                                end with
      | HNil => tt
      | HCons _ _ _ hl' => hl'
    end.

  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
      | HNil => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => B elm
                                          | _ :: _ => unit
                                        end) with
          | HFirst _ => tt
          | HNext _ _ _ => tt
        end
      | HCons _ _ x mls' => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => Empty_set
                                          | x' :: ls'' =>
                                            B x' -> (member ls'' -> B elm) -> B elm
                                        end) with
          | HFirst _ => fun x _ => x
          | HNext _ _ mem' => fun _ get_mls' => get_mls' mem'
        end x (hget mls')
    end.

  Fixpoint happ (ls1 : list A) (hl1 : hlist ls1) : forall ls2, hlist ls2 -> hlist (ls1 ++ ls2) :=
    match hl1 in hlist ls1 return forall ls2, hlist ls2 -> hlist (ls1 ++ ls2) with
      | HNil => fun _ hl2 => hl2
      | HCons _ _ x hl1' => fun _ hl2 => HCons x (happ hl1' hl2)
    end.

  Variable f : forall x, B x.

  Fixpoint hmake (ls : list A) : hlist ls :=
    match ls with
      | nil => HNil
      | x :: ls' => HCons (f x) (hmake ls')
    end.

  Theorem hget_hmake : forall ls (m : member ls),
    hget (hmake ls) m = f elm.
    induction ls; crush;
      match goal with
        | [ |- context[match ?E with HFirst _ => _ | HNext _ _ _ => _ end] ] => dep_destruct E
      end; crush.
  Qed.
End hlist.

Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].
Implicit Arguments hmake [A B].

Implicit Arguments HFirst [A elm ls].
Implicit Arguments HNext [A elm].

Infix ":::" := HCons (right associativity, at level 60).
Infix "+++" := happ (right associativity, at level 60).

Section hmap.
  Variable A C : Type.
  Variables B1 B2 : A -> Type.

  Variable f : forall x, B1 x -> B2 x.
  Variable f1 : forall x, B1 x -> C.

  Fixpoint hmap (ls : list A) (hl : hlist B1 ls) : hlist B2 ls :=
    match hl with
      | HNil => HNil
      | HCons _ _ x hl' => f x ::: hmap hl'
    end.

  Fixpoint hmap1 (ls : list A) (hl : hlist B1 ls) : list C  :=
    match hl with
    | HNil => nil
    | HCons _ _ x hl' => f1 x :: hmap1 hl'
    end.

  Fixpoint zipH {B3} (ls : list A) (f : forall x, B1 x -> B2 x -> B3 x)
    (l : hlist B1 ls) {struct l} : hlist B2 ls -> hlist B3 ls :=
    match l with
    | HNil => fun _ => HNil
    | HCons _ _ x xs => fun hl =>
      match hl in hlist _ l' return
      match l' with
      | nil => unit
      | x::xs => B1 x -> (hlist B2 xs -> hlist B3 xs) -> hlist B3 l' end with
      | HNil => tt
      | HCons _ _ x' hl' => fun x r => f _ x x' ::: r hl'
      end x (zipH f xs)
    end.

  Fixpoint fromList (ls : list A) (l : list (list C)) : hlist (fun _ => list C) ls :=
    match ls with
    | nil => HNil
    | _::ys =>
      match l with
      | nil => HCons nil (fromList ys nil)
      | x::xs => HCons x (fromList ys xs)
    end
    end.

  Fixpoint zipL (ls : list A) (f2 : C -> forall x, B1 x -> B2 x) (l1 : hlist B1 ls) {struct l1}:
  forall l2 : list C, length l2 = length ls -> hlist B2 ls.
  refine(
  match l1 in hlist _ l' return forall l2 : list C, length l2 = length l' -> hlist B2 l' with
  | HNil => fun _ _ => HNil
  | HCons _ _ x xs => fun l2 p => _
  end).
  - destruct l2 eqn:e.
  + inversion p.
  + pose (f2 c a x).
    inversion p.
    pose (zipL _ f2 xs l0 H0).
    apply HCons. * exact b. * exact h.
  Defined.

  Theorem hmap_happ : forall ls2 (h2 : hlist B1 ls2) ls1 (h1 : hlist B1 ls1),
    hmap h1 +++ hmap h2 = hmap (h1 +++ h2).
  Proof.
    induction h1.
    - simpl. reflexivity.
    - simpl. rewrite IHh1. reflexivity.
  Qed.

  Theorem hget_hmap : forall elm ls (hls : hlist B1 ls) (m : member elm ls),
    hget (hmap hls) m = f (hget hls m).
    induction hls; crush;
      match goal with
        | [ |- context[match ?E with HFirst _ => _ | HNext _ _ _ => _ end] ] => dep_destruct E
      end; crush.
  Qed.
End hmap.

Implicit Arguments hmap [A B1 B2 ls].


(* Additional definitions and lemmas on lists *)

Require Import Arith.
Require Import Omega.

(*** Support definitions and lemmas ***)

Module List_lib_Arith.

Lemma le_lt_dec_S :
  forall n m A (x y:A),
    (if le_lt_dec (S n) (S m) then x else y) =
    (if le_lt_dec n m then x else y).
Proof.
  intros. destruct (le_lt_dec n m); destruct (le_lt_dec (S n) (S m)).
  reflexivity. elimtype False; omega. elimtype False; omega. reflexivity.
Qed.

End List_lib_Arith.

Section functions.
  Set Implicit Arguments.
  Variables A B C D : Type.
  Definition compose (g:B->C) (f:A->B) x := g (f x).
  Definition compose2 (h:B->C->D) (f:A->B) (g:A->C) x y := h (f x) (g y).
End functions.
Hint Unfold compose compose2 : core.

Section option.
  Set Implicit Arguments.
  Variables A B : Type.

  Definition map_option (f:A->B) (xo:option A) : option B :=
    match xo with
      | Some x => Some (f x)
      | None => None
    end.
  Definition map_error := map_option.

  Definition fold_option (f:A->B->B) (xo:option A) (y:B) : B :=
    match xo with
      | Some x => f x y
      | None => y
    end.
  Definition fold_error := fold_option.
End option.
Hint Unfold map_option map_error fold_option fold_error : core.


(** * Test programs. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import Basics QArith String.
Local Open Scope program_scope.
Local Open Scope string_scope.

From ITree Require Import
  ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From cwp Require Import compile cpGCL cpo cwp eR itree order tactics tree.

Local Open Scope cpGCL_scope.
(* Local Open Scope nat_scope. *)

Definition incr (v : val) : val :=
  match v with
  | vnat n => vnat (S n)
  | _ => v
  end.

Definition plus (v1 v2 : val) : val :=
  match (v1, v2) with
  | (vnat n, vnat m) => vnat (n + m)
  | _ => vnat O
  end.

Definition flip (x : string) (p : Q) : cpGCL :=
  CChoice (const p) (fun b => x <-- b).

(* (* Expected value is 1. *) *)
(* Definition count_heads : cpGCL := *)
(*   let i := O in *)
(*   let x := S O in *)
(*   i <-- O; *)
(*   x <-- true; *)
(*   while (fun s => as_bool (s x)) do *)
(*       CChoice (const (1#2)) *)
(*         (fun b => if b then *)

(*         (i <-- fun s => incr (s i)) *)
(*         (x <-- false) *)
(*   end. *)

From Coq Require Import ExtrOcamlBasic ExtrOcamlString.

(* Extract Inductive bool => "bool" [ "true" "false" ]. *)
(* Extract Inductive list => "list" [ "[]" "(::)" ]. *)

(* Definition sampler : itree boolE nat := *)
(*   ITree.map (fun s => as_nat (s O)) (cpGCL_to_itree count_heads empty). *)
(* Extraction "extract/test/heads.ml" sampler. *)

(* Definition uniform (x : string) (n : nat) : cpGCL := *)
(*   CUniform (const n) (fun i => x <-- const i). *)
(* Definition sampler : itree boolE nat := *)
(*   ITree.map (fun s => as_nat (s EmptyString)) *)
(*     (cpGCL_to_itree (uniform EmptyString 10000) empty). *)
(* Extraction "extract/test/uniform.ml" sampler. *)

Definition gp : cpGCL :=
  flip "f" (1#2);
  CChoice (const (1#2))
    (fun b => if b then
             "r" <-- (fun s => s "f")
           else
             "r" <-- (fun s => true));
  obs (fun s => s "r").

From Coq Require Import ExtrOcamlBasic ExtrOcamlString.

Definition sampler : itree boolE bool :=
  ITree.map (fun s => as_bool (s "f")) (cpGCL_to_itree gp empty).
Extraction "extract/test/gp.ml" sampler.

Require Import cotree cotcwp.

Definition gp_cotree : cotree bool bool := icotree sampler.

Definition gp_chain (n : nat) : atree bool bool := tprefix n gp_cotree.

Eval compute in (List.map (Qred ∘ btwpQ (fun b : bool => if b then 1%Q else 0%Q)) (misc.prefix gp_chain 30)).

Inductive mytree (A : Type) : Type :=
| mybot : mytree A
| myleaf : A -> mytree A
| mytau : mytree A -> mytree A
| mynode : mytree A -> mytree A -> mytree A.

Fixpoint mytree_of_atree {A} (t : atree bool A) : mytree A :=
  match t with
  | abot => mybot
  | aleaf x => myleaf x
  | atau t => mytau (mytree_of_atree t)
  | anode k => mynode (mytree_of_atree (k true)) (mytree_of_atree (k false))
  end.

Fixpoint string_of_mytree (t : mytree string) : string :=
  match t with
  | mybot => "⊥"
  | myleaf s => "(Leaf " ++ s ++ ")"
  | mytau t => "(Tau " ++ string_of_mytree t ++ ")"
  | mynode l r => "(Node " ++ string_of_mytree l ++ " " ++ string_of_mytree r ++ ")"
  end.

(* Eval compute in (List.map mytree_of_atree (misc.prefix gp_chain 4)). *)

(* Eval compute in (List.map (string_of_mytree ∘ mytree_of_atree ∘ *)
(*                              atree_map (fun b : bool => if b then "true" else "false")) *)
(*                    (misc.prefix gp_chain 10)). *)


From CoqMTL Require Import Control.All.
From CoqMTL Require Import Control.Monad.Identity.
From CoqMTL Require Import Control.Monad.Class.MonadFree.

(** The free monad of a functor F. It models a computation whose effects
    are described by the functor F. Contrary to Haskell, it is implemented
    using Church encoding, because the corresponding inductive type is not
    strictly positive.

    The implementation is type-driven, so we shouldn't expect to get an
    intuitive understanding of what the operations really do... *)

Definition Free (F : Type -> Type) (A : Type) : Type :=
  forall X : Type, (A -> X) -> (F X -> X) -> X.

Section Free.

Variable F : Type -> Type.

Definition fmap_Free
  {A B : Type} (f : A -> B) (x : Free F A) : Free F B :=
    fun X pure wrap => x X (f .> pure) wrap.

#[refine]
#[export]
Instance Functor_Free : Functor (Free F) :=
{
  fmap := @fmap_Free
}.
Proof. all: reflexivity. Defined.

Definition pure_Free
  {A : Type} (x : A) : Free F A :=
    fun X pure _ => pure x.

Definition ap_Free
  {A B : Type} (mf : Free F (A -> B)) (ma : Free F A) : Free F B :=
    fun X pure wrap => mf X (fun f => fmap f ma X pure wrap) wrap.

#[refine]
#[export]
Instance Applicative_Free : Applicative (Free F) :=
{
  pure := @pure_Free;
  ap := @ap_Free;
}.
Proof. all: reflexivity. Defined.

Definition bind_Free
  {A B : Type} (x : Free F A) (f : A -> Free F B) : Free F B :=
    fun X pure wrap => x X (fun a => f a X pure wrap) wrap.

#[refine]
#[export]
Instance Monad_Free : Monad (Free F) :=
{
  bind := @bind_Free
}.
Proof. all: reflexivity. Defined.

End Free.

(** We shouldn't expect free monads to support any structure besides that
    of a monad, so in particular no [Alternative]. *)
Lemma Free_not_Alternative :
  (forall F : Type -> Type, Alternative (Free F)) -> False.
Proof.
  unfold Free; intro. destruct (X Identity); unfold Identity in *.
  apply (aempty False False); trivial.
Qed.

Definition wrap_Free
  {F : Type -> Type} {instF : Functor F} {A : Type}
  (x : F (Free F A)) : Free F A :=
    fun X pure wrap =>
      wrap (fmap (fun f : forall X : Type, (A -> X) -> (F X -> X) -> X =>
               f X pure wrap) x).

#[global] Hint Unfold fmap_Free pure_Free ap_Free bind_Free wrap_Free : CoqMTL.

#[refine]
#[export]
Instance MonadFree_Free
  (F : Type -> Type) (instF : Functor F)
  : MonadFree F (Free F) instF (Monad_Free F) :=
{
  wrap := @wrap_Free F instF
}.
Proof.
  monad. rewrite <- !fmap_comp'. unfold compose. reflexivity.
Defined.