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

(**********************************************************************)
(*                       Closure Calculus                             *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

(* coqdoc Closure_calculus.v --latex --no-lib-name -o Closure_calculus.tex  *)

Require Import List Omega.

(** General tactics *)

Ltac eapply2 H := eapply H; eauto.

Ltac split_all := simpl; intros;
match goal with
| H : _ /\ _ |- _ => inversion_clear H; split_all
| H : exists _, _ |- _ => inversion H; clear H; split_all
| _ =>  try (split; split_all); try contradiction
end; try congruence; auto.

Ltac exist x := exists x; split_all.
Ltac invsub :=
match goal with
| H : _ = _ |- _ => inversion H; subst; clear H; invsub
| _ => split_all
end.

(**
The terms of closure calculus are:
-variables (given by natural numbers)
-tagged applications
-applications
-the identity operator
-extensions (constructor Add)
-closures (constructor Abs)

The variable names will become de Bruijn indices when doing meta-theory,
but this will come after the reduction rules have been defined.
*)

Inductive lambda:  Set :=
| Ref : nat -> lambda
| Tag : lambda -> lambda -> lambda
| App : lambda -> lambda -> lambda
| Iop : lambda
| Add : lambda -> nat -> lambda -> lambda (* Add sigma x u *)
| Abs : lambda -> nat -> lambda -> lambda  (* Abs sigma x t *)
          .

Hint Constructors lambda.

Definition termred := lambda -> lambda -> Prop.

(* Reflexive, transitive closures *)

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: lambda-> lambda -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Hint Constructors multi_step.

Definition reflective red := forall (M: lambda), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| _ => split_all
end.

Definition transitive red := forall (M N P: lambda), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Ltac one_step :=
  try red;
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try reflect
end.

(* Confluence *)

Definition confluence (A : Set) (R : A -> A -> Prop) :=
  forall x y : A,
  R x y -> forall z : A, R x z -> exists u : A, R y u /\ R z u.

Definition diamond0 (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond0_flip: forall red1 red2, diamond0 red1 red2 -> diamond0 red2 red1.
Proof.
unfold diamond0. intros red1 red2 d M N r2 P r1.  elim (d M P r1 N r2); split_all. exist x. Qed.

Lemma diamond0_strip :
forall red1 red2, diamond0 red1 red2 -> diamond0 red1 (multi_step red2).
Proof.
intros red1 red2 d. eapply2 diamond0_flip. red; induction 1;  intros Q r.
(* 2 *)
exist Q.
(* 1 *)
elim (d M Q r N); split_all.
elim(IHmulti_step d x); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Definition diamond0_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond0_star_strip:
forall red1 red2, diamond0_star red1 red2 -> diamond0 (multi_step red2) red1 .
Proof.
red. intros red1 red2 d. intros M N r;  induction r;  intros Q r1.
(* 2 *)
exist Q.
(* 1 *)
elim(d M Q r1 N H); split_all.
elim(IHr d x); split_all.
exist x0.
apply transitive_red with x; auto.
Qed.

Lemma diamond0_tiling :
forall red1 red2, diamond0 red1 red2 -> diamond0 (multi_step red1) (multi_step red2).
Proof.
red. intros red1 red2 d M N r;  induction r; intros Q r2.
(* 2 *)
exist Q.
(* 1 *)
elim(diamond0_strip red red2 d M N H Q); split_all.
elim(IHr d x H1); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond0_tiling.

Definition diamond (red1 red2 : termred) :=
forall M N P, red1 M N -> red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_iff_diamond0 : forall red1 red2, diamond red1 red2 <-> diamond0 red1 red2.
Proof.  intros; red; split_all; red; split_all; eapply2 H. Qed.

Lemma diamond_tiling : forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
  intros. eapply2 diamond_iff_diamond0. eapply2 diamond0_tiling. eapply2 diamond_iff_diamond0.
Qed.

(* Reduction rules (sequential) *)

Inductive seq_red1 : lambda -> lambda -> Prop :=
  | tagl_seq_red :  forall M M' N, seq_red1 M M' -> seq_red1 (Tag M N) (Tag M' N)
  | tagr_seq_red :  forall M N N', seq_red1 N N' -> seq_red1 (Tag M N) (Tag M N')
  | appl_seq_red :  forall M M' N, seq_red1 M M' -> seq_red1 (App M N) (App M' N)
  | appr_seq_red :  forall M N N', seq_red1 N N' -> seq_red1 (App M N) (App M N')
  | addl_seq_red :  forall i M M' sigma, seq_red1 M M' ->
      seq_red1 (Add sigma i M) (Add sigma i M')
  | addr_seq_red :  forall i M sigma sigma', seq_red1 sigma sigma' ->
      seq_red1 (Add sigma i M) (Add sigma' i M)
  | absl_seq_red :  forall sigma sigma' i M, seq_red1 sigma sigma' ->
      seq_red1 (Abs sigma i M) (Abs sigma' i M)
  | absr_seq_red :  forall sigma i M M', seq_red1 M M' ->
      seq_red1 (Abs sigma i M) (Abs sigma i M')
  | app_ref_seq_red : forall i M, seq_red1 (App (Ref i) M) (Tag (Ref i) M)
  | app_tag_seq_red : forall M N P, seq_red1 (App (Tag M N) P) (Tag (Tag M N) P)
  | beta_seq_red : forall sigma j M N,
      seq_red1 (App (Abs sigma j M) N) (App (Add sigma j N) M)
  | nil_seq_red : forall M, seq_red1 (App Iop M) M
  | subst_eq_seq_red : forall j sigma N, seq_red1 (App (Add sigma j N) (Ref j)) N
  | subst_uneq_seq_red : forall sigma i j N, i<> j ->
      seq_red1 (App (Add sigma i N) (Ref j)) (App sigma (Ref j))
  | subst_tag_seq_red : forall j U sigma M N,
      seq_red1 (App (Add j U sigma) (Tag M N))
               (App (App (Add j U sigma) M) (App (Add j U sigma) N))
  | subst_nil_seq_red : forall j U sigma,
      seq_red1 (App (Add sigma j U) Iop) (App sigma Iop)
  | subst_add_seq_red : forall j N sigma j2 P sigma2,
      seq_red1 (App (Add sigma j N) (Add sigma2 j2 P))
               (Add  (App (Add sigma j N) sigma2) j2 (App (Add sigma j N) P))
  | subst_abs_seq_red : forall j N sigma j2 sigma2 M,
      seq_red1 (App (Add sigma j N) (Abs sigma2 j2 M))
               (Abs (App (Add sigma j N) sigma2) j2 M) (* no action on M! *)
 .

Hint Constructors seq_red1 .
Definition seq_red := multi_step seq_red1.

Lemma reflective_seq_red: reflective seq_red.
Proof. red; red; reflect. Qed.
Hint Resolve reflective_seq_red.

(* Preservation *)

Definition preserve (R : termred) (P : lambda -> Prop) :=
  forall x : lambda, P x -> forall y : lambda, R x y -> P y.

Definition preserves_tagl (red : termred) :=
forall M M' N, red M M' -> red (Tag M N) (Tag M' N).

Definition preserves_tagr (red : termred) :=
forall M N N', red N N' -> red (Tag M N) (Tag M N').

Lemma preserves_tagl_multi_step : forall (red: termred), preserves_tagl red -> preserves_tagl (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (Tag N0 N); auto. Qed.

Lemma preserves_tagr_multi_step : forall (red: termred), preserves_tagr red -> preserves_tagr (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (Tag M N); auto. Qed.

Definition preserves_tag (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (Tag M N) (Tag M' N').

Definition preserves_apl (red : termred) :=
forall M M' N, red M M' -> red (App M N) (App M' N).

Definition preserves_apr (red : termred) :=
forall M N N', red N N' -> red (App M N) (App M N').

Lemma preserves_apl_multi_step : forall (red: termred), preserves_apl red -> preserves_apl (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (App N0 N); auto. Qed.

Lemma preserves_apr_multi_step : forall (red: termred), preserves_apr red -> preserves_apr (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (App M N); auto. Qed.

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Definition preserves_adl (red : termred) :=
forall i M M' N, red M M' -> red (Add M i N) (Add M' i N).

Definition preserves_adr (red : termred) :=
forall i M sigma sigma', red sigma sigma' -> red (Add M i sigma) (Add M i sigma').

Lemma preserves_adl_multi_step : forall (red: termred), preserves_adl red -> preserves_adl (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (Add N0 i N); auto. Qed.

Lemma preserves_adr_multi_step : forall (red: termred), preserves_adr red -> preserves_adr (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (Add M i N); auto. Qed.

Definition preserves_add (red : termred) :=
forall M M' N N' i, red M M' -> red N N' -> red (Add M i N) (Add M' i N').

Definition preserves_absl (red : termred) :=
forall sigma sigma' j M, red sigma sigma' -> red (Abs sigma j M) (Abs sigma' j M).

Definition preserves_absr (red : termred) :=
forall sigma j M M', red M M' -> red (Abs j sigma M) (Abs j sigma M').

Lemma preserves_absl_multi_step : forall (red: termred), preserves_absl red -> preserves_absl (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (Abs N j M); auto. Qed.

Lemma preserves_absr_multi_step : forall (red: termred), preserves_absr red -> preserves_absr (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (Abs j sigma N); auto. Qed.

Definition preserves_abs (red : termred) :=
forall sigma sigma' j M N, red sigma sigma' -> red M N -> red (Abs sigma j M) (Abs sigma' j N).

Lemma preserves_tagl_seq_red: preserves_tagl seq_red.
Proof. eapply2 preserves_tagl_multi_step. red; split_all.  Qed.
Hint Resolve preserves_tagl_seq_red.

Lemma preserves_tagr_seq_red: preserves_tagr seq_red.
Proof. eapply2 preserves_tagr_multi_step. red; split_all.  Qed.
Hint Resolve preserves_tagr_seq_red.

Lemma preserves_tag_seq_red: preserves_tag seq_red.
Proof.
red; split_all.
apply transitive_red with (Tag M' N); split_all.
eapply2 preserves_tagl_seq_red.
eapply2 preserves_tagr_seq_red.
Qed.
Hint Resolve preserves_tag_seq_red.

Lemma preserves_apl_seq_red: preserves_apl seq_red.
Proof. eapply2 preserves_apl_multi_step. red; split_all.  Qed.
Hint Resolve preserves_apl_seq_red.

Lemma preserves_apr_seq_red: preserves_apr seq_red.
Proof. eapply2 preserves_apr_multi_step. red; split_all.  Qed.
Hint Resolve preserves_apr_seq_red.

Lemma preserves_app_seq_red: preserves_app seq_red.
Proof.
red; split_all.
apply transitive_red with (App M' N); split_all.
eapply2 preserves_apl_seq_red.
eapply2 preserves_apr_seq_red.
Qed.
Hint Resolve preserves_app_seq_red.

Lemma preserves_adl_seq_red: preserves_adl seq_red.
Proof. eapply2 preserves_adl_multi_step. red; split_all.  Qed.
Hint Resolve preserves_adl_seq_red.

Lemma preserves_adr_seq_red: preserves_adr seq_red.
Proof. eapply2 preserves_adr_multi_step. red; split_all.  Qed.
Hint Resolve preserves_adr_seq_red.

Lemma preserves_add_seq_red: preserves_add seq_red.
Proof.
red; split_all.
apply transitive_red with (Add M' i N); split_all.
eapply2 preserves_adl_seq_red.
eapply2 preserves_adr_seq_red.
Qed.
Hint Resolve preserves_add_seq_red.

Lemma preserves_absl_seq_red: preserves_absl seq_red.
Proof. eapply2 preserves_absl_multi_step. red; split_all.  Qed.
Hint Resolve preserves_absl_seq_red.

Lemma preserves_absr_seq_red: preserves_absr seq_red.
Proof. eapply2 preserves_absr_multi_step. red; split_all.  Qed.
Hint Resolve preserves_absr_seq_red.

Lemma preserves_abs_seq_red: preserves_abs seq_red.
Proof.
red; split_all.
apply transitive_red with (Abs sigma' j M); split_all.
eapply2 preserves_absl_seq_red.
eapply2 preserves_absr_seq_red.
Qed.

(* Parallel reduction *)

Inductive dl_red1: termred :=
  | ref_red : forall i, dl_red1 (Ref i) (Ref i)
  | tag_red : forall M M' ,
      dl_red1 M M' ->
      forall N N', dl_red1 N N' -> dl_red1 (Tag M N) (Tag M' N')
  | app_red :
      forall M M' ,
      dl_red1 M M' ->
      forall N N', dl_red1 N N' -> dl_red1 (App M N) (App M' N')
  | Iop_red : dl_red1 Iop Iop
  | add_red : forall M M' ,
      dl_red1 M M' ->
      forall sigma sigma', dl_red1 sigma sigma' ->
        forall i,  dl_red1 (Add sigma i M) (Add sigma' i M')
  | abs_red :
      forall sigma sigma' j M M', dl_red1 sigma sigma' -> dl_red1 M M' ->
                                  dl_red1 (Abs sigma j M) (Abs sigma' j M')
  | app_ref_red : forall i M M' , dl_red1 M M' ->
                                  dl_red1 (App (Ref i) M) (Tag (Ref i) M')
  | app_tag_red : forall M M' N N' P P', dl_red1 M M' -> dl_red1 N N' -> dl_red1 P P' ->
                                  dl_red1 (App (Tag M N) P) (Tag (Tag M' N') P')
(* beta and subst *)
  | beta_red : forall sigma sigma' j M M' N N',
                  dl_red1 sigma sigma' -> dl_red1 M M' -> dl_red1 N N' ->
                      dl_red1 (App (Abs sigma j M) N)
                              (App (Add sigma' j N') M')
  | nil_red : forall M M', dl_red1 M M' -> dl_red1 (App Iop M) M'
  | subst_eq_red : forall j sigma N N', dl_red1 N N' -> dl_red1 (App (Add sigma j N) (Ref j)) N'
  | subst_uneq_red : forall sigma sigma' i j N, i<> j -> dl_red1 sigma sigma' ->
                                  dl_red1 (App (Add sigma i N) (Ref j)) (App sigma' (Ref j))
  | subst_tag_red : forall j U U' sigma sigma' M M' N N',
                       dl_red1 U U'  -> dl_red1 sigma sigma' -> dl_red1 M M' -> dl_red1 N N' ->
                                    dl_red1 (App (Add sigma j U) (Tag M N))
                                        (App (App (Add sigma' j U') M')
                                             (App (Add sigma' j U') N'))
  | subst_nil_red : forall j U sigma sigma',  dl_red1 sigma sigma' ->
                                              dl_red1 (App (Add sigma j U) Iop) (App sigma' Iop)
  | subst_add_red : forall j N N' sigma sigma' j2 P P' sigma2 sigma2' ,
                  dl_red1 sigma sigma' -> dl_red1 P P' -> dl_red1 N N' ->dl_red1 sigma2 sigma2' ->
                          dl_red1 (App (Add sigma j N) (Add sigma2 j2 P))
                                  (Add (App (Add sigma' j N') sigma2') j2
                                       (App (Add sigma' j N') P')
)
  | subst_abs_red : forall j N N' sigma sigma' j2 M M' sigma2 sigma2' ,
                  dl_red1 sigma sigma' -> dl_red1 M M' -> dl_red1 N N' ->
                  dl_red1 sigma2 sigma2' ->
                      dl_red1 (App (Add sigma j N) (Abs sigma2 j2 M))
                               (Abs (App (Add sigma' j N') sigma2') j2 M') (* no action on M*)
.

Hint Constructors dl_red1.
Definition dl_red := multi_step dl_red1.

Lemma refl_red1: reflective dl_red1.
Proof. red. induction M; split_all. Qed.
Hint Resolve refl_red1.

Ltac inv_dl_red :=
match goal with
| H: dl_red1 (Ref _) _ |- _ => inversion H; clear H; subst; inv_dl_red
| H: dl_red1 (Tag _ _) _ |- _ => inversion H; clear H; subst; inv_dl_red
| H: dl_red1 Iop _ |- _ => inversion H; clear H; subst; inv_dl_red
| H: dl_red1 (Add _ _ _) _ |- _ => inversion H; clear H; subst; inv_dl_red
| H: dl_red1 (Abs _ _ _) _ |- _ => inversion H; clear H; subst; inv_dl_red
| _ => invsub; eauto
end.

Lemma diamond_red1 : diamond dl_red1 dl_red1.
Proof.
red. induction M; intros N P r1 r2; inv_dl_red.
(* 4 *)
elim(IHM1 M' M'0); split_all. elim(IHM2 N' N'0); split_all.  eauto.
(* 3 *)
inversion r1; inversion r2; subst; inv_dl_red; eauto.
(* 32 *)
elim(IHM1 M' M'0); split_all. elim(IHM2 N' N'0); split_all.  eauto.
(* 31 *)
elim(IHM2 N' M'0); split_all; eauto.
(* 30 *)
elim(IHM1 (Tag M'0 N'0) (Tag M'1 N'1)); elim(IHM2 N' P'); split_all; eauto.
inv_dl_red. exist (Tag (Tag M' N'2) x).
(* 29 *)
elim(IHM1 (Abs sigma' j M'0) (Abs sigma'0 j M'1)); split_all.
elim(IHM2 N' N'0); split_all.
inv_dl_red. exist (App (Add sigma'1 j x0) M').
(* 28 *)
elim(IHM2 N' P); split_all; eauto.
(* 27 *)
elim(IHM1 (Add sigma j P) (Add sigma j M'0)); split_all.
inv_dl_red.
(* 26 *)
elim(IHM1 (Add sigma' i N1) (Add sigma'0 i N1)); split_all.
inv_dl_red.
(* 25 *)
elim(IHM1 (Add sigma' j U') (Add sigma'0 j M'2)); split_all.
elim(IHM2 (Tag M'0 N'0) (Tag M'1 N'1)); split_all. inv_dl_red.
exist(App (App (Add sigma'1 j M'3) M') (App (Add sigma'1 j M'3) N')) .
(* 24 *)
elim(IHM1 (Add sigma' j U) (Add sigma'0 j U)); split_all. inv_dl_red.
(* 23 *)
elim(IHM1 (Add sigma' j N'0) (Add sigma'1 j M'1)); split_all.
elim(IHM2 (Add sigma2' j2 P')(Add sigma'0 j2 M'0)); split_all. inv_dl_red.
exist(Add (App (Add sigma'3 j M'2) sigma'2) j2 (App (Add sigma'3 j M'2) M')).
(* 22 *)
elim(IHM1 (Add sigma' j N'0) (Add sigma'0 j M'1)); split_all.
elim(IHM2 (Abs sigma2' j2 M'0)(Abs sigma'1 j2 M')); split_all. inv_dl_red.
exist(Abs (App (Add sigma'2 j M'2) sigma'3) j2 M'3).
(* 21 *)
elim(IHM2 M' N'); split_all; eauto.
(* 20 *)
elim(IHM2 M' M'0); split_all; eauto.
(* 19 *)
elim(IHM1 (Tag M' N') (Tag M'1 N'1)); elim(IHM2 P' N'0); split_all.
inv_dl_red. exist(Tag (Tag M'0 N'2) x).
(* 18 *)
elim(IHM1 (Tag M' N') (Tag M'0 N'0)); elim(IHM2 P' P'0); split_all.
inv_dl_red. exist(Tag (Tag M'1 N'1) x).
(* 17 *)
elim(IHM1 (Abs sigma' j M') (Abs sigma'0 j M'1));  split_all.
elim(IHM2 N' N'0); split_all.
inv_dl_red. exist (App (Add sigma'1 j x0) M'0).
(* 16 *)
elim(IHM1 (Abs sigma' j M') (Abs sigma'0 j M'0));  split_all.
elim(IHM2 N' N'0); split_all.
inv_dl_red. exist (App (Add sigma'1 j x0) M'1).
(* 15 *)
elim(IHM2 N N'); split_all; eauto.
(* 14 *)
elim(IHM1 (Add sigma j N)(Add sigma j M'0)); split_all; inv_dl_red; eauto.
(* 13 *)
elim(IHM1 (Add sigma j N)(Add sigma j P)); split_all; inv_dl_red; eauto.
(* 12 *)
elim(IHM1 (Add sigma' i N0)(Add sigma'0 i N0)); split_all; inv_dl_red; eauto.
(* 11 *)
elim(IHM1 (Add sigma' i N0)(Add sigma'0 i N0)); split_all; inv_dl_red; eauto.
(* 10 *)
elim(IHM1 (Add sigma' j U')(Add sigma'0 j M'2)); split_all.
elim(IHM2 (Tag M' N') (Tag M'1 N'1)); split_all.  inv_dl_red; eauto.
exist(App (App (Add sigma'1 j M'3) M'0) (App (Add sigma'1 j M'3) N'0)) .
(* 9 *)
elim(IHM1 (Add sigma' j U')(Add sigma'0 j U'0)); split_all.
elim(IHM2 (Tag M' N') (Tag M'0 N'0)); split_all.  inv_dl_red; eauto.
exist(App (App (Add sigma'1 j M'2) M'1) (App (Add sigma'1 j M'2) N'1)) .
(* 8 *)
elim(IHM1 (Add sigma' j U) (Add sigma'0 j U)); split_all. inv_dl_red.
(* 7 *)
elim(IHM1 (Add sigma' j U) (Add sigma'0 j U)); split_all. inv_dl_red.
(* 6 *)
elim(IHM1 (Add sigma' j N')(Add sigma'1 j M'1)); split_all.
elim(IHM2 (Add sigma2' j2 P') (Add sigma'0 j2 M'0)); split_all.  inv_dl_red; eauto.
exist(Add (App (Add sigma'3 j M'2) sigma'2) j2 (App (Add sigma'3 j M'2) M')).
(* 5 *)
elim(IHM1 (Add sigma' j N')(Add sigma'0 j N'0)); split_all.
elim(IHM2 (Add sigma2' j2 P') (Add sigma2'0 j2 P'0)); split_all.  inv_dl_red; eauto.
exist(Add (App (Add sigma'2 j M'0) sigma'1) j2 (App (Add sigma'2 j M'0) M')) .
(* 4 *)
elim(IHM2 (Abs sigma2' j2 M')(Abs sigma'1 j2 M'0)); split_all.
elim(IHM1 (Add sigma' j N') (Add sigma'0 j M'1)); split_all.
inv_dl_red. exist (Abs (App (Add sigma'2 j M'2) sigma'3) j2 M'3).
(* 3 *)
elim(IHM2 (Abs sigma2' j2 M')(Abs sigma2'0 j2 M'0)); split_all.
elim(IHM1 (Add sigma' j N') (Add sigma'0 j N'0)); split_all.
inv_dl_red. exist (Abs (App (Add sigma'1 j M'1) sigma'2) j2 M'2).
(* 2 *)
elim(IHM2 M' M'0); split_all. elim(IHM1 sigma' sigma'0); split_all.  eauto.
(* 1 *)
elim(IHM1 sigma' sigma'0); split_all. elim(IHM2 M' M'0); split_all.  eauto.
Qed.

Theorem tuple_parallel_confluence: confluence lambda dl_red.
Proof. red. eapply2 diamond0_tiling. eapply2 diamond_iff_diamond0. eapply2 diamond_red1. Qed.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.

Lemma seq_red1_to_red1 : implies_red seq_red1 dl_red1.
Proof.
  red. intros M N B; induction B; split_all; try (red; one_step; fail).
Qed.

Lemma seq_red_to_red: implies_red seq_red dl_red.
Proof.
  eapply2 implies_red_multi_step. red; split_all; one_step; eapply2 seq_red1_to_red1.
Qed.

Lemma to_seq_red_multi_step: forall red, implies_red red seq_red -> implies_red (multi_step red) seq_red.
Proof.
red.  intros red B M N R; induction R; split_all.
red; split_all.
assert(seq_red M N) by eapply2 B.
apply transitive_red with N; auto.
eapply2 IHR.
Qed.

Hint Resolve preserves_app_seq_red preserves_abs_seq_red.

Lemma dl_red1_to_seq_red: implies_red dl_red1 seq_red .
Proof.
  red.  intros M N OR; induction OR; split_all;
        try(eapply2 succ_red;
        try eapply2 preserves_ref_seq_red;
        try eapply2 beta_tag_seq_red;
        try eapply2 preserves_tag_seq_red;
        try eapply2 preserves_add_seq_red;
       try eapply2 preserves_abs_seq_red;
        try eapply2 preserves_app_seq_red;
        try eapply2 preserves_aps_seq_red; fail).
Qed.

Hint Resolve dl_red1_to_seq_red.

Lemma dl_red_to_seq_red: implies_red dl_red seq_red.
Proof. eapply2 to_seq_red_multi_step. Qed.

Lemma diamond_seq_red: diamond seq_red seq_red.
Proof.
red; split_all.
assert(dl_red M N) by eapply2 seq_red_to_red.
assert(dl_red M P) by eapply2 seq_red_to_red.
elim(tuple_parallel_confluence M N H1 P); split_all.
exist x; eapply2 dl_red_to_seq_red.
Qed.

Theorem closure_confluence: confluence lambda seq_red.
Proof. red. split_all. eapply2 diamond_seq_red. Qed.

(* normal forms *)

Inductive normal : lambda -> Prop :=
| nf_ref: forall i, normal (Ref i)
| nf_tag: forall s u,  normal s -> normal u -> normal (Tag s u)
| nf_nil: normal Iop
| nf_add: forall s j u,  normal s -> normal u -> normal (Add s j u)
| nf_abs : forall sigma j M, normal sigma -> normal M -> normal (Abs sigma j M)
.

Hint Constructors normal.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma normal_is_irreducible:
forall M, normal M -> irreducible M seq_red1.
Proof.
  intros M nor; induction nor; split_all;
  intro; intro r; inversion r; subst; split_all;
  try (eapply2 IHnor1; fail); try (eapply2 IHnor2; fail).
Qed.

Theorem closure_progress :
forall (M : lambda),  (normal M) \/ (exists N, seq_red1 M N) .
Proof.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 4 *)
inversion IHM1; inversion IHM2; split_all; try (right; eauto; fail).
(* 3 *)
inversion IHM1; inversion IHM2; split_all;  eauto.
inversion H; subst; eauto.  inversion H0; subst; eauto.
right; assert(i=j \/ i<>j) by decide equality. inversion H3; subst; eauto.
(* 2 *)
inversion IHM1; inversion IHM2; split_all;  eauto.
(* 1 *)
inversion IHM1; inversion IHM2; split_all;  eauto.
Qed.

Lemma irreducible_is_normal:
forall M, irreducible M seq_red1 -> normal M.
Proof.
split_all. elim(closure_progress M); split_all. assert False by eapply2 H.  inversion H0.
Qed.

Theorem irreducible_iff_normal:
  forall M, (irreducible M seq_red1 <-> normal M).
Proof. split_all. eapply2 irreducible_is_normal. eapply2 normal_is_irreducible. Qed.

Definition stable M := forall N, dl_red M N -> N = M.

Theorem normal_implies_stable: forall M, normal M -> stable M.
Proof.
unfold stable; split_all.
assert(seq_red M N) by eapply2 dl_red_to_seq_red.
inversion H1; subst; auto.
assert(irreducible M seq_red1) by eapply2 irreducible_iff_normal.
assert False by eapply2 H4. inversion H5.
Qed.

(* Recursion *)

Definition omega := Abs Iop 1 (Abs (Add Iop 1 (Ref 1)) 0 (Tag (Ref 0) (Tag (Tag (Ref 1) (Ref 1)) (Ref 0)))).
Definition Ycomb := Abs (Add Iop 1 omega)  0 (Tag (Ref 0) (Tag (Tag (Ref 1) (Ref 1)) (Ref 0))).

Lemma fixpoint_property:
forall f, seq_red (App Ycomb f) (App f (App Ycomb f)).
Proof.
intros; unfold Ycomb  at 1.
repeat (eapply2 succ_red; eapply2 succ_red).
repeat eapply2 preserves_app_seq_red.
unfold omega at 1, Ycomb. repeat eapply2 succ_red.
Qed.

Definition omega2 := (* \wfx. f(wwf)x *)
  Abs Iop 1 (Abs (Add Iop 1 (Ref 1)) 0 (Abs (Add (Add Iop 0 (Ref 0)) 1 (Ref 1)) 2
    (Tag (Tag (Ref 0) (Tag (Tag (Ref 1) (Ref 1)) (Ref 0))) (Ref 2))))
 .
Definition Y2 :=  App omega2 omega2.

Lemma Y2_normalisable: forall f, normal f -> exists N, seq_red (App Y2 f) N /\ normal N.
Proof.
intros.
exist
(Abs (Add (Add Iop 0 f) 1 omega2) 2
   (Tag (Tag (Ref 0) (Tag (Tag (Ref 1) (Ref 1)) (Ref 0))) (Ref 2))).
unfold Y2, omega2 at 1. repeat eapply2 succ_red.
eapply2 nf_abs.  eapply2 nf_add.
 unfold omega2; auto.
repeat eapply2 nf_abs.
Qed.

Lemma fixpoint2_property:
forall f N, seq_red (App (App Y2 f) N) (App (App f (App Y2 f)) N).
Proof.
intros; unfold Y2 at 1. unfold omega2 at 1.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 preserves_app_seq_red. eapply2 preserves_app_seq_red.
repeat eapply2 succ_red. repeat eapply2 succ_red.
Qed.

Definition omega3 := (* \wfxy. f(wwf)xy *)
  Abs Iop 1 (Abs (Add Iop 1 (Ref 1)) 0 (Abs (Add (Add Iop 0 (Ref 0)) 1 (Ref 1)) 2
    (Abs (Add (Add (Add Iop 0 (Ref 0)) 1 (Ref 1)) 2 (Ref 2)) 3
       (Tag (Tag (Tag (Ref 0) (Tag (Tag (Ref 1) (Ref 1)) (Ref 0))) (Ref 2)) (Ref 3)))))
 .
Definition Y3 := App omega3 omega3.

Lemma fixpoint3_property:
forall f N P, seq_red  (App(App (App Y3 f) N) P) (App (App (App f (App Y3 f)) N) P).
Proof.
intros; unfold Y3 at 1. unfold omega3 at 1.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 preserves_app_seq_red. eapply2 preserves_app_seq_red. eapply2 preserves_app_seq_red.
repeat eapply2 succ_red.
Qed.

Lemma Y3_normalisable:
forall f M, normal f -> normal M -> exists N, seq_red (App (App Y3 f) M) N /\ normal N.
Proof.
intros.
exist  (Abs
     (Add (Add (Add Iop 0 f) 1 omega3) 2 M) 3
     (Tag (Tag (Tag (Ref 0) (Tag (Tag (Ref 1) (Ref 1)) (Ref 0))) (Ref 2)) (Ref 3))).
unfold Y3, omega3 at 1.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red. eapply2 succ_red.
eapply2 succ_red. eapply2 succ_red.
eapply2 preserves_abs_seq_red. repeat eapply2 preserves_add_seq_red.
repeat eapply2 succ_red. repeat eapply2 succ_red.

eapply2 nf_abs.  repeat eapply2 nf_add.  2: repeat eapply2 nf_tag.
 unfold omega3; auto.
repeat eapply2 nf_abs. repeat eapply2 nf_tag.
Qed.

Definition tt := Abs Iop 1 (Abs (Add Iop 1 (Ref 1)) 0 (Ref 1)).
Definition ff := Abs Iop 1 (Abs Iop 0 (Ref 0)).

Lemma if_true : forall m n, seq_red (App (App tt m) n) m.
Proof. split_all; subst; unfold tt.  repeat eapply2 succ_red. Qed.

Lemma if_false : forall m n, seq_red (App (App ff m) n) n.
Proof. split_all; subst; unfold ff.  eapply2 succ_red. Qed.


Require Export Bool Arith.

Require Export List.
Export ListNotations.

Parameter Loc : Type.
Parameter dec : Loc -> Loc -> bool.
Parameter dec_spec :
  forall x y : Loc, reflect (x = y) (dec x y).

Notation "x =? y" := (dec x y) (at level 70).

Ltac inv H :=
  inversion H; subst; clear H; eauto.

(** * Stuff for dealing with [option]. *)

Definition omap {A B : Type}
  (f : A -> B) (oa : option A) : option B :=
match oa with
    | None => None
    | Some a => Some (f a)
end.

Definition liftM2 {A B C : Type}
  (f : A -> B -> C) (oa : option A) (ob : option B) : option C :=
match oa, ob with
    | Some a, Some b => Some (f a b)
    | _, _ => None
end.

Definition obind {A B : Type}
  (oa : option A) (f : A -> option B) : option B :=
match oa with
    | None => None
    | Some a => f a
end.

(** * Reflexive-transitive closures *)

Inductive rtc {A : Type} (R : A -> A -> Prop) : A -> A -> Prop :=
    | rtc_step :
        forall x y : A, R x y -> rtc R x y
    | rtc_refl :
        forall x : A, rtc R x x
    | rtc_trans :
        forall x y z : A, rtc R x y -> rtc R y z -> rtc R x z.

#[global] Hint Constructors rtc : core.

Inductive rtc' {A : Type} (R : A -> A -> Prop) : A -> A -> Prop :=
    | rtc'_refl :
        forall x : A, rtc' R x x
    | rtc'_steptrans :
        forall x y z : A, R x y -> rtc' R y z -> rtc' R x z.

#[global] Hint Constructors rtc' : core.

Require Export Setoid Classes.RelationClasses.

#[export]
Instance Reflexive_rtc' {A : Type} (R : A -> A -> Prop) : Reflexive (rtc' R).
Proof.
  red. constructor.
Defined.

#[export]
Instance Transitive_rtc' {A : Type} (R : A -> A -> Prop) : Transitive (rtc' R).
Proof.
  red. intros x y z Hxy Hyz. revert z Hyz.
  induction Hxy; intros.
    assumption.
    eauto.
Defined.

Definition rtc'_trans := @Transitive_rtc'.

(** * Transitive closure *)

Inductive tc {A : Type} (R : A -> A -> Prop) : A -> A -> Prop :=
    | tc_singl :
        forall x y : A, R x y -> tc R x y
    | tc_cons  :
        forall x y z : A, R x y -> tc R y z -> tc R x z.

Lemma tc_trans :
  forall {A : Type} {R : A -> A -> Prop} {x y z : A},
    tc R x y -> tc R y z -> tc R x z.
Proof.
  intros * Hxy Hyz.
  revert z Hyz.
  induction Hxy; intros.
    econstructor 2; eassumption.
    econstructor 2.
      eassumption.
      apply IHHxy. assumption.
Qed.


(** * FunG_prog : Alternative definition of Hofstadter's G function *)

Require Import FunG.
Require Import Arith Omega Wf_nat List Program Program.Wf.
Set Implicit Arguments.

(** Same as [FunG.g_spec], but via the Program framework *)

Program Fixpoint g_spec n { measure n } : { r : nat | G n r } :=
 match n with
 | O => O
 | S n => S n - g_spec (g_spec n)
 end.
Next Obligation.
 destruct g_spec; simpl. apply le_n_S. now apply G_le.
Defined.
Next Obligation.
 program_simpl.
 destruct (g_spec _) as (a,Ha).
 program_simpl.
 destruct (g_spec _) as (b,Hb).
 program_simpl.
 eapply GS; eauto. change (S n = S n - b + b).
 generalize (G_le Ha) (G_le Hb). omega.
Defined.

Definition g n := let (a,_) := g_spec n in a.

(*Eval lazy in g 55.*) (* Compute is very slow... *)

(*Recursive Extraction g.*) (* TODO: des let-in parasites *)

(** This is just an alternative presentation... *)

Lemma nothing_new n : g n = FunG.g n.
Proof.
 apply G_fun with n.
 unfold g. now destruct g_spec.
 apply FunG.g_correct.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

(*i $Id: Classical_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Ensembles.
Require Export Constructive_sets.
Require Export Classical_Type.

Section Ensembles_classical.
  Variable U : Type.

  Lemma not_included_empty_Inhabited :
    forall A:Ensemble U, ~ Included U A (Empty_set U) -> Inhabited U A.
  Proof.
    intros A NI.
    elim (not_all_ex_not U (fun x:U => ~ In U A x)).
    intros x H; apply Inhabited_intro with x.
    apply NNPP; auto with sets.
    red in |- *; intro.
    apply NI; red in |- *.
    intros x H'; elim (H x); trivial with sets.
  Qed.

  Lemma not_empty_Inhabited :
    forall A:Ensemble U, A <> Empty_set U -> Inhabited U A.
  Proof.
    intros; apply not_included_empty_Inhabited.
    red in |- *; auto with sets.
  Qed.

  Lemma Inhabited_Setminus :
    forall X Y:Ensemble U,
      Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X).
  Proof.
    intros X Y I NI.
    elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI).
    intros x YX.
    apply Inhabited_intro with x.
    apply Setminus_intro.
    apply not_imply_elim with (In U X x); trivial with sets.
    auto with sets.
  Qed.

  Lemma Strict_super_set_contains_new_element :
    forall X Y:Ensemble U,
      Included U X Y -> X <> Y -> Inhabited U (Setminus U Y X).
  Proof.
    auto 7 using Inhabited_Setminus with sets.
  Qed.

  Lemma Subtract_intro :
    forall (A:Ensemble U) (x y:U), In U A y -> x <> y -> In U (Subtract U A x) y.
  Proof.
    unfold Subtract at 1 in |- *; auto with sets.
  Qed.
  Hint Resolve Subtract_intro : sets.

  Lemma Subtract_inv :
    forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y.
  Proof.
    intros A x y H'; elim H'; auto with sets.
  Qed.

  Lemma Included_Strict_Included :
    forall X Y:Ensemble U, Included U X Y -> Strict_Included U X Y \/ X = Y.
  Proof.
    intros X Y H'; try assumption.
    elim (classic (X = Y)); auto with sets.
  Qed.

  Lemma Strict_Included_inv :
    forall X Y:Ensemble U,
      Strict_Included U X Y -> Included U X Y /\ Inhabited U (Setminus U Y X).
  Proof.
    intros X Y H'; red in H'.
    split; [ tauto | idtac ].
    elim H'; intros H'0 H'1; try exact H'1; clear H'.
    apply Strict_super_set_contains_new_element; auto with sets.
  Qed.

  Lemma not_SIncl_empty :
    forall X:Ensemble U, ~ Strict_Included U X (Empty_set U).
  Proof.
    intro X; red in |- *; intro H'; try exact H'.
    lapply (Strict_Included_inv X (Empty_set U)); auto with sets.
    intro H'0; elim H'0; intros H'1 H'2; elim H'2; clear H'0.
    intros x H'0; elim H'0.
    intro H'3; elim H'3.
  Qed.

  Lemma Complement_Complement :
    forall A:Ensemble U, Complement U (Complement U A) = A.
  Proof.
    unfold Complement in |- *; intros; apply Extensionality_Ensembles;
      auto with sets.
    red in |- *; split; auto with sets.
    red in |- *; intros; apply NNPP; auto with sets.
  Qed.

End Ensembles_classical.

 Hint Resolve Strict_super_set_contains_new_element Subtract_intro
  not_SIncl_empty: sets v62.


(*|
===============================================
TAPFA - Partie Coq - Modules et Types Abstraits
===============================================

:Auteurs: Jean-Paul Bodeveix (resp. UE), Erik Martin-Dorel, Pierre Roux
:Date:    L3 Info, Semestre 6, Année 2021-2022

Supports de ce cours :

-  https://pfitaxel.github.io/tapfa-coq-alectryon/

Modules en Coq et application aux TAD
=====================================

1. Spécification de modules (types de modules)
----------------------------------------------

Déclaration d’identificateurs.

On distingue :

-  des identificateurs de types

-  des identificateurs de constantes ou d’opérations

-  des identificateurs de propriétés (axiomes)

Exemple

.. coq::
|*)
Module Type Monoide.
  Parameter T : Type.           (* une sorte *)
  Parameter un : T.             (* une constante *)
  Parameter prod : T -> T -> T. (* une opération *)

  Axiom assoc :
    forall x y z : T, prod x (prod y z) = prod (prod x y) z.
  Axiom neutre_g : forall x, prod un x = x.
  Axiom neutre_d : forall x, prod x un = x.
End Monoide.
(*|

2. Modules réalisant une spécification
--------------------------------------

Définition des identificateurs déclarés dans la spécification

Implantations possibles du monoide :

-  entiers avec :math:`0` et :math:`+`

-  entiers avec :math:`1` et :math:`*`

-  listes avec concaténation

-  type singleton

-  …

2. Modules réalisant une spécification
--------------------------------------

Exemple : monoide des listes avec concaténation

.. coq::
|*)
Require Import List. Import ListNotations.
Set Implicit Arguments.

Module MonoList <: Monoide. (* vérification sans masquage *)
  Definition T := list nat.
  Definition un : T := [].
  Definition prod (x y : T) := x ++ y.

  Lemma assoc :
    forall x y z : T, prod x (prod y z) = prod (prod x y) z.
  Proof. apply app_assoc. Qed.

  Lemma neutre_g : forall x, prod un x = x.
  Proof. reflexivity. Qed.

  Lemma neutre_d : forall x, prod x un = x.
  Proof. induction x; auto. simpl. rewrite IHx. reflexivity. Qed.
End MonoList.
(*|

3. Utilisation indépendante de l’implantation (foncteur)
--------------------------------------------------------

Exemple : unicité de l’élément neutre

.. coq::
|*)
Module Use(M : Monoide).
  Theorem unicite :
    forall u : M.T, (forall x, M.prod x u = x) -> u = M.un.
  Proof.
  intros u Hu.
  rewrite <-(Hu M.un).
  rewrite M.neutre_g.
  reflexivity.
  Qed.
End Use.
(*|

4. Instantiation du foncteur (a.k.a. module paramétré)
------------------------------------------------------

Exemple

.. coq::
|*)
Module Inst := Use(MonoList).
  Check Inst.unicite.  (* .unfold *)

  Print MonoList.un.  (* .unfold *)
  Print MonoList.T.  (* .unfold *)
(*|

Exemple autour de la structure de pile
======================================

Signature d’un TAD Pile
-----------------------

Ecrire la spécification du type abstrait tPile introduisant un type
Elem, un type P, et les opérations habituelles sur les piles. On
essaiera d’étendre au maximum le domaine des fonctions partielles (par
ex. en retournant la pile vide), ou si besoin en utilisant le type
option :

.. coq::
|*)
Inductive option {T : Type} := None | Some (valeur : T).

Module Type Pile.
  Parameter Elem : Type.
  Parameter P : Type.
  Parameter vide : P.
  Parameter push : Elem -> P -> P.
  Parameter estVide : P -> bool.
  Parameter top : P -> @option Elem.
  Parameter pop : P -> P.
  (* et pas "P -> option P" :
   * choix de conception pour simplifier les preuves *)

  Axiom estVide_vide : estVide vide = true.
  Axiom estVide_push : forall p e, estVide (push e p) = false.
  Axiom top_vide : top vide = None.
  Axiom top_push : forall p e, top (push e p) = Some e.
  Axiom pop_vide : pop vide = vide.
  Axiom pop_push : forall p e, pop (push e p) = p.
End Pile.
(*|

Implémentation du TAD Pile
--------------------------

Implémentez un TAD Pile d’entiers naturels,
en vous appuyant sur la bibliothèque des listes.

.. coq::
|*)
Module Pile_Liste <: Pile.
  Definition Elem := nat.
  Definition P := list nat.
  Definition vide : P := [].
  Definition push (e : Elem) (p : P) := e :: p.
  Definition estVide (p : P) :=
    match p with [] => true | _ => false end.
  Definition top (p : P) :=
    match p with [] => None | x :: _ => Some x end.
  Definition pop (p : P) :=
    match p with [] => [] | _ :: l => l end.

  Lemma estVide_vide : estVide vide = true.
  Proof. reflexivity. Qed.

  Lemma estVide_push : forall p e, estVide (push e p) = false.
  Proof. intros p e. reflexivity. Qed.

  Lemma top_vide : top vide = None.
  Proof. reflexivity. Qed.

  Lemma top_push : forall p e, top (push e p) = Some e.
  Proof. intros p e. reflexivity. Qed.

  Lemma pop_vide : pop vide = vide.
  Proof. reflexivity. Qed.

  Lemma pop_push : forall p e, pop (push e p) = p.
  Proof. intros p e. reflexivity. Qed.
End Pile_Liste.
(*|

Autre exemple d’implémentation
------------------------------

Peut-on implémenter le même TAD avec des
listes, mais en empilant et dépilant en queue ?

.. coq::
|*)
Module Pile_QListe <: Pile.
  Definition Elem := nat.
  Definition P := list nat.
  Definition vide : P := [].
  Definition push (e : Elem) (p : P) := p ++ [e].
  Definition estVide (p : P) :=
    match p with [] => true | _ => false end.
  Fixpoint top (p : P) :=
    match p with [] => None | [e] => Some e | x:: l => top l end.
  Fixpoint pop (p : P) :=
    match p with [] => [] | [e] => [] | x :: l => x :: pop l end.

  Lemma estVide_vide : estVide vide = true.
  Proof. reflexivity. Qed.

  Lemma estVide_push : forall p e, estVide (push e p) = false.
  Proof. induction p; simpl; auto. Qed.

  Lemma top_vide : top vide = None.
  Proof. reflexivity. Qed.

  Lemma top_push : forall p e, top (push e p) = Some e.
  Proof. induction p; auto; destruct p; auto. Qed.

  Lemma pop_vide : pop vide = vide.
  Proof. reflexivity. Qed.

  Lemma pop_push : forall p e, pop (push e p) = p.
  Proof.
  induction p; auto.
  destruct p; auto.
  intros e; rewrite <-(IHp e) at 2; auto.
  Qed.
End Pile_QListe.


(** * Anticlique graph : an infinite graph with no edge *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import notations decidable_prop list_dec.
Require Import equiv_obs sem_obs.
Require Import laws.

Section s.
  Context {V : Set} {decV : decidable_set V}.
  Hypothesis infiniteV : forall l : list V, exists a : V, ~ a ∈ l.
  Context { a__o : V}.

  (** * Definition of the graph *)
  Instance Ω : Graph :=
    {
    vertex := V;
    coh := @eq V;
    coh_refl := @eq_Reflexive V;
    coh_sym := @eq_Symmetric V
    }.

  Instance decΩ : DecidableGraph Ω.
  Proof.
    split.
    - exact decV.
    - intros;apply DecidableProp_Eq,decV.
  Qed.

  (** * Axiomatisation *)
  Reserved Notation " x =Ω y " (at level 80).
  Inductive Ω_ax : relation observation :=
  | Ω_top' a b : ⦑a⦒⟇(⦑a⦒→⊥o) =Ω ⦑b⦒⟇(⦑b⦒→⊥o)
  | Ω_neg (X : list V) : ((⋁ (map o_obs X))→⊥o)→⊥o =Ω ⋁ (map o_obs X)
  where " x =Ω y " := (Ω_ax x y).
  Notation axΩ := (ha_ax (+) (obs_ax (+) Ω_ax)).
  Hint Constructors Ω_ax : core.

  Remark eo_Ω_top' a b : axΩ ⊢ ⦑a⦒⟇(⦑a⦒→⊥o) ≡ ⦑b⦒⟇(⦑b⦒→⊥o).
  Proof. auto with equiv_obs. Qed.
  Remark eo_Ω_neg X : axΩ ⊢ ((⋁ (map o_obs X))→⊥o)→⊥o ≡ ⋁ (map o_obs X).
  Proof. auto with equiv_obs. Qed.

  (** * Basic laws *)
  Notation "⊤'" := (⦑ a__o ⦒ ⟇ (⦑ a__o ⦒→⊥o)).

  Lemma top'_a a : axΩ ⊢ ⦑a⦒ ≦ ⊤'.
  Proof.
    transitivity (⦑ a ⦒⟇(⦑ a ⦒ → ⊥o));
      [apply eo_inf_or_left;reflexivity|].
    erewrite eo_Ω_top';reflexivity.
  Qed.

  Lemma top'_not_a a : axΩ ⊢ ⦑a⦒ → ⊥o ≦ ⊤'.
  Proof.
    transitivity (⦑ a ⦒⟇(⦑ a ⦒ → ⊥o));
      [apply eo_inf_or_right;reflexivity|].
    erewrite eo_Ω_top';reflexivity.
  Qed.

  Lemma top'_or_neg a b :
    a <> b -> axΩ ⊢ ⊤' ≦ (⦑ a ⦒ → ⊥o) ⟇ (⦑ b ⦒ → ⊥o).
  Proof.
    intros h.
    rewrite (eo_Ω_top' a__o a).
    unfold__lat.
    - apply eo_inf_or_right,eo_heyting.
      rewrite<- eo_eq_bot_iff_inf_bot.
      auto with equiv_obs.
    - apply eo_inf_or_left;reflexivity.
  Qed.
   Lemma neg_neg_axΩ a : axΩ ⊢ (⦑a⦒ → ⊥o)→ ⊥o ≡ ⦑a⦒.
  Proof.
    transitivity (⋁(map o_obs [a]));[|simpl;apply eo_or_bot].
    rewrite <- eo_Ω_neg.
    apply eo_impl;[|reflexivity].
    apply eo_impl;[|reflexivity].
    simpl;symmetry;apply eo_or_bot.
  Qed.

  Lemma neg_top'_is_bot :
    axΩ ⊢ ⊤' → ⊥o ≡ ⊥o.
  Proof. rewrite eo_impl_distr_left;apply eo_contradict. Qed.

  Lemma weak_excluded_middle u :
    axΩ ⊢ ⊤' ≦ ⋁ (map o_obs u) ⟇ (⋁ (map o_obs u) → ⊥o).
  Proof.
    rewrite eo_impl_Join,or_Meet,map_map.
    apply obs_Meet;intros x hx;apply in_map_iff in hx as (y&<-&hy).
    apply in_map_iff in hy as (a&<-&ha).
    rewrite (eo_Ω_top' _ a).
    apply o_or_inf;[apply eo_inf_in_Join,in_map_iff;exists a;tauto
                   |reflexivity].
  Qed.

  Remark Meet_not_and_sgl_not_in x u :
    ~ x ∈ u -> axΩ ⊢ ⋀ (map (fun a => ⦑ a ⦒ → ⊥o) u) ⟑ ⦑ x ⦒ ≡ ⦑ x ⦒.
  Proof.
    intro h.
    rewrite eo_and_comm,<- eo_inf_o_and.
    apply obs_Meet.
    intros y hy;apply in_map_iff in hy as (a&<-&ha).
    apply eo_heyting.
    rewrite <- eo_eq_bot_iff_inf_bot.
    cut (x ⌣ a);[auto with equiv_obs|intros <-].
    tauto.
  Qed.

  Remark Meet_not_and_sgl_in x u :
    x ∈ u ->
    axΩ ⊢ ⋀ (map (fun a : V => ⦑ a ⦒ → ⊥o) u) ⟑ ⦑ x ⦒ ≡ ⊥o.
  Proof.
    intro h.
    split_order;[|apply eo_inf_bot].
    rewrite eo_and_comm.
    etransitivity;[|eapply eq_obs_inf_obs,eo_contradict].
    apply o_and_inf;[reflexivity|].
    apply eo_inf_in_Meet,in_map_iff;exists x;tauto.
  Qed.

  (** * Representations *)
  Definition Obs__Ω := option (list V + list V)%type.
  Definition V' := option V.

  Instance sat__Ω : Satisfaction V' Obs__Ω :=
    fun x (o : Obs__Ω) =>
      match x,o with
      | _,None => True
      | Some a,Some (inl u) => ~ a ∈ u
      | Some a,Some (inr u) => a ∈ u
      | _,_ => False
      end.

  Definition inf__Ω : Obs__Ω -> Obs__Ω -> bool :=
    fun x y =>
      match x,y with
      | _,None => true
      | Some(inl u),Some(inl v)
      | Some(inr v),Some(inr u) => inclb v u
      | Some(inr u),Some(inl v) => (u ∩ v) =?= []
      | _,_ => false
      end.

  Lemma complete_inf__Ω s t : inf__Ω s t = true <-> s ≲ t.
  Proof.
    destruct s as [[u|u]|], t as [[v|v]|];simpl;try tauto.
    - rewrite inclb_correct;split.
      + intros h [a|];unfold satisfies;simpl;[pose proof (h a)|];tauto.
      + intros h a ha.
        case_in a u;[tauto|].
        exfalso;apply (h (Some a)).
        * apply I.
        * apply ha.
    - split;[discriminate|].
      intro f;exfalso.
      destruct (infiniteV (u++v)) as [a ha].
      rewrite in_app_iff in ha.
      case_in a u;[tauto|].
      apply (f (Some a)) in I;apply ha;right;apply I.
    - split;[intros _|reflexivity].
      intros [] _;exact I.
    - rewrite eqX_correct;split.
      + intros e [a|] ha;unfold satisfies in *;simpl in *.
        * intros f;cut (a ∈ []);[simpl;tauto|].
          rewrite <-e ;apply intersect_spec;tauto.
        * tauto.
      + intros h;apply incl_l_nil.
        intros a ha;apply intersect_spec in ha as (hu&hv);simpl.
        revert hv;apply (h (Some a)),hu.
    - rewrite inclb_correct;split.
      + intros h [a|];unfold satisfies;simpl;[pose proof (h a)|];tauto.
      + intros h a ha.
        apply (h (Some a)),ha.
    - split;[intros _|reflexivity].
      intros [] _;exact I.
    - split;[discriminate|].
      intros f;exfalso;apply (f None),I.
    - split;[discriminate|].
      intros f;exfalso;apply (f None),I.
    - split;reflexivity.
  Qed.

  (** * Cliques are either empty or singletons *)
  Remark cliques_at_most_one_elt (α : clique) a b :
    a ⊨ α -> b ⊨ α -> a = b.
  Proof. apply (members_are_coh α). Qed.

  Corollary mem_is_sgl (α : clique) a : a ⊨ α <-> α ≃ sgl a.
  Proof.
    split;[|intros e;apply e,sgl_spec;reflexivity].
    intros h1 b.
    (* unfold satisfies,satClique at 1;simpl. *)
    (* unfold satClique. *)
    rewrite (sgl_spec b a).
    split.
    - intros h2;eapply cliques_at_most_one_elt;assumption.
    - intros ->;assumption.
  Qed.

  (** * Isomorphism between cliques and [option V] *)
  Definition ξ : V' -> clique :=
    fun x => match x with None => empt | Some a => sgl a end.

  Definition ζ : clique -> V' :=
    fun α =>
      match (incompat α a__o) with
      | Some a => Some a
      | None => if member α a__o then Some a__o else None
      end.

  Lemma ζ_Some α a : ζ α = Some a -> α ≃ sgl a.
  Proof.
    unfold ζ;case_eq (incompat α a__o).
    - intros b eb e;inversion e;subst.
      apply incompat_Some in eb.
      apply mem_is_sgl,eb.
    - intros h;case_eq (member α a__o);[|discriminate].
      intros ea e;inversion e;subst.
      apply mem_is_sgl,Is_true_eq_left,ea.
  Qed.

  Lemma ζ_None α : ζ α = None -> α ≃ empt.
  Proof.
    unfold ζ;case_eq (incompat α a__o);[discriminate|].
    intros h;case_eq (member α a__o);[discriminate|].
    rewrite <-not_true_iff_false,<-Is_true_iff_eq_true.
    intros h' _ a;split;[|intro f;exfalso;apply f].
    intros e;apply mem_is_sgl in e;apply h',e,sgl_spec.
    apply (incompat_None _ h),e,sgl_spec;reflexivity.
  Qed.

  Corollary ξ_ζ α : ξ (ζ α) ≃ α.
  Proof. symmetry;case_eq (ζ α);[apply ζ_Some|apply ζ_None]. Qed.

  Lemma ζ_sgl a : ζ (sgl a) = Some a.
  Proof.
    unfold ζ;case_eq (incompat (!(@sgl__f Ω _ a)) a__o).
    - intros b eb;f_equal.
      apply sgl_spec.
      eapply incompat_Some,eb.
    - intros h;case_eq (member (!(@sgl__f Ω _ a)) a__o).
      + intro e;apply Is_true_iff_eq_true,sgl_spec in e as ->.
        reflexivity.
      + rewrite <-not_true_iff_false,<-Is_true_iff_eq_true.
        intros f;exfalso.
        destruct_eqX a__o a.
        * apply f,sgl_spec;reflexivity.
        * apply N,(incompat_None _ h),sgl_spec;reflexivity.
  Qed.

  Lemma ζ_empt : ζ empt = None.
  Proof.  reflexivity. Qed.

  Corollary ζ_ξ x : ζ(ξ x) = x.
  Proof. destruct x as [a|];[apply ζ_sgl|apply ζ_empt]. Qed.

  (** * The axioms are sound *)
  Proposition axΩ_sound : subrelation axΩ sequiv.
  Proof.
    intros _ _ [s t h|_ _ [s t h|_ _ [a b|X]]].
    - apply ha_sound,h.
    - apply Obs_sound,jright,h.
    - destruct_eqX a b;[reflexivity|].
      intro α.
      rewrite <- (ξ_ζ α);rsimpl.
      setoid_rewrite sat_at.
      setoid_rewrite sat_bot.
      destruct (ζ α) as [c|].
      + simpl;setoid_rewrite sgl_spec.
        split;intros _;[destruct_eqX b c|destruct_eqX a c];
          (now left)||right;intros y hy;apply mem_is_sgl in hy as ->.
        * intros f;apply N0,symmetry;apply sgl_spec,f,sgl_spec.
          reflexivity.
        * intros f;apply N0,symmetry;apply sgl_spec,f,sgl_spec.
          reflexivity.
      + unfold satisfies at 1 3,satClique;simpl.
        split;(intros [h|h];exfalso;[apply h|]);
          [apply (h(sgl a))|apply (h (sgl b))];
          (apply sgl_spec;reflexivity)||apply (@empt_max Ω).
    - intros α;rsimpl.
      setoid_rewrite sat_bot.
      rewrite satisfies_Join.
      setoid_rewrite sat_impl.
      setoid_rewrite satisfies_Join.
      setoid_rewrite in_map_iff.
      setoid_rewrite sat_bot.
      split.
      + pose proof (ξ_ζ α) as e;setoid_rewrite <- e.
        destruct (ζ α) as [a|];simpl.
        * intros h.
          case_in a X.
          -- eexists ;split.
             ++ exists a;tauto.
             ++ apply sat_at,sgl_spec;reflexivity.
          -- exfalso;apply (h (!(@sgl__f Ω _ a)));[|reflexivity].
             intros y (x&(b&<-&hb)&e').
             apply sat_at,mem_is_sgl in e' as ->.
             intros f;destruct_eqX a b;[tauto|].
             apply N,(@sgl_spec Ω _ a b),f,sgl_spec;reflexivity.
        * destruct(infiniteV X) as [a ha].
          intros h;exfalso;apply (h (!(@sgl__f Ω _ a)));
            [|apply (@empt_max Ω)].
          intros y (x&(b&<-&hb)&e').
          apply sat_at,mem_is_sgl in e' as ->.
          intros f;destruct_eqX a b;[tauto|].
          apply N,(@sgl_spec Ω _ a b),f,sgl_spec;reflexivity.
      + intros (x&(a&<-&ha)&e);apply mem_is_sgl in e.
        setoid_rewrite e.
        intros y h1 h2.
        apply (h1 (!(@sgl__f Ω _ a))).
        * eexists;split;[exists a;tauto|].
          apply sat_at,sgl_spec;reflexivity.
        * intros b hb.
          apply sgl_spec;symmetry;apply sgl_spec.
          apply mem_is_sgl in hb.
          apply hb,h2,sgl_spec;reflexivity.
  Qed.

  Corollary inf_axΩ_sound s t :
    axΩ ⊢ s ≦ t -> s ≲ t.
  Proof.
    intro h;apply eo_sound in h as <-;[|apply axΩ_sound].
    intro;rsimpl;tauto.
  Qed.
  Corollary eq_axΩ_sound s t :
    axΩ ⊢ s ≡ t -> s ≃ t.
  Proof.
    intro h;apply eo_sound in h as <-;[|apply axΩ_sound].
    intro;simpl;tauto.
  Qed.

  (** * From representations to terms *)
  Definition τ (o : Obs__Ω) : observation :=
    match o with
    | None => ⊤o
    | Some (inl u) =>
      if u =?= []
      then ⊤'
      else ⋀ (map (fun a => ⦑ a ⦒ → ⊥o) u)
    | Some (inr u) => ⋁ (map o_obs u)
    end.

  Lemma τ_ζ α o : α ⊨ (τ o) -> ζ α ⊨ o.
  Proof.
    case_eq (ζ α).
    - intros a ea;apply ζ_Some in ea as ->.
      unfold satisfies at 2.
      destruct o as [[u|u]|];simpl.
      + destruct_eqX u (@nil V).
        * simpl;tauto.
        * intros h1 h2.
          (* cut (sgl a ⊨ (⦑a⦒→⊥o)). *)
          cut (@satisfies _ _ satObs (sgl a) (⦑a⦒→⊥o)).
          -- rsimpl;intros f.
             cut (@satisfies _ _ satObs (sgl a) ⊥o).
             ++ rsimpl;tauto.
             ++ apply f;[simpl;apply sgl_spec|];reflexivity.
          -- rewrite satisfies_Meet in h1.
             apply h1,in_map_iff;exists a;tauto.
      + intros h;apply satisfies_Join in h as (x&hx&h).
        apply in_map_iff in hx as (b&<-&hb);rsimpl in *.
        apply sgl_spec in h;subst;tauto.
      + tauto.
    - intro h;apply ζ_None in h as ->.
      unfold satisfies at 2.
      destruct o as [[u|u]|];simpl;[| |intro h;apply h];intro f;exfalso.
      + destruct_eqX u (@nil V).
        * destruct f as [f|f];simpl in f.
          -- tauto.
          -- apply (f (!(@sgl__f Ω _ a__o))).
             ++ apply sgl_spec;reflexivity.
             ++ apply (empt_max (!(@sgl__f Ω _ a__o))).
        * destruct u as [|a u];[tauto|cut (empt ⊨ (⦑a⦒→⊥o))].
          -- rsimpl.
             setoid_rewrite sat_at.
             setoid_rewrite sat_bot.
             intro ff.
             apply (ff (!(@sgl__f Ω _ a))).
             ++ apply sgl_spec;reflexivity.
             ++ apply (@empt_max Ω).
          -- apply f.
      + apply satisfies_Join in f as (x&hx&h).
        apply in_map_iff in hx as (a&<-&ha).
        apply h.
  Qed.

  Lemma τ_ξ α o : α ⊨ o -> ξ α ⊨ (τ o).
  Proof.
    unfold satisfies at 1,sat__Ω; destruct o as [[u|u]|],α as [b|];simpl;
      rsimpl;try tauto.
    - destruct_eqX u (@nil V);simpl.
      + intros _;rsimpl.
        destruct_eqX b a__o.
        * left;apply sgl_spec;reflexivity.
        * right.
          intros y h1 h2;rsimpl in *.
          apply mem_is_sgl in h1.
          rewrite h1 in h2.
          apply N.
          apply (@sgl_spec Ω _ b a__o),h2,sgl_spec;reflexivity.
      + intros hv;rewrite satisfies_Meet.
        intros x hx;apply in_map_iff in hx as (a&<-&ha).
        rsimpl;intros y h1 h2;rsimpl in *.
        apply mem_is_sgl in h1.
        rewrite h1 in h2.
        replace a with b in *;[tauto|].
        apply (@sgl_spec Ω _ b a),h2,sgl_spec;reflexivity.
    - intro h;apply satisfies_Join;eexists;split.
      + apply in_map_iff;exists b;split;[reflexivity|assumption].
      + apply sat_at,sgl_spec;reflexivity.
  Qed.

  Lemma sound_τ_sat__Ω α o : α ⊨ (τ o) <-> ζ α ⊨ o.
  Proof.
    split;[apply τ_ζ|].
    rewrite <- (ξ_ζ α) at 2.
    apply τ_ξ.
  Qed.

  Instance τ_proper_inf__Ω : Proper (ssmaller ==> inf_obs axΩ) τ.
  Proof.
    intros u v; rewrite <- complete_inf__Ω.
    destruct u as [[u|u]|], v as [[v|v]|];simpl;
      try discriminate||rewrite inclb_correct||rewrite eqX_correct;
      intros hyp.
    - destruct_eqX u (@nil V);destruct_eqX v (@nil V).
      + reflexivity.
      + exfalso.
        apply incl_l_nil in hyp as ->;tauto.
      + destruct u as [|a u];[tauto|].
        apply eo_inf_and_left,top'_not_a.
      + unfold__lat.
        apply eo_inf_in_Meet,in_map_iff;exists a;split;[reflexivity|].
        apply hyp,ha.
    - apply eo_inf_top.
    - unfold__lat.
      destruct_eqX v (@nil V).
      + apply top'_a.
      + unfold__lat.
        rewrite <-eo_heyting,<-eo_eq_bot_iff_inf_bot.
        apply eo_ax,jright,jleft,obs_incoh.
        intros <-;cut (a ∈ (u∩v));[rewrite hyp;simpl
                                 |apply intersect_spec];
          tauto.
    - unfold__lat.
      apply eo_inf_in_Join,in_map_iff;exists a;split;
        [reflexivity|apply hyp,ha].
    - apply eo_inf_top.
    - reflexivity.
  Qed.

  Instance dec_inf__Ω x y : DecidableProp (x ≲ y).
  Proof.
    case_eq (inf__Ω x  y);intro e;[left|right];
      rewrite <-complete_inf__Ω,e;[reflexivity|discriminate].
  Qed.

  (** * From terms to reprentations *)
  Fixpoint to_Obs__Ω s : Obs__Ω :=
    match s with
    | ⊥o => Some (inr [])
    | ⊤o => None
    | ⦑a⦒ => Some (inr [a])
    | s⟇t => match (to_Obs__Ω s),(to_Obs__Ω t) with
            | None,_ | _,None => None
            | Some(inl u),Some(inl v) => Some(inl (u∩v))
            | Some(inr u),Some(inr v) => Some(inr (u++v))
            | Some(inl u),Some(inr v)
            | Some(inr v),Some(inl u) => Some(inl (u−v))
            end
    | s⟑t => match (to_Obs__Ω s),(to_Obs__Ω t) with
    | Some(inl u),Some(inl v) => Some(inl (u++v))
    | Some(inr u),Some(inr v) => Some(inr (u∩v))
    | Some(inl u),Some(inr v)
    | Some(inr v),Some(inl u) => Some(inr (v−u))
    | None,z | z,None => z
    end
    | s→t =>
        if inf__Ω (to_Obs__Ω s) (to_Obs__Ω t)
        then None
        else
          match (to_Obs__Ω s),(to_Obs__Ω t) with
          | x,None | None,x => x
          | Some (inl u),Some (inl v) => Some (inl (v − u))
          | Some (inr u),Some (inl v) => Some (inl (u ∩ v))
          | Some (inl u),Some (inr v) => Some (inr (u ++ v))
          | Some (inr u),Some (inr v) => Some (inl (u − v))
          end
    end.

  Lemma τ_join__Ω s t :
    axΩ ⊢ τ (to_Obs__Ω (s ⟇ t)) ≡ τ (to_Obs__Ω s) ⟇ τ (to_Obs__Ω t).
  Proof.
    simpl;destruct (to_Obs__Ω s) as [[u|u]|],
        (to_Obs__Ω t) as [[v|v]|];simpl.
    - destruct_eqX (u∩v) (@nil V).
      + destruct_eqX u (@nil V);destruct_eqX v (@nil V).
        * symmetry;apply eo_or_idem.
        * split_order;[apply eo_inf_or_left;reflexivity|].
          apply obs_join;[reflexivity|].
          destruct v;[tauto|apply eo_inf_and_left].
          apply top'_not_a.
        * split_order;[apply eo_inf_or_right;reflexivity|].
          apply obs_join;[|reflexivity].
          destruct u;[tauto|apply eo_inf_and_left].
          apply top'_not_a.
        * split_order.
          -- rewrite (Meet_or_Meet (map _ u) (map _ v)).
             unfold_meet.
             destruct a as (a1&a2).
             apply pairs_spec in ha as (h1&h2).
             apply in_map_iff in h1 as (a&<-&ha).
             apply in_map_iff in h2 as (b&<-&hb);simpl.
             apply top'_or_neg.
             intros ->.
             cut (b ∈ []);[simpl;tauto|].
             rewrite <-E,intersect_spec;tauto.
          -- unfold__lat.
             ++ destruct u as [|a u];[tauto|simpl].
                apply eo_inf_and_left.
                apply top'_not_a.
             ++ destruct v as [|a v];[tauto|simpl].
                apply eo_inf_and_left.
                apply top'_not_a.
      + destruct_eqX u (@nil V);destruct_eqX v (@nil V);simpl in *;
          try tauto.
        * exfalso;apply N,incl_l_nil;intro.
          rewrite intersect_spec;simpl;tauto.
        * split_order.
          -- rewrite Meet_or_Meet.
             unfold__lat.
             destruct a as (?&?);apply pairs_spec in ha as (h1&h2).
             apply in_map_iff in h1 as (a&<-&ha).
             apply in_map_iff in h2 as (b&<-&hb);simpl.
             destruct_eqX a b.
             ++ apply eo_inf_or_left,eo_inf_in_Meet,in_map_iff.
                exists b;split;[reflexivity|].
                apply intersect_spec;tauto.
             ++ etransitivity;[clear a b ha hb N2 N0 N1
                              |apply (top'_or_neg N2)].
                destruct (u∩v) as [|a uv];[tauto|simpl].
                apply eo_inf_and_left,top'_not_a.
          -- unfold__lat;apply eo_inf_in_Meet,in_map_iff;
               apply intersect_spec in ha as (h1&h2);exists a;tauto.
    - destruct_eqX u (@nil V);[|destruct_eqX (u − v) (@nil V)].
      + split_order.
        * apply eo_inf_or_left;reflexivity.
        * unfold__lat;apply top'_a||apply top'_not_a.
      + split_order;[|unfold__lat].
        * rewrite (eo_or_comm (⋀ (map _ u)) (⋁ (map _ v))).
          rewrite or_Meet,map_map.
          unfold_meet.
          rewrite (eo_Ω_top' a__o a);apply obs_join.
          -- apply eo_inf_or_left,eo_inf_in_Join,in_map_iff.
             exists a;split;[reflexivity|].
             case_in a v;[tauto|].
             exfalso;cut (a ∈ []);[simpl;tauto|].
             rewrite <- E;apply difference_spec;tauto.
          -- apply eo_inf_or_right;reflexivity.
        * destruct u as [|a u];[tauto|simpl].
          apply eo_inf_and_left,top'_not_a.
        * apply top'_a.
      + split_order;[rewrite eo_or_comm,or_Meet,map_map|]; unfold__lat.
        * case_in a v.
          -- transitivity ⊤'.
             ++ destruct (u−v) as [|b uv];[tauto|simpl].
                apply eo_inf_and_left,top'_not_a.
             ++ rewrite (eo_Ω_top' a__o a);unfold__lat.
                ** apply eo_inf_or_left,eo_inf_in_Join,in_map_iff.
                   exists a;tauto.
                ** apply eo_inf_or_right;reflexivity.
          -- apply eo_inf_or_right,eo_inf_in_Meet,in_map_iff.
             exists a;split;[reflexivity|].
             apply difference_spec;tauto.
        * apply eo_inf_in_Meet,in_map_iff.
          exists a;apply difference_spec in ha;tauto.
        * apply eo_heyting.
          rewrite <- eo_eq_bot_iff_inf_bot.
          cut (a ⌣ a0);[auto with equiv_obs|intros <-].
          apply difference_spec in ha0;tauto.
    - symmetry;apply eo_or_top.
    - destruct_eqX v (@nil V);[|destruct_eqX (v − u) (@nil V)].
      + split_order.
        * apply eo_inf_or_right;reflexivity.
        * unfold__lat;apply top'_a||apply top'_not_a.
      + split_order;[|unfold__lat].
        * rewrite or_Meet,map_map.
          unfold_meet.
          rewrite (eo_Ω_top' a__o a);apply obs_join.
          -- apply eo_inf_or_left,eo_inf_in_Join,in_map_iff.
             exists a;split;[reflexivity|].
             case_in a u;[tauto|].
             exfalso;cut (a ∈ []);[simpl;tauto|].
             rewrite <- E;apply difference_spec;tauto.
          -- apply eo_inf_or_right;reflexivity.
        * apply top'_a.
        * destruct v as [|a v];[tauto|simpl].
          apply eo_inf_and_left,top'_not_a.
      + split_order;[rewrite or_Meet,map_map|];unfold__lat.
        * case_in a u.
          -- transitivity ⊤'.
             ++ destruct (v−u) as [|b uv];[tauto|simpl].
                apply eo_inf_and_left,top'_not_a.
             ++ rewrite (eo_Ω_top' a__o a);unfold__lat.
                ** apply eo_inf_or_left,eo_inf_in_Join,in_map_iff.
                   exists a;tauto.
                ** apply eo_inf_or_right;reflexivity.
          -- apply eo_inf_or_right,eo_inf_in_Meet,in_map_iff.
             exists a;split;[reflexivity|].
             apply difference_spec;tauto.
        * apply eo_heyting.
          rewrite <- eo_eq_bot_iff_inf_bot.
          cut (a ⌣ a0);[auto with equiv_obs|intros <-].
          apply difference_spec in ha0;tauto.
        * apply eo_inf_in_Meet,in_map_iff.
          exists a;apply difference_spec in ha;tauto.
    - rewrite map_app;apply Join_app.
    - symmetry;apply eo_or_top.
    - symmetry;etransitivity;[apply eo_or_comm|apply eo_or_top].
    - symmetry;etransitivity;[apply eo_or_comm|apply eo_or_top].
    - symmetry;apply eo_or_top.
  Qed.

  Lemma τ_meet__Ω s t :
    axΩ ⊢ τ (to_Obs__Ω (s ⟑ t)) ≡ τ (to_Obs__Ω s) ⟑ τ (to_Obs__Ω t).
  Proof.
    simpl;destruct (to_Obs__Ω s) as [[u|u]|],(to_Obs__Ω t) as [[v|v]|];simpl.
    - destruct_eqX (u++v) (@nil V).
      + apply app_eq_nil in E as (->&->);rewrite eqX_refl.
        symmetry;apply eo_and_idem.
      + destruct_eqX u (@nil V);
          destruct_eqX v (@nil V);[subst;simpl in *;tauto| | |].
        * simpl in *.
          symmetry;rewrite eo_and_comm.
          apply eo_inf_o_and.
          destruct v as [|a v];[tauto|simpl].
          apply eo_inf_and_left,top'_not_a.
        * rewrite app_nil_r in *.
          symmetry;apply eo_inf_o_and.
          destruct u as [|a u];[tauto|simpl].
          apply eo_inf_and_left,top'_not_a.
        * rewrite map_app;apply Meet_app.
    - destruct_eqX u (@nil V).
      + replace (v − []) with v by
            (clear;induction v;simpl;[|rewrite <- IHv];reflexivity).
        symmetry;rewrite eo_and_comm.
        apply eo_inf_o_and.
        unfold_join;apply top'_a.
      + rewrite and_Join,map_map.
        split_order;unfold__lat.
        * apply difference_spec in ha as (ha1&ha2).
          etransitivity;[|apply eo_inf_in_Join,in_map_iff;exists a;split;
                          [reflexivity|assumption]].
          unfold__lat;[|reflexivity].
          apply eo_heyting;rewrite <- eo_eq_bot_iff_inf_bot.
          cut (a ⌣ a0);[auto with equiv_obs|intros <-].
          tauto.
        * case_in a u.
          -- etransitivity;[|apply eo_inf_bot].
             etransitivity;[apply o_and_inf;
                            [apply eo_inf_in_Meet,in_map_iff;
                             exists a;tauto
                            |reflexivity]|].
             apply eo_heyting;reflexivity.
          -- apply eo_inf_and_right,eo_inf_in_Join,in_map_iff.
             exists a;split;[reflexivity|].
             apply difference_spec;tauto.
    - symmetry;apply eo_and_top.
    - destruct_eqX v (@nil V).
      + replace (u − []) with u by
            (clear;induction u;simpl;[|rewrite <- IHu];reflexivity).
        symmetry;apply eo_inf_o_and.
        unfold_join;apply top'_a.
      + rewrite eo_and_comm.
        rewrite and_Join,map_map.
        split_order;unfold__lat.
        * apply difference_spec in ha as (ha1&ha2).
          etransitivity;[|apply eo_inf_in_Join,in_map_iff;exists a;split;
                          [reflexivity|assumption]].
          unfold__lat;[|reflexivity].
          apply eo_heyting;rewrite <- eo_eq_bot_iff_inf_bot.
          cut (a ⌣ a0);[auto with equiv_obs|intros <-].
          tauto.
        * case_in a v.
          -- etransitivity;[|apply eo_inf_bot].
             etransitivity;[apply o_and_inf;
                            [apply eo_inf_in_Meet,in_map_iff;
                             exists a;tauto
                            |reflexivity]|].
             apply eo_heyting;reflexivity.
          -- apply eo_inf_and_right,eo_inf_in_Join,in_map_iff.
             exists a;split;[reflexivity|].
             apply difference_spec;tauto.
    - split_order.
      + unfold__lat;apply intersect_spec in ha as (hau&hav);
          apply eo_inf_in_Join,in_map_iff;exists a;tauto.
      + rewrite Join_and_Join.
        unfold__lat.
        destruct a as [a1 a2];apply pairs_spec in ha as (ha&hb);
          apply in_map_iff in ha as (a&<-&ha);
          apply in_map_iff in hb as (b&<-&hb);simpl.
        destruct_eqX a b.
        * apply eo_inf_and_left,eo_inf_in_Join,in_map_iff.
          exists b;rewrite intersect_spec;tauto.
        * etransitivity;[|apply eo_inf_bot].
          rewrite <- eo_eq_bot_iff_inf_bot.
          auto with equiv_obs.
    - symmetry;apply eo_and_top.
    - symmetry;etransitivity;[apply eo_and_comm|apply eo_and_top].
    - symmetry;etransitivity;[apply eo_and_comm|apply eo_and_top].
    - symmetry;apply eo_and_idem.
  Qed.

  Lemma τ_neg__Ω s : axΩ ⊢ τ (to_Obs__Ω (s→⊥o)) ≡ τ (to_Obs__Ω s) → ⊥o.
  Proof.
    simpl;destruct (to_Obs__Ω s) as [[u|u]|];simpl.
    - destruct_eqX u (@nil V);simpl.
      + rewrite eo_impl_distr_left.
        rewrite neg_neg_axΩ,eo_and_comm,eo_contradict;reflexivity.
      + rewrite app_nil_r,<- (eo_Ω_neg u) at 1.
        apply eo_impl;[|reflexivity].
        etransitivity;[apply eo_impl_Join|].
        rewrite map_map;reflexivity.
    - destruct_eqX u (@nil V);simpl.
      + symmetry;apply eo_tauto.
      + case_eq (inclb u (@nil V)).
        * rewrite inclb_correct;intro f;exfalso;apply N,incl_l_nil,f.
        * intros _.
          rewrite difference_nil;simpl.
          replace (u =?= []) with false by (symmetry;apply eqX_false,N).
          symmetry;etransitivity;[apply eo_impl_Join|].
          rewrite map_map;reflexivity.
    - symmetry;etransitivity;[symmetry;apply eo_and_top|].
      apply eo_eq_bot_iff_inf_bot.
      apply eo_heyting;reflexivity.
  Qed.

  Lemma τ_impl__Ω s t :
    axΩ ⊢ τ (to_Obs__Ω (s → t)) ≡ τ (to_Obs__Ω s) → τ (to_Obs__Ω t).
  Proof.
    simpl;case_eq (inf__Ω (to_Obs__Ω s)(to_Obs__Ω t)).
    - intros h;apply complete_inf__Ω in h.
      simpl;symmetry.
      apply eo_eq_top_iff_top_inf,eo_heyting.
      rewrite eo_and_comm,eo_and_top.
      apply τ_proper_inf__Ω,h.
    - destruct (to_Obs__Ω s) as [[u|u]|],(to_Obs__Ω t) as [[v|v]|];simpl;
        try discriminate;intro hyp;apply not_true_iff_false in hyp;
        (rewrite inclb_correct in hyp)
        || (rewrite eqX_correct in hyp)
        || clear hyp.
      + destruct_eqX v (@nil V);[exfalso;apply hyp,incl_nil|].
        destruct_eqX (v − u) (@nil V);
          [exfalso;apply hyp;intros a h1;case_in a u;
           [tauto|cut (a ∈ v − u);
                  [rewrite E;simpl;tauto|apply difference_spec;tauto]]|].
        destruct_eqX u (@nil V).
        * replace (v − []) with v by
              (clear;induction v;simpl;[|rewrite <- IHv];reflexivity).
          rewrite <- impl_Join.
          rewrite <- @eo_curry.
          apply eo_impl;[|reflexivity].
          rewrite @eo_and_comm.
          symmetry;apply eo_inf_o_and.
          unfold_join;apply top'_a.
        * repeat rewrite <- impl_Join.
          rewrite <- @eo_curry.
          apply eo_impl;[|reflexivity].
          rewrite eo_impl_Join,map_map.
          rewrite and_Join,map_map.
          split_order;unfold__lat.
          -- apply difference_spec in ha as (ha1&ha2).
             etransitivity;[|apply eo_inf_in_Join,in_map_iff;exists a;
                             split;[reflexivity|assumption]].
             unfold__lat;[|reflexivity].
             apply eo_heyting.
             assert (h : a ⌣ a0) by (intros <-;tauto).
             apply eq_obs_inf_obs.
             auto with equiv_obs.
          -- case_in a u.
             ++ etransitivity;[|apply eo_inf_bot].
                etransitivity;[|apply eq_obs_inf_obs,eo_contradict].
                apply obs_meet.
                ** apply eo_inf_and_right;reflexivity.
                ** apply eo_inf_and_left,eo_inf_in_Meet,in_map_iff.
                   exists a;tauto.
             ++ apply eo_inf_and_right,eo_inf_in_Join,in_map_iff.
                exists a;rewrite difference_spec;tauto.
      + destruct_eqX u (@nil V).
        * simpl;clear u E.
          split_order.
          -- unfold_join.
             apply eo_heyting,eo_inf_and_left,eo_inf_in_Join,in_map_iff.
             exists a ;tauto.
          -- case_prop (exists a, a ∈ v /\ a=a);
               [destruct hyp as (a&ha&_)
               |destruct v as [|a v];
                [clear hyp|exfalso;apply hyp;exists a;simpl;tauto]].
             ++ rewrite (eo_Ω_top' a__o a).
                rewrite @eo_impl_distr_left.
                apply eo_inf_and_right.
                rewrite <- (eo_Ω_neg v) at 1.
                rewrite <- @eo_curry.
                rewrite <- @eo_impl_distr_left.
                transitivity (⋁ (map o_obs (a::v))).
                ** etransitivity;[|apply eq_obs_inf_obs,eo_Ω_neg].
                   apply o_impl_inf;[apply o_impl_inf|];try reflexivity.
                ** unfold_join.
                   destruct ha0 as [->|ha0];
                     apply eo_inf_in_Join,in_map_iff;exists a0;tauto.
             ++ rewrite neg_top'_is_bot;reflexivity.
        * rewrite <- impl_Join.
          rewrite <- (eo_Ω_neg v).
          rewrite <- @eo_curry.
          rewrite <- @eo_impl_distr_left.
          rewrite <- @Join_app.
          rewrite <- map_app.
          symmetry;apply eo_Ω_neg.
      + pose proof hyp as e;apply eqX_false in e as ->.
        destruct_eqX v (@nil V);[rewrite interect_nil in hyp;tauto|].
        rewrite eo_impl_Join,map_map.
        split_order;unfold__lat.
        * rewrite eo_Meet_impl,map_map.
          unfold__lat.
          rewrite <- eo_curry.
          destruct_eqX a a0;[symmetry in E;subst|].
          -- rewrite eo_and_idem.
             apply eo_inf_in_Meet,in_map_iff;exists a.
             rewrite intersect_spec;tauto.
          -- etransitivity;[apply eo_inf_top|].
             apply eo_heyting.
             rewrite eo_and_comm,eo_and_top.
             rewrite <-eo_eq_bot_iff_inf_bot.
             apply eo_ax,jright,jleft,obs_incoh,N0.
        * apply intersect_spec in ha as (h1&h2).
          etransitivity;[apply eo_inf_in_Meet,in_map_iff;exists a;split;
                         [reflexivity|assumption]|].
          rewrite eo_Meet_impl,map_map.
          etransitivity;[apply eo_inf_in_Meet,in_map_iff;exists a;split;
                         [reflexivity|assumption]|].
          rewrite <- eo_curry,eo_and_idem;reflexivity.
      + destruct_eqX (u−v) (@nil V).
        * exfalso;apply hyp;intro a.
          assert (~ a ∈ u − v) as f by (now rewrite E;simpl).
          rewrite difference_spec in f;case_in a v;tauto.
        * clear N.
          rewrite eo_impl_Join,map_map.
          split_order;unfold__lat.
          -- case_in a v.
             ** etransitivity;[apply eo_inf_top|].
                apply eo_heyting;rewrite eo_and_comm,eo_and_top.
                apply eo_inf_in_Join,in_map_iff;exists a;tauto.
             ** etransitivity;[apply eo_inf_in_Meet,in_map_iff;exists a|].
                --- split;[reflexivity|apply difference_spec;tauto].
                --- apply o_impl_inf,eo_inf_bot;reflexivity.
          -- apply difference_spec in ha as (h1&h2).
             etransitivity;[apply eo_inf_in_Meet,in_map_iff;exists a|].
             ** split;[reflexivity|assumption].
             ** rewrite <- eo_heyting,eo_and_comm,eo_impl_premise.
                rewrite and_Join,map_map;unfold__lat.
                destruct_eqX a a0;[tauto|].
                rewrite <-eo_eq_bot_iff_inf_bot.
                apply eo_ax,jright,jleft,obs_incoh,N.
      + symmetry;apply eo_top_impl.
      + symmetry;apply eo_top_impl.
  Qed.

  Lemma τ_to_Obs__Ω s : axΩ ⊢ s ≡ τ (to_Obs__Ω s).
  Proof.
    induction s;try reflexivity.
    - simpl;symmetry;apply eo_or_bot.
    - rewrite IHs1,IHs2 at 1.
      rewrite <- τ_join__Ω;reflexivity.
    - rewrite IHs1,IHs2 at 1.
      rewrite <- τ_meet__Ω;reflexivity.
    - rewrite IHs1,IHs2 at 1.
      rewrite <- τ_impl__Ω;reflexivity.
  Qed.

  (** * Main results *)
  Theorem completeness_anticlique s t :
    axΩ ⊢ s ≦ t <-> s ≲ t.
  Proof.
    split.
    - apply inf_axΩ_sound.
    - pose proof (τ_to_Obs__Ω s) as e;rewrite e at 2.
      apply eq_axΩ_sound in e;rewrite e at 1;clear e.
      pose proof (τ_to_Obs__Ω t) as e;rewrite e at 2.
      apply eq_axΩ_sound in e;rewrite e at 1;clear e.
      intro h.
      apply τ_proper_inf__Ω.
      intros a;pose proof (ζ_ξ a) as <-.
      repeat rewrite <- sound_τ_sat__Ω;apply h.
  Qed.

  Corollary completeness_anticlique_eq s t :
    axΩ ⊢ s ≡ t <-> s ≃ t.
  Proof.
    rewrite (@inf_obs_partialorder Ω _ s t).
    unfold relation_conjunction,predicate_intersection,Basics.flip;simpl.
    repeat rewrite completeness_anticlique.
    symmetry;apply ssmaller_PartialOrder.
  Qed.

    Corollary ξ_to_Obs__Ω x s : x ⊨ (to_Obs__Ω s) <-> ξ x ⊨ s.
  Proof.
    pose proof (τ_to_Obs__Ω s) as e.
    apply completeness_anticlique_eq in e.
    rewrite e at 2.
    rewrite sound_τ_sat__Ω.
    rewrite ζ_ξ.
    reflexivity.
  Qed.

  Corollary sem_bij_to_Obs__Ω s t : to_Obs__Ω s ≲ to_Obs__Ω t <-> s ≲ t.
  Proof.
    unfold ssmaller.
    split;intros hyp.
    - intros α;rewrite <-(ξ_ζ α).
      setoid_rewrite <-ξ_to_Obs__Ω.
      apply hyp.
    - intros a.
      repeat  rewrite ξ_to_Obs__Ω.
      apply hyp.
  Qed.

  Instance dec_sat α (s : observation) : DecidableProp (α ⊨ s).
  Proof.
    pose proof (τ_to_Obs__Ω s) as e.
    apply eq_axΩ_sound in e.
    cut (DecidableProp (ζ α ⊨ (to_Obs__Ω s))).
    - intros h;apply (DecidableProp_equiv_prop h).
      rewrite <- sound_τ_sat__Ω,<-e;reflexivity.
    - generalize (to_Obs__Ω s) as o;clear e s;intros [[u|u]|];simpl;
        destruct (ζ α) as [a|];unfold satisfies,sat__Ω;
        (now left)||(now right)||typeclasses eauto.
  Qed.

  Instance anticlique_dec_inf (s t : observation) :
    DecidableProp (s ≲ t).
  Proof.
    apply (@DecidableProp_equiv_prop (to_Obs__Ω s ≲ to_Obs__Ω t)).
    - typeclasses eauto.
    - apply sem_bij_to_Obs__Ω.
  Qed.

  Lemma anticlique_inf_or_cntrex (s t : observation) :
    {s ≲ t} + {exists β, β ⊨ s /\ ~ β ⊨ t}.
  Proof.
    case_eq (to_Obs__Ω s);intros [u|u] e1||intros e1;case_eq (to_Obs__Ω t);
      intros [v|v] e2||intros e2.
    + case_prop (exists a, a ∈ v /\ ~ a ∈ u).
      * right;destruct hyp as (a&h1&h2);exists (ξ (Some a)).
        repeat rewrite <-ξ_to_Obs__Ω.
        rewrite e1,e2;unfold satisfies,sat__Ω.
        tauto.
      * left;apply sem_bij_to_Obs__Ω.
        rewrite e1,e2;apply complete_inf__Ω;simpl.
        apply inclb_correct;intros a ha.
        case_in a u;[tauto|].
        exfalso;apply hyp;exists a;tauto.
    + right.
      destruct (infiniteV (u++v)) as [a ha].
      exists (ξ (Some a)).
      repeat rewrite <-ξ_to_Obs__Ω.
      rewrite e1,e2;unfold satisfies,sat__Ω.
      rewrite in_app_iff in ha;tauto.
    + left;apply sem_bij_to_Obs__Ω.
      rewrite e1,e2;apply complete_inf__Ω;simpl.
      reflexivity.
    + case_prop (exists a, a∈ u /\ a ∈ v).
      * right.
        destruct hyp as (a&h1&h2);exists  (ξ (Some a)).
        repeat rewrite <-ξ_to_Obs__Ω.
        rewrite e1,e2;unfold satisfies,sat__Ω.
        tauto.
      * left;apply sem_bij_to_Obs__Ω.
        rewrite e1,e2;apply complete_inf__Ω;simpl.
        apply eqX_correct,incl_l_nil.
        intros a ha;apply hyp;exists a;apply intersect_spec,ha.
    + case_prop (exists a, a∈ u /\ ~ a ∈ v).
      * right.
        destruct hyp as (a&h1&h2);exists (ξ (Some a)).
        repeat rewrite <-ξ_to_Obs__Ω.
        rewrite e1,e2;unfold satisfies,sat__Ω.
        tauto.
      * left;apply sem_bij_to_Obs__Ω.
        rewrite e1,e2;apply complete_inf__Ω;simpl.
        apply inclb_correct;intros a ha.
        case_in a v;[|exfalso;apply hyp;exists a];tauto.
    + left;apply sem_bij_to_Obs__Ω.
      rewrite e1,e2;apply complete_inf__Ω;simpl.
      reflexivity.
    + right.
      exists (ξ None).
      repeat rewrite <-ξ_to_Obs__Ω;rewrite e1,e2;unfold satisfies,sat__Ω.
      tauto.
    + right.
      exists (ξ None).
      repeat rewrite <-ξ_to_Obs__Ω;rewrite e1,e2;unfold satisfies,sat__Ω.
      tauto.
    + left;apply sem_bij_to_Obs__Ω.
      rewrite e1,e2;apply complete_inf__Ω;simpl.
      reflexivity.
  Qed.

  Proposition anticlique_choose_clique : choose_clique Ω.
  Proof.
    intros α s t.
    case_eq (ζ α).
    - intros a e.
      case_prop (α ⊨ s /\ ~ α ⊨ t).
      + right;exists α;split;[reflexivity|tauto].
      + left;intros β h.
        cut (β ≃ α).
        * intros -> h';case_prop (α ⊨ t);tauto.
        * intros b;split;[|apply h].
          intro h';apply mem_is_sgl in h'.
          rewrite h' in h.
          repeat rewrite mem_is_sgl;symmetry.
          revert h;pose proof (ξ_ζ α) as <-;rewrite e;simpl.
          intros h;apply mem_is_sgl,h,sgl_spec;reflexivity.
    - destruct (anticlique_inf_or_cntrex s t) as [h|h];intros e.
      + left;intros ? _;apply h.
      + right;destruct h as (β&h);exists β;split.
        pose proof (ξ_ζ α) as <-;rewrite e.
        * apply empt_max.
        * apply h.
  Qed.

End s.


Require Import Psatz.

Require Export SystemFR.StarInversions.
Require Export SystemFR.SizeLemmas.
Require Export SystemFR.RewriteTactics.

From Equations Require Import Equations.
Require Import Equations.Prop.Subterm. (* lexicographic ordering *)

Require Import Coq.Program.Program.

(* Lexicographic order used for the termination argument of reducibility *)
(* Follows the lexicographic order definition given in Equations *)
(* The measure used is: (size, recursive index) *)

Definition index (T: tree): tree :=
  match T with
  | T_rec n _ _ => n
  | _ => notype_err
  end.

Set Program Mode.

Fixpoint nat_value_to_nat (v: tree) (p: is_nat_value v): nat :=
  match v with
  | zero  => 0
  | succ v' => S (nat_value_to_nat v' _)
  | _ => False_rec nat _
  end.

Ltac destruct_is_nat_value :=
  match goal with
  | H: is_nat_value ?v |- _ =>
     is_var v;
     destruct H
  end.

Ltac t_nat_value_to_nat :=
  repeat program_simpl || step || step_inversion is_nat_value;
    try solve [ destruct_is_nat_value; repeat step ].

Solve Obligations with t_nat_value_to_nat.

Fail Next Obligation.

Unset Program Mode.

Lemma nat_value_to_nat_fun:
  forall v p1 p2, nat_value_to_nat v p1 = nat_value_to_nat v p2.
Proof.
  induction v; repeat step || step_inversion is_nat_value.
Qed.

Definition lt_index (t1 t2: tree) :=
  exists v1 v2 (p1: is_nat_value v1) (p2: is_nat_value v2),
     t1 ~>* v1 /\
     t2 ~>* v2 /\
     nat_value_to_nat v1 p1 < nat_value_to_nat v2 p2
.

Ltac tlu :=
  match goal with
  | H: lt_index _ _ |- _ => unfold lt_index in H
  end.

Lemma acc_ind_aux:
  forall m t v (p: is_nat_value v),
    nat_value_to_nat v p < m ->
    t ~>* v ->
    Acc lt_index t.
Proof.
  induction m; destruct p; steps; try lia.
  - apply Acc_intro; repeat step || tlu || t_deterministic_star || simp nat_value_to_nat in *; try lia.
  - apply Acc_intro; repeat step || tlu || t_deterministic_star || simp nat_value_to_nat in *.
    apply IHm with v1 p1; steps.
    match goal with
    | H1: context[nat_value_to_nat ?t ?p1],
      H2: context[nat_value_to_nat ?t ?p2] |- _ =>
      rewrite (nat_value_to_nat_fun t p1 p2) in *
    end; eauto with lia.
Qed.

Lemma acc_ind:
  forall n, Acc lt_index n.
Proof.
  intro; apply Acc_intro; repeat step || tlu; eauto using acc_ind_aux.
Qed.

Lemma wf_lt_index: well_founded lt_index.
Proof.
  unfold well_founded.
  destruct a; repeat step; eauto using acc_ind.
Qed.

#[export]
Instance wellfounded_lt_index :
  WellFounded lt_index := wf_lt_index.

Definition lt_partial := (lexprod nat tree lt lt_index).
Definition wf_measure_partial := wellfounded_lexprod nat tree lt lt_index lt_wf wf_lt_index.

Opaque lt.

Definition measure_domain: Type := (nat * tree).
Definition lt_measure: measure_domain -> measure_domain -> Prop := lt_partial.
Notation "p1 '<<' p2" := (lt_measure p1 p2) (at level 80).

Lemma leq_lt_measure:
  forall a1 b1 a2 b2,
    a1 <= a2 ->
    lt_index b1 b2 ->
    (a1, b1) << (a2, b2).
Proof.
  unfold "<<", lt_partial; intros;
  destruct (PeanoNat.Nat.eq_dec a1 a2); steps; eauto using right_lex; eauto using left_lex with lia.
Qed.

Lemma measure_induction:
  forall P,
    (forall m, (forall m', m' << m -> P m') -> P m) ->
    (forall m, P m).
Proof.
  repeat step || unfold measure_domain in *.
  pose proof (wf_measure_partial (a, b)) as H.
  induction H; steps.
Qed.

Lemma nat_value_to_nat_succ:
  forall t p1 p2,
    nat_value_to_nat t p1 < nat_value_to_nat (succ t) p2.
Proof.
  repeat step || simp nat_value_to_nat in *.
    match goal with
    | |- context[nat_value_to_nat ?t?p]  =>
      rewrite (nat_value_to_nat_fun t p1 p) in *
    end; eauto with lia.
Qed.

Lemma lt_index_step:
  forall t v,
    t ~>* succ v ->
    is_nat_value v ->
    lt_index v t.
Proof.
  unfold lt_index; intros.
  unshelve eexists v, (succ v), _, _; steps;
    eauto with is_nat_value;
    eauto using nat_value_to_nat_succ.
Qed.

Definition get_measure (T: tree) := (type_nodes T, index T).

Lemma leq_lt_measure':
  forall a1 b1 c1 a2 b2 c2,
    a1 <= a2 ->
    b1 < b2 ->
    lexprod nat (nat * tree) lt lt_partial (a1, (b1, c1)) (a2, (b2, c2)).
Proof.
  intros.
  destruct (PeanoNat.Nat.eq_dec a1 a2); steps.
  - apply right_lex, left_lex; lia.
  - apply left_lex; lia.
Qed.

Lemma leq_leq_lt_measure:
  forall a1 b1 c1 a2 b2 c2,
    a1 <= a2 ->
    b1 <= b2 ->
    lt_index c1  c2 ->
    lexprod nat (nat * tree) lt lt_partial (a1, (b1, c1)) (a2, (b2, c2)).
Proof.
  intros.
  destruct (PeanoNat.Nat.eq_dec a1 a2);
  destruct (PeanoNat.Nat.eq_dec b1 b2); steps;
    eauto using right_lex, left_lex with lia.
  - apply right_lex, right_lex; steps.
  - apply right_lex, left_lex; lia.
Qed.

Lemma type_nodes_get_measure:
  forall T1 T2,
    type_nodes T1 < type_nodes T2 ->
    get_measure T1 << get_measure T2.
Proof.
  unfold get_measure; intros; apply left_lex; auto.
Qed.

#[export]
Hint Extern 1 => solve [
  apply left_lex; repeat step || autorewrite with bsize; eauto 2 with lia; t_closer
]: measure.

#[export]
Hint Extern 1 => solve [
  apply right_lex; steps; eauto using lt_index_step
]: measure.

Definition prop_at (P: tree -> Prop) m T := get_measure T = m -> P T.

Definition prop_until (P: tree -> Prop) (m: measure_domain): Prop :=
  forall m', m' << m -> forall T, prop_at P m' T.

Lemma prop_until_at:
  forall P m T,
    prop_until P m ->
    get_measure T << m ->
    P T.
Proof.
  unfold prop_until, prop_at;
    steps; eauto.
Qed.

#[export]
Hint Extern 1 => solve [ eapply prop_until_at; eauto with measure ]: prop_until.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e448m2e224m1_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e191m19_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e196m15_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import HoTT.
From GR.bicategories Require Import
     general_category
     bicategory.bicategory
     bicategory.examples.image
     bicategory.adjoint
     bicategory.univalent
     lax_functor.lax_functor.

Section ImageRestriction.
  Context {C D : BiCategory}.
  Variable (F : LaxFunctor C D).

  Definition restrict_image_d : LaxFunctor_d C (image F).
  Proof.
    make_laxfunctor.
    - intros X.
      simple refine (F X;_) ; simpl.
      exact (tr(X;idpath)).
    - intros X Y ; cbn.
      exact (Fmor F X Y).
    - intros X Y Z g f ; cbn.
      exact (Fcomp₁ F g f).
    - intros X ; cbn.
      exact (Fid F X).
  Defined.

  Definition restrict_image_is_lax : is_lax restrict_image_d.
  Proof.
    make_is_lax ; intros ; simpl in * ; apply F.
  Qed.

  Definition restrict_image : LaxFunctor C (image F)
    := Build_LaxFunctor restrict_image_d restrict_image_is_lax.
End ImageRestriction.

Global Instance restrict_image_is_pseudo
           `{Univalence}
           {C D : BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
  : is_pseudo (restrict_image F).
Proof.
  split ; cbn ; apply _.
Defined.

Definition restrict_image_pseudo
           `{Univalence}
           {C D : BiCategory}
           (F : PseudoFunctor C D)
  : PseudoFunctor C (image F).
Proof.
  make_pseudo_functor_lax.
  - exact (restrict_image F).
  - exact (restrict_image_is_pseudo F).
Defined.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e194m33_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e189m25_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.