Require Import Coq.Init.Datatypes.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.Lists.ListSet.
Require Import Coq.Init.Nat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
From Coq Require Import Lia.
Require Coq.Classes.RelationClasses.
Require Import Coq.Logic.Classical_Prop.

Open Scope bool_scope.

Set Implicit Arguments.

Module DirectedWeightedGraph.

Definition prop_on_unfolded_pair {A : Type}
  (pair : A * A) (P : A -> A -> Prop): Prop :=
  match pair with (fst, snd) => P fst snd end.

Notation "'Sig_no'" := (False_rec _ _) (at level 42).
Notation "'Sig_yes' e" := (exist _ e _) (at level 42).
Notation "'Sig_take' e" :=
  (match e with Sig_yes ex => ex end) (at level 42).

Fixpoint list_from_n'_to_0 (n : nat) : list nat :=
  match n with
  | S n' => n' :: list_from_n'_to_0 n'
  | O => []
  end.
(* Definition W : forall (u v : nat), { p : nat * nat | E u v /\ p = (u, v) }.
  refine (fun u v => if u =? v then Sig_no else Sig_yes (u, v)).

Check ({ p : nat * nat | E u v /\ p = (u, v) }). *)
Structure DWGraph := {
  num_v :> nat ;
  E :> nat -> nat -> Prop ;
  W : nat -> nat -> nat ;
  E_decidable : forall u v : nat, ({E u v} + {~ E u v}) ;
  adjacent (u v : nat) : bool := if E_decidable u v then true else false ;
  adjacent_v_ids (u : nat) : list nat := filter (adjacent u) (seq 0 num_v) ;
  all_nodes : set nat := seq 0 num_v
}.

Definition Empty (n : nat) : DWGraph.
Proof.
  refine {| num_v := n ;
            E := (fun x y => False)
         |}.
  auto.
  auto.
Defined.

Definition empty3 := Empty 3.
Compute (W empty3).
Compute (adjacent empty3).

End DirectedWeightedGraph.


Require Import
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.Compose
        Fiat.Narcissus.BinLib.Core
        Fiat.Narcissus.BinLib.FixInt.

Set Implicit Arguments.

Record test_t :=
  { f1 : { n : N | (n < exp2 32)%N };
    f2 : { n : N | (n < exp2 8)%N };
    f3 : { n : N | (n < exp2 4)%N };
    f4 : { n : N | (n < exp2 16)%N } }.

Instance test_cache : Cache :=
  {| CacheFormat := unit;
     CacheDecode := unit;
     Equiv := fun _ _ => True |}.

Instance test_cache_add_nat : CacheAdd test_cache N :=
  {| addE := fun ce _ => ce;
     addD := fun cd _ => cd;
     add_correct := fun _ _ _ => id |}.

Definition format_test (t : test_t) (ce : CacheFormat) :=
  compose bmonoid (FixInt_format (f1 t)) (
  compose bmonoid (FixInt_format (f2 t)) (
  compose bmonoid (FixInt_format (f3 t)) (
  compose bmonoid (FixInt_format (f4 t)) (
                       (fun e => (nil, e)))))) ce.

(* Commenting out until we update for new framework. *)
(*
Definition test_decoder
  : { decode | exists P, format_decode_correct test_cache bmonoid P format_test decode }.
Proof.
  eapply compose_format_correct. eapply FixInt_format_correct. solve_predicate.
  intro.
  eapply compose_format_correct. eapply FixInt_format_correct. solve_predicate.
  intro.
  eapply compose_format_correct. eapply FixInt_format_correct. solve_predicate.
  intro.
  eapply compose_format_correct. eapply FixInt_format_correct. solve_predicate.
  intro.
  solve_done.
Defined.

Definition test_decoder'
  : list bool -> CacheDecode -> test_t * list bool * CacheDecode.
Proof.
  let p' := eval cbv delta [ proj1_sig test_decoder ] beta iota in (proj1_sig test_decoder) in
                                                                      pose p' as p.
  exact p.
Defined. *)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^384 - 317
Base: 54 + 6/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 54 + 6/7;
    bitwidth := 64;
    s := 2^384;
    c := [(1, 317)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Construction.Product.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Bifunctor.

Context {C : Category}.
Context {D : Category}.
Context {E : Category}.

Definition bimap {F : C ∏ D ⟶ E} {x w : C} {y z : D}
(f : x ~{C}~> w) (g : y ~{D}~> z) :
F (x, y) ~{E}~> F (w, z) := @fmap (C ∏ D) E F (x, y) (w, z) (f, g).

Corollary bimap_fmap {F : C ∏ D ⟶ E} {x w : C} {y z : D}
(f : x ~{C}~> w) (g : y ~{D}~> z) :
@fmap (C ∏ D) E F (x, y) (w, z) (f, g) = bimap f g.
Proof. hammer_hook "Bifunctor" "Bifunctor.bimap_fmap". reflexivity. Defined.

Global Program Instance bimap_respects {F : C ∏ D ⟶ E} {x w : C} {y z : D} :
Proper (equiv ==> equiv ==> equiv) (@bimap F x w y z).
Next Obligation.
proper.
unfold bimap.
apply fmap_respects.
split; assumption.
Qed.

Lemma bimap_id_id {F : C ∏ D ⟶ E} {x y} :
bimap (id[x]) (id[y]) ≈ id.
Proof. hammer_hook "Bifunctor" "Bifunctor.bimap_id_id".
destruct F; simpl.
apply fmap_id.
Qed.

Lemma bimap_comp {F : C ∏ D ⟶ E} {x y z w u v}
(f : y ~{C}~> z) (h : x ~{C}~> y)
(g : v ~{D}~> w) (i : u ~{D}~> v) :
bimap (f ∘ h) (g ∘ i) ≈ bimap f g ∘ bimap h i.
Proof. hammer_hook "Bifunctor" "Bifunctor.bimap_comp".
unfold bimap.
rewrite <- fmap_comp.
apply fmap_respects.
reflexivity.
Qed.

Lemma bimap_comp_id_left {F : C ∏ D ⟶ E} {w}
`(f : y ~{D}~> z) `(g : x ~{D}~> y) :
bimap (id[w]) (f ∘ g) ≈ bimap id f ∘ bimap id g.
Proof. hammer_hook "Bifunctor" "Bifunctor.bimap_comp_id_left".
unfold bimap.
rewrite <- fmap_comp.
apply fmap_respects.
split; simpl; cat.
Qed.

Lemma bimap_comp_id_right {F : C ∏ D ⟶ E} {w}
`(f : y ~{C}~> z) `(g : x ~{C}~> y) :
bimap (f ∘ g) (id[w]) ≈ bimap f id ∘ bimap g id.
Proof. hammer_hook "Bifunctor" "Bifunctor.bimap_comp_id_right".
unfold bimap.
rewrite <- fmap_comp.
apply fmap_respects.
split; simpl; cat.
Qed.

Lemma bimap_id_right_left {F : C ∏ D ⟶ E} {w}
`(f : z ~{C}~> w) `(g : x ~{D}~> y) :
bimap f id ∘ bimap id g ≈ bimap f g.
Proof. hammer_hook "Bifunctor" "Bifunctor.bimap_id_right_left".
unfold bimap.
rewrite <- fmap_comp.
apply fmap_respects.
split; simpl; cat.
Qed.

Lemma bimap_id_left_right {F : C ∏ D ⟶ E} {w}
`(f : z ~{D}~> w) `(g : x ~{C}~> y) :
bimap id f ∘ bimap g id ≈ bimap g f.
Proof. hammer_hook "Bifunctor" "Bifunctor.bimap_id_left_right".
unfold bimap.
rewrite <- fmap_comp.
apply fmap_respects.
split; simpl; cat.
Qed.

Global Program Instance bifunctor_respects {F : C ∏ D ⟶ E} :
Proper ((fun p q => Isomorphism (fst p) (fst q) ∧
Isomorphism (snd p) (snd q))
==> Isomorphism) F.
Next Obligation.
proper; simpl in *.
isomorphism.
- exact (bimap X H).
- exact (bimap (X⁻¹) (H⁻¹)).
- rewrite <- bimap_comp.
rewrite !iso_to_from.
rewrite bimap_id_id.
reflexivity.
- rewrite <- bimap_comp.
rewrite !iso_from_to.
rewrite bimap_id_id.
reflexivity.
Defined.

End Bifunctor.

Notation "bimap[ F ]" := (@bimap _ _ _ F%functor _ _ _ _)
(at level 9, format "bimap[ F ]") : morphism_scope.

Hint Rewrite @bimap_id_id : categories.

Ltac bimap_left :=
apply bimap_respects; [reflexivity|].

Ltac bimap_right :=
apply bimap_respects; [|reflexivity].

Ltac normal :=
repeat
match goal with
| [ |- context [?F ∘ (?G ∘ ?H)] ] =>
rewrite (comp_assoc F G H)

| [ |- context [fmap[?F] ?G ∘ fmap[?F] _] ] =>
rewrite <- (@fmap_comp _ _ F _ _ _ G)

| [ |- context [fmap[?F] id] ] =>
rewrite <- (@fmap_id _ _ F)

| [ |- context [bimap ?F _ ∘ bimap _ _] ] =>
rewrite <- (bimap_comp F)
| [ |- context [(?F ∘ bimap ?G _) ∘ bimap _ _] ] =>
rewrite <- (comp_assoc F (bimap _ _));
rewrite <- (bimap_comp G)

| [ |- context [id ∘ ?F] ] => rewrite (id_left F)
| [ |- context [?F ∘ id] ] => rewrite (id_right F)

| [ |- context [bimap id id] ] =>
rewrite bimap_id_id
| [ |- context [bimap ?F id ∘ bimap id ?G] ] =>
rewrite (bimap_id_right_left F)
| [ |- context [bimap id ?F ∘ bimap ?G id] ] =>
rewrite (bimap_id_left_right F G)

| [ H : context [fmap[?F] ?G ∘ fmap[?F] _] |- _ ] =>
rewrite <- (@fmap_comp _ _ F _ _ _ G) in H
| [ H : context [bimap ?F id ∘ bimap id ?G] |- _ ] =>
rewrite (bimap_id_right_left F) in H
| [ H : context [bimap id ?F ∘ bimap ?G id] |- _ ] =>
rewrite (bimap_id_left_right F G) in H
| [ H : context [bimap ?F _ ∘ bimap _ _] |- _ ] =>
rewrite <- (bimap_comp F) in H
| [ H : context [(?F ∘ bimap ?G _) ∘ bimap _ _] |- _ ] =>
rewrite <- (comp_assoc F (bimap _ _)) in H;
rewrite <- (bimap_comp G) in H
| [ H : context [id ∘ ?F] |- _ ] => rewrite (id_left F) in H
| [ H : context [?F ∘ id] |- _ ] => rewrite (id_right F) in H
end.


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

Require Export RelationClasses.
Require Import Bool Morphisms Setoid.

Set Implicit Arguments.
Unset Strict Implicit.

(** Structure with nothing inside.
    Used to force a module type T into a module via Nop <+ T. (HACK!) *)

Module Type Nop.
End Nop.

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

Module Type Typ.
  Parameter Inline(10) t : Type.
End Typ.

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

Module Type HasEq (Import T:Typ).
  Parameter Inline(30) 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.

(** In a BooleanEqualityType, [eqb] is compatible with [eq] *)

Module BoolEqualityFacts (Import E : BooleanEqualityType).

Instance eqb_compat : Proper (E.eq ==> E.eq ==> Logic.eq) eqb.
Proof.
intros x x' Exx' y y' Eyy'.
apply eq_true_iff_eq.
now rewrite 2 eqb_eq, Exx', Eyy'.
Qed.

End BoolEqualityFacts.

(** * 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 Export Iron.Language.SystemF2Effect.Step.Frame.

(********************************************************************)
(* Region identifier is not mentioned some FPriv frame. *)
Fixpoint NoPrivF (p : nat) (f : frame) {struct f} :=
 match f with
 | FLet t x               => True
 | FPriv None p1          => ~(p = p1)
 | FPriv (Some p1) p2     => ~(p = p1) /\ ~(p = p2)
 end.

Definition NoPrivFs (p : nat) (fs : stack)
 := Forall (NoPrivF p) fs.

Lemma noprivFs_head
 :  forall p fs f
 ,  NoPrivFs p (fs :> f)
 -> NoPrivF  p f.
Proof.
 intros. inverts H. eauto.
Qed.
Hint Resolve noprivFs_head.

Lemma noprivFs_tail
 :  forall p fs f
 ,  NoPrivFs p (fs :> f)
 -> NoPrivFs p fs.
Proof.
 intros. inverts H. eauto.
Qed.
Hint Resolve noprivFs_tail.

(********************************************************************)
(* Region identifier is not mentioned in the given stack frame. *)
Fixpoint FreshF (p : nat) (ff : frame) {struct ff} :=
 match ff with
 | FLet  t x           => FreshT p t /\ FreshX p x
 | FPriv None      p2  => ~(p = p2)
 | FPriv (Some p1) p2  => ~(p = p1)  /\ ~(p = p2)
 end.

(* Region identifier is not mentioned in the given stack.  *)
Definition FreshFs (p : nat) (fs : stack)
 := Forall (FreshF p) fs.
Hint Unfold FreshFs.

Lemma freshFs_head
 :  forall p f fs
 ,  FreshFs p (fs :> f)
 -> FreshFs p fs.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve freshFs_head.

Lemma freshFs_tail
 :  forall p f fs
 ,  FreshFs p (fs :> f)
 -> FreshF  p f.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve freshFs_tail.

Lemma freshFs_cons
 :  forall p f fs
 ,  FreshFs p fs -> FreshF p f
 -> FreshFs p (fs :> f).
Proof. snorm. Qed.
Hint Resolve freshFs_cons.

Lemma freshF_noprivF
 : forall p f
 , FreshF p f -> NoPrivF p f.
Proof.
 intros.
 destruct f.
 - snorm.
 - destruct o; snorm.
Qed.
Hint Resolve freshF_noprivF.

Lemma freshFs_noprivFs
 : forall  p fs
 , FreshFs p fs -> NoPrivFs p fs.
Proof.
 intros.
 induction fs.
 - unfold NoPrivFs. eauto.
 - unfold NoPrivFs. inverts H. firstorder.
Qed.
Hint Resolve freshFs_noprivFs.

(*********************************************************************)
(* Region identifier is not mentioned in the types of the free variables
   of the given stack frame. *)
Fixpoint   FreshFreeF (p : nat) (te : tyenv) (f : frame) {struct f} :=
 match f with
 | FLet t x       => FreshFreeX p (te :> t) x
 | FPriv _ _      => True
 end.

(* Region identifier is not mentioned in the types of the free variables
   of the given stack. *)
Definition FreshFreeFs (p : nat) (te : tyenv) (fs : stack)
 := Forall (FreshFreeF p te) fs.
Hint Unfold FreshFreeFs.

Lemma freshFreeF_nil
 :  forall p f
 ,  FreshF p f
 -> FreshFreeF p nil f.
Proof.
 intros.
 destruct f; snorm.
Qed.
Hint Resolve freshFreeF_nil.

Lemma freshFreeFs_nil
 :  forall p fs
 ,  FreshFs p fs
 -> FreshFreeFs p nil fs.
Proof.
 intros.
 induction fs; eauto.
 inverts H. rip.
Qed.
Hint Resolve freshFreeFs_nil.

Lemma freshFreeFs_tail
 :  forall p te fs f
 ,  FreshFreeFs p te (fs :> f)
 -> FreshFreeFs p te fs.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshFreeFs_tail.

(********************************************************************)
(* Region identifier is not mentioned in the types of the locations
   used in the given stack frame. *)
Fixpoint  FreshSuppF   (p : nat) (se : stenv) (f : frame) {struct f} :=
 match f with
 | FLet  t x      => FreshSuppX p se x
 | FPriv _ _      => True
 end.

(* Region identifier is not mentioned in the types of the locations
   used in the given stack. *)
Definition FreshSuppFs p2 se fs
 := Forall (FreshSuppF p2 se) fs.
Hint Unfold FreshSuppFs.

Lemma freshSuppFs_tail
 :  forall p te fs f
 ,  FreshSuppFs p te (fs :> f)
 -> FreshSuppFs p te fs.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshSuppFs_tail.

Lemma freshSuppFs_head
 :  forall p te fs f
 ,  FreshSuppFs p te (fs :> f)
 -> FreshSuppF  p te f.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshSuppFs_head.

Lemma freshSuppF_mergeTE
 :  forall p1 p2 p3 te f
 ,  FreshSuppF p1 te f
 -> FreshSuppF p2 te f
 -> FreshSuppF p2 (mergeTE p3 p1 te) f.
Proof.
 intros.
 destruct f.
 - snorm.
   eapply freshSuppX_mergeTE; auto.
 - eauto.
Qed.

Lemma freshSuppFs_mergeTE
 :  forall p1 p2 p3 te fs
 ,  FreshSuppFs p1 te fs
 -> FreshSuppFs p2 te fs
 -> FreshSuppFs p2 (mergeTE p3 p1 te) fs.
Proof.
 intros.
 unfold FreshSuppFs in *.
 induction fs; auto.
 inverts H.
 inverts H0. rip.
 eapply Forall_cons; auto.
 eapply freshSuppF_mergeTE; auto.
Qed.


Require Import AutoSep.

(** * A trivial example to make sure the array proof automation isn't completely borked *)

Definition readS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] [| $3 < natToW (length ls) |] * array ls (V "x")
  POST[R] [| R = selN ls 3 |] * array ls (V "x").

Definition writeS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] [| $3 < natToW (length ls) |] * array ls (V "x")
  POST[_] array (updN ls 3 11) (V "x").

Definition bump := map (fun w : W => w ^+ $1).

Definition bumpS : spec := SPEC("arr", "len") reserving 3
  Al ls,
  PRE[V] [| V "len" = $(length ls) |] * array ls (V "arr")
  POST[_] array (bump ls) (V "arr").

Open Scope list_scope.

Definition arrays := bmodule "read" {{
  bfunction "read"("x") [readS]
    "x" <- "x" + 12;;
    "x" <-* "x";;
    Return "x"
  end with bfunction "write"("x") [writeS]
    "x" <- "x" + 12;;
    "x" *<- 11;;
    Return 0
  end with bfunction "bump"("arr", "len", "i", "tmp", "tmp2") [bumpS]
    "i" <- 0;;
    [Al ls, Al done, Al pending,
      PRE[V] [| V "len" = $(length ls) |] * [| V "i" = $(length done) |] * [| ls = done ++ pending |]
        * array ls (V "arr")
      POST[_] Ex ls', [| ls' = done ++ bump pending |] * array ls' (V "arr") ]
    While ("i" < "len") {
      "tmp" <- 4 * "i";;
      "tmp" <- "arr" + "tmp";;
      "tmp2" <-* "tmp";;
      "tmp" *<- "tmp2" + 1;;
      "i" <- "i" + 1
    };;
    Return 0
  end
}}.

Hint Rewrite app_length : sepFormula.

Lemma shift_pos : forall (ls1 ls2 : list W),
  (length ls1 < length (ls1 ++ ls2))%nat
  -> length ls1 + length ls2 = length (ls1 ++ hd (natToW 0) ls2 ^+ natToW 1 :: nil) + length (tl ls2).
  intros; autorewrite with sepFormula in *;
    destruct ls2; simpl in *; unfold W; omega.
Qed.

Ltac pure' := intros; repeat match goal with
                               | [ H : sel _ _ = _ |- _ ] => rewrite H in *
                             end;
  try match goal with
        | [ _ : context[length (?A ++ ?B)] |- _ ] =>
          assert (goodSize (length (A ++ B))) by (eapply containsArray_goodSize; eauto)
      end;
  autorewrite with sepFormula in *; simpl length in *; autorewrite with sepFormula.

Ltac pure := pure'; try (apply f_equal; apply shift_pos; pure'); eauto 7.

Lemma nil_front : forall A n,
  n = @length A nil + n.
  reflexivity.
Qed.

Hint Immediate nil_front.

Lemma shift_updN : forall v pending done,
  (length pending > 0)%nat
  -> updN (done ++ pending) (length done) v = done ++ v :: tl pending.
  induction done; simpl; intuition;
    destruct pending; simpl in *; auto; omega.
Qed.

Theorem selN_hd : forall pending done,
  selN (done ++ pending) (length done) = hd $0 pending.
  induction done; simpl; intuition;
    destruct pending; reflexivity.
Qed.

Hint Rewrite shift_updN selN_hd using solve [ eauto ] : sepFormula.

Hint Rewrite DepList.pf_list_simpl : sepFormula.

Hint Rewrite sel_selN upd_updN using solve [ eauto 6 ] : sepFormula.

Hint Resolve shift_pos.

Lemma not_done_yet : forall A (done pending : list A),
  natToW (length done) < $ (length done + length pending)
  -> (length pending > 0)%nat.
  destruct pending; simpl; intuition;
    rewrite <- plus_n_O in *; unfold natToW in *; nomega.
Qed.

Hint Immediate not_done_yet.

Lemma shift_reorg : forall pending,
  (length pending > 0)%nat
  -> hd $0 pending ^+ $1 :: bump (tl pending)
  = bump pending.
  intros; autorewrite with sepFormula in *; destruct pending; simpl in *; auto; omega.
Qed.

Hint Rewrite shift_reorg using solve [ eauto ] : sepFormula.

Hint Rewrite Npow2_nat wordToN_nat wordToNat_natToWord_idempotent
  using nomega : N.

Lemma now_done : forall A (done pending : list A),
  natToW (length done + length pending) <= $ (length done)
  -> goodSize (length done + length pending)
  -> pending = nil.
  destruct pending; simpl; intuition; elimtype False; eauto.
Qed.

Hint Resolve now_done.

Lemma unbump : forall done pending,
  pending = nil
  -> done ++ pending = done ++ bump pending.
  intros; subst; reflexivity.
Qed.

Hint Resolve unbump.

Hint Rewrite wordToNat_natToW_goodSize using solve [ eauto ] : N.

Lemma bound_nat : forall (done pending : list W),
  natToW (length done) < natToW (length done + length pending)
  -> goodSize (length (done ++ hd $0 pending ^+ $1 :: tl pending))
  -> (length done < length done + length pending)%nat.
  intros; autorewrite with sepFormula N in *; simpl in *;
    apply lt_goodSize'; eauto; destruct pending; simpl in *; eauto using goodSize_weaken.
Qed.

Hint Resolve bound_nat.

Hint Extern 1 (himp _ _ _) => reflexivity.

Lemma goodSize_prefix : forall a b : list W,
  goodSize (length (a ++ b))
  -> goodSize (length a).
  intros; autorewrite with sepFormula in *; eapply goodSize_weaken; eauto.
Qed.

Lemma goodSize_full : forall a b : list W,
  goodSize (length (a ++ b))
  -> goodSize (length a + length b).
  intros; autorewrite with sepFormula in *; eapply goodSize_weaken; eauto.
Qed.

Hint Extern 1 (goodSize (length _)) => eapply goodSize_prefix; eapply containsArray_goodSize.
Hint Extern 1 (goodSize (length _ + length _)) => eapply goodSize_full; eapply containsArray_goodSize.

Hint Extern 1 (_ < _)%nat => apply lt_goodSize'; [ assumption | | ].

Theorem arraysOk : moduleOk arrays.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract (sep_auto; pure).
(*TIME  Print Timing Profile. *)
Qed.


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

(** %\subsection*{ examples :  trivial\_spaces.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export bases_finite_dim.
From Algebra Require Export Singleton.
Require Export alt_build_vecsp.
(** - Here we will make the trivial vectorspace as an example of vectorspaces. Notice
 this differs from the trivial subspace defined in subspaces.v *)

(** -  The underlying set contains only the zero vector; we can take an arbitrary set
 and an arbitrary element on which we build the trivial vectorspace containing only
 that element as the zero vector *)

Section MAIN.
Variable A : Setoid.
Variable a : A.

Let T := single a.

Definition Tplus : Map2 T T T.
apply
 Build_Map2
  with (fun t t' : single a => Build_subtype (Refl a:Pred_fun (single a) a)).
red in |- *.
intros.
auto with algebra.
Defined.

Definition Tzero : T := Build_subtype (Refl a:Pred_fun (single a) a).

Definition Tminus : Map T T.
apply Build_Map with (fun t : T => t).
red in |- *.
auto.
Defined.

Variable F : field.

Definition Tmult : Map2 F T T.
apply Build_Map2 with (fun (f : F) (t : T) => t).
red in |- *.
auto.
Defined.

Definition trivvecsp : vectorspace F.
apply alt_Build_vectorspace with T Tplus Tmult Tzero Tminus; red in |- *;
 auto with algebra.
simpl in |- *.
red in |- *.
intro; destruct x.
simpl in subtype_prf.
simpl in |- *.
auto with algebra.
simpl in |- *.
red in |- *.
simpl in |- *.
intros; destruct x; simpl in subtype_prf; simpl in |- *; auto with algebra.
Defined.
End MAIN.

Section basis.
Variable F : field.
Require Export bases.
Variable A : Setoid.
Variable a : A.
Definition triv_basis : basis (trivvecsp a F).
apply Build_basis with (empty (trivvecsp a F)).
red in |- *.
split.
red in |- *.
cbn - [trivvecsp].
red in |- *.
cbn - [trivvecsp].
Opaque trivvecsp.
split; auto; intros _.
Transparent trivvecsp.
red in |- *.
exists 0.
exists (empty_seq F).
Transparent trivvecsp.
exists (empty_seq (empty (single a))).
cbn - [trivvecsp].
unfold trivvecsp in x.
repeat red in x.
destruct x.
red in |- *.
simpl in subtype_prf.
auto.
apply empty_lin_indep.
Defined.

(* More generally: *)
Definition trivial_basis :
  forall V : vectorspace F, full V =' single (zero V) in _ -> basis V.
intros.
apply Build_basis with (empty V).
red in |- *.
split.
2: apply empty_lin_indep.
red in |- *.
apply Trans with (single (zero V)); auto with algebra.
simpl in |- *.
red in |- *.
simpl in |- *.
split; intros.
red in H0.
inversion_clear H0.
inversion_clear H1.
inversion_clear H0.
assert (x0 =' 0 in _).
generalize no_seq_n_empty; intro p.
apply (p _ V (empty V) (Refl (empty V)) x2).
simpl in H0.
move H0 after x1.
generalize dependent x0.
intros x0 H0.
rewrite H0.
clear H0 x0.
simpl in |- *.
auto.

apply is_lin_comb_comp with (zero V) (empty V); auto with algebra.
red in |- *.
exists 0.
simpl in |- *.
exists (empty_seq F).
exists (empty_seq (empty V)).
auto with algebra.
Defined.

Lemma trivial_then_has_dim_zero :
 forall V : vectorspace F, full V =' single (zero V) in _ -> has_dim 0 V.
intros.
red in |- *.
exists (trivial_basis H).
simpl in |- *.
apply empty_then_has_zero_elements; auto with algebra.
Qed.

Lemma trivvecsp_has_dim_zero : has_dim 0 (trivvecsp a F).
red in |- *.
exists triv_basis.
apply has_n_elements_comp with 0 (empty (trivvecsp a F)); auto with algebra.
Qed.
End basis.


(*

  Copyright 2014 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export approx_props1.

Lemma respects_alpha_2 {o} :
  forall (r1 r2 : bin_rel (@NTerm o)),
    respects_alpha r1
    -> respects_alpha r2
    -> respects_alpha (r1 \2/ r2).
Proof.
  introv resp1 resp2.
  allunfold @respects2; repnd; dands; eauto 3 with slow.
Qed.
Hint Resolve respects_alpha_2 : slow.

Lemma respects_alpha_approx_aux {o} :
  forall lib (r : bin_rel (@NTerm o)),
    respects_alpha r
    -> respects_alpha (approx_aux lib r).
Proof.
  introv resp.
  allunfold @respects2; repnd; dands; eauto 3 with slow.
Qed.
Hint Resolve respects_alpha_approx_aux : slow.

Lemma respects_alpha_bot2 {o} :
  respects_alpha (@bot2 o).
Proof.
  allunfold @respects2; repnd; dands; eauto 3 with slow.
Qed.
Hint Resolve respects_alpha_bot2 : slow.


From Paco Require Export paconotation.
From Paco Require Import pacotac_internal paconotation_internal.
Set Implicit Arguments.
Set Primitive Projections.

(** ** Predicates of Arity 1
*)

Section Arg1_def.

Variable T0 : Type.
Variable lf : rel1 T0 -> rel1 T0.
Arguments lf : clear implicits.

Inductive pind (r: rel1 T0) x0 : Prop :=
| pind_pfold pin
    (* (GE : (pind r /1\ r) <1= pin) *)
    (LE : pin <1= (pind r /1\ r))
    (SIM: lf pin x0)
.

Lemma pind_proper
      r (P: T0 -> Prop)
      (PIND: forall x0 pin
               (LE: pin <1= (pind r /1\ r))
               (IH: pin <1= P)
               (SIM: lf pin x0),
          P x0)
  :
  forall x0 (PR: pind r x0), P x0.
Proof.
  fix IH 2. intros. destruct PR. eapply PIND; eauto.
  intros. apply IH. apply LE in PR. destruct PR. auto.
Qed.

Definition upind (r: rel1 T0) := pind r /1\ r.

End Arg1_def.

Arguments pind [ T0 ] lf r x0.
Arguments upind [ T0 ] lf r x0.
#[export] Hint Unfold upind : core.

(* Less than or equal - internal use only *)
Notation "p <_pind_1= q" :=
  (forall _pind_x0 (PR: p _pind_x0 : Prop), q _pind_x0 : Prop)
  (at level 50, no associativity).

(* (* coinduction automation - internal use only *) *)
(* Ltac pind_cofix_auto := *)
(*   let CIH := fresh "CIH" in cofix CIH; repeat intro; *)
(*   match goal with [H: _ |- _] => apply pind_observe in H; destruct H as [] end; do 2 econstructor; *)
(*   try (match goal with [H: _|-_] => apply H end); intros; *)
(*   lazymatch goal with [PR: _ |- _] => match goal with [H: _ |- _] => apply H in PR end end; *)
(*   repeat match goal with [ H : _ \/ _ |- _] => destruct H end; first [eauto; fail|eauto 10]. *)

Definition monotone T0 (lf: rel1 T0 -> rel1 T0) :=
  forall x0 r r' (IN: lf r x0) (LE: r <1= r'), lf r' x0.

Definition _monotone T0 (lf: rel1 T0 -> rel1 T0) :=
  forall r r' (LE: r <1= r'), lf r <1== lf r'.

Lemma monotone_eq T0 (lf: rel1 T0 -> rel1 T0) :
  monotone lf <-> _monotone lf.
Proof. unfold monotone, _monotone, le1. split; eauto. Qed.

Lemma pind_mon_gen T0 lf lf' r r' x
      (PR: @pind T0 lf r x)
      (LElf: lf <2= lf')
      (LEr: r <1= r'):
  pind lf' r' x.
Proof.
  generalize dependent lf'. generalize dependent r'. induction PR using pind_proper; intros.
  econstructor.
  2: eauto.
  intros. specialize (LE _ PR). destruct LE. split.
  2: eauto.
  eapply IH; eauto.
Qed.

Section Arg1.

Variable T0 : Type.
Variable lf : rel1 T0 -> rel1 T0.
Arguments lf : clear implicits.

Theorem pind_acc: forall
  l r (OBG: forall rr (DEC: rr <1= r) (IH: rr <1= l), pind lf rr <1= l),
  pind lf r <1= l.
Proof.
  intros. assert (SIM: pind lf (r /1\ l) x0).
  { generalize dependent l. induction PR using pind_proper; intros.
    econstructor. 2: eauto.
    intros. specialize (LE _ PR). destruct LE.
    repeat split; eauto.
    eapply (OBG (r /1\ l)); eauto. all: intros x2 AND; destruct AND; eauto.
  }
  clear PR. eapply (OBG (r /1\ l)); eauto. all: intros x1 AND; destruct AND; eauto.
Qed.

Theorem pind_mon: monotone (pind lf).
Proof.
  unfold monotone. intros. generalize dependent r'. induction IN using pind_proper; intros.
  econstructor. 2: eauto.
  intros. specialize (LE _ PR). destruct LE. split; eauto.
Qed.

Theorem pind_mult_strong: forall r,
    pind lf r <1= pind lf (upind lf r).
Proof.
  intros. unfold upind. induction PR using pind_proper. econstructor. 2: eauto.
  intros. specialize (LE _ PR). destruct LE. repeat split; eauto.
Qed.

Corollary pind_mult: forall r,
    pind lf r <1= pind lf (pind lf r).
Proof.
  intros. eapply pind_mult_strong in PR. eapply pind_mon; eauto. unfold upind. intros x1 AND; destruct AND; eauto.
Qed.

Theorem pind_fold: forall r,
  lf (upind lf r) <1= pind lf r.
Proof.
  intros. econstructor. 2: eauto. intros. destruct PR0. auto.
Qed.

Theorem pind_unfold: forall (MON: monotone lf) r,
  pind lf r <1= lf (upind lf r).
Proof.
  intros. unfold upind. induction PR using pind_proper. eapply MON; eauto.
Qed.

Theorem _pind_acc: forall
  l r (OBG: forall rr (DEC: rr <1== r) (IH: rr <1== l), pind lf rr <1== l),
  pind lf r <1== l.
Proof. unfold le1. eapply pind_acc. Qed.

Theorem _pind_mon: _monotone (pind lf).
Proof. apply monotone_eq. eapply pind_mon. Qed.

Theorem _pind_mult_strong: forall r,
  pind lf r <1== pind lf (upind lf r).
Proof. unfold le1. eapply pind_mult_strong. Qed.

Theorem _pind_fold: forall r,
  lf (upind lf r) <1== pind lf r.
Proof. unfold le1. eapply pind_fold. Qed.

Theorem _pind_unfold: forall (MON: _monotone lf) r,
  pind lf r <1== lf (upind lf r).
Proof.
  unfold le1. intro.
  eapply pind_unfold; apply monotone_eq; eauto.
Qed.

End Arg1.

#[export] Hint Unfold monotone : core.
#[export] Hint Resolve pind_fold : core.

Arguments pind_mon_gen        [ T0 ] lf lf' r r' x PR LElf LEr.
Arguments pind_acc            [ T0 ] lf l r OBG x0 PR.
Arguments pind_mon            [ T0 ] lf x0 r r' IN LE.
Arguments pind_mult_strong    [ T0 ] lf r x0 PR.
Arguments pind_mult           [ T0 ] lf r x0 PR.
Arguments pind_fold           [ T0 ] lf r x0 PR.
Arguments pind_unfold         [ T0 ] lf MON r x0 PR.


Require Import List.
Require Import Omega.
Require Import ssreflect.

Inductive configuration : Set :=
  | x
  | a  (_: nat)
  | a' (_: nat)
  | b  (_: nat)
  | b' (_: nat).

Inductive trans : configuration -> configuration -> Prop :=
| trans_xx    : trans x x
| trans_xa    : forall n, trans x (a n)
| trans_xb'   : forall n, trans x (b' n)
| trans_ab    : forall n, trans (a n) (b n)
| trans_a'x   : forall n, trans (a' n) x
| trans_a'a   : forall n m, trans (a' n) (a m)
| trans_a'b'  : forall n m, trans (a' n) (b' m)
| trans_bx    : forall n, trans (b n) x
| trans_ba    : forall n m, trans (b n) (a m)
| trans_bb'   : forall n m, trans (b n) (b' m)
| trans_b'a'  : forall n, trans (b' n) (a' n).

Hint Resolve trans_xx trans_xa trans_xb' : transitions.
Hint Resolve trans_ab trans_a'x trans_a'a trans_a'b' : transitions.
Hint Resolve trans_bx trans_ba trans_bb' trans_b'a' : transitions.

Inductive execution : list configuration -> Prop :=
| exec_nil : execution nil
| exec_a : forall n, execution (a n :: nil)
| exec_x : execution (x :: nil)
| exec_trans : forall `(trans c c')
                 `(execution (e ++ c :: nil)),
	         execution (e ++ c :: c' :: nil).

Definition test_conf_list := x :: x :: (a 1) :: (b 1) :: x :: x :: (b' 5) :: nil.

Lemma rearrange (A: Set) : forall (a b c : A), a :: b :: c :: nil = (a :: nil) ++ (b :: c :: nil).
Proof. by []. Qed.

Lemma test_exec : execution test_conf_list.
Proof.
rewrite /test_conf_list.
repeat (
  rewrite rearrange;
  repeat rewrite app_comm_cons;
  apply exec_trans;
  auto with transitions;
  simpl).
by apply exec_trans with (e := nil); [ apply trans_xx | apply exec_x ].
Qed.

Fixpoint a_updates (e : list configuration) : list nat :=
  match e with
  | nil => nil
  | a n :: e' => n :: a_updates e'
  | a' n :: e' => n :: a_updates e'
  | _ :: e' => a_updates e'
  end.

Eval compute in a_updates test_conf_list.

Fixpoint b_updates (e : list configuration) : list nat :=
  match e with
  | nil => nil
  | b n  :: e' => n :: b_updates e'
  | b' n :: e' => n :: b_updates e'
  | _  :: e' => b_updates e'
  end.

Eval compute in b_updates test_conf_list.

Lemma test_conf_exists : exists e', (execution e') /\ b_updates test_conf_list = a_updates e'.
Proof.
exists (x :: x :: a 1 :: b 1 :: x :: x :: b' 5 :: a' 5 :: nil).
split; rewrite //.
repeat (
  rewrite rearrange;
  repeat rewrite app_comm_cons;
  apply exec_trans;
  auto with transitions;
  rewrite /=).
by apply exec_trans with (e := nil); [ apply trans_xx | apply exec_x ].
Qed.

Lemma rev_case : forall (e : list configuration), e = nil \/ (exists e', exists c, e = e' ++ (c :: nil)).
Proof.
elim/rev_ind => [|c e H]; first by left.
elim: H => H; first by right; rewrite H; exists nil; exists c.
right.
move: H => [ e' [ c' H]].
rewrite H {H}.
by exists (e' ++ c' :: nil); exists c.
Qed.

Lemma b_updates_comp : forall (e : list configuration) (c : configuration),
  b_updates (e ++ c :: nil) = b_updates e ++ b_updates (c :: nil).
Proof.
elim => [c|c e IH c']; first done.
case: c => [|n|n|n|n]; case: c' => [|n0|n0|n0|n0]; (try rewrite /= IH -app_nil_end //=); (try rewrite -IH //=); (try rewrite /= IH //=).
Qed.

Lemma a_updates_comp : forall (e : list configuration) (c : configuration),
  a_updates (e ++ c :: nil) = a_updates e ++ a_updates (c :: nil).
Proof.
elim => [c|c e IH c']; first done.
case: c => [|n|n|n|n]; case: c' => [|n0|n0|n0|n0]; (try rewrite /= IH -app_nil_end /=; try done); (try rewrite -IH /=; try done); (try rewrite /= IH; try done).
Qed.

Lemma coalesce_tail : forall (e : list configuration) (c c' : configuration),
  (e ++ c :: nil) ++ c' :: nil = e ++ c :: c' :: nil.
Proof. by move => e c c'; rewrite -ass_app -app_comm_cons. Qed.

Lemma coalesce_tail_long : forall (e : list configuration) (c c' c'' : configuration),
  (e ++ c :: c' :: nil) ++ c'' :: nil = e ++ c :: c' :: c'' :: nil.
Proof. by move => e c c' c''; rewrite -ass_app -app_comm_cons. Qed.

Lemma coalesce_long_tail : forall (e : list configuration) (c c' c'' : configuration),
  (e ++ c :: nil) ++ c' :: c'' :: nil = e ++ c :: c' :: c'' :: nil.
Proof. by move => e c c' c''; rewrite -ass_app -app_comm_cons. Qed.

Lemma exists_exec_n_remain : forall `(execution e) `(execution e') (n : nat),
  b_updates e = a_updates e' -> exists e0 : list configuration, execution e0 /\
    b_updates e ++ n :: nil = a_updates e0.
Proof.
move => e execution0 e' H n H0.
pose proof rev_case e' as H1.
elim: H1 => H1; first by subst; exists (a n :: nil); split; [ apply exec_a | rewrite H0 ].
elim: H1 => e0 H1; elim: H1.
case => [|n'|n'|n'|n'] H1; rewrite H1 {H1 e'} in H H0.
- exists (e0 ++ x :: a n :: nil).
  split; first by apply exec_trans; [ apply trans_xa | done ].
  by rewrite H0 -coalesce_tail 3!a_updates_comp.
- exists (e0 ++ a n' :: b n' :: a n :: nil); split.
  * rewrite -coalesce_long_tail.
    apply exec_trans; first by apply trans_ba.
    by rewrite coalesce_tail; apply exec_trans; first by apply trans_ab.
  * by rewrite -coalesce_tail_long -coalesce_tail 2!a_updates_comp H0 -app_nil_end.
- exists (e0 ++ a' n' :: a n :: nil).
  split; first by apply exec_trans; [ apply trans_a'a | done ].
  by rewrite -coalesce_tail a_updates_comp H0.
- exists (e0 ++ b n' :: a n :: nil).
  split; first by apply exec_trans; [ apply trans_ba | done ].
  by rewrite -coalesce_tail a_updates_comp H0.
- exists (e0 ++ a n :: nil).
  rewrite a_updates_comp -app_nil_end in H0.
  inversion H as [H1|n0 H1|H1|c c' H1 e' H2 H3].
  * by contradict H1; apply app_cons_not_nil.
  * change (a n0 :: nil) with (nil ++ a n0 :: nil) in H1.
    apply app_inj_tail in H1.
    by elim: H1 => H1 H2.
  * change (x :: nil) with (nil ++ x :: nil) in H1.
    apply app_inj_tail in H1.
    by elim: H1 => H1 H2.
  * rewrite -coalesce_tail in H3.
    apply app_inj_tail in H3.
    elim: H3 => H3 H4.
    rewrite H3 in H2.
    rewrite H4 {H4 c'} in H1.
    split; last by rewrite a_updates_comp H0.
    move: H1 H3.
    case: c => [|n0|n0|n0|n0] H1 H3.
    + rewrite -H3 coalesce_tail.
      by apply exec_trans; [ apply trans_xa | rewrite -H3 in H2 ].
    + by inversion H1.
    + rewrite -H3 coalesce_tail.
      by apply exec_trans; [ apply trans_a'a | rewrite H3 ].
    + rewrite -H3 coalesce_tail.
      by apply exec_trans; [ apply trans_ba | rewrite H3 ].
    + by inversion H1.
Qed.

Theorem exists_exec_with_eq_bs : forall `(execution e),
  exists e', (execution e') /\ b_updates e = a_updates e'.
Proof.
elim/rev_ind => [H|c e IH H]; first by exists nil; split; rewrite //; apply exec_nil.
inversion H as [H0|n H0|H0|c' c0 H0 e' H1 H2].
- by apply app_cons_not_nil in H0.
- by exists nil; split; rewrite //; apply exec_nil.
- by exists (x :: nil); split; rewrite //; apply exec_x.
- rewrite -coalesce_tail in H2.
  apply app_inj_tail in H2.
  move: H2 => [H2 [H3 ] ].
  move: H IH H0 H1; rewrite -coalesce_tail H2 H3 {H2 H3 c0 e'} => H IH H0 H1.
  pose proof H1 as H2.
  apply IH in H1.
  elim: H1 => e' H1 {IH}.
  elim: H1 => H1 H3.
  move: H H0.
  case: c => [|n|n|n|n] H H0.
  * by exists e'; split; rewrite // b_updates_comp H3 -app_nil_end.
  * by exists e'; split; rewrite // b_updates_comp H3 -app_nil_end.
  * by exists e'; split; rewrite // b_updates_comp H3 -app_nil_end.
  * by rewrite b_updates_comp; apply (exists_exec_n_remain H2 H1).
  * by rewrite b_updates_comp; apply (exists_exec_n_remain H2 H1).
Qed.

Lemma list_neq_length (A: Set) : forall l l': list A, length l <> length l' -> l <> l'.
intros.
contradict H.
subst.
reflexivity.
Qed.

Lemma sub_execution : forall `(execution (e ++ c :: nil)), execution e.
(* behöver ej induktion *)
destruct e using rev_ind; intros.
apply exec_nil.
inversion execution0.
contradict H0; apply app_cons_not_nil.
contradict H0.
apply list_neq_length.
rewrite app_length.
rewrite app_length.
simpl.
omega.
contradict H0.
apply list_neq_length.
rewrite app_length.
rewrite app_length.
simpl; omega.
rewrite -coalesce_tail in H0.
apply app_inj_tail in H0.
elim H0; intros.
apply app_inj_tail in H.
elim H; intros.
subst.
assumption.
Qed.

Lemma exec_impl_trans : forall `(execution (e ++ c :: c' :: nil)), trans c c'.
intros.
inversion execution0;
  try (contradict H0; apply list_neq_length; simpl; rewrite app_length; simpl; omega).
rewrite -2!coalesce_tail in H0.
apply app_inj_tail in H0; elim H0; intros.
apply app_inj_tail in H; elim H; intros.
subst.
assumption.
Qed.

Lemma exec_tail_cases : forall `(execution (e ++ c :: nil)),
  (exists n, c = a  n /\ (b_updates (e ++ c :: nil)) ++ n :: nil = a_updates (e ++ c :: nil)) \/
  (exists n, c = b  n /\ b_updates (e ++ c :: nil) = a_updates (e ++ c :: nil)) \/
  (exists n, c = b' n /\ b_updates (e ++ c :: nil) = (a_updates e) ++ n :: nil) \/
  (exists n, c = a' n /\ b_updates (e ++ c :: nil) = (a_updates e) ++ n :: nil) \/
  (c = x /\ b_updates (e ++ c :: nil) = a_updates (e ++ c :: nil)).
destruct e using rev_ind; intros.
destruct c.
right; right; right; right.
split; reflexivity.
left.
exists n.
split; reflexivity.
right; right; right; left.
simpl in execution0.
inversion execution0.
apply app_eq_unit in H0.
elim H0; intros.
elim H; intros.
inversion H2.
elim H; intros.
inversion H2.
simpl in execution0.
inversion execution0.
apply app_eq_unit in H0.
elim H0; intros.
elim H; intros.
inversion H2.
elim H; intros.
inversion H2.
simpl in execution0.
inversion execution0.
apply app_eq_unit in H0.
elim H0; intros.
elim H; intros.
inversion H2.
elim H; intros.
inversion H2.

(* inductive case *)
pose proof (IHe x0 (sub_execution execution0)).
clear IHe.
rewrite coalesce_tail in execution0.
apply exec_impl_trans in execution0.
inversion execution0; subst.

(* case x x *)
right; right; right; right.
split.
reflexivity.
move: H => [H | [ H | [ H | [H | H]]]]; try by (elim: H => n H; elim: H).
elim: H => H_eq H.
rewrite b_updates_comp; rewrite a_updates_comp.
rewrite H.
reflexivity.

(* case x a *)
left.
exists n.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
rewrite b_updates_comp a_updates_comp.
rewrite H0.
rewrite -app_nil_end.
reflexivity.

(* case x b' *)
right; right; left.
exists n.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
rewrite b_updates_comp a_updates_comp.
rewrite H0.
rewrite a_updates_comp.
reflexivity.

(* case a b *)
right; left.
exists n.
split; first by reflexivity.
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
inversion H; subst.
rewrite a_updates_comp.
rewrite -H0.
simpl.
rewrite b_updates_comp.
auto with datatypes.

elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. discriminate.

(* case a x *)
right; right; right; right.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
inversion H; subst.
rewrite a_updates_comp b_updates_comp.
rewrite H0.
rewrite a_updates_comp.
reflexivity.
elim H; clear H; intros H; discriminate.

(* case a' a *)
left.
exists m.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
inversion H; subst.
rewrite a_updates_comp.
rewrite a_updates_comp.
rewrite -H0.
rewrite b_updates_comp.
rewrite -app_nil_end.
reflexivity.
elim H; clear H; intros H; discriminate.

(* case a' b' *)
right; right; left.
exists m.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
inversion H; subst.
rewrite a_updates_comp.
rewrite -H0.
rewrite b_updates_comp.
reflexivity.
elim H; clear H; intros H; discriminate.

(* case b x *)
right; right; right; right.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
inversion H; subst.
rewrite a_updates_comp b_updates_comp.
rewrite -H0.
rewrite b_updates_comp.
reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros H; discriminate.

(* case b a *)
left.
exists m.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
inversion H; subst.
rewrite a_updates_comp b_updates_comp.
rewrite -H0.
rewrite b_updates_comp.
rewrite -app_nil_end.
reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros H; discriminate.

(* case b b' *)
right; right; left.
exists m.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
inversion H; subst.
rewrite b_updates_comp.
rewrite -H0.
rewrite b_updates_comp.
reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros H; discriminate.

(* case b' a' *)
right; right; right; left.
exists n.
split; first by reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
inversion H; subst.
rewrite b_updates_comp a_updates_comp.
simpl.
rewrite -2!app_nil_end.
rewrite -H0.
reflexivity.
elim: H => H. elim H; clear H; intros n' H; elim H; clear H; intros H_disc; discriminate.
elim H; clear H; intros H; discriminate.
Qed.

  Lemma list_neq_length_alt (A: Set) : forall l l': list A, length l <> length l' -> l <> l'.
    intros.
    contradict H.
    subst.
    reflexivity.
  Qed.

Theorem exists_exec_with_eq_bs_2 : forall `(execution e), exists e', (execution e') /\ b_updates e = a_updates e'.
intros.
pose proof (rev_case e) as H_ecase.
elim H_ecase; clear H_ecase; intros; subst.
exists nil; split; [ apply exec_nil | reflexivity ].
elim H; clear H; intros e0 H.
elim H; clear H; intros c H.
subst.
pose proof (exec_tail_cases execution0).
elim H; clear H; intros.
(* FALL 1 *)
exists e0.
split.
apply sub_execution in execution0; assumption.
elim H; clear H; intros.
elim H; clear H; intros.
subst.
assert (forall l, a_updates (l ++ a x0 :: nil) = (a_updates l) ++ x0 :: nil).
  induction l.
  reflexivity.
  simpl.
  rewrite IHl.
  destruct a0; reflexivity.
rewrite H in H0.
apply app_inj_tail in H0.
elim H0; intros.
assumption.

(* FALL 2 *)
elim H; clear H; intros.
exists (e0 ++ c :: nil).
split.
assumption.
elim H; clear H; intros.
elim H; clear H; intros.
assumption.

(* FALL 3 *)
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
subst.
exists ((e0 ++ b' x0 :: nil) ++ (a' x0 :: nil)).
split.
rewrite app_ass.
simpl.
apply exec_trans.
apply trans_b'a'.
assumption.
rewrite H0.
rewrite a_updates_comp.
simpl.
rewrite a_updates_comp.
simpl.
rewrite -app_nil_end.
reflexivity.
(* FALL 4 *)
elim H; clear H; intros.
elim H; clear H; intros.
elim H; clear H; intros.
exists (e0 ++ c :: nil).
split.
assumption.
subst.
rewrite H0.
rewrite a_updates_comp.
reflexivity.
(* FALL 5 *)
elim H; clear H; intros.
exists (e0 ++ c :: nil).
split.
assumption.
assumption.
Qed.


Require Import bol.
Require Import sql.

Require Import List.
Import ListNotations.

Require Import String.
Open Scope string_scope.

(* BOL Semantics in terms of SQL *)
(* ============================= *)

Module SQLSemantics.

(* 1. Signature Semantics *)
Definition idSemantics (id: bolID): string := match id with
| fromString str => str
end.

Definition typeSemantics (tp: bolType): sqlColumnType := match tp with
| bolInt => sqlIntType
| bolString => sqlStringType
| _ => sqlUnknownType (* todo *)
end.

Definition declSemantics (decl: bolDecl): sqlDecl := match decl with
| bolIndDecl  id => sqlInsert "individuals" [(idSemantics id)]
| bolConDecl  id => sqlTableDecl (idSemantics id) [("ind", sqlStringType)]
| bolRelDecl  id => sqlTableDecl (idSemantics id) ([("sub", sqlStringType)] ++ [("obj", sqlStringType)])
| bolPropDecl id tp => sqlTableDecl (idSemantics id) ([("ind", sqlStringType)] ++ [("val", (typeSemantics tp))])
end.

Definition bolSignatureSemantics (bolSig: bolSignature): sqlSignature := map declSemantics bolSig.

(* 2. Theory Semantics *)
Definition bolIndSemantics (ind: bolInd): string := match ind with
| fromID (fromString id) => id
end.

Definition sqlDummyQuery := sqlProj sqlAllColumns (sqlTable "???").

Fixpoint bolConSemantics (bolCon: bolConcept): sqlQuery := match bolCon with
| bolAtomicCon (fromString id) => sqlProj sqlAllColumns (sqlTable id)
| bolConUnion c1 c2 => sqlUnion (bolConSemantics c1) (bolConSemantics c2)
| bolConIntersect c1 c2 => sqlIntersect (bolConSemantics c1) (bolConSemantics c2)
| bolRelDom R => sqlProj (sqlDistinct (sqlColumnList ["sub"])) (bolRelSemantics R)
| bolRelCod R => sqlProj (sqlDistinct (sqlColumnList ["obj"])) (bolRelSemantics R)
| bolConForall R c => sqlDummyQuery
| bolConExists R c => sqlDummyQuery
end

with bolRelSemantics (rel: bolRelation): sqlQuery := match rel with
| bolAtomicRel (fromString id) => sqlProj sqlAllColumns (sqlTable id)
| bolRelUnion R1 R2 => sqlUnion (bolRelSemantics R1) (bolRelSemantics R2)
| bolRelComp R1 R2 => sqlDummyQuery
| bolRelInv R => sqlProj (sqlColumnList (["obj"] ++ ["sub"])) (bolRelSemantics R)
| bolRelTrans R => sqlDummyQuery
| bolRelDiag c => sqlProj (sqlColumnList (["ind"] ++ ["ind"])) (bolConSemantics c)
end.

Definition bolPropSemantics (prop: bolProp): sqlQuery := match prop with
| bolAtomicProp (fromString id) => sqlProj sqlAllColumns id
end.

Definition bolValueSemantics (val: bolValue): sqlScalarExpression := match val with
| bolNaturalNumberValue n => sqlNaturalNumber n
| bolBoolValue true => sqlTrue
| bolBoolValue false => sqlFalse
end.

Definition formulaSemantics (formula: bolFormula): sqlQuery := match formula with
| bolEq c1 c2 => let s1 := bolConSemantics c1 in let s2 := bolConSemantics c2 in
    sqlUnion (sqlExcept s1 s2) (sqlExcept s2 s1)
| bolSub c1 c2 => sqlExcept (bolConSemantics c1) (bolConSemantics c2)
| bolInRel i1 R i2 =>
    sqlSelect sqlAllColumns (bolRelSemantics R) (sqlAnd (sqlEq "sub" (bolIndSemantics i1)) (sqlEq "obj" (bolIndSemantics i2)))
| bolIsA ind c => sqlSelect sqlAllColumns (bolConSemantics c) (sqlEq "ind" (bolIndSemantics ind))
| bolHasPropValue i P v => sqlSelect sqlAllColumns (bolPropSemantics P) (sqlAnd (sqlEq "ind" (bolIndSemantics i)) (sqlEq "val" (bolValueSemantics v)))
end.

Definition bolTheorySemantics (bolThy: bolTheory): sqlTheory := map formulaSemantics bolThy.

End SQLSemantics.

(* 3. Overall Semantics *)
Definition sqlSemantics (bolOntology: bolOntology): sqlSystem := match bolOntology with
| (bolSig, bolTheory) => (SQLSemantics.bolSignatureSemantics bolSig, SQLSemantics.bolTheorySemantics bolTheory)
end.


From iris.base_logic.lib Require Import invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Import notation proofmode.
From iris_examples.concurrent_stacks Require Import specs.
Set Default Proof Using "Type".

(** Stack 1: No helping, bag spec. *)

Definition new_stack : val := λ: "_", ref NONEV.
Definition push : val :=
  rec: "push" "s" "v" :=
    let: "tail" := ! "s" in
    let: "new" := SOME (ref ("v", "tail")) in
    if: CAS "s" "tail" "new" then #() else "push" "s" "v".
Definition pop : val :=
  rec: "pop" "s" :=
    match: !"s" with
      NONE => NONEV
    | SOME "l" =>
      let: "pair" := !"l" in
      if: CAS "s" (SOME "l") (Snd "pair")
      then SOME (Fst "pair")
      else "pop" "s"
    end.

Section stacks.
  Context `{!heapG Σ} (N : namespace).
  Implicit Types l : loc.

  Local Notation "l ↦{-} v" := (∃ q, l ↦{q} v)%I
    (at level 20, format "l  ↦{-}  v") : bi_scope.

  Lemma partial_mapsto_duplicable l v :
    l ↦{-} v -∗ l ↦{-} v ∗ l ↦{-} v.
  Proof.
    iIntros "H"; iDestruct "H" as (?) "[Hl Hl']"; iSplitL "Hl"; eauto.
  Qed.

  Definition oloc_to_val (ol: option loc) : val :=
    match ol with
    | None => NONEV
    | Some loc => SOMEV (#loc)
    end.
  Local Instance oloc_to_val_inj : Inj (=) (=) oloc_to_val.
  Proof. intros [|][|]; simpl; congruence. Qed.

  Definition is_list_pre (P : val → iProp Σ) (F : option loc -d> iPropO Σ) :
     option loc -d> iPropO Σ := λ v, match v with
     | None => True
     | Some l => ∃ (h : val) (t : option loc), l ↦{-} (h, oloc_to_val t)%V ∗ P h ∗ ▷ F t
     end%I.

  Local Instance is_list_contr (P : val → iProp Σ) : Contractive (is_list_pre P).
  Proof.
    rewrite /is_list_pre => n f f' Hf v.
    repeat (f_contractive || f_equiv).
    apply Hf.
  Qed.

  Definition is_list_def (P : val -> iProp Σ) := fixpoint (is_list_pre P).
  Definition is_list_aux P : seal (@is_list_def P). by eexists. Qed.
  Definition is_list P := unseal (is_list_aux P).
  Definition is_list_eq P : @is_list P = @is_list_def P := seal_eq (is_list_aux P).

  Lemma is_list_unfold (P : val → iProp Σ) v :
    is_list P v ⊣⊢ is_list_pre P (is_list P) v.
  Proof.
    rewrite is_list_eq. apply (fixpoint_unfold (is_list_pre P)).
  Qed.

  Lemma is_list_dup (P : val → iProp Σ) v :
    is_list P v -∗ is_list P v ∗ match v with
      | None => True
      | Some l => ∃ h t, l ↦{-} (h, oloc_to_val t)%V
      end.
  Proof.
    iIntros "Hstack". iDestruct (is_list_unfold with "Hstack") as "Hstack".
    destruct v as [l|].
    - iDestruct "Hstack" as (h t) "(Hl & Hlist)".
      iDestruct (partial_mapsto_duplicable with "Hl") as "[Hl1 Hl2]".
      rewrite (is_list_unfold _ (Some _)); iSplitR "Hl2"; iExists _, _; by iFrame.
    - rewrite is_list_unfold; iSplitR; eauto.
  Qed.

  Definition stack_inv P v :=
    (∃ l ol', ⌜v = #l⌝ ∗ l ↦ oloc_to_val ol' ∗ is_list P ol')%I.

  Definition is_stack (P : val → iProp Σ) v :=
    inv N (stack_inv P v).

  Theorem new_stack_spec P :
    {{{ True }}} new_stack #() {{{ s, RET s; is_stack P s }}}.
  Proof.
    iIntros (ϕ) "_ Hpost".
    iApply wp_fupd.
    wp_lam.
    wp_alloc ℓ as "Hl".
    iMod (inv_alloc N ⊤ (stack_inv P #ℓ) with "[Hl]") as "Hinv".
    { iNext; iExists ℓ, None; iFrame;
      by iSplit; last (iApply is_list_unfold). }
    by iApply "Hpost".
  Qed.

  Theorem push_spec P s v :
    {{{ is_stack P s ∗ P v }}} push s v {{{ RET #(); True }}}.
  Proof.
    iIntros (Φ) "[#Hstack HP] HΦ".
    iLöb as "IH".
    wp_lam. wp_let. wp_bind (Load _).
    iInv N as (ℓ v') "(>% & Hl & Hlist)" "Hclose"; subst.
    wp_load.
    iMod ("Hclose" with "[Hl Hlist]") as "_".
    { iNext; iExists _, _; by iFrame. }
    iModIntro. wp_let. wp_alloc ℓ' as "Hl'". wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as (ℓ'' v'') "(>% & >Hl & Hlist)" "Hclose"; simplify_eq.
    destruct (decide (v' = v'')) as [->|Hne].
    - wp_cmpxchg_suc. { destruct v''; left; done. }
      iMod ("Hclose" with "[HP Hl Hl' Hlist]") as "_".
      { iNext; iExists _, (Some ℓ'); iFrame; iSplit; first done;
        rewrite (is_list_unfold _ (Some _)). iExists _, _; iFrame; eauto. }
      iModIntro.
      wp_pures.
      by iApply "HΦ".
    - wp_cmpxchg_fail.
      { destruct v', v''; simpl; congruence. }
      { destruct v''; left; done. }
      iMod ("Hclose" with "[Hl Hlist]") as "_".
      { iNext; iExists _, _; by iFrame. }
      iModIntro.
      wp_pures.
      iApply ("IH" with "HP HΦ").
  Qed.

  Theorem pop_spec P s :
    {{{ is_stack P s }}} pop s {{{ ov, RET ov; ⌜ov = NONEV⌝ ∨ ∃ v, ⌜ov = SOMEV v⌝ ∗ P v }}}.
  Proof.
    iIntros (Φ) "#Hstack HΦ".
    iLöb as "IH".
    wp_lam. wp_bind (Load _).
    iInv N as (ℓ v') "(>% & Hl & Hlist)" "Hclose"; subst.
    iDestruct (is_list_dup with "Hlist") as "[Hlist Hlist2]".
    wp_load.
    iMod ("Hclose" with "[Hl Hlist]") as "_".
    { iNext; iExists _, _; by iFrame. }
    iModIntro.
    destruct v' as [l|]; last first.
    - wp_match.
      iApply "HΦ"; by iLeft.
    - wp_match. wp_bind (Load _).
      iInv N as (ℓ' v') "(>% & Hl' & Hlist)" "Hclose". simplify_eq.
      iDestruct "Hlist2" as (???) "Hl".
      wp_load.
      iMod ("Hclose" with "[Hl' Hlist]") as "_".
      { iNext; iExists _, _; by iFrame. }
      iModIntro.
      wp_pures. wp_bind (CmpXchg _ _ _).
      iInv N as (ℓ'' v'') "(>% & Hl' & Hlist)" "Hclose". simplify_eq.
      destruct (decide (v'' = (Some l))) as [-> |].
      * rewrite is_list_unfold.
        iDestruct "Hlist" as (h' t') "(Hl'' & HP & Hlist)".
        iDestruct "Hl''" as (q') "Hl''".
        simpl.
        wp_cmpxchg_suc.
        iDestruct (mapsto_agree with "Hl'' Hl") as %[= <- <-%oloc_to_val_inj].
        iMod ("Hclose" with "[Hl' Hlist]") as "_".
        { iNext; iExists ℓ'', _; by iFrame. }
        iModIntro.
        wp_pures.
        iApply ("HΦ" with "[HP]"); iRight; iExists _; by iFrame.
      * wp_cmpxchg_fail. { destruct v''; simpl; congruence. }
        iMod ("Hclose" with "[Hl' Hlist]") as "_".
        { iNext; iExists ℓ'', _; by iFrame. }
        iModIntro.
        wp_pures.
        iApply ("IH" with "HΦ").
  Qed.
End stacks.

Program Definition spec {Σ} N `{heapG Σ} : concurrent_bag Σ :=
  {| is_bag := is_stack N; new_bag := new_stack; bag_push := push; bag_pop := pop |} .
Solve Obligations of spec with eauto using pop_spec, push_spec, new_stack_spec.


(** * Chapter 10 - Type Safety for F-Sub *)

(** ** Part 1 : System F *)

Require Export Coq.Lists.List.
Require Import Coq.Program.Equality.
Require Import core fintype.
Import ScopedNotations.
From Chapter10 Require Export sysf.
Require Import Coq.Program.Tactics.

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

Ltac autorevert x :=
  try (match goal with
    | [y : ?Y |- ?claim] =>
      try (match x with y => idtac end; fail 1);
        match goal with [z : _ |- _] =>
          match claim with context[z] =>
            first
              [ match Y with context[z] => revert y; autorevert x end
              | match y with z => revert y; autorevert x end]
          end
        end
       end).

Definition ctx n := fin n -> ty n.

Reserved Notation "'SUB' Delta |- A <: B"
         (at level 68, A at level 99, no associativity).

(** *** Properties of Subtyping *)
Open Scope fscope.

Inductive sub {n} (Delta : ctx n) : ty n -> ty n -> Prop :=
| SA_top A :
    SUB Delta |- A <: top
| SA_Refl x :
    SUB Delta |- var_ty x <: var_ty x
| SA_Trans x  B :
     SUB Delta |- (Delta x) <: B ->  SUB Delta |- var_ty x <: B
| SA_arrow A1 A2 B1 B2 :
    SUB Delta |- B1 <: A1 -> SUB Delta |- A2 <: B2 ->
    SUB Delta |- arr A1 A2 <: arr B1 B2
| SA_all (A1: ty n) (A2: ty (S n)) B1 B2 :
    SUB Delta |- B1 <: A1 -> @sub (S n) ((B1 .: Delta) >> ⟨↑⟩) A2 B2 ->
    SUB Delta |- all A1 A2 <: all B1 B2
where "'SUB' Delta |- A <: B" := (sub Delta A B).

Hint Constructors sub.

Require Import Setoid Morphisms.

(* a.d. we prove this morphism for asimpl *)
Instance sub_morphism {n}:
  Proper (pointwise_relation _ eq ==> eq ==> eq ==> Basics.impl) (@sub n).
Proof.
  intros Gamma Gamma' HGamma T T' -> t t' ->.
  intros H. induction H in Gamma', HGamma |- *.
  - constructor.
  - constructor.
  - constructor. rewrite <- HGamma. apply IHsub. apply HGamma.
  - constructor.
    apply IHsub1, HGamma.
    apply IHsub2, HGamma.
  - constructor.
    apply IHsub1, HGamma.
    apply IHsub2.
    intros [|]. cbn. rewrite HGamma. reflexivity.
    cbn. reflexivity.
Qed.

Lemma sub_refl n (Delta: ctx n) A : SUB Delta |- A <: A.
Proof. revert Delta. induction A; intuition; constructor; eauto. Qed.

Lemma sub_weak m n (Delta1: ctx m) (Delta2: ctx n) A1 A2 A1' A2' (xi: fin m -> fin n) :
  SUB Delta1 |- A1 <: A2 ->
 (forall x, (Delta1 x)⟨xi⟩ = Delta2 (xi x)) ->
  A1' = A1⟨xi⟩ -> A2' = A2⟨xi⟩ ->
  SUB Delta2 |- A1' <: A2' .
Proof.
  intros H. autorevert H. induction H; intros; subst; asimpl; econstructor; eauto.
  - eapply IHsub2; try reflexivity.
    auto_case.
    unfold funcomp.
    rewrite <- H1. now asimpl.
    (* DONE auto_case should call asimpl on this goal. and asimpl directly solves this. so why is it still here?
     pointwise version solves it again *)
Qed.

Lemma sub_weak1 n (Delta : ctx n) A A' B B' C :
  SUB Delta |- A <: B ->  A' = A⟨↑⟩ ->  B' = B⟨↑⟩ -> SUB ((C .: Delta) >> ⟨↑⟩) |- A' <: B'.
Proof. intros. eapply sub_weak;  eauto. intros x. now asimpl. Qed.

Definition transitivity_at {n} (B: ty n) := forall m Gamma (A : ty m) C  (xi: fin n -> fin m),
  SUB Gamma |- A <: B⟨xi⟩ -> SUB Gamma |- B⟨ xi⟩ <: C ->  SUB Gamma |- A <: C.

 Lemma transitivity_proj n (Gamma: ctx n) A B C :
  transitivity_at B ->
  SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C.
Proof. intros H. specialize (H n Gamma A C id). now asimpl in H. Qed.
Hint Resolve transitivity_proj.

Lemma transitivity_ren m n B (xi: fin m -> fin n) : transitivity_at B -> transitivity_at B⟨xi⟩.
Proof. unfold transitivity_at. intros. apply H with (xi:=funcomp xi0 xi); asimpl in H0; asimpl in H1; eauto.
Qed.

Lemma sub_narrow n (Delta Delta': ctx n) A C :
  (forall x, SUB Delta' |- Delta' x <: Delta x) ->
  (forall x, Delta x = Delta' x \/ transitivity_at (Delta x)) ->
  SUB Delta |- A <: C -> SUB Delta' |- A <: C.
Proof with asimpl;eauto.
  intros H H' HH. autorevert HH. induction HH; intros; eauto.
  - destruct (H' x); eauto. rewrite H0 in *. eauto.
  - constructor; eauto.
    eapply IHHH2.
    + auto_case; try apply sub_refl.
      eapply sub_weak; try reflexivity. eapply H. now asimpl.
    + auto_case. destruct (H' f);  eauto using transitivity_ren.
      rewrite H0. now left.
Qed.

Corollary sub_trans' n (B : ty n): transitivity_at B.
Proof with asimpl;eauto.
  unfold transitivity_at.
  autorevert B. induction B; intros...
  - depind H...
  - depind H... depind H0...
  - depind H... depind H1...
  - depind H... depind H1...
    econstructor... clear IHsub0 IHsub3 IHsub1 IHsub2.
    eapply IHB2 with (xi:=upRen_ty_ty xi).
    + asimpl. eapply sub_narrow; try eapply H0.
      * auto_case. apply sub_refl.
        eapply sub_weak with (xi := ↑); try reflexivity; eauto.
      * intros [x|]; try cbn; eauto. right. apply transitivity_ren. apply transitivity_ren. eauto.
    + asimpl in H1_0. auto.
Qed.

Corollary sub_trans n (Delta  : ctx n) A B C:
  SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C.
Proof. eauto using sub_trans'. Qed.

Lemma sub_substitution m m' (sigma : fin m -> ty m') Delta (Delta': ctx m') A B:
   (forall x ,  SUB Delta' |- sigma x <: (Delta x)[sigma] ) ->
   SUB Delta |- A <: B -> SUB Delta' |- subst_ty sigma A <: subst_ty sigma B.
Proof.
    intros eq H. autorevert H. induction H; try now (econstructor; eauto).
  - intros. asimpl. eapply sub_refl.
  - intros. asimpl. eauto. cbn in *. eauto using sub_trans.
  - intros. asimpl. econstructor; eauto.
    asimpl. eapply IHsub2.
    auto_case; asimpl; cbn; eauto using sub_refl.
    eapply sub_weak; try reflexivity. eapply eq.
    all: now asimpl.
Qed.

(** *** Type Safety *)

Inductive value {m n}: tm m n -> Prop :=
| Value_abs A s : value(abs A s)
| Value_tabs A s : value(tabs A s).

Reserved Notation "'TY' Delta ; Gamma |- A : B"
  (at level 68, A at level 99, no associativity,
   format "'TY'  Delta ; Gamma  |-  A  :  B").

Definition dctx m n := fin m -> ty n.

Inductive has_ty {m n} (Delta : ctx m) (Gamma : dctx  n m) : tm m n -> ty m -> Prop :=
| T_Var  x :
    TY Delta;Gamma |- var_tm x : (Gamma x)
 | T_abs (A: ty m) B (s: tm m (S n)):
    @has_ty m (S n) Delta (A .: Gamma) s B   ->
    TY Delta;Gamma |- abs A s : arr A B
| T_app A B s t:
    TY Delta;Gamma |- s : arr A B   ->   TY Delta;Gamma |- t : A   ->
    TY Delta;Gamma |- app s t : B
| T_tabs A B s :
    @has_ty (S m) n ((A .: Delta) >> ⟨↑⟩) (Gamma >> ⟨↑⟩) s B ->
    TY Delta;Gamma |- tabs A s : all A B
| T_Tapp A B A' s B' :
    TY Delta;Gamma |- s : all A B ->
    SUB Delta |- A' <: A -> B' = subst_ty (A'..) B ->
    TY Delta;Gamma |- tapp s A' : B'
 | T_Sub A B s :
    TY Delta;Gamma |- s : A   ->   SUB Delta |- A <: B   ->
    TY Delta;Gamma |- s : B
where "'TY' Delta ; Gamma |- s : A" := (has_ty Delta Gamma s A).

Hint Constructors has_ty.

(* a.d. we prove this morphism for asimpl *)
Instance has_ty_morphism {m n} :
  Proper (pointwise_relation _ eq ==> pointwise_relation _ eq ==> eq ==> eq ==> Basics.impl) (@has_ty m n).
Proof.
  intros Delta Delta' HDelta Gamma Gamma' HGamma T T' -> t t' -> H.
  induction H in Delta', Gamma', HDelta, HGamma |- *.
  - rewrite HGamma. constructor.
  - constructor.
    apply IHhas_ty. assumption.
    intros [|]; cbn. apply HGamma. reflexivity.
  - econstructor. apply IHhas_ty1; assumption.
    apply IHhas_ty2; assumption.
  - constructor. apply IHhas_ty.
    intros [|]; cbn. rewrite HDelta. 1, 2: reflexivity.
    intros x. unfold funcomp. rewrite HGamma. reflexivity.
  - econstructor. apply IHhas_ty; assumption.
    setoid_rewrite <- HDelta. assumption.
    assumption.
  - econstructor. 2: setoid_rewrite <- HDelta; apply H0.
    apply IHhas_ty; assumption.
Qed.

Reserved Notation "'EV' s => t"
  (at level 68, s at level 80, no associativity, format "'EV'   s  =>  t").
Inductive eval {m n} : tm m n -> tm m n -> Prop :=
| E_appabs A s t : EV app (abs A s) t => s[ids; t..]
| E_Tapptabs A s B : EV tapp (tabs A s) B => s[B..; ids]
| E_appFun s s' t :
     EV s => s' ->
     EV app s t => app s' t
| E_appArg s s' v:
     EV s => s' -> value v ->
     EV app v s => app v s'
| E_TyFun s s' A :
     EV s => s' ->
     EV tapp s A => tapp s' A
where "'EV' s => t" := (eval s t).

(* a.d. we prove this morphism for asimpl *)
Instance eval_morphism {m n}:
  Proper (eq ==> eq ==> Basics.impl) (@eval m n).
Proof.
  intros s s' -> t t' ->. unfold Basics.impl. trivial.
Qed.

(** **** Progress *)

Definition empty {X} : fin 0 -> X :=
  fun x => match x with end.

Lemma can_form_arr {s: tm 0 0} {A B}:
  TY empty;empty |- s : arr A B -> value s -> exists C t, s = abs C t.
Proof.
  intros H.
  depind H; intros; eauto.
  all: try now (try destruct x0; try inversion H1).
  inversion H0; subst; eauto. inversion x.
Qed.

Lemma can_form_all {s A B}:
  TY empty;empty |- s : all A B -> value s -> exists C t, s = tabs C t.
Proof.
  intros H.
  depind H; intros; eauto.
  all: try now (try destruct x0; try inversion H1).
  inv H0; subst; eauto. inversion x.
Qed.

Theorem ev_progress s A:
  TY empty;empty |- s : A -> value s \/ exists t,  EV s => t.
Proof.
  intros. depind H; eauto; try (left; constructor).
  - inversion x.
  - right. edestruct IHhas_ty1 as [? | [? ?]]; try reflexivity.
    + edestruct (can_form_arr H H1) as [? [? ?]]; subst.
      eexists. econstructor.
    + eexists. econstructor. eauto.
  - right. edestruct IHhas_ty as [? | [? ?]]; try reflexivity.
    + edestruct (can_form_all H H1) as [? [? ?]]; subst. eexists. econstructor.
    + eexists. econstructor. eauto.
Qed.

(** **** Preservation *)

Lemma context_renaming_lemma m m' n n' (Delta: ctx m') (Gamma: dctx n' m')                                                   (s: tm m n) A (sigma : fin m -> fin m') (tau: fin n -> fin n') Delta' (Gamma' : dctx n m):
  (forall x, (Delta' x)⟨sigma⟩ = Delta (sigma x)) ->
  (forall (x: fin n) , (Gamma' x)⟨sigma⟩ =  (Gamma (tau x))) ->
  TY Delta'; Gamma' |- s : A -> TY Delta; Gamma |- s⟨sigma;tau⟩ : A⟨sigma⟩.
Proof.
  intros H H' ty. autorevert ty.
  induction ty; asimpl; intros; (* asimpl in *;  *)subst; try now (econstructor; eauto).
  - rewrite H0. constructor.
  - constructor. apply IHty; eauto. auto_case.
  - econstructor. apply IHty; eauto.
    + auto_case; try now asimpl.
      unfold funcomp.
      rewrite <- H. now asimpl.
    + intros. asimpl.
      unfold funcomp.
      rewrite <- H'. now asimpl.
  - eapply T_Tapp with (A0 := A⟨sigma⟩) (B0:=ren_ty (upRen_ty_ty sigma) B).
    asimpl in IHty.
    eapply IHty; eauto.
    eapply sub_weak; eauto.
    now asimpl.
  - econstructor. eauto.
    eapply sub_weak; eauto.
Qed.

Lemma context_morphism_lemma m m' n n' (Delta: ctx m) (Delta': ctx m') (Gamma: dctx n m) (s: tm m n) A (sigma : fin m -> ty m') (tau: fin n -> tm m' n') (Gamma' : dctx n' m'):
  (forall x, SUB Delta' |- sigma x <: (Delta x)[sigma]) ->
  (forall (x: fin n) ,  TY Delta'; Gamma' |- tau x : subst_ty sigma (Gamma x)) ->
  TY Delta; Gamma |- s : A -> TY Delta'; Gamma' |- s[sigma;tau] : A[sigma].
Proof.
  intros eq1 eq2 ty. autorevert ty.
  induction ty; intros; subst; asimpl; try now (econstructor; eauto).
  - eapply eq2.
  - constructor. eapply IHty; eauto.
    auto_case; asimpl.
    +  assert (subst_ty sigma (Gamma f)  = ((Gamma f)[sigma]⟨id⟩)) as -> by (now asimpl) .
       eapply context_renaming_lemma; eauto; now asimpl.
    + econstructor.
  - constructor. eapply IHty; eauto.
    + auto_case.
      * asimpl.
        specialize (eq1 f).
        eapply sub_weak1 with (C := A[sigma]) in eq1; eauto.  asimpl in eq1. eapply eq1.
      * asimpl. econstructor. apply sub_refl.
    + intros x. asimpl.
      assert ((Gamma x) [sigma >> ⟨↑⟩] = (Gamma x)[sigma]⟨↑⟩) by (now asimpl).
      auto_unfold in *. rewrite H.
      eapply context_renaming_lemma; eauto.
      * intros. now asimpl.
      * intros. now asimpl.
  - eapply T_Tapp with (A0 := subst_ty sigma A) (B0:=B[up_ty_ty sigma]).
    asimpl in IHty. eapply IHty; eauto.
    eapply sub_substitution; eauto.
    now asimpl.
 - econstructor.
    + eapply IHty; eauto.
    + eapply sub_substitution; eauto.
Qed.

 Lemma ty_inv_abs m n Delta Gamma A A' B C (s: tm m (S n)):
  TY Delta;Gamma |- abs A s : C   ->   SUB Delta |- C <: arr A' B   ->
  (SUB Delta |- A' <: A /\
    exists B', TY Delta; A .: Gamma |- s : B' /\ SUB Delta |- B' <: B).
Proof.
  intros H. depind H; intros.
  - inv H0. split; eauto.
  - eauto using sub_trans.
Qed.

Lemma ty_subst m n (Gamma: dctx m n) (Delta: ctx n) Delta' s A:
    (forall x, SUB Delta' |- Delta' x <: Delta x) ->
  TY Delta; Gamma |- s : A -> TY Delta'; Gamma |- s : A.
Proof.
  intros eq H. autorevert H. induction H; eauto; intros.
  - econstructor; eauto. asimpl. eapply IHhas_ty. auto_case; eauto using sub_refl.
    eapply sub_weak; try reflexivity. apply eq. intros x. now asimpl.
  - econstructor; eauto.
    replace A with (A[ids]) by (now asimpl). replace A' with (A'[ids]) by (now asimpl).
    eapply sub_substitution; eauto. intros x.
    asimpl. econstructor. eauto.
  - econstructor; eauto. eapply sub_substitution with (sigma := ids) (Delta':=Delta') in H0; eauto.
    + asimpl in H0. apply H0.
    + intros x. econstructor. asimpl. eapply eq.
Qed.

Lemma ty_inv_tabs {m n} {Delta Gamma A A' B C} (s : tm (S m) n):
  TY Delta;Gamma |- tabs A s : C   ->   SUB Delta |- C <: all A' B   ->
  (SUB Delta |- A' <: A /\ exists B',
   TY (A'.:Delta) >> ren_ty ↑; Gamma >> ren_ty ↑ |- s : B' /\ SUB (A' .: Delta) >> ren_ty ↑ |- B' <: B).
Proof.
  intros H. depind H; intros.
  - inv H0. split; eauto.
    eexists. split; eauto.
    eapply ty_subst; eauto. auto_case.
    apply sub_refl. eapply sub_weak; try reflexivity; eauto.
  - eauto using sub_trans.
Qed.

Theorem preservation m n Delta Gamma (s: tm m n) t A :
  TY Delta;Gamma |- s : A -> EV s => t ->
  TY Delta;Gamma |- t : A.
Proof.
  intros H_ty H_ev. autorevert H_ev.
  induction H_ev; intros; eauto using ty.
  all: try (now (depind H_ty; eauto)).
  - depind H_ty; [|eauto].
    + depind H_ty1; subst.
      * replace B with (B[ids]) by (now asimpl).
        eapply context_morphism_lemma; eauto.
        -- intros. asimpl. repeat constructor. apply sub_refl.
        -- intros [|]; intros; cbn; asimpl; eauto.
      * pose proof (ty_inv_abs _ _ _ _ _ _ _ _ _ H_ty1 H) as (?&?&?&?).
        eapply T_Sub; eauto.
        replace x with (x[var_ty]) by (now asimpl).
        eapply context_morphism_lemma; eauto.
        -- intros. asimpl. repeat constructor. apply sub_refl.
        -- intros [|]; intros; cbn; asimpl; eauto.
  - depind H_ty; eauto.
    + depind H_ty.
      * asimpl in H_ty.
        eapply context_morphism_lemma; try eapply H_ty; eauto.
        -- auto_case.
           ++ asimpl. constructor. apply sub_refl.
        -- intros x. asimpl. constructor.
      * pose proof (ty_inv_tabs _ H_ty H) as (?&?&?&?).
        eapply T_Sub; eauto.
        eapply context_morphism_lemma; eauto.
        -- auto_case; asimpl; eauto. asimpl. constructor. apply sub_refl.
        -- intros z. unfold funcomp. asimpl. constructor.
        -- eapply sub_substitution; eauto.
           auto_case; asimpl.
           constructor. apply sub_refl.
Qed.

Print Assumptions preservation.


From SLF (* TLC *) Require Export LibCore TLCbuffer.
From SLF (* Sep *) Require Export Rules.

(*------------------------------------------------------------------------*)

(* ================================================================= *)
(** Some ltac to simplify the verification *)

(*--- to extract the existential quantifier ---*)
Ltac extexists :=
  intros; simpl;
  try apply triple_hfexists;
  try apply triple_hfexists';
  try apply triple_hbexists;
  try apply triple_hbexists';
  try apply triple_hexists.

(*--- to extract the pure fact ---*)
Ltac extpure :=
  intros; simpl;
  try apply triple_hfpure;
  try apply triple_hbpure;
  try apply triple_hpure;
  simpls;
  intros ->.

(* - combine the extraction - *)
Ltac ext :=
  try extpure; try extexists.

(*--------- Some scripts for CBS-heap entailments --------------*)
Ltac inner_femp :=
 try intros r;
 try rewrite hstar_sep;
 try rewrite hfstar_hempty_l;
 try rewrite hfstar_hempty_r;
 apply himpl_refl.

Ltac inner_bemp :=
 try intros r;
 try rewrite hstar_sep;
 try rewrite hbstar_hempty_l;
 try rewrite hbstar_hempty_r;
 apply himpl_refl.

Ltac outer_emp :=
 try intros r;
 try rewrite hstar_hempty_l';
 try rewrite hstar_hempty_r';
 apply himpl_refl.

Ltac rew_read:=
  intros v;
  rewrite hstar_assoc,hstar_sep,hfstar_hempty_l;
  apply himpl_refl;
  ext.

(*--------- Some scripts for recursive programs --------------*)
Lemma nth_listbloc_1 : forall p1 p2 p3,
(nth_default bnull (to_nat 1) (p1 :: p2 :: p3 :: nil)) = p2.
Proof.
  intros. rewrite to_nat_1,nth_default_succ,nth_default_zero. auto.
Qed.

Lemma nth_listbloc_1' : forall p1 p2,
(nth_default bnull (to_nat 1) (p1 :: p2 :: nil)) = p2.
Proof.
  intros. rewrite to_nat_1,nth_default_succ,nth_default_zero. auto.
Qed.

Lemma nth_listbloc_2 : forall p1 p2 p3,
(nth_default bnull (to_nat (1 + 1)) (p1 :: p2 :: p3 :: nil)) = p3.
Proof.
  intros. rewrite to_nat_plus; try math.
  rewrite to_nat_1. do 2 rewrite nth_default_succ. rewrite~ nth_default_zero.
Qed.

(*----- expand the recursive program  -------*)
Ltac exp_fix :=
  intros; subst; applys* triple_app_fix2; simpl;
  applys triple_let triple_fsize; ext;
  applys triple_let triple_eq; ext;
  applys triple_if; case_if*.

(*----- verify rec body until to the target block -------*)
Ltac fix_body :=
  applys triple_let triple_fget_nth_blk; ext;
  applys triple_let triple_add; ext;
  try rewrite nth_default_zero;
  try rewrite nth_listbloc_1;
  try rewrite nth_listbloc_1';
  try rewrite nth_listbloc_2.

(* ------ for read file example --------- *)
Ltac fix_read :=
  exp_fix; fix_body;
  applys triple_let;
  try applys triple_conseq_frame triple_bget.

(* ------ for map file example --------- *)
Ltac fix_map :=
  exp_fix; fix_body;
  applys triple_let;
  try applys triple_conseq_frame triple_wdmap.

Ltac fix_locate :=
  exp_fix; fix_body;
  applys triple_let;
  try applys triple_conseq_frame triple_locate.

(* ------ for remove file example --------- *)
Ltac fix_rem :=
  exp_fix; fix_body;
  applys triple_seq;
  try applys triple_conseq_frame triple_bdelete.

(* ################################## *)
Lemma eqword_refl : forall n1,
  eqword (n1,1) (n1,1) = true.
Proof. intros. unfold eqword. simpl. apply~ Z.eqb_eq. Qed.

Lemma neqword_refl : forall n1,
  neqword (n1,1) (n1,1) = false.
Proof. intros. unfold neqword. rewrite~ eqword_refl. Qed.

Lemma eqword_diff : forall n1 n2,
  n1 =? n2 = false ->
  eqword (n1,1) (n2,1) = false.
Proof. intros. unfold eqword. simpls~. Qed.

Lemma neqword_diff : forall n1 n2,
  n1 =? n2 = false ->
  neqword (n1,1) (n2,1) = true.
Proof. intros. unfold neqword. rewrite~ eqword_diff. Qed.

Lemma eqb_comm : forall n1 n2,
  (n1 =? n2) = (n2 =? n1).
Proof.
  intros. destruct (n1 =? n2) eqn:H.
  apply Z.eqb_eq in H. rewrite H.
  symmetry. apply~ Z.eqb_eq.
  symmetry. apply Bool.not_true_is_false.
  intro N.  apply Z.eqb_eq in N.
  rewrite N in H. lets : Z.eqb_eq n1 n1.
  assert (H1: n1 = n1). auto.
  apply H0 in H1. rewrite H in H1. discriminate.
Qed.

Lemma eqword_diff_2 : forall n1 n2,
  n1 =? n2 = false ->
  eqword (n2,1) (n1,1) = false.
Proof. intros. unfold eqword. simpls. rewrite~ eqb_comm. Qed.

Lemma neqword_diff_2 : forall n1 n2,
  n1 =? n2 = false ->
  neqword (n2,1) (n1,1) = true.
Proof. intros. unfold neqword. rewrite~ eqword_diff_2. Qed.

Hint Resolve eqword_refl neqword_refl eqword_diff_2 neqword_diff_2
             eqb_comm neqword_diff.

Definition diff_each_3 (n1 n2 n3:int) : Prop :=
  n1 =? n2 = false /\ n1 =? n3 = false /\ n2 =? n3 = false.

Lemma diff_3_bool : forall n1 n2 n3,
   diff_each_3 n1 n2 n3 ->
   eqword (n1,1) (n1,1) = true
/\ eqword (n2,1) (n2,1) = true
/\ eqword (n3,1) (n3,1) = true
/\ neqword (n1,1) (n2,1) = true
/\ neqword (n1,1) (n3,1) = true
/\ neqword (n2,1) (n3,1) = true
/\ neqword (n2,1) (n1,1) = true
/\ neqword (n3,1) (n1,1) = true
/\ neqword (n3,1) (n2,1) = true
/\ eqword (n1,1) (n2,1) = false
/\ eqword (n1,1) (n3,1) = false
/\ eqword (n2,1) (n3,1) = false
/\ eqword (n2,1) (n1,1) = false
/\ eqword (n3,1) (n1,1) = false
/\ eqword (n3,1) (n2,1) = false
/\ neqword (n1,1) (n1,1) = false
/\ neqword (n2,1) (n2,1) = false
/\ neqword (n3,1) (n3,1) = false.
Proof. introv. intros (H1&H2&H3). splits*. Qed.

Lemma shuffle_diff : forall (n1 n2 n3:int),
  diff_each_3 n1 n2 n3 ->
  wordshuffle ((n1,1)::(n2,1)::(n3,1)::(n1,1)::(n2,1)::nil) =
  (((n1,1)::(n1,1):: nil) :: ((n2,1)::(n2,1)::nil) ::((n3,1)::nil) ::nil).
Proof.
  intros.
  apply diff_3_bool in H
  as (H1&H2&H3&H4&H5&H6&H7&H8&H9&H10
    &H11&H12&H13&H14&H15&H16&H17&H18).
  unfold wordshuffle, shuffle, remove_duplicates.
  repeat case_if. simpl.
  repeat case_if. simpl.
  repeat case_if. simpl.
  repeat case_if. auto.
Qed.

(* $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ *)
Lemma eqiikey_refl : forall n b,
  eqiikey (n,b,1) (n,b,1) = true.
Proof. intros. unfold eqiikey, eqindex. simpl.
  apply Bool.andb_true_iff. splits*;
  apply~ Z.eqb_eq.
Qed.

Lemma neqiikey_refl : forall n b,
  neqiikey (n,b,1) (n,b,1) = false.
Proof. intros. unfold neqiikey. rewrite~ eqiikey_refl. Qed.

Lemma eqiikey_diff_n : forall n1 n2 b1 b2,
  n1 =? n2 = false ->
  eqiikey (n1,b1,1) (n2,b2,1) = false.
Proof.
  intros. unfold eqiikey,eqindex. simpl.
  apply Bool.andb_false_iff. left~.
Qed.

Lemma eqiikey_diff_b : forall n1 n2 (b1 b2:nat),
  b1 =? b2 = false ->
  eqiikey (n1,b1,1) (n2,b2,1) = false.
Proof.
  intros. unfold eqiikey,eqindex. simpl.
  apply Bool.andb_false_iff. right~.
Qed.

Lemma neqiikey_diff_n : forall n1 n2 b1 b2,
  n1 =? n2 = false ->
  neqiikey (n1,b1,1) (n2,b2,1) = true.
Proof. intros. unfold neqiikey. rewrite~ eqiikey_diff_n. Qed.

Lemma neqiikey_diff_b : forall n1 n2 (b1 b2:nat),
  b1 =? b2 = false ->
  neqiikey (n1,b1,1) (n2,b2,1) = true.
Proof. intros. unfold neqiikey. rewrite~ eqiikey_diff_b. Qed.

Lemma eqindex_comm : forall n1 n2 b1 b2,
  eqindex (n1,b1) (n2,b2) = eqindex (n2,b2) (n1,b1).
Proof.
  intros. destruct (eqindex (n1,b1) (n2,b2)) eqn:H.
  unfolds eqindex. simpls.
  apply Bool.andb_true_iff in H as (H1&H2).
  symmetry. apply Bool.andb_true_iff.
  split; rewrite~ eqb_comm.
  unfolds eqindex. simpls.
  apply Bool.andb_false_iff in H.
  destruct H; symmetry; apply Bool.andb_false_iff.
  left. rewrite~ eqb_comm.
  right. rewrite~ eqb_comm.
Qed.

Lemma eqiikey_diff_2_n : forall n1 n2 b1 b2,
  n1 =? n2 = false ->
  eqiikey (n2,b1,1) (n1,b2,1) = false.
Proof.
  intros. unfold eqiikey. simpl.
  rewrite eqindex_comm. unfold eqindex. simpls.
  apply Bool.andb_false_iff. left~.
Qed.

Lemma eqiikey_diff_2_b : forall n1 n2 (b1 b2:bloc),
  b1 =? b2 = false ->
  eqiikey (n1,b2,1) (n2,b1,1) = false.
Proof.
  intros. unfold eqiikey. simpl.
  rewrite eqindex_comm. unfold eqindex. simpls.
  apply Bool.andb_false_iff. right~.
Qed.

Lemma neqiikey_diff_2_n : forall n1 n2 b1 b2,
  n1 =? n2 = false ->
  neqiikey (n2,b1,1) (n1,b2,1) = true.
Proof. intros. unfold neqiikey. rewrite~ eqiikey_diff_2_n. Qed.

Lemma neqiikey_diff_2_b : forall n1 n2 (b1 b2:bloc),
  b1 =? b2 = false ->
  neqiikey (n1,b2,1) (n2,b1,1) = true.
Proof. intros. unfold neqiikey. rewrite~ eqiikey_diff_2_b. Qed.

Hint Resolve eqiikey_refl neqiikey_refl
eqiikey_diff_n eqiikey_diff_b neqiikey_diff_n
neqiikey_diff_b eqiikey_diff_2_n eqiikey_diff_2_b
neqiikey_diff_2_n neqiikey_diff_2_b.

Lemma diff_each_index: forall (n1 n2:int) (b1 b2:bloc),
  n1 =? n2 = false /\ b1 =? b2 = false ->
  eqiikey (n1,b1,1) (n1,b1,1) = true
/\ eqiikey (n1,b2,1) (n1,b2,1) = true
/\ eqiikey (n2,b1,1) (n2,b1,1) = true
/\ neqiikey (n1,b1,1) (n1,b2,1) = true
/\ neqiikey (n1,b1,1) (n2,b1,1) = true
/\ neqiikey (n1,b2,1) (n2,b1,1) = true
/\ neqiikey (n1,b2,1) (n1,b1,1) = true
/\ neqiikey (n2,b1,1) (n1,b1,1) = true
/\ neqiikey (n2,b1,1) (n1,b2,1) = true
/\ eqiikey (n1,b1,1) (n1,b2,1) = false
/\ eqiikey (n1,b1,1) (n2,b1,1) = false
/\ eqiikey (n1,b2,1) (n2,b1,1) = false
/\ eqiikey (n1,b2,1) (n1,b1,1) = false
/\ eqiikey (n2,b1,1) (n1,b1,1) = false
/\ eqiikey (n2,b1,1) (n1,b2,1) = false
/\ neqiikey (n1,b1,1) (n1,b1,1) = false
/\ neqiikey (n1,b2,1) (n1,b2,1) = false
/\ neqiikey (n2,b1,1) (n2,b1,1) = false.
Proof. introv. intros (H1&H2). splits*. Qed.

Lemma iishuffle_diff : forall (n1 n2:int) (b1 b2:bloc),
  n1 =? n2 = false /\ b1 =? b2 = false ->
(iishuffle ((n1, b1, 1) :: (n2, b1, 1)::
            (n1, b1, 1):: (n1, b2, 1) :: nil)) =
( ((n1, b1, 1) :: (n1, b1, 1) :: nil)::
  ((n2, b1, 1) :: nil)::
  ((n1, b2, 1) :: nil):: nil).
Proof.
  intros.
  apply diff_each_index in H as
  (H1&H2&H3&H4&H5&H6&H7&H8&H9&H10
    &H11&H12&H13&H14&H15&H16&H17&H18).
  unfold iishuffle,shuffle,remove_duplicates.
  simpl. repeat case_if.
  simpl. repeat case_if.
  simpl. repeat case_if.
  simpl. repeat case_if. auto.
Qed.

(* $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ *)
Lemma eqid_refl : forall (n c1 c2:int) (b1 b2:bloc),
  eqid (n,b1,c1) (n,b2,c2) = true.
Proof. intros. unfold eqid. simpl. apply~ Z.eqb_eq. Qed.

Lemma neqid_refl : forall (n c1 c2:int) (b1 b2:bloc),
  neqid (n,b1,c1) (n,b2,c2) = false.
Proof. intros. unfold neqid. rewrite~ eqid_refl. Qed.

Lemma eqid_diff : forall (n1 n2 c1 c2:int) (b1 b2:bloc),
  n1 =? n2 = false ->
  eqid (n1,b1,c1) (n2,b2,c2) = false.
Proof. intros. unfold eqid. simpls~. Qed.

Lemma neqid_diff : forall (n1 n2 c1 c2:int) (b1 b2:bloc),
  n1 =? n2 = false ->
  neqid (n1,b1,c1) (n2,b2,c2) = true.
Proof. intros. unfold neqid. rewrite~ eqid_diff. Qed.

Lemma eqid_diff_2 : forall (n1 n2 c1 c2:int) (b1 b2:bloc),
  n1 =? n2 = false ->
  eqid (n2,b1,c1) (n1,b2,c2) = false.
Proof. intros. unfold eqid. simpls. rewrite~ eqb_comm. Qed.

Lemma neqid_diff_2 : forall (n1 n2 c1 c2:int) (b1 b2:bloc),
  n1 =? n2 = false ->
  neqid (n2,b1,c1) (n1,b2,c2) = true.
Proof. intros. unfold neqid. rewrite~ eqid_diff_2. Qed.

Hint Resolve eqid_refl neqid_refl eqid_diff_2 neqid_diff_2
             eqb_comm neqid_diff.

Lemma diff_ind : forall (n1 n2:int) (b1 b2:bloc),
  n1 =? n2 = false /\ b1 =? b2 = false ->
   eqid (n1,b1,2) (n1,b1,2) = true
/\ eqid (n1,b1,2) (n2,b1,1) = false
/\ eqid (n1,b1,2) (n1,b2,1) = true
/\ eqid (n2,b1,1) (n2,b1,1) = true
/\ eqid (n2,b1,1) (n1,b1,2) = false
/\ eqid (n2,b1,1) (n1,b2,1) = false
/\ eqid (n1,b2,1) (n2,b1,1) = false
/\ eqid (n1,b2,1) (n1,b1,2) = true
/\ eqid (n1,b2,1) (n1,b2,1) = true
/\ neqid (n1,b1,2) (n1,b1,2) = false
/\ neqid (n1,b1,2) (n2,b1,1) = true
/\ neqid (n1,b1,2) (n1,b2,1) = false
/\ neqid (n2,b1,1) (n2,b1,1) = false
/\ neqid (n2,b1,1) (n1,b1,2) = true
/\ neqid (n2,b1,1) (n1,b2,1) = true
/\ neqid (n1,b2,1) (n2,b1,1) = true
/\ neqid (n1,b2,1) (n1,b1,2) = false
/\ neqid (n1,b2,1) (n1,b2,1) = false.
Proof. intros. splits*. Qed.

Lemma iiorgan_diff : forall (n1 n2:int) (b1 b2:bloc),
  n1 =? n2 = false /\ b1 =? b2 = false ->
iiorganize ((n1, b1, 2) :: (n2, b1, 1) :: (n1, b2, 1) :: nil) =
  ((n1, (b1, 2) :: (b2, 1) :: nil) :: (n2, (b1, 1) :: nil) :: nil).
Proof.
  intros. unfold iiorganize, idshuffle.
  unfold shuffle, remove_duplicates.
  apply diff_ind in H as
  (H1&H2&H3&H4&H5&H6&H7&H8&H9&H10
    &H11&H12&H13&H14&H15&H16&H17&H18).
  simpl. repeat case_if.
  simpl. repeat case_if.
  simpl. repeat case_if. auto.
Qed.


From Coq Require Import
     ssreflect
.

From ExtensibleCompiler.Semantics.Static Require Import
     TypeEquality
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Functor
     ProgramAlgebra
     ProofAlgebra
     Types
     UniversalProperty
.

Definition typeEqualityCorrectnessStatement
           {T} `{Functor T}
           {TypeEquality__T :
              forall {R},
                ProgramAlgebra ForTypeEquality T R (TypeEqualityResult T)}
           (tau : Fix T)
           (UP'__tau : FoldUP' tau)
  : Prop
  := forall tau',
    typeEquality tau tau' = true ->
    tau = proj1_sig tau'.

Variant ForTypeEqualityCorrectness := .

Lemma typeEqualityCorrectness
      {T} `{Functor T}
      {typeEqualityForT :
         forall R,
           ProgramAlgebra ForTypeEquality T R (TypeEqualityResult T)}
      `{PA : ! ProofAlgebra ForTypeEqualityCorrectness T
                     (sig (UniversalPropertyP typeEqualityCorrectnessStatement))}
      `{! WellFormedProofAlgebra PA}
  : forall tau, typeEqualityCorrectnessStatement (proj1_sig tau) (proj2_sig tau).
Proof.
  move => tau.
  apply (
      proj2_sig
        (Induction
           (P := UniversalPropertyP typeEqualityCorrectnessStatement)
           _
           (proj2_sig tau)
        )
    ).
Qed.


Require Import RuntimeDefinitions.
From Coq Require Import Lists.List.
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.

(* Checks if raw_enclave_ID is in the memory range for enclave_state *)
Definition contains_enclave (l: enclave_memory_range) (id: raw_enclave_ID): bool :=
  match (NatMap.find id l) with
  | Some _ => true
  | None => false
  end.
Inductive validatable_enclave_state :=
  | enclave_state_valid: enclave_state -> validatable_enclave_state
  | enclave_state_error: validatable_enclave_state.

Definition data_equality (x: data) (y: data) :=
  match x, y with
  | data_value x1, data_value y1 => x1 =? y1
  | _, _ => false
  end.

(* Enclave Creation *)
Fixpoint is_all_zeroes (mu: memory) (block: block_ID) (offset: data_offset) (block_size: nat) (current_size: nat) {struct current_size} : bool :=
  match current_size with
  | 0 => true
  | S new_size =>
    match (NatMap.find block mu) with
    | None => false
    | Some l =>
      match (NatMap.find offset l) with
      | None => false
      | Some x =>
        match x with
        | memory_value_instruction _ => false
        | memory_value_data d =>
          match d with
          | data_none => false
          | data_value v =>
            match v with
            | S _ => false
            | 0 =>
              match ((S offset) =? block_size) with
              | true => is_all_zeroes mu (S block) 0 block_size new_size
              | false => is_all_zeroes mu block (S offset) block_size new_size
              end
            end
          end
        end
      end
    end
  end.
Definition add_new_enclave_to_enclave_state (state: enclave_state) (e: raw_enclave_ID) (l: memory_address) (n: number) : validatable_enclave_state :=
  match state with
  | enclave_state_value x mem_range =>
    match (NatMap.find e mem_range) with
    | Some _ => enclave_state_error
    | None => enclave_state_valid (enclave_state_value x (NatMap.add e (enclave_address_and_data l n) mem_range))
    end
  end.
Definition enclave_creation (state: enclave_state) (mu: memory) (e: raw_enclave_ID) (l: memory_address) (n: number): validatable_enclave_state :=
  match l with
  | address block offset =>
    match (NatMap.find block mu) with
    | Some x =>
      match (is_all_zeroes mu block offset (length (NatMapProperties.to_list x)) n) with
      | true => add_new_enclave_to_enclave_state state e l n
      | false => enclave_state_error
      end
    | None => enclave_state_error
    end
  end.

(* Active Enclave Update *)
Definition active_enclave_update (state: enclave_state) (id: enclave_ID): validatable_enclave_state :=
  match state with
  | enclave_state_value e mem_range =>
    match id with
    | enclave_ID_active x =>
      match (NatMap.find x mem_range) with
      | Some _ => enclave_state_valid (enclave_state_value id mem_range)
      | None => enclave_state_error
      end
    | enclave_ID_inactive => enclave_state_valid (enclave_state_value enclave_ID_inactive mem_range)
    end
  end.

(* Enclave Elimination *)
Definition enclave_elimination (state: enclave_state) (id: raw_enclave_ID): validatable_enclave_state :=
  match state with
  | enclave_state_value e memory_range =>
    match e with
    | enclave_ID_inactive => enclave_state_valid (enclave_state_value e (NatMap.remove id memory_range))
    | enclave_ID_active e_raw =>
      match (eqb id e_raw) with
      | true => enclave_state_error
      | false => enclave_state_valid (enclave_state_value e (NatMap.remove id memory_range))
      end
    end
  end.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


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 E Eprime A B C Oprime Aprime Cprime Eprimeprime Bprimeprime C2 C3 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ B Oprime /\ (wd_ Bprimeprime O /\ (wd_ Eprimeprime A /\ (wd_ E Eprimeprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ B Bprimeprime /\ (wd_ Eprime C2 /\ (wd_ Aprime C2 /\ (wd_ Oprime Aprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Oprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ (col_ O B Oprime /\ (col_ Oprime B Oprime /\ col_ O Eprimeprime C3))))))))))))))))))))))))))))))))) -> col_ Oprime O E)).
Proof.
  time tac.
Qed.

End FOFProblem.