From Hammer Require Import Hammer.

From hahn Require Import HahnBase.
Require Import List Omega Relations Setoid Morphisms.

Set Implicit Arguments.

Section SetDefs.

Variables A B : Type.
Implicit Type f : A -> B.
Implicit Type s : A -> Prop.
Implicit Type ss : A -> B -> Prop.

Definition set_empty       := fun x : A => False.
Definition set_full        := fun x : A => True.
Definition set_compl s     := fun x => ~ (s x).
Definition set_union s s'  := fun x => s x \/ s' x.
Definition set_inter s s'  := fun x => s x /\ s' x.
Definition set_minus s s'  := fun x => s x /\ ~ (s' x).
Definition set_subset s s' := forall x, s x -> s' x.
Definition set_equiv s s'  := set_subset s s' /\ set_subset s' s.
Definition set_finite s    := exists findom, forall x (IN: s x), In x findom.
Definition set_coinfinite s:= ~ set_finite (set_compl s).
Definition set_collect f s := fun x => exists y, s y /\ f y = x.
Definition set_bunion s ss := fun x => exists y, s y /\ ss y x.
Definition set_disjoint s s':= forall x (IN: s x) (IN': s' x), False.

End SetDefs.

Arguments set_empty {A}.
Arguments set_full {A}.
Arguments set_subset {A}.
Arguments set_equiv {A}.

Notation "P ∪₁ Q" := (set_union P Q) (at level 50, left associativity).
Notation "P ∩₁ Q" := (set_inter P Q) (at level 40, left associativity).
Notation "P \₁ Q" := (set_minus P Q) (at level 46).
Notation "∅"     := (@set_empty _).
Notation "a ⊆₁ b" := (set_subset a b) (at level 60).
Notation "a ≡₁ b" := (set_equiv a b)  (at level 60).
Notation "⋃₁ x ∈ s , a" := (set_bunion s (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃₁ '/ ' x  ∈  s ,  '/ ' a ']'").
Notation "'⋃₁' x , a" := (set_bunion (fun _ => True) (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃₁ '/ ' x ,  '/ ' a ']'").
Notation "'⋃₁' x < n , a" := (set_bunion (fun t => t < n) (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃₁ '/ ' x  <  n ,  '/ ' a ']'").
Notation "'⋃₁' x <= n , a" := (set_bunion (fun t => t <= n) (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃₁ '/ ' x  <=  n ,  '/ ' a ']'").

Hint Unfold set_empty set_full set_compl set_union set_inter : unfolderDb.
Hint Unfold set_minus set_subset set_equiv set_coinfinite set_finite : unfolderDb.
Hint Unfold set_collect set_bunion set_disjoint : unfolderDb.

Section SetProperties.
Local Ltac u :=
repeat autounfold with unfolderDb in *;
ins; try solve [tauto | firstorder | split; ins; tauto].

Variables A B C : Type.
Implicit Type a : A.
Implicit Type f : A -> B.
Implicit Type s : A -> Prop.
Implicit Type ss : A -> B -> Prop.

Lemma set_compl_empty : set_compl ∅ ≡₁ @set_full A.
Proof. hammer_hook "HahnSets" "HahnSets.set_compl_empty". u. Qed.

Lemma set_compl_full : set_compl (@set_full A) ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_compl_full". u. Qed.

Lemma set_compl_compl s : set_compl (set_compl s) ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_compl_compl". u. Qed.

Lemma set_compl_union s s' :
set_compl (s ∪₁ s') ≡₁ set_compl s ∩₁ set_compl s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_compl_union". u. Qed.

Lemma set_compl_inter s s' :
set_compl (s ∩₁ s') ≡₁ set_compl s ∪₁ set_compl s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_compl_inter". u. Qed.

Lemma set_compl_minus s s' :
set_compl (s \₁ s') ≡₁ s' ∪₁ set_compl s.
Proof. hammer_hook "HahnSets" "HahnSets.set_compl_minus". u. Qed.

Lemma set_unionA s s' s'' : (s ∪₁ s') ∪₁ s'' ≡₁ s ∪₁ (s' ∪₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_unionA". u. Qed.

Lemma set_unionC s s' : s ∪₁ s' ≡₁ s' ∪₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_unionC". u. Qed.

Lemma set_unionK s : s ∪₁ s ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_unionK". u. Qed.

Lemma set_union_empty_l s : ∅ ∪₁ s ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_union_empty_l". u. Qed.

Lemma set_union_empty_r s : s ∪₁ ∅ ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_union_empty_r". u. Qed.

Lemma set_union_full_l s : set_full ∪₁ s ≡₁ set_full.
Proof. hammer_hook "HahnSets" "HahnSets.set_union_full_l". u. Qed.

Lemma set_union_full_r s : s ∪₁ set_full ≡₁ set_full.
Proof. hammer_hook "HahnSets" "HahnSets.set_union_full_r". u. Qed.

Lemma set_union_inter_l s s' s'' : (s ∩₁ s') ∪₁ s'' ≡₁ (s ∪₁ s'') ∩₁ (s' ∪₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_union_inter_l". u. Qed.

Lemma set_union_inter_r s s' s'' : s ∪₁ (s' ∩₁ s'') ≡₁ (s ∪₁ s') ∩₁ (s ∪₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_union_inter_r". u. Qed.

Lemma set_union_eq_empty s s' : s ∪₁ s' ≡₁ ∅ <-> s ≡₁ ∅ /\ s' ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_union_eq_empty". u. Qed.

Lemma set_interA s s' s'' : (s ∩₁ s') ∩₁ s'' ≡₁ s ∩₁ (s' ∩₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_interA". u. Qed.

Lemma set_interC s s' : s ∩₁ s' ≡₁ s' ∩₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_interC". u. Qed.

Lemma set_interK s : s ∩₁ s ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_interK". u. Qed.

Lemma set_inter_empty_l s : ∅ ∩₁ s ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_empty_l". u. Qed.

Lemma set_inter_empty_r s : s ∩₁ ∅ ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_empty_r". u. Qed.

Lemma set_inter_full_l s : set_full ∩₁ s ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_full_l". u. Qed.

Lemma set_inter_full_r s : s ∩₁ set_full ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_full_r". u. Qed.

Lemma set_inter_union_l s s' s'' : (s ∪₁ s') ∩₁ s'' ≡₁ (s ∩₁ s'') ∪₁ (s' ∩₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_union_l". u. Qed.

Lemma set_inter_union_r s s' s'' : s ∩₁ (s' ∪₁ s'') ≡₁ (s ∩₁ s') ∪₁ (s ∩₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_union_r". u. Qed.

Lemma set_inter_minus_l s s' s'' : (s \₁ s') ∩₁ s'' ≡₁ (s ∩₁ s'') \₁ s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_minus_l". u. Qed.

Lemma set_inter_minus_r s s' s'' : s ∩₁ (s' \₁ s'') ≡₁ (s ∩₁ s') \₁ s''.
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_minus_r". u. Qed.

Lemma set_minusE s s' : s \₁ s' ≡₁ s ∩₁ set_compl s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_minusE". u. Qed.

Lemma set_minusK s : s \₁ s ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_minusK". u. Qed.

Lemma set_minus_inter_l s s' s'' :
(s ∩₁ s') \₁ s'' ≡₁ (s \₁ s'') ∩₁ (s' \₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_minus_inter_l". u. Qed.

Lemma set_minus_inter_r s s' s'' :
s \₁ (s' ∩₁ s'') ≡₁ (s \₁ s') ∪₁ (s \₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_minus_inter_r". u; split; ins; tauto. Qed.

Lemma set_minus_union_l s s' s'' :
(s ∪₁ s') \₁ s'' ≡₁ (s \₁ s'') ∪₁ (s' \₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_minus_union_l". u. Qed.

Lemma set_minus_union_r s s' s'' :
s \₁ (s' ∪₁ s'') ≡₁ (s \₁ s') ∩₁ (s \₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_minus_union_r". u. Qed.

Lemma set_minus_minus_l s s' s'' :
s \₁ s' \₁ s'' ≡₁ s \₁ (s' ∪₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_minus_minus_l". u. Qed.

Lemma set_minus_minus_r s s' s'' :
s \₁ (s' \₁ s'') ≡₁ (s \₁ s') ∪₁ (s ∩₁ s'').
Proof. hammer_hook "HahnSets" "HahnSets.set_minus_minus_r". u. Qed.

Lemma set_subsetE s s' : s ⊆₁ s' <-> s \₁ s' ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_subsetE". u; intuition; apply NNPP; firstorder. Qed.

Lemma set_subset_eq (P : A -> Prop) a (H : P a): eq a ⊆₁ P.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_eq". by intros x H'; subst. Qed.

Lemma set_subset_refl : reflexive _ (@set_subset A).
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_refl". u. Qed.

Lemma set_subset_trans : transitive _ (@set_subset A).
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_trans". u. Qed.

Lemma set_subset_empty_l s : ∅ ⊆₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_empty_l". u. Qed.

Lemma set_subset_empty_r s : s ⊆₁ ∅ <-> s ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_empty_r". u. Qed.

Lemma set_subset_full_l s : set_full ⊆₁ s <-> s ≡₁ set_full.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_full_l". u. Qed.

Lemma set_subset_full_r s : s ⊆₁ set_full.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_full_r". u. Qed.

Lemma set_subset_union_l s s' s'' : s ∪₁ s' ⊆₁ s'' <-> s ⊆₁ s'' /\ s' ⊆₁ s''.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_union_l". u. Qed.

Lemma set_subset_union_r1 s s' : s ⊆₁ s ∪₁ s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_union_r1". u. Qed.

Lemma set_subset_union_r2 s s' : s' ⊆₁ s ∪₁ s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_union_r2". u. Qed.

Lemma set_subset_union_r s s' s'' : s ⊆₁ s' \/ s ⊆₁ s'' -> s ⊆₁ s' ∪₁ s''.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_union_r". u. Qed.

Lemma set_subset_inter_r s s' s'' : s ⊆₁ s' ∩₁ s'' <-> s ⊆₁ s' /\ s ⊆₁ s''.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_inter_r". u. Qed.

Lemma set_subset_compl s s' (S1: s' ⊆₁ s) : set_compl s ⊆₁ set_compl s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_compl". u. Qed.

Lemma set_subset_inter s s' (S1: s ⊆₁ s') t t' (S2: t ⊆₁ t') : s ∩₁ t ⊆₁ s' ∩₁ t'.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_inter". u. Qed.

Lemma set_subset_union s s' (S1: s ⊆₁ s') t t' (S2: t ⊆₁ t') : s ∪₁ t ⊆₁ s' ∪₁ t'.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_union". u. Qed.

Lemma set_subset_minus s s' (S1: s ⊆₁ s') t t' (S2: t' ⊆₁ t) : s \₁ t ⊆₁ s' \₁ t'.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_minus". u. Qed.

Lemma set_subset_bunion_l s ss sb (H: forall x (COND: s x), ss x ⊆₁ sb) : (⋃₁x ∈ s, ss x) ⊆₁ sb.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_bunion_l". u. Qed.

Lemma set_subset_bunion_r s ss sb a (H: s a) (H': sb ⊆₁ ss a) : sb ⊆₁ ⋃₁x ∈ s, ss x.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_bunion_r". u. Qed.

Lemma set_subset_bunion s s' (S: s ⊆₁ s') ss ss' (SS: forall x (COND: s x), ss x ⊆₁ ss' x) :
(⋃₁x ∈ s, ss x) ⊆₁ ⋃₁x ∈ s, ss' x.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_bunion". u. Qed.

Lemma set_subset_bunion_guard s s' (S: s ⊆₁ s') ss ss' (EQ: ss = ss') :
(⋃₁x ∈ s, ss x) ⊆₁ (⋃₁x ∈ s', ss' x).
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_bunion_guard". subst; u. Qed.

Lemma set_subset_collect f s s' (S: s ⊆₁ s') : set_collect f s ⊆₁ set_collect f s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_collect". u. Qed.

Lemma set_equivE s s' : s ≡₁ s' <-> s ⊆₁ s' /\ s' ⊆₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_equivE". u; firstorder. Qed.

Lemma set_equiv_refl : reflexive _ (@set_equiv A).
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_refl". u. Qed.

Lemma set_equiv_symm : symmetric _ (@set_equiv A).
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_symm". u. Qed.

Lemma set_equiv_trans : transitive _ (@set_equiv A).
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_trans". u. Qed.

Lemma set_equiv_compl s s' (S1: s ≡₁ s') : set_compl s ≡₁ set_compl s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_compl". u. Qed.

Lemma set_equiv_inter s s' (S1: s ≡₁ s') t t' (S2: t ≡₁ t') : s ∩₁ t ≡₁ s' ∩₁ t'.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_inter". u. Qed.

Lemma set_equiv_union s s' (S1: s ≡₁ s') t t' (S2: t ≡₁ t') : s ∪₁ t ≡₁ s' ∪₁ t'.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_union". u. Qed.

Lemma set_equiv_minus s s' (S1: s ≡₁ s') t t' (S2: t ≡₁ t') : s \₁ t ≡₁ s' \₁ t'.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_minus". u. Qed.

Lemma set_equiv_bunion s s' (S: s ≡₁ s') ss ss' (SS: forall x (COND: s x), ss x ≡₁ ss' x) :
set_bunion s ss ≡₁ set_bunion s' ss'.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_bunion". u. Qed.

Lemma set_equiv_bunion_guard s s' (S: s ≡₁ s') ss ss' (EQ: ss = ss') : set_bunion s ss ≡₁ set_bunion s' ss'.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_bunion_guard". subst; u. Qed.

Lemma set_equiv_collect f s s' (S: s ≡₁ s') : set_collect f s ⊆₁ set_collect f s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_collect". u. Qed.

Lemma set_equiv_subset s s' (S1: s ≡₁ s') t t' (S2: t ≡₁ t') : s ⊆₁ t <-> s' ⊆₁ t'.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_subset". u. Qed.

Lemma set_equiv_exp s s' (EQ: s ≡₁ s') : forall x, s x <-> s' x.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_exp". split; apply EQ. Qed.

Lemma set_union_absorb_l s s' (SUB: s ⊆₁ s') : s ∪₁ s' ≡₁ s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_union_absorb_l". u. Qed.

Lemma set_union_absorb_r s s' (SUB: s ⊆₁ s') : s' ∪₁ s ≡₁ s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_union_absorb_r". u. Qed.

Lemma set_inter_absorb_l s s' (SUB: s ⊆₁ s') : s' ∩₁ s ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_absorb_l". u. Qed.

Lemma set_inter_absorb_r s s' (SUB: s ⊆₁ s') : s ∩₁ s' ≡₁ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_inter_absorb_r". u. Qed.

Lemma set_minus_absorb_l s s' (SUB: s ⊆₁ s') : s \₁ s' ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_minus_absorb_l". u. Qed.

Lemma set_subset_single_l a s : eq a ⊆₁ s <-> s a.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_single_l". u; intuition; desf. Qed.

Lemma set_subset_single_r a s :
s ⊆₁ eq a <-> s ≡₁ eq a \/ s ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_single_r".
u; intuition; firstorder.
destruct (classic (exists b, s b)) as [M|M]; desf.
left; split; ins; desf; eauto.
specialize (H _ M); desf.
right; split; ins; eauto.
Qed.

Lemma set_subset_single_single a b :
eq a ⊆₁ eq b <-> a = b.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_single_single". u; intuition; desf; eauto using eq_sym. Qed.

Lemma set_equiv_single_single a b :
eq a ≡₁ eq b <-> a = b.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_single_single". u; intuition; desf; apply H; ins. Qed.

Lemma set_nonemptyE s : ~ s ≡₁ ∅ <-> exists x, s x.
Proof. hammer_hook "HahnSets" "HahnSets.set_nonemptyE".
u; intuition; firstorder.
apply NNPP; intro; apply H0; ins; eauto.
Qed.

Lemma set_bunion_empty ss : set_bunion ∅ ss ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_bunion_empty". u. Qed.

Lemma set_bunion_eq a ss : set_bunion (eq a) ss ≡₁ ss a.
Proof. hammer_hook "HahnSets" "HahnSets.set_bunion_eq". u; splits; ins; desf; eauto. Qed.

Lemma set_bunion_union_l s s' ss :
set_bunion (s ∪₁ s') ss ≡₁ set_bunion s ss ∪₁ set_bunion s' ss.
Proof. hammer_hook "HahnSets" "HahnSets.set_bunion_union_l". u. Qed.

Lemma set_bunion_union_r s ss ss' :
set_bunion s (fun x => ss x ∪₁ ss' x) ≡₁ set_bunion s ss ∪₁ set_bunion s ss'.
Proof. hammer_hook "HahnSets" "HahnSets.set_bunion_union_r". u. Qed.

Lemma set_bunion_bunion_l s ss (ss' : B -> C -> Prop) :
(⋃₁x ∈ (⋃₁y ∈ s, ss y), ss' x) ≡₁ ⋃₁y ∈ s, ⋃₁x ∈ ss y, ss' x.
Proof. hammer_hook "HahnSets" "HahnSets.set_bunion_bunion_l". u. Qed.

Lemma set_bunion_inter_compat_l s sb ss :
set_bunion s (fun x => sb ∩₁ ss x) ≡₁ sb ∩₁ set_bunion s ss.
Proof. hammer_hook "HahnSets" "HahnSets.set_bunion_inter_compat_l". u; split; ins; desf; eauto 8. Qed.

Lemma set_bunion_inter_compat_r s sb ss :
set_bunion s (fun x => ss x ∩₁ sb) ≡₁ set_bunion s ss ∩₁ sb.
Proof. hammer_hook "HahnSets" "HahnSets.set_bunion_inter_compat_r". u; split; ins; desf; eauto 8. Qed.

Lemma set_bunion_minus_compat_r s sb ss :
set_bunion s (fun x => ss x \₁ sb) ≡₁ set_bunion s ss \₁ sb.
Proof. hammer_hook "HahnSets" "HahnSets.set_bunion_minus_compat_r". u; split; ins; desf; eauto 8. Qed.

Lemma set_collectE f s : set_collect f s ≡₁ set_bunion s (fun x => eq (f x)).
Proof. hammer_hook "HahnSets" "HahnSets.set_collectE". u. Qed.

Lemma set_collect_empty f : set_collect f ∅ ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_collect_empty". u. Qed.

Lemma set_collect_eq f a : set_collect f (eq a) ≡₁ eq (f a).
Proof. hammer_hook "HahnSets" "HahnSets.set_collect_eq". u; splits; ins; desf; eauto. Qed.

Lemma set_collect_union f s s' :
set_collect f (s ∪₁ s') ≡₁ set_collect f s ∪₁ set_collect f s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_collect_union". u. Qed.

Lemma set_collect_bunion f (s : B -> Prop) (ss : B -> A -> Prop) :
set_collect f (⋃₁x ∈ s, ss x) ≡₁ ⋃₁x ∈ s, set_collect f (ss x).
Proof. hammer_hook "HahnSets" "HahnSets.set_collect_bunion". u. Qed.

Lemma set_finite_empty : set_finite (A:=A) ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_finite_empty". exists nil; ins. Qed.

Lemma set_finite_eq a : set_finite (eq a).
Proof. hammer_hook "HahnSets" "HahnSets.set_finite_eq". exists (a :: nil); ins; desf; eauto. Qed.

Lemma set_finite_le n : set_finite (fun t => t <= n).
Proof. hammer_hook "HahnSets" "HahnSets.set_finite_le". exists (List.seq 0 (S n)); intros; apply in_seq; ins; auto with arith. Qed.

Lemma set_finite_lt n : set_finite (fun t => t < n).
Proof. hammer_hook "HahnSets" "HahnSets.set_finite_lt". exists (List.seq 0 n); intros; apply in_seq; ins; auto with arith. Qed.

Lemma set_finite_union s s' : set_finite (s ∪₁ s') <-> set_finite s /\ set_finite s'.
Proof. hammer_hook "HahnSets" "HahnSets.set_finite_union".
u; split; splits; ins; desf; eauto.
eexists (_ ++ _); ins; desf; eauto using in_or_app.
Qed.

Lemma set_finite_unionI s (F: set_finite s) s' (F': set_finite s') : set_finite (s ∪₁ s').
Proof. hammer_hook "HahnSets" "HahnSets.set_finite_unionI".
u; desf; eauto; eexists (_ ++ _); ins; desf; eauto using in_or_app.
Qed.

Lemma set_finite_bunion s (F: set_finite s) ss :
set_finite (set_bunion s ss) <-> forall a (COND: s a), set_finite (ss a).
Proof. hammer_hook "HahnSets" "HahnSets.set_finite_bunion".
u; split; ins; desf; eauto.
revert s F H; induction findom; ins.
by exists nil; ins; desf; eauto.
specialize (IHfindom (fun x => s x /\ x <> a)); ins.
specialize_full IHfindom; ins; desf; eauto.
by apply F in IN; desf; eauto.
tertium_non_datur (s a) as [X|X].
eapply H in X; desf.
eexists (findom0 ++ findom1); ins; desf.
tertium_non_datur (y = a); desf; eauto 8 using in_or_app.
eexists findom0; ins; desf; apply IHfindom; eexists; splits; eauto; congruence.
Qed.

Lemma set_disjointE s s' : set_disjoint s s' <-> s ∩₁ s' ≡₁ ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjointE". u. Qed.

Lemma set_disjointC s s' : set_disjoint s s' <-> set_disjoint s' s.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjointC". u. Qed.

Lemma set_disjoint_empty_l s : set_disjoint ∅ s.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_empty_l". u. Qed.

Lemma set_disjoint_empty_r s : set_disjoint s ∅.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_empty_r". u. Qed.

Lemma set_disjoint_eq_l a s : set_disjoint (eq a) s <-> ~ s a.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_eq_l". u; split; ins; desf; eauto. Qed.

Lemma set_disjoint_eq_r a s : set_disjoint s (eq a) <-> ~ s a.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_eq_r". u; split; ins; desf; eauto. Qed.

Lemma set_disjoint_eq_eq a b : set_disjoint (eq a) (eq b) <-> a <> b.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_eq_eq". u; split; ins; desf; eauto. Qed.

Lemma set_disjoint_union_l s s' s'' :
set_disjoint (s ∪₁ s') s'' <-> set_disjoint s s'' /\ set_disjoint s' s''.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_union_l". u. Qed.

Lemma set_disjoint_union_r s s' s'' :
set_disjoint s (s' ∪₁ s'') <-> set_disjoint s s' /\ set_disjoint s s''.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_union_r". u. Qed.

Lemma set_disjoint_bunion_l s ss sr :
set_disjoint (set_bunion s ss) sr <-> forall x (IN: s x), set_disjoint (ss x) sr.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_bunion_l". u. Qed.

Lemma set_disjoint_bunion_r s ss sr :
set_disjoint sr (set_bunion s ss) <-> forall x (IN: s x), set_disjoint sr (ss x).
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_bunion_r". u. Qed.

Lemma set_disjoint_subset_l s s' (SUB: s ⊆₁ s') s'' :
set_disjoint s' s'' -> set_disjoint s s''.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_subset_l". u. Qed.

Lemma set_disjoint_subset_r s s' (SUB: s ⊆₁ s') s'' :
set_disjoint s'' s' -> set_disjoint s'' s.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_subset_r". u. Qed.

Lemma set_disjoint_subset s s' (SUB: s ⊆₁ s') sr sr' (SUB': sr ⊆₁ sr') :
set_disjoint s' sr' -> set_disjoint s sr.
Proof. hammer_hook "HahnSets" "HahnSets.set_disjoint_subset". u. Qed.

Lemma set_le n : (fun i => i <= n) ≡₁ (fun i => i < n) ∪₁ (eq n).
Proof. hammer_hook "HahnSets" "HahnSets.set_le".
u; intuition; omega.
Qed.

Lemma set_lt n : (fun i => i < n) ≡₁ (fun i => i <= n) \₁ (eq n).
Proof. hammer_hook "HahnSets" "HahnSets.set_lt".
u; intuition; omega.
Qed.

End SetProperties.

Lemma set_finite_coinfinite_nat (s: nat -> Prop) :
set_finite s -> set_coinfinite s.
Proof. hammer_hook "HahnSets" "HahnSets.set_finite_coinfinite_nat".
assert (LT: forall l x, In x l -> x <= fold_right Init.Nat.add 0 l).
induction l; ins; desf; try apply IHl in H; omega.
repeat autounfold with unfolderDb; red; ins; desf.
tertium_non_datur (s (S (fold_right plus 0 findom + fold_right plus 0 findom0))) as [X|X];
[apply H in X | apply H0 in X]; apply LT in X; omega.
Qed.

Lemma set_coinfinite_fresh (s: nat -> Prop) (COINF: set_coinfinite s) :
exists b, ~ s b /\ set_coinfinite (s ∪₁ eq b).
Proof. hammer_hook "HahnSets" "HahnSets.set_coinfinite_fresh".
repeat autounfold with unfolderDb in *.
tertium_non_datur (forall b, s b).
by destruct COINF; exists nil; ins; desf.
exists n; splits; red; ins; desf.
apply COINF; exists (n :: findom); ins; desf; eauto.
specialize (H0 x); tauto.
Qed.

Add Parametric Relation A : (A -> Prop) (set_subset (A:=A))
reflexivity proved by (set_subset_refl (A:=A))
transitivity proved by (set_subset_trans (A:=A))
as set_subset_rel.

Add Parametric Relation A : (A -> Prop) (set_equiv (A:=A))
reflexivity proved by (set_equiv_refl (A:=A))
symmetry proved by (set_equiv_symm (A:=A))
transitivity proved by (set_equiv_trans (A:=A))
as set_equiv_rel.

Instance set_compl_Proper A : Proper (_ --> _) _ := set_subset_compl (A:=A).
Instance set_union_Proper A : Proper (_ ==> _ ==> _) _ := set_subset_union (A:=A).
Instance set_inter_Proper A : Proper (_ ==> _ ==> _) _ := set_subset_inter (A:=A).
Instance set_minus_Proper A : Proper (_ ++> _ --> _) _ := set_subset_minus (A:=A).
Instance set_bunion_Proper A B : Proper (_ ==> _ ==> _) _ := set_subset_bunion_guard (A:=A) (B:=B).

Instance set_compl_Propere A : Proper (_ ==> _) _ := set_equiv_compl (A:=A).
Instance set_union_Propere A : Proper (_ ==> _ ==> _) _ := set_equiv_union (A:=A).
Instance set_inter_Propere A : Proper (_ ==> _ ==> _) _ := set_equiv_inter (A:=A).
Instance set_minus_Propere A : Proper (_ ==> _ ==> _) _ := set_equiv_minus (A:=A).
Instance set_bunion_Propere A B : Proper (_ ==> _ ==> _) _ := set_equiv_bunion_guard (A:=A) (B:=B).
Instance set_subset_Proper A : Proper (_ ==> _ ==> _) _ := set_equiv_subset (A:=A).

Add Parametric Morphism A : (@set_finite A) with signature
set_subset --> Basics.impl as set_finite_mori.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_Proper". red; autounfold with unfolderDb; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_finite A) with signature
set_equiv ==> iff as set_finite_more.
Proof. red; autounfold with unfolderDb; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_coinfinite A) with signature
set_subset --> Basics.impl as set_coinfinite_mori.
Proof. unfold set_coinfinite; ins; rewrite H; ins. Qed.

Add Parametric Morphism A : (@set_coinfinite A) with signature
set_equiv ==> iff as set_coinfinite_more.
Proof. unfold set_coinfinite; ins; rewrite H; ins. Qed.

Add Parametric Morphism A B : (@set_collect A B) with signature
eq ==> set_subset ==> set_subset as set_collect_mori.
Proof. autounfold with unfolderDb; ins; desf; eauto. Qed.

Add Parametric Morphism A B : (@set_collect A B) with signature
eq ==> set_equiv ==> set_equiv as set_collect_more.
Proof. repeat autounfold with unfolderDb; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_disjoint A) with signature
set_subset --> set_subset --> Basics.impl as set_disjoint_mori.
Proof. red; autounfold with unfolderDb; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_disjoint A) with signature
set_equiv ==> set_equiv ==> iff as set_disjoint_more.
Proof. red; autounfold with unfolderDb; splits; ins; desf; eauto. Qed.

Lemma set_subset_refl2 A (x: A -> Prop) :  x ⊆₁ x.
Proof. hammer_hook "HahnSets" "HahnSets.set_subset_refl2". reflexivity. Qed.

Lemma set_equiv_refl2 A (x: A -> Prop) :  x ≡₁ x.
Proof. hammer_hook "HahnSets" "HahnSets.set_equiv_refl2". reflexivity. Qed.

Hint Immediate set_subset_refl2.
Hint Resolve set_equiv_refl2.

Hint Rewrite set_compl_empty set_compl_full set_compl_compl : hahn.
Hint Rewrite set_compl_union set_compl_inter set_compl_minus : hahn.
Hint Rewrite set_union_empty_l set_union_empty_r set_union_full_l set_union_full_r : hahn.
Hint Rewrite set_inter_empty_l set_inter_empty_r set_inter_full_l set_inter_full_r : hahn.
Hint Rewrite set_bunion_empty set_bunion_eq set_bunion_bunion_l : hahn.
Hint Rewrite set_collect_empty set_collect_eq set_collect_bunion : hahn.
Hint Rewrite set_finite_union : hahn.
Hint Rewrite set_disjoint_eq_eq set_disjoint_eq_l set_disjoint_eq_r : hahn.

Hint Rewrite set_inter_union_l set_inter_union_r set_union_eq_empty : hahn_full.
Hint Rewrite set_minus_union_l set_minus_union_r set_union_eq_empty : hahn_full.
Hint Rewrite set_subset_union_l set_subset_inter_r : hahn_full.
Hint Rewrite set_minusK set_interK set_unionK : hahn_full.
Hint Rewrite set_bunion_inter_compat_l set_bunion_inter_compat_r : hahn_full.
Hint Rewrite set_bunion_minus_compat_r : hahn_full.
Hint Rewrite set_bunion_union_l set_bunion_union_r : hahn_full.
Hint Rewrite set_collect_union : hahn_full.
Hint Rewrite set_disjoint_union_l set_disjoint_union_r : hahn_full.
Hint Rewrite set_disjoint_bunion_l set_disjoint_bunion_r : hahn_full.

Hint Immediate set_subset_empty_l set_subset_full_r : hahn.
Hint Immediate set_finite_empty set_finite_eq set_finite_le set_finite_lt : hahn.
Hint Immediate set_disjoint_empty_l set_disjoint_empty_r : hahn.

Hint Resolve set_subset_union_r : hahn.
Hint Resolve set_finite_unionI set_finite_bunion : hahn.


Require Import List.
From Coq Require Import Lia ssreflect.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Asymmetric Patterns.

Import ListNotations.

From Equations Require Import Equations.

Section list_size.
    Context {A : Type} (f : A -> nat).
    Equations list_size (l : list A) : nat :=
      {
        list_size nil := 0;
        list_size (cons x xs) := S (f x + list_size xs)
      }.
End list_size.

Section Map.

  Equations map_In {A B : Type}
     (l : list A) (f : forall (x : A), In x l -> B) : list B :=
  map_In nil _ := nil;
  map_In (cons x xs) f := cons (f x _) (map_In xs (fun x H => f x _)).

End Map.

Section Test.

  Variables (L U R : Type).

  Inductive Foo : Type :=
  | C1 : L -> Foo
  | C3 : L -> list Foo -> Foo.

  Inductive Result : Type :=
  | ULeaf : U -> Result
  | UNode : list Result -> Result.
  (* Derive NoConfusion for Result. *)

  Fixpoint rsize (r : Result) :=
    match r with
    | ULeaf a => 0
    | UNode l => S (list_size rsize l)
    end.

  Lemma In_result_rsize_leq r res :
    In r res ->
    rsize r < (list_size rsize res).
  Proof.
    funelim (list_size rsize res) => //=.
    case=> [-> | Hin]; [| have Hleq := (H r Hin)]; lia.
  Qed.

  Variables (Null : R) (resolve : U -> Result).

Set Equations  Debug.
  Equations? (noind) execute (initial_value : U) (foos : list Foo) : list R  :=
    {
      execute _ [] := [];

      execute initial_value (_ :: qs) := (complete_value (resolve initial_value)) ++ execute initial_value qs

          where complete_value (res : Result) : list R by wf (rsize res) :=
                  {
                    complete_value (UNode res) :=
                    concat (map_In res (fun r Hin => complete_value r));

                    complete_value (ULeaf res) := []
                  }

    }.

  all: do ?[by have Hleq := (In_result_rsize_leq r res Hin); lia].
  Qed.
  Print execute_unfold_clause_2_complete_value.

End Test.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith.

Require Import tacs.

Set Implicit Arguments.

Notation "R 'inc2' S" := (forall x y, R x y -> S x y) (at level 71).
Notation "R '~eq2' S" := (R inc2 S /\ S inc2 R) (at level 71).

Section included2.

  Variable (X Y : Type).

  Implicit Type (R T U : X -> Y -> Prop).

  Fact inc2_refl R : R inc2 R.
  Proof. auto. Qed.

  Fact inc2_trans R T U : R inc2 T -> T inc2 U -> R inc2 U.
  Proof. auto. Qed.

  Fact e2_refl R : R ~eq2 R.
  Proof. auto. Qed.

  Fact eq2_trans R T U : R ~eq2 T -> T ~eq2 U -> R ~eq2 U.
  Proof. intros [] []; split; auto. Qed.

End included2.

Reserved Notation "x '[' R '*>' y" (at level 70).
Reserved Notation "x '~[' R ']' y" (at level 70).

Section usual_closures.

  Variable (X : Type).

  Implicit Type (R T : X -> X -> Prop).

  (* Reflexive and transitive closure *)

  Inductive crt R : X -> X -> Prop :=
    | in_crt_1 : forall x y,        R x y
                          ->       x [R*> y

    | in_crt_2 : forall x,         x [R*> x

    | in_crt_3 : forall x y z,     x [R*> y
                          ->       y [R*> z
                          ->       x [R*> z
  where "x [ R *> y" := (crt R x y).

  (* Reflexive, symmetric and transitive closure *)

  Inductive crst R : X -> X -> Prop :=
    | in_crst_1 : forall x y,       R x y
                          ->       x ~[R] y

    | in_crst_2 : forall x,        x ~[R] x

    | in_crst_3 : forall x y,      x ~[R] y
                          ->       y ~[R] x

    | in_crst_4 : forall x y z,    x ~[R] y
                          ->       y ~[R] z
                          ->       x ~[R] z
  where "x ~[ R ] y" := (crst R x y).

  (* Symmetric closure *)

  Inductive cs R : X -> X -> Prop :=
    | in_cs_1 : forall x y,       R x y
                        ->     cs R x y

    | in_cs_2 : forall x y,    cs R x y
                        ->     cs R y x.

  Fact crt_inc R : R inc2 crt R.
  Proof.
    apply in_crt_1.
  Qed.

  Fact crt_mono R T : R inc2 T -> crt R inc2 crt T.
  Proof.
    intros H x y.
    induction 1 as [ | | x y ].
    constructor 1; auto.
  Admitted.

  Fact crt_idem R : crt (crt R) inc2 crt R.
  Proof.
    induction 1 as [ | | x y ]; auto.
  Admitted.

  Lemma crt_closure R T : R inc2 crt T <-> crt R inc2 crt T.
  Proof.
    split; intros H.
    apply inc2_trans with (2 := @crt_idem T).
    apply crt_mono, H.
    apply inc2_trans with (2 := H), crt_inc.
  Qed.

  Fact crst_inc R : R inc2 crst R.
  Proof.
  Admitted.

  Fact crst_mono R T : R inc2 T -> crst R inc2 crst T.
  Proof.
  Admitted.

  Fact crst_idem R : crst (crst R) inc2 crst R.
  Proof.
  Admitted.

  Lemma crst_closure R T : R inc2 crst T <-> crst R inc2 crst T.
  Proof.
  Admitted.

  Fact cs_inc R : R inc2 cs R.
  Proof. constructor 1; auto. Qed.

  Fact cs_mono R T : R inc2 T -> cs R inc2 cs T.
  Proof.
    intros H x y.
    induction 1.
    constructor 1; auto.
    constructor 2; auto.
  Qed.

  Fact cs_idem R : cs (cs R) inc2 cs R.
  Proof.
    induction 1; auto.
    constructor 2; auto.
  Qed.

  Fact crt_inc_crst R x y : x [R*> y -> x ~[R] y.
  Proof.
    induction 1 as [ | | ? y ].
  Admitted.

  Fact cs_inc_crst R : cs R inc2 crst R.
  Proof.
    induction 1.
  Admitted.

  Lemma crt_sym R : cs R inc2 R -> cs (crt R) inc2 crt R.
  Proof.
    intros H.
    induction 1 as [ | x y _ IHxy ]; auto.
    induction IHxy as [ | | x y ].
    constructor 1; apply H; constructor 2; constructor 1; auto.
    constructor 2.
    constructor 3 with y; auto.
  Qed.

  Lemma crst_eq_crt_cs R : crst R ~eq2 crt (cs R).
  Proof.
    split.
    induction 1 as [ | | | x y ].
    constructor 1; constructor 1; auto.
    constructor 2.
    apply crt_sym.
    apply cs_idem.
    constructor 2; constructor 1; auto.
    constructor 3 with y; auto.
    apply inc2_trans with (2 := @crst_idem _).
    apply inc2_trans with (2 := @crt_inc_crst _).
    apply crt_mono, cs_inc_crst.
  Qed.

End usual_closures.

Notation "x [ R *> y" := (crt R x y) (at level 70).
Notation "x ~[ R ] y" := (crst R x y) (at level 70).

Reserved Notation "x '[' R ',' n '>>' y" (at level 70).

Section rel_iter.

  Variable (X : Type).

  Implicit Type (R : X -> X -> Prop).

  Fixpoint rel_iter R n (x y : X) : Prop :=
    match n with
      | 0   => x = y
      | S n => exists a, R x a /\ a [ R , n >> y
    end
  where "x [ R , n >> y" := (rel_iter R n x y).

  Fact rel_iter_one R x y : R x y <-> x [R,1>> y.
  Proof.
    simpl; split.
    exists y; split; auto.
    intros (a & ? & ?); subst a; auto.
  Qed.

  Fact rel_iter_plus R n m x y : x [R,n+m>> y <-> exists a, x [R,n>> a /\ a [R,m>> y.
  Proof.
    revert x y; induction n as [ | n IHn ]; intros x y; split; simpl.

    exists x; auto.
    intros (a & ? & Ha); subst a; auto.

    intros (a & H1 & H2).
    apply IHn in H2.
    destruct H2 as (b & H2 & H3).
    exists b; split; auto; exists a; auto.

    intros (a & (b & H1 & H2) & H3).
    exists b; split; auto.
    apply IHn; exists a; auto.
  Qed.

  Fact rel_iter_inv R n x y : x [R,1+n>> y <-> exists a, x [R,n>> a /\ R a y.
  Proof.
    rewrite plus_comm, rel_iter_plus.
    split; intros (a & ? & ?); exists a;
    split; auto; apply (rel_iter_one R); auto.
  Qed.

  Lemma rel_iter_eq_crt R x y : x [R*> y <-> exists n, x [R,n>> y.
  Proof.
    split.

    induction 1 as [ | | x y z H1 (n1 & Hn1) H2 (n2 & Hn2) ].
    exists 1, y; simpl; auto.
    exists 0; simpl; auto.
    exists (n1+n2).
    apply rel_iter_plus.
    exists y; auto.

    intros (n & Hn).
    revert x y Hn; induction n as [ | n IHn ]; simpl; intros x z H.
    subst; constructor 2.
    destruct H as (y & H1 & H2).
    constructor 3 with y; auto.
    constructor 1; auto.
  Qed.

End rel_iter.

Notation "x [ R , n >> y" := (rel_iter R n x y) (at level 70).

Section normal.

  Variable (X : Type) (R : X -> X -> Prop).

  Definition normal m := forall x, ~ R m x.

  Fact normal_crt_stop m : normal m -> forall y, m [R*> y -> m = y.
  Proof.
    intros Hm y.
    rewrite rel_iter_eq_crt.
    intros ([ | n ] & Hn); simpl in Hn; auto.
    destruct Hn as (z & Hz & _).
    exfalso; revert Hz; apply Hm.
  Qed.

End normal.


Require Export Bool.
Require Export ZArith.
Require Export Reals.
Require Export Flocq.Core.Fcore_Raux.
Require Export Gappa_real.
Require Export Gappa_definitions.
Require Export Gappa_dyadic.

Lemma Zeq_bool_correct_t :
  forall m n : Z, Zeq_bool m n = true -> (m = n)%Z.
Proof.
intros m n H.
apply Zcompare_Eq_eq.
unfold Zeq_bool in H.
induction (m ?= n)%Z ; try discriminate.
exact (refl_equal _).
Qed.

Lemma Zlt_bool_correct_t :
  forall m n : Z, Zlt_bool m n = true -> (m < n)%Z.
Proof.
intros m n H.
generalize (Zlt_cases m n).
rewrite H.
trivial.
Qed.


Require Import eqv.

(* This file aims to compare the following variations of heterogenous equality with and without the axioms of extensionality and univalence *)

(* This is Conor McBride's "John Major Equality" *)
Inductive heq0 : forall {A B}, A -> B -> Type :=
| hrefl0 : forall {A} (a : A), heq0 a a.

(* I propose this one, I do not know if it has been studied elsewhere. *)
Inductive heq1 : forall {A B}, (A -> B) -> A -> B -> Type :=
| hrefl1 : forall {A} a, heq1 (fun x : A => x) a a.

(* This one was proposed to me by François Thiré to simplify the
statement of symmetry. *)
Inductive heq2 : forall {A B}, (A -> B) -> (B -> A) -> A -> B -> Type :=
| hrefl2 : forall {A} a, heq2 (fun x : A => x) (fun x : A => x) a a.

(* This looks like a natural middle step between heq2 and heq4 *)
Inductive heq3 : forall {A B}, (eqv A B) -> A -> B -> Type :=
| hrefl3 : forall {A} a, heq3 (eqv_refl A) a a.

(* This one is pretty close to the heterogeneous equality of Cubical
Type Theory (CTT) but in CTT the type equality used is also
heterogeneous (recursively). *)
Inductive heq4 : forall {A B}, (A == B) -> A -> B -> Type :=
| hrefl4 : forall {A} a, heq4 (eq_refl A) a a.

(* This is not an heterogeneous equality but a property of functions
   that implies beeing an equivalence. It arises naturally
   in the study of heq1. *)
Inductive isStrongEqv : forall {A B}, (A -> B) -> Type :=
| isStrongEqv_id : forall A, isStrongEqv (id A).

Section going_down.

Lemma heq4to3 {A B} {e : A == B} {a b} :
  heq4 e a b ->
  heq3 (id_to_eqv e) a b.
Proof.
  intros [].
  apply hrefl3.
Defined.

Lemma heq4to2 {A B} {e : A == B} {a b} :
  heq4 e a b ->
  heq2 (id_to_eqv e) (id_to_eqv (eq_sym e)) a b.
Proof.
  intros [].
  apply hrefl2.
Defined.

Lemma heq4to1 {A B} {e : A == B} {a b} :
  heq4 e a b ->
  heq1 (id_to_eqv e) a b.
Proof.
  intros [].
  apply hrefl1.
Defined.

Lemma heq4to0 {A B} {e : A == B} {a b} :
  heq4 e a b ->
  heq0 a b.
Proof.
  intros [].
  apply hrefl0.
Defined.

Lemma heq3to2 {A B} {f : eqv A B} {a b} :
  heq3 f a b ->
  heq2 f (eqv_sym f) a b.
Proof.
  intros [].
  apply hrefl2.
Defined.

Lemma heq3to1 {A B} {f : eqv A B} {a b} :
  heq3 f a b ->
  heq1 f a b.
Proof.
  intros [].
  apply hrefl1.
Defined.

Lemma heq3to0 {A B} {f : eqv A B} {a b} :
  heq3 f a b ->
  heq0 a b.
Proof.
  intros [].
  apply hrefl0.
Defined.

Lemma heq2to1 {A B} {f : A -> B} {g a b} :
  heq2 f g a b ->
  heq1 f a b.
Proof.
  intros [].
  apply hrefl1.
Defined.

Lemma heq2to0 {A B} {f : A -> B} {g a b} :
  heq2 f g a b ->
  heq0 a b.
Proof.
  intros [].
  apply hrefl0.
Defined.

Lemma heq1to0 {A B} {f : A -> B} {a b} :
  heq1 f a b ->
  heq0 a b.
Proof.
  intros [].
  apply hrefl0.
Defined.

End going_down.

Section heq1_eqv_heq3.

(* I am too lazy to prove this, maybe this requires extensionality *)
Hypothesis isProp_isEqv : forall A B (f : A -> B), isProp (isEqv f).

Lemma isProp_diag : forall A B f x, isProp_isEqv A B f x x == eq_refl x.
Proof.
  intros A B f x.
  apply isProp_eq.
  apply isProp_isEqv.
Defined.

(* From heq1 we can go back to heq3 *)
Lemma heq1to3 {A B} {f : eqv A B} {a b} :
  heq1 f a b ->
  heq3 f a b.
Proof.
  destruct f as (f, Hf).
  simpl.
  intro e.
  destruct e.
  assert (Hf == isEqv_id A).
  + apply isProp_isEqv.
  + rewrite X.
    apply hrefl3.
Defined.

(* And it is actually an equivalence *)
Lemma heq1to3_eqv {A B} {f : eqv A B} {a b} :
  eqv (heq1 f a b) (heq3 f a b).
Proof.
  exists heq1to3.
  apply (isEqv_intro heq3to1).
  - intro e.
    destruct e.
    simpl.
    rewrite isProp_diag.
    reflexivity.
  - destruct f as (f, Hf).
    simpl.
    intro e.
    destruct e.
    assert (Hf == isEqv_id A).
    + apply isProp_isEqv.
    + rewrite X.
      rewrite isProp_diag.
      reflexivity.
Defined.

End heq1_eqv_heq3.

Section going_up_with_existentials.

(* From heq0, we can go back all the way up to heq4 by existentially
quantifying on the missing piece of information: an equality between
A and B *)

Lemma heq0to4_ex {A B} {a : A} {b : B} :
  heq0 a b ->
  {e : A == B & heq4 e a b}.
Proof.
  intros [].
  exists (eq_refl A0).
  apply hrefl4.
Defined.

Lemma heq4to0_ex {A B} {a : A} {b : B} :
  {e : A == B & heq4 e a b} -> heq0 a b.
Proof.
  intros (e, h).
  destruct h.
  apply hrefl0.
Defined.

Lemma heq0to4_ex_eqv {A B} {a : A} {b : B} :
  eqv (heq0 a b) {e : A == B & heq4 e a b}.
Proof.
  exists heq0to4_ex.
  apply (isEqv_intro heq4to0_ex).
  - intros (e, h4).
    destruct h4.
    reflexivity.
  - intro h.
    destruct h.
    reflexivity.
Defined.

Lemma heq1toeq {A B} {f : A -> B} {a b} : heq1 f a b -> b == f a.
Proof.
  intros [].
  apply eq_refl.
Defined.

Lemma heq1to2_ex {A B a b} {f : A -> B} : heq1 f a b -> {g : B -> A & heq2 f g a b}.
Proof.
  intros [].
  exists (fun x => x).
  apply hrefl2.
Defined.

Lemma heq1to2_eqv {A B a b} {f : A -> B} : eqv (heq1 f a b) {g : B -> A & heq2 f g a b}.
Proof.
  exists heq1to2_ex.
  apply (isEqv_intro (fun gh : {g : B -> A & heq2 f g a b} =>
                      let (_, h) := gh in heq2to1 h)).
  - intros (g, Hg).
    destruct Hg.
    reflexivity.
  - intro h.
    destruct h.
    reflexivity.
Defined.

Definition heq5 {A B} (f : A -> B) a b := (isStrongEqv f * (f a == b))%type.

Lemma heq1to5 {A B} {f : A -> B} {a b} : heq1 f a b -> heq5 f a b.
Proof.
  intros [].
  split.
  - apply isStrongEqv_id.
  - reflexivity.
Defined.

Lemma heq5to1 {A B} {f : A -> B} {a b} : heq5 f a b -> heq1 f a b.
Proof.
  intros (Hf, e).
  destruct Hf.
  unfold id in e.
  destruct e.
  apply hrefl1.
Defined.

Lemma heq1to5_eqv {A B} {f : A -> B} {a b} : eqv (heq1 f a b) (heq5 f a b).
Proof.
  exists heq1to5.
  apply (isEqv_intro heq5to1).
  - intros (Hf, e).
    destruct Hf.
    unfold id in e.
    destruct e.
    reflexivity.
  - intro h.
    destruct h.
    reflexivity.
Defined.

Definition seqv A B := {f : A -> B & isStrongEqv f}.

Definition seqv_fun {A B} (e : seqv A B) : A -> B :=
  let (f, _) := e in f.

Coercion seqv_fun : seqv >-> Funclass.

Lemma seqv_refl A : seqv A A.
Proof.
  exists (id A).
  apply isStrongEqv_id.
Defined.

Lemma seqv_to_eq {A B} : seqv A B -> A == B.
Proof.
  intros (f, Hf).
  destruct Hf.
  reflexivity.
Defined.

Lemma eq_to_seqv {A B} : A == B -> seqv A B.
Proof.
  intros [].
  apply seqv_refl.
Defined.

Lemma StrongEqv_eq {A B} : eqv (A == B) (seqv A B).
Proof.
  exists eq_to_seqv.
  apply (isEqv_intro seqv_to_eq).
  - intros (f, Hf).
    destruct Hf.
    reflexivity.
  - intros [].
    reflexivity.
Defined.

Lemma seqv_is_eq_to_seqv {A B} (f : seqv A B) : f == eq_to_seqv (seqv_to_eq f).
Proof.
  destruct f as (f, Hf).
  destruct Hf.
  reflexivity.
Defined.

Lemma eq_is_seqv_to_eq {A B} (e : A == B) : e == seqv_to_eq (eq_to_seqv e).
Proof.
  destruct e.
  reflexivity.
Defined.

Goal forall A B (e : A == B), (eq_to_seqv e : A -> B) == (id_to_eqv e : A -> B).
Proof.
  intros A B e.
  unfold eq_to_seqv, id_to_eqv.
  destruct e.
  reflexivity.
Defined.

Lemma heq5to4 {A B} {e : A == B} {a b} : eq_to_seqv e a == b -> heq4 e a b.
Proof.
  intro H.
  rewrite (eq_is_seqv_to_eq e).
  generalize H; clear H.
  generalize (eq_to_seqv e) as f.
  intro f; clear e.
  destruct f as (f, Hf).
  destruct Hf.
  simpl.
  intros [].
  apply hrefl4.
Defined.

Lemma heq4to5 {A B} {e : A == B} {a b} : heq4 e a b -> eq_to_seqv e a == b.
Proof.
  intro h4.
  destruct h4.
  reflexivity.
Defined.

Lemma heq4to5_eqv {A B} {e : A == B} {a b} :
  eqv (heq4 e a b) (eq_to_seqv e a == b).
Proof.
  exists heq4to5.
  apply (isEqv_intro heq5to4).
  - intro h.
    destruct e.
    simpl in h.
    unfold id in h.
    destruct h.
    reflexivity.
  - unfold pinv.
    intro h.
    destruct h.
    reflexivity.
Defined.

Lemma heq1_seqv_intro {A B} (f : seqv A B) a b : b == f a -> heq1 f a b.
Proof.
  rewrite (seqv_is_eq_to_seqv f).
  generalize (seqv_to_eq f).
  intro e; destruct e.
  simpl.
  unfold id.
  intro e; destruct e.
  apply hrefl1.
Defined.

Lemma heq1to4_eqv2 {A B} (f : A -> B) a b :
  eqv (heq1 f a b) {H : isStrongEqv f & (heq4 (seqv_to_eq (existT _ f H)) a b)}.
Proof.
  apply (eqv_trans heq1to5_eqv).
  unfold heq5.
  apply (eqv_trans eqv_prod_sigma).
  apply eqv_sym.
  apply sigT_eqv.
  intros Hf.
  apply (eqv_trans heq4to5_eqv).
  rewrite <- seqv_is_eq_to_seqv.
  apply eqv_refl.
Defined.

(* Going from heq1 to heq2 by taking as g the inverse of f (actually, any right pseudo-inverse) requires a weak version of functional extensionality *)
Definition id_to_fun {A B} (f g : forall x : A, B x) : f == g -> forall x, f x == g x.
Proof.
  intros [].
  reflexivity.
Defined.

Axiom functional_extensionality : forall A B (f g : forall x : A, B x), isEqv (id_to_fun f g).

Definition funext {A B} (f g : forall x : A, B x) :
  (forall x : A, f x == g x) -> f == g
  := isEqv_inv _ (functional_extensionality A B f g).

Lemma funext_id {A} f : (forall x : A, f x == x) -> f == (fun x => x).
Proof.
  apply funext.
Defined.

Lemma funext_inv1 {A B} {f g : forall x : A, B x} (p : f == g) :
  funext f g (id_to_fun f g p) == p.
Proof.
  unfold funext.
  apply isEqv_inv_eta.
Defined.

Lemma funext_refl {A B} {f : forall x : A, B x} :
  funext f f (fun x => eq_refl (f x)) == eq_refl f.
Proof.
  apply (funext_inv1 (eq_refl f)).
Defined.

Lemma fun_is_id_to_fun {A B} {f g : forall x : A, B x} (h : forall x, f x == g x) :
  h == id_to_fun f g (funext f g h).
Proof.
  unfold funext.
  apply eq_sym.
  apply isEqv_inv_eps.
Defined.

Lemma eq_is_funext {A B} {f g : forall x : A, B x} (h : f == g) :
  h == funext f g (id_to_fun f g h).
Proof.
  unfold funext.
  apply eq_sym.
  apply isEqv_inv_eta.
Defined.

Lemma funext_inj {A B} {f g : forall x : A, B x} (h1 h2 : forall x, f x == g x) :
  funext f g h1 == funext f g h2 -> h1 == h2.
Proof.
  intro H.
  rewrite (fun_is_id_to_fun h1).
  rewrite (fun_is_id_to_fun h2).
  rewrite H.
  reflexivity.
Defined.

Lemma heq1to2_all {A B} {f : A -> B} {a b} :
  forall g, pinv f g ->
            heq1 f a b ->
            heq2 f g a b.
Proof.
  intros g Hg.
  intros h.
  destruct h.
  apply (funext_id g) in Hg.
  rewrite Hg.
  apply hrefl2.
Defined.

Lemma heq1to2_alleqv {A B} {f : A -> B} {Hf : isEqv f} {a b} :
  heq1 f a b -> heq2 f (isEqv_inv f Hf) a b.
Proof.
  intro H.
  apply heq1to2_all.
  + apply isEqv_inv_eps.
  + assumption.
Defined.

(* Axiomatisation of the circle: all points of the circle are equal to
the base point and we have a non trivial equality between base and
base. *)

Variable Circle : Type.
Variable base : Circle.
Variable loop : base == base.
Variable eq_base : forall x : Circle, x == base.
Hypothesis eq_base_base : eq_base base == eq_refl base.
Hypothesis loop_not_refl : loop == eq_refl base -> Empty_set.

(* A non trivial proof of id = id *)
Definition id_is_id : id Circle == id Circle.
Proof.
  apply funext_id.
  intro x.
  unfold id.
  apply (transport (fun x => x == x) (eq_sym (eq_base x))).
  exact loop.
Defined.

Lemma id_is_id_is_not_refl : id_is_id == eq_refl _ -> Empty_set.
Proof.
  unfold id_is_id.
  rewrite <- funext_refl.
  unfold funext_id.
  fold (id Circle).
  intro H.
  apply funext_inj in H.
  assert (forall x : Circle, transport (fun x => x == x) (eq_sym (eq_base x)) loop == eq_refl _).
  - intro x.
    apply (id_to_fun _ _ H x).
  - specialize (X base).
    rewrite eq_base_base in X.
    simpl in X.
    apply loop_not_refl in X.
    assumption.
Defined.

(* going from heq1 or heq2 to heq4 is also possible using univalence.
   With univalence, we can also go from (b = f a /\ isEqv f) to heq1 *)

Section with_univalence.

  Variable univalence : forall A B, isEqv (@id_to_eqv A B).

  Definition ua {A B} : eqv A B -> A == B := isEqv_inv _ (univalence A B).

  Lemma ua_inv1 {A B} (p : A == B) : ua (id_to_eqv p) == p.
  Proof.
    unfold ua.
    apply isEqv_inv_eta.
  Defined.

  Lemma ua_refl A : ua (eqv_refl A) == eq_refl A.
  Proof.
    apply (ua_inv1 (eq_refl A)).
  Defined.

  Lemma eqv_is_ua {A B} (f : eqv A B) : f == id_to_eqv (ua f).
  Proof.
    unfold ua.
    apply eq_sym.
    apply isEqv_inv_eps.
  Defined.

  Lemma ua_sym {A B} {f : eqv A B} : ua (eqv_sym f) == eq_sym (ua f).
  Proof.
    rewrite (eqv_is_ua f).
    generalize (ua f).
    intro e.
    destruct e.
    rewrite ua_inv1.
    simpl.
    apply ua_refl.
  Defined.

  Lemma heq1_intro {A B} (f : eqv A B) a b : b == f a -> heq1 f a b.
  Proof.
    rewrite (eqv_is_ua f).
    generalize (ua f).
    intro e; destruct e.
    simpl.
    unfold id.
    intro e; destruct e.
    apply hrefl1.
  Defined.

  Lemma heq1to4 {A B} (f : eqv A B) a b : heq1 f a b -> heq4 (ua f) a b.
  Proof.
    rewrite (eqv_is_ua f).
    generalize (ua f).
    clear f.
    intro e.
    destruct e.
    rewrite ua_refl.
    simpl.
    intro H.
    apply heq1toeq in H.
    unfold id in H.
    destruct H.
    apply hrefl4.
  Defined.

  Lemma pinv_negb : pinv@{Type Type Type} negb negb.
  Proof.
    intros []; reflexivity.
  Defined.

  Definition NOT : eqv@{Type Type Type Type Type} bool bool.
  Proof.
    exists negb.
    apply (isEqv_intro negb); apply pinv_negb.
  Defined.

  Definition heq1_example: heq1 negb true false :=
    heq1_intro NOT true false (eq_refl false).

  Definition heq2_example: heq2 negb negb true false :=
    heq1to2_all negb pinv_negb heq1_example.

  Definition heq0_example: heq0 true false :=
    heq1to0 heq1_example.

  Definition heq4_example: heq4 (ua NOT) true false :=
    heq1to4 NOT true false heq1_example.

End with_univalence.


Require Import ltl.
Require Import eqnSys.

(* The set of normalized LTL formulas *)

Inductive ra_ltl : ltl -> Prop :=
  | ra_ltl_OR :
      forall v v' : V,
      ra_ltl (var v .\/ var v')
  | ra_ltl_X :
      forall (v : V) (phi : ltl_phi),
      ra_ltl (X (var v) ./\ phi)
  | ra_ltl_STORE_X :
      forall r (v : V) (phi : ltl_phi),
      ra_ltl ((↓ r, X (var v)) ./\ phi)
  | ra_ltl_PHI :
      forall (phi : ltl_phi),
      ra_ltl (φ phi)
  .

(* Transition rules *)

Inductive SigmaE :=
  | epsilon
  | Σφ (phi : ltl_phi)
  .
Inductive regSet :=
  | reg_empty
  | reg (r : register)
  .
Inductive ruleA (sigma : eqn_sys)
  : ltl -> SigmaE -> regSet -> ltl -> Prop :=
  | ruleA_PHI :
    forall phi : ltl_phi,
    ruleA sigma (φ phi) (Σφ phi) reg_empty (φ [tt])
  | ruleA_OR_left :
    forall v1 v2 : V,
    ruleA sigma (var v1 .\/ var v2) epsilon reg_empty (sigma v1)
  | ruleA_OR_right :
    forall v1 v2 : V,
    ruleA sigma (var v1 .\/ var v2) epsilon reg_empty (sigma v2)
  | ruleA_X :
    forall (v : V) (phi : ltl_phi),
    ruleA sigma (X (var v) ./\ phi) (Σφ phi) reg_empty (sigma v)
  | ruleA_STORE_X :
    forall r (v : V) (phi : ltl_phi),
    ruleA sigma ((↓ r, X (var v)) ./\ phi) (Σφ phi) (reg r) (sigma v)
  .

Definition Config := (ltl * Theta * data_word)%type.

Inductive moveA (sigma : eqn_sys)
  : Config -> Config -> Prop :=
  | moveA_epsilon :
    forall q1 q2 theta w,
    ruleA sigma q1 epsilon reg_empty q2 ->
    moveA sigma (q1, theta, w) (q2, theta, w)
  | moveA_not_update :
    forall q1 q2 phi theta h t,
    ruleA sigma q1 (Σφ phi) reg_empty q2 ->
    models_phi (h::t) theta phi ->
    moveA sigma (q1, theta, h::t) (q2, theta, t)
  | moveA_update :
    forall q1 q2 phi r theta a t,
    ruleA sigma q1 (Σφ phi) (reg r) q2 ->
    models_phi (a::t) theta phi ->
    moveA sigma (q1, theta, a::t) (q2, update theta r (snd a), t)
  .

Inductive moveA_star (sigma : eqn_sys)
  : Config -> Config -> Prop :=
  | moveA_star_ref :
    forall q1,
    moveA_star sigma q1 q1
  | moveA_star_trans :
    forall q1 q2 q3,
    moveA sigma q1 q2 -> moveA_star sigma q2 q3 ->
    moveA_star sigma q1 q3
  .

Inductive finalA
  : ltl -> Prop :=
  | finalA_tt  : finalA (φ [tt])
  | finalA_END : finalA (φ [END])
  | finalA_not_p : forall a, finalA (φ ~[p a])
  | finalA_not_MATCH : forall r, finalA (φ ~[↑ r])
  | finalA_and : forall p1 p2,
    finalA (φ p1) -> finalA (φ p2) -> finalA (φ p1 ../\ p2)
  .

Lemma moveA_star_is_transitive :
  forall sigma c1 c2 c3,
  moveA_star sigma c1 c2 ->
  moveA_star sigma c2 c3 ->
  moveA_star sigma c1 c3.
Proof.
  intros sigma c1 c2 c3.
  intros H12 H23.
  induction H12 as [| c1 c2 c3' H12 H23' IH];
  auto.
  apply moveA_star_trans with c2;
  now try apply IH.
Qed.

Lemma moveA_star_is_transitive_at_last :
  forall sigma c1 c2 c3,
  moveA_star sigma c1 c2 ->
  moveA sigma c2 c3 ->
  moveA_star sigma c1 c3.
Proof.
  intros sigma c1 c2 c3 H12 H23.
  apply moveA_star_is_transitive with c2; auto.
  apply moveA_star_trans with c3;
  try apply moveA_star_ref.
  apply H23.
Qed.

Lemma tt_loop_exists :
  forall sigma theta w,
  moveA_star sigma (φ [tt], theta, w) (φ [tt], theta, nil).
Proof.
  intros sigma theta w.
  induction w.
  - apply moveA_star_ref.
  - apply (moveA_star_trans sigma _ (φ [tt], theta, w)).
  + apply moveA_not_update with (phi := [tt]).
  * apply ruleA_PHI.
  * now unfold models_phi.
  + trivial.
Qed.

Lemma satisfied_at_end_is_finalA :
  forall phi theta,
  models_phi nil theta phi <-> finalA (φ phi).
Proof.
  intros phi theta.
  split.
  - intros Hmo.
  induction phi as [l | l | p1 IHp1 p2 IHp2].
  + destruct l;
  try now unfold models_phi in Hmo.
  * apply finalA_tt.
  * apply finalA_END.
  + destruct l;
  try unfold models_phi in Hmo;
  try now unfold models_atom in Hmo.
  * apply finalA_not_MATCH.
  * apply finalA_not_p.
  + unfold models_phi in Hmo.
  destruct Hmo as [Hp1 Hp2].
  apply IHp1 in Hp1.
  apply IHp2 in Hp2.
  now apply finalA_and.

  - induction phi as [l | l | p1 IHp1 p2 IHp2];
  intros Hf;
  try (inversion Hf; now unfold models_phi).
  inversion Hf as [| | | | p1' p2' Hf1 Hf2 [EQp1' EQp2']].
  unfold models_phi.
  split; [apply IHp1 | apply IHp2]; trivial.
Qed.

Section CorrectnessOfConversionToRA.

Variable sigma : eqn_sys.
Hypothesis Hra :
  forall v : V, ra_ltl (sigma v).

Variable ell : nat.
Definition lfpF := Fpow_emp sigma ell.
Hypothesis HlfpF : lfpF = F sigma lfpF.

Theorem A_is_equivalent_to_sigma_1 :
  forall w v theta,
  (w, theta |= lfpF, sigma v) ->
  exists theta' qF,
  finalA qF /\
  moveA_star sigma (sigma v, theta, w) (qF, theta', nil).
Proof.
  unfold lfpF.
  induction ell as [| l IHl].
  - (* ell = 0 -> ... *)
  intros w v theta Hw.
  assert (Hra' := Hra v).
  inversion Hw
  as [w' th u phi Hmo EQu EQw' EQth EQphi
     | h t th u r psi Hmo EQu [EQh EQt] EQth EQpsi
     | h t th u psi Hmo EQu [EQh EQt] EQth EQpsi
     | w' th u psi phi Hpsi Hmo EQu EQw' EQth EQpsi
     | w' th u psi1 psi2 Hmo EQu EQw' EQth EQpsi
     | w' th u psi Hmo EQu EQw' EQth EQpsi
     | w' th u phi psi Hmo EQu EQw' EQth EQpsi
     | w' th u v' Hmo EQu EQw' EQth EQpsi].
  * (* sigma v = φ phi -> ... *)
  exists theta.
  destruct w as [| a w].
  -- (* w = nil -> ... *)
  exists (φ phi).
  destruct phi;
  split;
  try apply moveA_star_ref;
  now apply satisfied_at_end_is_finalA with theta.
  -- (* w' = a :: w -> ... *)
  exists (φ [tt]).
  destruct phi as [l0 | l0 | p1 p2];
  split;
  try apply finalA_tt;
  apply moveA_star_trans with (q2 := (φ [tt], theta, w));
  try apply tt_loop_exists.
  ++ (* sigma v = φ [l0] -> ... *)
  apply moveA_not_update with (phi := [l0]);
  try apply Hmo; apply ruleA_PHI.
  ++ (* sigma v = φ ~[l] -> ... *)
  apply moveA_not_update with (phi := ~[l0]);
  try apply Hmo; apply ruleA_PHI.
  ++ (* sigma v = φ p1 ../\ p2 -> ... *)
  apply moveA_not_update with (phi := p1 ../\ p2);
  try apply Hmo; apply ruleA_PHI.

  * (* sigma v = ↓ r, psi -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.
  * (* sigma v = X psi -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.

  * (* sigma v = psi ./\ phi -> ... *)
  rewrite <- EQpsi in Hra'.
  inversion Hra'
  as [| v0 phi0 [EQv0 EQphi0]| r v0 phi0 [EQv0 EQphi0]|].
  -- (* sigma v = X (var v0) ./\ phi -> ... *)
  rewrite <- EQv0 in Hpsi.
  inversion Hpsi
  as [| | h t th' u' psi' Hmo' EQu' [EQh EQt] EQth' EQpsi'| | | | |].
  clear th' EQth' u' EQu' psi' EQpsi'.
  inversion Hmo'
  as [| | | | | | |w'' th' u' v1 Hf EQu' EQw'' EQth' EQv1].
  now unfold Fpow_emp in Hf.
  -- (* sigma v = (↓ r, X (var v0)) ./\ phi -> ... *)
  rewrite <- EQv0 in Hpsi.
  inversion Hpsi
  as [| h t th' u' r' psi' Hmo' EQu' [EQh EQt] EQth' [EQr' EQpsi'] | | | | | |].
  clear th' EQth' u' EQu' r' EQr' psi' EQpsi'.
  inversion Hmo'
  as [| | h' t' th' u' psi' Hmo'' EQu' [EQh' EQt'] EQth' EQpsi'| | | | |].
  clear h' EQh' t' EQt' th' EQth' u' EQu' psi' EQpsi'.
  inversion Hmo''
  as [| | | | | | |w'' th' u' v1 Hf EQu' EQw'' EQth' EQv1].
  now unfold Fpow_emp in Hf.

  * (* sigma v = psi1 .\/ psi2 -> ... *)
  rewrite <- EQpsi in Hra'.
  inversion Hra' as [v1 v2 [EQpsi1 EQpsi2]| | |].
  (* sigma v = var v1 .\/ var v2 -> ... *)
  rewrite <- EQpsi1 in Hmo.
  rewrite <- EQpsi2 in Hmo.
  unfold Fpow_emp in Hmo.
  unfold Fpow in Hmo.
  destruct Hmo as [Hmo | Hmo].
  -- (* (nil, theta |= empty_env, var v1) -> ... *)
  inversion Hmo as [| | | | | | |w'' th' u' v' H].
  now unfold empty_env in H.
  -- (* (nil, theta |= empty_env, var v2) -> ... *)
  inversion Hmo as [| | | | | | |w'' th' u' v' H].
  now unfold empty_env in H.

  * (* sigma v = G psi -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.
  * (* sigma v = phi U psi -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.
  * (* sigma v = var v' -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.

  - (* inductive step on ell *)
  intros w v theta Hw.
  assert (Hra' := Hra v).
  inversion Hw
  as [w' th u phi Hmo EQu EQw' EQth EQphi
     | h t th u r psi Hmo EQu [EQh EQt] EQth EQpsi
     | h t th u psi Hmo EQu [EQh EQt] EQth EQpsi
     | w' th u psi phi Hpsi Hmo EQu EQw' EQth EQpsi
     | w' th u psi1 psi2 Hmo EQu EQw' EQth EQpsi
     | w' th u psi Hmo EQu EQw' EQth EQpsi
     | w' th u phi psi Hmo EQu EQw' EQth EQpsi
     | w' th u v' Hmo EQu EQw' EQth EQpsi].
  * (* sigma v = φ phi -> ... *)
  exists theta.
  destruct w as [| a w].
  -- (* w = nil -> ... *)
  exists (φ phi).
  destruct phi;
  split;
  try apply moveA_star_ref;
  now apply satisfied_at_end_is_finalA with theta.

  -- (* w' = a :: w -> ... *)
  exists (φ [tt]).
  destruct phi as [l0 | l0 | p1 p2];
  split;
  try apply finalA_tt;
  apply moveA_star_trans with (q2 := (φ [tt], theta, w));
  try apply tt_loop_exists.
  ++ (* sigma v = φ [l0] -> ... *)
  apply moveA_not_update with (phi := [l0]);
  try apply Hmo; apply ruleA_PHI.
  ++ (* sigma v = φ ~[l] -> ... *)
  apply moveA_not_update with (phi := ~[l0]);
  try apply Hmo; apply ruleA_PHI.
  ++ (* sigma v = φ p1 ../\ p2 -> ... *)
  apply moveA_not_update with (phi := p1 ../\ p2);
  try apply Hmo; apply ruleA_PHI.

  * (* sigma v = ↓ r, psi -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.
  * (* sigma v = X psi -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.

  * (* sigma v = psi ./\ phi -> ... *)
  rewrite <- EQpsi in Hra'.
  inversion Hra'
  as [| v0 phi0 [EQv0 EQphi0]| r v0 phi0 [EQv0 EQphi0]|].
  -- (* sigma v = X (var v0) ./\ phi -> ... *)
  rewrite <- EQv0 in Hpsi.
  inversion Hpsi
  as [| | h t th' u' psi' Hmo' EQu' [EQh EQt] EQth' EQpsi'| | | | |].
  clear th' EQth' u' EQu' psi' EQpsi'.
  rewrite<- EQh in Hmo.
  inversion Hmo'
  as [| | | | | | |w'' th' u' v1 Hf EQu' EQw'' EQth' EQv1].
  clear w'' EQw'' th' EQth' u' EQu' v1 EQv1.
  assert (IHl' := IHl t v0 theta Hf).
  destruct IHl' as [theta' [qF [Hfin Hmv]]].
  exists theta'.
  exists qF.
  split; auto.
  apply (moveA_star_trans _ _ (sigma v0, theta, t));
  auto.
  apply moveA_not_update with (phi := phi);
  auto.
  apply ruleA_X.
  -- (* sigma v = (↓ r, X (var v0)) ./\ phi -> ... *)
  rewrite <- EQv0 in Hpsi.
  inversion Hpsi
  as [| h t th' u' r' psi' Hmo' EQu' [EQh EQt] EQth' [EQr' EQpsi'] | | | | | |].
  clear th' EQth' u' EQu' r' EQr' psi' EQpsi'.
  rewrite<- EQh in Hmo.
  inversion Hmo'
  as [| | h' t' th' u' psi' Hmo'' EQu' [EQh' EQt'] EQth' EQpsi'| | | | |].
  clear h' EQh' t' EQt' th' EQth' u' EQu' psi' EQpsi'.
  inversion Hmo''
  as [| | | | | | |w'' th' u' v1 Hf EQu' EQw'' EQth' EQv1].
  assert (IHl' := IHl t v0 (update theta r (snd h)) Hf).
  destruct IHl' as [theta' [qF [Hfin Hmv]]].
  exists theta'.
  exists qF.
  split; auto.
  apply (moveA_star_trans _ _ (sigma v0, (update theta r (snd h)), t));
  auto.
  apply moveA_update with (phi := phi);
  auto.
  apply ruleA_STORE_X.

  * (* sigma v = psi1 .\/ psi2 -> ... *)
  rewrite <- EQpsi in Hra'.
  inversion Hra' as [v1 v2 [EQpsi1 EQpsi2]| | |].
  (* sigma v = var v1 .\/ var v2 -> ... *)
  rewrite <- EQpsi1 in Hmo.
  rewrite <- EQpsi2 in Hmo.
  unfold Fpow_emp in Hmo.
  unfold Fpow in Hmo.
  clear w' EQw' th EQth u EQu.
  destruct Hmo as [Hmo | Hmo].
  -- (* (w, theta |= Fpow sigma (S l), var v1) -> ... *)
  inversion Hmo as [| | | | | | |w' th' u' v' H EQu' EQw' EQth' EQv'].
  clear w' EQw' th' EQth' u' EQu' v' EQv'.
  assert (IHl' := IHl w v1 theta H).
  destruct IHl' as [theta' [qF [Hfin Hmv]]].
  exists theta'.
  exists qF.
  split; auto.
  apply (moveA_star_trans _ _ (sigma v1, theta, w));
  auto.
  apply moveA_epsilon.
  apply ruleA_OR_left.
  -- (* (w, theta |= Fpow sigma (S l), var v2) -> ... *)
  inversion Hmo as [| | | | | | |w' th' u' v' H EQu' EQw' EQth' EQv'].
  clear w' EQw' th' EQth' u' EQu' v' EQv'.
  assert (IHl' := IHl w v2 theta H).
  destruct IHl' as [theta' [qF [Hfin Hmv]]].
  exists theta'.
  exists qF.
  split; auto.
  apply (moveA_star_trans _ _ (sigma v2, theta, w));
  auto.
  apply moveA_epsilon.
  apply ruleA_OR_right.

  * (* sigma v = G psi -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.
  * (* sigma v = phi U psi -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.
  * (* sigma v = var v' -> ... *)
  rewrite <- EQpsi in Hra';
  inversion Hra'.
Qed.

Theorem A_is_equivalent_to_sigma_2 :
  forall w v theta,
  (exists theta' qF,
   finalA qF /\
   moveA_star sigma (sigma v, theta, w) (qF, theta', nil)) ->
  (w, theta |= lfpF, sigma v).
Proof.
  intros w v theta.
  intros [theta' [qF [Hfin Hmo]]].
  remember (sigma v, theta, w) as x.
  remember (qF, theta', nil) as y.
  generalize dependent theta.
  generalize dependent v.
  generalize dependent w.
  induction Hmo as [| c1 c2 c3 Hmo1 Hmo IH];
  intros w v theta Heqx.
  - (* qF = sigma v -> ... *)
  rewrite Heqy in Heqx.
  injection Heqx;
  intros EQw EQtheta' EQqF.
  rewrite EQqF in Hfin.
  rewrite<- EQw.
  inversion Hfin as [| | | |p1 p2 Hf1 Hf2 EQp1p2];
  apply models_PHI; try now auto.
  apply satisfied_at_end_is_finalA.
  now rewrite EQp1p2.
  - (* inductive step *)
  assert (IH' := IH Heqy).
  clear IH.
  rewrite Heqx in Hmo1.
  assert (Hra' := Hra v).
  inversion Hra'
  as [v1 v2 Hpsi| v1 phi Hpsi | r v1 phi Hpsi| phi Hpsi].
  + (* sigma v = var v1 .\/ var v2 -> ... *)
  apply models_OR.
  rewrite<- Hpsi in Hmo1.
  inversion Hmo1
  as [q1 q2 th w' Hru [EQq1 EQth EQw'] EQq2
     |q1 q2 phi th h t Hru
     |q1 q2 phi r th h t Hru ].
  * clear q1 EQq1 th EQth w' EQw'.
  inversion Hru
  as [|v1' v2' [EQv1' EQv2'] EQeps EQreg EQq2'
      |v1' v2' [EQv1' EQv2'] EQeps EQreg EQq2'| |].
  -- (* q2 = sigma v1 -> ... *)
  clear v1' EQv1' v2' EQv2' EQeps EQreg.
  rewrite<- EQq2' in EQq2; clear EQq2'.
  symmetry in EQq2.
  left.
  apply models_var.
  rewrite HlfpF.
  unfold F.
  now apply IH'.
  -- (* q2 = sigma v2 -> ... *)
  clear v1' EQv1' v2' EQv2' EQeps EQreg.
  rewrite<- EQq2' in EQq2; clear EQq2'.
  symmetry in EQq2.
  right.
  apply models_var.
  rewrite HlfpF.
  unfold F.
  now apply IH'.
  * inversion Hru.
  * inversion Hru.
  + (* sigma v = X (var v1) ./\ phi -> ... *)
  rewrite<- Hpsi in Hmo1.
  inversion Hmo1
  as [q1 q2 th w' Hru [EQq1 EQth EQw'] EQq2
     |q1 q2 phi' th h t Hru Hphi [EQq1 EQth EQht] EQq2
     |q1 q2 phi' r th h t Hru ].
  * inversion Hru.
  * clear q1 EQq1 th EQth.
  inversion Hru
  as [| | | v1' phi'' [EQv1' EQphi''] EQphi EQreg EQq2'|].
  clear v1' EQv1' phi'' EQphi'' EQreg.
  rewrite<- EQq2' in EQq2; clear EQq2'.
  symmetry in EQq2.
  apply models_AND; auto.
  apply models_X.
  apply models_var.
  rewrite HlfpF.
  unfold F.
  now apply IH'.
  * inversion Hru.
  + (* sigma v = (↓ r, X (var v1)) ./\ phi -> ... *)
  rewrite<- Hpsi in Hmo1.
  inversion Hmo1
  as [q1 q2 th w' Hru [EQq1 EQth EQw'] EQq2
     |q1 q2 phi' th h t Hru Hphi [EQq1 EQth EQht] EQq2
     |q1 q2 phi' r' th h t Hru Hphi [EQq1 EQth EQht] EQq2].
  * inversion Hru.
  * inversion Hru.
  * clear q1 EQq1 th EQth.
  inversion Hru
  as [| | | |r'' v1' phi'' [EQr'' EQv1' EQphi''] EQphi EQr EQq2'].
  clear r'' EQr'' v1' EQv1' phi'' EQphi''.
  rewrite<- EQq2' in EQq2; clear EQq2'.
  symmetry in EQq2.
  apply models_AND; auto.
  apply models_STORE.
  apply models_X.
  apply models_var.
  rewrite HlfpF.
  unfold F.
  now apply IH'.
  + (* sigma v = φ phi -> ... *)
  rewrite<- Hpsi in Hmo1.
  inversion Hmo1
  as [q1 q2 th w' Hru [EQq1 EQth EQw'] EQq2
     |q1 q2 phi' th h t Hru Hphi [EQq1 EQth EQht] EQq2
     |q1 q2 phi' r' th h t Hru Hphi [EQq1 EQth EQht] EQq2].
  * inversion Hru.
  * clear q1 EQq1 th EQth.
  inversion Hru
  as [phi'' EQphi'' EQphi EQreg EQq2'| | | |].
  now apply models_PHI.
  * inversion Hru.
Qed.

End CorrectnessOfConversionToRA.


Require Import List.

Require Import Repr.Lists.

Require Import Repr.Tactics.
Require Import Repr.Tactics.LibTactics.
Require Import Repr.Tactics.Opburn.

Require Import Coq.Arith.Peano_dec.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Lt.

Require Import Repr.SystemFOp.Kind.

(* Looks better to use a 'tvar' over a nat for a de bruijn index *)
Definition tvar := nat.

(* TVars are indexes into a kind environment. We use TNat as our base type. *)
Inductive typ : Set :=
  | TVar   : tvar -> typ
  | TNat   : typ
  | TArrow : typ -> typ -> typ
  | TAll   : typ -> typ .

Hint Constructors typ.

(* Types are well-formed with respect to a kind environment. *)
Inductive well_formed_typ : kenv -> typ -> Prop :=
  | WFT_TVar :
      forall D X,
        (exists K, get D X = Some K) ->
        well_formed_typ D (TVar X)
  | WFT_TNat :
      forall D,
        well_formed_typ D TNat
  | WFT_TArrow :
      forall D T1 T2,
        well_formed_typ D T1 ->
        well_formed_typ D T2 ->
        well_formed_typ D (TArrow T1 T2)
  | WFT_TAll :
      forall D T,
        (exists K, well_formed_typ (K :: D) T) ->
        well_formed_typ D (TAll T) .

Hint Constructors well_formed_typ.

(* A type is closed if it is well-formed in the empty kind environment *)
Definition closed_typ (T:typ) : Prop := well_formed_typ nil T.

(* Trick to control how far simpl goes for better automation *)
Definition lift_le_gt_dec (n m : nat) := le_gt_dec n m.
Arguments lift_le_gt_dec _ _ : simpl nomatch.

(* Standard de bruijn lifting and substituion functions operating at the type level *)
Fixpoint typ_lift (dp:nat)(T:typ) : typ :=
  match T with
    | TVar X =>
       if (lift_le_gt_dec dp X) then TVar (S X) else TVar X
    | TNat =>
       TNat
    | TArrow T1 T2 =>
       TArrow (typ_lift dp T1) (typ_lift dp T2)
    | TAll T' =>
       TAll (typ_lift (S dp) T')
  end.

Fixpoint typ_substitute (X:tvar)(U T:typ) : typ :=
  match T with
    | TVar Y =>
       match nat_compare Y X with
         | Eq => U
         | Gt => TVar (Y-1)
         | Lt => TVar Y
       end
    | TNat =>
       TNat
    | TArrow T1 T2 =>
       TArrow (typ_substitute X U T1) (typ_substitute X U T2)
    | TAll T' =>
       TAll (typ_substitute (S X) (typ_lift 0 U) T')
  end.

Notation "'[' X '|=>' U ']' T" := (typ_substitute X U T) (at level 30).

(********************************************************************)
(* We must define a Kind Judgement for Types *)

Reserved Notation "D '\\-' T \: K" (at level 30).

Inductive kind_rel : kenv -> typ -> kind -> Prop :=
  | KR_TVar :
      forall D X K,
        get D X = Some K ->
        D \\- TVar X \: K
  | KR_TNat :
      forall D,
        D \\- TNat \: KStar
  | KR_TArrow :
      forall D T1 T2,
        D \\- T1 \: KStar ->
        D \\- T2 \: KStar ->
        D \\- TArrow T1 T2 \: KStar
  | KR_TAll :
      forall D T,
        (KStar :: D) \\- T \: KStar ->
        D \\- TAll T \: KStar

where "D '\\-' T \: K" := (kind_rel D T K).

Hint Constructors kind_rel.

(* A couple of useful Lemma's --- I am cheating though, I saw these
   from Iron Lambda *)

(* Simple tactic that helps burn down the easy cases. *)
Ltac inverts_typ :=
  repeat
    (match goal with
       | [ H: _ \\- (TVar _)     \: _ |- _ ] => inverts H
       | [ H: _ \\- TNat         \: _ |- _ ] => inverts H
       | [ H: _ \\- (TArrow _ _) \: _ |- _ ] => inverts H
       | [ H: _ \\- (TAll _)     \: _ |- _ ] => inverts H
     end).

(* This tactic 'usually' gets most of the inductive and easy cases
 * when we induct over the typing relation. *)
Tactic Notation "induction_kind" ident(t) :=
  induction t; rip; simpl; inverts_typ; tburn.

(********************************************************************)
(* Lemmas for manipulating the lifting and substitution operations. *)

(* Handy tactic for burning down TVar case analysis which usually boils down
 * to repeated less than and nat compares *)

Ltac case_lift :=
  match goal with
    | [ |- context [lift_le_gt_dec ?a ?b] ] =>
      case (lift_le_gt_dec a b)
  end.

(* Mega tactic that deals with all the de bruijn comparisons *)
Ltac burn_tvar :=
  simpl;
  match goal with
    | [ |- context[nat_compare _ _ ] ]
      => break_nat_compare ;
         opburn ;
         burn_tvar
    | [ |- context[ match nat_compare ?n ?m with
                      | Eq => _
                      | Lt => _
                      | Gt => _
                    end ] ]
      => break (nat_compare n m) ;
         norm_nat_compare ;
         opburn ;
         burn_tvar
    | [ |- context [lift_le_gt_dec _ _ ] ]
      => case_lift ;
         opburn ;
         burn_tvar
     | [ |- context [ match ?n with O => _ | S _ => _ end ] ]
       => destruct n ;
          opburn ;
          burn_tvar
    | _
      => opburn
  end.

Lemma typ_subs_nil_typ_lift
  :  forall X U T
  ,  [X |=> U] (typ_lift X T) = T.
Proof.
  linduction T; destruct X; opburn' tt tt kind_rel; burn_tvar.
Qed.

Lemma typ_lift_SX
  :  forall (X Y:tvar)(T:typ)
  ,  Y <= X
  -> typ_lift (S X) (typ_lift Y T) = typ_lift Y (typ_lift X T).
Proof.
  linduction T; opburn' tt tt kind_rel; burn_tvar.
Qed.

Definition marker_Snm (n n':nat) := S n + n'.
Hint Unfold marker_Snm.

Lemma Snm_Snpm
  :  forall (n m : nat)
  ,  S (n + m) = marker_Snm n m.
Proof. opburn. Qed.

Lemma typ_lift_over_subs
  :  forall (n n':nat)(U T:typ)
  ,  typ_lift n ([(n + n') |=> U] T)
  =  [(1 + n + n') |=> typ_lift n U] typ_lift n T.
Proof.
  linduction T;
  opburn'
    tt
    (typ_lift_SX, Snm_Snpm)
    kind_rel;
  [burn_tvar].
Qed.

Lemma typ_lift_over_subs'
  :  forall (n n':nat)(U T:typ)
  ,  typ_lift (n + n') ([n |=> U] T)
  =  [n  |=> typ_lift (n + n') U] typ_lift (1 + n + n') T.
Proof.
  linduction T;
  opburn'
    tt
    (typ_lift_SX, Snm_Snpm)
    kind_rel;
  [burn_tvar].
Qed.

Definition marker_Onm (n n':nat) := O + (n + n').
Hint Unfold marker_Onm.

Lemma Onm
  :  forall (n m : nat)
  ,  (n + m) = marker_Onm n m.
Proof. opburn. Qed.

Lemma Onm_ONCE : rewrite_ONCE (Onm).
  constructor.
Qed.

(* LAST *)
(* Coq tuples are right associative, we need our own notation *)

Lemma commute_typ_subs
  :  forall (n n':nat)(T1 T2 T3:typ)
  ,  [n + n' |=> T3] ([n |=> T2] T1)
  =  [n |=> [ n + n' |=> T3] T2 ] ([1 + n + n' |=> (typ_lift n T3)] T1).
Proof.
  linduction T1;
  opburn'
    tt
    (Onm_ONCE, Snm_Snpm, typ_lift_SX, typ_lift_over_subs)
    kind_rel;
  [burn_tvar];
  opburn' tt typ_subs_nil_typ_lift tt.
Qed.

(********************************************************************)

(* A well-kinded type is well-formed *)
Lemma kind_rel_imp_well_formed_typ
  :  forall D T K
  ,  D \\- T \: K
  -> well_formed_typ D T.
Proof.
  linduction T; opburn' tt tt kind_rel; eauto.
Qed.

(* NOTE: inster will fall on polymorphic types, but we can make it work
   by trying to *type of* all H's on the goal. *)
(* One dirty trick due to K's rewrite *)
Lemma kind_rel_insert
  :  forall D T K X
  ,  D \\- T \: K
  -> insert D X KStar \\- typ_lift X T \: K.
Proof.
  linduction T;
  opburn''
    tt
    insert_rewind
    kind_rel
    ltac:(fun H => match type of H with | kind => rewrite H in * end);
  match goal with
    (* TVar *)
    | [ |- context [lift_le_gt_dec ?A ?B] ]
      => break (lift_le_gt_dec A B) ;
           econstructor ;
           opburn' (get_insert_above_idx' kind) get_insert_below_idx tt
    (* TAbs *)
    | _
      => econstructor; opburn' tt insert_rewind kind_rel_insert
  end.
Qed.

Theorem kind_rel_weakening
  :  forall D T K
  ,  D \\- T \: K
  -> (KStar :: D) \\- typ_lift 0 T \: K.
Proof.
  intros; rewrite K in *;
  opburn'
    kind_rel_insert
    cons_as_insert
    tt.
Qed.

Lemma type_substition_preserves_kinding'
  :  forall (D:kenv)(X:tvar)(U T:typ)
  ,  delete D X \\- U \: KStar
  -> D \\- T \: KStar
  -> delete D X \\- [X |=> U] T \: KStar.
Proof.
  linduction T;
  opburn'
    kind_rel_weakening
    delete_rewind
    kind_rel;
  [ (* T-Var *)
    burn_tvar; econstructor ;
    opburn' tt (get_delete_above_idx, get_delete_below_idx) tt
  | (* T-All *)
    econstructor ;
    match goal with
    | [ H : delete ?D ?X \\- _ \: _ |- _ ] =>
      let x := fresh "D" in
      pose (x := delete D X)
    end ;
    opburn' kind_rel_weakening delete_rewind tt
  ].
Qed.

Lemma type_substition_preserves_kinding
  :  forall (D:kenv)(X:tvar)(U T:typ)
  ,  delete (KStar :: D) 0 \\- U \: KStar
  -> (KStar :: D) \\- T \: KStar
  -> delete (KStar :: D) 0 \\- [0 |=> U] T \: KStar.
Proof. intros; eapply type_substition_preserves_kinding'; opburn. Qed.

(********************************************************************)

(* We define type environments and some operations over them here. *)
Definition tenv := list typ.
Hint Unfold tenv.

(* We will need to lift and substitute over type environments when
 * new type variables are 'pushed' *)
Definition tenv_lift (dp:nat)(G:tenv) : tenv :=
  map (typ_lift dp) G.

Definition tenv_substitute (X:tvar)(U:typ)(G:tenv) : tenv :=
  map (typ_substitute X U) G.

(********************************************************************)

Lemma delete_tenv_lift
  :  forall G x
  ,  delete (tenv_lift 0 G) x = tenv_lift 0 (delete G x).
Proof.
  linduction x; destruct G; opburn.
Qed.

Lemma get_tenv_lift
  :  forall G x T X
  ,  get G x = Some T
  -> get (tenv_lift X G) x = Some (typ_lift X T).
Proof.
  linduction G; destruct x; opburn.
Qed.

Lemma rewind_tenv_lift
  :  forall G T X
  ,  typ_lift X T :: tenv_lift X G = tenv_lift X (T :: G).
Proof. opburn. Qed.

Lemma tenv_lift_SX
  :  forall G X
  ,  tenv_lift 0 (tenv_lift X G) = tenv_lift (S X) (tenv_lift 0 G).
Proof.
  linduction G; opburn' tt typ_lift_SX tt.
Qed.

Lemma get_tenv_substitute
  :  forall G X Y U T
  ,  get G Y = Some T
  -> get (tenv_substitute X U G) Y = Some ([X |=> U] T).
Proof.
  linduction G; destruct Y; opburn.
Qed.

Lemma rewind_tenv_substitute
  :  forall G U T X
  ,  [X |=> U] T :: tenv_substitute X U G = tenv_substitute X U (T :: G).
Proof. opburn. Qed.

Lemma typ_lift_over_tenv_subs
  :  forall (n n':nat)(U:typ)(D:tenv)
  ,  tenv_lift n (tenv_substitute (n + n') U D)
  =  tenv_substitute (1 + n + n') (typ_lift n U) (tenv_lift n D).
Proof.
  linduction D;
  opburn'
    tt
    (typ_lift_over_subs, rewind_tenv_substitute, rewind_tenv_lift)
    tt.
Qed.

Lemma typ_lift_over_tenv_subs'
  :  forall (n n':nat)(U:typ)(D:tenv)
  ,  tenv_lift (n + n') (tenv_substitute n U D)
  =  tenv_substitute n (typ_lift (n + n') U) (tenv_lift (1 + n + n') D).
Proof.
  linduction D;
  opburn'
    tt
    (typ_lift_over_subs', rewind_tenv_substitute, rewind_tenv_lift)
    tt.
Qed.


Require Export D.

(** **** Exercise: 1 star (update_example)  *)
(** Before starting to play with tactics, make sure you understand
    exactly what the theorem is saying! *)

Theorem update_neq : forall x2 x1 n st,
  x2 <> x1 ->
  (update st x2 n) x1 = (st x1).
Proof.
  intros. unfold update. apply neq_id. assumption.
Qed.

Theorem update_example : forall (n:nat),
  (update empty_state (Id 2) n) (Id 3) = 0.
Proof.
  intros. apply (update_neq (Id 3) (Id 2) n empty_state).
  unfold not. intros. inversion H.
  Qed.


Require Export SfLib.
Require Export Smtrg.

Module SmtrgProp.
Import Smtrg.Smtrg.

Theorem unique_typing : forall Gamma t T1 T2,
    Gamma |- t \in T1 ->
    Gamma |- t \in T2 ->
    T1 = T2 .

Proof with auto.
  intros Gamma t Ta Tb HTa HTb.
  generalize dependent Tb.
  has_type_cases (induction HTa) Case ; intros Tb HTb; inversion HTb.
  Case "T_Var". rewrite H in H2. injection H2. auto.
  Case "T_Abs".
    assert (T12 = T1).
    apply IHHTa. assumption.
    rewrite H5. reflexivity.
  Case "T_App".
    assert (TArrow T11 T12 = TArrow T0 Tb). apply IHHTa1. assumption.
    injection H5. auto.
  Case "T_Unit". reflexivity.
  Case "T_Pair".
    f_equal.
    apply IHHTa1...
    apply IHHTa2...
  Case "T_Fst".
    assert (TProd T1 T2 = TProd Tb T3).
    apply IHHTa...
    injection H3...
  Case "T_Snd".
    assert (TProd T1 T2 = TProd T0 Tb).
    apply IHHTa...
    injection H3...
  Case "T_Fix".
    assert (TArrow T T = TArrow Tb Tb)...
    injection H3...
  Case "T_Formula". reflexivity.
  Case "T_If". apply IHHTa1 ; assumption.
Qed.

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma.
  Ltac isvalue v_xx := left ; apply v_xx.
  Case "T_Var".
    (* contradiction: variables aren't typed in empty context *)
    unfold empty in H ; discriminate H.
  Case "T_Abs". isvalue v_abs.
  Case "T_App".
    (* t1 t2.
       If t1 steps, then we make progress with ST_App,
       otherwise, t1 must be an abstraction, so we make progress with ST_AppAbs.
    *)
    right. destruct IHHt1...
    SCase "t1 is a value".
      v_cases (inversion H) SSCase; subst; try solve by inversion.
      SSCase "v_abs".
        exists ([x0:=t2]t).
        apply ST_AppAbs ; assumption.
    SCase "t1 steps".
      inversion H as [t1' Hstp].
      exists (tapp t1' t2).
      apply ST_App ; assumption.
  Case "T_Unit". isvalue v_unit.
  Case "T_Pair". isvalue v_pair.
  Case "T_Fst".
    (* fst t
       If t steps, then we make progress with ST_Fst,
       otherwise, t must be a pair, so we make progress with ST_FstPair.
    *)
    right. destruct IHHt...
    SCase "t is a value".
      v_cases (inversion H) SSCase; subst; try solve by inversion.
      SSCase "v_pair".
        exists t1.
        apply ST_FstPair ; assumption.
    SCase "t steps".
      inversion H as [t' Hstp].
      exists (tfst t').
      apply ST_Fst ; assumption.

  Case "T_Snd".
    (* snd t
       If t steps, then we make progress with ST_Snd,
       otherwise, t must be a pair, so we make progress with ST_SndPair.
    *)
    right. destruct IHHt...
    SCase "t is a value".
      v_cases (inversion H) SSCase; subst; try solve by inversion.
      SSCase "v_pair".
        exists t2.
        apply ST_SndPair ; assumption.
    SCase "t steps".
      inversion H as [t' Hstp].
      exists (tsnd t').
      apply ST_Snd ; assumption.
  Case "T_Fix".
    (* makes progress by ST_Fix *)
    right.
    exists (tapp t (tfix t)).
    apply ST_Fix ; assumption.
  Case "T_Formula". isvalue v_formula.
  Case "T_If".
    (* makes progress by one of
       ST_IfAbs, ST_IfUnit, ST_IfPair, ST_IfFormula,
       ST_IfLeft, or ST_IfRight, depending on
       t1 and t2 as being values or stepping,
       which we have by induction
    *)
    right.
    destruct (IHHt1 (eq_refl empty)) as [Hvalue1 | Hsteps1];
    destruct (IHHt2 (eq_refl empty)) as [Hvalue2 | Hsteps2].
    SCase "t1 and t2 values".
      v_cases (destruct Hvalue1) SSCase ;
      (* Both values must have the same type *)
      destruct Hvalue2 ; inversion Ht1 ; inversion Ht2 ; subst ; try discriminate.
      SSCase "v_abs".
        (* We know the argument types match for both lambdas *)
        injection H7; intros ; subst.

        (* So apply ST_IfAbs *)
        exists (tabs x T0 (tif f (tapp (tabs x0 T0 t) (tvar x)) (tapp (tabs x1 T0 t0) (tvar x)))).
        apply ST_IfAbs.
      SSCase "v_unit". exists tunit ; apply ST_IfUnit.
      SSCase "v_pair". exists (tpair (tif f t1 t2) (tif f t0 t3)) ; apply ST_IfPair.
      SSCase "v_formula". exists (tformula (Sat.fite f f0 f1)) ; apply ST_IfFormula.
    SCase "t1 value, t2 steps".
      destruct Hsteps2 as [t2'].
      exists (tif f t1 t2') ; apply ST_IfRight ; assumption.
    SCase "t1 steps, t2 value".
      destruct Hsteps1 as [t1'].
      exists (tif f t1' t2) ; apply ST_IfLeft ; assumption.
    SCase "t1 steps, t2 steps".
      destruct Hsteps1 as [t1'].
      exists (tif f t1' t2) ; apply ST_IfLeft ; assumption.
Qed.

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_pair1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tpair t1 t2)
  | afi_pair2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tpair t1 t2)
  | afi_fst : forall x t,
      appears_free_in x t ->
      appears_free_in x (tfst t)
  | afi_snd : forall x t,
      appears_free_in x t ->
      appears_free_in x (tsnd t)
  | afi_fix : forall x t,
      appears_free_in x t ->
      appears_free_in x (tfix t)
  | afi_if1 : forall x f t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tif f t1 t2)
  | afi_if2 : forall x f t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tif f t1 t2)
  .

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"
  | Case_aux c "afi_pair1" | Case_aux c "afi_pair2"
  | Case_aux c "afi_fst" | Case_aux c "afi_snd"
  | Case_aux c "afi_fix"
  | Case_aux c "afi_if1" | Case_aux c "afi_if2"
  ].

Hint Constructors appears_free_in.

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite extend_neq in H7; assumption.
Qed.

Lemma closed_typing : forall t T,
  empty |- t \in T ->
  closed t.
Proof.
  intros t T HT.
  unfold closed.
  intro x.
  unfold not.
  intro Hafi.
  absurd (exists (T':ty), empty x = Some T').
  unfold not. intro Hsilly. inversion Hsilly. inversion H.
  apply free_in_context with t T; assumption.
Qed.

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  has_type_cases (induction H) Case; intros; auto.
  Case "T_Var".
    apply T_Var. rewrite <- H0...
  Case "T_Abs".
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [extend Gamma x T11] *)
    unfold extend. destruct (eq_id_dec x0 x1)...
  Case "T_App". apply T_App with T11...
  Case "T_Fst". apply T_Fst with T2...
  Case "T_Snd". apply T_Snd with T1...
Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     extend Gamma x U |- t \in T ->
     empty |- v \in U   ->
     Gamma |- [x:=v]t \in T.

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  t_cases (induction t) Case; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  Case "tvar".
    rename i into y. destruct (eq_id_dec x y).
    SCase "x=y".
      subst.
      rewrite extend_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      apply T_Var. rewrite extend_neq in H2...
  Case "tabs".
    rename i into y. apply T_Abs.
    destruct (eq_id_dec x y).
    SCase "x=y".
      eapply context_invariance...
      subst.
      intros x Hafi. unfold extend.
      destruct (eq_id_dec y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      destruct (eq_id_dec y z)...
      subst. rewrite neq_id...
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t ==> t'  ->
     empty |- t' \in T.

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  Ltac doesnt_step := inversion HE.
  has_type_cases (induction HT) Case;
       intros t' HE; subst.
  Case "T_Var". doesnt_step.
  Case "T_Abs". doesnt_step.
  Case "T_App".
    (* ST_AppAbs: app (abs x t1) t2 steps to t1[x=t2]
         and substitution preserves typing.
       ST_App: t1 t2 steps to app t1' t2
         By induction, t1' has the same type as t1, so t1' t2 has the
         same type as t1' t2.
    *)
    inversion HE; subst.
    SCase "ST_AppAbs".
      apply substitution_preserves_typing with T11...
      inversion HT1...
    SCase "ST_App".
      apply T_App with T11 ;
      [ apply IHHT1 ; [ reflexivity | assumption ]
      | assumption].
  Case "T_Unit". doesnt_step.
  Case "T_Pair". doesnt_step.
  Case "T_Fst".
    (* ST_FstPair: fst (t1, t2) steps to t1
       ST_Fst: fst t steps to fst t'
         t goes to t', which has the same type as t by induction.
         Then fst t' has the same type as fst t.
    *)
    inversion HE; subst.
    SCase "ST_FstPair".
      inversion HT ; subst. assumption.
    SCase "ST_Fst".
      apply T_Fst with T2.
      apply IHHT; [reflexivity | assumption].
  Case "T_Snd".
    (* ST_SndPair: snd (t1, t2) steps to t2
       ST_Snd: snd t steps to snd t'
         t goes to t', which has the same type as t by induction.
         Then snd t' has the same type as snd t.
    *)
    inversion HE; subst.
    SCase "ST_SndPair".
      inversion HT ; subst. assumption.
    SCase "ST_Snd".
      apply T_Snd with T1;
      apply IHHT; [ reflexivity | assumption].
  Case "T_Fix".
    (* tfix t must step to (tapp t (tfix t)),
       and because (tfix t) has type T, and t has type T -> T,
       (tapp t (tfix t)) also has type T.
    *)
    inversion HE. subst.
    apply T_App with T; [ assumption | apply T_Fix ; assumption].
  Case "T_Formula". doesnt_step.
  Case "T_If".
    inversion HE ; subst.
    SCase "IfAbs".
      inversion HT1 ; subst ; inversion HT2 ; subst.
      apply T_Abs.
      apply T_If.
      apply T_App with T0.
      apply context_invariance with empty.
      apply T_Abs ; assumption.

      intros x0 Hfree.
      absurd (appears_free_in x0 (tabs x1 T0 t0)).
      assert (closed (tabs x1 T0 t0)).
      apply closed_typing with (TArrow T0 T12) ; assumption.
      unfold closed in H.
      specialize H with x0. apply H.
      apply Hfree.
      apply T_Var. auto.

      apply T_App with T0.
      apply context_invariance with empty.
      assumption.
      intros x0 Hfree.
      absurd (appears_free_in x0 (tabs x2 T0 t3)).
      assert (closed (tabs x2 T0 t3)).
      apply closed_typing with (TArrow T0 T12) ; assumption.
      unfold closed in H.
      specialize H with x0. apply H.
      apply Hfree.
      apply T_Var. auto.

    SCase "IfUnit". inversion HT2. apply T_Unit.
    SCase "IfPair".
      inversion HT1 ; subst ; inversion HT2; subst.
      apply T_Pair; apply T_If ; assumption.
    SCase "IfFormula". inversion HT1. apply T_Formula.
    SCase "IfLeft".
      apply T_If.
      apply (IHHT1 (eq_refl empty)) ; assumption.
      assumption.
    SCase "IfRight".
      apply T_If.
      assumption.
      apply (IHHT2 (eq_refl empty)) ; assumption.
Qed.

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti. apply Hnot_val.
   destruct (progress x0 T).
   apply Hhas_type. apply H.
   contradiction.

   apply IHHmulti.
   apply (preservation x0 y0). apply Hhas_type. apply H.
   apply Hnf. apply Hnot_val.
Qed.

Theorem step_deterministic : forall t t1 t2 T,
   empty |- t \in T ->
   t ==> t1 ->
   t ==> t2 ->
   t1 = t2
   .
Proof.
  intro t.
  t_cases (induction t) Case;
    (* terms which are values are solved by inversion on Hstep1 *)
    intros ty1 ty2 T HT Hstep1 Hstep2 ; inversion Hstep1 ; subst ; inversion Hstep2 ; subst.
  Case "tapp".
    SCase "tf = tabs x0 T0 t0".
      SSCase "tf = tabs x0 T0 t0". reflexivity.
      SSCase "tf steps". inversion H2. (* tabs can't step *)
    SCase "tf steps".
      SSCase "tf = tabs". inversion H2. (* tabs can't step *)
      SSCase "tf steps". (* by induction, tf steps to the same place *)
         f_equal.
         inversion HT.
         apply IHt1 with (TArrow T11 T) ; assumption.
  Case "tfst".
    SCase "fst pair".
      SSCase "fst pair". reflexivity.
      SSCase "fst". inversion H0. (* pair can't step *)
    SCase "fst".
      SSCase "fst pair". inversion H0.
      SSCase "fst".
        f_equal.
        inversion HT.
        apply IHt with (TProd T T2) ; assumption.
  Case "tsnd".
    SCase "snd pair".
      SSCase "snd pair". reflexivity.
      SSCase "snd". inversion H0.
    SCase "snd".
      SSCase "snd pair". inversion H0.
      SSCase "snd".
        f_equal.
        inversion HT.
        apply IHt with (TProd T1 T) ; assumption.
  Case "tfix". reflexivity.
  Case "tif".
     SCase "IfAbs".
      SSCase "IfAbs". reflexivity.
      SSCase "IfLeft". inversion H3.
      SSCase "IfRight". inversion H4.
     SCase "IfUnit".
      SSCase "IfUnit". reflexivity.
      SSCase "IfLeft". inversion H3.
      SSCase "IfRight". inversion H4.
     SCase "IfPair".
      SSCase "IfPair". reflexivity.
      SSCase "IfLeft". inversion H3.
      SSCase "IfRight". inversion H4.
     SCase "IfFormula".
      SSCase "IfPair". reflexivity.
      SSCase "IfLeft". inversion H3.
      SSCase "IfRight". inversion H4.
     SCase "IfLeft".
      SSCase "IfAbs". inversion H3.
      SSCase "IfUnit". inversion H3.
      SSCase "IfPair". inversion H3.
      SSCase "IfFormula". inversion H3.
      SSCase "IfLeft".
        f_equal.
        inversion HT ; subst.
        apply IHt1 with T ; assumption.
      SSCase "IfRight".
        destruct H4 ; inversion H3.
     SCase "IfRight".
      SSCase "IfAbs". inversion H4.
      SSCase "IfUnit". inversion H4.
      SSCase "IfPair". inversion H4.
      SSCase "IfFormula". inversion H4.
      SSCase "IfLeft". destruct H3 ; inversion H5.
      SSCase "IfRight".
        f_equal.
        inversion HT ; subst.
        apply IHt2 with T ; assumption.
Qed.

End SmtrgProp.


Require Import PolyDefs PolyVal Bool.
Import ZArith Lia.
Require Import PolyArith Valid.

(* Boolean Formulas *)

Definition impb (b1 b2: bool) := if b1 then b2 else true.
Definition cst_poly (z:Z) := {| VP_value := (Cst z); VP_prop := eq_refl |}.

Inductive form : Set :=
| f_true 	: form
| f_false   : form
| f_var 	: nat -> form
| f_and 	: form -> form -> form
| f_or  	: form -> form -> form
| f_not 	: form -> form
| f_imp 	: form -> form -> form
.

Fixpoint eval_form (f:form) (val : nat -> bool) : bool :=
  match f with
  | f_true => true
  | f_false => false
  | f_var i => val i
  | f_and f1 f2 => eval_form f1 val && eval_form f2 val
  | f_or f1 f2 => eval_form f1 val || eval_form f2 val
  | f_not f1 => negb (eval_form f1 val	)
  | f_imp f1 f2 => impb (eval_form f1 val) (eval_form f2 val)
  end
.

#[local] Hint Constructors form : core.
Notation "A ∧ B" := (f_and A B) (at level 30, right associativity).
Notation "A ∨ B" := (f_or A B) (at level 35, right associativity).
Notation "A → B" := (f_imp A B) (at level 49, right associativity, B at level 50).
Notation "⊤" := (f_true) (at level 5).
Notation "⊥" := (f_false) (at level 5).
Notation "# x" := (f_var x) (at level 10).
Notation "! A" := (f_not A) (at level 11).

Definition valuation := (fun x => match x with |0 => false |_=> true end).

Eval compute in (eval_form (# 0 ∨ # 1) valuation).
(* Eval compute in (eval_form (# 0 → # 1) valuation).
Eval compute in (eval_form (# 1 → # 0) valuation).
Eval compute in (eval_form (# 1 → # 1) valuation). *)

From Coq Require Import List .
Import ListNotations .

Ltac list_add a l :=
  let rec aux a l n :=
    match l with
    | [] => constr :(( n , a :: l ))
    | a :: _ => constr :(( n , l ))
    | ?x :: ?l =>
      match aux a l ( S n ) with
      | (?n , ?l ) => constr :(( n , x :: l ))
      end
    end
  in
  aux a l O
.

Ltac read_term_ f l :=
match f with
|negb ?x =>
  match read_term_ x l with
  |(?x' , ?l') => constr:(( f_not x' , l'))
  end
|andb ?x ?y =>
  match read_term_ x l with
  |(?x' , ?l') => match read_term_ y l' with
    |(?y' , ?l'') => constr:(( f_and x' y' , l''))
  end end
|orb ?x ?y =>
  match read_term_ x l with
  |(?x' , ?l') => match read_term_ y l' with
    |(?y' , ?l'') => constr:(( f_or x' y' , l''))
  end end
|impb ?x ?y =>
  match read_term_ x l with
  |(?x' , ?l') => match read_term_ y l' with
    |(?y' , ?l'') => constr:(( f_imp x' y' , l''))
  end end
|false => constr:((f_false , l))
|true => constr:((f_true , l))

|_ =>
  match list_add f l with
  | (?n , ?l') =>  constr:(( f_var n , l'))
  end
end.

Ltac read_term f := read_term_ f (@nil bool).

Goal forall b : bool , True .
intros b.
let v := read_term (andb b ( negb b)) in
idtac v.
let v := read_term (orb b (negb ( negb b))) in
idtac v.
let v := read_term (andb b (negb false)) in
idtac v.
let v := read_term (orb (negb false) true) in
idtac v.
let v := read_term (impb (negb b) true) in
idtac v.
let v := read_term (impb (false) true) in
idtac v.
Abort.

Definition sub_poly (p q:valid_poly) := sum_poly p (mul_poly (cst_poly (-1)%Z) q).

Lemma poly_val_cst (z:Z) (val:nat->Z) : (poly_val (cst_poly z) val) = z.
Proof.
  unfold poly_val. unfold cst_poly.
  simpl.
  reflexivity.
Qed.

Lemma poly_val_sub (p q : valid_poly) (val:nat->Z) :
poly_val (sub_poly p q) val = Z.sub (poly_val p val)  (poly_val q val)
.
Proof.
  unfold sub_poly.
  rewrite sum_poly_val.
  rewrite mul_poly_val.
  simpl.
  destruct (poly_val q val); intuition.
Qed.

Fixpoint to_poly (f:form) (val:nat->bool) : valid_poly :=
  match f with
  |f_true => cst_poly 1%Z
  |f_false => cst_poly 0%Z
  |f_and a b => mul_poly (to_poly a val) (to_poly b val)
  |f_or a b => sub_poly (sum_poly (to_poly a val) (to_poly b val)) (mul_poly (to_poly a val) (to_poly b val))
  |f_not a =>  sub_poly (cst_poly 1%Z) (to_poly a val)
  |f_var n => if (val n) then cst_poly 1%Z else cst_poly 0%Z
|f_imp a b => sub_poly (sum_poly (sub_poly (cst_poly 1%Z) (to_poly a val)) (to_poly b val)) (mul_poly (sub_poly (cst_poly 1%Z) (to_poly a val)) (to_poly b val))
end.

Definition z_of_bool := (fun x : bool => if x then 1%Z else 0%Z).

Theorem eval_form_to_poly  (f:form) (val : nat -> bool) :
z_of_bool (eval_form f val) =
poly_val (to_poly f val) (fun n => z_of_bool (val n)).
Proof.
  induction f; simpl eval_form; simpl to_poly.
  - reflexivity.
  - reflexivity.
  - destruct (val n); reflexivity.
  - rewrite mul_poly_val.
    rewrite <- IHf1. rewrite <- IHf2.
    destruct (eval_form f1 val).
    + rewrite andb_true_l. simpl z_of_bool. lia.
    + rewrite andb_false_l. simpl z_of_bool. lia.
  - rewrite poly_val_sub. rewrite sum_poly_val. rewrite mul_poly_val.
    rewrite <- IHf1. rewrite <- IHf2.
    destruct ((eval_form f1 val)); simpl z_of_bool.
    + destruct (eval_form f2 val); simpl; reflexivity.
    + simpl. lia.
  - rewrite poly_val_sub.
    rewrite poly_val_cst.
    rewrite <- IHf.
    destruct (eval_form f val); simpl; reflexivity.
  - rewrite poly_val_sub. rewrite sum_poly_val.
    rewrite mul_poly_val. rewrite poly_val_sub.
    rewrite <- IHf1. rewrite <- IHf2.
    rewrite poly_val_cst.
    destruct (eval_form f1 val); simpl impb; simpl z_of_bool; lia.
Qed.

Definition eq_form (f1:form) (l1: list bool) (f2:form) (l2: list bool) :=
  forall (val:nat->Z),
  poly_val (to_poly f1 (fun n => List.nth n l1 false)) val = poly_val (to_poly f2 (fun n => List.nth n l1 false)) val
  .

Eval compute in (VP_value (to_poly (f_and f_true f_false) (fun n => false))).

(* Example : here we can prove that (false || b) = false, in the environnement where b is true *)
Goal (eq_form (f_and f_false (f_var 0)) [true] f_false [] ).
unfold eq_form.
simpl.
unfold cst_poly.
intro.
rewrite mul_poly_val.
unfold poly_val.
simpl.
reflexivity.
Qed.

(* Example : here we can prove that (b0 || b1) = (b1 || b0), when b0 is true and b1 is false (in both environnements) *)
Goal (eq_form (f_and (f_var 0) (f_var 1)) [true; false] (f_and (f_var 1) (f_var 0)) [true; false] ).
unfold eq_form.
simpl.
unfold cst_poly.
intro.
rewrite mul_poly_val.
rewrite mul_poly_val.
unfold poly_val.
simpl.
reflexivity.
Qed.

(* Example : here we can prove that ((b0 || b1) && b2) = (b2 && (b1 || b0)), when b0 is true and b1 is false (in both environnements) *)
Goal (eq_form  (((# 0) ∨ (# 1)) ∧ # 2) [true; false; false] (# 2 ∧ ((# 1) ∨ (# 0))) [true; false; false] ).
unfold eq_form.
simpl.
unfold cst_poly.
intro.
rewrite mul_poly_val.
rewrite mul_poly_val.
unfold sub_poly.
unfold cst_poly.
rewrite sum_poly_val.
rewrite sum_poly_val.
rewrite sum_poly_val.
rewrite sum_poly_val.
simpl.
reflexivity.
Qed.