(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id: Equalities.v 13475 2010-09-29 14:33:13Z letouzey $ *)

Require Export RelationClasses.

Set Implicit Arguments.
Unset Strict Implicit.

(** * Structure with just a base type [t] *)

Module Type Typ.
  Parameter Inline t : Type.
End Typ.

(** * Structure with an equality relation [eq] *)

Module Type HasEq (Import T:Typ).
  Parameter Inline eq : t -> t -> Prop.
End HasEq.

Module Type Eq := Typ <+ HasEq.

Module Type EqNotation (Import E:Eq).
  Infix "==" := eq (at level 70, no associativity).
  Notation "x ~= y" := (~eq x y) (at level 70, no associativity).
End EqNotation.

Module Type Eq' := Eq <+ EqNotation.

(** * Specification of the equality via the [Equivalence] type class *)

Module Type IsEq (Import E:Eq).
  Declare Instance eq_equiv : Equivalence eq.
End IsEq.

(** * Earlier specification of equality by three separate lemmas. *)

Module Type IsEqOrig (Import E:Eq').
  Axiom eq_refl : forall x : t, x==x.
  Axiom eq_sym : forall x y : t, x==y -> y==x.
  Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z.
  Hint Immediate eq_sym.
  Hint Resolve eq_refl eq_trans.
End IsEqOrig.

(** * Types with decidable equality *)

Module Type HasEqDec (Import E:Eq').
  Parameter eq_dec : forall x y : t, { x==y } + { ~ x==y }.
End HasEqDec.

(** * Boolean Equality *)

(** Having [eq_dec] is the same as having a boolean equality plus
    a correctness proof. *)

Module Type HasEqBool (Import E:Eq').
  Parameter Inline eqb : t -> t -> bool.
  Parameter eqb_eq : forall x y, eqb x y = true <-> x==y.
End HasEqBool.

(** From these basic blocks, we can build many combinations
    of static standalone module types. *)

Module Type EqualityType := Eq <+ IsEq.

Module Type EqualityTypeOrig := Eq <+ IsEqOrig.

Module Type EqualityTypeBoth <: EqualityType <: EqualityTypeOrig
 := Eq <+ IsEq <+ IsEqOrig.

Module Type DecidableType <: EqualityType
 := Eq <+ IsEq <+ HasEqDec.

Module Type DecidableTypeOrig <: EqualityTypeOrig
 := Eq <+ IsEqOrig <+ HasEqDec.

Module Type DecidableTypeBoth <: DecidableType <: DecidableTypeOrig
 := EqualityTypeBoth <+ HasEqDec.

Module Type BooleanEqualityType <: EqualityType
 := Eq <+ IsEq <+ HasEqBool.

Module Type BooleanDecidableType <: DecidableType <: BooleanEqualityType
 := Eq <+ IsEq <+ HasEqDec <+ HasEqBool.

Module Type DecidableTypeFull <: DecidableTypeBoth <: BooleanDecidableType
 := Eq <+ IsEq <+ IsEqOrig <+ HasEqDec <+ HasEqBool.

(** Same, with notation for [eq] *)

Module Type EqualityType' := EqualityType <+ EqNotation.
Module Type EqualityTypeOrig' := EqualityTypeOrig <+ EqNotation.
Module Type EqualityTypeBoth' := EqualityTypeBoth <+ EqNotation.
Module Type DecidableType' := DecidableType <+ EqNotation.
Module Type DecidableTypeOrig' := DecidableTypeOrig <+ EqNotation.
Module Type DecidableTypeBoth' := DecidableTypeBoth <+ EqNotation.
Module Type BooleanEqualityType' := BooleanEqualityType <+ EqNotation.
Module Type BooleanDecidableType' := BooleanDecidableType <+ EqNotation.
Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation.

(** * Compatibility wrapper from/to the old version of
      [EqualityType] and [DecidableType] *)

Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E.
 Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv.
 Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv.
 Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv.
End BackportEq.

Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E.
 Instance eq_equiv : Equivalence E.eq.
 Proof. exact (Build_Equivalence _ _ F.eq_refl F.eq_sym F.eq_trans). Qed.
End UpdateEq.

Module Backport_ET (E:EqualityType) <: EqualityTypeBoth
 := E <+ BackportEq.

Module Update_ET (E:EqualityTypeOrig) <: EqualityTypeBoth
 := E <+ UpdateEq.

Module Backport_DT (E:DecidableType) <: DecidableTypeBoth
 := E <+ BackportEq.

Module Update_DT (E:DecidableTypeOrig) <: DecidableTypeBoth
 := E <+ UpdateEq.

(** * Having [eq_dec] is equivalent to having [eqb] and its spec. *)

Module HasEqDec2Bool (E:Eq)(F:HasEqDec E) <: HasEqBool E.
 Definition eqb x y := if F.eq_dec x y then true else false.
 Lemma eqb_eq : forall x y, eqb x y = true <-> E.eq x y.
 Proof.
  intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ].
  auto with *.
  split. discriminate. intro EQ; elim NEQ; auto.
 Qed.
End HasEqDec2Bool.

Module HasEqBool2Dec (E:Eq)(F:HasEqBool E) <: HasEqDec E.
 Lemma eq_dec : forall x y, {E.eq x y}+{~E.eq x y}.
 Proof.
  intros x y. assert (H:=F.eqb_eq x y).
  destruct (F.eqb x y); [left|right].
  apply -> H; auto.
  intro EQ. apply H in EQ. discriminate.
 Defined.
End HasEqBool2Dec.

Module Dec2Bool (E:DecidableType) <: BooleanDecidableType
 := E <+ HasEqDec2Bool.

Module Bool2Dec (E:BooleanEqualityType) <: BooleanDecidableType
 := E <+ HasEqBool2Dec.

(** * UsualDecidableType

   A particular case of [DecidableType] where the equality is
   the usual one of Coq. *)

Module Type HasUsualEq (Import T:Typ) <: HasEq T.
 Definition eq := @Logic.eq t.
End HasUsualEq.

Module Type UsualEq <: Eq := Typ <+ HasUsualEq.

Module Type UsualIsEq (E:UsualEq) <: IsEq E.
 (* No Instance syntax to avoid saturating the Equivalence tables *)
 Definition eq_equiv : Equivalence E.eq := eq_equivalence.
End UsualIsEq.

Module Type UsualIsEqOrig (E:UsualEq) <: IsEqOrig E.
 Definition eq_refl := @Logic.eq_refl E.t.
 Definition eq_sym := @Logic.eq_sym E.t.
 Definition eq_trans := @Logic.eq_trans E.t.
End UsualIsEqOrig.

Module Type UsualEqualityType <: EqualityType
 := UsualEq <+ UsualIsEq.

Module Type UsualDecidableType <: DecidableType
 := UsualEq <+ UsualIsEq <+ HasEqDec.

Module Type UsualDecidableTypeOrig <: DecidableTypeOrig
 := UsualEq <+ UsualIsEqOrig <+ HasEqDec.

Module Type UsualDecidableTypeBoth <: DecidableTypeBoth
 := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec.

Module Type UsualBoolEq := UsualEq <+ HasEqBool.

Module Type UsualDecidableTypeFull <: DecidableTypeFull
 := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec <+ HasEqBool.

(** Some shortcuts for easily building a [UsualDecidableType] *)

Module Type MiniDecidableType.
 Include Typ.
 Parameter eq_dec : forall x y : t, {x=y}+{~x=y}.
End MiniDecidableType.

Module Make_UDT (M:MiniDecidableType) <: UsualDecidableTypeBoth
 := M <+ HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig.

Module Make_UDTF (M:UsualBoolEq) <: UsualDecidableTypeFull
 := M <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqBool2Dec.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Decidable.

Section with_context.
  Context {base_type_code Name var} (Context : @Context base_type_code Name var)
          (base_type_code_dec : DecidableRel (@eq base_type_code))
          (Name_dec : DecidableRel (@eq Name)).

  Fixpoint find_Name n
           {T : flat_type base_type_code}
    : interp_flat_type (fun _ => Name) T -> option base_type_code
    := match T with
       | Tbase t' => fun n' : Name => if dec (n = n') then Some t' else None
       | Unit => fun _ => None
       | Prod A B
         => fun ab : interp_flat_type _ A * interp_flat_type _ B
            => match @find_Name n B (snd ab), @find_Name n A (fst ab) with
               | Some tb, _ => Some tb
               | None, Some ta => Some ta
               | None, None => None
               end
       end.

  Fixpoint find_Name_and_val {var'} t (n : Name)
           {T : flat_type base_type_code}
    : interp_flat_type (fun _ => Name) T -> interp_flat_type var' T -> option (var' t) -> option (var' t)
    := match T with
       | Tbase t' => fun (n' : Name) v default
                     => if dec (n = n')
                        then cast_if_eq t' t v
                        else default
       | Unit => fun _ _ default => default
       | Prod A B
         => fun (ab : interp_flat_type _ A * interp_flat_type _ B)
                (a'b' : interp_flat_type _ A * interp_flat_type _ B)
                default
            => @find_Name_and_val
                 var' t n B (snd ab) (snd a'b')
                 (@find_Name_and_val
                    var' t n A (fst ab) (fst a'b')
                    default)
       end.

  Class ContextOk :=
    { lookupb_extendb_same
      : forall (ctx : Context) n t v, lookupb t (extendb ctx n (t:=t) v) n = Some v;
      lookupb_extendb_different
      : forall (ctx : Context) n n' t t' v, n <> n' -> lookupb t' (extendb ctx n (t:=t) v) n'
                                                       = lookupb t' ctx n';
      lookupb_extendb_wrong_type
      : forall (ctx : Context) n t t' v, t <> t' -> lookupb t' (extendb ctx n (t:=t) v) n = None;
      lookupb_removeb_different
      : forall (ctx : Context) n n' t t', n <> n' -> lookupb t' (removeb t ctx n) n'
                                                     = lookupb t' ctx n';
      lookupb_removeb_same
      : forall (ctx : Context) n t t', lookupb t' (removeb t ctx n) n = None;
      lookupb_empty
      : forall n t, lookupb t (@empty _ _ _ Context) n = None;

      lookupb_unique_type
      : forall (ctx : Context) n t t', lookupb t' ctx n <> None -> lookupb t ctx n <> None -> t = t' }.

  Definition context_equiv (a b : Context)
    := forall n t, lookupb t a n = lookupb t b n.
End with_context.


(* This module defines finitary containers. *)

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Equality.

Record Cont : Type := cont {shapes: Type; arity: shapes -> nat}.

Inductive fin : nat -> Set :=
|F1 : forall {n}, fin (S n)
|FS : forall {n}, fin n -> fin (S n).

Definition vector A n := fin n -> A.

Definition vtail {A n} (v : vector A (S n)) : vector A n :=
  fun i => v (FS i).

Definition vhead {A n} (v : vector A (S n)) : A := v F1.

Definition vcons' {A n} (a : A) (i : fin (S n)) : (fin n -> A) -> A :=
  match i  with
    | F1 _ => fun v => a
    | FS _ j => fun v => v j
  end.

Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) :=
  fun i => vcons' a i v.

Definition vnil {A} : vector A 0 :=
  fun i => match i in fin n return match n with
                                     | 0 => A
                                     | _ => unit
                                   end with
             | F1 _ => tt
             | FS _ _ => tt
           end.

Lemma vector_cons {A n} (v : vector A (S n)) : vcons (vhead v) (vtail v) = v.
Proof.
  unfold vcons, vhead, vtail. apply functional_extensionality. intros.
  dependent destruction x; reflexivity.
Qed.

Hint Resolve vector_cons.

Program Fixpoint vector_ind A (P : forall n, vector A n  -> Prop)
         (base : forall (v : vector A 0), P 0 v)
         (step : forall n v a, P n v -> P (S n) (vcons a v))
         n {struct n} : forall (v : vector A n), P n v :=
  match n with
    | 0 => fun v => base v
    | S m => fun v => step m (vtail v) (vhead v) (vector_ind A P base step m (vtail v))
  end.

Lemma vcons_suc n A x (xs : vector A n) i : vcons x xs (FS i) = xs i.
Proof.
  reflexivity.
Qed.

Set Implicit Arguments.

Definition pos C (shape : shapes C) : Set := fin (arity C shape).

Record Ext (C:Cont )(X:Type):Type := ext {shape: shapes C; elems : vector X (arity C shape) }.

Definition vforall {X} (P : X -> Prop) {n} (v : vector X n) : Prop :=
  forall (p : fin n), P (v p).

Definition vexists {X} (P : X -> Prop) {n} (v : vector X n) : Prop :=
  exists (p : fin n), P (v p).

Definition cforall {X} (P : X -> Prop) {C} (E : Ext C X) : Prop :=
  vforall P (elems E).

Definition cexists {X} (P : X -> Prop) {C} (E : Ext C X) : Prop :=
  vexists P (elems E).

Definition cmap {C} {X Y} (f : X -> Y) (E : Ext C X) : Ext C Y :=
  {| shape := shape E; elems := (fun p => f (elems E p)) |}.

Lemma cmap_cmap  {X Y Z} (f : X -> Y) (g : Y -> Z) {C} (E : Ext C X) :
  cmap g (cmap f E) = cmap (compose g f) E.
Proof. auto. Qed.

Lemma cmap_id {X} {C} (E : Ext C X) :
  cmap (fun x => x) E = E.
Proof. destruct E. reflexivity. Qed.

Unset Implicit Arguments.

Ltac cmap_eq := intros; unfold cmap; f_equal; simpl; apply functional_extensionality; intros;
  unfold cforall in *; auto.

Lemma cforall_rewrite {X Y} (f g : X -> Y) {C} (E : Ext C X):
  cforall (fun x => f x = g x) E -> cmap f E = cmap g E.
Proof.
  cmap_eq.
Qed.

Definition cmap_prop {A B C} {P : A -> Prop} (f : forall m : A, P m -> B)
           {E : Ext C A} (proof : cforall P E) : Ext C B :=
  {| shape := shape E; elems := (fun p => f (elems E p) (proof p)) |}.

Lemma cmap_prop_eq {A B C} {P : A -> Prop} (f g : forall m : A, P m -> B)
           {E : Ext C A} (proof : cforall P E) (eq : forall x y, f x y = g x y) :
  cmap_prop f proof = cmap_prop g proof.
Proof.
  unfold cmap_prop. f_equal. apply functional_extensionality. auto.
Qed.

Lemma cmap_prop_cmap {A B C} {P : A -> Prop} {f : A -> B}
           {E : Ext C A} {proof : cforall P E} :
  cmap_prop (fun x _ => f x) proof = cmap f E.
Proof.
  reflexivity.
Qed.

Definition czipWith {A B D C} (f : A -> B -> D) (E : Ext C A) (E' : pos C (shape E) -> B) : Ext C D :=
  {| shape := shape E; elems := (fun p => f (elems E p) (E' p)) |}.

Set Implicit Arguments.

Fixpoint vfoldn {A B} (n : nat) (f : forall n, A -> B n -> B (S n)) (e : B 0) {struct n} : vector A n -> B n :=
  match n with
      | 0 => fun v => e
      | S m => fun v => f m (v F1) (vfoldn f e (vtail v))
  end.

Definition vfold {A B} {n : nat} (f : A -> B -> B)  : B -> vector A n -> B := vfoldn (fun _ => f).

Lemma vfold_nil {A B} (f : A -> B -> B) (b:B) (v: vector A 0) : vfold f b v = b.
Proof.
  reflexivity.
Qed.

Hint Resolve vfold_nil.

Lemma vfold_cons {A B} {n : nat} (f : A -> B -> B) (a : A) (b:B) (v: vector A n) :
  vfold f b (vcons a v) = f a (vfold f b v).
Proof.
  reflexivity.
Qed.

Hint Resolve vfold_cons.

Lemma vforall_head n A P (x :A) (xs : vector A n) : vforall P (vcons x xs) -> P x.
Proof.
  unfold vforall. intro H. apply (H F1).
Qed.

Lemma vforall_tail n A P (x :A) (xs : vector A n) : vforall P (vcons x xs) -> vforall P xs.
Proof.
  unfold vforall. intros. apply (H (FS p)).
Qed.

Definition cfold {A B C} (f : A -> B -> B) (e : B) (E : Ext C A) : B := vfold f e (elems E).

Fixpoint vseq {A} {n : nat} : (vector (option A) n) -> option (vector A n) :=
  let run (n : nat) (o : option A) (v : option (vector A n)) : option (vector A (S n)) :=
      match o with
        | None => None
        | Some a => match v with
                      | None => None
                      | Some v' => Some (vcons a v')
                    end
      end
  in
  vfoldn run (Some vnil).

Definition cseq {A C} (E : Ext C (option A)) : option (Ext C A) :=
  match vseq (elems E) with
      | None => None
      | Some res => Some {| shape := shape E; elems := res |}
  end.


(* This file is part of the Linear Logic  formalization in Coq: https://github.com/brunofx86/LL *)

(** ** Cut Cases

In this file we prove the cases for cut-elimination. Each lemma contains a case for the respective connective (and its dual).
 *)

(* Require Export Tactics.
Set Implicit Arguments. *)

Require Import llTactics.

Lemma aux_CUT_ap n1 n2 h B L M1 M2 v:
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; 0; m; B; L -> exists m, m |~> 0; B; L) ->
  S h = plus n1 n2 -> 0%nat = lexp_weight (v ⁺) -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; v ⁺ :: M1 ->
               n2 |~> 0; B; v ⁻ :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H Hh Hw P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * {
      inversion Hn2; subst; inversion Hh; try cut_free.
      - simpl_cases2.
        refine (tab_bot_right_zero _ P _ _ _ H4 H3 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_par_right_zero _ _ _ P _ H4 H3 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_tensor_right_zero _ _ _ P _ H3 H4 H6 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus1_right_zero _ _ _ P _ H4 H3 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus2_right_zero _ _ _ P _ H4 H3 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_with_right_zero _ _ P _ H3 H4 H6 Hn1 Hn2); eauto.
      - refine (tab_copy_right_zero _ _ _ P H2 _ _ Hn1 _) ; eauto.
      - simpl_cases2;
          refine (tab_quest_right_zero _ _ _ P _ H4 H3 Hn1 _); eauto.
      - apply resolvers2 in H2; firstorder; inversion H2.
    }
  * apply resolvers2 in H0; firstorder; inversion H0.
  * simpl_cases2.
    top_commutes.
  * simpl_cases2;
      refine (tab_bot_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_tensor_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * simpl_cases2;
      refine (tab_plus1_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_with_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * refine (tab_copy_left_zero _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; inversion H0.
Qed.
Arguments aux_CUT_ap [n1 n2 h B L M1 M2 v].

Lemma aux_CUT_tz n1 n2 h B L M1 M2:
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; 0; m; B; L ->
                         exists m, m |~> 0; B; L) ->
  S h = plus n1 n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; ⊤ :: M1 ->
               n2 |~> 0; B; 0 :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H0; firstorder; inversion H0.
  * apply resolvers2 in H0; firstorder; inversion H0.
  * {
      simpl_cases4.
      inversion Hn2; subst; inversion Hh; try cut_free.
      - simpl_cases2;
          refine (tab_bot_right_zero _ P _ _ _ H4 H3 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_par_right_zero _ _ _ P _ H4 H3 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_tensor_right_zero _ _ _ P _ H3 H4 H6 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus1_right_zero _ _ _ P _ H4 H3 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus2_right_zero _ _ _ P _ H4 H3 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_with_right_zero _ _ P _ H3 H4 H6 Hn1 Hn2); eauto.
      - refine (tab_copy_right_zero _ _ _ P H2 _ _ Hn1 _) ; eauto.
      - simpl_cases2;
          refine (tab_quest_right_zero _ _ _ P _ H4 H3 Hn1 _); eauto.
      - apply resolvers2 in H2; firstorder; inversion H2.
    }

  * simpl_cases2;
      refine (tab_bot_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_tensor_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * simpl_cases2;
      refine (tab_plus1_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_with_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * refine (tab_copy_left_zero _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; inversion H0.
Qed.
Arguments aux_CUT_tz [n1 n2 h B L M1 M2].

Lemma aux_CUT_bo n1 n2 h B L M1 M2:
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; 0; m; B; L -> exists m, m |~> 0; B; L) ->
  S h = plus n1 n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; ⊥ :: M1 ->
               n2 |~> 0; B; 1 :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H0; firstorder; inversion H0.
  * apply resolvers2 in H0; firstorder; inversion H0.
  * simpl_cases2;
      top_commutes.
  * {
      simpl_cases4.
      inversion Hn2; subst; inversion Hh; try cut_free.
      - apply resolvers in H2; firstorder; inversion H2.
      - apply resolvers2 in H2; firstorder.
        eexists.
        rewrite P, H3, H0, union_nil.
        eauto.
      - simpl_cases2; top_commutes.
      - simpl_cases2;
          refine (tab_bot_right_unit' _ P _ _ H3 H4 Hn1 _ ); eauto.
      - simpl_cases2;
          refine (tab_par_right_unit' _ _ P _ H3 H4 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_tensor_right_unit' _ _ P _ H3 H5 H7 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus1_right_unit' _ _ P _ H3 H4 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus2_right_unit' _ _  P _ H3 H4 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_with_right_unit' _ _ P _ H3 H5 H7 Hn1 Hn2); eauto.
      - refine (tab_copy_right_unit' _ _ P H2 _ H5 Hn1 _); eauto.
      - simpl_cases2.
        refine (tab_quest_right_unit' _ _ P _ H3 H4 Hn1 _); eauto.
      - apply resolvers2 in H2; firstorder; inversion H2.
    }
  * simpl_cases2;
      refine (tab_par_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_tensor_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * simpl_cases2;
      refine (tab_plus1_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_with_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * refine (tab_copy_left_zero _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; inversion H0.
Qed.
Arguments aux_CUT_bo [n1 n2 h B L M1 M2].

Lemma aux_CUT_tp n1 n2 w h B L F G M1 M2:
  (forall m : nat,
      m <= w ->
      forall (h n : nat) (L B : Multiset),
        n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
  w = plus (lexp_weight F) (lexp_weight G) ->
  S h = plus n1 n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; (F ** G) :: M1 ->
               n2 |~> 0; B; (F° $ G°) :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; inversion H1.
  * apply resolvers2 in H1; firstorder; inversion H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2;
      refine (tab_bot_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * {
      destruct (eq_dec (F ** G) (F0 ** G0)) as [Te|notTe].
      rewrite <- Te in *.
      apply tns_eq in Te.
      destruct Te as [Te1 Te2].
      rewrite <- Te1, <- Te2 in *.
      clear Te1. clear Te2.
      + {
          simpl_cases4. (* Tensor é principal em Hn1 *)
          inversion Hn2; subst; inversion Hh; try cut_free.
          - apply resolvers in H1; firstorder; inversion H1.
          - apply resolvers2 in H1; firstorder; inversion H1.
          - simpl_cases2; top_commutes.
          - simpl_cases2;
              refine (tab_bot_right _ P _ _ H6 H4 Hn1 Hn2); eauto.
          -
            destruct (eq_dec (F1 $ G1) (F° $ G°)) as [Te|notTe].
            rewrite Te in *.
            apply par_eq in Te.
            destruct Te as [Te1 Te2].
            rewrite Te1, Te2 in *.
            clear Te1; clear Te2.
            *
              simpl_cases4. (* Par é principal em Hn2 *)
              rewrite meq_swap_cons in H4.
              assert (exists m, m |~> 0 ; B; F° :: (N ++ M0)) as Hyp.
              refine (H _ _ _ _ _ _ _);
                [|change (0%nat) with (plus 0 0);
                  refine (sig3_cut _ _ _ H5 H4); auto]; resolve_max.

              destruct Hyp as [p Hp].
              refine (H _ _ _ _ _ _ _);
                [|change (0%nat) with (plus 0 0);
                  refine (sig3_cut _ _ _ H3 Hp); auto].
              resolve_max.
              rewrite P, H1, H2.
              app_normalize.
            * simpl_cases2.
              assert (exists m, m |~> 0 ; B; F1 :: G1 :: (x ++ M1)) as Hyp.
              rewrite meq_swap_cons in H4;
                rewrite H1 in H4.
              rewrite union_rotate_cons in H4.
              refine (H0 _ _ _ _ _ _);
                [ | change (0%nat) with (plus 0 0);
                    refine (sig3_cut _ _ _ Hn1 H4);
                    auto]. resolve_max.
              solve_permutation.
              destruct Hyp as [t Ht];
                eexists; refine (sig3_par _ Ht); auto;
                  resolve_rewrite.
          - simpl_cases2;
              refine (tab_tensor_right _ _ P _ H4 H6 H8 Hn1 Hn2); eauto.
          - simpl_cases2;
              refine (tab_plus1_right _ _ P _ H6 H4 Hn1 Hn2); eauto.
          - simpl_cases2;
              refine (tab_plus2_right _ _  P _ H6 H4 Hn1 Hn2); eauto.
          - simpl_cases2;
              refine (tab_with_right _ _ P _ _ H6 H8 Hn1 Hn2); eauto.
          - refine (tab_copy_right _ _ P H1 _ H6 Hn1 _); eauto.
          - simpl_cases2;
              refine (tab_quest_right _ _ P _ H6 H4 Hn1 _); eauto.
          - apply resolvers2 in H1; firstorder; inversion H1.
        }
      +
        symmetry in H2.
        simpl_cases2.
        refine (tab_tensor_left_zero' _ _ P _ H1 H3 H5 Hn1 _); eauto.
    }

  * simpl_cases2;
      refine (tab_plus1_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_with_left_zero' _ _ P _ H2 H3 H5 Hn1 _ ); eauto.
  * refine (tab_copy_left _ _ _ P H1 _ H3 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * apply resolvers2 in H1; firstorder; inversion H1.
Qed.
Arguments aux_CUT_tp [n1 n2 w h B L F G M1 M2].

Lemma aux_CUT_pw n1 n2 w h B L F G M1 M2:
  (forall m : nat,
      m <= w ->
      forall (h n : nat) (L B : Multiset),
        n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
  w = plus (lexp_weight F) (lexp_weight G) ->
  S h = plus n1 n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; (F & G) :: M1 ->
               n2 |~> 0; B; (F° ⊕ G°) :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; inversion H1.
  * apply resolvers2 in H1; firstorder; inversion H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2;
      refine (tab_bot_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_tensor_left_zero' _ _ P _ H2 H3 H5 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus1_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * {
      destruct (eq_dec (F & G) (F0 & G0)) as [Te|notTe].
      rewrite <- Te in *.
      apply wth_eq in Te.
      destruct Te as [Te1 Te2].
      rewrite <- Te1, <- Te2 in *.
      clear Te1; clear Te2.
      + {
          simpl_cases4. (* With é principal em Hn1 *)
          inversion Hn2; subst; inversion Hh; try cut_free.
          - apply resolvers in H1; firstorder; inversion H1.
          - apply resolvers2 in H1; firstorder; inversion H1.
          - simpl_cases2; top_commutes.
          - simpl_cases2;
              refine (tab_bot_right _ P _ _ H6 H4 Hn1 Hn2); eauto.
          - simpl_cases2;
              refine (tab_par_right' _ _ P _ H6 H4 Hn1 _ ); eauto.
          - simpl_cases2;
              refine (tab_tensor_right _ _ P _ H4 H6 H8 Hn1 _ ); eauto.
          - destruct (eq_dec (F° ⊕ G°) (F1 ⊕ G1)) as [Te|notTe].
            rewrite <- Te in *.
            apply pls_eq in Te.
            destruct Te as [Te1 Te2].
            rewrite <- Te1 in *.
            clear Te1; clear Te2.
            *
              simpl_cases4. (* Plus1 é principal em Hn2 *)
              refine (H _ _ _ _ _ _ _);
                [|change (0%nat) with (plus 0 0);
                  refine (sig3_cut _ _ _ H3 H4);
                  auto; resolve_rewrite ]; resolve_max.
            * symmetry in H1. simpl_cases2.
              refine (tab_plus1_right _ _ P _ H1 H4 Hn1 _ ); eauto.
          - destruct (eq_dec (F° ⊕ G°) (F1 ⊕ G1)) as [Te|notTe].
            rewrite <- Te in *.
            apply pls_eq in Te.
            destruct Te as [Te1 Te2].
            rewrite <- Te2 in *.
            clear Te1; clear Te2.
            *
              simpl_cases4. (* Plus2 é principal em Hn2 *)
              refine (H _ _ _ _ _ _ _);
                [|change (0%nat) with (plus 0 0);
                  refine (sig3_cut _ _ _ H5 H4);
                  auto; resolve_rewrite ]; resolve_max.
            * symmetry in H1. simpl_cases2.
              refine (tab_plus2_right _ _ P _ H1 H4 Hn1 _ ); eauto.
          - simpl_cases2;
              refine (tab_with_right _ _ P _ _ H6 H8 Hn1 Hn2); eauto.
          - refine (tab_copy_right _ _ P H1 _ H6 Hn1 _); eauto.
          - simpl_cases2;
              refine (tab_quest_right _ _ P _ H6 H4 Hn1 _); eauto.
          - apply resolvers2 in H1; firstorder; inversion H1.
        }
      + symmetry in H2. simpl_cases2.
        refine (tab_with_left_zero' _ _ P _ H1 H3 H5 Hn1 _); eauto.
    }
  * refine (tab_copy_left _ _ _ _ _ _ H3 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * apply resolvers2 in H1; firstorder; inversion H1.
Qed.
Arguments aux_CUT_pw [n1 n2 w h B L F G M1 M2].

Lemma aux_CUT_bq n1 n2 w h B L F M1 M2:
  (forall m : nat,
      m <= w ->
      forall (h n : nat) (L B : Multiset),
        n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
  w = lexp_weight F ->
  S h = plus n1 n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; (! F) :: M1 ->
               n2 |~> 0; B; (? F°) :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; inversion H1.
  * apply resolvers2 in H1; firstorder; inversion H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2;
      refine (tab_bot_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2.
    simpl_cases_tns.

    assert (exists m, m |~> 0 ; B; F0 :: (L1 ++ M2)) as Hyp.
    rewrite HL1 in H3.
    rewrite meq_swap_cons in H3.
    refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (plus 0 0); refine (sig3_cut _ _ _ H3 Hn2);
          auto; try resolve_rewrite]; resolve_max.

    destruct Hyp as [t Ht];
      eexists;
      refine (sig3_tensor _ Ht H5); auto; resolve_rewrite.

    assert (exists m, m |~> 0 ; B; G :: (L2 ++ M2)) as Hyp.
    rewrite HL2 in H5;
      rewrite meq_swap_cons in H5.
    refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (plus 0 0); refine (sig3_cut _ _ _ H5 Hn2);
          auto; try resolve_rewrite]; resolve_max.

    destruct Hyp as [t Ht];
      eexists;
      refine (sig3_tensor _ H3 Ht); auto; resolve_rewrite.
  * simpl_cases2;
      refine (tab_plus1_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2.
    assert (exists m, m |~> 0 ; B; F0 :: (M2 ++ x)) as Hyp1.
    rewrite H1 in H3;
      rewrite meq_swap_cons in H3.
    refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (plus 0 0);
          refine (sig3_cut _ _ _ H3 Hn2); auto;
          try resolve_rewrite; perm_simplify]; resolve_max.

    assert (exists m, m |~> 0 ; B; G :: (M2 ++ x)) as Hyp2.
    rewrite H1 in H5;
      rewrite meq_swap_cons in H5.
    refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (plus 0 0);
          refine (sig3_cut _ _ _ H5 Hn2); auto;
          try resolve_rewrite; perm_simplify]; resolve_max.

    destruct Hyp1 as [t1 Ht1];
      destruct Hyp2 as [t2 Ht2];

      eexists;
      refine (sig3_with _ Ht1 Ht2);
      resolve_rewrite.
    rewrite <- app_comm_cons. solve_permutation.
  * refine (tab_copy_left _ _ _ P _ _ _ Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * {
      apply resolvers2 in H1; firstorder; inversion H1. (* Bang é principal em Hn1 *)
      rewrite H3 in Hn1.
      rewrite <- H6 in *.
      clear H1; clear H6.
      inversion Hn2; subst; inversion Hh; try cut_free.
      - apply resolvers in H1; firstorder; inversion H1.
      - apply resolvers2 in H1; firstorder; inversion H1.
      - simpl_cases2; top_commutes.
      - simpl_cases2;
          refine (tab_bot_right_unit  _ _ _ _ H3 H5 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_par_right_unit _ _ _ _ H3 H5 Hn1 _ ); eauto.
      - simpl_cases2;
          refine (tab_tensor_right_unit _ _ _ _  H3 H6 H8 Hn1 _ ); eauto.
      - simpl_cases2;
          refine (tab_plus1_right_unit _ _ _ _ H3 H5 Hn1 Hn2 ); eauto.
      - simpl_cases2;
          refine (tab_plus2_right_unit _ _ _ _ H3 H5 Hn1 Hn2 ); eauto.
      - simpl_cases2;
          refine (tab_with_right_unit _ _ _ _ H3 H6 H8 Hn1 _ ); eauto.
      - refine (tab_copy_right_unit _ _ _ H1 _ _ Hn1 Hn2) ; eauto.
      - destruct (eq_dec (? F0°) (? F1)) as [Te|notTe].
        rewrite <- Te in *; rewrite qst_eq in Te.
        rewrite <- Te in *. clear Te.
        + simpl_cases4. (* Quest é principal em Hn2 *)
          eapply H0 with (m:=plus (S n)  n0); resolve_max.
          change (0%nat) with (plus 0 0);
            refine (sig3_ccut _ _ _ Hn1 H5); eauto.
        + symmetry in H1. simpl_cases2.
          assert (exists m, m |~> 0 ; F1 :: B ; x) as Hyp.
          eapply height_preserving_weakning_sig3 with (D:=[F1]) in Hn1;
            rewrite union_comm_app in Hn1. simpl in Hn1.
          rewrite H3 in H5.
          refine (H0 _ _ _ _ _ _);
            [|change (0%nat) with (plus 0 0);
              refine (sig3_cut _ _ _ Hn1 H5);
              auto; try resolve_rewrite]; resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_quest _ Ht); auto;
              resolve_rewrite.
      - apply resolvers2 in H1; firstorder; inversion H1.
    }
Qed.
Arguments aux_CUT_bq [n1 n2 w h B L F M1 M2].


Require Export Limits.
Require Import Common.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Equalizer.
  Context `(C : @SpecializedCategory objC).
  Variables A B : objC.
  Variables f g : C.(Morphism) A B.

  Inductive EqualizerTwo := EqualizerA | EqualizerB.

  Definition EqualizerIndex_Morphism (a b : EqualizerTwo) : Set :=
    match (a, b) with
      | (EqualizerA, EqualizerA) => unit
      | (EqualizerB, EqualizerB) => unit
      | (EqualizerB, EqualizerA) => Empty_set
      | (EqualizerA, EqualizerB) => EqualizerTwo
    end.

  Global Arguments EqualizerIndex_Morphism a b /.

  Definition EqualizerIndex_Compose s d d' (m1 : EqualizerIndex_Morphism d d') (m2 : EqualizerIndex_Morphism s d) :
    EqualizerIndex_Morphism s d'.
    destruct s, d, d'; simpl in *; trivial.
  Defined.

  Definition EqualizerIndex : @SpecializedCategory EqualizerTwo.
    refine (@Build_SpecializedCategory _
                                       EqualizerIndex_Morphism
                                       (fun x => match x with EqualizerA => tt | EqualizerB => tt end)
                                       EqualizerIndex_Compose
                                       _
                                       _
                                       _);
    abstract (
        intros; destruct_type EqualizerTwo; simpl in *; destruct_type Empty_set; trivial
      ).
  Defined.

  Definition EqualizerDiagram_ObjectOf x :=
    match x with
      | EqualizerA => A
      | EqualizerB => B
    end.

  Global Arguments EqualizerDiagram_ObjectOf x /.

  Definition EqualizerDiagram_MorphismOf s d (m : Morphism EqualizerIndex s d) :
    Morphism C (EqualizerDiagram_ObjectOf s) (EqualizerDiagram_ObjectOf d).
    destruct s, d; simpl in *; try apply Identity;
      try solve [ destruct m ];
        exact match m with
                | EqualizerA => f
                | EqualizerB => g
              end.
  Defined.

  Definition EqualizerDiagram : SpecializedFunctor EqualizerIndex C.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          EqualizerDiagram_ObjectOf
          EqualizerDiagram_MorphismOf
          _
          _
        )
    end;
    abstract (
      unfold EqualizerDiagram_MorphismOf; simpl; intros;
        destruct_type EqualizerTwo;
        repeat rewrite LeftIdentity; repeat rewrite RightIdentity;
          trivial; try destruct_to_empty_set
    ).
  Defined.

  Definition Equalizer := Limit EqualizerDiagram.
  Definition Coequalizer := Colimit EqualizerDiagram.
End Equalizer.


Require Export Category.
Require Import Common.

Set Implicit Arguments.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope equiv_scope.
Local Open Scope category_scope.

Section Groupoid.
  Variable X : Type.
  Context `{IsTrunc 1 X}.

  Local Notation Groupoid_Morphism := (@paths X).

  Definition Groupoid_Compose s d d' (m : Groupoid_Morphism d d') (m' : Groupoid_Morphism s d)
  : Groupoid_Morphism s d'
    := transitivity s d d' m' m.

  Definition Groupoid_Identity x : Groupoid_Morphism x x
    := reflexivity _.

  Global Arguments Groupoid_Compose [s d d'] m m' / .
  Global Arguments Groupoid_Identity x / .

  Definition Groupoid : PreCategory.
    refine (@Build_PreCategory X
                               Groupoid_Morphism
                               Groupoid_Identity
                               Groupoid_Compose
                               _
                               _
                               _
                               _);
    simpl; intros; path_induction; reflexivity.
  Defined.

  Definition Groupoid_isotoid (s d : Groupoid)
  : s ≅ d -> s = d
    := fun f => IsomorphicMorphism.

  Global Instance GroupoidIsCategory : IsCategory Groupoid.
  Proof.
    repeat intro.
    apply (isequiv_adjointify (@idtoiso Groupoid _ _)
                              (@Groupoid_isotoid _ _));
      repeat intro;
      destruct_head @Isomorphic;
      destruct_head @IsIsomorphism;
      compute in *;
      path_induction_hammer.
  Qed.
End Groupoid.

Arguments Groupoid _ {_}.

Lemma GroupoidIsStrict X `{IsHSet X}
: IsStrictCategory (Groupoid X).
Proof.
  typeclasses eauto.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O A B C I C1 C2 : Universe, ((wd_ A I /\ (wd_ B I /\ (wd_ C1 A /\ (wd_ A B /\ (wd_ C1 B /\ (wd_ B O /\ (wd_ A O /\ (wd_ B C /\ (wd_ A C /\ (wd_ A C2 /\ (wd_ B C2 /\ (wd_ C1 C2 /\ (col_ C1 C2 I /\ (col_ C1 O C2 /\ col_ A I B)))))))))))))) -> col_ O C1 I)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Coq.Program.Equality.
Require Import Lia.
Require Import Ascii.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.
Require Import List.
Require Import FinProof.All.

Require Import UMLang.All.
Require Import UrsusStdLib.Solidity.All.
Require Import UrsusStdLib.Solidity.unitsNotations.
Require Import UrsusTVM.Solidity.All.

Import UrsusNotations.
Local Open Scope xlist_scope.
Local Open Scope record.
Local Open Scope program_scope.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Require Import SetcodeMultisig.

Require Import UMLang.ExecGenerator.
Require Import UMLang.ExecGen.GenFlags.
Require Import UMLang.ExecGen.ExecGenDefs.
Require Import FinProof.CommonInstances.

Require Import CommonQCEnvironment.
Require Import SetcodeMultisig_LocalState.

#[global, program]
Instance listInfinite : listInfiniteFunRec_gen XList.
Next Obligation.
(* we have three while loops: *)
(* 1st -- max MAX_CUSTODIAN_COUNT + 1 = 33 iterations *)
(* 2nd -- max MAX_CLEANUP_TXNS + 1 = 41 iterations *)
(* 3rd -- ??? TODO investigate*)
exact (repeat PhantomPoint 41).
Defined.

Notation rec := LocalStateLRecord.
Definition computed : LocalStateLRecord := Eval compute in default.
#[global]
Instance def : XDefault LocalStateLRecord := {
  default := computed
} .
Definition VMStateDefault : VMStateLRecord  := Eval compute in default.
Definition LedgerDefault : LedgerLRecord LocalStateLRecord  := Eval compute in default.

Definition incr_time (l: LedgerLRecord rec) (dt: N) :=
   let st := getPruvendoRecord Ledger_VMState l in
   let t := getPruvendoRecord VMState_ι_now st in
   let newst := {$$ st with VMState_ι_now := Build_XUBInteger (uint2N t + dt) $$} in
   {$$ l with Ledger_VMState := newst $$}.

Definition incr_timestamp (l: LedgerLRecord rec)  :=
   let st := getPruvendoRecord Ledger_VMState l in
   let t := getPruvendoRecord VMState_ι_timestamp st in
   let newst := {$$ st with VMState_ι_timestamp := Build_XUBInteger (uint2N t + 1) $$} in
   {$$ l with Ledger_VMState := newst $$}.

#[global, program]
Instance IDefault_booleq : XBoolEquable bool IDefault.
Next Obligation.
destruct H, H0.
refine true.
Defined.

Fixpoint Pos_bitcount (p: positive) :=
  match p with
    | xH => 1
    | xO p' => Pos_bitcount p'
    | xI p' => 1 + Pos_bitcount p'
  end.

Definition N_bitcount (n: N) :=
  match n with
    | N0 => 0
    | Npos p => Pos_bitcount p
  end.

Definition computeCorrectSignsReceived (tx : TransactionLRecord) :=
  let confirmationsMask := getPruvendoRecord Transaction_ι_confirmationsMask tx in
  N_bitcount (uint2N confirmationsMask).

Definition computeCorrectSignsUpdateRequest (req : UpdateRequestLRecord) :=
  let confirmationsMask := getPruvendoRecord UpdateRequest_ι_confirmationsMask req in
  N_bitcount (uint2N confirmationsMask).

Definition transactionsCorrect (txs: Datatypes.list (uint64 * TransactionLRecord)) (tvm_now: N) (timestamp : N):=
  List.forallb (fun tx : (uint64 * _) => (
  andb
    (andb
      (Common.eqb (fst tx) (getPruvendoRecord Transaction_ι_id (snd tx)))
      (Common.eqb (computeCorrectSignsReceived (snd tx))
        (uint2N (getPruvendoRecord Transaction_ι_signsReceived (snd tx))))
    )
    (andb
      (N.leb (N.shiftr (uint2N (fst tx)) 32) tvm_now)
      (N.ltb (N.land (uint2N (fst tx)) 0xFFFFFFFF) timestamp)
    )
   )) txs.

Definition requestsCorrect (reqs: Datatypes.list (uint64 * UpdateRequestLRecord)) (tvm_now: N) (timestamp : N):=
  List.forallb (fun req : (uint64 * _) => (
  andb
    (andb
      (Common.eqb (fst req) (getPruvendoRecord UpdateRequest_ι_id (snd req)))
      (Common.eqb (computeCorrectSignsUpdateRequest (snd req))
        (uint2N (getPruvendoRecord UpdateRequest_ι_signs (snd req))))
    )
    (andb
      (N.leb (N.shiftr (uint2N (fst req)) 32) tvm_now)
      (N.ltb (N.land (uint2N (fst req)) 0xFFFFFFFF) timestamp)
    )
   )) reqs.

Definition get_index (tx : TransactionLRecord) : N :=
  uint2N (TransactionLGetField Transaction_ι_index tx).

Definition get_id (tx : TransactionLRecord) : N :=
  uint2N (TransactionLGetField Transaction_ι_id tx).

Definition get_id_req (req : UpdateRequestLRecord) : N :=
  uint2N (UpdateRequestLGetField UpdateRequest_ι_id req).

Definition noDuplicateIds (txs: Datatypes.list (uint64 * TransactionLRecord)) :=
  List.forallb (fun tx => Common.eqb (length_ (List.filter
    (fun tx' => Common.eqb (get_id (snd tx)) (get_id (snd tx'))) txs)) 1) txs.

Definition noDuplicateReqs (reqs: Datatypes.list (uint64 * UpdateRequestLRecord)) :=
  List.forallb (fun tx => Common.eqb (length_ (List.filter
    (fun tx' => Common.eqb (get_id_req (snd tx)) (get_id_req (snd tx'))) reqs)) 1) reqs.

Definition computeCorrectRequestMask (transactions: mapping uint64 TransactionLRecord) :=
  List.fold_left (fun acc e =>
    acc + (N.shiftl 1 (8 * (get_index (snd e))))
  ) (unwrap transactions) 0.

Definition requestMaskCorrect (requestMask: uint256) (transactions: mapping uint64 TransactionLRecord) :=
  Common.eqb (uint2N requestMask) (computeCorrectRequestMask transactions).

Definition correctState l :=
    let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
    let custodianCount := toValue (eval_state (sRReader (m_custodianCount_right rec def) ) l) in
    let ownerKey := toValue (eval_state (sRReader (m_ownerKey_right rec def) ) l) in
    let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l) in
    let requests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l) in
    let requestMask := toValue (eval_state (sRReader (m_requestsMask_right rec def) ) l) in
    let tvm_now := uint2N (toValue (eval_state (sRReader || now || ) l)) in
    let timestamp := uint2N (toValue (eval_state (sRReader || tx->timestamp || ) l)) in
    let lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
    length_ custodians = uint2N custodianCount /\
    hmapIsMember ownerKey custodians = true /\
    transactionsCorrect (unwrap transactions) tvm_now timestamp = true /\
    requestsCorrect (unwrap requests) tvm_now timestamp = true /\
    noDuplicateIds (unwrap transactions) = true /\
    noDuplicateReqs (unwrap requests) = true /\
    requestMaskCorrect requestMask transactions = true /\
    N.ltb lifetime tvm_now = true
    .

Import ListNotations.
Fixpoint dedupTransactions (txs: Datatypes.list (uint64 * TransactionLRecord))  (mem: mapping N bool) :=
  match txs with
  | [ ]%list => [ ]%list
  | (tx :: txs)%list =>
  let id := get_id (snd tx) in
  if hmapIsMember id mem then dedupTransactions txs mem
  else let mem' := xHMapInsert id true mem in
  (tx :: dedupTransactions txs mem')%list
  end.
Fixpoint dedupRequests (reqs: Datatypes.list (uint64 * UpdateRequestLRecord))  (mem: mapping N bool) :=
  match reqs with
  | [ ]%list => [ ]%list
  | (req :: reqs)%list =>
  let id := get_id_req (snd req) in
  if hmapIsMember id mem then dedupRequests reqs mem
  else let mem' := xHMapInsert id true mem in
  (req :: dedupRequests reqs mem')%list
  end.

 Definition quickFixState (l: LedgerLRecord rec) : LedgerLRecord rec :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let ownerKey := toValue (eval_state (sRReader (m_ownerKey_right rec def) ) l) in
  let custodians' := if hmapIsMember ownerKey custodians then custodians
    else xHMapInsert ownerKey (Build_XUBInteger (length_ custodians)) custodians in
  let defaultRequired := toValue (eval_state (sRReader (m_defaultRequiredConfirmations_right rec def) ) l) in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l) in
  let requests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l) in
  let transactions':= (CommonInstances.wrap Map (dedupTransactions (map
    (fun tx : (uint64 * TransactionLRecord) => (Build_XUBInteger (N.shiftl (uint2N(fst tx)) 32),
      {$$ {$$ snd tx with Transaction_ι_id := Build_XUBInteger (N.shiftl (uint2N(fst tx)) 32) $$}
         with Transaction_ι_signsReceived := (Build_XUBInteger (computeCorrectSignsReceived (snd tx)))
      $$} : TransactionLRecord))
  (unwrap transactions)) (CommonInstances.wrap Map Datatypes.nil))) in
  let requests' := (CommonInstances.wrap Map (dedupRequests (map
    (fun req : (uint64 * UpdateRequestLRecord) => (Build_XUBInteger (N.shiftl (uint2N(fst req)) 32),
      {$$ {$$ snd req with UpdateRequest_ι_id := Build_XUBInteger (N.shiftl (uint2N(fst req)) 32) $$}
        with UpdateRequest_ι_signs := (Build_XUBInteger (computeCorrectSignsUpdateRequest (snd req)))
      $$} : UpdateRequestLRecord))
  (unwrap requests)) (CommonInstances.wrap Map Datatypes.nil))) in
  {$$ l with Ledger_MainState :=
    {$$ {$$ {$$ {$$ {$$getPruvendoRecord Ledger_MainState l with
      _m_custodianCount := Build_XUBInteger (length_ custodians')
    $$} with
      _m_custodians := custodians'
    $$}
     with
      _m_transactions := transactions'
    $$}
     with
      _m_requestsMask := (Build_XUBInteger (computeCorrectRequestMask transactions'))
    $$}
    with
      _m_updateRequests := requests'
    $$}
  $$}.

#[global]
Instance xhmap_booleq {K V} `{XBoolEquable bool K} `{XBoolEquable bool V}: XBoolEquable bool (XHMap K V).
Proof.
  esplit. intros. apply ( @XBoolEquableList(K*V)).
  apply pair_xbool_equable.
  exact (unwrap X). exact (unwrap X0).
Defined.

#[global]
Instance xarray_booleq {K} `{XBoolEquable bool K}: XBoolEquable bool (listArray K).
Proof.
  esplit. intros. apply ( @XBoolEquableList(K)). auto.
  exact (unwrap X). exact (unwrap X0).
Defined.

#[global]
Instance xqueue_booleq {K} `{XBoolEquable bool K}: XBoolEquable bool (XQueue K).
Proof.
  esplit. intros. apply ( @XBoolEquableList(XUInteger*K)).
  apply pair_xbool_equable.
  exact (unwrap X). exact (unwrap X0).
Defined.

Definition T := Eval compute in LedgerLRecord rec.
Definition ledgerEqb : T -> T -> bool := Common.eqb.

Definition checkMap1 (custodians: mapping uint256 uint8) :=
  List.forallb
    (fun v => Common.eqb (length_ (List.filter
      (fun e => Common.eqb (snd e) v) (unwrap custodians))) 1)
      (map (fun x => Build_XUBInteger x) (listRange (length_ custodians))).

Definition checkMap2' (m: XHMap ( uint256 )( uint8 )) (i: N) (k: option uint256) :=
  let k' := xMaybeMapDefault id k (Build_XUBInteger 0) in
  (andb (xMaybeIsSome k) (hmapIsMember k' m)).

Fixpoint checkMap2 m n (owners: listArray uint256):=
  match n with
  | O => true
  | S n' => andb (checkMap2 m n' owners) (checkMap2' m (N.of_nat n') (arrLookup (N.of_nat n') owners))
  end.


Require Import QArith Le Max List Bool NPeano Omega Psatz.
Require Import Cecoa.Rationals.Lib Cecoa.Rationals.Syntax Cecoa.Rationals.CBV_cache Cecoa.Rationals.Bounds Cecoa.Rationals.Ordering Cecoa.Rationals.QI.

Section Main.

(* Syntax *)

Variables variable function constructor : Type.
Notation value := (Syntax.value constructor).
Notation term := (Syntax.term variable function constructor).
Notation pattern := (Syntax.pattern variable constructor).
Notation rule := (Syntax.rule variable function constructor).
Notation "'╎' t '╎'" := (@term_size variable function constructor t) (at level 10).

Variable prog : list rule.
Variable max_arity:nat.
Variable rule_default : rule.

Hypothesis prog_is_wf: wf_prog max_arity prog.

Variable variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.
Variable function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.
Variable constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.

Notation cache := (CBV_cache.cache variable function constructor).
Notation cbv := (CBV_cache.cbv variable function constructor).
Notation wf := (CBV_cache.wf variable_eq_dec function_eq_dec constructor_eq_dec rule_default
                prog max_arity).
Notation "'∣' p '∣'" := (@size variable function constructor p) (at level 10).

(* PPO *)
Variable rank: function -> nat.
Variable max_rank : nat.
Hypothesis pos_max_rank : 0 < max_rank.
Hypothesis max_rank_is_max_rank : forall f, rank f <= max_rank.
Hypothesis prog_is_ppo : PPO_prog prog rank.

Definition gsp := (Bounds.gary_seven_poly variable function constructor prog max_rank).
Definition bep := (Bounds.bobby_eight_poly variable function constructor max_arity prog).

(* QI *)
Variable cs: constructor -> Qpos.  (* constructor size *)
Variable mcs: Qpos. (* max constructor size *)
Variable qic: assignment_constructor constructor.
Variable qif: assignment_function function.
Hypothesis prog_has_QI: valid_QI variable function constructor prog mcs qic qif cs.
Notation cache_bounded := (QI.cache_bounded variable function constructor qic qif).

Definition CBV_bound A S C :=  (* generic bound *)
  (* A : number of ℐᵃ
     S : max size of an activation
     C : cache *)
  (A * 𝓡 prog S + A + 1 + (max_arity * A * (1 + 𝓡 prog S))) *
  (𝓡 prog S + S + cache_size C +
  (1 + max S (maxl (map (fun tv : term * value => value_size (snd tv)) C))) *
  (1 + (A * 𝓡 prog S + A) + max_arity * (A * 𝓡 prog S + A))) +
  cache_size C.

Definition PPO_bound S := gsp (bep S).
(* S : max size of an activation *)

(* Rough upper bound on rationals *)
Definition ub (q :  Q) : nat := let (n,d):= q in Z.abs_nat n.

Lemma ub_is_ub : forall q, (q <= inject_Z (Z.of_nat (ub q)))%Q.
Proof.
intros (q&d). simpl. destruct q; unfold inject_Z; simpl; auto with *;
rewrite positive_nat_Z; unfold Qle; simpl; nia.
Qed.

Definition QI_bound (f:function) (lv: list term) :=
  (* f : active function symbol
     lv : list of its arguments *)
    (Qpos_of_nat(max_arity + 1)) *q
    (qif f (map (fun x=> Qpos_mult mcs (Qpos_of_nat (╎fapply f lv╎))) lv))
    +q 1.

Definition global_bound f lv C :=
  let S:= ub (QI_bound f lv) in
  let A:= PPO_bound S in
  CBV_bound A S C.

(********** Proofs **********)

(* All bounds are increasing *)
Lemma gary_increase: (* move to Ordering ? *)
  forall x y, x <=y -> gsp x <= gsp y.
Proof.
intros.
unfold gary_seven_poly.
apply suml_map_le.
intros.
unfold ℐᵃ_at_rank_bound.
apply Mult.mult_le_compat_l.
apply pow_le_compat;trivial.
Qed.

Lemma PPO_bound_increase:
  (forall x y, x <= y -> PPO_bound x <= PPO_bound y)%nat.
Proof.
intros.
unfold PPO_bound.
apply gary_increase.
apply bobby_increase.
trivial.
Qed.

Lemma 𝓡_increase:
  forall x y, x <= y -> 𝓡 prog x <= 𝓡 prog y.
Proof.
intros.
unfold 𝓡.
apply Mult.mult_le_compat_l.
apply Plus.plus_le_compat_l;trivial.
Qed.

Lemma CBV_bound_increase:
  forall x1 y1 x2 y2 C, x1 <= y1 -> x2 <= y2 -> CBV_bound x1 x2 C <= CBV_bound y1 y2 C.
Proof.
intros.
unfold CBV_bound.
apply Plus.plus_le_compat_r.
apply Mult.mult_le_compat;
repeat (try apply Plus.plus_le_compat; trivial; try apply Mult.mult_le_compat; trivial).
apply Nat.max_le_compat_r;trivial.
Qed.

(** Theorem 9 (P-criterion) *)
Theorem P_criterion: forall i s p c f lv d v,
  let t :=  (fapply f lv) in
  let π := cbv_update i s p c t d v in
  wf π -> cache_bounded c ->
  ∣π∣ <= global_bound f lv c.
Proof.
intros i s p c f lv d v t π well_formed cache_bound.
unfold global_bound.
assert (𝓢 π <= ub (QI_bound f lv)).
- rewrite Nat2Z.inj_le, Zle_Qle.
  eapply Qle_trans; [ | apply ub_is_ub].
  apply 𝓢_bound
 with (prog:=prog) (rule_default:=rule_default)
        (variable_eq_dec:=variable_eq_dec) (function_eq_dec :=function_eq_dec) (constructor_eq_dec:=constructor_eq_dec)
        (qic:=qic) (cs:=cs);trivial.
- apply le_trans with (m:= CBV_bound (PPO_bound (𝓢 π)) (𝓢 π) c).
  + assert (length (ℐᵃ π) <= PPO_bound (𝓢 π)).
    * {
        apply le_trans with (m:=gsp (A_T variable function constructor rank π)).
        - apply gary_seven with (variable_eq_dec:=variable_eq_dec) (function_eq_dec:=function_eq_dec)
                                (constructor_eq_dec:=constructor_eq_dec) (rule_default:=rule_default)
                                (max_arity:=max_arity);try trivial.
          apply PPO_is_compatible_prog;trivial.
        - unfold PPO_bound.
          apply gary_increase.
          apply A_T_bound with (variable_eq_dec:=variable_eq_dec) (function_eq_dec:=function_eq_dec)
                               (constructor_eq_dec:=constructor_eq_dec) (rule_default:=rule_default)
                               (max_rank:=max_rank);trivial.
      }
    * {
        apply le_trans with (m:=CBV_bound (length (ℐᵃ π)) (𝓢 π) c).
        - apply size_bound_gen with (variable_eq_dec:=variable_eq_dec) (function_eq_dec:=function_eq_dec)
                                    (constructor_eq_dec:=constructor_eq_dec) (rule_default:=rule_default);trivial.
        - apply CBV_bound_increase;trivial.
      }
  + apply CBV_bound_increase;try trivial.
    * apply PPO_bound_increase;try trivial.
Qed.

End Main.


Require Import prelude.all.

Require Import syntax.hit_signature.
Require Import algebras.set_algebra.
Require Import displayed_algebras.displayed_algebra.

(**
Some operations needed for displayed algebras
 *)
Definition poly_dact_const
           (P : poly_code)
           {X Y : hSet}
           (x : ⦃ P ⦄ X)
  : poly_dact P (λ (z : X), Y) x → ⦃ P ⦄ Y.
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (idfun _).
  - exact (idfun _).
  - induction x as [x | x].
    + exact (λ z, inl (IHP₁ x z)).
    + exact (λ z, inr (IHP₂ x z)).
  - exact (λ z, IHP₁ (pr1 x) (pr1 z) ,, IHP₂ (pr2 x) (pr2 z)).
Defined.

Definition poly_dmap_const
           (P : poly_code)
           {X Y : hSet}
           (x : ⦃ P ⦄ X)
           (f : X → Y)
  : poly_dact_const P x (poly_dmap P (λ (z : X), Y) f x)
    =
    #⦃ P ⦄ f x.
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - reflexivity.
  - reflexivity.
  - induction x as [x | x].
    + simpl ; cbn.
      apply maponpaths.
      exact (IHP₁ x).
    + simpl ; cbn.
      apply maponpaths.
      exact (IHP₂ x).
  - apply pathsdirprod.
    + exact (IHP₁ (pr1 x)).
    + exact (IHP₂ (pr2 x)).
Qed.

Definition endpoint_dact_const
           {A : poly_code}
           (X Y : set_prealgebras A)
           {P Q : poly_code}
           (e : endpoint A P Q)
           {z : ⦃ P ⦄ (prealg_carrier X)}
           (y : poly_dact P (λ _ : prealg_carrier X, prealg_carrier Y) z)
  : poly_dact_const
      Q
      (set_endpoint e X z)
      (endpoint_dact X e
                     (λ x y, prealg_operation Y (poly_dact_const A x y))
                     y)
    =
    set_endpoint e Y (poly_dact_const P z y).
Proof.
  induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                  | P Q | P Q | P Q | P Q | P Q R e₁ IHe₁ e₂ IHe₂ | P T t | Z₁ Z₂ f | ]
  ; try reflexivity.
  - simpl.
    exact (IHe₂ _ _ @ maponpaths _ (IHe₁ _ _)).
  - apply pathsdirprod.
    + apply IHe₁.
    + apply IHe₂.
Qed.

Definition const_disp_algebra
           {Σ : hit_signature}
           (X Y : set_algebra Σ)
  : disp_algebra X.
Proof.
  use make_disp_algebra.
  - intro.
    apply Y.
  - intros x z ; simpl in *.
    exact (alg_operation Y (poly_dact_const (point_arg Σ) x z)).
  - intros j x z ; simpl in *.
    rewrite transportf_const ; unfold idfun.
    exact ((endpoint_dact_const X Y (path_lhs Σ j) z)
             @ alg_paths Y j (poly_dact_const (path_arg Σ j) x z)
             @ !(endpoint_dact_const X Y (path_rhs Σ j) z)).
Defined.

Definition const_disp_alg_mor_to_alg_mor
           {Σ : hit_signature}
           (X Y : set_algebra Σ)
  : disp_algebra_map (const_disp_algebra X Y) → X --> Y.
Proof.
  intros f.
  use make_algebra_map.
  - exact (pr1 f).
  - intros x ; simpl ; cbn.
    refine (pr2 f x @ _).
    cbn.
    apply maponpaths.
    apply poly_dmap_const.
Defined.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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 conj15synthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus lv0 (mult (Succ lv0) lv1))) (plus (mult lv0 (Succ lv1)) (Succ lv1))).
Admitted.
QuickChick conj15synthconj3.


Require Coq.Lists.List.
Import List.ListNotations.

Require Import RecursionSchemes.Indexed.
Require Import RecursionSchemes.Fix.
Require Import RecursionSchemes.PCofix.

Example example_curried_0 : forall t, (Tip *-> t) = t.
Proof. reflexivity. Qed.

Example example_curried_1 :
  forall t1 t, (list_to_telescope [t1] *-> t) = (t1 -> t).
Proof. reflexivity. Qed.

Example example_curried_2 : forall t1 t2 t,
    (list_to_telescope [t1; t2] *-> t) = (t1 -> t2 -> t).
Proof. reflexivity. Qed.

Example example_lift_curried :
  forall t1 t2 s t u
         (f : s -> t -> u)
         (a : list_to_telescope [t1; t2] *-> s)
         (b : list_to_telescope [t1; t2] *-> t)
         (x1 : t1) (x2 : t2),
    lift_curried (list_to_telescope [t1; t2]) f a b x1 x2
    = f (a x1 x2) (b x1 x2).
Proof. reflexivity. Qed.

Example example_algebra : forall t1 t2 f g,
    algebra (list_to_telescope [t1; t2]) f g =
    (forall x1 x2, f g x1 x2 -> g x1 x2).
Proof. reflexivity. Qed.

Example example_mu : forall t1 t2 f x1 x2,
    mu (list_to_telescope [t1; t2]) f x1 x2 =
    forall g, algebra (list_to_telescope [t1; t2]) f g -> g x1 x2.
Proof. reflexivity. Qed.

Inductive listF (A : Type) (list_A : Type) :=
| nilF : listF A list_A
| consF : A -> list_A -> listF A list_A.

Arguments nilF {A list_A}.
Arguments consF {A list_A}.

Definition list' (A : Type) := mu Tip (listF A).

Definition from_list_ {A : Type} (xs : list A) : listF A (list A) :=
  match xs with
  | [] => nilF
  | x :: xs => consF x xs
  end%list.

Definition from_list {A : Type} (xs : list A) : list' A :=
  fun _ alg =>
    (fix fold xs :=
       match xs with
       | [] => alg nilF
       | x :: xs => alg (consF x (fold xs))
       end%list) xs.

Definition to_list {A : Type} (xs : list' A) : list A :=
  xs _ (fun xs =>
          match xs with
          | nilF => []
          | consF x xs => x :: xs
          end%list).

CoInductive stream :=
| Yield : nat -> stream.

Inductive zz_ (zz : list nat -> Prop) : list nat -> Prop :=
| ZZ : forall t, zz t -> zz_ zz (0 :: t).

Definition zz := paco1 _ zz_ (@bot 1 (Tip >- _)).


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl 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 3 of the License, or
  (at your option) any later version.

  VPrl 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 VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export rules_apply.
Require Export rules_function_elim.

(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(* begin hide *)

Hint Rewrite @nh_vars_hyps_app : slow.
Hint Rewrite @nh_vars_hyps_snoc : slow.

(* end hide *)

(* [23] ============ LAMBDA FORMATION ============ *)

(**

 The following rule is called the lambda formation rules.  It says
 that to prove that a function type is true, it is enough to prove
 that given a element [z] in its domain [A], we can prove that its
 codomain [B[x\z]] is true.  We also have to prove that its domain [A}
 is a well-formed type.x
<<
   H |- x:A -> B ext \z.b

     By lambdaFormation lvl(i) z ()

     H z : A |- B[x\z] ext b
     H |- A = A in Type(i)
>>

 *)

Definition rule_lambda_formation {p}
           (A B b : NTerm)
           (x z  : NVar)
           (i    : nat)
           (H    : @barehypotheses p) :=
  mk_rule
    (mk_baresequent H (mk_concl (mk_function A x B) (mk_lam z b)))
    [ mk_baresequent (snoc H (mk_hyp z A))
                    (mk_concl (subst B x (mk_var z)) b),
      mk_baresequent H (mk_conclax (mk_equality A A (mk_uni i))) ]
    [sarg_var z].

Lemma rule_lambda_formation_true {p} :
  forall lib (A B b : NTerm)
         (x z : NVar)
         (i   : nat)
         (H   : @barehypotheses p)
         (bc1 : !LIn z (bound_vars B)),
    rule_true lib (rule_lambda_formation A B b x z i H).
Proof.
  intros.
  unfold rule_lambda_formation, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent (snoc H (mk_hyp z A))
                                  (mk_concl (subst B x (mk_var z)) b))
                   (inl eq_refl))
             (hyps (mk_baresequent H (mk_conclax (mk_equality A A (mk_uni i))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.
  duplicate wfct as wfi.
  rw <- @wf_function_iff in wfct.
  destruct wfct as [ wa wb ].
  duplicate ce0 as ce.
  allrw @nh_vars_hyps_snoc; allsimpl.

  assert (covered (mk_lam z b) (nh_vars_hyps H)) as cv.
  clear hyp1 hyp2.
  allunfold @covered; allsimpl; allrw app_nil_r.
  allrw subvars_remove_nvars.
  allrw <- snoc_as_append; sp.

  exists cv; GC.

  (* We prove some simple facts on our sequents *)
  assert ((z <> x -> !LIn z (free_vars B))
          # !LIn z (free_vars A)
          # !LIn z (vars_hyps H)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
  try (complete (generalize (cg z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (apply_in_hyp p;
                 generalize (subvars_hs_vars_hyps H); intro sv;
                 rw subvars_prop in sv;
                 apply sv in p; sp)).

  destruct vhyps as [ nzB vhyps ].
  destruct vhyps as [ nzA nzH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  (* We prove our first subgoal *)
  assert (forall s2 pC2,
            similarity lib s1 s2 H
            -> tequality lib (lsubstc (mk_function A x B) wfi s1 pC1)
                         (lsubstc (mk_function A x B) wfi s2 pC2)) as tfb.
  clear s2 pC2 pt2 sim.
  intros s2 pC2 sim.
  lift_lsubst.
  rw @tequality_function.

  (* we have to prove that A is a type and B is a type family *)
  split.

  (* we use our 2nd hypothesis to prove that A is a type *)
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2); clear hyp2; intro hyp2.
  autodimp hyp2 h.
  autodimp hyp2 h; exrepd.
  lsubst_tac.
  rw @tequality_mkc_equality in t; repnd; GC.
  allrewrite @member_eq.
  rw <- @member_equality_iff in e.
  dimp t2.
  apply @equality_in_uni in hyp. auto.

  (* we use our 1st hypothesis to prove that B is a type family *)
  intros.
  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 h.

  (* To use our 1st hyp, we first have to prove that the hypotheses are functional *)
  intros s3 sim3.
  inversion sim3; cpx; allsimpl; cpx; clear_irr.
  assert (cover_vars A s4) as c4
    by (apply similarity_cover_vars with (t := A) in sim0; auto).
  (* we use our hyp (coming from proving that our sequent is true) that says that H is functional *)
  rw @eq_hyps_snoc; simpl.

  exists s1 s4 a t2 wa c1 c4; sp.
  (* now to prove that functionality statement on A, we use our 2nd hyp *)
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s4); clear hyp2; intro hyp2.
  autodimp hyp2 hyp.
  autodimp hyp2 hyp; exrepd.
  lsubst_tac.
  rw @tequality_mkc_equality in t; repnd; GC.
  allrewrite @member_eq.
  allrw <- @member_equality_iff.
  dimp t3.
  apply @equality_in_uni in hyp.
  auto.

  (* and we're done proving that the hypotheses are functional *)

  (* now we can keep using our 1st hypothesis *)
  autodimp hyp1 hyp.

  (* For that we have to prove that the two terms we picked to be equal in A are actually equal in A *)
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wa c1; sp.
  (* easy enough *)

  (* and again, we keep on using our 1st hypothesis *)
  exrepd. (* we prove that from t *)

  assert (lsubstc (subst B x (mk_var z)) wfct1 (snoc s1 (z, a)) pC0
          = substc a x (lsubstc_vars B wb (csub_filter s1 [x]) [x] c2)) as eq1
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq1 in t.

  assert (lsubstc (subst B x (mk_var z)) wfct1 (snoc s2 (z, a')) pC3
          = substc a' x (lsubstc_vars B wb (csub_filter s2 [x]) [x] c3)) as eq2
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq2 in t.
  auto.
  (* and we're done proving our 1st subgoal (the tequality) *)

  (* We now prove our second subgoal *)
  sp; lift_lsubst.
  applydup @similarity_refl in sim.
  rw @equality_in_function.

  sp.
  (* We have to prove 3 goals *)

  (* 1) we have to prove that A is a type *)
  generalize (tfb s1 pC1 sim0); sp.
  lsubst_tac.
  allrw @tequality_function; sp.

  (* 2) we have to prove that B is a type family *)
  generalize (tfb s1 pC1 sim0); sp.
  lsubst_tac.
  allrw @tequality_function; sp.

  (* 3) we have to prove that b is a member B *)
  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* first we have to prove that the hypotheses are functional *)
  intros s3 sim3.
  inversion sim3; cpx; allsimpl; cpx; clear_irr.
  assert (cover_vars A s4) as c4
    by (apply similarity_cover_vars with (t := A) in sim1; auto).
  (* we use our hyp (coming from proving that our sequent is true) that says that H is functional *)
  allapplydup eqh.
  rw @eq_hyps_snoc; simpl.
  exists s1 s4 a t2 wa c1 c4; sp.
  (* now to prove that functionality statement on A, we use our 2nd hyp (from tfb) *)
  assert (cover_vars (mk_isect A x B) s4) as c5
    by (apply cover_vars_isect; sp;
        allapplydup @similarity_dom; sp;
        apply @cover_vars_upto_eq_dom_csub with (s2 := s4) in c2; sp;
        allrw; sp).
  generalize (tfb s4 c5 sim1); sp.
  lsubst_tac.
  allrw @tequality_function; sp.
  (* and we're done proving that the hypotheses are functional *)

  (* now we can keep using our 1st hypothesis *)
  autodimp hyp1 hyp.

  (* For that we have to prove that the two terms we picked to be equal in A are actually equal in A *)
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wa c1; sp.
  (* easy enough *)

  (* and again, we keep on using our 1st hypothesis *)
  exrepd. (* we prove that from e *)
  clear t; clear_irr.

  assert (lsubstc (subst B x (mk_var z)) wfct1 (snoc s1 (z, a)) pC0
          = substc a x (lsubstc_vars B wb (csub_filter s1 [x]) [x] c2)) as eq1.
  rewrite substc_eq_lsubstc; simpl.
  apply lsubstc_eq_if_csubst.
  rewrite csubst_app.
  unfold subst, csubst.
  try (rw lsubstn_lsubst; try (complete (simpl; rw disjoint_singleton_r; sp))).
  rewrite simple_lsubst_lsubst;
    try (complete (sp; allapply @in_csub2sub; sp));
    try (complete (simpl; sp; cpx; simpl; apply disjoint_singleton_l; auto)).
  rewrite lsubst_sub_singleton.
  rewrite fold_csubst.
  rewrite csubst_snoc_var;
    try (complete (allapply @similarity_dom; exrepd; allrw; sp)).
  rewrite <- csub2sub_app; simpl.
  rewrite <- snoc_as_append.
  rewrite <- lsubst_swap;
    try (complete (sp; allapply @in_csub2sub; sp));
    try (complete (rewrite @dom_csub_eq; rewrite @dom_csub_csub_filter; rw in_remove_nvars; simpl; sp)).
  repeat (rewrite <- @csub2sub_cons).
  repeat (rewrite @fold_csubst).
  destruct (eq_var_dec z x); subst.
  (* if they're equal it's easy *)
  rewrite csubst_cons_trim.
  rewrite csub_filter_snoc1; sp.
  (* if they're not: *)
  rewrite <- csubst_csub_filter with (l := [z]);
    try (rw disjoint_singleton_r; sp).
  assert (x <> z) as d by auto; simpl.
  apply memvar_singleton_diff_r in d; rewrite d.
  rewrite csub_filter_snoc1; sp.
  rewrite csubst_cons_trim.
  rewrite <- csub_filter_app_r; simpl.
  symmetry.
  rewrite <- csubst_csub_filter with (l := [z]); simpl;
    try (rw disjoint_singleton_r; sp).
  rewrite d.
  rewrite csub_filter_swap.
  rewrite <- csub_filter_app_r; sp.

  rewrite eq1 in e; clear eq1.

  lsubst_tac; sp.

  assert (cequivc lib
            (lsubstc b wfce1 (snoc s1 (z, a)) pt0)
            (mkc_apply
               (mkc_lam z (lsubstc_vars b wfce1 (csub_filter s1 [z]) [z] c0))
               a)) as ceq1.
  apply cequivc_sym.
  revert c0; rw @csub_filter_trivial; introv;
  try (complete (simpl; sp; subst; allapply @similarity_dom; repnd; allrw sim1; sp)).
  destruct_cterms; unfold cequivc; simpl; unfold csubst; simpl.
  allrw @csub2sub_snoc; simpl.
  generalize (cequiv_beta lib z (lsubst b (csub2sub s1)) x1); introv ceq1.
  autodimp ceq1 hyp.
  apply csubst.isprog_vars_lsubst.
  introv k; allrw @in_range_iff; exrepnd; allapply @in_csub2sub; sp.
  simpl.
  rw @isprog_vars_eq; sp.
  allunfold @covered.
  rw @dom_csub_eq.
  allapply @similarity_dom; repnd; allrw.
  apply subvars_trans with (vs2 := snoc (nh_vars_hyps H) z); sp.
  rw subvars_prop; introv j; allsimpl; allrw in_snoc; sp.
  generalize (subset_hs_vars_hyps H); intro k.
  right; apply k; sp.
  rw @nt_wf_eq; sp.
  autodimp ceq1 hyp.
  allrw @isprogram_eq; sp.
  rw @simple_lsubst_snoc in ceq1; sp.
  rw @isprogram_eq; sp.
  allapply @in_csub2sub; sp.

  assert (cequivc lib
            (lsubstc b wfce1 (snoc s2 (z, a')) pt3)
            (mkc_apply
               (mkc_lam z (lsubstc_vars b wfce1 (csub_filter s2 [z]) [z] c3))
               a'))
         as ceq2.
  apply cequivc_sym.
  revert c3; rw @csub_filter_trivial; introv;
  try (complete (simpl; sp; subst; allapply @similarity_dom; repnd; allrw sim; sp)).
  destruct_cterms; unfold cequivc; simpl; unfold csubst; simpl.
  allrw @csub2sub_snoc; simpl.
  generalize (cequiv_beta lib z (lsubst b (csub2sub s2)) x0); introv ceq2.
  autodimp ceq2 hyp.
  apply csubst.isprog_vars_lsubst.
  introv k; allrw @in_range_iff; exrepnd; allapply @in_csub2sub; sp.
  simpl.
  rw @isprog_vars_eq; sp.
  allunfold @covered.
  rw @dom_csub_eq.
  allapply @similarity_dom; repnd; allrw.
  apply subvars_trans with (vs2 := snoc (nh_vars_hyps H) z); sp.
  rw subvars_prop; introv j; allsimpl; allrw in_snoc; sp.
  generalize (subset_hs_vars_hyps H); intro k.
  right; apply k; sp.
  rw @nt_wf_eq; sp.
  autodimp ceq2 hyp.
  allrw @isprogram_eq; sp.
  rw @simple_lsubst_snoc in ceq2; sp.
  rw @isprogram_eq; sp.
  allapply @in_csub2sub; sp.

  apply @equality_respects_cequivc_left with (t1 := lsubstc b wfce1 (snoc s1 (z, a)) pt0); sp.
  apply @equality_respects_cequivc_right with (t2 := lsubstc b wfce1 (snoc s2 (z, a')) pt3); sp.
Qed.

(* begin hide *)

Lemma rule_lambda_formation_true_ex {p} :
  forall lib i z A B b x H (bc1 : !LIn z (bound_vars B)),
    @rule_true_if p lib (rule_lambda_formation A B b x z i H).
Proof.
  intros.
  generalize (rule_lambda_formation_true lib A B b x z i H bc1); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [24] ============ FUNCTION EQUALITY ============ *)

(**

  The following rule is called the function equality rule.  It says
  that to prove that a function type is well-formed, we have to prove
  that its domain is well-formed and that its co-domain is functional
  over its domain.
<<
   H |- x1:a1 -> b1 = x2:a2 -> b2 in Type(i)

     By functionEquality y ()

     H |- a1 = a2 in Type(i)
     H y : a1 |- subst b1 x1 y = subst b2 x2 y in Type(i)
>>
 *)

Definition rule_function_equality_concl {o} (H : @bhyps o) a1 x1 b1 a2 x2 b2 i :=
  mk_baresequent
    H
    (mk_conclax (mk_equality
                   (mk_function a1 x1 b1)
                   (mk_function a2 x2 b2)
                   (mk_uni i))).

Definition rule_function_equality_hyp1 {o} (H : @bhyps o) a1 a2 i e1 :=
  mk_baresequent
    H
    (mk_concl (mk_equality a1 a2 (mk_uni i)) e1).

Definition rule_function_equality_hyp2 {o} (H : @bhyps o) y a1 b1 x1 b2 x2 i e2 :=
  mk_baresequent
    (snoc H (mk_hyp y a1))
    (mk_concl (mk_equality
                 (subst b1 x1 (mk_var y))
                 (subst b2 x2 (mk_var y))
                 (mk_uni i)) e2).

Definition rule_function_equality {p}
           (a1 a2 b1 b2 e1 e2 : NTerm)
           (x1 x2 y : NVar)
           (i   : nat)
           (H   : @barehypotheses p) :=
  mk_rule
    (rule_function_equality_concl H a1 x1 b1 a2 x2 b2 i)
    [
      rule_function_equality_hyp1 H a1 a2 i e1,
      rule_function_equality_hyp2 H y a1 b1 x1 b2 x2 i e2
    ]
    [ sarg_var y ].

Lemma rule_function_equality_true {o} :
  forall lib (a1 a2 b1 b2 e1 e2 : NTerm) (x1 x2 y : NVar) (i : nat) (H : @barehypotheses o),
    rule_true lib (rule_function_equality
                     a1 a2 b1 b2 e1 e2
                     x1 x2 y
                     i
                     H).
Proof.
  intros.
  apply (rule_tyfam_equality_true _ _ mkc_function); auto.
  - introv; simpl; allrw remove_nvars_nil_l; allrw app_nil_r; auto.
  - introv; apply lsubstc_mk_function_ex.
  - introv; apply equality_function.
Qed.

Lemma rule_function_equality_true3 {o} :
  forall lib (a1 a2 b1 b2 e1 e2 : NTerm) (x1 x2 y : NVar) (i : nat) (H : @barehypotheses o),
    rule_true3 lib (rule_function_equality
                     a1 a2 b1 b2 e1 e2
                     x1 x2 y
                     i
                     H).
Proof.
  intros.
  apply (rule_tyfam_equality_true3 _ _ mkc_function); auto.
  - introv; simpl; allrw remove_nvars_nil_l; allrw app_nil_r; auto.
  - introv; apply lsubstc_mk_function_ex.
  - introv; apply equality_function.
Qed.

Lemma rule_function_equality_true_ext_lib {o} :
  forall lib (a1 a2 b1 b2 e1 e2 : NTerm) (x1 x2 y : NVar) (i : nat) (H : @barehypotheses o),
    rule_true_ext_lib lib (rule_function_equality
                             a1 a2 b1 b2 e1 e2
                             x1 x2 y
                             i
                             H).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_function_equality_true3.
Qed.

Lemma rule_function_equality_wf2 {o} :
  forall (a1 a2 b1 b2 e1 e2 : NTerm) (x1 x2 y : NVar) (i : nat) (H : @barehypotheses o),
    !LIn y (vars_hyps H)
    -> wf_rule2 (rule_function_equality
                   a1 a2 b1 b2 e1 e2
                   x1 x2 y
                   i
                   H).
Proof.
  introv niyH wf j.

  allsimpl; repdors; sp; subst; allunfold @wf_bseq; wfseq;
    allrw <- @wf_function_iff; repnd; auto;
      allrw @covered_function; repnd; auto; eauto 4 with slow.

  - apply vswf_hypotheses_snoc; dands; simpl; auto.
    apply isprog_vars_iff_covered; dands; auto.

  - apply covered_subst; eauto 2 with slow.
    eapply covered_subvars;[|eauto].
    rw subvars_eq; introv j; simpl in *; allrw in_snoc; tcsp.

  - apply covered_subst; eauto 2 with slow.
    eapply covered_subvars;[|eauto].
    rw subvars_eq; introv j; simpl in *; allrw in_snoc; tcsp.
Qed.

(* begin hide *)

Lemma rule_function_equality_true_ex {o} :
  forall lib y i a1 a2 b1 b2 e1 e2 x1 x2 H,
    @rule_true_if o lib (rule_function_equality a1 a2 b1 b2 e1 e2 x1 x2 y i H).
Proof.
  intros.
  generalize (rule_function_equality_true lib a1 a2 b1 b2 e1 e2 x1 x2 y i H); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [25] ============ LAMBDA EQUALITY ============ *)

(**

  The following rule is called the lambda equality rule.  It allows
  one to prove that lambda-abstractions are well-typed.
<<

   H |- \x1.t1 = \x2.t2 in x:A->B

     By lambdaEquality lvl(i) z ()

     H z : A |- t1[x1\z] = t2[x2\z] in B[x\z]
     H |- A = A in Type(i)
>>
 *)

Definition rule_lambda_equality {o}
           (A B t1 t2 : NTerm)
           (x1 x2 x z : NVar)
           (i : nat)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_lam x1 t1)
                      (mk_lam x2 t2)
                      (mk_function A x B))))
    [ mk_baresequent
        (snoc H (mk_hyp z A))
        (mk_conclax (mk_equality
                       (subst t1 x1 (mk_var z))
                       (subst t2 x2 (mk_var z))
                       (subst B x (mk_var z)))),
      mk_baresequent
        H
        (mk_conclax (mk_equality A A (mk_uni i))) ]
    [sarg_var z].

Lemma rule_lambda_equality_true {o} :
  forall lib (A B t1 t2 : NTerm)
         (x1 x2 x z : NVar)
         (i   : nat)
         (H   : @barehypotheses o)
         (bc1 : !LIn z (bound_vars B))
         (bc2 : !LIn z (bound_vars t1))
         (bc3 : !LIn z (bound_vars t2)),
    rule_true lib (rule_lambda_equality A B t1 t2 x1 x2 x z i H).
Proof.
  intros.
  unfold rule_lambda_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.
  duplicate wfct as wfi.
  rw <- @wf_equality_iff in wfct.
  destruct wfct as [ wl1 wfct ].
  destruct wfct as [ wl2 wfct ].
  rw <- @wf_function_iff in wfct.
  destruct wfct as [ wA wB ].
  duplicate ce0 as ce.
  allrw @nh_vars_hyps_snoc; allsimpl.

  exists (@covered_axiom o (nh_vars_hyps H)); GC.

  (* We prove some simple facts on our sequents *)
  assert ((z <> x -> !LIn z (free_vars B))
          # (z <> x1 -> !LIn z (free_vars t1))
          # (z <> x2 -> !LIn z (free_vars t2))
          # !LIn z (free_vars A)
          # !LIn z (vars_hyps H)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
  try (complete (generalize (cg z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (generalize (cg0 z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (generalize (cg1 z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (apply_in_hyp p;
                 generalize (subvars_hs_vars_hyps H); intro sv;
                 rw subvars_prop in sv;
                 apply sv in p; sp)).

  destruct vhyps as [ nzB vhyps ].
  destruct vhyps as [ nzt1 vhyps ].
  destruct vhyps as [ nzt2 vhyps ].
  destruct vhyps as [ nzA nzH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  lsubst_tac.
  rw @member_eq.
  rw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality lib
                (mk_function A x B) (mk_lam x1 t1) (mk_lam x2 t2) s1 s2 H
                wT wl1 wl2 c1 c0 c2 c3 cT cT0 eqh sim);
    intro k.
  lsubst_tac.
  apply k; clear k.

  rw @tequality_function.

  split.

  (* First, we prove that the a's are types *)
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2 eqh sim); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  rw @member_eq in hyp2.
  rw <- @member_equality_iff in hyp2.
  apply @equality_commutes2 in hyp0; try (complete auto).
  apply @equality_in_uni in hyp0; auto.

  (* Then we prove that the b's are type families *)
  intros a a' ea.
  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* we have to prove the functionality of our hypotheses *)
  apply hyps_functionality_snoc2; simpl; try (complete sp).
  introv eq s.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s' eqh s); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  rw @member_eq in hyp1.
  rw <- @member_equality_iff in hyp1.
  apply @equality_commutes2 in hyp0; try (complete auto).
  apply @equality_in_uni in hyp0; auto.

  (* we have to prove the similarity of our hypotheses *)
  autodimp hyp1 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wA c4; sp.

  (* we can now use hyp1 *)
  exrepnd; lsubst_tac.

  (* we use hyp0 *)
  rw @tequality_mkc_equality in hyp0; repnd.

  (* we use hyp3 *)
  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a)) cT1
          = substc a x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c5)) as eq1
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq1 in hyp3.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s2 (z, a')) cT2
          = substc a' x (lsubstc_vars B wB (csub_filter s2 [x]) [x] c7)) as eq2
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq2 in hyp3.

  sp.

  (* we prove the membership *)
  clear dependent s1; clear dependent s2.
  introv hf sim.
  lsubst_tac.
  rw @equality_in_function3.

  dands.

  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  rw @member_eq in hyp2.
  rw <- @member_equality_iff in hyp2.
  apply @equality_in_uni in hyp2; auto.

  introv ea.

  assert (cover_vars (mk_var z) (snoc s1 (z, a)))
    as cv1 by (apply @cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  assert (cover_vars (mk_var z) (snoc s2 (z, a')))
    as cv2 by (apply @cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  assert (disjoint (free_vars (@mk_var o z)) (bound_vars t1))
    as disj1 by (simpl; rw disjoint_singleton_l; sp).

  assert (disjoint (free_vars (@mk_var o z)) (bound_vars t2))
    as disj2 by (simpl; rw disjoint_singleton_l; sp).

  assert (disjoint (free_vars (@mk_var o z)) (bound_vars B))
    as disjB by (simpl; rw disjoint_singleton_l; sp).

  dands.

  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s1 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* we have to prove the functionality of our hypotheses *)
  apply hyps_functionality_snoc2; simpl; try (complete sp).
  introv eq sim'.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s' hf sim'); clear hyp2; intro hyp2; exrepd.
  lsubst_tac.
  rw @member_eq in e.
  rw <- @member_equality_iff in e.
  apply @equality_commutes2 in t; try (complete auto).
  apply @equality_in_uni in t; auto.

  (* we have to prove the similarity of our hypotheses *)
  autodimp hyp1 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s1 a a' wA c1; sp.
  apply @similarity_refl in sim; auto.

  exrepnd.
  lsubst_tac.
  rw @tequality_mkc_equality in hyp0; repnd.
  clear hyp1 hyp0.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a)) cT
          = substc a x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c2)) as eq1
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq1 in hyp3; clear eq1.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a')) cT0
          = substc a' x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c2)) as eq2
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq2 in hyp3; clear eq2.
  auto.

  repeat betared.

  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* we have to prove the functionality of our hypotheses *)
  apply hyps_functionality_snoc2; simpl; try (complete sp).
  introv eq sim'.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s' hf sim'); clear hyp2; intro hyp2; exrepd.
  lsubst_tac.
  rw @member_eq in e.
  rw <- @member_equality_iff in e.
  apply @equality_commutes2 in t; try (complete auto).
  apply @equality_in_uni in t; auto.

  (* we have to prove the similarity of our hypotheses *)
  autodimp hyp1 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wA c1; sp.

  exrepnd.
  lsubst_tac.
  rw @member_eq in hyp1.
  rw <- @member_equality_iff in hyp1.

  apply @equality_commutes4 in hyp0; auto; clear hyp1.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a)) cT
          = substc a x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c2)) as eq
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq in hyp0; clear eq.

  assert (lsubstc (subst t1 x1 (mk_var z)) w2 (snoc s1 (z, a)) c4
          = substc a x1 (lsubstc_vars t1 w1 (csub_filter s1 [x1]) [x1] c0)) as eq
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq in hyp0; clear eq.

  assert (lsubstc (subst t2 x2 (mk_var z)) w3 (snoc s2 (z, a')) c7
          = substc a' x2 (lsubstc_vars t2 w0 (csub_filter s2 [x2]) [x2] c3)) as eq
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq in hyp0; clear eq.
  auto.
Qed.

(* begin hide *)

(* end hide *)