Require Import Utf8.
Require Import Coq.Program.Equality.

(** printing Γ %\ensuremath{\Gamma}% #Γ# *)
(** printing Γ' %\ensuremath{\Gamma}% #Γ'# *)
(** printing Γ'' %\ensuremath{\Gamma}% #Γ''# *)
(** printing τ %\ensuremath{\tau}% #τ# *)
(** printing σ %\ensuremath{\sigma}% #σ# *)
(** printing ⊓ %\ensuremath{\sqcap}% #∩# *)
(** printing ⋂ %\ensuremath{\bigcap}% #∩# *)

(** * DSL Primitives
   Heaps, refined references, stability, etc. *)

Axiom heap : Set.
Definition hpred (A:Set) := A -> heap -> Prop.
Definition hrel (A:Set) := A -> A -> heap -> heap -> Prop.
Definition subhrel {A} (G R:hrel A) := forall x x' h h', G x x' h h' -> R x x' h h'.
Definition hreflexive {A}(R:hrel A) := forall x h, R x x h h.

(** Predicate and Relation Combinators *)
Definition pred_and {A:Set} (P:hpred A) (Q:hpred A) : hpred A :=
  fun a => fun h =>
    P a h /\ Q a h.
Infix "⊓" := (pred_and) (at level 40).

Definition pred_or {A:Set} (P Q:hpred A) : hpred A :=
  fun a => fun h => P a h \/ Q a h.
Infix "⊔" := (pred_or) (at level 41).

Definition pred_sub_eq {A:Set} (P Q:hpred A) : Prop :=
  forall x h, P x h -> Q x h.
Infix "⊑" := (pred_sub_eq) (at level 41).

Definition rel_and {A:Set} (R:hrel A) (S:hrel A) : hrel A :=
  fun a a' h h' =>
    R a a' h h' /\ S a a' h h'.
Infix "⋂" := (rel_and) (at level 40).

Definition rel_or {A:Set} (R S:hrel A) : hrel A :=
  fun a a' h h' => R a a' h h' \/ S a a' h h'.
Infix "⋃" := (rel_or) (at level 41).

Definition rel_sub_eq {A:Set} (R S:hrel A) : Prop :=
  forall a a' h h', R a a' h h' -> S a a' h h'.
Infix "⊆" := (rel_sub_eq) (at level 45).

Notation "R ⊆⊇ R'" := (rel_sub_eq R R' /\ rel_sub_eq R' R) (at level 50).

Definition stable {A} (P:hpred A) (R:hrel A) :=
  forall x x' h h', P x h -> R x x' h h' -> P x' h'.

Definition pred_iff {A : Set} (P Q : hpred A) : Prop :=
  forall x h, P x h <-> Q x h.
Infix "≡p" := (pred_iff) (at level 45).

(** * References
    ref must be defined completely, otherwise Coq's positivity checks are extremely conservative *)
Inductive ref (A:Set) (P:hpred A) (R G:hrel A) : Set :=
  | ref_placeholder : nat -> ref A P R G.
(*  mkref {ptr:nat}.*)
Notation "ref{ τ | P }[ R , G ]" := (ref τ P R G) (at level 80).
Axiom ref_stable : forall {A P R G}(r:ref{A|P}[R,G]), stable P R.
(* TODO: Nuke this? if alloc only creates stable refs, then this is okay, though awkward. *)
Hint Resolve @ref_stable.

(** ** Heap interaction primitives
    Including reachability, containment, precision, and relation folding *)

Axiom heap_write : forall {A P R G} (p:ref A P R G) (v:A) (h:heap), heap.
Axiom heap_alloc : forall (A:Set) (a:A) (P:hpred A) (R G:hrel A), heap -> (ref A P R G * heap).
(** heap_deref doesn't need to fold types because it's entirely propositional; "inside the heap" if you will,
    and does not actually affect execution *)
Axiom heap_deref : forall {A P R G} (h:heap), ref{A|P}[R,G] -> A.
Notation "h [ r ]" := (heap_deref h r) (at level 40).
Axiom heap_lookup2 : forall {A P R G} (h:heap) (r:ref{A|P}[R,G]), P (h[r]) h.
(** Some concepts require a parameter-polymorphic reference equality. *)
Axiom ptr_eq : forall {A A' P P' R R' G G'}, ref A P R G -> ref A' P' R' G' -> Prop.
Infix "≡" := (ptr_eq) (at level 80).

Axiom rgref_exchange : forall τ P P' R R' G G', P ≡p P' -> R ⊆⊇ R' -> G ⊆⊇ G' -> ref{τ|P}[R,G] = ref{τ|P'}[R',G'].

Axiom type_based_nonaliasing : forall h τ σ P R G Q R' G' `(a:ref{τ|P}[R,G]) `(b:ref{σ|Q}[R',G']) v, τ<>σ ->
  (heap_write a v h)[b] = h[b].
Axiom non_ptr_eq_based_nonaliasing : forall h τ τ' P R G Q R' G' (a:ref{τ|P}[R,G]) (b:ref{τ'|Q}[R',G']) v,
  (~ (b ≡ a)) ->
  (heap_write a v h)[b] = h[b].

(** ** Reachability
    We need to define what is reachable from a given type in order to define precise prediates and relations. *)
Class ImmediateReachability (A:Set) := {
  imm_reachable_from_in : forall {T:Set}{P R G} (p:ref{T|P}[R,G]) (a:A), Prop
}.
Global Instance ref_reach `{A:Set,P:hpred A,R:hrel A,G:hrel A}: ImmediateReachability (ref{A|P}[R,G]) :=
  { imm_reachable_from_in := fun T P' R' G' dst src => src≡dst}.
(** This is the reachability definition used globally.  Each structure must define a trusted
    ImmediateReachability instance to find pointers in a local structure.
    This relation adds the transitive and reflexive parts of reachability.
    This setup allows us to implement reference immutability generically over any
    type with an ImmediateReachability instance, and prove it precise without
    needing details about an unknown type's internal structure *)
Inductive reachable_from_in : forall {A:Set} {IRA:ImmediateReachability A}{T:Set}{P R G} (p:ref{T|P}[R,G]) (a:A) (h:heap), Prop :=
  | reflexively_reachable : forall (T:Set) P R G (r:ref{T|P}[R,G]) h, reachable_from_in r r h
  | directly_reachable : forall (U:Set) {IRU:ImmediateReachability U} {T:Set}{P R G}(p:ref{T|P}[R,G]) u h,
                           imm_reachable_from_in p u -> reachable_from_in p u h
  | trans_reachable : forall (A:Set){IRA:ImmediateReachability A} (a:A) (* value *)
                             (I:Set){ReI:ImmediateReachability I}{PI RI GI}(i:ref{I|PI}[RI,GI]) (* intermediate *)
                             {T:Set}{P R G}(p:ref{T|P}[R,G]) (* dest *)
                             h, (* heap *)
                        imm_reachable_from_in i a -> reachable_from_in p (h[i]) h ->
                        reachable_from_in p a h.
(** ** Precision
    Predicates and relations must be agnostic to changes outside the heap reachable
    from their target. *)
(** For predicates, precision really means stability over any heap changes that don't touch
    the predicates footprint *)
Definition precise_pred {A:Set}{AR:ImmediateReachability A} (P:hpred A) :=
  forall a h h', P a h ->
                 (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a h -> h[r]=h'[r]) ->
                 P a h'.
(** For relations, precision means they accept any heap changes outside their footprint. *)
Definition precise_rel {A:Set}{AR:ImmediateReachability A} (R:hrel A) :=
  forall a a' h h' h2 h2',
    (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a h -> h[r]=h2[r]) ->
    (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a' h' -> h'[r]=h2'[r]) ->
    (R a a' h h' -> R a a' h2 h2').

(** ** Relation Folding:
    Folding a rely-guarantee pair through a type to restrict the results of
    heap reads.  For any well-formed ref type the rely relation must already
    contain the literal rely of any reachable refs, so the rely portion
    is essentially a no-op.  The guarantee, however, still needs to be
    projected and intersected component-wise in any structure. *)
Class rel_fold (A:Set) :=
  { rgfold : forall (R G:hrel A), Set ;
    fold : forall {R G}, A -> rgfold R G
  }.
(** In meta-proofs, of things like satisfying a guarantee, we use this
    identity fold instead of the appropriate developer instance so
    G and P don't have to have polymorphic arities and relation arguments
    to work on all sorts of folded versions of A. We place it in its
    own section so it isn't used as an instance by user programs.
*)
Section HideMetaFold.
Local Instance meta_fold {A:Set} : rel_fold A :=
  { rgfold := fun R G => A ;
    fold := fun _ _ x => x
  }.
End HideMetaFold.
Notation "{{{ e }}}" := (let mfold : forall A, rel_fold A := @meta_fold in e) (at level 50).

(** *** New Folding
    The existing rel_fold infrastructure is brittle and painful.  Folding an arbitrary relation isn't even possible
    in some cases, since constructor arguments that aren't typed by a parameter don't fold right.
    So let's try a new approach, which explicitly makes a reference at a certain type readable
    at a certain type.  This way we can treat special cases like identity reads soundly.

    In the future, it will also be easier to extend this to enforce checking soundness of folds.
*)
Class readable_at (T : Set) (R G : hrel T) :=
  { res : Set ;
    dofold : T -> res
  }.
(** We can always build a new fold from an old one *)
Instance legacy_fold {A:Set}{R G:hrel A}`{rel_fold A} : readable_at A R G :=
  { res := rgfold R G ;
    dofold := fold
  }.

(** ** Containment
    Containment means a reference's rely admits at least as much interference
    on references reachable from it as those reachable references themselves. *)
Class Containment (A:Set) := {
  contains : forall (R:hrel A), Prop
}.

Axiom ptr_eq_deref : forall A P P' R R' G G' h (p:ref{A|P}[R,G]) (r:ref{A|P'}[G',R']), p≡r -> h[p]=h[r].
Hint Resolve ptr_eq_deref.
Axiom ptr_eq_update : forall A P P' R R' G G' (p:ref{A|P}[R,G]) (r:ref{A|P'}[G',R']),
                        p≡r -> (forall h h' v, h'=heap_write p v h -> h'[r]=v).
(* ptr_eq_update is not likely to be effective for automated solving.  Possibly a good
   candidate for a custom tactic, or with experience with goals that need this
   perhaps we can rewrite it to be more useful as a general hint. *)
Require Import Coq.Setoids.Setoid.
Global Instance refl_ptr_eq {A P R G} : Reflexive (@ptr_eq A A P P R R G G). Admitted.
Global Instance trans_ptr_eq {A P R G} : Transitive (@ptr_eq A A P P R R G G). Admitted.

(** * Default Instances for reachability, containment, precision, folding *)
(** ** Reachability *)

(** A parameterized reachability instance useful for closed base types *)
Definition closed (A:Set) (T:Set){P R G} (p:ref{T|P}[R,G]) (a:A) : Prop := False.
Global Instance nat_reach : ImmediateReachability nat := {imm_reachable_from_in := closed nat}.
Global Instance bool_reach : ImmediateReachability bool := {imm_reachable_from_in := closed bool}.
Global Instance unit_reach : ImmediateReachability unit := {imm_reachable_from_in := closed unit}.
Global Instance pair_reach `{A:Set,B:Set,AR:ImmediateReachability A,BR:ImmediateReachability B} : ImmediateReachability (A*B) :=
  { imm_reachable_from_in :=
    fun T P R G v a => match a with
                   | (l,r) => imm_reachable_from_in v l \/ imm_reachable_from_in v r
                   end
  }.
Fixpoint list_reachable {A:Set}{AR:ImmediateReachability A} (T:Set){P R G} (v:ref{T|P}[R,G]) (a:list A) : Prop :=
  match a with
  | nil => False
  | cons hd tl => imm_reachable_from_in v hd \/ list_reachable T v tl
  end.
Global Instance list_reach `{A:Set,AR:ImmediateReachability A} : ImmediateReachability (list A) :=
  { imm_reachable_from_in := fun T P R G v a => list_reachable T v a }.
(** The reference immediate reachability instance (i.e. reflexivity) was defined earlier *)

(** TODO: Containment and folding are currently formulated as functions. I might get
    better expressiveness if they were formulated as relations (propositions) instead *)
(** ** Containment *)
(** For primitives, any relation contains the permitted interference (none) *)
Definition closed_contains (A:Set) (R:hrel A) : Prop := True.
Global Instance nat_contains : Containment nat := { contains := closed_contains nat }.
Global Instance bool_contains : Containment bool := { contains := closed_contains bool }.
Global Instance unit_contains : Containment unit := { contains := closed_contains unit }.
(** TODO: This pair contains is quite weak. If R cares assumes a certain domain
    of values for either component, this basically becomes unprovable. *)
Global Instance pair_contains `{A:Set,B:Set,CA:Containment A,CB:Containment B} : Containment (A*B) :=
  { contains :=
    fun R => contains (fun a a' h h' => forall b, R (a,b) (a',b) h h')
          /\ contains (fun b b' h h' => forall a, R (a,b) (a,b') h h')
  }.
Global Instance ref_contains {A:Set}{P:hpred A}{R G:hrel A} : Containment (ref{A|P}[R,G]) :=
  { contains :=
    fun R' => forall a a' h h',
                R a a' h h' ->
                forall (r:ref{A|P}[R,G]),
                  h[r]=a -> h'[r]=a' ->
                  R' r r h h'
  }.
(** TODO: polymorphic lists *)

(** ** Relation Folding *)
Definition const_rel_fold (A:Set) (R G:hrel A) : Set := A.
Definition const_id_fold {A:Set}(R G:hrel A)(x:A) := x.
Global Instance nat_fold : rel_fold nat := {rgfold := const_rel_fold nat; fold := const_id_fold}.
Global Instance bool_fold : rel_fold bool := {rgfold := const_rel_fold bool; fold := const_id_fold}.
Global Instance unit_fold : rel_fold unit := {rgfold := const_rel_fold unit; fold := const_id_fold}.
Global Instance pair_fold `{A:Set,B:Set,FA:rel_fold A,FB:rel_fold B}: rel_fold (A*B) :=
  { rgfold := fun R G =>
    prod (rgfold (fun _ _ _ _ => True) (fun a a' h h' => forall b, G (a,b) (a',b) h h'))
         (rgfold (fun _ _ _ _ => True) (fun b b' h h' => forall a, G (a,b) (a,b') h h')) ;
    fold := fun R G xy => match xy with (x,y) => (fold x, fold y) end
  }.
Print rel_fold.
Global Instance ref_fold `{A:Set,P:hpred A,R:hrel A,G:hrel A} : rel_fold (ref{A|P}[R,G]) :=
  { rgfold := fun R' G' => ref{A|P}[R,G ⋂ (fun a a' h h' =>
                                             forall (r:ref{A|P}[R,G]), h[r]=a -> h'[r]=a' -> G' r r h h')];
    fold := (fun R G r => match r with ref_placeholder n => ref_placeholder _ _ _ _ n end)
  }.
(* Exposing this fold definition above is risky; it could have weird results in some proofs... *)

(** TODO: polymorphic lists *)

(** ** Reachability, containment, and folding for pure types *)
(** A pure type is one that contains no references, anywhere.
    A polymorphic type is pure if all arguments to the type constructor
    and all data constructors are themselves pure. *)
Class pure_type (T:Set).
Global Instance pure_reachable `{A:Set,PA:pure_type A} : ImmediateReachability A :=
  { imm_reachable_from_in := fun _ _ _ _ _ _ => False }.
Global Instance pure_contains `{A:Set,PA:pure_type A} : Containment A :=
  { contains := fun _ => True }.
Global Instance pure_fold `{A:Set,PA:pure_type A} : rel_fold A :=
  { rgfold := fun _ _ => A ; fold := const_id_fold }.
Global Instance nat_pure : pure_type nat.
Global Instance bool_pure : pure_type bool.
Global Instance unit_pure : pure_type unit.
Global Instance list_pure `{A:Set,PA:pure_type A} : pure_type (list A).

(** ** Additional Axioms
    Things like heap dereference being the same between converted and unconverted references, etc. *)
(** If we have a reference in hand, it should be valid and self-splitting as long as our allocation
    and conversion axioms are correct. *)
Axiom existing_ref_wf_split: forall T P R G (r:ref{T|P}[R,G]), G ⊆ R.
Axiom existing_ref_wf_prec_R: forall T `{ImmediateReachability T} P R G (r:ref{T|P}[R,G]), precise_rel R.
Axiom existing_ref_wf_prec_G: forall T `{ImmediateReachability T} P R G (r:ref{T|P}[R,G]), precise_rel G.
Axiom existing_ref_wf_prec_P: forall T `{ImmediateReachability T} P R G (r:ref{T|P}[R,G]), precise_pred P.
Axiom existing_ref_wf_stable: forall T P R G (r:ref{T|P}[R,G]), stable P R.
(** For now we need an explicit subtyping operator *)
Axiom convert : forall {A:Set}{P P':hpred A}{R R' G G':hrel A}`{ImmediateReachability A},
                ref{A|P}[R,G] ->
                (forall v h, P v h -> P' v h) ->
                (G' ⊆ G) -> (R ⊆ R') -> stable P' R' ->
                (G' ⊆ R') -> (* <-- self-splitting, this is a pure conversion *)
                precise_pred P' -> precise_rel R' -> precise_rel G' ->
                ref{A|P'}[R',G'].
Axiom convert_equiv : forall {A}{P P':hpred A}{R R' G G':hrel A}`{ImmediateReachability A}
                             (r:ref{A|P}[R,G]) pfP pfG pfR stab splt prP prR prG,
                             forall h, h[r]=h[@convert A P P' R R' G G' _ r pfP pfG pfR stab splt prP prR prG].
Axiom convert_equiv2 : forall {A}{P P':hpred A}{R R' G G':hrel A}`{ImmediateReachability A}
                             (r:ref{A|P}[R,G]) pfP pfG pfR stab splt prP prR prG,
                             forall v h,
                                heap_write r v h = heap_write (@convert A P P' R R' G G' _ r pfP pfG
                                pfR stab splt prP prR prG) v h.
Program Definition convert_P {A:Set}{P P':hpred A}{R G}`{ImmediateReachability A}
                             (impl:forall v h, P v h -> P' v h)
                             (prec:precise_pred P') (stbl:stable P' R) (r:ref{A|P}[R,G]) : ref{A|P'}[R,G] :=
          convert r impl _ _ stbl _ _ _ _
.
Next Obligation. compute; auto. Qed.
Next Obligation. compute; auto. Qed.
Next Obligation. eapply existing_ref_wf_split; eassumption. Qed.
Next Obligation. eapply existing_ref_wf_prec_R; eassumption. Qed.
Next Obligation. eapply existing_ref_wf_prec_G; eassumption. Qed.

Program Definition convert_G {A:Set}{P:hpred A}{R G G':hrel A}`{ImmediateReachability A}
                             (prG:precise_rel G') (sub:G' ⊆ G) (r:ref{A|P}[R,G]) : ref{A|P}[R,G'] :=
          convert r _ sub _ _ _ _ _ _
.
Next Obligation. compute; auto. Qed.
Next Obligation. eapply existing_ref_wf_stable; eassumption. Qed.
Next Obligation.
  intros x x' h h'. intros Hg. compute in sub. specialize (sub x x' h h' Hg).
  eapply existing_ref_wf_split; eauto.
Qed.
Next Obligation. eapply existing_ref_wf_prec_P; eauto. Qed.
Next Obligation. eapply existing_ref_wf_prec_R; eauto. Qed.

Lemma conversion_P_refeq : forall h A (P P':hpred A) (R G:hrel A)`{ImmediateReachability A} pf1 pf2 pf3 x,
 h[(@convert_P A P P' R G _ pf1 pf2 pf3 x)]=h[x].
Proof. intros. unfold convert_P. symmetry. eapply convert_equiv.
Qed.


Require Export Iron.Language.SystemF2Effect.Type.Exp.Base.
Require Export Iron.Language.SystemF2Effect.Type.Operator.FlattenT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.KindTs.
Require Export Iron.Language.SystemF2Effect.Type.Relation.EquivT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.EquivTs.

(********************************************************************)
Fixpoint bunchT (k : ki) (tt : list ty) : ty
 := match tt with
    | nil           => TBot k
    | t :: ts       => TSum t (bunchT k ts)
    end.

(********************************************************************)
Lemma bunchT_kindT
 :  forall ke sp ts k
 ,  SumKind k
 -> KindTs ke sp ts k
 -> KindT  ke sp (bunchT k ts) k.
Proof.
 intros.
 induction ts.
 - simpl. eauto.
 - inverts H0.
   eapply KiSum; eauto.
Qed.
Hint Resolve bunchT_kindT.

Lemma bunchT_kindTs
 :  forall ke sp ts k
 ,  KindT  ke sp (bunchT k ts) k
 -> KindTs ke sp ts k.
Proof.
 intros.
 induction ts.
 - auto.
 - unfold KindTs.
   snorm.
   inverts H0.
   + inverts H. auto.
   + inverts H. rip.
     unfold KindTs in *. snorm.
Qed.
Hint Resolve bunchT_kindTs.

Lemma bunchT_singleton
 :  forall ke sp t k
 ,  SumKind k
 -> KindT ke sp t k
 -> EquivT ke sp (bunchT k (t :: nil)) t k.
Proof.
 intros.
 simpl.
 eapply EqSym.
  auto.
  auto.
  eapply EqSumBot; auto.
Qed.

Lemma bunchT_sum
 :  forall ke sp ts1 ts2 k
 ,  SumKind k
 -> KindTs ke sp ts1 k
 -> KindTs ke sp ts2 k
 -> EquivT ke sp (bunchT k (ts2 >< ts1))
                 (TSum (bunchT k ts1) (bunchT k ts2)) k.
Proof.
 intros.
 induction ts1.
 - simpl.
   eapply EqSym; auto.
 - have (KindTs ke sp ts1 k). rip.
   have (KindT  ke sp a   k).
   simpl.
   eapply EqTrans
    with (t2 := TSum a (TSum (bunchT k ts1) (bunchT k ts2))).
   + eapply EqSumCong; auto.
   + eapply EqSumAssoc; auto.
Qed.
Hint Resolve bunchT_sum.

Lemma bunchT_flattenT_sum
 :  forall ke sp k t1 t2
 ,  SumKind k
 -> EquivT ke sp (bunchT k (flattenT t1)) t1 k
 -> EquivT ke sp (bunchT k (flattenT t2)) t2 k
 -> EquivT ke sp (bunchT k (flattenT t2 >< flattenT t1)) (TSum t1 t2) k.
Proof.
 intros.
 eapply EqTrans.
 - eapply bunchT_sum; eauto.
 - eapply EqSumCong; eauto.
Qed.

Lemma bunchT_flattenT
 :  forall ke sp t k
 ,  SumKind k
 -> KindT   ke sp t k
 -> EquivT  ke sp (bunchT k (flattenT t)) t k.
Proof.
 induction t; intros; simpl; snorm.

 - Case "TSum".
   inverts H0.
   spec IHt1 k.
   spec IHt2 k.
   rip.
   eapply bunchT_flattenT_sum; auto.

 - Case "TBot".
   inverts H0. eauto.
Qed.
Hint Resolve bunchT_flattenT.

(* The converse is not true.
   If 'ts' contains  '(TSum t1 t2)'  this will be eliminated
   by 'flattenT . bunchT', then the EqsSum check fails.
Lemma flattenT_bunchT
 :  forall  ke sp ts k
 ,  SumKind k
 -> KindTs  ke sp ts k
 -> EquivTs ke sp (flattenT (bunchT k ts)) ts k.
*)


(** Attempts to solve the strictly positive issue. *)

Module One.
  Inductive t : Type -> Type :=
  | Ret : forall (A : Type), A -> t A
  | Double : forall (A : Type) (T : Type -> Type), t A -> t (T A).

  (*Definition test :=
    Double unit t (Ret unit tt).*)
End One.

Module Two.
  Inductive t (T : Type -> Type) : Type -> Type :=
  | Double : forall (A : Type), t T A -> t T (T A).
End Two.

Module Three.
  (*Inductive t : Type -> Type :=
  | Double : forall (A : Type), t A -> t (s A)
  with s : Type -> Type :=
  | Lift : forall (A : Type), t A -> s A.*)
End Three.


(** * Semantics of the Heap Machine *)

Require Import TM.Prelim TM.Relations.
Require Import FunInd.

(** Types *)
Definition Var := nat.
Inductive Com := varT (n : Var) | appT | lamT | retT.
Definition Pro := list Com.

Definition HAdd : Type := nat.
Definition HClos : Type := HAdd * Pro.
Definition HEntr : Type := option (HClos * HAdd).
Definition Heap : Type := list HEntr.

Section Semantics.

  Implicit Types H : Heap.
  Implicit Types T V : list HClos.
  Implicit Types n m : Var.
  Implicit Types a b c : HAdd.
  Implicit Types g : HClos.
  Implicit Types P Q : Pro.

  Definition put H e : HAdd * Heap := (|H|, H++[e]).

  Definition tailRecursion : HClos -> list HClos -> list HClos :=
    fun '(a, P) T =>
      match P with
      | [] => T
      | _ => (a, P) :: T
      end.

  Definition state : Type := list HClos * list HClos * Heap.

  Fixpoint jumpTarget (k:nat) (Q:Pro) (P:Pro) : option (Pro*Pro) :=
    match P with
    | retT :: P' => match k with
                   | 0 => Some (Q,P')
                   | S k' => jumpTarget k' (Q++[retT]) P'
                   end
    | lamT :: P' => jumpTarget (S k) (Q++[lamT]) P'
    | t :: P' => jumpTarget k (Q++[t]) P' (* either [varT n] or [appT] *)
    | [] => None
    end.

  Fixpoint lookup H a n : option HClos :=
    match nth_error H a with
    | Some (Some (g, b)) =>
      match n with
      | 0 => Some g
      | S n' => lookup H b n'
      end
    | _ => None
    end.

  Lemma lookup_eq H a n :
    lookup H a n =
    match nth_error H a with
    | Some (Some (g, b)) =>
      match n with
      | 0 => Some g
      | S n' => lookup H b n'
      end
    | _ => None
    end.
  Proof. destruct n; auto. Qed.

  Inductive step : state -> state -> Prop :=
  | step_pushVal P P' Q a T V H :
      jumpTarget O [] P = Some (Q, P') ->
      step ((a, (lamT :: P)) :: T, V, H) (tailRecursion (a, P') T, (a, Q) :: V, H)
  | step_beta a b g P Q H H' c T V :
      put H (Some (g, b)) = (c, H') ->
      step ((a, (appT :: P)) :: T, g :: (b, Q) :: V, H) ((c, Q) :: tailRecursion (a, P) T, V, H')
  | step_load P a n g T V H :
      lookup H a n = Some g ->
      step ((a, (varT n :: P)) :: T, V, H) (tailRecursion (a, P) T, g :: V, H)
  .

  Definition halt_state (s : state) : Prop :=
    forall s', ~ step s s'.

  Definition steps : state -> state -> Prop := star step.

  Definition steps_k : nat -> state -> state -> Prop := pow step.

  Corollary steps_k_steps (s s' : state) (k : nat) :
    steps_k k s s' -> steps s s'.
  Proof. intros. apply star_pow. eauto. Qed.

  Corollary steps_steps_k (s s' : state) :
    steps s s' -> exists k, steps_k k s s'.
  Proof. intros. apply star_pow. eauto. Qed.

  Definition halts (s : state) : Prop :=
    exists s', steps s s' /\ halt_state s'.

  Definition halts_k (s : state) (k : nat) : Prop :=
    exists s', steps_k k s s' /\ halt_state s'.

  Definition step_fun : state -> option state :=
    fun '(T, V, H) =>
      match T with
      | (a, (lamT :: P)) :: T =>
        match jumpTarget O [] P with
        | Some (Q, P') =>
          Some (tailRecursion (a, P') T, (a, Q) :: V, H)
        | _ => None
        end
      | (a, (appT :: P)) :: T =>
        match V with
        | g :: (b, Q) :: V =>
          let (c, H') := put H (Some (g, b)) in
          Some ((c, Q) :: tailRecursion (a, P) T, V, H')
        | _ => None
        end
      | (a, (varT x :: P)) :: T =>
        match lookup H a x with
        | Some g => Some (tailRecursion (a, P) T, g :: V, H)
        | _ => None
        end
      | _ => None
      end.

  Functional Scheme step_fun_ind := Induction for step_fun Sort Prop.

  Lemma step_step_fun : forall s s', step s s' -> step_fun s = Some s'.
  Proof.
    intros s s' HStep. induction HStep; cbn in *; auto.
    - now rewrite H0.
    - now inv H0.
    - now rewrite H0.
  Qed.

  Lemma step_fun_step : forall s s', step_fun s = Some s' -> step s s'.
  Proof.
    intros s. functional induction (step_fun s); intros s' HEq; cbn; try congruence.
    - inv HEq. now econstructor.
    - inv HEq. now econstructor.
    - inv HEq. now econstructor.
  Qed.

  Lemma step_iff : forall s s', step s s' <-> step_fun s = Some s'.
  Proof. split; auto using step_step_fun, step_fun_step. Qed.

  Lemma step_functional : functional step.
  Proof. hnf. intros x z1 z2 H1 % step_iff H2 % step_iff. congruence. Qed.

  Definition is_halt_state (s : state) : bool :=
    match step_fun s with
    | Some s' => false
    | None => true
    end.

  Lemma is_halt_state_halt (s : state) :
    is_halt_state s = true -> halt_state s.
  Proof.
    unfold is_halt_state, halt_state in *.
    intros H.
    destruct (step_fun s) eqn:EStep; inv H.
    intros s' H % step_iff. congruence.
  Qed.

  Lemma halt_state_is_halt_state (s : state) :
    halt_state s -> is_halt_state s = true.
  Proof.
    unfold is_halt_state, halt_state in *.
    intros H.
    destruct (step_fun s) eqn:EStep; auto.
    apply step_iff in EStep. specialize (H s0). tauto.
  Qed.

  Lemma is_halt_state_correct (s : state) :
    is_halt_state s = true <-> halt_state s.
  Proof. intros. split; auto using is_halt_state_halt, halt_state_is_halt_state. Qed.

  Lemma step_is_halt_state (s s' : state) :
    step s s' -> is_halt_state s = false.
  Proof.
    intros H. destruct (is_halt_state) eqn:EHaltState; auto. exfalso.
    apply is_halt_state_correct in EHaltState. eapply EHaltState; eauto.
  Qed.

  Global Instance halt_state_dec : forall s, dec (halt_state s).
  Proof. intros s. eapply dec_transfer. apply is_halt_state_correct. auto. Defined.

  Lemma halt_state_steps s s' :
    halt_state s -> steps s s' -> s' = s.
  Proof.
    intros HHalt HSteps. hnf in HHalt.
    destruct HSteps; auto. now specialize (HHalt _ H).
  Qed.

  Lemma halt_state_steps_k s s' k :
    halt_state s -> steps_k k s s' -> s' = s /\ k = 0.
  Proof.
    intros HHalt HSteps. hnf in HHalt.
    destruct HSteps; auto. now specialize (HHalt _ H).
  Qed.

End Semantics.


Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Program.Tactics.
Require FMapList.
Require FMapFacts.

Module WXFacts_fun (E:DecidableType) (Import Map:FMapInterface.WSfun E).
Module MapF := FMapFacts.WFacts_fun E Map.
Module MapProperties := FMapFacts.WProperties_fun E Map.
Section XMapFacts.
  Notation eq_dec := E.eq_dec.
  Context {elt: Type}.
  Implicit Types m: t elt.
  Implicit Types x y z: key.
  Implicit Types e: elt.
  Notation Partition := MapProperties.Partition.
  Notation Disjoint := MapProperties.Disjoint.
  Notation update := MapProperties.update.

  Definition Submap m1 m2 :=
    forall k e, MapsTo k e m1 -> MapsTo k e m2.

  Lemma Submap_in:
    forall {m1 m2}, Submap m1 m2 ->
                    forall k, In k m1 -> In k m2.
  Proof.
    intros m1 m2 S k I.
    destruct I.
    exists x.
    now apply S.
  Qed.

  (* Pull in the library’s facts on Disjoint and Partition. *)
  Lemma Disjoint_alt:
    forall m m', Disjoint m m' <->
                 (forall k e e', MapsTo k e m ->
                                 MapsTo k e' m' ->
                                 False).
  Proof.
    apply MapProperties.Disjoint_alt.
  Qed.

  Lemma Disjoint_empty_r:
    forall {m}, Disjoint m (Map.empty elt).
  Proof.
    intros; rewrite Disjoint_alt; intros.
    now rewrite MapF.empty_mapsto_iff in H0.
  Qed.

  Lemma Disjoint_sym:
    forall {m1 m2}, Disjoint m1 m2 -> Disjoint m2 m1.
  Proof.
    apply MapProperties.Disjoint_sym.
  Qed.

  Lemma Disjoint_in_nin:
    forall {m1 m2}, Disjoint m1 m2 ->
                    forall k, In k m1 -> ~ In k m2.
  Proof.
    intros m1 m2 D k I1 I2; apply (D k); intuition.
  Qed.

  Lemma Disjoint_mapsto_nin:
    forall {m1 m2}, Disjoint m1 m2 ->
                    forall k e, MapsTo k e m1 -> ~ In k m2.
  Proof.
    intros m1 m2 D k e M1 I2; apply (D k); intuition; now exists e.
  Qed.

  Lemma Disjoint_submap_r:
    forall m1 m2 m3, Disjoint m1 m2 ->
                     Submap m3 m2 -> Disjoint m1 m3.
  Proof.
    intros m1 m2 m3 D S k I; destruct I as [I1 I2].
    apply (Submap_in S) in I2; now apply (D k).
  Qed.

  Lemma update_in_iff:
    forall m1 m2 k, In k (update m1 m2) <-> In k m1 \/ In k m2.
  Proof.
    apply MapProperties.update_in_iff.
  Qed.

  Lemma update_mapsto_iff:
    forall m1 m2 k e, MapsTo k e (update m1 m2) <->
                      (MapsTo k e m2 \/
                       (MapsTo k e m1 /\ ~ In k m2)).
  Proof.
    apply MapProperties.update_mapsto_iff.
  Qed.

  Lemma disjoint_update_mapsto_iff:
    forall {m1 m2}, Disjoint m1 m2 ->
                    forall k e, MapsTo k e (update m1 m2) <->
                                MapsTo k e m1 \/ MapsTo k e m2.
  Proof.
    intros m1 m2 D k e; rewrite update_mapsto_iff.
    generalize (Disjoint_mapsto_nin D k e); intros G; intuition.
  Qed.

  Lemma disjoint_update_comm:
    forall {m1 m2}, Disjoint m1 m2 ->
                    Map.Equal (update m1 m2) (update m2 m1).
  Proof.
    intros m1 m2 D; rewrite MapF.Equal_mapsto_iff; intros.
    rewrite (disjoint_update_mapsto_iff D).
    rewrite (disjoint_update_mapsto_iff (Disjoint_sym D)).
    intuition.
  Qed.

  Lemma update_submap_r:
    forall m1 m2, Submap m2 (update m1 m2).
  Proof.
    intros m1 m2 k e M; apply update_mapsto_iff; now left.
  Qed.

  Lemma disjoint_update_submap_l:
    forall {m1 m2}, Disjoint m1 m2 ->
                    Submap m1 (update m1 m2).
  Proof.
    intros m1 m2 D k e M; apply disjoint_update_mapsto_iff; intuition.
  Qed.

  Lemma Partition_disjoint:
    forall {m m1 m2}, Partition m m1 m2 -> Disjoint m1 m2.
  Proof.
    unfold Partition; intuition.
  Qed.

  Lemma Partition_mapsto_iff:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k e, MapsTo k e m <->
                                  MapsTo k e m1 \/ MapsTo k e m2.
  Proof.
    unfold Partition; intuition.
  Qed.

  Lemma Partition_mapsto_l:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k e, MapsTo k e m1 -> MapsTo k e m.
  Proof.
    intros; rewrite (Partition_mapsto_iff H); intuition.
  Qed.

  Lemma Partition_mapsto_r:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k e, MapsTo k e m2 -> MapsTo k e m.
  Proof.
    intros; rewrite (Partition_mapsto_iff H); intuition.
  Qed.

  Lemma Partition_submap_l:
    forall {m m1 m2}, Partition m m1 m2 -> Submap m1 m.
  Proof.
    intros m m1 m2 P k e M; rewrite (Partition_mapsto_iff P); intuition.
  Qed.

  Lemma Partition_submap_r:
    forall {m m1 m2}, Partition m m1 m2 -> Submap m2 m.
  Proof.
    intros m m1 m2 P k e M; rewrite (Partition_mapsto_iff P); intuition.
  Qed.

  Lemma Partition_in_iff:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k, In k m <-> In k m1 \/ In k m2.
  Proof.
    intros; generalize (Partition_mapsto_iff H); split; intros.
    - destruct H1; rewrite H0 in H1; destruct or H1;
        [ left | right ]; now exists x.
    - destruct or H1; destruct H1; exists x; rewrite H0; intuition.
  Qed.

  Lemma Partition_in_l:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k, In k m1 -> In k m.
  Proof.
    intros; rewrite (Partition_in_iff H); intuition.
  Qed.

  Lemma Partition_in_r:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k, In k m2 -> In k m.
  Proof.
    intros; rewrite (Partition_in_iff H); intuition.
  Qed.

  Lemma Partition_refl:
    forall m, Partition m m (Map.empty elt).
  Proof.
    intros; unfold Partition; split.
    - apply Disjoint_empty_r.
    - intros; rewrite MapF.empty_mapsto_iff; intuition.
  Qed.

  Lemma Partition_sym:
    forall m m1 m2, Partition m m1 m2 -> Partition m m2 m1.
  Proof.
    apply MapProperties.Partition_sym.
  Qed.

  Lemma Partition_empty_r:
    forall m m', Partition m m' (Map.empty elt) ->
                 Map.Equal m m'.
  Proof.
    intros; apply MapF.Equal_mapsto_iff; intros.
    unfold Partition in *; destruct_conjs.
    generalize (H0 k e); rewrite MapF.empty_mapsto_iff; intuition.
  Qed.

  Lemma Partition_update:
    forall m m1 m2, Partition m m1 m2 ->
                    Map.Equal m (update m1 m2).
  Proof.
    intros; unfold MapProperties.Partition in *; destruct_conjs.
    apply MapF.Equal_mapsto_iff; intros.
    rewrite H0.
    rewrite (disjoint_update_mapsto_iff H).
    intuition.
  Qed.

  Lemma disjoint_update_partition:
    forall m1 m2, Disjoint m1 m2 ->
                  Partition (update m1 m2) m1 m2.
  Proof.
    intros; unfold Partition; split; auto; intros.
    rewrite (disjoint_update_mapsto_iff H); intuition.
  Qed.

  Lemma Partition_assoc:
    forall m m1 m2 m2a m2b,
      Partition m m1 m2 ->
      Partition m2 m2a m2b ->
      Partition m (update m1 m2a) m2b.
  Proof.
    intros; unfold Partition; split.
    - unfold Disjoint; intros k I; destruct I as [Ia Ib].
      apply update_in_iff in Ia; destruct or Ia.
      + apply (Partition_disjoint H k).
        now apply (Partition_in_r H0) in Ib.
      + now apply (Partition_disjoint H0 k).
    - intros; rewrite disjoint_update_mapsto_iff.
      rewrite (Partition_mapsto_iff H).
      rewrite (Partition_mapsto_iff H0).
      split; intuition.
      apply Disjoint_submap_r with (m2:=m2).
      apply (Partition_disjoint H).
      apply (Partition_submap_l H0).
  Qed.

  Lemma Partition_add_1:
    forall m m1 m2 k v v1,
      Partition m (Map.add k v1 m1) m2 ->
      Partition (Map.add k v m) (Map.add k v m1) m2.
  Proof.
    intros m m1 m2 k v v1 P.
    unfold Partition; split.
    - intros kk I; destruct I; apply (Partition_disjoint P kk).
      rewrite MapF.add_in_iff in *; intuition.
    - intros kk e.
      rewrite MapF.add_mapsto_iff.
      rewrite (Partition_mapsto_iff P).
      repeat rewrite MapF.add_mapsto_iff.
      intuition.
      right; split; intuition.
      apply (Partition_disjoint P kk).
      rewrite H in *; rewrite MapF.add_in_iff; intuition; now exists e.
  Qed.

End XMapFacts.
End WXFacts_fun.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i 	$Id$	 i*)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import NArith.
Require Import Ndigits.
Require Import Ndec.
Require Import Map.
Require Import Mapaxioms.
Require Import Mapiter.
Require Import Fset.
Require Import List.
Require Import Lsort.
Require Import Mapsubset.
Require Import Mapcard.

Section MapCanon.

  Variable A : Type.

  Inductive mapcanon : Map A -> Prop :=
    | M0_canon : mapcanon (M0 A)
    | M1_canon : forall (a:ad) (y:A), mapcanon (M1 A a y)
    | M2_canon :
        forall m1 m2:Map A,
          mapcanon m1 ->
          mapcanon m2 -> 2 <= MapCard A (M2 A m1 m2) -> mapcanon (M2 A m1 m2).

  Lemma mapcanon_M2 :
   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> 2 <= MapCard A (M2 A m1 m2).
  Proof.
    intros. inversion H. assumption.
  Qed.

  Lemma mapcanon_M2_1 :
   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m1.
  Proof.
    intros. inversion H. assumption.
  Qed.

  Lemma mapcanon_M2_2 :
   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m2.
  Proof.
    intros. inversion H. assumption.
  Qed.

  Lemma M2_eqmap_1 :
   forall m0 m1 m2 m3:Map A,
     eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m0 m2.
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_div2 a).
    rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1).
    rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m2 m3).
    exact (H (Ndouble a)).
  Qed.

  Lemma M2_eqmap_2 :
   forall m0 m1 m2 m3:Map A,
     eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m1 m3.
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_plus_one_div2 a).
    rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1).
    rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m2 m3).
    exact (H (Ndouble_plus_one a)).
  Qed.

  Lemma mapcanon_unique :
   forall m m':Map A, mapcanon m -> mapcanon m' -> eqmap A m m' -> m = m'.
  Proof.
    simple induction m. simple induction m'. trivial.
    intros a y H H0 H1. cut (None = MapGet A (M1 A a y) a). simpl in |- *. rewrite (Neqb_correct a).
    intro. discriminate H2.
    exact (H1 a).
    intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4).
    rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2).
    intros a y. simple induction m'. intros. cut (MapGet A (M1 A a y) a = None). simpl in |- *.
    rewrite (Neqb_correct a). intro. discriminate H2.
    exact (H1 a).
    intros a0 y0 H H0 H1. cut (MapGet A (M1 A a y) a = MapGet A (M1 A a0 y0) a). simpl in |- *.
    rewrite (Neqb_correct a). intro. elim (sumbool_of_bool (Neqb a0 a)). intro H3.
    rewrite H3 in H2. inversion H2. rewrite (Neqb_complete _ _ H3). reflexivity.
    intro H3. rewrite H3 in H2. discriminate H2.
    exact (H1 a).
    intros. cut (2 <= MapCard A (M1 A a y)). intro. elim (le_Sn_O _ (le_S_n _ _ H4)).
    rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2).
    simple induction m'. intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4).
    rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1).
    intros a y H1 H2 H3. cut (2 <= MapCard A (M1 A a y)). intro.
    elim (le_Sn_O _ (le_S_n _ _ H4)).
    rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1).
    intros. rewrite (H m2). rewrite (H0 m3). reflexivity.
    exact (mapcanon_M2_2 _ _ H3).
    exact (mapcanon_M2_2 _ _ H4).
    exact (M2_eqmap_2 _ _ _ _ H5).
    exact (mapcanon_M2_1 _ _ H3).
    exact (mapcanon_M2_1 _ _ H4).
    exact (M2_eqmap_1 _ _ _ _ H5).
  Qed.

  Lemma MapPut1_canon :
   forall (p:positive) (a a':ad) (y y':A), mapcanon (MapPut1 A a y a' y' p).
  Proof.
    simple induction p. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon.
    apply M1_canon.
    apply le_n.
    apply M2_canon. apply M1_canon.
    apply M1_canon.
    apply le_n.
    simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M0_canon.
    apply H.
    simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n.
    apply M2_canon. apply H.
    apply M0_canon.
    simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n.
    simpl in |- *. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon.
    apply M1_canon.
    simpl in |- *. apply le_n.
    apply M2_canon. apply M1_canon.
    apply M1_canon.
    simpl in |- *. apply le_n.
  Qed.

  Lemma MapPut_canon :
   forall m:Map A,
     mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut A m a y).
  Proof.
    simple induction m. intros. simpl in |- *. apply M1_canon.
    intros a0 y0 H a y. simpl in |- *. case (Nxor a0 a). apply M1_canon.
    intro. apply MapPut1_canon.
    intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
    exact (mapcanon_M2_2 m0 m1 H1).
    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1).
    apply plus_le_compat. exact (MapCard_Put_lb A m0 N0 y).
    apply le_n.
    intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1).
    apply H0. exact (mapcanon_M2_2 m0 m1 H1).
    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
    exact (mapcanon_M2 m0 m1 H1).
    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 (Npos p0) y).
    intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
    exact (mapcanon_M2_2 m0 m1 H1).
    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
    exact (mapcanon_M2 m0 m1 H1).
    apply plus_le_compat_r. exact (MapCard_Put_lb A m0 (Npos p0) y).
    apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1).
    apply H0. apply (mapcanon_M2_2 m0 m1 H1).
    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
    exact (mapcanon_M2 m0 m1 H1).
    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 N0 y).
  Qed.

  Lemma MapPut_behind_canon :
   forall m:Map A,
     mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut_behind A m a y).
  Proof.
    simple induction m. intros. simpl in |- *. apply M1_canon.
    intros a0 y0 H a y. simpl in |- *. case (Nxor a0 a). apply M1_canon.
    intro. apply MapPut1_canon.
    intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
    exact (mapcanon_M2_2 m0 m1 H1).
    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1).
    apply plus_le_compat. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 N0 y).
    apply le_n.
    intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1).
    apply H0. exact (mapcanon_M2_2 m0 m1 H1).
    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
    exact (mapcanon_M2 m0 m1 H1).
    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 (Npos p0) y).
    intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
    exact (mapcanon_M2_2 m0 m1 H1).
    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
    exact (mapcanon_M2 m0 m1 H1).
    apply plus_le_compat_r. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 (Npos p0) y).
    apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1).
    apply H0. apply (mapcanon_M2_2 m0 m1 H1).
    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
    exact (mapcanon_M2 m0 m1 H1).
    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 N0 y).
  Qed.

  Lemma makeM2_canon :
   forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (makeM2 A m m').
  Proof.
    intro. case m. intro. case m'. intros. exact M0_canon.
    intros a y H H0. exact (M1_canon (Ndouble_plus_one a) y).
    intros. simpl in |- *. apply M2_canon; try assumption. exact (mapcanon_M2 m0 m1 H0).
    intros a y m'. case m'. intros. exact (M1_canon (Ndouble a) y).
    intros a0 y0 H H0. simpl in |- *. apply M2_canon; try assumption. apply le_n.
    intros. simpl in |- *. apply M2_canon; try assumption.
    apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H0).
    exact (le_plus_r (MapCard A (M1 A a y)) (MapCard A (M2 A m0 m1))).
    simpl in |- *. intros. apply M2_canon; try assumption.
    apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H).
    exact (le_plus_l (MapCard A (M2 A m0 m1)) (MapCard A m')).
  Qed.

  Fixpoint MapCanonicalize (m:Map A) : Map A :=
    match m with
    | M2 m0 m1 => makeM2 A (MapCanonicalize m0) (MapCanonicalize m1)
    | _ => m
    end.

  Lemma mapcanon_exists_1 : forall m:Map A, eqmap A m (MapCanonicalize m).
  Proof.
    simple induction m. apply eqmap_refl.
    intros. apply eqmap_refl.
    intros. simpl in |- *. unfold eqmap, eqm in |- *. intro.
    rewrite (makeM2_M2 A (MapCanonicalize m0) (MapCanonicalize m1) a).
    rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if.
    rewrite <- (H (Ndiv2 a)). rewrite <- (H0 (Ndiv2 a)). reflexivity.
  Qed.

  Lemma mapcanon_exists_2 : forall m:Map A, mapcanon (MapCanonicalize m).
  Proof.
    simple induction m. apply M0_canon.
    intros. simpl in |- *. apply M1_canon.
    intros. simpl in |- *. apply makeM2_canon; assumption.
  Qed.

  Lemma mapcanon_exists :
   forall m:Map A, {m' : Map A | eqmap A m m' /\ mapcanon m'}.
  Proof.
    intro. split with (MapCanonicalize m). split. apply mapcanon_exists_1.
    apply mapcanon_exists_2.
  Qed.

  Lemma MapRemove_canon :
   forall m:Map A, mapcanon m -> forall a:ad, mapcanon (MapRemove A m a).
  Proof.
    simple induction m. intros. exact M0_canon.
    intros a y H a0. simpl in |- *. case (Neqb a a0). exact M0_canon.
    assumption.
    intros. simpl in |- *. case (Nbit0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
    apply H0. exact (mapcanon_M2_2 _ _ H1).
    apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1).
    exact (mapcanon_M2_2 _ _ H1).
  Qed.

  Lemma MapMerge_canon :
   forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapMerge A m m').
  Proof.
    simple induction m. intros. exact H0.
    simpl in |- *. intros a y m' H H0. exact (MapPut_behind_canon m' H0 a y).
    simple induction m'. intros. exact H1.
    intros a y H1 H2. unfold MapMerge in |- *. exact (MapPut_canon _ H1 a y).
    intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 _ _ H3).
    exact (mapcanon_M2_1 _ _ H4).
    apply H0. exact (mapcanon_M2_2 _ _ H3).
    exact (mapcanon_M2_2 _ _ H4).
    change (2 <= MapCard A (MapMerge A (M2 A m0 m1) (M2 A m2 m3))) in |- *.
    apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H3).
    exact (MapMerge_Card_lb_l A (M2 A m0 m1) (M2 A m2 m3)).
  Qed.

  Lemma MapDelta_canon :
   forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapDelta A m m').
  Proof.
    simple induction m. intros. exact H0.
    simpl in |- *. intros a y m' H H0. case (MapGet A m' a).
    intro. exact (MapRemove_canon m' H0 a).
    exact (MapPut_canon m' H0 a y).
    simple induction m'. intros. exact H1.
    unfold MapDelta in |- *. intros a y H1 H2. case (MapGet A (M2 A m0 m1) a).
    intro. exact (MapRemove_canon _ H1 a).
    exact (MapPut_canon _ H1 a y).
    intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H3).
    exact (mapcanon_M2_1 _ _ H4).
    apply H0. exact (mapcanon_M2_2 _ _ H3).
    exact (mapcanon_M2_2 _ _ H4).
  Qed.

  Variable B : Type.

  Lemma MapDomRestrTo_canon :
   forall m:Map A,
     mapcanon m -> forall m':Map B, mapcanon (MapDomRestrTo A B m m').
  Proof.
    simple induction m. intros. exact M0_canon.
    simpl in |- *. intros a y H m'. case (MapGet B m' a).
    intro. apply M1_canon.
    exact M0_canon.
    simple induction m'. exact M0_canon.
    unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a).
    intro. apply M1_canon.
    exact M0_canon.
    intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
    apply H0. exact (mapcanon_M2_2 m0 m1 H1).
  Qed.

  Lemma MapDomRestrBy_canon :
   forall m:Map A,
     mapcanon m -> forall m':Map B, mapcanon (MapDomRestrBy A B m m').
  Proof.
    simple induction m. intros. exact M0_canon.
    simpl in |- *. intros a y H m'. case (MapGet B m' a); try assumption.
    intro. exact M0_canon.
    simple induction m'. exact H1.
    intros a y. simpl in |- *. case (Nbit0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
    apply MapRemove_canon. exact (mapcanon_M2_2 _ _ H1).
    apply makeM2_canon. apply MapRemove_canon. exact (mapcanon_M2_1 _ _ H1).
    exact (mapcanon_M2_2 _ _ H1).
    intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1).
    apply H0. exact (mapcanon_M2_2 _ _ H1).
  Qed.

  Lemma Map_of_alist_canon : forall l:alist A, mapcanon (Map_of_alist A l).
  Proof.
    simple induction l. exact M0_canon.
    intro r. elim r. intros a y l0 H. simpl in |- *. apply MapPut_canon. assumption.
  Qed.

  Lemma MapSubset_c_1 :
   forall (m:Map A) (m':Map B),
     mapcanon m -> MapSubset A B m m' -> MapDomRestrBy A B m m' = M0 A.
  Proof.
    intros. apply mapcanon_unique. apply MapDomRestrBy_canon. assumption.
    apply M0_canon.
    exact (MapSubset_imp_2 _ _ m m' H0).
  Qed.

  Lemma MapSubset_c_2 :
   forall (m:Map A) (m':Map B),
     MapDomRestrBy A B m m' = M0 A -> MapSubset A B m m'.
  Proof.
    intros. apply MapSubset_2_imp. unfold MapSubset_2 in |- *. rewrite H. apply eqmap_refl.
  Qed.

End MapCanon.

Section FSetCanon.

  Variable A : Type.

  Lemma MapDom_canon :
   forall m:Map A, mapcanon A m -> mapcanon unit (MapDom A m).
  Proof.
    simple induction m. intro. exact (M0_canon unit).
    intros a y H. exact (M1_canon unit a _).
    intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 A _ _ H1).
    apply H0. exact (mapcanon_M2_2 A _ _ H1).
    change (2 <= MapCard unit (MapDom A (M2 A m0 m1))) in |- *. rewrite <- MapCard_Dom.
    exact (mapcanon_M2 A _ _ H1).
  Qed.

End FSetCanon.

Section MapFoldCanon.

  Variables A B : Type.

  Lemma MapFold_canon_1 :
   forall m0:Map B,
     mapcanon B m0 ->
     forall op:Map B -> Map B -> Map B,
       (forall m1:Map B,
          mapcanon B m1 ->
          forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) ->
       forall f:ad -> A -> Map B,
         (forall (a:ad) (y:A), mapcanon B (f a y)) ->
         forall (m:Map A) (pf:ad -> ad),
           mapcanon B (MapFold1 A (Map B) m0 op f pf m).
  Proof.
    simple induction m. intro. exact H.
    intros a y pf. simpl in |- *. apply H1.
    intros. simpl in |- *. apply H0. apply H2.
    apply H3.
  Qed.

  Lemma MapFold_canon :
   forall m0:Map B,
     mapcanon B m0 ->
     forall op:Map B -> Map B -> Map B,
       (forall m1:Map B,
          mapcanon B m1 ->
          forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) ->
       forall f:ad -> A -> Map B,
         (forall (a:ad) (y:A), mapcanon B (f a y)) ->
         forall m:Map A, mapcanon B (MapFold A (Map B) m0 op f m).
  Proof.
    intros. exact (MapFold_canon_1 m0 H op H0 f H1 m (fun a:ad => a)).
  Qed.

  Lemma MapCollect_canon :
   forall f:ad -> A -> Map B,
     (forall (a:ad) (y:A), mapcanon B (f a y)) ->
     forall m:Map A, mapcanon B (MapCollect A B f m).
  Proof.
    intros. rewrite MapCollect_as_Fold. apply MapFold_canon. apply M0_canon.
    intros. exact (MapMerge_canon B m1 m2 H0 H1).
    assumption.
  Qed.

End MapFoldCanon.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section VotedForMoreUpToDate.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition votedFor_moreUpToDate (net : network) : Prop :=
    forall t h h',
      currentTerm (snd (nwState net h)) = t ->
      type (snd (nwState net h)) = Candidate ->
      votedFor (snd (nwState net h')) = Some h ->
      currentTerm (snd (nwState net h')) = t ->
      exists vl,
        moreUpToDate (maxTerm (log (snd (nwState net h)))) (maxIndex (log (snd (nwState net h))))
                     (maxTerm vl) (maxIndex vl) = true /\
        In (t, h, vl) (votesWithLog (fst (nwState net h'))).

  Class votedFor_moreUpToDate_interface : Prop :=
    {
      votedFor_moreUpToDate_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votedFor_moreUpToDate net
    }.
End VotedForMoreUpToDate.


Require Import UFO.Lang.Syntax.
Require Import UFO.Lang.Bindings.
Require Import UFO.Lang.Sig.
Set Implicit Arguments.

Implicit Types EP EV LV V L : Set.

Notation se E1 E2 := (∀ e, In e E1 → In e E2).

Inductive
ss EP EV LV L : ms EP EV LV L → ms EP EV LV L → Prop :=
  | ss_eff :
    ∀ σ1 σ2, @ss _ _ _ _ σ1 σ2 → ss (ms_ev σ1) (ms_ev σ2)
  | ss_lbl :
    ∀ σ1 σ2, @ss _ _ _ _ σ1 σ2 → ss (ms_lv σ1) (ms_lv σ2)
  | ss_tm :
    ∀ T1 T2 σ1 σ2, st T2 T1 → ss σ1 σ2 → ss (ms_tm T1 σ1) (ms_tm T2 σ2)
  | ss_res :
    ∀ T1 T2 E1 E2, st T1 T2 → se E1 E2 → ss (ms_res T1 E1) (ms_res T2 E2)
  | ss_tran :
    ∀ σ1 σ2 σ3, ss σ1 σ2 → ss σ2 σ3 → ss σ1 σ3
with
st EP EV LV L : ty EP EV LV L → ty EP EV LV L → Prop :=
  | st_unit : st 𝟙 𝟙
  | st_cont :
    ∀ Ta1 Ta2 Ea1 Ea2 Tb1 Tb2 Eb1 Eb2,
    st Ta2 Ta1 → se Ea2 Ea1 → st Tb1 Tb2 → se Eb1 Eb2 →
    st (ty_cont Ta1 Ea1 Tb1 Eb1) (ty_cont Ta2 Ea2 Tb2 Eb2)
  | st_it : ∀ N ℓ, st (ty_it N ℓ) (ty_it N ℓ)
  | st_ms : ∀ σ1 σ2 ℓ, ss σ1 σ2 → st (ty_ms σ1 ℓ) (ty_ms σ2 ℓ)
  | st_tran :
    ∀ T1 T2 T3, st T1 T2 → st T2 T3 → st T1 T3
.

Arguments st_unit [EP EV LV L].

(** Static semantics with label identifiers represented as [var] *)

Section section_wf.

Inductive wf_lbl EV LV (Ξ : XEnv EV LV) : lbl LV ∅ → Prop :=
| wf_lbl_id : ∀ X, X \in dom Ξ → wf_lbl Ξ (lbl_id (lid_f X))
| wf_lbl_var : ∀ p, wf_lbl Ξ (lbl_var p)
.

Inductive wf_ef EP EV LV (Ξ : XEnv EV LV) : ef EP EV LV ∅ → Prop :=
| wf_ef_par : ∀ α, wf_ef Ξ (ef_par α)
| wf_ef_var : ∀ α, wf_ef Ξ (ef_var α)
| wf_ef_lbl : ∀ ℓ, wf_lbl Ξ ℓ → wf_ef Ξ (ef_lbl ℓ)
.

Inductive wf_eff EP EV LV (Ξ : XEnv EV LV) : eff EP EV LV ∅ → Prop :=
| wf_eff_nil  : wf_eff Ξ []
| wf_eff_cons : ∀ e E, wf_ef Ξ e → wf_eff Ξ E → wf_eff Ξ (e :: E)
.

Inductive wf_it EP EV LV (Ξ : XEnv EV LV) : ∀ κ, it EP EV LV ∅ κ → Prop :=
| wf_it_name :
  ∀ F, wf_it Ξ (it_name F)
| wf_it_inst :
  ∀ κ N E, wf_it Ξ N → wf_eff Ξ E → wf_it Ξ (κ := κ) (it_inst N E)
.

Inductive
wf_ty EP EV LV (Ξ : XEnv EV LV) : ty EP EV LV ∅ → Prop :=
| wf_ty_unit : wf_ty Ξ 𝟙
| wf_ty_cont :
    ∀ Ta Ea Tb Eb,
    wf_ty Ξ Ta → wf_eff Ξ Ea → wf_ty Ξ Tb → wf_eff Ξ Eb →
    wf_ty Ξ (ty_cont Ta Ea Tb Eb)
| wf_ty_it : ∀ N ℓ, wf_it Ξ N → wf_lbl Ξ ℓ → wf_ty Ξ (ty_it N ℓ)
| wf_ty_ms : ∀ σ ℓ, wf_ms Ξ σ → wf_lbl Ξ ℓ → wf_ty Ξ (ty_ms σ ℓ)
with
wf_ms EP EV LV (Ξ : XEnv EV LV) : ms EP EV LV ∅ → Prop :=
| wf_ms_ev : ∀ σ, wf_ms (EV := inc EV) (EV_shift_XEnv Ξ) σ → wf_ms Ξ (ms_ev σ)
| wf_ms_lv : ∀ σ, wf_ms (LV := inc LV) (LV_shift_XEnv Ξ) σ → wf_ms Ξ (ms_lv σ)
| wf_ms_tm : ∀ S σ, wf_ty Ξ S → wf_ms Ξ σ → wf_ms Ξ (ms_tm S σ)
| wf_ms_res : ∀ T E, wf_ty Ξ T → wf_eff Ξ E → wf_ms Ξ (ms_res T E)
.

Inductive
wf_md
EV LV V (Ξ : XEnv EV LV) (Γ : V → ty ∅ EV LV ∅) :
md EV LV V ∅ → ms ∅ EV LV ∅ → var → Prop :=
| wf_md_ev :
  ∀ m σ X,
  @wf_md _ _ _ (EV_shift_XEnv Ξ) (EV_shift_ty ∘ Γ)
    m σ X →
  (* wf_ms (EV_shift_XEnv Ξ) σ → X ∈ dom Ξ → *)
  wf_md Ξ Γ (md_ev m) (ms_ev σ) X
| wf_md_lv :
  ∀ m σ X,
  @wf_md _ _ _ (LV_shift_XEnv Ξ) (LV_shift_ty ∘ Γ)
    m σ X →
  (* wf_ms (LV_shift_XEnv Ξ) σ → X ∈ dom Ξ → *)
  wf_md Ξ Γ (md_lv m) (ms_lv σ) X
| wf_md_tm :
  ∀ m S σ X,
  wf_ty Ξ S →
  @wf_md _ _ _ Ξ (env_ext Γ S) m σ X →
  (* wf_ms Ξ σ → X ∈ dom Ξ → *)
  wf_md Ξ Γ (md_tm m) (ms_tm S σ) X
| wf_md_res :
  ∀ t Ta Ea X Tb Eb,
  binds X (Tb, Eb) Ξ →
  wf_ty Ξ Ta → wf_eff Ξ Ea → wf_ty Ξ Tb → wf_eff Ξ Eb →
  @wf_tm _ _ _ Ξ
    (env_ext Γ (ty_cont Ta (ef_lbl (lbl_id (lid_f X)) :: Ea) Tb Eb))
    t Tb Eb →
  wf_md Ξ Γ (md_res t) (ms_res Ta Ea) X

with
wf_ktx
EV LV V (Ξ : XEnv EV LV) (Γ : V → ty ∅ EV LV ∅) :
ktx EV LV V ∅ →
ty ∅ EV LV ∅ → eff ∅ EV LV ∅ →
ty ∅ EV LV ∅ → eff ∅ EV LV ∅ → Prop :=
| wf_ktx_hole :
  ∀ T E,
  wf_ty Ξ T → wf_eff Ξ E →
  wf_ktx Ξ Γ ktx_hole T E T E
| wf_ktx_op :
  ∀ K T' E' N ℓ E,
  wf_ktx Ξ Γ K T' E' (ty_it N ℓ) E →
  wf_ktx Ξ Γ (ktx_op K) T' E' (ty_ms (it_msig N) ℓ) E
| wf_ktx_up :
  ∀ K T' E' T E₁ ℓ E₂,
  wf_ktx Ξ Γ K T' E' (ty_ms (ms_res T E₁) ℓ) E₂ →
  wf_ktx Ξ Γ (ktx_up K) T' E' T ((ef_lbl ℓ) :: (E₁ ++ E₂))
| wf_ktx_app_eff :
  ∀ K T' E' E₁ σ ℓ E₂,
  wf_eff Ξ E₁ →
  wf_ktx Ξ Γ K T' E' (ty_ms (ms_ev σ) ℓ) E₂ →
  wf_ktx Ξ Γ (ktx_app_eff K E₁) T' E' (ty_ms (EV_subst_ms E₁ σ) ℓ) E₂
| wf_ktx_app_lbl :
  ∀ K T' E' ℓ₁ σ ℓ₂ E,
  wf_lbl Ξ ℓ₁ →
  wf_ktx Ξ Γ K T' E' (ty_ms (ms_lv σ) ℓ₂) E →
  wf_ktx Ξ Γ (ktx_app_lbl K ℓ₁) T' E' (ty_ms (LV_subst_ms ℓ₁ σ) ℓ₂) E
| wf_ktx_app_tm1 :
  ∀ K T' E' S σ ℓ E s,
  wf_ktx Ξ Γ K T' E' (ty_ms (ms_tm S σ) ℓ) E →
  wf_tm Ξ Γ s S E →
  wf_ktx Ξ Γ (ktx_app_tm1 K s) T' E' (ty_ms σ ℓ) E
| wf_ktx_app_tm2 :
  ∀ K T' E' v S σ ℓ E,
  wf_val Ξ Γ v (ty_ms (ms_tm S σ) ℓ) →
  wf_ktx Ξ Γ K T' E' S E →
  wf_ktx Ξ Γ (ktx_app_tm2 K v) T' E' (ty_ms σ ℓ) E
| wf_ktx_throw :
  ∀ K T' E' Ta Ea Tb Eb s,
  wf_ktx Ξ Γ K T' E' (ty_cont Ta Ea Tb Eb) Eb →
  wf_tm Ξ Γ s Ta Ea →
  wf_ktx Ξ Γ (ktx_throw K s) T' E' Tb Eb
| wf_ktx_let :
  ∀ K T' E' S E T t,
  wf_ktx Ξ Γ K T' E' S E →
  wf_ty Ξ S →
  @wf_tm _ _ _ Ξ (env_ext Γ S) t T E →
  wf_ktx Ξ Γ (ktx_let K t) T' E' T E

with
wf_val
EV LV V (Ξ : XEnv EV LV) (Γ : V → ty ∅ EV LV ∅) :
val EV LV V ∅ → ty ∅ EV LV ∅ → Prop :=
| wf_val_unit :
  wf_val Ξ Γ val_unit 𝟙
| wf_val_var :
  ∀ x,
  wf_val Ξ Γ (val_var x) (Γ x)
| wf_val_fix :
  ∀ m N X,
  wf_md (V := inc V) Ξ (env_ext Γ (ty_it N (lbl_id (lid_f X)))) m (it_msig N) X →
  wf_it Ξ N → X ∈ dom Ξ →
  wf_val Ξ Γ (val_fix m (lid_f X)) (ty_it N (lbl_id (lid_f X)))
| wf_val_md :
  ∀ m σ X,
  wf_md Ξ Γ m σ X →
  wf_val Ξ Γ (val_md m (lid_f X)) (ty_ms σ (lbl_id (lid_f X)))
| wf_val_cont :
  ∀ K Ta Ea Tb Eb,
  wf_ktx Ξ Γ K Ta Ea Tb Eb →
  wf_val Ξ Γ (val_cont K) (ty_cont Ta Ea Tb Eb)

with
wf_tm
EV LV V (Ξ : XEnv EV LV) (Γ : V → ty ∅ EV LV ∅) :
tm EV LV V ∅ → ty ∅ EV LV ∅ → eff ∅ EV LV ∅ → Prop :=
| wf_tm_val :
  ∀ v T,
  wf_val Ξ Γ v T →
  wf_tm Ξ Γ (tm_val v) T []
| wf_tm_app_eff :
  ∀ t E₁ σ ℓ E₂,
  wf_tm Ξ Γ t (ty_ms (ms_ev σ) ℓ) E₂ →
  wf_eff Ξ E₁ →
  wf_tm Ξ Γ (tm_app_eff t E₁) (ty_ms (EV_subst_ms E₁ σ) ℓ) E₂
| wf_tm_app_lbl :
  ∀ t ℓ₁ σ ℓ₂ E,
  wf_tm Ξ Γ t (ty_ms (ms_lv σ) ℓ₂) E →
  wf_lbl Ξ ℓ₁ →
  wf_tm Ξ Γ (tm_app_lbl t ℓ₁) (ty_ms (LV_subst_ms ℓ₁ σ) ℓ₂) E
| wf_tm_app_tm :
  ∀ t s S σ ℓ E,
  wf_tm Ξ Γ t (ty_ms (ms_tm S σ) ℓ) E →
  wf_tm Ξ Γ s S E →
  wf_tm Ξ Γ (tm_app_tm t s) (ty_ms σ ℓ) E
| wf_tm_op :
  ∀ t N ℓ E,
  wf_tm Ξ Γ t (ty_it N ℓ) E →
  wf_tm Ξ Γ (tm_op t) (ty_ms (it_msig N) ℓ) E
| wf_tm_up :
  ∀ t T ℓ E₁ E₂,
  wf_tm Ξ Γ t (ty_ms (ms_res T E₁) ℓ) E₂ →
  wf_tm Ξ Γ (⇧ t) T ((ef_lbl ℓ) :: (E₁ ++ E₂))
| wf_tm_Down :
  ∀ t T E (B : vars),
  wf_ty Ξ T →
  wf_eff Ξ E →
  ( ∀ X, X ∉ B →
    wf_tm (Ξ & X ~ (T, E)) Γ
    (L_subst_tm (lid_f X) t) T (ef_lbl (lbl_id (lid_f X)) :: E)
  ) →
  wf_tm Ξ Γ (⬇ t) T E
| wf_tm_throw :
  ∀ t s Ta Ea Tb Eb,
  wf_tm Ξ Γ t (ty_cont Ta Ea Tb Eb) Eb →
  wf_tm Ξ Γ s Ta Ea →
  wf_tm Ξ Γ (tm_throw t s) Tb Eb
| wf_tm_let :
  ∀ S s t T E,
  wf_ty Ξ S →
  wf_tm Ξ Γ s S E →
  @wf_tm _ _ _ Ξ (env_ext Γ S) t T E →
  wf_tm Ξ Γ (tm_let s t) T E
| wf_tm_sub :
  ∀ t T T' E E',
  wf_tm Ξ Γ t T E →
  st T T' → se E E' →
  wf_ty Ξ T' → wf_eff Ξ E' →
  wf_tm Ξ Γ t T' E'
.

Inductive wf_XEnv EV LV : XEnv EV LV → Prop :=
| wf_XEnv_empty : wf_XEnv empty
| wf_XEnv_cons Ξ X T E :
    wf_XEnv Ξ → X # Ξ → wf_ty Ξ T → wf_eff Ξ E →
    wf_XEnv (Ξ & X ~ (T, E))
.

Definition wf_Γ EV LV V (Ξ : XEnv EV LV) (Γ : V → ty ∅ EV LV ∅) : Prop :=
∀ x, wf_ty Ξ (Γ x).

End section_wf.

Inductive XLEnv EV LV :
∀ L, XEnv EV LV → LEnv EV LV L → (L → lid ∅) → Prop :=
| XLEnv_empty : XLEnv empty LEnv_empty ∅→
| XLEnv_push :
  ∀ L Ξ X T E (Π : LEnv EV LV L) (f : L → lid ∅),
  XLEnv Ξ Π f → X ∉ dom Ξ →
  wf_ty Ξ (L_bind_ty f T) → wf_eff Ξ (L_bind_eff f E) →
  XLEnv
    (Ξ & X ~ (L_bind_ty f T, L_bind_eff f E))
    (LEnv_push Π T E)
    (env_ext f (lid_f X))
.

Section section_ok.

(** Static semantics with label identifiers represented as de Bruijn indices *)

Inductive
subms EV LV L : ms ∅ EV LV L → ms ∅ EV LV L → Prop :=
  | subms_ev :
    ∀ σ1 σ2, @subms _ _ _ σ1 σ2 → subms (ms_ev σ1) (ms_ev σ2)
  | subms_lv :
    ∀ σ1 σ2, @subms _ _ _ σ1 σ2 → subms (ms_lv σ1) (ms_lv σ2)
  | subms_tm :
    ∀ T1 T2 σ1 σ2, subty T2 T1 → subms σ1 σ2 → subms (ms_tm T1 σ1) (ms_tm T2 σ2)
  | subms_res :
    ∀ T1 T2 E1 E2, subty T1 T2 → se E1 E2 → subms (ms_res T1 E1) (ms_res T2 E2)
  | subms_tran :
    ∀ σ1 σ2 σ₃, subms σ1 σ2 → subms σ2 σ₃ → subms σ1 σ₃
with
subty EV LV L : ty ∅ EV LV L → ty ∅ EV LV L → Prop :=
  | subty_unit : subty 𝟙 𝟙
  | subty_cont :
    ∀ Ta1 Ta2 Ea1 Ea2 Tb1 Tb2 Eb1 Eb2,
    subty Ta2 Ta1 → se Ea2 Ea1 → subty Tb1 Tb2 → se Eb1 Eb2 →
    subty (ty_cont Ta1 Ea1 Tb1 Eb1) (ty_cont Ta2 Ea2 Tb2 Eb2)
  | subty_it : ∀ N ℓ, subty (ty_it N ℓ) (ty_it N ℓ)
  | subty_ms : ∀ σ1 σ2 ℓ, subms σ1 σ2 → subty (ty_ms σ1 ℓ) (ty_ms σ2 ℓ)
  | subty_tran :
    ∀ T1 T2 T3, subty T1 T2 → subty T2 T3 → subty T1 T3
.

Arguments subty_unit [EV LV].

Inductive ok_lbl EV LV L (Π : LEnv EV LV L) : lbl LV L → Prop :=
| ok_lbl_id : ∀ β, ok_lbl Π (lbl_id (lid_b β))
| ok_lbl_var : ∀ p, ok_lbl Π (lbl_var p)
.

Inductive ok_ef EV LV L (Π : LEnv EV LV L) : ef ∅ EV LV L → Prop :=
| ok_ef_var : ∀ α, ok_ef Π (ef_var α)
| ok_ef_lbl : ∀ ℓ, ok_lbl Π ℓ → ok_ef Π (ef_lbl ℓ)
.

Inductive ok_eff EV LV L (Π : LEnv EV LV L) : eff ∅ EV LV L → Prop :=
| ok_eff_nil  : ok_eff Π []
| ok_eff_cons : ∀ e E, ok_ef Π e → ok_eff Π E → ok_eff Π (e :: E)
.

Inductive ok_it EV LV L (Π : LEnv EV LV L) : ∀ κ, it ∅ EV LV L κ → Prop :=
| ok_it_name :
  ∀ 𝔽, ok_it Π (it_name 𝔽)
| ok_it_inst :
  ∀ κ N E, ok_it Π N → ok_eff Π E → ok_it Π (κ := κ) (it_inst N E)
.

Inductive
ok_ty EV LV L (Π : LEnv EV LV L) : ty ∅ EV LV L → Prop :=
| ok_ty_unit : ok_ty Π 𝟙
| ok_ty_cont :
    ∀ Ta Ea Tb Eb,
    ok_ty Π Ta → ok_eff Π Ea → ok_ty Π Tb → ok_eff Π Eb →
    ok_ty Π (ty_cont Ta Ea Tb Eb)
| ok_ty_it : ∀ N ℓ, ok_it Π N → ok_lbl Π ℓ → ok_ty Π (ty_it N ℓ)
| ok_ty_ms : ∀ σ ℓ, ok_ms Π σ → ok_lbl Π ℓ → ok_ty Π (ty_ms σ ℓ)
with
ok_ms EV LV L (Π : LEnv EV LV L) : ms ∅ EV LV L → Prop :=
| ok_ms_ev : ∀ σ, @ok_ms _ _ _ (EV_shift_LEnv Π) σ → ok_ms Π (ms_ev σ)
| ok_ms_lv : ∀ σ, @ok_ms _ _ _ (LV_shift_LEnv Π) σ → ok_ms Π (ms_lv σ)
| ok_ms_tm : ∀ S σ, ok_ty Π S → ok_ms Π σ → ok_ms Π (ms_tm S σ)
| ok_ms_res : ∀ T E, ok_ty Π T → ok_eff Π E → ok_ms Π (ms_res T E)
.

Fixpoint LEnv_lookup EV LV L (β : L) (Π : LEnv EV LV L) {struct Π} :
ty ∅ EV LV L * eff ∅ EV LV L.
Proof.
destruct Π as [ | L Π T E ].
+ destruct β.
+ destruct β as [ | β ].
  - exact (L_shift_ty T, L_shift_eff E).
  - exact (
      (λ p, match p with (T, E) => (L_shift_ty T, L_shift_eff E) end)
      (LEnv_lookup _ _ _ β Π)
    ).
Defined.

Inductive
ok_md
EV LV V L (Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L) :
md EV LV V L → ms ∅ EV LV L → L → Prop :=
| ok_md_ev :
  ∀ m σ β,
  @ok_md _ _ _ _ (EV_shift_LEnv Π) (EV_shift_ty ∘ Γ)
    m σ β →
  ok_md Π Γ (md_ev m) (ms_ev σ) β
| ok_md_lv :
  ∀ m σ β,
  @ok_md _ _ _ _ (LV_shift_LEnv Π) (LV_shift_ty ∘ Γ)
    m σ β →
  ok_md Π Γ (md_lv m) (ms_lv σ) β
| ok_md_tm :
  ∀ m S σ β,
  ok_ty Π S →
  @ok_md _ _ _ _ Π (env_ext Γ S) m σ β →
  ok_md Π Γ (md_tm m) (ms_tm S σ) β
| ok_md_res :
  ∀ t Ta Ea β Tb Eb,
  LEnv_lookup β Π = (Tb, Eb) →
  ok_ty Π Ta → ok_eff Π Ea → ok_ty Π Tb → ok_eff Π Eb →
  @ok_tm _ _ _ _ Π
    (env_ext Γ (ty_cont Ta (ef_lbl (lbl_id (lid_b β)) :: Ea) Tb Eb))
    t Tb Eb →
  ok_md Π Γ (md_res t) (ms_res Ta Ea) β

with
ok_ktx
EV LV V L (Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L) :
ktx EV LV V L →
ty ∅ EV LV L → eff ∅ EV LV L →
ty ∅ EV LV L → eff ∅ EV LV L → Prop :=
| ok_ktx_hole :
  ∀ T E,
  ok_ty Π T → ok_eff Π E →
  ok_ktx Π Γ ktx_hole T E T E
| ok_ktx_op :
  ∀ K T' E' N ℓ E,
  ok_ktx Π Γ K T' E' (ty_it N ℓ) E →
  ok_ktx Π Γ (ktx_op K) T' E' (ty_ms (it_msig N) ℓ) E
| ok_ktx_up :
  ∀ K T' E' T E₁ ℓ E₂,
  ok_ktx Π Γ K T' E' (ty_ms (ms_res T E₁) ℓ) E₂ →
  ok_ktx Π Γ (ktx_up K) T' E' T ((ef_lbl ℓ) :: (E₁ ++ E₂))
| ok_ktx_app_eff :
  ∀ K T' E' E₁ σ ℓ E₂,
  ok_eff Π E₁ →
  ok_ktx Π Γ K T' E' (ty_ms (ms_ev σ) ℓ) E₂ →
  ok_ktx Π Γ (ktx_app_eff K E₁) T' E' (ty_ms (EV_subst_ms E₁ σ) ℓ) E₂
| ok_ktx_app_lbl :
  ∀ K T' E' ℓ₁ σ ℓ₂ E,
  ok_lbl Π ℓ₁ →
  ok_ktx Π Γ K T' E' (ty_ms (ms_lv σ) ℓ₂) E →
  ok_ktx Π Γ (ktx_app_lbl K ℓ₁) T' E' (ty_ms (LV_subst_ms ℓ₁ σ) ℓ₂) E
| ok_ktx_app_tm1 :
  ∀ K T' E' S σ ℓ E s,
  ok_ktx Π Γ K T' E' (ty_ms (ms_tm S σ) ℓ) E →
  ok_tm Π Γ s S E →
  ok_ktx Π Γ (ktx_app_tm1 K s) T' E' (ty_ms σ ℓ) E
| ok_ktx_app_tm2 :
  ∀ K T' E' v S σ ℓ E,
  ok_val Π Γ v (ty_ms (ms_tm S σ) ℓ) →
  ok_ktx Π Γ K T' E' S E →
  ok_ktx Π Γ (ktx_app_tm2 K v) T' E' (ty_ms σ ℓ) E
| ok_ktx_throw :
  ∀ K T' E' Ta Ea Tb Eb s,
  ok_ktx Π Γ K T' E' (ty_cont Ta Ea Tb Eb) Eb →
  ok_tm Π Γ s Ta Ea →
  ok_ktx Π Γ (ktx_throw K s) T' E' Tb Eb
| ok_ktx_let :
  ∀ K T' E' S E T t,
  ok_ktx Π Γ K T' E' S E →
  ok_ty Π S →
  @ok_tm _ _ _ _ Π (env_ext Γ S) t T E →
  ok_ktx Π Γ (ktx_let K t) T' E' T E

with
ok_val
EV LV V L (Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L) :
val EV LV V L → ty ∅ EV LV L → Prop :=
| ok_val_unit :
  ok_val Π Γ val_unit 𝟙
| ok_val_var :
  ∀ x, ok_val Π Γ (val_var x) (Γ x)
| ok_val_fix :
  ∀ m N β,
  ok_md (V := inc V) Π (env_ext Γ (ty_it N (lbl_id (lid_b β)))) m (it_msig N) β →
  ok_it Π N →
  ok_val Π Γ (val_fix m (lid_b β)) (ty_it N (lbl_id (lid_b β)))
| ok_val_md :
  ∀ m σ β,
  ok_md Π Γ m σ β →
  ok_val Π Γ (val_md m (lid_b β)) (ty_ms σ (lbl_id (lid_b β)))
| ok_val_cont :
  ∀ K Ta Ea Tb Eb,
  ok_ktx Π Γ K Ta Ea Tb Eb →
  ok_val Π Γ (val_cont K) (ty_cont Ta Ea Tb Eb)

with
ok_tm
EV LV V L (Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L) :
tm EV LV V L → ty ∅ EV LV L → eff ∅ EV LV L → Prop :=
| ok_tm_val :
  ∀ v T,
  ok_val Π Γ v T →
  ok_tm Π Γ (tm_val v) T []
| ok_tm_app_eff :
  ∀ t E₁ σ ℓ E₂,
  ok_tm Π Γ t (ty_ms (ms_ev σ) ℓ) E₂ →
  ok_eff Π E₁ →
  ok_tm Π Γ (tm_app_eff t E₁) (ty_ms (EV_subst_ms E₁ σ) ℓ) E₂
| ok_tm_app_lbl :
  ∀ t ℓ₁ σ ℓ₂ E,
  ok_tm Π Γ t (ty_ms (ms_lv σ) ℓ₂) E →
  ok_lbl Π ℓ₁ →
  ok_tm Π Γ (tm_app_lbl t ℓ₁) (ty_ms (LV_subst_ms ℓ₁ σ) ℓ₂) E
| ok_tm_app_tm :
  ∀ t s S σ ℓ E,
  ok_tm Π Γ t (ty_ms (ms_tm S σ) ℓ) E →
  ok_tm Π Γ s S E →
  ok_tm Π Γ (tm_app_tm t s) (ty_ms σ ℓ) E
| ok_tm_op :
  ∀ t N ℓ E,
  ok_tm Π Γ t (ty_it N ℓ) E →
  ok_tm Π Γ (tm_op t) (ty_ms (it_msig N) ℓ) E
| ok_tm_up :
  ∀ t T ℓ E₁ E₂,
  ok_tm Π Γ t (ty_ms (ms_res T E₁) ℓ) E₂ →
  ok_tm Π Γ (⇧ t) T ((ef_lbl ℓ) :: (E₁ ++ E₂))
| ok_tm_Down :
  ∀ t (T : ty ∅ EV LV L) (E : eff ∅ EV LV L),
  ok_ty Π T → ok_eff Π E →
  @ok_tm _ _ _ _ (LEnv_push Π T E) (L_shift_ty ∘ Γ) t
    (L_shift_ty T) (ef_lbl (lbl_id (lid_b VZ)) :: (L_shift_eff E)) →
  ok_tm Π Γ (⬇ t) T E
| ok_tm_throw :
  ∀ t s Ta Ea Tb Eb,
  ok_tm Π Γ t (ty_cont Ta Ea Tb Eb) Eb →
  ok_tm Π Γ s Ta Ea →
  ok_tm Π Γ (tm_throw t s) Tb Eb
| ok_tm_let :
  ∀ S s t T E,
  ok_ty Π S →
  ok_tm Π Γ s S E →
  @ok_tm _ _ _ _ Π (env_ext Γ S) t T E →
  ok_tm Π Γ (tm_let s t) T E
| ok_tm_sub :
  ∀ t T T' E E',
  ok_tm Π Γ t T E →
  subty T T' → se E E' →
  ok_ty Π T' → ok_eff Π E' →
  ok_tm Π Γ t T' E'
.

Definition ok_Γ EV LV V L (Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L) : Prop :=
∀ x, ok_ty Π (Γ x).

End section_ok.

Parameter wf_it_msig :
∀ EV LV Ξ (N : it ∅ EV LV ∅ _), wf_it Ξ N → wf_ms Ξ (it_msig N).


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.Syntax.Util.
Require Import Crypto.Compilers.FoldTypes.

Section min_or_max.
  Context (f : base_type -> base_type -> base_type)
          (init : base_type).

  Definition TypeFold {t} (e : Expr t) : base_type
    := TypeFold (fun t => t) f init e.
End min_or_max.

Definition MaxTypeUsed {t} (e : Expr t) : base_type
  := TypeFold base_type_max (TWord 0) e.
Definition MinTypeUsed {t} (e : Expr t) : base_type
  := TypeFold base_type_min TZ e.


(*

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

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

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

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

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_lib.
Require Export sequents_tacs.
Require Export sequents_tacs2.
Require Export per_props_equality.
Require Export per_props_isect.
Require Export rules_tyfam.
Require Export rules_tyfam2.
Require Export subst_tacs_aeq.
Require Export cequiv_tacs.

(* end hide *)

(**

  We now prove the truth of several rules about the intersection type.

*)

(* [3] ============ ISECT MEMBER FORMATION ============ *)

(**

  We can state the intersection member formation rule as follows:

<<
   H |- isect x:A. B ext b

     By isect_memberFormation lvl(i) z ()

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

 *)

Definition rule_isect_member_formation_concl {o} A x B b (H : @bhyps o) :=
  mk_baresequent H (mk_concl (mk_isect A x B) b).

Definition rule_isect_member_formation_hyp1 {o} z A x B b (H : @bhyps o) :=
  mk_baresequent
    (snoc H (mk_hhyp z A))
    (mk_concl (subst B x (mk_var z)) b).

Definition rule_isect_member_formation_hyp2 {o} A e i (H : @bhyps o) :=
  mk_baresequent H (mk_concl (mk_equality A A (mk_uni i)) e).

Definition rule_isect_member_formation {o}
           (A B b e : NTerm)
           (x z  : NVar)
           (i    : nat)
           (H    : @barehypotheses o) :=
  mk_rule
    (rule_isect_member_formation_concl A x B b H)
    [ rule_isect_member_formation_hyp1 z A x B b H,
      rule_isect_member_formation_hyp2 A e i H ]
    [sarg_var z].

Lemma rule_isect_member_formation_true3 {o} :
  forall lib (A B b e : NTerm)
         (x z : NVar)
         (i   : nat)
         (H   : @barehypotheses o),
    rule_true3 lib (rule_isect_member_formation A B b e x z i H).
Proof.
  intros.
  unfold rule_isect_member_formation, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp into hyp1.
  rename Hyp0 into hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_concl (mk_isect A x B) b))) as wfc.
  { clear hyp1 hyp2.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; auto.
    introv j.
    rw in_app_iff in j; repndors; tcsp.
  }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

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

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

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

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

  (* We prove our first subgoal *)
  assert (forall s2 pC2,
            similarity lib s1 s2 H
            -> tequality lib (lsubstc (mk_isect A x B) wf1 s1 pC1)
                         (lsubstc (mk_isect A x B) wf1 s2 pC2)) as tfb.

  { clear s2 pC2 pt2 sim.
    intros s2 pC2 sim.
    lift_lsubst.
    rw @tequality_isect.

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

    - (* we use our 2nd hypothesis to prove that A is a type *)
      vr_seq_true in hyp2.
      generalize (hyp2 s1 s2); clear hyp2; intro hyp2.
      autodimp hyp2 h.
      autodimp hyp2 h; exrepd.
      lsubst_tac.
      apply equality_in_mkc_equality in e0; repnd.
      clear e0 e2.
      apply equality_commutes in t; auto.
      apply equality_in_uni in t; auto.

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

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

        exists s1 s4 a t2 w1 c1 c4; sp.
        (* now to prove that functionality statement on A, we use our 2nd hyp *)
        vr_seq_true in hyp2.
        generalize (hyp2 s1 s4); clear hyp2; intro hyp2.
        autodimp hyp2 hyp.
        autodimp hyp2 hyp; exrepd.
        lsubst_tac.
        apply equality_in_mkc_equality in e1; repnd.
        clear e1 e3.
        apply equality_commutes in t; auto.
        apply equality_in_uni in t; auto.
        (* and we're done proving that the hypotheses are functional *)

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

        { (* For that we have to prove that the two terms we picked to be equal in A are actually equal in A *)
          sim_snoc; dands; auto. }

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

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

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

          repeat (lsubstc_subst_aeq2;[]).
          repeat (substc_lsubstc_vars3;[]).
          revert c c4 t.
          lsubst_tac.
          introv t.
          repeat (lsubstc_snoc2;[]).
          proof_irr; auto.
          (* and we're done proving our 1st subgoal (the tequality) *)
        }
  }

  (* We now prove our second subgoal *)
  dands; auto.
  lsubst_tac_c.
  applydup @similarity_refl in sim.
  rw @equality_in_isect.

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

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

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

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

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

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

      + (* For that we have to prove that the two terms we picked to be equal in A are actually equal in A *)
        sim_snoc; dands; auto.
        (* easy enough *)

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

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

        lsubstc_subst_aeq2.
        repeat (substc_lsubstc_vars3;[]).
        revert c0 e0.
        lsubst_tac.
        introv e0.
        lsubstc_snoc2.
        proof_irr; auto.
  }
Qed.

Lemma rule_isect_member_formation_true_ext_lib {o} :
  forall lib (A B b e : NTerm)
         (x z : NVar)
         (i   : nat)
         (H   : @barehypotheses o),
    rule_true_ext_lib lib (rule_isect_member_formation A B b e x z i H).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_isect_member_formation_true3.
Qed.

(* begin hide *)

Lemma rule_isect_member_formation_true {o} :
  forall lib (A B b e : NTerm)
         (x z : NVar)
         (i   : nat)
         (H   : @barehypotheses o),
    rule_true lib (rule_isect_member_formation A B b e x z i H).
Proof.
  introv.
  apply rule_true3_implies_rule_true.
  apply rule_isect_member_formation_true3.
Qed.

Lemma rule_isect_member_formation_true_ex {o} :
  forall lib i z e A B b x H,
    @rule_true_if o lib (rule_isect_member_formation A B b e x z i H).
Proof.
  intros.
  generalize (rule_isect_member_formation_true lib A B b e x z i H); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

Lemma rule_isect_member_formation_true2 {o} :
  forall lib i z e A B b x H,
    @rule_true2 o lib (rule_isect_member_formation A B b e x z i H).
Proof.
  intros.
  generalize (rule_isect_member_formation_true lib A B b e x z i H); intro rt.
  apply rule_true_iff_rule_true2; sp.
Qed.

Lemma rule_isect_member_formation_wf {o} :
  forall i z e A B b x H,
    !LIn z (vars_hyps H)
    -> wf_term e
    -> @wf_rule o (rule_isect_member_formation A B b e x z i H).
Proof.
  introv niz wfe.

  introv pwf m; allsimpl; repdors; subst; sp;
    allunfold @pwf_sequent; wfseq; sp;
      allrw @covered_isect; repnd; auto;
        allrw <- @wf_isect_iff; repnd; auto.

  { allrw @vswf_hypotheses_nil_eq.
    apply wf_hypotheses_snoc; simpl; sp.
    apply isprog_vars_eq; sp.
    apply nt_wf_eq; sp. }

  { apply subst_preserves_wf_term; sp. }

  { apply @covered_subst; sp;
      try (apply @covered_var; rw in_snoc; sp);
      try (complete (rw cons_snoc; apply @covered_snoc_weak; auto)). }
Qed.

Lemma rule_isect_member_formation_wf2 {o} :
  forall i z A B b e x H,
    !LIn z (vars_hyps H)
    -> @wf_rule2 o (rule_isect_member_formation A B b e x z i H).
Proof.
  introv niz wf j; allsimpl; repndors; subst; tcsp;
    allunfold @wf_bseq; repnd; allsimpl; wfseq;
      allrw @covered_isect; repnd; auto;
        allrw <- @wf_isect_iff; repnd; auto.

  - allrw @vswf_hypotheses_nil_eq.
    apply wf_hypotheses_snoc; simpl; sp.
    apply isprog_vars_eq; sp.
    apply nt_wf_eq; sp.

  - apply subst_preserves_wf_term; sp.

  - apply @covered_subst; sp;
    try (apply @covered_var; rw in_snoc; sp);
    try (complete (rw cons_snoc; apply @covered_snoc_weak; auto)).
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr  &all    Inria, 2006              *)
(*************************************************************)

(*Load Pol_ring.*)
Require Import Mylist.

Require Import Arith.
Require Import ZArith.
Require Import Even.
Require Import CAD_types.
Require Import Utils.
Require Import Pol_ring.

Add New Ring PolRing : PRth Abstract.
Add  New Ring CoefRing : cRth Abstract.

Fixpoint get_coef (k:nat) (P:Pol) {struct k}: Coef:=
           match k with
                        O => match P with
                                 Pc c => c
                                | PX _ _ c => c
                               end
                        |S k' => match P with
                                Pc _ => c0
                               | PX Q xH _ => get_coef k' Q
                               | PX Q i _ => get_coef k' (PX Q (i-1) c0)
                         end
                end.

Lemma gcoef_P0 : forall k , get_coef k P0 == c0.
intro k; case k;simpl; intros;setoid ring.
Qed.

(*Axiom Cheat: forall A:Prop,A.*)

Lemma Pplus_xIPminus1_assoc: forall p q , (p + (xI q - 1) = p + xI q - 1)%positive.
intros.
 rewrite (Pplus_reg_l 1(p + (xI q - 1))(p + xI q - 1 )).
auto.
 rewrite Pplus_assoc.
rewrite (Pplus_comm 1).
rewrite <- Pplus_assoc.
rewrite Pplus_minus;auto.
rewrite Pplus_minus; trivial.
destruct p;simpl;auto with arith.
Qed.

Lemma Pplus_Pminus1_assoc: forall p q , (p + (xO q - 1) = p + xO q - 1)%positive.
intros.
 rewrite (Pplus_reg_l 1(p + (xO q - 1))(p + xO q - 1 )).
auto.
 rewrite Pplus_assoc.
rewrite (Pplus_comm 1).
rewrite <- Pplus_assoc.
rewrite Pplus_minus;auto.
rewrite Pplus_minus; trivial.
destruct p;simpl;auto with arith.
Qed.

Add Morphism get_coef  with signature (@eq nat) ==> Pol_Eq ==> ceq as gcoef_Morphism.
induction x.
intros P Q  Heq; inversion Heq; simpl;trivial.
rename P0 into P2;subst.
apply ceq_sym;trivial.
intros P Q  Heq; inversion Heq;try (rename P0 into P2;subst).
simpl; setoid ring.
simpl.
generalize (gcoef_P0 x);intro.
destruct i.
rewrite (IHx (PX P2 (xI i - 1) c0) (P0)).
constructor; [setoid ring|trivial].
apply ceq_sym;trivial.
rewrite (IHx (PX P2 (xO i - 1) c0) P0).
constructor; [setoid ring|trivial].
apply ceq_sym;trivial.
rewrite <-H1; apply IHx; apply PolEq_sym;trivial.
simpl.
generalize (gcoef_P0 x);intro.
destruct i.
rewrite (IHx (PX P2 (xI i - 1) c0) P0); trivial.
constructor; [setoid ring|trivial].
rewrite (IHx (PX P2 (xO i - 1) c0) P0); trivial.
constructor; [setoid ring|trivial].
rewrite <-H1; apply IHx; trivial.
simpl.
destruct i; apply IHx; rewrite H0;setoid ring.
simpl.
destruct j.
destruct i.
simpl Pplus at 1.
simpl.
apply IHx;rewrite H0.
rewrite PX_pq_pq;simpl.
rewrite Pplus_carry_spec.
rewrite xO_succ_permute.
rewrite xI_succ_xO.
generalize (Psucc (xO (i + j))); intro.
generalize (Ppred_succ p0); intro.
assert (Psucc p0 -1 = Ppred (Psucc p0))%positive.
destruct p0;simpl;auto with arith.
rewrite  H2;rewrite H1;setoid ring.
simpl.
apply IHx;rewrite H0.
rewrite PX_pq_pq;simpl.
generalize (i+j)%positive;intro.
assert (xO p0= xI p0 -1)%positive.
destruct p0;simpl;auto with arith.
rewrite H1;setoid ring.
simpl;apply IHx;rewrite H0.
rewrite PX_pq_pq;simpl.
generalize j;intro.
assert (xO(Psucc j0) =xI j0 + 1)%positive.
destruct j;simpl; auto with arith.
rewrite H1;auto  with arith.
assert (xI j0 = xI j0 +1 -1)%positive.
rewrite Pplus_comm; rewrite <-  Pplus_xIPminus1_assoc.
rewrite Pplus_minus;auto.
rewrite <- H2; setoid ring.
destruct i;simpl;apply IHx;rewrite H0.
rewrite PX_pq_pq.
cut ((xI i + (xO j - 1)= xI (i + j) - 1)%positive).
intro h;rewrite h;setoid ring.
rewrite  Pplus_Pminus1_assoc.
simpl;auto.
rewrite PX_pq_pq.
rewrite  Pplus_Pminus1_assoc;simpl;setoid ring.
rewrite PX_pq_pq.
rewrite Pplus_minus; auto;unfold Pminus;simpl; setoid ring.
destruct i;simpl;apply IHx;rewrite H0.
unfold Pminus;simpl.
rewrite Pdouble_minus_one_o_succ_eq_xI;setoid ring.
unfold Pminus;simpl;setoid ring.
unfold Pminus;simpl;setoid ring.
simpl.
destruct i;destruct j; simpl; apply IHx; rewrite H0; try rewrite PX_pq_pq.
unfold Pminus;simpl.
rewrite Pplus_carry_spec.
rewrite Pdouble_minus_one_o_succ_eq_xI;setoid ring.
rewrite  Pplus_Pminus1_assoc;simpl;setoid ring.
unfold Pminus;simpl.
rewrite Pdouble_minus_one_o_succ_eq_xI;setoid ring.
rewrite  Pplus_xIPminus1_assoc;simpl;setoid ring.
rewrite  Pplus_Pminus1_assoc;simpl;setoid ring.
unfold Pminus;simpl;setoid ring.
simpl.
unfold Pminus;simpl.
rewrite Pdouble_minus_one_o_succ_eq_xI;setoid ring.
rewrite  Pplus_Pminus1_assoc;simpl;setoid ring.
unfold Pminus;simpl;setoid ring.
Qed.

Lemma Pscal_Pc: forall a c, a!* Pc c != Pc (a**c).
intros.
unfold Pol_mul_Rat;case_c0_test a;simpl.
rewrite H0; constructor; setoid ring.
case_c0_test  (a -- c1); [assert (h:a ==c1);[ apply copp_eq;trivial|rewrite h]|idtac].
constructor; setoid ring.
constructor; setoid ring.
Qed.

Lemma PX_Pmul_rat_aux_Xchange : forall P a p c, (PX (Pol_mul_Rat_aux P a) p (c ** a) != Pol_mul_Rat_aux (PX P p c) a).
induction P;intros.
simpl.
case_c0_test (c**a).
rewrite H0; constructor; try setoid ring.
 constructor;setoid ring.
setoid ring.
simpl.
repeat rewrite mkPX_PX_c.
setoid ring.
Qed.

Lemma gcoef_Pmul_Rat_aux: forall n P a, get_coef n (Pol_mul_Rat_aux P a) == a** get_coef n P.
induction n.
induction P.
intros;simpl; setoid ring.
intros;simpl Pol_mul_Rat_aux;rewrite mkPX_PX_c; setoid ring.
simpl;setoid ring.
induction P.
intros;simpl;setoid ring.
simpl Pol_mul_Rat_aux.
intros;rewrite mkPX_PX_c.

simpl.
assert (c0 == c0**a).
setoid ring.
destruct p; try rewrite H.
rewrite (PX_Pmul_rat_aux_Xchange P a  (xI p - 1)).
rewrite IHn.
rewrite <- H;setoid ring.

rewrite (PX_Pmul_rat_aux_Xchange P a  (xO p - 1)).
rewrite IHn.
rewrite <- H;setoid ring.
apply IHn.
Qed.

Lemma gcoef_Pmul_Rat: forall n P a, get_coef n (Pol_mul_Rat P a) == a** get_coef n P.
intros; unfold Pol_mul_Rat; case_c0_test a.
rewrite H0;rewrite gcoef_P0; setoid ring.
case_c0_test  (a -- c1); [assert (h:a==c1);[ apply copp_eq;trivial|rewrite h]|idtac].
setoid ring.
apply gcoef_Pmul_Rat_aux.
Qed.

Lemma gcoef_last : forall n P p c c' , get_coef (S n) (PX P p c) == get_coef (S n) (PX P p c').
induction n.
intros;simpl.
destruct p; try setoid ring.
intros.
simpl.

destruct p.
case (xI p - 1)%positive;
intros; apply gcoef_Morphism; setoid ring.
case (xO p - 1)%positive;
intros; apply gcoef_Morphism; setoid ring.

case P; intros; try setoid ring.
Qed.

Lemma gcoef_Padd: forall  n P Q ,   get_coef n (P+Q) == get_coef n P ++ get_coef n Q.
induction n;intros.
destruct P; destruct Q; rename c0 into c2; try (simpl;setoid ring; fail).
simpl Pol_add;destruct (ZPminus p p0);rewrite mkPX_PX_c;simpl; setoid ring.

destruct P; destruct Q; rename c0 into c2; try (simpl;setoid ring; fail).
generalize (ZPminus_spec p p0); destruct (ZPminus p p0) ; intro h; rewrite h.
simpl Pol_add; rewrite ZPminus0;rewrite mkPX_PX_c;simpl.
destruct p0;try rewrite PX_Padd_r; apply IHn.
simpl Pol_add;rewrite ZPminuspos;rewrite mkPX_PX_c;simpl.
caseEq p0; intros.
caseEq p1;intros;simpl.
rewrite PX_Padd_r;rewrite PX_pq_pq;rewrite IHn.
apply cadd_ext;setoid ring.
apply gcoef_Morphism.
simpl.
cut ((xI (p3 + p2) = xO (Pplus_carry p2 p3) - 1)%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
unfold Pminus;simpl.
assert (Pdouble_minus_one (Pplus_carry p2  p3) = (xO p3 + xI p2)%positive).
rewrite Pplus_carry_spec.
rewrite Pdouble_minus_one_o_succ_eq_xI.
rewrite Pplus_comm;reflexivity.
rewrite H1;auto with arith.
rewrite PX_Padd_r;rewrite PX_pq_pq;rewrite IHn.
apply cadd_ext;setoid ring.
apply gcoef_Morphism.
simpl.
cut ((xO (p3 + p2) = xI(p2 + p3) - 1)%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
unfold Pminus;simpl; rewrite Pplus_comm;trivial.
rewrite PX_Padd_r;rewrite PX_pq_pq;rewrite IHn.
apply cadd_ext;setoid ring.
apply gcoef_Morphism.
simpl.
cut ((xI p2 = (xO (Psucc p2) - 1))%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
unfold Pminus;simpl.
rewrite  Pdouble_minus_one_o_succ_eq_xI; trivial.
caseEq p1;intros;simpl.
rewrite PX_Padd_r;rewrite PX_pq_pq;rewrite IHn.
apply cadd_ext;setoid ring.
apply gcoef_Morphism.
cut (((xI p3 + (xO p2 - 1)) = (xI (p2 + p3) - 1))%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
rewrite xI_succ_xO.
rewrite Pplus_one_succ_r.
rewrite <- Pplus_assoc.
rewrite Pplus_minus.
unfold Pminus;simpl; rewrite Pplus_comm;trivial.
simpl; trivial.
rewrite PX_Padd_r;rewrite PX_pq_pq;rewrite IHn.
apply cadd_ext;setoid ring.
apply gcoef_Morphism.
cut ((xO p3 + (xO p2 - 1) =(xO (p2 + p3) - 1))%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
assert ((xO p3 + xO p2  = xO(p2 + p3))%positive).
simpl; rewrite Pplus_comm;trivial.
rewrite <- H1.
apply Pplus_Pminus1_assoc.
rewrite PX_Padd_r;rewrite PX_pq_pq;rewrite IHn.
apply cadd_ext;setoid ring.
apply gcoef_Morphism.
cut (( 1 + (xO p2 - 1)=(xI p2 - 1) )%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
rewrite xI_succ_xO; rewrite Pplus_one_succ_l;rewrite Pplus_Pminus1_assoc; trivial.
caseEq p1;intros;simpl;
rewrite IHn;
apply cadd_ext;setoid ring;
apply gcoef_Morphism.
unfold Pminus;simpl.
rewrite Pdouble_minus_one_o_succ_eq_xI;setoid ring.
unfold Pminus;simpl; setoid ring.
unfold Pminus;simpl; setoid ring.

rewrite Padd_sym;simpl Pol_add;rewrite ZPminuspos;rewrite mkPX_PX_c.
simpl.
caseEq p; intros;
caseEq p1;intros;simpl;
try rewrite PX_Padd_r;try rewrite PX_pq_pq;rewrite IHn;
rewrite cadd_sym;apply cadd_ext;setoid ring;
apply gcoef_Morphism.

simpl.
cut ((xI (p3 +  p2) = xO (Pplus_carry p2 p3) - 1)%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
unfold Pminus;simpl.
assert (Pdouble_minus_one (Pplus_carry p2  p3) = (xO p3 + xI p2)%positive).
rewrite Pplus_carry_spec.
rewrite Pdouble_minus_one_o_succ_eq_xI.
rewrite Pplus_comm;reflexivity.
rewrite H1;auto with arith.
simpl.
cut ((xO (p3 + p2) = xI(p2 + p3) - 1)%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
unfold Pminus;simpl; rewrite Pplus_comm;trivial.
simpl.
cut ((xI p2 = (xO (Psucc p2) - 1))%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
unfold Pminus;simpl.
rewrite  Pdouble_minus_one_o_succ_eq_xI; trivial.
cut (((xI p3 + (xO p2 - 1)) = (xI (p2 + p3) - 1))%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
rewrite xI_succ_xO.
rewrite Pplus_one_succ_r.
rewrite <- Pplus_assoc.
rewrite Pplus_minus.
unfold Pminus;simpl; rewrite Pplus_comm;trivial.
simpl; trivial.
cut ((xO p3 + (xO p2 - 1) =(xO (p2 + p3) - 1))%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
assert ((xO p3 + xO p2  = xO(p2 + p3))%positive).
simpl; rewrite Pplus_comm;trivial.
rewrite <- H1.
apply Pplus_Pminus1_assoc.
cut (( 1 + (xO p2 - 1)=(xI p2 - 1) )%positive).
intro h1; rewrite h1; apply Eq_PX_PX; try setoid ring; try setoid ring.
rewrite xI_succ_xO; rewrite Pplus_one_succ_l;rewrite Pplus_Pminus1_assoc; trivial.
unfold Pminus;simpl.
rewrite Pdouble_minus_one_o_succ_eq_xI;setoid ring.
unfold Pminus;simpl; setoid ring.
unfold Pminus;simpl; setoid ring.
Qed.

(*
Definition  even_odd_dec : forall n, {even n} + {odd n}.
induction n.
auto with arith.
elim IHn; auto with arith.
Defined.
*)

Section ListAux.

Variable A: Set.
Theorem length_app:
 forall (l1 l2 : list A),  length (app l1  l2) = (length l1 + length l2)%nat.
intros l1; elim l1; simpl; auto.
Qed.

End ListAux.

Section Det.

(* Polynomial addition plus scalar *)
Notation  pol:= Pol.
Notation add :=Pol_add.
Definition scal :Coef -> pol -> pol.
intros c P; exact (Pol_mul_Rat P c).
Defined.

Section phi.
Variable d:nat.
(*Variable n:nat.
Hypothesis n_le_d:  (n<= d)%nat.*)

Definition phi (n:nat) := if (le_gt_dec  (d+2) n) then (fun P: Pol => Pc c0) else
                          match n with
                                         O => (fun P: Pol => Pc c0)
                                      | S O => (fun P:Pol => P)
                                      | _ =>  match even_odd_dec n with
                                                left _ =>  (fun P : Pol => Pc (get_coef (d - (n-2)) P))
				     		|  right _  => (fun P : Pol => Pc (-- get_coef (d - (n-2)) P))
                                                 end
                               end.

Lemma phi_scal : forall n a P, phi n (a !* P) != a !* (phi n P).
intros;unfold phi;
case (le_gt_dec (d+2) n  ); intros;simpl.
rewrite Pscal_Pc; constructor;setoid ring.
case n;simpl.
rewrite Pscal_Pc; constructor;setoid ring.
intros;case n0.
setoid ring.
intros;simpl.
match goal with |- context [if ?X then _ else _ ] => case X end;
rewrite gcoef_Pmul_Rat;
rewrite Pscal_Pc;
constructor;setoid ring;simpl;ring.
Qed.

Lemma phi_Padd: forall n  P Q, phi n (P + Q) != phi n P + phi n Q.
intros;unfold phi;
case (le_gt_dec (d+2)n); intros.
simpl;constructor; setoid ring.
intros;case n;simpl.
constructor;setoid ring.
intros;case n0.
setoid ring.

intros;simpl.
match goal with |- context [if ?X then _ else _ ] => case X end;intros;
rewrite gcoef_Padd;
simpl;try apply PolEq_refl.
constructor;setoid ring.
Qed.

Add Morphism phi  with signature (@eq nat) ==> Pol_Eq ==> Pol_Eq  as phi_Morphism.
intros n P Q;unfold phi;case (le_gt_dec (d+2)n); intros.
setoid ring.

case n;simpl.
intros;setoid ring.
intros;case n0; trivial.
intros;match goal with |- context [if ?X then _ else _ ] => case X end;
intros;simpl;
rewrite H;setoid ring.
Qed.

(* Hypothesis phi_m: forall n a b c d, phi n (add (scal a  b) (scal c  d)) = a !* phi n b + c !* phi n d.*)
Lemma  phi_m: forall n a b c d, phi n (add (scal a  b) (scal c  d)) != a !* phi n b + c !* phi n d.
intros ; unfold scal.
rewrite phi_Padd.
repeat rewrite phi_scal.
setoid ring.
Qed.

(*

(* The function that takes coeff that behaves ok *)
Variable phi: nat -> pol -> pol.

Hypothesis phi_m: forall n a b c d, phi n (add (scal a  b) (scal c  d)) = a !* phi n b + c !* phi n d.
*)
End phi.

End Det.


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

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sha_sel_upp_reduce :
  forall T1 x1 L1 ss1 T1', T1 = (t_sha_sel x1 L1 ss1 T1') ->
                      forall T2 L2 T2', T2 = t_upp L2 T2' ->
                                   subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


(* Coq tactics, ready to be copy-pasted into your current project.
 *)

(* Breaks an exsistential quantifier out into it's pieces *)
Ltac break_step H :=
  match type of H with
  (exists x, _) =>
    let x' := fresh x in
    destruct H as [x' H]
  end.

Ltac break H :=
  repeat (break_step H).

Example break_unit :
  (exists a b, a /\ b)
  -> (exists a b, a /\ b)
  -> (exists a b, a \/ b).
Proof.
  intros Hab Hab2.
  break Hab.
  exists a, b.
  destruct Hab as [Ha Hb].
  left; assumption.
Qed.

(** refl:
Because I can't spell reflexivity.
 **)

Ltac refl_step :=
  match goal with
    (* if it works, it works *)
  | |- _ => reflexivity
  | |- _ = _ => assumption
    (* clear the H after use make sure that no infinite
       recursion happens *)
  | [ H : _ = _ |- _ ] =>
    rewrite <- H; clear H
  | [ H : _ = _ |- _ ] =>
    rewrite -> H; clear H
  end.

Ltac refl :=
  (* define refl to repeat until success, or fail *)
  repeat refl_step; fail.

Example refl_unit :
  forall a, a = 1 -> a = 1.
Proof.
  intros a Ha.
  refl.
Qed.

Example refl_rev_unit :
  forall a, 1 = a -> a = 1.
Proof.
  intros a Ha.
  refl.
Qed.

Example refl_trans_unit :
  forall a b c : Type, a = b -> b = c -> a = c.
Proof.
  intros a b c Hab Hbc.
  refl.
Qed.

(** UNROLL **)

Require Import List.
Import ListNotations.

(* Try to prove that something is not in a list*)
Ltac unroll_false_step H :=
  match type of H with
  | In _ _ =>
    unfold In in H
  | _ \/ _ =>
    destruct H as [H | H]
  | _ = _ =>
    discriminate
  | _ =>
    congruence
  | False =>
    destruct H
  end.

Tactic Notation "unroll" "in" hyp(H) :=
  repeat (unroll_false_step H);
  try match type of H with
        (* clean up unfolding *)
        _ ?x ?l =>
        fold (In x l) in H
      end.

Example unroll_false_unit:
  ~ In 4 [1; 2; 3].
Proof.
  intros H.
  unroll in H.
Qed.

(* Try to prove that something is in a list *)
Ltac unroll_step :=
  match goal with
  | |- ~ In _ _ =>
    let H := fresh "Hunroll" in
    intro H; unroll in H
  | |- In _ (_ :: _) =>
    unfold In
  | |- _ \/ _  => left; refl
  | |- _ \/ _  => right
  | |- _ => assumption
  end.

Ltac unroll :=
  repeat unroll_step;
  try match goal with
        (* clean up unfolding *)
        [ |- _ ?x ?l ] => fold (In x l)
      end.

Example unroll_not_unit:
  ~ In 4 [1; 2; 3].
Proof.
  unroll.
Qed.

Example unroll_in_unit:
  In 3 [1; 2; 3].
Proof.
  unroll.
Qed.

Example unroll_exists_unit:
  exists e, In (3, e) [(1,1); (2, 2); (3, 3)].
Proof.
  eexists.
  unroll.
Qed.

Example unroll_forall_unit:
  forall e, In e [1; 2; 3] -> In (e, 1) [(1,1); (2, 1); (3, 1)].
Proof.
  intros e He.
  unroll in He; unroll.
Qed.

Example unroll_little_list_unit:
  forall ls, forall e a : Set,
    In e (a :: ls)
    -> a <> e
    -> In e ls.
Proof.
  intros ls e a Hin Hneq.
  unroll in Hin.
  assumption.
Qed.