Require Import Coq.ZArith.BinInt.
Inductive type := Z | prod (A B : type) | arrow (s d : type).
Inductive expr {var:type -> Type} : type -> Type :=
| LetIn {s d} (x : expr s) (f : var s -> expr d) : expr d
| App {s d} (f : expr (arrow s d)) (x : expr s) : expr d
| Abs {s d} (f : var s -> expr d) : expr (arrow s d)
| Var {t} (v : var t) : expr t
| Pair {A B} (x : expr A) (y : expr B) : expr (prod A B)
| Fst {A B} (x : expr (prod A B)) : expr A
| Snd {A B} (x : expr (prod A B)) : expr B
| Add (x y : expr Z) : expr Z
| Mul (x y : expr Z) : expr Z
| Sub (x y : expr Z) : expr Z
| Opp (x : expr Z) : expr Z
| Literal (v : BinInt.Z) : expr Z
| AddWithGetCarry (x y c : expr Z) : expr (prod Z Z)
| CastToSize (lower upper : BinInt.Z) (v : expr Z) : expr Z.

Delimit Scope etype_scope with etype.
Delimit Scope expr_scope with expr.
Bind Scope etype_scope with type.
Bind Scope expr_scope with expr.
Infix "*" := prod : etype_scope.
Infix "*" := Mul : expr_scope.
Infix "->" := arrow : etype_scope.
Infix "-" := Sub : expr_scope.
Infix "+" := Add : expr_scope.

Check (_ + _ * _ - _)%expr.
(* M-x load-theme tango-dark *)
Notation "- x" := (Opp x) : expr_scope.
Print Grammar constr.
Notation "# x" := (Literal x) (at level 10, format "# x") : expr_scope.
Open Scope expr_scope.
Check fun x => #(Z.succ x).
Notation "$ x" := (Var x) (at level 10, format "$ x") : expr_scope.
Check #1 + #1.
Notation "'expr_let' x := y 'in' f"
  := (LetIn y (fun x => f%expr))
       (at level 200, right associativity,
        format "'[' 'expr_let'  x  :=  y  'in' '//' f ']'") : expr_scope.
Check (expr_let x := #1 in expr_let y := $x + #2 in $y + $x).

Module MorePretty.
  Notation "x" := (Literal x) (only printing, at level 10) : expr_scope.
  Notation "x" := (Var x) (only printing, at level 10) : expr_scope.
  Notation "T x = y ; f"
    := (LetIn (s:=T) y (fun x => f%expr))
         (only printing, at level 200, right associativity,
          format "'[' T  x  =  y ; '//' f ']'") : expr_scope.
  Notation int := Z.
  Fail Notation "T x = y ; .. ; T' x' = y' ;; 'return' f"
    := (LetIn (s:=T) y (fun x => .. (LetIn (s:=T') y' (fun x' => f%expr)) .. ))
         (only printing, at level 200, right associativity) : expr_scope.
  Check (expr_let x := #1 in expr_let y := $x + #2 in $y + $x).
End MorePretty.

Notation "( x , y , .. , z )" := (Pair .. (Pair x y) .. z) : expr_scope.
Print Grammar constr.
Notation "\ x .. y , f"
  := (Abs (fun x => .. (Abs (fun y => f%expr)) .. ))
       (at level 99, x binder, y binder, right associativity, f at level 200) : expr_scope.

(* Syntax of notations (e.g., \texttt{Infix "+" := add.}; \texttt{Notation "a + b" := (add a b).}) *)
(* Notation bodies must be parenthesized *)
(* How to use levels and associativity, how to pick levels, how to discover levels of existing notations (\texttt{Print Grammar constr}) *)
(* Controlling display: \texttt{format}, extra spaces, quoting symbols, boxes in \texttt{format} for display of indentation, newlines, and whitespace *)
(* Recursive notations: \texttt{..} for pair- and $\lambda$-like things *)
(* \texttt{Reserved Notation} and \texttt{only printing}, useful for ensuring that notations don't conflict *)
(* Using single-variable only-printing notations for hiding identifiers *)
(* Abbreviations vs notations (what it means when your \texttt{Notation} doesn't have quotes, and why you might want this) *)
(* Notation scopes, useful for overloading notations and selecting the right one automatically (\texttt{Bind Scope}, \texttt{Delimit Scope}, \texttt{Open Scope}) *)
(* Using binders for destructuring pairs *)
(* Parenthesizing notations: when to use parentheses, and when to use levels *)
(* Deliberate ordering of notations: how to express wildcard and negation in notation matching *)

(** Feeback: *)
(* Strange point on the spectrum between understand nothing and understand everything
- Who's the target audience? (ppl who don't read the manual?)
- Showing larger scale example (e.g., fiat-crypto pipeline Notations) for wow factor at the beginning
- Look into showing VST Notations in action
- Make sure to explain when you need 4000 lines of notations, when not
- Maybe do a proof with/with-out notations ("can you spot the bug now?")
- too much time typing "Infix" at the beginning
- don't use "things" ('the things need to be the same')
- if mention uniform inheritance ("too much polymorphism to explain")
- careful about mentioning fiat-crypto without explanation
- don't explain PHOAS
- print out outline, not in buffer
- too much time pitching scopes (more code, less talk)
- less time scrolling through tiny buffer of levels, give a couple more examples
*)


(** * Computability Logic *)

(** This is an attempt at formalizing Giorgi Japaridze's Computability
    Logic based on "In the beginning was game semantics" from the book
    "Games: Unifying Logic, Language, and Philosophy".

    The approach is to replace Japaridze's "classical" definitions with
    mainly coinductive ones friendly to type theory. Currently it's
    rather experimental and certainly very broken, because he seems to
    define game operations by defining their structure and winner mutually
    at the same time. Here this would require mutual coinduction and I
    don't know how to do it properly. *)

Require Import List.
Import ListNotations.

Require Import Bool.
Require Import Arith.

Require Import FunctionalExtensionality.

Axiom LEM : forall P : Prop, P \/ ~ P.

Inductive Player : Type :=
    | Machine : Player
    | Nature : Player.

CoInductive ConstantGame : Type :=
{
    winner : Player;
    Labmove : Type;
    who : Labmove -> Player;
    next : Labmove -> ConstantGame;
}.

Definition Win : ConstantGame.
Proof.
refine
{|
    winner := Machine;
    Labmove := Empty_set;
    who l := match l with end;
    next l := match l with end;
|}.
Defined.

CoFixpoint Lose : ConstantGame.
Proof.
refine
{|
    winner := Nature;
    Labmove := Empty_set;
    who l := match l with end;
    next l := match l with end;
|}.
Defined.

Definition swap (p : Player) : Player :=
match p with
    | Machine => Nature
    | Nature => Machine
end.

Definition transport
  {A : Type} (P : A -> Type) {x y : A} (p : x = y) : P x -> P y.
Proof.
  destruct p. intro. assumption.
Defined.

Lemma transport_cat :
  forall
    (A : Type) (P : A -> Type) (x y z : A) (p : x = y) (q : y = z) (u : P x),
      transport P q (transport P p u) = transport P (eq_trans p q) u.
Proof.
  destruct p, q. cbn. reflexivity.
Defined.

Lemma cat_inv :
  forall (A : Type) (x y : A) (p : x = y),
    eq_trans (eq_sym p) p = eq_refl.
Proof.
  destruct p. cbn. reflexivity.
Defined.

CoInductive sim (g1 g2 : ConstantGame) : Prop :=
{
    winners : winner g1 = winner g2;
    Labmoves : Labmove g1 = Labmove g2;
    whos :
      forall move : Labmove g1,
        who g1 move = who g2 (@transport _ id _ _ Labmoves move);
    nexts :
      forall move : Labmove g1,
        sim (next g1 move)
          (next g2 (@transport _ id _ _ Labmoves move))
}.

Axiom sim_eq :
  forall g1 g2 : ConstantGame, sim g1 g2 -> g1 = g2.

(** The axiom is fine, because replacing [sim] with [=] in the definition
    of [sim] gives exactly what HoTT tells us is the characterization of
    paths for constant games. *)

Require Import Setoid.

Lemma sim_refl :
  forall g : ConstantGame, sim g g.
Proof.
  cofix CH.
  econstructor; cbn; intros. Unshelve.
    1, 4: reflexivity.
    reflexivity.
    apply CH.
Qed.

Lemma sim_sym :
  forall g1 g2 : ConstantGame,
    sim g1 g2 -> sim g2 g1.
Proof.
  cofix CH.
  destruct 1 as [w p whos nexts].
  econstructor. Unshelve.
    4: auto.
    auto.
    intro. rewrite whos, transport_cat, cat_inv. cbn. reflexivity.
    intro. apply CH.
      specialize (nexts (@transport _ id _ _ (eq_sym p) move)).
      rewrite transport_cat, cat_inv in *. cbn in *.
        assumption.
Qed.

Lemma sim_trans :
  forall g1 g2 g3 : ConstantGame,
    sim g1 g2 -> sim g2 g3 -> sim g1 g3.
Proof.
  cofix CH.
  destruct 1 as [w1 p1 whos1 nexts1],
           1 as [w2 p2 whos2 nexts2].
  econstructor. Unshelve.
    4: exact (eq_trans p1 p2).
    rewrite w1. assumption.
    intro. rewrite whos1, whos2, transport_cat. reflexivity.
    intro. apply (CH _ (next g2 (transport id p1 move))).
      apply nexts1.
      rewrite <- transport_cat. apply nexts2.
Qed.

#[export]
Instance Equivalence_sim : Equivalence sim.
Proof.
  split; red.
    apply sim_refl.
    apply sim_sym.
    apply sim_trans.
Defined.

(** Tactics *)

#[global] Hint Constructors Player : CoL.

#[global] Hint Extern 1 =>
match goal with
    | |- exists p : Player, _ => exists Machine; cbn
end : CoL.

#[global] Hint Extern 1 =>
match goal with
    | |- exists p : Player, _ => exists Nature; cbn
end : CoL.

(** Connectives *)

CoFixpoint Not (g : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := swap (winner g);
    Labmove := Labmove g;
    who move := swap (who g move);
    next move := Not (next g move);
|}.
Defined.

Definition chor (g1 g2 : ConstantGame) : ConstantGame.
Proof.
  refine
  {|
      winner := Nature;
      Labmove := bool;
      who move := Machine;
      next move := if move then g1 else g2;
  |}.
Defined.

Definition chand (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := Machine;
    Labmove := bool;
    who move := Nature;
    next move := if move then g1 else g2;
|}.
Defined.

Definition chexists {A : Type} (f : A -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := Nature;
    Labmove := A;
    who move := Machine;
    next move := f move;
|}.
Defined.

Definition chall {A : Type} (f : A -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := Machine;
    Labmove := A;
    who move := Nature;
    next move := f move;
|}.
Defined.

CoFixpoint por (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner :=
      match winner g1, winner g2 with
          | Nature, Nature => Nature
          | _, _ => Machine
      end;
    Labmove := Labmove g1 + Labmove g2;
    who move :=
      match move with
          | inl move' => who g1 move'
          | inr move' => who g2 move'
      end;
    next move :=
      match move with
          | inl move' => por (next g1 move') g2
          | inr move' => por g1 (next g2 move')
      end
|}.
Defined.

CoFixpoint pand (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner :=
      match winner g1, winner g2 with
          | Machine, Machine => Machine
          | _, _ => Nature
      end;
    Labmove := Labmove g1 + Labmove g2;
    who move :=
      match move with
          | inl move' => who g1 move'
          | inr move' => who g2 move'
      end;
    next move :=
      match move with
          | inl move' => pand (next g1 move') g2
          | inr move' => pand g1 (next g2 move')
      end
|}.
Defined.

Axiom LEM' : forall A : Type, A + (A -> False).

CoFixpoint pexists (f : nat -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner :=
      if LEM' (exists n : nat, winner (f n) = Machine)
      then Machine
      else Nature;
    Labmove := {n : nat & Labmove (f n)};
    who move :=
      match move with
          | existT _ n move => who (f n) move
      end;
    next move :=
      match move with
          | existT _ n move =>
              pexists (fun m : nat => if n =? m then next (f n) move else f m)
      end
|}.
Defined.

CoFixpoint pall (f : nat -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner :=
      if LEM' (forall n : nat, winner (f n) = Machine)
      then Machine
      else Nature;
    Labmove := {n : nat & Labmove (f n)};
    who move :=
      match move with
          | existT _ n move => who (f n) move
      end;
    next move :=
      match move with
          | existT _ n move =>
              pall (fun m : nat => if n =? m then next (f n) move else f m)
      end
|}.
Defined.

CoFixpoint sor (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := winner g1;
    Labmove := option (Labmove g1);
    who move :=
      match move with
          | None => Machine
          | Some move' => who g1 move'
      end;
    next move :=
      match move with
          | None => g2
          | Some move' => sor (next g1 move') g2
      end;
|}.
Defined.

CoFixpoint sand (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := winner g1;
    Labmove := option (Labmove g1);
    who move :=
      match move with
          | None => Nature
          | Some move' => who g1 move'
      end;
    next move :=
      match move with
          | None => g2
          | Some move' => sand (next g1 move') g2
      end;
|}.
Defined.

CoFixpoint sexists (f : nat -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := winner (f 0);
    Labmove := option (Labmove (f 0));
    who move :=
      match move with
          | None => Machine
          | Some move' => who (f 0) move'
      end;
    next move :=
      match move with
          | None => sexists (fun n : nat => f (S n))
          | Some move' =>
              sexists (fun n : nat =>
                      match n with
                          | 0 => next (f 0) move'
                          | S n' => f (S n')
                      end)
      end;
|}.
Defined.

CoFixpoint sall (f : nat -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := winner (f 0);
    Labmove := option (Labmove (f 0));
    who move :=
      match move with
          | None => Nature
          | Some move' => who (f 0) move'
      end;
    next move :=
      match move with
          | None => sall (fun n : nat => f (S n))
          | Some move' =>
              sall (fun n : nat =>
                      match n with
                          | 0 => next (f 0) move'
                          | S n' => f (S n')
                      end)
      end;
|}.
Defined.

CoFixpoint tor (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := winner g1;
    Labmove := option (Labmove g1);
    who move :=
      match move with
          | None => Machine
          | Some move' => who g1 move'
      end;
    next move :=
      match move with
          | None => tor g2 g1
          | Some move' => tor (next g1 move') g2
      end;
|}.
Defined.

CoFixpoint tand (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner := winner g1;
    Labmove := option (Labmove g1);
    who move :=
      match move with
          | None => Nature
          | Some move' => who g1 move'
      end;
    next move :=
      match move with
          | None => tand g2 g1
          | Some move' => tand (next g1 move') g2
      end;
|}.
Defined.

CoFixpoint texists' (f : nat -> ConstantGame) (n : nat) : ConstantGame.
Proof.
refine
{|
    winner := winner (f n);
    Labmove := Labmove (f n) + nat;
    who move :=
      match move with
          | inl move' => who (f n) move'
          | inr _ => Machine
      end;
    next move :=
      match move with
          | inl move' => texists'
              (fun m : nat => if n =? m then next (f n) move' else f m) n
          | inr m => texists' f m
      end;
|}.
Defined.

CoFixpoint tall' (f : nat -> ConstantGame) (n : nat) : ConstantGame.
Proof.
refine
{|
    winner := winner (f n);
    Labmove := Labmove (f n) + nat;
    who move :=
      match move with
          | inl move' => who (f n) move'
          | inr _ => Nature
      end;
    next move :=
      match move with
          | inl move' => tall'
              (fun m : nat => if n =? m then next (f n) move' else f m) n
          | inr m => tall' f m
      end;
|}.
Defined.

Definition texists (f : nat -> ConstantGame) : ConstantGame :=
  texists' f 0.

Definition tall (f : nat -> ConstantGame) : ConstantGame :=
  tall' f 0.

(** Some proofs - de Morgan laws *)

Lemma Not_Not :
  forall g : ConstantGame,
    sim (Not (Not g)) g.
Proof.
  cofix CH.
  econstructor; cbn; intros. Unshelve.
    4: cbn; reflexivity.
    destruct (winner g); reflexivity.
    cbn. destruct (who g move); cbn; reflexivity.
    apply CH.
Qed.

Lemma Not_chor :
  forall g1 g2 : ConstantGame,
    sim (Not (chor g1 g2)) (chand (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor; cbn; intros. Unshelve.
    4: cbn; reflexivity.
    1-2: reflexivity.
    cbn. destruct move; apply sim_refl.
Qed.

Lemma Not_chand :
  forall g1 g2 : ConstantGame,
    sim (Not (chand g1 g2)) (chor (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor; cbn; intros. Unshelve.
    all: cbn; try reflexivity.
    cbn. destruct move; apply sim_refl.
Qed.

Lemma Not_chexists :
  forall (A : Type) (f : A -> ConstantGame),
    sim (Not (chexists f)) (chall (fun x : A => Not (f x))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    all: cbn; try reflexivity.
    intro. apply sim_refl.
Qed.

Lemma Not_chall :
  forall (A : Type) (f : A -> ConstantGame),
    sim (Not (chall f)) (chexists (fun x : A => Not (f x))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    all: cbn; try reflexivity.
    intro. apply sim_refl.
Qed.

Lemma Not_por :
  forall g1 g2 : ConstantGame,
    sim (Not (por g1 g2)) (pand (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor. Unshelve.
    all: cbn; try reflexivity.
    destruct (winner g1), (winner g2); cbn; reflexivity.
    destruct move; reflexivity.
    destruct move; apply CH.
Qed.

(*
Lemma Not_pand :
  forall g1 g2 : ConstantGame,
    sim (Not (pand g1 g2)) (por (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      destruct p; firstorder.
      destruct move; reflexivity.
      destruct move; apply CH.
Qed.
*)

Lemma Not_pexists :
  forall f : nat -> ConstantGame,
    sim (Not (pexists f)) (pall (fun n : nat => Not (f n))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    all: cbn; try reflexivity.
      destruct (LEM' _), (LEM' _); cbn; try reflexivity.
        destruct e. specialize (e0 x). rewrite H in e0. inversion e0.
        cut False.
          destruct 1.
          apply f1. intro. case_eq (winner (f n)); cbn; intro.
            cut False. destruct 1. apply f0. eauto.
            reflexivity.
      destruct move. cbn. reflexivity.
      destruct move as [n move]. cbn.
        replace (pall _) with (pall
          (fun m : nat => Not (if n =? m then next (f n) move else f m))).
          apply CH.
          f_equal. extensionality m. destruct (n =? m); reflexivity.
Qed.


(* Fixing missing test for variable shadowing *)

Definition test (x y:bool*bool) :=
  match x with
  | (e as e1, (true) as e2)
  | ((true) as e1, e as e2) =>
    let '(e, b) := y in
    e
  | _ => true
  end.

Goal test (true,false) (true,true) = true.
(* used to evaluate to "false = true" in 8.4 *)
reflexivity.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj24synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (plus (mult lv0 lv1) lv1) lv0)) (plus (mult lv2 lv0) lv2)).
Admitted.
QuickChick conj24synthconj6.


From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils
  PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICUtils PCUICPosition.
From MetaCoq.PCUIC Require Export PCUICCumulativitySpec.
From MetaCoq.PCUIC Require Export PCUICCases PCUICNormal.
Require Import MLTTTyping.

Definition RedConvTe {Γ} {t u A : term} :
    [Γ |- t ⇒ u ::: A] ->
    [Γ |- t ≅ u ::: A].
    intro.
    induction X.
    eapply TermConv; eassumption.
    eapply TermAppCong. eassumption.
    constructor. assumption.
    eapply TermBRed; assumption.
Defined.

Definition RedConvTeC {Γ} {t u A : term} :
    [Γ |- t ⇒* u ::: A] ->
    [Γ |- t ≅ u ::: A].
    intro.
    induction X.
    + constructor. assumption.
    + eapply TermTrans.
      exact (RedConvTe t0).
      assumption.
Defined.

Definition RedConvTy {Γ} {A B : term} :
    [Γ |- A ⇒ B] ->
    [Γ |- A ≅ B].
    intro.
    destruct X.
    pose proof (RedConvTe t).
    exact (convUniv X).
Defined.

Definition RedConvTyC {Γ} {A B : term} :
    [Γ |- A ⇒* B] ->
    [Γ |- A ≅ B].
    intro.
    induction X.
    exact (TypeRefl w).
    eapply TypeTrans.
    exact (RedConvTy t).
    assumption.
Defined.

Definition ClosureConv {Γ} {t u A B} :
    [Γ |- t ⇒* u ::: A] ->
    [Γ |- A ≅ B] ->
    [Γ |- t ⇒* u ::: B].
    intros.
    induction X.
    constructor.
    eapply wfTermConv; eassumption.
    eapply termRedSucc.
    eapply conv; eassumption.
    exact (IHX X0).
Defined.

Definition TermRedWFConv {Γ} {t u A B} :
    [Γ |- t :⇒*: u ::: A] ->
    [Γ |- A ≅ B] ->
    [Γ |- t :⇒*: u ::: B].
    intros.
    destruct X.
    constructor.
    1,2 : eapply wfTermConv; eassumption.
    exact (ClosureConv C X0).
Defined.

Definition TypeRedWFConv {Γ} {A B} :
    [Γ |- A :⇒*: B] ->
    [Γ |- A ≅ B].
    intro.
    destruct X.
    exact (RedConvTyC D).
Defined.

Definition RedConvTeWFC {Γ} {t u A} :
    [Γ |- t :⇒*: u ::: A] ->
    [Γ |- t ≅ u ::: A].
    intro.
    destruct X.
    exact (RedConvTeC C).
Defined.

Ltac skip :=
    match goal with
        | |- _ => try intro
    end.

Ltac gen_conv :=
    match goal with
    | H : [ ?Γ |- ?A ⇒ ?B ] , _ : [ ?Γ |- ?A ≅ ?B]|- _ => skip
    | H : [ _ |- _ ⇒ _] |- _ => pose proof (RedConvTe H)
    | |- _ => skip
    end;match goal with
    | H : [ ?Γ |- ?A ⇒* ?B ] , _ : [ ?Γ |- ?A ≅ ?B]|- _ => skip
    | H : [ _ |- _ ⇒* _] |- _ => pose proof (RedConvTeC H)
    | |- _ => skip
    end;match goal with
    | H : [ ?Γ |- ?t ⇒ ?u ::: ?A ] , _ : [ ?Γ |- ?t ≅ ?u ::: ?A]|- _ => skip
    | H : [ _ |- _ ⇒ _ ::: _] |- _ => pose proof (RedConvTy H)
    | |- _ => skip
    end;match goal with
    | H : [ ?Γ |- ?t ⇒* ?u ::: ?A ] , _ : [ ?Γ |- ?t ≅ ?u ::: ?A]|- _ => skip
    | H : [ _ |- _ ⇒* _ ::: _] |- _ => pose proof (RedConvTy H)
    | |- _ => skip
    end;match goal with
    | H : [ ?Γ |- ?A :⇒*: ?B ] , _ : [ ?Γ |- ?A ≅ ?B]|- _ => skip
    | H : [ _ |- _ :⇒*: _ ] |- _ => pose proof (TypeRedWFConv H)
    | |- _ => skip
    end;match goal with
    | H1 : [ _ |- _ ⇒* _ ::: ?A] , H2 : [_ |- ?A ≅ _] |- _ => pose proof (ClosureConv H1 H2)
    | |- _ => skip
    end;match goal with
    | H1 : [ _ |- _ :⇒*: _ ::: ?A] , H2 : [_ |- ?A ≅ _] |- _ => pose proof (TermRedWFConv H1 H2)
    | |- _ => skip
    end;match goal with
    | H1 : [ _ |- _ ⇒* _ ::: ?A] , H2 : [_ |- _ ≅ ?A] |- _ => pose proof (ClosureConv H1 (TypeSym H2))
    | |- _ => skip
    end;match goal with
    | H1 : [ _ |- _ :⇒*: _ ::: ?A] , H2 : [ _ |- _ ≅ ?A ] |- _ => pose proof (TermRedWFConv H1 (TypeSym H2))
    | |- _ => skip
    end.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

(** * Equational theory on a term algebra *)

From Coq Require Import List Relations Wellfounded Arith Setoid.
From CoLoR Require Import closure more_list weaved_relation dickson term_spec.

Notation " T '-[' R ']->' U " := (R U T) (at level 80) : term_scope .

(** ** Module Type EqTh, an equational theory over a term algebra. *)

Module Type EqTh.

  Declare Module T : Term.

  Import T.

 Inductive defined (R : relation term) : symbol -> Prop :=
  | Def : forall f l t, R t (Term f l) -> defined R f.

 Inductive constructor (R : relation term) : symbol -> Prop :=
  | Const : forall f, (forall l t, ~ (R t (Term f l))) -> constructor R f.

Inductive module (R1 R2 : relation term) : Prop :=
  | Mod :
      (forall f2 s t, defined R2 f2 ->  R1 s t -> symb_in_term_list f2 (s :: t :: nil) = false) ->
      module R1 R2.

  (** *** One step at top. *)
  Inductive axiom (R : relation term) : term -> term -> Prop :=
    | instance :
        forall t1 t2 sigma, R t1 t2 -> axiom R (apply_subst sigma t1) (apply_subst sigma t2).

  (** *** One step at any position. *)
  Inductive one_step (R : relation term) : term -> term -> Prop :=
  | at_top : forall t1 t2, axiom R t1 t2 -> one_step R t1 t2
  | in_context : forall f l1 l2, one_step_list (one_step R) l1 l2 -> one_step R (Term f l1) (Term f l2).

  (** *** Equational Theory as reflexive, symetric
      and transitive closure of an equational step. *)

  (** *** Rewriting Theory as transitive closure of an equational step. *)
  Definition rwr (R : relation term) := trans_clos (one_step R).

  Parameter one_step_one_rule :
    forall R s t, one_step R t s ->
    exists r, exists l, R r l /\ one_step (fun r' l' => In (r',l') ((r,l) :: nil)) t s.

Notation " T '-[' R '+]->' U " := (rwr R T U) (at level 80) : term_scope .

  Parameter no_need_of_instance' : forall (R : relation term) t1 t2, R t1 t2 -> axiom R t1 t2.

  Parameter context_in :
    forall R t1 t2, rwr R t1 t2 -> forall f l l', rwr R (Term f (l ++ t1  :: l')) (Term f (l ++ t2 :: l')).

  Parameter general_context :
    forall R f l1 l2, rwr_list (one_step R) l1 l2 -> rwr R (Term f l1) (Term f l2).

  Parameter one_step_apply_subst :
     forall R t1 t2 sigma , one_step R t1 t2 ->
	one_step R (apply_subst sigma t1) (apply_subst sigma t2).

 Parameter one_step_subterm_subst :
   forall R s t sigma,
   refl_trans_clos (union _ (one_step R) (direct_subterm)) s t ->
   refl_trans_clos (union _ (one_step R) (direct_subterm)) (apply_subst sigma s) (apply_subst sigma t).

  Parameter  rwr_apply_subst :
    forall R t1 t2 sigma, rwr R t1 t2 ->
      rwr R (apply_subst sigma t1) (apply_subst sigma t2).

  Parameter rwr_inv :
    forall A R (eq : A -> A -> Prop) (f : term -> A),
      (forall a1 a2 a3, eq a1 a2 -> eq a2 a3 -> eq a1 a3) ->
      (forall t1 t2, one_step R t1 t2 -> eq (f t1) (f t2)) ->
      forall t1 t2, rwr R t1 t2 -> eq (f t1) (f t2).

  Parameter one_step_incl :
    forall (R1 R2 : term -> term -> Prop) ,
      (forall t1 t2, R1 t1 t2 -> R2 t1 t2) ->
      forall t1 t2, one_step R1 t1 t2 -> one_step R2 t1 t2.

  Parameter rwr_incl :
    forall (R1 R2 : term -> term -> Prop),
      (forall t1 t2, R1 t1 t2 -> R2 t1 t2) ->
      forall t1 t2, rwr R1 t1 t2 -> rwr R2 t1 t2.

 Parameter rwr_list_incl :
    forall (R1 R2 : term -> term -> Prop),
      (forall t1 t2, R1 t1 t2 -> R2 t1 t2) ->
      forall l1 l2, rwr_list (one_step R1) l1 l2 -> rwr_list (one_step R2) l1 l2.

  Parameter th_eq_closure_one_step :
    forall (R : term -> term -> Prop),
      forall t1 t2, one_step (rwr R) t1 t2 -> rwr R t1 t2.

  Parameter th_eq_closure :
    forall t1 t2 (R : term -> term -> Prop),
      rwr (rwr R) t1 t2 -> rwr R t1 t2.

  Parameter  R_in_rwr_R :
  forall t1 t2 (R : term -> term -> Prop),
   R t1 t2 -> rwr R t1 t2.

 Parameter split_rel :
  forall R1 R2 s t, one_step (union _ R1 R2) t s <->
  (one_step R1 t s \/ one_step R2 t s).

  Parameter  no_need_of_instance_is_modular :
    forall (R1 R2 : term -> term -> Prop),
      (forall t1 t2, axiom R1 t1 t2 -> R1 t1 t2) ->
      (forall t1 t2, axiom R2 t1 t2 -> R2 t1 t2) ->
      (forall t1 t2, axiom (union term R1 R2) t1 t2 -> (union term R1 R2) t1 t2).

Definition non_overlapping (R : relation term) :=
  forall l1 r1 l2 r2 sigma tau, R r1 l1 -> R r2 l2 ->
  forall f l p, subterm_at_pos l1 p = Some (Term f l) ->
  apply_subst sigma (Term f l) = apply_subst tau l2 -> p = nil /\ l1 = l2 /\ r1 = r2.

Definition overlay (R : relation term) :=
  forall l1 r1 l2 r2 sigma tau, R r1 l1 -> R r2 l2 ->
  forall f l p, subterm_at_pos l1 p = Some (Term f l) ->
  apply_subst sigma (Term f l) = apply_subst tau l2 -> p = nil.

  Definition sym_refl R (t1 t2 : term) := R t1 t2 \/ R t2 t1 \/ t1 = t2.
  Definition th_eq R := rwr (sym_refl R).

Notation " T '<-[' R '*]->' U " := (th_eq R T U) (at level 80) : term_scope .

  Parameter th_refl : forall R t, th_eq R t t.

  Parameter th_sym : forall R t1 t2, th_eq R t1 t2 -> th_eq R t2 t1.

Parameter rwr_at_pos :
 forall R p t sigma u v t', subterm_at_pos t p = Some (apply_subst sigma u) ->
  rwr R u v -> t' = (replace_at_pos t (apply_subst sigma v) p) -> rwr R t t'.

(** *** Accessibility of the rewriting relation. *)
Parameter acc_one_step :  forall R t, Acc (one_step R) t <-> Acc (rwr R) t.

Parameter rwr_sub_acc_sub_acc_sub :
  forall R l1 l2, refl_trans_clos (one_step_list (one_step R)) l2 l1 ->
  (forall s, In s l1 -> Acc (one_step R) s) -> (forall s, In s l2 -> Acc (one_step R) s).

Parameter acc_subterms :
  forall R, (forall x t, ~ (R t (Var x))) ->
  forall f l, (forall t, In t l -> Acc (one_step R) t) -> constructor R f ->
                   Acc (one_step R) (Term f l).

Parameter acc_subterms_1 :
   forall R t s, Acc (one_step R) t -> direct_subterm s t -> Acc (one_step R) s.

Parameter acc_subterms_3 :
   forall R p t s, Acc (one_step R) t -> subterm_at_pos t p = Some s ->
   Acc (one_step R) s.

Parameter acc_with_subterm_subterms :
  forall R t, Acc (union _ (one_step R) direct_subterm) t ->
                 forall s, direct_subterm s t ->
                   Acc (union _ (one_step R) direct_subterm) s.

Parameter acc_with_subterm :
  forall R t, Acc (one_step R) t <-> Acc (union _ (one_step R) direct_subterm) t.

Parameter var_acc :
   forall R l x sigma, In x (var_list_list l) ->
   (forall t, In t (map (apply_subst sigma) l) -> Acc (one_step R) t) ->
   Acc (one_step R) (apply_subst sigma (Var x)).

Parameter term_acc_subst :
  forall R t sigma, Acc (one_step R) (apply_subst sigma t) -> Acc (one_step R) t.

Parameter nf_one_step_subterm:
  forall R t, nf (one_step R) t -> forall s, direct_subterm s t -> nf (one_step R) s.

Parameter compute_red : list (term * term) -> term -> list term.

Parameter compute_red_is_correct :
   forall rule_list : list (term * term),
   (forall l r : term, In (l, r) rule_list -> forall v : variable, In v (var_list r) -> In v (var_list l)) ->
   forall R : term -> term -> Prop,
   (forall l r : term, R r l <-> In (l, r) rule_list) ->
   forall t s : term, In s (compute_red rule_list t) <-> one_step R s t.

Parameter well_formed_rwr :
  forall (R : relation term), (forall s t, R s t -> forall x, In x (var_list s) -> In x (var_list t)) ->
  (forall r l, R r l -> well_formed r /\ well_formed l) ->
  forall s t, rwr R t s -> well_formed s -> well_formed t.

Parameter Acc_var :
      forall R : relation term, (forall v t, ~ R t (Var v)) -> forall x, Acc (one_step R) (Var x).

Parameter acc_well_formed_acc_all :
      forall R : relation term,
       (forall s t, R s t -> forall x : variable, In x (var_list s) -> In x (var_list t)) ->
       (forall v t, ~ R t (Var v)) ->
       (forall s t, R s t -> well_formed s /\ well_formed t) ->
       forall (inject : nat -> variable) (inject_inv : variable -> nat),
       (forall n : nat, inject_inv (inject n) = n) ->
       (forall t : term, well_formed t -> Acc (one_step R) t) ->
       forall t : term, Acc (one_step R) t.

Parameter are_constructors_of_R :
  forall R, (forall v t, ~ R t (Var v)) ->
  forall  f l t', (refl_trans_clos (one_step R) t' (Term f l)) ->
  (~defined R f) ->
  exists l', t' = Term f l' /\ refl_trans_clos (one_step_list (one_step R)) l' l.

End EqTh.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing included %\ensuremath{\subseteq}% #⊆# *)

Require Export CoRN.algebra.CSetoidFun.

Section inclusion.

(**
** Inclusion

Let [S] be a setoid, and [P], [Q], [R] be predicates on [S]. *)

Variable S : CSetoid.

Definition included (P Q : S -> CProp) : CProp := forall x : S, P x -> Q x.

Section Basics.

Variables P Q R : S -> CProp.

Lemma included_refl : included P P.
Proof.
 red in |- *; intros.
 auto.
Qed.

Lemma included_trans : included P Q -> included Q R -> included P R.
Proof.
 intros.
 red in |- *; intros.
 apply X0; apply X; auto.
Qed.

Lemma included_conj : forall P Q R, included P Q -> included P R -> included P (Conj Q R).
Proof.
 intros.
 red in |- *; red in X, X0.
 intros; red in |- *.
 split.
  apply X; assumption.
 apply X0; assumption.
Qed.

Lemma included_conj' : included (Conj P Q) P.
Proof.
 exact (prj1 _ P Q).
Qed.

Lemma included_conj'' : included (Conj P Q) Q.
Proof.
 exact (prj2 _ P Q).
Qed.

Lemma included_conj_lft : included R (Conj P Q) -> included R P.
Proof.
 red in |- *.
 unfold conjP.
 intros H1 x H2.
 elim (H1 x); auto.
Qed.

Lemma included_conj_rht : included R (Conj P Q) -> included R Q.
Proof.
 red in |- *. unfold conjP.
 intros H1 x H2.
 elim (H1 x); auto.
Qed.

Lemma included_extend : forall (H : forall x, P x -> CProp),
 included R (extend P H) -> included R P.
Proof.
 intros H0 H1.
 red in |- *.
 unfold extend in H1.
 intros.
 elim (H1 x); auto.
Qed.

End Basics.

(**
%\begin{convention}% Let [I,R:S->CProp] and [F G:(PartFunct S)], and denote
by [P] and [Q], respectively, the domains of [F] and [G].
%\end{convention}%
*)

Variables F G : (PartFunct S).

(* begin hide *)
Let P := Dom F.
Let Q := Dom G.
(* end hide *)

Variable R : S -> CProp.

Lemma included_FComp : included R P -> (forall x Hx, (R x) -> Q (F x Hx)) -> included R (Dom (G[o]F)).
Proof.
 intros HP HQ.
 simpl in |- *.
 red in |- *; intros x Hx.
 exists (HP x Hx).
 apply HQ.
 assumption.
Qed.

Lemma included_FComp' : included R (Dom (G[o]F)) -> included R P.
Proof.
 intro H; simpl in H; red in |- *; intros x Hx.
 elim (H x Hx); auto.
Qed.

End inclusion.

Arguments included [S].

#[global]
Hint Resolve included_refl included_FComp : included.

#[global]
Hint Immediate included_trans included_FComp' : included.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Require Export common.lhs_equ_reduce.rhs_low_reduce.
Require Export common.lhs_equ_reduce.rhs_upp_reduce.
Require Export common.lhs_equ_reduce.rhs_equ_reduce.
Require Export common.lhs_equ_reduce.rhs_other_reduce.

Import WfExtensionality.

Lemma subtype_equ_reduce :
  forall T1 L1 T1', T1 = t_equ L1 T1' ->
               forall T2, subtype T1 T2 = match T2 with
                                     | t_upp L2 T2' => andb (eq_label L1 L2)
                                                           (subtype T1' T2')
                                     | t_low L2 T2' => andb (eq_label L1 L2)
                                                           (subtype T2' T1')
                                     | t_equ L2 T2' => andb (eq_label L1 L2)
                                                           (andb (subtype T1' T2')
                                                                 (subtype T2' T1'))
                                     | _ => false
                                     end.
Proof.
  intros; subst; destruct T2;
    try solve [eapply subtype_equ_other_reduce; crush].

  eapply subtype_equ_upp_reduce; crush.

  eapply subtype_equ_low_reduce; crush.

  eapply subtype_equ_equ_reduce; crush.
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                              inversionSL.v                               *)
(****************************************************************************)

(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

                       (* Inversion de sigma_lift (relSL) *)
Require Import sur_les_relations.
Require Import TS.
Require Import sigma_lift.

(*****************
Definition e_invSL:=[b:wsort][M:(TS b)][N:(TS b)]
(<[b:wsort]Prop>Case M of
 (* var *) [n:nat] False
 (* app *) [M1,M2:terms]
           (<[b:wsort]Prop>Case N of
            (* var *) [n:nat]False
            (* app *) [N1,N2:terms]
                      ((relSL M1 N1) /\ (M2=N2))
                   \/ ((M1=N1) /\ (relSL M2 N2))
            (* lam *) [N1:terms]False
            (* env *) [N1:terms][N2:sub_explicits]False
            (* id  *) False
            (*  |  *) False
            (*  .  *) [N1:terms][N2:sub_explicits]False
            (*  o  *) [N1,N2:sub_explicits]False
            (* ||  *) [N1:sub_explicits]False
            (*  X  *) [n:nat]False
            (*  x  *) [n:nat]False  end)
 (* lam *) [M1:terms]
           (<[b:wsort]Prop>Case N of
            (* var *) [n:nat]False
            (* app *) [N1,N2:terms]False
            (* lam *) [N1:terms](relSL M1 N1)
            (* env *) [N1:terms][N2:sub_explicits]False
            (* id  *) False
            (*  |  *) False
            (*  .  *) [N1:terms][N2:sub_explicits]False
            (*  o  *) [N1,N2:sub_explicits]False
            (* ||  *) [N1:sub_explicits]False
            (*  X  *) [n:nat]False
            (*  x  *) [n:nat]False  end)
 (* env *) [M1:terms][M2:sub_explicits]
           (<[b:wsort]Prop>Case N of
            (* var *) [n:nat]
                 (Ex( ([m:nat] (M1=(var m)) /\ (n=(S m)) /\ (M2=shift) )))
             \/  (Ex( ([s:sub_explicits] (M1=(var O)) /\
                                  (M2=(lift s)) /\ (n=O) )))
             \/  (Ex( ([s:sub_explicits] (M1=(var O)) /\
                            (M2=(cons (var n) s)) )))
             \/ ((M1=(var n)) /\ (M2=id))
            (* app *) [N1,N2:terms]
                (Ex( ([a:terms] (Ex( ([b:terms] (M1=(app a b))
                    /\ (N1=(env a M2)) /\ (N2=(env b M2)) ))) )))
             \/ (Ex( ([s:sub_explicits] (M1=(var O)) /\
                            (M2=(cons (app N1 N2) s)) )))
             \/ ((M1=(app N1 N2)) /\ (M2=id))
            (* lam *) [N1:terms]
                (Ex( ([a:terms] (M1=(lambda a))
                                 /\ (N1=(env a (lift M2))) )))
             \/ (Ex( ([s:sub_explicits] (M1=(var O)) /\
                            (M2=(cons (lambda N1) s)) )))
             \/ ((M1=(lambda N1)) /\ (M2=id) )
            (* env *) [N1:terms][N2:sub_explicits]
                (Ex( ([s:sub_explicits] (M1=(env N1 s)) /\
                            (N2=(comp s M2)) )))
             \/ (Ex( ([n:nat] (M1=(var n)) /\
                       (M2=(comp shift N2)) /\ (N1=(var (S n))) )))
             \/ (Ex( ([s:sub_explicits] (M1=(var O)) /\
                               (M2=(cons (env N1 N2) s)) )))
             \/ (Ex( ([s:sub_explicits] (M1=(var O)) /\
                        (M2=(comp (lift s) N2)) /\ (N1=(var O)) )))
             \/ (Ex( ([n:nat] (Ex( ([a:terms] (M1=(var (S n))) /\
                        (M2=(cons a N2)) /\ (N1=(var n)) ))) )))
             \/ (Ex( ([n:nat] (Ex( ([s:sub_explicits]
                   (M1=(var (S n))) /\ (M2=(lift s)) /\
                   (N1=(var n)) /\ (N2=(comp s shift)) ))) )))
             \/ (Ex( ([n:nat] (Ex( ([s:sub_explicits]
                  (Ex( ([t:sub_explicits] (M1=(var (S n))) /\
                  (M2=(comp (lift s) t)) /\ (N1=(var n)) /\
                  (N2=(comp s (comp shift t))) ))) ))) )))
             \/ ((M1=(env N1 N2)) /\ (M2=id))
             \/ ((relSL M1 N1) /\ (M2=N2))
             \/ ((M1=N1) /\ (relSL M2 N2))
            (* id  *) False
            (*  |  *) False
            (*  .  *) [N1:terms][N2:sub_explicits]False
            (*  o  *) [N1,N2:sub_explicits]False
            (* ||  *) [N1:sub_explicits]False
            (*  X  *) [n:nat]
             (Ex( ([s:sub_explicits] (M1=(var O)) /\
                            (M2=(cons (meta_X n) s)) )))
             \/ ((M1=(meta_X n)) /\ (M2=id))
            (*  x  *) [n:nat]False  end)
 (* id  *) False
 (*  |  *) False
 (*  .  *) [M1:terms][M2:sub_explicits]
           (<[b:wsort]Prop>Case N of
            (* var *) [n:nat]False
            (* app *) [N1,N2:terms]False
            (* lam *) [N1:terms]False
            (* env *) [N1:terms][N2:sub_explicits]False
            (* id  *) False
            (*  |  *) False
            (*  .  *) [N1:terms][N2:sub_explicits]
                      ((relSL M1 N1) /\ (M2=N2))
                      \/  ((M1=N1) /\ (relSL M2 N2))
            (*  o  *) [N1,N2:sub_explicits]False
            (* ||  *) [N1:sub_explicits]False
            (*  X  *) [n:nat]False
            (*  x  *) [n:nat]False  end)
 (*  o  *) [M1,M2:sub_explicits]
           (<[b:wsort]Prop>Case N of
            (* var *) [n:nat]False
            (* app *) [N1,N2:terms]False
            (* lam *) [N1:terms]False
            (* env *) [N1:terms][N2:sub_explicits]False
            (* id  *) (Ex( ([a:terms] (M1=shift) /\
                           (M2=(cons a id)) )))
                   \/ ((M1=id) /\ (M2=id))
            (*  |  *) (Ex( ([a:terms] (M1=shift) /\
                        (M2=(cons a shift)) )))
                   \/ ((M1=id) /\ (M2=shift))
                   \/ ((M1=shift) /\ (M2=id))
            (*  .  *) [N1:terms][N2:sub_explicits]
                  (Ex( ([a:terms](Ex( ([s:sub_explicits]
                     (M1=(cons a s)) /\ (N1=(env a M2)) /\
                     (N2=(comp s M2)) ))) )))
               \/ (Ex( ([a:terms] (M1=shift) /\
                        (M2=(cons a (cons N1 N2))) )))
               \/ (Ex( ([s:sub_explicits]
                     (Ex( ([t:sub_explicits] (M1=(lift s)) /\ (M2=(cons N1 t))
                         /\ (N2=(comp s t)) ))) )))
               \/ ((M1=id) /\ (M2=(cons N1 N2)))
               \/ ((M1=(cons N1 N2)) /\ (M2=id))
            (*  o  *) [N1,N2:sub_explicits]
                 (Ex( ([t:sub_explicits]
                   (M1=(comp N1 t)) /\ (N2=(comp t M2)) )))
              \/ (Ex( ([a:terms] (M1=shift) /\ (M2=(cons a (comp N1 N2))) )))
              \/ ((M1=shift) /\ (M2=(lift N1)) /\ (N2=shift))
              \/ (Ex( ([t:sub_explicits] (M1=shift) /\
                   (M2=(comp (lift N1) t)) /\ (N2=(comp shift t)) )))
              \/ (Ex( ([s:sub_explicits]
                 (Ex( ([t:sub_explicits] (M1=(lift s)) /\
                    (M2=(comp (lift t) N2)) /\ (N1=(lift (comp s t)))))))))
              \/ ((M1=id) /\ (M2=(comp N1 N2)))
              \/ ((M1=(comp N1 N2)) /\ (M2=id))
              \/ ((relSL M1 N1) /\ (M2=N2))
              \/ ((M1=N1) /\ (relSL M2 N2))
            (* ||  *) [N1:sub_explicits]
                 (Ex( ([a:terms] (M1=shift) /\ (M2=(cons a (lift N1))))))
              \/ (Ex( ([s:sub_explicits]
                 (Ex( ([t:sub_explicits] (M1=(lift s)) /\
                 (M2=(lift t)) /\ (N1=(comp s t)) ))) )))
              \/ ((M1=id) /\ (M2=(lift N1)))
              \/ ((M1=(lift N1)) /\ (M2=id))
            (*  X  *) [n:nat]False
            (*  x  *) [n:nat]
                 (Ex( ([a:terms] (M1=shift) /\ (M2=(cons a (meta_x n))))))
                   \/ ((M1=id) /\ (M2=(meta_x n)))
                   \/ ((M1=(meta_x n)) /\ (M2=id))  end)
 (* ||  *) [M1:sub_explicits]
           (<[b:wsort]Prop>Case N of
            (* var *) [n:nat]False
            (* app *) [N1,N2:terms]False
            (* lam *) [N1:terms]False
            (* env *) [N1:terms][N2:sub_explicits]False
            (* id  *) (M1=id)
            (*  |  *) False
            (*  .  *) [N1:terms][N2:sub_explicits]False
            (*  o  *) [N1,N2:sub_explicits]False
            (* ||  *) [N1:sub_explicits](relSL M1 N1)
            (*  X  *) [n:nat]False
            (*  x  *) [n:nat]False end)
  (*  X  *) [n:nat]False
  (*  x  *) [n:nat]False  end).

****************)

Definition e_invSL (b : wsort) (M N : TS b) :=
  match M, N with
  | lift M1, id => M1 = id
  | lift M1, lift N1 => e_relSL _ M1 N1
  | lambda M1, lambda N1 => e_relSL _ M1 N1
  | app M1 M2, app N1 N2 =>
      e_relSL _ M1 N1 /\ M2 = N2 \/ M1 = N1 /\ e_relSL _ M2 N2
  | env M1 M2, var n as V =>
      (exists m : nat, M1 = var m /\ n = S m /\ M2 = shift) \/
      (exists s : sub_explicits, M1 = var 0 /\ M2 = lift s /\ n = 0) \/
      (exists s : sub_explicits, M1 = var 0 /\ M2 = cons V s) \/
      M1 = V /\ M2 = id
  | env M1 M2, app N1 N2 as A =>
      (exists a : terms,
         (exists b : terms, M1 = app a b /\ N1 = env a M2 /\ N2 = env b M2)) \/
      (exists s : sub_explicits, M1 = var 0 /\ M2 = cons A s) \/
      M1 = A /\ M2 = id
  | env M1 M2, lambda N1 as L =>
      (exists a : terms, M1 = lambda a /\ N1 = env a (lift M2)) \/
      (exists s : sub_explicits, M1 = var 0 /\ M2 = cons L s) \/
      M1 = L /\ M2 = id
  | env M1 M2, env N1 N2 as E =>
      (exists s : sub_explicits, M1 = env N1 s /\ N2 = comp s M2) \/
      (exists n : nat, M1 = var n /\ M2 = comp shift N2 /\ N1 = var (S n)) \/
      (exists s : sub_explicits, M1 = var 0 /\ M2 = cons E s) \/
      (exists s : sub_explicits,
         M1 = var 0 /\ M2 = comp (lift s) N2 /\ N1 = var 0) \/
      (exists n : nat,
         (exists a : terms, M1 = var (S n) /\ M2 = cons a N2 /\ N1 = var n)) \/
      (exists n : nat,
         (exists s : sub_explicits,
            M1 = var (S n) /\ M2 = lift s /\ N1 = var n /\ N2 = comp s shift)) \/
      (exists n : nat,
         (exists s : sub_explicits,
            (exists t : sub_explicits,
               M1 = var (S n) /\
               M2 = comp (lift s) t /\
               N1 = var n /\ N2 = comp s (comp shift t)))) \/
      M1 = E /\ M2 = id \/
      e_relSL _ M1 N1 /\ M2 = N2 \/ M1 = N1 /\ e_relSL _ M2 N2
  | env M1 M2, meta_X n =>
      (exists s : sub_explicits, M1 = var 0 /\ M2 = cons (meta_X n) s) \/
      M1 = meta_X n /\ M2 = id
  | cons M1 M2, cons N1 N2 =>
      e_relSL _ M1 N1 /\ M2 = N2 \/ M1 = N1 /\ e_relSL _ M2 N2
  | comp M1 M2, id =>
      (exists a : terms, M1 = shift /\ M2 = cons a id) \/ M1 = id /\ M2 = id
  | comp M1 M2, shift =>
      (exists a : terms, M1 = shift /\ M2 = cons a shift) \/
      M1 = id /\ M2 = shift \/ M1 = shift /\ M2 = id
  | comp M1 M2, cons N1 N2 as C =>
      (exists a : terms,
         (exists s : sub_explicits,
            M1 = cons a s /\ N1 = env a M2 /\ N2 = comp s M2)) \/
      (exists a : terms, M1 = shift /\ M2 = cons a C) \/
      (exists s : sub_explicits,
         (exists t : sub_explicits,
            M1 = lift s /\ M2 = cons N1 t /\ N2 = comp s t)) \/
      M1 = id /\ M2 = C \/ M1 = C /\ M2 = id
  | comp M1 M2, comp N1 N2 =>
      (exists t : sub_explicits, M1 = comp N1 t /\ N2 = comp t M2) \/
      (exists a : terms, M1 = shift /\ M2 = cons a (comp N1 N2)) \/
      M1 = shift /\ M2 = lift N1 /\ N2 = shift \/
      (exists t : sub_explicits,
         M1 = shift /\ M2 = comp (lift N1) t /\ N2 = comp shift t) \/
      (exists s : sub_explicits,
         (exists t : sub_explicits,
            M1 = lift s /\ M2 = comp (lift t) N2 /\ N1 = lift (comp s t))) \/
      M1 = id /\ M2 = comp N1 N2 \/
      M1 = comp N1 N2 /\ M2 = id \/
      e_relSL _ M1 N1 /\ M2 = N2 \/ M1 = N1 /\ e_relSL _ M2 N2
  | comp M1 M2, lift N1 as L =>
      (exists a : terms, M1 = shift /\ M2 = cons a L) \/
      (exists s : sub_explicits,
         (exists t : sub_explicits,
            M1 = lift s /\ M2 = lift t /\ N1 = comp s t)) \/
      M1 = id /\ M2 = L \/ M1 = L /\ M2 = id
  | comp M1 M2, meta_x n as x =>
      (exists a : terms, M1 = shift /\ M2 = cons a x) \/
      M1 = id /\ M2 = x \/ M1 = x /\ M2 = id
  | _, _ => False
  end.
(***********)

Notation invSL := (e_invSL _) (only parsing).
(* <Warning> : Syntax is discontinued *)

Goal forall (b : wsort) (M N : TS b), e_systemSL _ M N -> e_invSL _ M N.
simple induction 1; simple induction 1; intros.
(* app *)
simpl in |- *; left; exists a0; exists b1; auto.
(* lambda *)
simpl in |- *; left; exists a0; auto.
(* clos *)
simpl in |- *; left; exists s; auto.
(* varshift1 *)
simpl in |- *; left; exists n; auto.
(* varshift2 *)
simpl in |- *; right; left; exists n; auto.
(* fvarcons *)
pattern a0 in |- *; apply terms_ind; intros; simpl in |- *.
 (* var *)
do 2 right; left; exists s; auto.
 (* app *)
right; left; exists s; auto.
 (* lam *)
right; left; exists s; auto.
 (* env *)
do 2 right; left; exists s; auto.
 (* X *)
left; exists s; auto.
(* fvarlift1 *)
simpl in |- *; right; left; exists s; auto.
(* fvarlift2 *)
simpl in |- *; do 3 right; left; exists s; auto.
(* rvarcons *)
simpl in |- *; do 4 right; left; exists n; exists a0; auto.
(* rvarlift1 *)
simpl in |- *; do 5 right; left; exists n; exists s; auto.
(* rvarlift2 *)
simpl in |- *; do 6 right; left; exists n; exists s; exists t; auto.
(* assenv *)
simpl in |- *; left; exists t0; auto.
(* mapenv *)
simpl in |- *; left; exists a; exists s0; auto.
(* shiftcons *)
pattern s0 in |- *; apply sub_explicits_ind; intros; simpl in |- *.
 (* id *)
left; exists a; auto.
 (*| *)
left; exists a; auto.
 (* . *)
right; left; exists a; auto.
 (* o *)
right; left; exists a; auto.
 (*|| *)
left; exists a; auto.
 (* x *)
left; exists a; auto.
(* shiftlift1 *)
simpl in |- *; do 2 right; left; auto.
(* shiftlift2 *)
simpl in |- *; do 3 right; left; exists t0; auto.
(* lift1 *)
simpl in |- *; right; left; exists s0; exists t0; auto.
(* lift2 *)
simpl in |- *; do 4 right; left; exists s0; exists t0; auto.
(* liftenv *)
simpl in |- *; right; right; left; exists s0; exists t0; auto.
(* idl *)
pattern s0 in |- *; apply sub_explicits_ind; intros; simpl in |- *.
 (* id *)
right; auto.
 (*| *)
right; left; auto.
 (* . *)
do 3 right; left; auto.
 (* o *)
do 5 right; left; auto.
 (*|| *)
do 2 right; left; auto.
 (* x *)
right; left; auto.
(* idr *)
pattern s0 in |- *; apply sub_explicits_ind; intros; simpl in |- *.
 (* id *)
right; auto.
 (*| *)
right; right; auto.
 (* . *)
do 4 right; auto.
 (* o *)
do 6 right; left; auto.
 (*|| *)
do 3 right; auto.
 (* x *)
right; right; auto.
(* liftid *)
simpl in |- *; auto.
(* id *)
pattern a0 in |- *; apply terms_ind; intros; simpl in |- *.
 (* var *)
do 3 right; auto.
 (* app *)
do 2 right; auto.
 (* lam *)
do 2 right; auto.
 (* env *)
do 7 right; left; auto.
 (* X *)
right; auto.
Save lemma1_inv_systemSL.
Hint Resolve lemma1_inv_systemSL.

Goal forall (b : wsort) (M N : TS b), e_relSL _ M N -> e_invSL _ M N.
simple induction 1; intros; simpl in |- *; auto 11.
Save lemma1_invSL.
Hint Resolve lemma1_invSL.