(** Coq coding by choukh, July 2022 **)

Require Import Notions Equivalence NatEmbed PartialFunc CT.
Require Import EnumerabilityFacts.

(* 克莱尼的SMN定理 https://en.wikipedia.org/wiki/Smn_theorem *)
Definition SMN (ϕ : ℕ → ℕ → ℕ → ℕ?) := ∃ S : ℕ → ℕ → ℕ,
  ∀ c x y, ϕ (S c x) y ≡{_} ϕ c ⟨x, y⟩.

Definition SMNᵂ (W : ℕ → ℕ → Prop) := ∃ S : ℕ → ℕ → ℕ,
  ∀ c x y, W (S c x) y ↔ W c ⟨x, y⟩.

(* 综合式 (Synthetic) 邱奇论题 *)
Definition SCT := Σ ϕ : ℕ → ℕ → ℕ → ℕ?,
  (∀ c x, 安定 (ϕ c x)) ∧
  ∀ fᵢ : ℕ → ℕ → ℕ, ∃ cᵢ, ∀ i x, ∃ n, ϕ (cᵢ i) x n = Some (fᵢ i x).

Definition SCTᴮ := Σ ϕ : ℕ → ℕ → ℕ → bool?,
  (∀ c x, 安定 (ϕ c x)) ∧
  ∀ fᵢ : ℕ → ℕ → bool, ∃ cᵢ, ∀ i x, ∃ n, ϕ (cᵢ i) x n = Some (fᵢ i x).

(* 综合式EA *)
Definition SEA := Σ ε : ℕ → ℕ → ℕ?,
  ∀ fᵢ : ℕ → ℕ → ℕ?, ∃ cᵢ, ∀ i, ε (cᵢ i) ≡{_} fᵢ i.

Definition SEAᵖₑ (ε : ℕ → ℕ → ℕ?) :=
  ∀ p : ℕ → ℕ → Prop, 参数化可枚举 p → ∃ cᵢ, 参数化枚举器 p (λ i, ε (cᵢ i)).

Definition SEAᵖₑ_uncurry (ε : ℕ → ℕ → ℕ?) :=
  ∀ p : ℕ → ℕ → Prop, 可枚举 (uncurry p) → ∃ cᵢ, 参数化枚举器 p (λ i, ε (cᵢ i)).

Definition SEAᵖ := Σ ε, SEAᵖₑ ε.

(* 综合式EPF *)
Definition SEPF `{偏函数模型} := Σ ε : ℕ → ℕ ⇀ ℕ,
  ∀ fᵢ : ℕ → ℕ ⇀ ℕ, ∃ cᵢ, ∀ i, ε (cᵢ i) ≡{_} fᵢ i.

Definition SEPFᴮ `{偏函数模型} := Σ ε : ℕ → ℕ ⇀ bool,
  ∀ fᵢ : ℕ → ℕ ⇀ bool, ∃ cᵢ, ∀ i, ε (cᵢ i) ≡{_} fᵢ i.

Theorem CT_SMN_to_SCT : (Σ ϕ, CTᵩ ϕ ∧ SMN ϕ) → SCT.
Proof.
  intros [ϕ H]. exists ϕ.
  destruct H as [[sat def] [S SMN]].
  split; auto. intros f.
  destruct (def (λ' ⟨x, y⟩, f x y)) as [c Hc].
  exists (S c). intros. eapply SMN.
  destruct (Hc ⟨i, x⟩). rewrite GF in H. eauto.
Qed.

Theorem SCT_to_CT : SCT → CT.
Proof.
  intros [ϕ [sat def]]. exists ϕ. split.
  - apply sat.
  - intros f. specialize (def (λ _, f)) as [γ H].
    exists (γ 0). intros. eauto.
Qed.

Lemma SEAᵖₑ_iff_SEAᵖₑ_uncurry (ε : ℕ → ℕ → ℕ?) : SEAᵖₑ ε ↔ SEAᵖₑ_uncurry ε.
Proof.
  split; intros H p Hp.
  - eapply 参数化可枚举反柯里化 in Hp; eauto.
  - apply H. eapply 参数化可枚举反柯里化; eauto.
Qed.

Lemma EAᵖ_SMNᵂ_to_SEAᵖₑ (ea : EAᵖ) : let ε := projT1 ea in SMNᵂ (W ε) → SEAᵖₑ ε.
Proof.
  destruct ea as [ε ea]. simpl.
  intros smn. apply SEAᵖₑ_iff_SEAᵖₑ_uncurry.
  intros p Hp. apply 反柯里化可枚举嵌入 in Hp.
  destruct ((proj1 (ea _)) Hp) as [c Hc].
  destruct smn as [S HS]. exists (λ x, S c x).
  intros x y. unfold 枚举器 in Hc. unfold W in HS.
  now rewrite HS, <- Hc, GF.
Qed.


Require Import List.
Require Import cotrans_derived.
Require Import fixpoints.

Set Implicit Arguments.

Inductive item : Set :=
  | atom (n : nat)
  | cons (l r : item).
Inductive inst :=
  | call
  | prim (op : list item -> list item).
Inductive cfg :=
  Cfg : list inst -> list item -> cfg.

Parameter prog : nat -> option (list inst).

Inductive step : cfg -> cfg -> Prop :=
  | prim_step : forall f code stk,
                  step (Cfg (prim f :: code) stk)
                       (Cfg code (f stk))
  | prim_call : forall label env code code' stk,
                  prog label = Some code' ->
                  step (Cfg (call :: code) ((cons (atom label) env) :: stk))
                       (Cfg code' (env :: stk)).

Module CallLanguage <: language.
Definition cfg := cfg.
Definition step := step.
End CallLanguage.

Module F := HoFixpoints CallLanguage.
Import F.
Import F.C.

(*
Definition RRel : Type := cfg -> (cfg -> Prop) -> Prop.
Definition subrel (A B : RRel) : Prop := forall x P, A x P -> B x P.
Definition mono (F : RRel -> RRel) : Prop := forall A B, subrel A B -> subrel (F A) (F B).

Definition weakenable (R : RRel) : Prop :=
  forall (P Q : cfg -> Prop), (forall x, P x -> Q x) ->
     forall x, (R x P -> R x Q).

Definition weakenize (R : RRel) : RRel :=
  fun x P => exists Q, R x Q /\ (forall x, Q x -> P x).

Definition min_ext (P : RRel -> Prop) (F : RRel -> RRel) : Prop :=
  (forall R, P (F R)) /\
  (forall R, subrel R (F R)) /\
  (forall R R', subrel R R' -> P R' -> subrel (F R) R').

Lemma weakenize_good : min_ext weakenable weakenize.
repeat split;firstorder.
Qed.
 *)

Definition proprop (P : RRel -> RRel -> Prop) : Prop :=
  (forall A B, weakenable A -> weakenable B -> subrel A B ->
        (forall X, weakenable X -> P X A -> P X B)
     /\ (forall X, weakenable X -> P B X -> P A X)).

Inductive ty := num | func (a b : ty).

Fixpoint represents (i : item) (t : ty) (N P : RRel) : Prop :=
  match t with
  | num => match i with
           | atom _ => True
           | _ => False
           end
  | func t1 t2 =>
      (forall arg,
         represents arg t1 P N ->
         (forall code stk r,
           P (Cfg (call :: code) (i :: arg :: r :: stk))
             (fun cfg' =>
              match cfg' with
              | Cfg (call :: _) (r' :: v' :: stk') =>
                 r' = r /\ stk' = stk /\
                   represents v' t2 N P
              | _ => False
              end)))
  end.

Definition subweak (X Y : RRel) : Prop :=
  forall (P Q : cfg -> Prop), (forall x, P x -> Q x) -> forall x, X x P -> Y x Q.

Lemma represents_mixed : forall t (A B X Y : RRel),
  subweak A B -> subweak X Y -> forall i, represents i t B X -> represents i t A Y.

induction t;simpl;intros.
tauto.
assert (represents arg t1 X B) by
  (revert H2;apply IHt1;assumption).
specialize (H1 arg H3 code stk r).
revert H1.
apply H0.
destruct x.
destruct l;trivial.
destruct i0;trivial.
destruct l0;trivial.
destruct l0;trivial.
intuition.
revert H6.
apply IHt2;assumption.
Qed.

Lemma represents_happy : forall t i, proprop (represents i t).
unfold proprop;intros. revert i.
induction t.
unfold represents;split;trivial.
split;simpl;intros.
(* Mono in second arg *)
specialize (H3 arg).
apply IHt1 in H4;[|assumption].
specialize (H3 H4 code stk r).
apply H1 in H3.
revert H3.
(* need to weaken B here *) apply H0.
clear IHt1.
destruct x.
destruct l;[tauto|].
destruct i0;[|tauto].
destruct l0;[tauto|].
destruct l0;[tauto|].
intuition.
apply IHt2;assumption.
(* Anti-mono in first *)
specialize (H3 arg).
apply IHt1 in H4;[|assumption].
specialize (H3 H4 code stk r).
revert H3.
apply H2.
clear IHt1.
destruct x.
destruct l;[tauto|].
destruct i0;[|tauto].
destruct l0;[tauto|].
destruct l0;[tauto|].
intuition.
apply IHt2;assumption.
Qed.

Parameter id_addr : nat.
Axiom id_code : prog id_addr =
 Some (prim (fun stk => match stk with
        | _ :: v :: r :: rest => r :: v :: rest
        | _ => stk
        end)
    :: call :: nil).

Inductive id_spec (N P : RRel) : RRel :=
  | id_call : forall v t,
               represents v t N P ->
              forall r code stk (Q : cfg -> Prop),
                (forall cfg',
                    match cfg' with
                   | Cfg (call :: _) (r' :: v' :: stk') =>
                        r' = r /\ stk' = stk /\
                       represents v' t P N
                   | _ => False
                   end -> Q cfg') ->
               id_spec N P (Cfg (call :: code) (cons (atom id_addr) (atom 0) :: v :: r :: stk)) Q.

Lemma id_spec_anti :
  forall A B, weakenable A -> weakenable B -> subrel A B ->
  forall X, weakenable X -> subrel (id_spec B X) (id_spec A X).
intros.  destruct 1.
pose proof (represents_happy t).
apply id_call with t.
revert H3. apply H5;assumption.
intros.
apply H4.
destruct cfg'.
destruct l;[destruct H6|].
destruct i;[|destruct H6].
destruct l0;[destruct H6|].
destruct l0;[destruct H6|].
intuition.
revert H9. apply H5; assumption.
Qed.

Lemma id_spec_mono :
  forall X Y, weakenable X -> weakenable Y -> subrel X Y ->
  forall A, weakenable A -> subrel (id_spec A X) (id_spec A Y).
intros. destruct 1.
apply id_call with t.
revert H3; apply represents_happy;assumption.
intros. apply H4.
destruct cfg'.
destruct l;[exfalso;assumption|].
destruct i;[|exfalso;assumption].
destruct l0;[exfalso;assumption|].
destruct l0;[exfalso;assumption|].
intuition.
revert H8. apply represents_happy;assumption.
Qed.

Definition mixed_weak (F : RRel -> RRel -> RRel) : Prop :=
  forall (S T : RRel),
    (forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       (forall x, T x P -> S x Q)) ->
  forall (X Y : RRel),
    (forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       (forall x, X x P -> Y x Q)) ->
    forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       forall x, F S X x P -> F T Y x Q.

(*
Inductive derived (F : RRel -> RRel)
                   (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | dleaf : X x P -> derived F X x P
  | ddone : P x -> derived F X x P
  | dstep : forall y, step x y -> derived F X y P -> derived F X x P
  | drule' : forall Q, subrel Q (derived F X) -> F Q x P -> derived F X x P.
Definition drule : forall F R x P, F (derived F R) x P -> derived F R x P :=
  fun _ _ _ _ H => drule' _ _ (fun _ _ H => H) H.

Inductive stepF (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | DoneF : P x -> stepF X x P
  | StepF : forall y, step x y -> X y P -> stepF X x P.
*)

Definition hoproof Rules Spec : Prop :=
     forall (Neg Pos : RRel)
       (Neg_ev : subrel (derived Rules (Spec Neg Pos)) Neg)
       (Pos_ev : subrel Pos (derived Rules (Spec Neg Pos))),
       subrel (Spec Neg Pos) (stepF (derived Rules (Spec Neg Pos))).

(*
Inductive trans_rule (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | dtrans : forall (Q : cfg -> Prop), X x Q ->
             (forall y, Q y -> X y P) -> trans_rule X x P.
*)

Lemma stepF_weak : forall R, weakenable R -> weakenable (stepF R).
unfold weakenable. intros. destruct H1; eauto using stepF.
Qed.

Lemma trans_weak : forall R, weakenable R -> weakenable (trans_rule R).
unfold weakenable. intros. destruct H1; eauto using trans_rule.
Qed.

Lemma derived_weak1 : forall F R,
  mono F ->
  weakenable R -> weakenable (derived (fun X => weakenize (F X)) R).
intros F R F_mono R_weak.
unfold weakenable.
induction 2;try solve[eauto using derived].
assert (weakenize (F Q0) x Q) by
  (destruct H2 as [P0 []]; exists P0; eauto).
clear H2.
apply drule.
destruct H3 as [P0 []];exists P0.
split;[|tauto].
apply F_mono in H0.
apply H0.
assumption.
Qed.

Lemma derived_trans_weak : forall R,
  weakenable R ->
  weakenable (derived trans_rule R).
intros.
induction 2;try solve[eauto using derived].
destruct H3.
apply drule.
apply dtrans with Q1.
apply H1. assumption.
intros.
eapply H2.
apply H4. assumption.
assumption.
Qed.

Definition union_rrel (R1 R2 : RRel) : RRel :=
  fun x P => R1 x P \/ R2 x P.

Inductive lfp (F : RRel -> RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  Lfp' : forall Q, subrel Q (lfp F) -> F Q x P -> lfp F x P.
Definition Lfp : forall F, subrel (F (lfp F)) (lfp F) :=
  fun F x P H => Lfp' x P (fun _ _ H => H) H.

CoInductive reaches (x : cfg) (P : cfg -> Prop) : Prop :=
  | Done : P x -> reaches x P
  | Step : forall y, step x y -> reaches y P -> reaches x P
  .

Lemma id_weakenable :
 forall X Y : RRel, weakenable X -> weakenable Y ->
   weakenable (id_spec X Y).
intros; unfold weakenable; intros.
destruct H2.
eapply id_call; eauto.
Qed.

(*
Definition adj_weak (F : RRel -> RRel) : Prop :=
  forall (X Y : RRel),
    (forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       (forall x, X x P -> Y x Q)) ->
    forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       forall x, F X x P -> F Y x Q.
 *)

Lemma id_adj : mixed_weak id_spec.
unfold mixed_weak;intros.
fold (subweak T S) in H.
fold (subweak X Y) in H0.

destruct H2.
apply id_call with t.
revert H2.
apply represents_mixed;assumption.

intros;apply H1;apply H3.
destruct cfg'.
destruct l;[tauto|].
destruct i;[|tauto].
destruct l0;[tauto|].
destruct l0;[tauto|].
intuition.

revert H7;apply represents_mixed;assumption.
Qed.

Lemma id_good :
   forall Neg Pos : RRel,
   weakenable Neg -> weakenable Pos ->
   subrel (derived trans_rule (id_spec Neg Pos)) Neg ->
   subrel Pos (derived trans_rule (id_spec Neg Pos)) ->
   subrel (id_spec Neg Pos) (stepF (derived trans_rule (id_spec Neg Pos))).
intros Neg Pos W_Neg W_Pos H_Neg H_Pos.
unfold subrel;intros.
destruct H.
eapply StepF. constructor. exact id_code.
eapply dstep. constructor. simpl.
eapply ddone.

apply H0.
intuition.
assert (subweak Pos Neg) by firstorder.
revert H. apply represents_mixed;assumption.
Qed.

(* Now need to make sure the soundness can carry through if
   we restrict to only "weakenable" instantiations *)

Require Import Morphisms.
Lemma trans_adj_weak : adj_weak trans_rule.
unfold adj_weak, weak_subrel, subpred, Proper, respectful. firstorder.
Qed.

Lemma trans_sound : forall Claims, derived_stable trans_rule Claims -> sound Claims.
intros. apply deri_sound with trans_rule.
  apply validity_from_m. apply trans_mono. apply trans_valid.
  assumption.
Qed.

Definition id_sound_prop' := @higher_order_stability'
  id_spec id_adj
  trans_rule trans_adj_weak trans_valid trans_sound
  id_good.

Lemma id_sound_prop :
 let derived_lfp :=
       fun Neg : RRel =>
       F.lfp (fun A : RRel => derived trans_rule (id_spec Neg A)):RRel in
 let N := F.union_rrel C.reaches (derived_lfp C.reaches) in
 subrel (id_spec N (derived_lfp N)) C.reaches.
Admitted.

(* Seems like the arguments are swapped between the spec and the represents predicate *)
Lemma id_type : forall N P B (H_pf : subrel (id_spec N P) B),
  subweak N B -> forall A, subweak A P -> forall t,
  represents (cons (atom id_addr) (atom 0)) (func t t) A B.
intros.
simpl.
intros.
apply H_pf. apply id_call with t.
eapply represents_mixed;[| |eassumption];assumption.

intros.
destruct cfg'.
repeat match goal with
|[|- match ?c with _ => _ end] => destruct c;try solve[exfalso;assumption];[idtac]
end.
intuition.
eapply represents_mixed;[| |eassumption];assumption.
Qed.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


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

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

Print Assumptions add.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import vst.mergesort.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Require Export Coq.Lists.List.
Require Export Coq.Arith.Arith.
Require Import Program.Wf.

Definition my_mergesort_spec : ident * funspec :=
 DECLARE _my_mergesort
 WITH p: val,  sh : share, il: list Z, gv: globals
 PRE [ tptr tuint , tint ]
    PROP (readable_share sh;
          3 < Zlength il <= Int.max_signed)
    PARAMS (p; Vint (Int.repr (Zlength il - 1 )) )
    GLOBALS(gv)
    SEP  (data_at sh (tarray tuint (Zlength il)) (map Vint (map Int.repr il)) p;
          mem_mgr gv)
 POST [ tvoid ]
    PROP ( ) RETURN ()
    SEP (data_at sh (tarray tuint (Zlength il)) (map Vint (map Int.repr il)) p;
         mem_mgr gv).

Definition Gprog : funspecs :=
  ltac:(with_library prog [
             my_mergesort_spec
 ]).

Lemma body_my_mergesort: semax_body Vprog Gprog f_my_mergesort my_mergesort_spec.
Proof.
  start_function.

  assert_PROP (Zlength il = Zlength (map Vint (map Int.repr il))).
  entailer!.
  forward.
  entailer!.
Qed.


Require Import QWIRE.Prelim.

Definition is_one_step_graph n1 n2 := length (get_path n1 n2) =? 2
Definition is_two_step_graph n1 n2 := length (get_path n1 n2) =? 3

Definition is_in_hp_graph x1 x2 y1 y2 u := (* two nodes: (x1, x2) (y1, y2) *)
 (is_one_step_path x1 y1) \/
 ((is_two_step_path x2 y2) /\ (is_elem x2 u))

 Definition get_path_hp x1 x2 y1 y2 u := (* two nodes: (x1, x2) (y1, y2) *)
 if is_in_hp_graph x1 x2 y1 y2 u then [(x1,x2), (y1,y2)]
 else if x1 < y1 then move_right_hp x1 x2 y1 y2 u
      else move_left_hp x1 x2 y1 y2 u

(* Inductive Vi_hp_g : list nat -> list nat
                             -> (nat -> nat -> bool)
                             -> (nat -> nat -> bool)
                             -> Prop := *)

Fixpoint intersect_v (l1 : list nat) pi : (list nat) :=
match l1 with
| [] => []
| (h :: t) => if (dom_pi h pi) && (not (pi_vi h pi))
              then (h:(intersect_v t pi))
              else (intersect_v t pi)

(** dom_pi h pi == v in dom(pi) **)
pi_vi h pi :=

Definition deg_pi pi :=


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition kepler2_bmap_list := [Build_varinfo Tdouble 1%positive (4) (636e-2);Build_varinfo Tdouble 2%positive (4) (636e-2);Build_varinfo Tdouble 3%positive (4) (636e-2);Build_varinfo Tdouble 4%positive (4) (636e-2);Build_varinfo Tdouble 5%positive (4) (636e-2);Build_varinfo Tdouble 6%positive (4) (636e-2)].

Definition kepler2_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list kepler2_bmap_list) in exact z).

Definition kepler2 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) (x5 : ftype Tdouble) (x6 : ftype Tdouble) :=
  cast Tdouble (((((((((x1 * x4)%F64 * ((((((-x1) + x2)%F64 + x3)%F64 - x4)%F64 + x5)%F64 + x6)%F64)%F64 + ((x2 * x5)%F64 * (((((x1 - x2)%F64 + x3)%F64 + x4)%F64 - x5)%F64 + x6)%F64)%F64)%F64 + ((x3 * x6)%F64 * (((((x1 + x2)%F64 - x3)%F64 + x4)%F64 + x5)%F64 - x6)%F64)%F64)%F64 - ((x2 * x3)%F64 * x4)%F64)%F64 - ((x1 * x3)%F64 * x5)%F64)%F64 - ((x1 * x2)%F64 * x6)%F64)%F64 - ((x4 * x5)%F64 * x6)%F64)%F64).

Definition kepler2_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive;4%positive;5%positive;6%positive]) kepler2 in exact e').

Derive kepler2_b
SuchThat (forall vmap, prove_roundoff_bound kepler2_bmap vmap kepler2_expr kepler2_b)
As kepler2_bound.
Proof.
idtac "Starting kepler2".
time "kepler2" (
try (subst kepler2_b; intro; prove_roundoff_bound);
try (prove_rndval; interval));
try (prove_roundoff_bound2; error_rewrites;
try (field_simplify_Rabs);
try ((prune_terms (cutoff 60));
 do_interval)).
Qed.

Lemma check_kepler2_bound: ltac:(CheckBound kepler2_b 6.2e-12%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import HJ.Tid.
Require Import HJ.Vars.
Require Import HJ.Phasers.Lang.
Require Import Coq.Lists.List.
Require Import Coq.Lists.SetoidList.
Import Regmode.Notations.
Require Import Aniceto.List.

Open Scope reg_scope.
Module Op.
Inductive Valid (pm:phasermap) (t:tid) : op -> Prop :=
  | valid_ph_new:
    forall p,
    PhNewPre p t pm ->
    Valid pm t (PH_NEW p)
  | valid_ph_signal:
    forall p,
    PhSignalPre p t pm ->
    Valid pm t (PH_SIGNAL p)
  | valid_ph_drop:
    forall p,
    PhDropPre p t pm ->
    Valid pm t (PH_DROP p)
  | valid_signal_all:
    Valid pm t SIGNAL_ALL
  | valid_wait_all:
    (forall p ph,
      Map_PHID.MapsTo p ph pm ->
      forall v,
      Map_TID.MapsTo t v ph ->
      wait_phase v < signal_phase v) ->
    Valid pm t WAIT_ALL
  | valid_drop_all:
    Valid pm t DROP_ALL
  | valid_async:
    forall ps,
    AsyncPre ps t pm ->
    Valid pm t (ASYNC ps).

Section Props.
  Ltac handle_not :=
      right; unfold not; intros N; inversion N;
      subst;
      contradiction;
      fail.

  Let valid_wait_all_dec pm t:
    {Valid pm t WAIT_ALL} + {~ Valid pm t WAIT_ALL}.
  Proof.
    assert (valid_lt:forall v, { wait_phase v < signal_phase v } + { ~ wait_phase v < signal_phase v }). {
      auto using Compare_dec.lt_dec.
    }
    remember (List.forallb (fun kv =>
      match Map_TID.find t (snd kv) with
      | Some v => if valid_lt v then true else false
      | None => true
      end
    ) (Map_PHID.elements pm)).
    symmetry in Heqb.
    destruct b. {
      left.
      apply valid_wait_all; intros.
      rewrite forallb_forall in Heqb.
      assert (i: In (p, ph) (Map_PHID.elements pm)). {
        rewrite Map_PHID_Extra.maps_to_iff_in_elements in H; auto using phid_eq_rw.
      }
      specialize Heqb with (p,ph).
      specialize (Heqb i).
      simpl in *.
      destruct (Map_TID_Extra.find_rw t ph) as [(?,N)|(v',(R,?))]. {
        contradiction N.
        eauto using Map_TID_Extra.mapsto_to_in.
      }
      rewrite R in *.
      assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst.
      destruct (valid_lt v); auto.
      inversion Heqb.
    }
    right.
    rewrite forallb_existsb in Heqb.
    rewrite Bool.negb_false_iff in *.
    apply existsb_exists in Heqb.
    unfold not; intros N.
    destruct Heqb as ((p,ph),(Hi,Hx)).
    apply Map_PHID_Extra.maps_to_iff_in_elements in Hi; auto using phid_eq_rw.
    rewrite Bool.negb_true_iff in *.
    simpl in *.
    destruct (Map_TID_Extra.find_rw t ph) as [(R,N1)|(v',(R,?))]; rewrite R in *; clear R. {
      inversion Hx.
    }
    destruct (valid_lt v'). {
      inversion Hx.
    }
    contradiction n.
    inversion N; subst; eauto.
  Defined.

  Lemma valid_dec pm t o :
    { Valid pm t o } + { ~ Valid pm t o }.
  Proof.
    destruct o.
    - destruct (ph_new_pre_dec p t pm); try handle_not.
      auto using valid_ph_new.
    - destruct (ph_signal_pre_dec p t pm); try handle_not.
      auto using valid_ph_signal.
    - destruct (ph_drop_pre_dec p t pm); try handle_not.
      auto using valid_ph_drop.
    - auto using valid_signal_all.
    - auto using valid_wait_all_dec.
    - auto using valid_drop_all.
    - destruct (async_pre_dec p t pm); try handle_not.
      auto using valid_async.
  Defined.
End Props.
End Op.
Section Valid.
Require Import Coq.ZArith.BinInt.
Require Import HJ.Phasers.PhaseDiff.
Require Import HJ.Phasers.TransDiff.

(**
  Our notion of a valid phaser map is such that
  the transitive difference is a function, which means that
  any [t1 - ... - t2] yields the the same difference [z].
*)

Definition Valid (pm:phasermap) := TransDiffFun (pm_diff pm).
End Valid.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable ss_ : Universe -> Universe -> Prop.
Variable s_ : Universe -> Universe -> Prop.
Variable rr_ : Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable e_ : Universe -> Universe -> Prop.
Variable dom_ : Universe -> Prop.

Variable b_ : Universe.
Variable a_ : Universe.

Variable initial_model_1 : (dom_ a_ /\ (dom_ b_ /\ ss_ a_ b_)).
Variable toprove_2 : (rr_ a_ b_ -> goal_).
Variable e_in_ss_3 : (forall X Y : Universe, (e_ X Y -> ss_ X Y)).
Variable e_in_rr_4 : (forall X Y : Universe, (e_ X Y -> rr_ X Y)).
Variable trans_rr_5 : (forall X Y Z : Universe, ((rr_ X Y /\ rr_ Y Z) -> rr_ X Z)).
Variable s_in_rr_6 : (forall X Y : Universe, (s_ X Y -> rr_ X Y)).
Variable ih_ss_in_rr_7 : (forall X Y : Universe, ((s_ a_ X /\ ss_ X Y) -> rr_ X Y)).
Variable e_or_sss_8 : (forall X Y : Universe, (ss_ X Y -> (exists Z : Universe, (e_ X Y \/ (dom_ Z /\ (s_ X Z /\ ss_ Z Y)))))).

Theorem srr_9 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export hexamys.

Lemma almost_pappus : hexamy -> forall P S Q O O' A A' X M,
dist6 P O S O' Q M ->
line Q M <> line O S ->
Col O O' S ->
Col M P Q ->
Col A S P ->
Col A O M ->
Col A' S Q ->
Col A' O' M ->
Col X O Q ->
Col X P O' ->
Col X A A'.
Proof.

intros.
unfold dist6 in *.
geo_norm.
create_inter O S Q M Y.
collapse.
remove_line_occ.

not_eq x x0.
not_eq x1 x2.
not_eq x3 x4.

hexamy_proof  P O S O' Q M  P O' M O Q S.

Qed.


Require Export Maximal_Principle.

(** Zermelo Postulate **)

Module Type Zermelo_Postulate.

Declare Module Max : Maximal_Principle.

Definition En_TB B A : Class :=
  \{ λ k, k ⊂ ∪A /\ (forall a, a ∈ (A ~ B) -> a ∩ k = Φ) /\
  (forall a, a ∈ B -> exists x, a ∩ k = [x]) \}.

Definition En_T A : Class :=
  \{ λ k, exists B, B ⊂ A /\ k ∈ (En_TB B A) \}.

Theorem Zermelo : forall A,
  Ensemble A -> Φ ∉ A ->
  (forall x y, x ∈ A /\ y ∈ A -> x ≠ y -> x ∩ y = Φ) ->
  (exists D, Ensemble D /\ (forall B, B ∈ A -> exists x, B ∩ D = [x])).
Proof.
  intros.
  generalize (classic (A = Φ)); intros; destruct H2.
  - rewrite H2 in *; clear H2; exists Φ; split; intros; auto.
    generalize (Theorem16 B); intros; contradiction.
  - assert (Ensemble (En_T A)).
    { apply Axiom_Amalgamation in H; apply Theorem38 in H; auto.
      assert (En_T A ⊂ pow(∪A)).
      { unfold Subclass; intros; apply Axiom_Scheme in H3; destruct H3.
        destruct H4 as [B H4], H4; unfold En_TB in H5.
        apply Axiom_Scheme in H5; destruct H5, H6.
        unfold PowerClass; apply Axiom_Scheme; split; auto. }
      apply Theorem33 in H3; auto. }
    assert (En_T A ≠ Φ).
    { apply Property_NotEmpty in H2; destruct H2.
      generalize (classic (x = Φ)); intros; destruct H4.
      - rewrite H4 in H2; contradiction.
      - apply Property_NotEmpty in H4; destruct H4.
        apply Property_NotEmpty; exists [x0]; unfold En_T.
        AssE x0; apply Theorem42 in H5; auto.
        apply Axiom_Scheme; split; auto; exists [x]; repeat split.
        + unfold Subclass, Singleton; intros; apply Axiom_Scheme in H6.
          destruct H6; rewrite H7; try apply Theorem19; Ens.
        + unfold En_TB; apply Axiom_Scheme; repeat split; auto; intros.
          * unfold Subclass; intros; apply Axiom_Scheme in H6; destruct H6.
            rewrite H7; try apply Theorem19; Ens; apply Axiom_Scheme; Ens.
          * unfold Setminus in H6; apply Theorem4' in H6; destruct H6.
            assert (x ∈ A /\ a ∈ A); auto; apply H1 in H8.
            { generalize (classic (a ∩ [x0] = Φ)); intros; destruct H9; auto.
              apply Property_NotEmpty in H9; destruct H9.
              apply Theorem4' in H9; destruct H9; apply Axiom_Scheme in H10.
              destruct H10; rewrite H11 in *; try apply Theorem19; Ens.
              assert (x0 ∈ (x ∩ a)); try apply Theorem4'; auto.
              rewrite H8 in H12; generalize (Theorem16 x0); contradiction. }
            { intro; rewrite H9 in H7; unfold Complement in H7.
              apply Axiom_Scheme in H7; destruct H7, H10; unfold Singleton.
              apply Axiom_Scheme; split; auto. }
          * exists x0; apply Axiom_Scheme in H6; destruct H6.
            rewrite H7 in *; try apply Theorem19; Ens.
            apply Axiom_Extent; split; intros.
            -- apply Theorem4' in H8; apply H8.
            -- apply Theorem4'; split; auto; apply Axiom_Scheme in H8.
               destruct H8; rewrite H9; try apply Theorem19; Ens. }
    apply Max.MaxPrinciple in H3.
    + destruct H3 as [C H3]; unfold MaxMember in H3.
      apply H3 in H4; clear H3; destruct H4; exists C; split; Ens.
      unfold En_T in H3; apply Axiom_Scheme in H3; destruct H3.
      destruct H5 as [B H5], H5.
      generalize (classic (B = A)); intro; destruct H7.
      * rewrite H7 in H6; apply Axiom_Scheme in H6; apply H6.
      * double H5; apply Property_Φ in H8; assert (A ~ B <> Φ).
        { intro; apply H8 in H9; symmetry in H9; tauto. }
        clear H7 H8; apply Property_NotEmpty in H9; destruct H9.
        unfold Setminus in H7; apply Theorem4' in H7; destruct H7.
        generalize (classic (x = Φ)); intro; destruct H9;
        try (rewrite H9 in H7; contradiction).
        apply Property_NotEmpty in H9; destruct H9.
        assert ((C ∪ [x0]) ∈ (En_T A)).
        { unfold En_T; apply Axiom_Scheme; split.
          - apply Axiom_Union; split; try apply Theorem42; Ens.
          - exists (B ∪ [x]); repeat split.
            + unfold Subclass; intros; apply Theorem4 in H10.
              destruct H10; auto; apply Axiom_Scheme in H10; destruct H10.
              rewrite H11; try apply Theorem19; Ens.
            + apply Axiom_Scheme; repeat split; intros.
              * apply Axiom_Union; split; try apply Theorem42; Ens.
              * unfold Subclass; intros; apply Theorem4 in H10; destruct H10.
                { apply Axiom_Scheme in H6; apply H6 in H10; auto. }
                { apply Axiom_Scheme in H10; destruct H10.
                  rewrite H11; try apply Theorem19; Ens; unfold Element_U.
                  apply Axiom_Scheme; split; Ens. }
              * apply Axiom_Scheme in H6; unfold Setminus in H10.
                apply Theorem4' in H10; destruct H10; rewrite Theorem8.
                apply Axiom_Scheme in H11; destruct H11.
                assert (a ∈ (B ∪ [x]) <-> a ∈ B \/ a ∈ [x]).
                { split; try apply Theorem4. }
                apply definition_not in H13; auto; clear H12.
                apply not_or_and in H13; destruct H13.
                assert (a ∈ (A ~ B)).
                { unfold Setminus; apply Theorem4'; split; auto.
                  unfold Complement; apply Axiom_Scheme; auto. }
                apply H6 in H14; rewrite H14; clear H14.
                assert (x ∈ A /\ a ∈ A); auto; apply H1 in H14.
                { generalize (classic (a ∩ [x0] = Φ)); intros; destruct H15.
                  - rewrite H15; apply Theorem5.
                  - apply Property_NotEmpty in H15; destruct H15.
                    apply Theorem4' in H15; destruct H15.
                    apply Axiom_Scheme in H16; destruct H16.
                    rewrite H17 in *; try apply Theorem19; Ens.
                    assert (x0 ∈ (x ∩ a)); try apply Theorem4'; auto.
                    rewrite H14 in H18; destruct (Theorem16 _ H18). }
                { intro; rewrite H15 in H13; destruct H13; unfold Singleton.
                  apply Axiom_Scheme; split; auto. }
              * apply Axiom_Scheme in H6; rewrite Theorem8.
                apply Theorem4 in H10; destruct H10.
                { double H10; apply H6 in H11; destruct H11; rewrite H11.
                  clear H11; assert (x ∈ A /\ a ∈ A); auto; apply H1 in H11.
                  - generalize (classic (a ∩ [x0] = Φ)); intros; destruct H12.
                    + rewrite H12; rewrite Theorem6, Theorem17; Ens.
                    + apply Property_NotEmpty in H12; destruct H12.
                      apply Theorem4' in H12; destruct H12.
                      apply Axiom_Scheme in H13; destruct H13.
                      rewrite H14 in *; try apply Theorem19; Ens.
                      assert (x0 ∈ (x ∩ a)); try apply Theorem4'; auto.
                      rewrite H11 in H15; destruct (Theorem16 _ H15).
                  - intro; rewrite <- H12 in H10; unfold Complement in H8.
                    apply Axiom_Scheme in H8; destruct H8; contradiction. }
                { apply Axiom_Scheme in H10; destruct H10.
                  rewrite H11; try apply Theorem19; Ens; clear H10 H11 a.
                  assert (x ∈ (A ~ B)); try apply Theorem4'; auto.
                  apply H6 in H10; rewrite H10, Theorem17; exists x0.
                  apply Axiom_Extent; split; intros.
                  - apply Theorem4' in H11; apply H11.
                  - apply Theorem4'; split; auto; apply Axiom_Scheme in H11.
                    destruct H11; rewrite H12; try apply Theorem19; Ens. } }
        apply H4 in H10; destruct H10; unfold ProperSubclass.
        split; unfold Subclass; intros; try (apply Theorem4; auto).
        apply Axiom_Scheme in H6.
        assert (x ∈ (A ~ B)); try apply Theorem4'; auto.
        apply H6 in H10; intro; assert (x0 ∈ Φ).
        { rewrite <- H10; apply Theorem4'; split; auto; rewrite H11.
          apply Theorem4; right; apply Axiom_Scheme; split; Ens. }
        generalize (Theorem16 x0); intros; contradiction.
    + intros; exists (∪n); split; intros.
      * apply Property_FinChar in H5; auto; split; auto; clear H6.
        destruct H5; unfold Finite_Character; repeat split; auto.
        { intros F H7 F1 H8; destruct H8; unfold En_T in H7.
          apply Axiom_Scheme in H7; destruct H7, H10 as [B H10], H10.
          unfold En_T; apply Axiom_Scheme; assert (Ensemble F1).
          { apply Theorem33 in H8; auto. }
          split; auto; unfold En_TB in H11; apply Axiom_Scheme in H11.
          destruct H11 as [_ H11], H11.
          exists \{ λ a, a ∈ B /\ exists x, a ∩ F1 = [x] \}; repeat split.
          - red; intros; apply Axiom_Scheme in H14; destruct H14, H15.
            apply H10 in H15; auto.
          - apply Axiom_Scheme; repeat split; auto; intros.
            + apply Theorem28 with (y:= F); split; auto.
            + apply Theorem4' in H14; destruct H14; apply Axiom_Scheme in H15.
              destruct H15 as [_ H15]; unfold NotIn in H15.
              apply definition_not with (B:= Ensemble a /\ a∈B /\
              (exists x, a ∩ F1 = [x])) in H15.
              * apply not_and_or in H15; destruct H15.
                { destruct H15; Ens. }
                { apply not_and_or in H15; destruct H15.
                  - assert (a ∈ (A ~ B)).
                    { unfold Setminus; apply Theorem4'; split; auto.
                      unfold Complement; apply Axiom_Scheme; split; Ens. }
                    apply H13 in H16; apply Theorem27;split;try apply Theorem26.
                    rewrite <- H16; unfold Subclass; intros.
                    apply Theorem4' in H17; apply Theorem4'; destruct H17; Ens.
                  - generalize (classic (a ∈ B)); intros; destruct H16.
                    + apply H13 in H16; destruct H16.
                      apply not_ex_all_not with (n:= x) in H15.
                      generalize (classic (a∩F1=Φ)); intros; destruct H17; auto.
                      apply Property_NotEmpty in H17; destruct H17 as [z H17].
                      assert ((a ∩ F1) ⊂ [x]).
                      { unfold Subclass; intros; rewrite <- H16.
                        apply Theorem4' in H18; apply Theorem4'; destruct H18.
                        split; auto. }
                      double H17; apply H18 in H19; unfold Singleton in H19.
                      apply Axiom_Scheme in H19; destruct H19.
                      assert ([x] ⊂ (a ∩ F1)).
                      { unfold Subclass; intros; unfold Singleton in H21.
                        apply Axiom_Scheme in H21; destruct H21.
                        assert (Ensemble x).
                        { apply Theorem42'; rewrite <- H16.
                          apply Theorem33 with (x:= a); Ens; unfold Subclass.
                          intros; apply Theorem4' in H23; apply H23. }
                        rewrite H22, <- H20; try apply Theorem19; Ens. }
                      assert ((a ∩ F1) ⊂ [x] /\ [x] ⊂ (a ∩ F1)); auto.
                      apply Theorem27 in H22; rewrite H22 in H15; tauto.
                    + assert (a ∈ (A ~ B)).
                      { unfold Setminus; apply Theorem4'; split; auto.
                        unfold Complement; apply Axiom_Scheme; split; Ens. }
                      apply H13 in H17; apply Theorem27.
                      split; try apply Theorem26; rewrite <- H17.
                      unfold Subclass; intros; apply Theorem4' in H18.
                      apply Theorem4'; destruct H18; Ens. }
              * split; intros; try apply Axiom_Scheme in H16; try apply Axiom_Scheme; Ens.
            + apply Axiom_Scheme in H14; apply H14. }
        { intros; destruct H7.
          generalize (classic (F ∈ (En_T A))); intros; destruct H9; auto.
          assert (forall B, B ⊂ A -> ~ F ∈ (En_TB B A)).
          { intros; unfold En_T in H9.
            apply definition_not with (B:= Ensemble F /\ exists B, B ⊂ A /\
            F ∈ (En_TB B A)) in H9.
            - apply not_and_or in H9; destruct H9; try tauto.
              apply not_ex_all_not with (n:= B) in H9.
              apply not_and_or in H9; tauto.
            - split; intros; try apply Axiom_Scheme; auto.
              apply Axiom_Scheme in H11; apply H11. }
          set (B:= \{ λ a, a ∈ A /\ a ∩ F <> Φ /\ ~ (exists x, a ∩ F = [x]) \}
            ∪ \{ λ a, a ∈ A /\ a ∩ F <> Φ /\ (exists x, a ∩ F = [x]) \}).
          assert (B ⊂ A).
          { unfold Subclass; intros; apply Theorem4 in H11.
            destruct H11; apply Axiom_Scheme in H11; apply H11. }
          apply H10 in H11; unfold En_TB in H11.
          apply definition_not with (B:= Ensemble F /\ F ⊂ ∪ A /\ (forall a,
          a ∈ (A ~ B) -> a ∩ F = Φ) /\ (forall a, a ∈ B -> exists x,
          a ∩ F = [x])) in H11.
          - apply not_and_or in H11; destruct H11; try tauto.
            apply not_and_or in H11; destruct H11.
            + assert (forall z, z ⊂ F /\ Finite z -> z ⊂ ∪ A).
              { intros; apply H8 in H12; unfold En_T in H12.
                apply Axiom_Scheme in H12; destruct H12, H13, H13.
                unfold En_TB in H14; apply Axiom_Scheme in H14; apply H14. }
              destruct H11; unfold Subclass; intros.
              assert ([z] ⊂ F /\ Finite ([z])).
              { split; try apply Finite_Single; Ens; unfold Subclass; intros.
                unfold Singleton in H13; apply Axiom_Scheme in H13; destruct H13.
                rewrite H14; try apply Theorem19; Ens. }
              apply H12 in H13; apply H13; unfold Singleton.
              apply Axiom_Scheme; split; Ens.
            + apply not_and_or in H11; destruct H11.
              * apply not_all_ex_not in H11; destruct H11 as [a H11].
                apply imply_to_and in H11; destruct H11.
                unfold Setminus in H11; apply Theorem4' in H11; destruct H11.
                apply Axiom_Scheme in H13; destruct H13.
                unfold NotIn in H14; apply definition_not with (B:= a ∈
                \{λ a, a∈A /\ a ∩ F <> Φ /\ ~ (exists x, a ∩ F = [x])\} \/
                a ∈ \{ λ a, a ∈ A /\ a ∩ F <> Φ /\ (exists x, a ∩ F = [x]) \})
                in H14.
                { apply not_or_and in H14; destruct H14.
                  apply definition_not with (B:= Ensemble a /\ a ∈ A /\
                  a ∩ F <> Φ /\ ~ (exists x, a ∩ F = [x])) in H14.
                  - apply definition_not with (B:= Ensemble a /\ a ∈ A /\
                    a ∩ F <> Φ /\ (exists x, a ∩ F = [x])) in H15; try tauto.
                    split; intros; try apply Axiom_Scheme; auto.
                    apply Axiom_Scheme in H16; auto.
                  - split; intros; try apply Axiom_Scheme; auto.
                    apply Axiom_Scheme in H16; auto. }
                { split; intros; try apply Theorem4; auto. }
              * apply not_all_ex_not in H11; destruct H11 as [a H11].
                apply imply_to_and in H11; destruct H11.
                apply Theorem4 in H11; destruct H11.
                { apply Axiom_Scheme in H11; clear B H12; destruct H11,H12,H13.
                  assert (~ (forall x y, x ∈ (a ∩ F) /\ y ∈ (a ∩ F) -> x = y)).
                  { intro; apply Property_NotEmpty in H13; destruct H13, H14.
                    exists x; apply Axiom_Extent; split; intros.
                    - add (x ∈ (a ∩ F)) H14; apply H15 in H14; rewrite H14.
                      unfold Singleton; apply Axiom_Scheme; Ens.
                    - unfold Singleton in H14; apply Axiom_Scheme in H14.
                      destruct H14; rewrite H16; try apply Theorem19; Ens. }
                  destruct H15; intros; destruct H15.
                  generalize (classic (x = y)); intros; destruct H17; auto.
                  apply Theorem4' in H15; apply Theorem4' in H16.
                  destruct H15, H16.
                  assert ([x|y] ⊂ F /\ Finite ([x|y])).
                  { split.
                    - unfold Subclass; intros; apply Theorem46 in H20; Ens.
                      destruct H20; rewrite H20; auto.
                    - unfold Unordered; apply Theorem168.
                      split; apply Finite_Single; Ens. }
                  apply H8 in H20; apply Axiom_Scheme in H20.
                  destruct H20, H21 as [B H21], H21; unfold En_TB in H22.
                  apply Axiom_Scheme in H22; destruct H22, H23.
                  generalize (classic (a ∈ B)); intros; destruct H25.
                  - apply H24 in H25; destruct H25.
                    assert ([x | y] ⊂ a).
                    { unfold Subclass; intros; apply Theorem46 in H26; Ens.
                      destruct H26; rewrite H26; auto. }
                    apply Theorem30 in H26; rewrite Theorem6' in H26.
                    rewrite H26 in H25; clear H26; destruct H17.
                    assert (x ∈ [x0] /\ y ∈ [x0]).
                    { rewrite <- H25; split; apply Theorem46; Ens. }
                    destruct H17; apply Axiom_Scheme in H17.
                    apply Axiom_Scheme in H26; destruct H17, H26.
                    assert (x0 ∈ μ).
                    { apply Theorem19; apply Theorem42'; rewrite <- H25.
                      apply Theorem46; Ens. }
                    rewrite H27, H28; auto.
                  - assert (a ∈ (A ~ B)).
                    { unfold Setminus; apply Theorem4'; split; auto.
                      unfold Complement; apply Axiom_Scheme; split; Ens. }
                    apply H24 in H26. clear H24.
                    assert ([x | y] ⊂ a).
                    { unfold Subclass; intros; apply Theorem46 in H24; Ens.
                      destruct H24; rewrite H24; auto. }
                    apply Theorem30 in H24; rewrite Theorem6' in H24.
                    rewrite H24 in H26; clear H24.
                    assert (x ∈ Φ). { rewrite <- H26; apply Theorem46; Ens. }
                    generalize (Theorem16 x); intros; contradiction. }
                { apply Axiom_Scheme in H11; destruct H11, H13, H14; tauto. }
          - split; intros; try apply Axiom_Scheme;
            try apply Axiom_Scheme in H12; auto. }
      * unfold Subclass; intros; apply Axiom_Scheme; split; Ens.
Qed.

Hint Resolve Zermelo : Axiom_of_Choice.

End Zermelo_Postulate.


Require Import Coq.Arith.Arith.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EnumEnsembles.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.MathGraph.
Require Import CertiGraph.graph.FiniteGraph.
Require Import CertiGraph.graph.reachable_computable.
Require Import Coq.Lists.List.

Section LIST_MODEL.

  Context {Vertex: Type}.
  Context {Edge: Type}.
  Context {EV: EqDec Vertex eq}.
  Context {EE: EqDec Edge eq}.

  Variable G : PreGraph Vertex Edge.

  Definition is_list (x: Vertex) : Prop :=
    exists p, valid_path G p /\ forall y, reachable G x y -> exists (py: path), unique (fun pa => G |= pa is x ~o~> y satisfying (fun _ => True)) py /\ Subpath G py p.

  Definition graph_list_isomorphism (l: list Vertex) (root: Vertex) : Prop :=
    (forall s d, reachable G root s /\ reachable G root d /\ G |= s ~> d <-> exists l1 l2, l = l1 ++ s :: d :: l2) /\ (forall v, reachable G root v <-> In v l) /\ NoDup l.

  Context {is_null: DecidablePred Vertex}.
  Context {MA: MathGraph G is_null}.
  Context {LF: LocalFiniteGraph G}.

  Lemma list_expand_nil_or_single: forall root l r,
      vvalid G root -> is_list root -> l = @new_working_list _ _ is_null nil (map (dst G) (edge_func G root)) (root :: r) -> l = nil \/ (exists v, l = v :: nil /\ G |= root ~> v).
  Proof.
    intros. destruct l. 1: left; auto. destruct l.
    + right. exists v; split; auto. assert (In v (v :: nil)) by apply in_eq. rewrite H1 in H2. rewrite in_new_working_list in H2. destruct H2 as [? [? ?]].
      rewrite app_nil_l in H2. rewrite <- edge_func_step in H2. split; [|split]; auto. rewrite step_spec in H2. destruct H2 as [e [? [? ?]]].
      destruct (valid_graph G e H2) as [_ ?]. hnf in H7. rewrite H6 in H7. destruct H7; [exfalso |]; auto.
    + exfalso. destruct LF in H1. unfold edge_func in H1. simpl in H1. destruct (local_enumerable root) as [l' [? ?]].
      simpl in H1. unfold Ensembles.In in i. destruct H0 as [lf [? ?]].
      assert (forall v', In v' (v :: v0 :: l) -> reachable G root v'). {
        intros. rewrite H1 in H3. rewrite in_new_working_list in H3. rewrite app_nil_l in H3. destruct H3 as [? [? ?]].
        rewrite in_map_iff in H3. destruct H3 as [e [? ?]]. exists (root, e :: nil). split; split; simpl; auto.
        + rewrite i in H6. destruct H6. unfold strong_evalid. rewrite H7. rewrite H3. do 3 (split; auto).
          destruct (valid_graph G e H6) as [_ ?]. hnf in H8. rewrite H3 in H8. destruct H8; [exfalso | ]; auto.
        + hnf. rewrite Forall_forall. intros; auto.
      } unfold new_working_list in H1. symmetry in H1. apply filter_2_cons in H1. destruct H1 as [l1 [l2 [l3 [? [? [? [? [? ?]]]]]]]]. simpl in H1. apply map_2_mid in H1.
      destruct H1 as [y1 [y2 [m1 [m2 [m3 [? [? [? [? [? ?]]]]]]]]]]. rewrite H1 in n. apply NoDup_app_r in n. apply NoDup_cons_2 in n.
      assert (reachable G root v) by apply H3, in_eq. assert (reachable G root v0) by apply H3, in_cons, in_eq. apply H2 in H14. apply H2 in H15.
      destruct H14 as [pv [[? ?] ?]]. destruct H15 as [pv0 [[? ?] ?]].
      assert (G |= (root, y1 :: nil) is root ~o~> v satisfying (fun _ => True)). {
        split; split; intros; auto. 2: hnf; rewrite Forall_forall; intros; auto. simpl. unfold strong_evalid. rewrite H12.
        assert (In y1 l') by (rewrite H1; rewrite in_app_iff; right; apply in_eq). rewrite i in H20. destruct H20. rewrite H21.
        apply reachable_by_path_is_reachable in H14. apply reachable_foot_valid in H14. split; auto.
      } pose proof (H16 _ H20).
      assert (G |= (root, y2 :: nil) is root ~o~> v0 satisfying (fun _ => True)). {
        split; split; intros; auto. 2: hnf; rewrite Forall_forall; intros; auto. simpl. unfold strong_evalid. rewrite H13.
        assert (In y2 l') by (rewrite H1; rewrite in_app_iff; right; right; rewrite in_app_iff; right; apply in_eq). rewrite i in H22. destruct H22. rewrite H23.
        apply reachable_by_path_is_reachable in H15. apply reachable_foot_valid in H15. split; auto.
      } pose proof (H18 _ H22). apply n. rewrite in_app_iff. right.
      assert (In_path G v lf) by (apply (In_path_Subpath _ pv); auto; rewrite H21, <- H12; right; exists y1; simpl; tauto).
      assert (In_path G v0 lf) by (apply (In_path_Subpath _ pv0); auto; rewrite H23, <- H13; right; exists y2; simpl; tauto).
      pose proof (valid_path_reachable _ _ _ _ H0 H24 H25). destruct H26; destruct H26 as [[vl pl] ?].
      - assert (G |= (path_glue (root, y1 :: nil) (vl, pl)) is root ~o~> v0 satisfying (fun _ => True)) by (apply reachable_by_path_merge with v; auto).
        unfold path_glue, fst, snd in H27. rewrite <- app_comm_cons, app_nil_l in H27. apply H18 in H27. rewrite H23 in H27. inversion H27. apply in_eq.
      - assert (G |= (path_glue (root, y2 :: nil) (vl, pl)) is root ~o~> v satisfying (fun _ => True)) by (apply reachable_by_path_merge with v0; auto).
        unfold path_glue, fst, snd in H27. rewrite <- app_comm_cons, app_nil_l in H27. apply H16 in H27. rewrite H21 in H27. inversion H27. apply in_eq.
  Qed.

  (* Print Assumptions list_expand_nil_or_single. *)

  Definition list_composed_by_edges (l: list Vertex) : Prop := forall l1 l2 s d, l = l1 ++ s :: d :: l2 -> G |= s ~> d.

  Lemma list_composed_by_edges_nil: list_composed_by_edges nil.
  Proof. repeat intro. assert (@length Vertex nil = length (l1 ++ s :: d :: l2)) by (rewrite H; tauto). rewrite app_length in H0; simpl in H0. intuition. Qed.

  Lemma list_composed_by_edges_single: forall v, list_composed_by_edges (v :: nil).
  Proof.
    repeat intro. exfalso. assert (length (v :: nil) = length (l1 ++ s :: d :: l2)) by (rewrite H; tauto). rewrite app_length in H0. simpl in H0. intuition.
  Qed.

  Lemma lcbe_rev_cons: forall v l, list_composed_by_edges (rev (v :: l)) -> list_composed_by_edges (rev l).
  Proof.
    intros. rewrite <- (app_nil_l l), app_comm_cons, rev_app_distr in H. simpl in H. unfold list_composed_by_edges in *. intros.
    specialize (H l1 (l2 +:: v) s d). apply H. rewrite H0. rewrite <- app_assoc. simpl. auto.
  Qed.

  Lemma lcbe_rev_cons_inv: forall v root l, G |= root ~> v -> list_composed_by_edges (rev (root :: l)) -> list_composed_by_edges (rev (v :: root :: l)).
  Proof.
    intros. rewrite <- (app_nil_l (root :: l)), app_comm_cons, rev_app_distr. simpl rev at 2. unfold list_composed_by_edges in *. intros. destruct l2.
    + simpl in H1. rewrite <- (app_nil_l (d :: nil)), (app_comm_cons nil (d :: nil) s) in H1. rewrite app_assoc in H1.
      do 2 (apply app_inj_tail in H1; destruct H1). subst. auto.
    + assert (v0 :: l2 <> nil) by (intro; inversion H2). apply exists_last in H2. destruct H2 as [l' [a ?]]. rewrite e in H1.
      rewrite app_comm_cons, (app_comm_cons (d :: l') (a :: nil) s), app_assoc in H1. apply app_inj_tail in H1. destruct H1. apply (H0 l1 l'); auto.
  Qed.

  Lemma is_list_edge: forall root v, G |= root ~> v -> is_list root -> is_list v.
  Proof.
    intros. unfold is_list in *. destruct H0 as [p [? ?]]. exists p. split; auto. intros.
    destruct H2 as [[v' pv] ?]. assert (v' = v) by (destruct H2 as [[? _] _]; simpl in H2; auto). subst v'. destruct H as [? [? ?]]. rewrite step_spec in H4.
    destruct H4 as [e [? [? ?]]].
    assert (forall pp, G |= pp is v ~o~> y satisfying (fun _ => True) -> G |= (path_glue (root, e :: nil) pp) is root ~o~> y satisfying (fun _ => True)). {
      intros. apply reachable_by_path_merge with v; auto. split; split; simpl; auto.
      + unfold strong_evalid. rewrite H5, H6. split; auto.
      + hnf. rewrite Forall_forall. intros; auto.
    }
    pose proof (H7 _ H2). unfold path_glue, fst, snd in H8. rewrite <- app_comm_cons, app_nil_l in H8. pose proof (reachable_by_path_is_reachable _ _ _ _ _ H8).
    apply H1 in H9. clear H1. destruct H9 as [py [[? ?] ?]]. pose proof (H9 _ H8). exists (v, pv). split; split; auto.
    + intros. specialize (H7 _ H12). destruct x' as [x px]. assert (x = v) by (destruct H12 as [[? _] _]; simpl in H12; auto). subst x.
      unfold path_glue, fst, snd in H7. rewrite <- app_comm_cons, app_nil_l in H7. specialize (H9 _ H7). rewrite H9 in H11. inversion H11. auto.
    + simpl. destruct H10. subst py. simpl in *. clear -H10. unfold incl in *. intros. apply H10. right; auto.
    + simpl. destruct H10. subst py. simpl in *. unfold In_path. clear -H6 H10. right. exists e. split; intuition.
  Qed.

  Lemma construct_reachable_edge:
    forall lim root r, vvalid G root -> is_list root -> list_composed_by_edges (rev (root :: r)) -> list_composed_by_edges (rev (@construct_reachable _ _ _ _ G is_null _ (lim, root :: nil, r))).
  Proof.
    intros lim root r. remember (lengthInput (lim, root :: nil, r)) as n. assert (lengthInput (lim, root :: nil, r) <= n) by intuition. clear Heqn.
    revert n lim root r H. induction n; intros.
    + simpl in H. rewrite construct_reachable_unfold. destruct (le_dec lim (length r)); [apply (lcbe_rev_cons root) | exfalso]; intuition.
    + rewrite construct_reachable_unfold. unfold lengthInput in H, IHn. destruct (le_dec lim (length r)). 1: apply (lcbe_rev_cons root); auto.
      remember (@new_working_list _ _ is_null nil (map (dst G) (edge_func G root)) (root :: r)).
      assert (l = nil \/ exists v, l = (v :: nil) /\ G |= root ~> v) by (apply (list_expand_nil_or_single _ _ r); auto). destruct H3.
      - clear Heql. subst l. simpl. rewrite construct_reachable_unfold. auto.
      - destruct H3 as [v [? ?]]. rewrite H3. simpl. apply IHn.
        * simpl. clear - H n0. intuition.
        * hnf in H4. intuition.
        * apply (is_list_edge root); auto.
        * apply lcbe_rev_cons_inv; auto.
  Qed.

  Lemma is_list_no_self_loop: forall root s, vvalid G root -> is_list root -> reachable G root s -> G |= s ~> s -> False.
  Proof.
    intros. destruct H2 as [? [? ?]]. rewrite step_spec in H4. destruct H4 as [e [? [? ?]]].
    assert (G |= (s, e :: nil) is s ~o~> s satisfying (fun _ => True)). {
      split; split; simpl; auto.
      + unfold strong_evalid. rewrite H5, H6. split; auto.
      + hnf. rewrite Forall_forall; intros; auto.
    } destruct H0 as [pf [? ?]]. apply H8 in H1. clear H8. destruct H1 as [ps [[? ?] ?]]. destruct ps as [v ps].
    assert (v = root) by (destruct H1 as [[? _] _]; simpl in H1; auto). subst v. pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H7). unfold path_glue, fst, snd in H10.
    apply H8 in H10. inversion H10. pose proof (f_equal (@length Edge) H12). rewrite app_length in H11. simpl in H11. intuition.
  Qed.

  Lemma is_list_edge_dst_the_same: forall root s d v, vvalid G root -> is_list root -> reachable G root s -> G |= s ~> d -> G |= s ~> v -> d = v.
  Proof.
    intros. assert (reachable G root d) by (apply reachable_edge with s; auto). assert (reachable G root v) by (apply reachable_edge with s; auto).
    destruct H0 as [pf [? ?]]. apply H6 in H4. destruct H4 as [pd [[? ?] ?]]. apply H6 in H5. destruct H5 as [pv [[? ?] ?]].
    assert (In_path G v pf) by (apply In_path_Subpath with pv; auto; destruct H5 as [[_ ?] _]; apply pfoot_in; auto).
    assert (In_path G d pf) by (apply In_path_Subpath with pd; auto; destruct H4 as [[_ ?] _]; apply pfoot_in; auto).
    pose proof (valid_path_reachable _ _ _ _ H0 H11 H12). clear H8 H10 H11 H12. destruct H2 as [? [? ?]]. rewrite step_spec in H10. destruct H10 as [ed [? [? ?]]].
    destruct H3 as [? [? ?]]. rewrite step_spec in H15. destruct H15 as [ev [? [? ?]]]. destruct H1 as [ps ?].
    assert (G |= (s, ed :: nil) is s ~o~> d satisfying (fun _ => True)). {
      split; split; simpl; auto.
      + unfold strong_evalid. rewrite H11, H12; split; auto.
      + hnf. rewrite Forall_forall; intros; auto.
    }
    assert (G |= (s, ev :: nil) is s ~o~> v satisfying (fun _ => True)). {
      split; split; simpl; auto.
      + unfold strong_evalid. rewrite H16, H17; split; auto.
      + hnf. rewrite Forall_forall; intros; auto.
    } destruct ps as [vs ps]. assert (vs = root) by (destruct H1 as [[? _] _]; simpl in H1; auto). subst vs.
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H18). unfold path_glue, fst, snd in H20.
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H19). unfold path_glue, fst, snd in H21. clear H4 H5. pose proof (H7 _ H20). pose proof (H9 _ H21). destruct H13.
    + destruct H13 as [[v' pv'] ?]. assert (v' = v) by (destruct H13 as [[? _] _]; simpl in H13; auto). subst v'.
      pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H21 H13). unfold path_glue, fst, snd in H22. apply H7 in H22. rewrite H4 in H22. inversion H22.
      pose proof (f_equal (@length Edge) H24). rewrite !app_length in H23. simpl in H23. assert (length pv' = 0) by intuition. destruct pv'. 2: inversion H25.
      clear H23 H25. rewrite app_nil_r in H24. apply app_inj_tail in H24. destruct H24. subst ed. rewrite H12 in H17. auto.
    + destruct H13 as [[d' pd'] ?]. assert (d' = d) by (destruct H13 as [[? _] _]; simpl in H13; auto). subst d'.
      pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H20 H13). unfold path_glue, fst, snd in H22. apply H9 in H22. rewrite H5 in H22. inversion H22.
      pose proof (f_equal (@length Edge) H24). rewrite !app_length in H23. simpl in H23. assert (length pd' = 0) by intuition. destruct pd'. 2: inversion H25.
      clear H23 H25. rewrite app_nil_r in H24. apply app_inj_tail in H24. destruct H24. subst ed. rewrite H12 in H17. auto.
  Qed.

  Lemma is_list_edge_src_the_same: forall root s d v, vvalid G root -> is_list root -> reachable G root s -> reachable G root v -> G |= s ~> d -> G |= v ~> d -> s = v.
  Proof.
    intros. destruct H3 as [? [? ?]]. rewrite step_spec in H6. destruct H6 as [es [? [? ?]]]. destruct H4 as [? [? ?]]. rewrite step_spec in H10. destruct H10 as [ev [? [? ?]]].
    assert (G |= (s, es :: nil) is s ~o~> d satisfying (fun _ => True)). {
      split; split; simpl; auto; [unfold strong_evalid; rewrite H7, H8; split; auto | hnf; rewrite Forall_forall; intros; auto].
    }
    assert (G |= (v, ev :: nil) is v ~o~> d satisfying (fun _ => True)). {
      split; split; simpl; auto; [unfold strong_evalid; rewrite H11, H12; split; auto | hnf; rewrite Forall_forall; intros; auto].
    } destruct H1 as [[vs ps] ?]. destruct H2 as [[vv pv] ?].
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H13). unfold path_glue, fst, snd in H15.
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H2 H14). unfold path_glue, fst, snd in H16. destruct H0 as [pf [? ?]].
    pose proof (reachable_by_path_is_reachable _ _ _ _ _ H16). apply H17 in H18. destruct H18 as [pp [[? ?] ?]]. apply H19 in H15. apply H19 in H16. rewrite H15 in H16.
    inversion H16. apply app_inj_tail in H23. destruct H23. subst es. rewrite H7 in H11. auto.
  Qed.

  Lemma construct_reachable_tail_preserve: forall lim p r, exists l', @construct_reachable _ _ _ _ G is_null _ (lim, p, r) = l' ++ r.
  Proof.
    intros lim p r. remember (lengthInput (lim, p, r)) as n. assert (lengthInput (lim, p, r) <= n) by intuition. clear Heqn. revert lim p r H. induction n; intros.
    + simpl in H. rewrite construct_reachable_unfold. destruct p. exists nil; rewrite app_nil_l; auto. destruct (le_dec lim (length r)).
      exists nil; rewrite app_nil_l; auto. exfalso; intuition.
    + simpl in H. rewrite construct_reachable_unfold. destruct p. exists nil; rewrite app_nil_l; auto. destruct (le_dec lim (length r)). exists nil; rewrite app_nil_l; auto.
      remember (@new_working_list _ _ is_null p (map (dst G) (edge_func G v)) (v :: r)). simpl. simpl in IHn. specialize (IHn lim l (v :: r)).
      assert (lim - length (v :: r) <= n) by (simpl; intuition). apply IHn in H0. destruct H0 as [l1 ?]. rewrite app_cons_assoc in H0. exists (l1 +:: v). auto.
  Qed.

  Theorem is_list_is_list: forall root, vvalid G root -> EnumCovered Vertex (reachable G root) -> is_list root -> {l | graph_list_isomorphism l root}.
  Proof.
    intros. remember (@construct_reachable _ _ _ _ G is_null _ (length (proj1_sig X), root :: nil, nil)). destruct (finite_reachable_computable' _ _ X l H Heql).
    hnf in H1. exists (rev l). split; [|split].
    + intros. destruct X as [ss [? ?]]. simpl in Heql. unfold Ensembles.In in i.
      assert (list_composed_by_edges (rev (root :: nil))) by (simpl; apply list_composed_by_edges_single). apply (construct_reachable_edge (length ss) _ nil H H0) in H3.
      hnf in H3. rewrite <- Heql in H3. split; intros.
      - destruct H4 as [? [? ?]]. pose proof H4. rewrite <- H1, in_rev in H4. apply in_split in H4. destruct H4 as [l1 [l2 ?]]. exists l1. destruct l2.
        * exfalso. pose proof H5. rewrite <- H1, in_rev, H4 in H8. rewrite in_app_iff in H8. simpl in H8. destruct H8 as [? | [? | ?]]; auto.
          2: subst d; apply (is_list_no_self_loop root s); auto. destruct l1. 1: inversion H8.
          assert (v = root). {
            rewrite construct_reachable_unfold in Heql. destruct (le_dec (length ss) (length nil)). 1: rewrite Heql in H4; simpl in H4; inversion H4.
            remember (@new_working_list _ _ is_null nil (map (dst G) (edge_func G root)) (root :: nil)). simpl in Heql.
            destruct (construct_reachable_tail_preserve (length ss) l0 (root :: nil)) as [l' ?]. rewrite <- Heql in H9. rewrite H9 in H4.
            rewrite rev_unit in H4. simpl in H4. inversion H4. auto.
          } subst v. simpl in H8. destruct H8.
          1: {
            subst d. destruct H0 as [pf [? ?]]. apply H8 in H5. clear H8. destruct H5 as [pr [[? ?] ?]].
            assert (G |= (root, nil) is root ~o~> root satisfying (fun _ => True)) by
                (split; split; simpl; auto; red; simpl; auto).
            destruct H7 as [[vr ps] ?]. destruct H6 as [? [? ?]]. rewrite step_spec in H12. destruct H12 as [e [? [? ?]]].
            assert (G |= (s, e :: nil) is s ~o~> root satisfying (fun _ => True)). {
              split; split; simpl; auto.
              + unfold strong_evalid. rewrite H13, H14. split; auto.
              + hnf. rewrite Forall_forall; intros; auto.
            } pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H7 H15). unfold path_glue, fst, snd in H16. apply H8 in H10. apply H8 in H16. rewrite H10 in H16.
            inversion H16. destruct ps; simpl in H19; inversion H19.
          }
          1: {
            apply in_split in H8. destruct H8 as [l0 [l2 ?]]. subst l1. assert (root :: l0 <> nil) by (intro HS; inversion HS). apply exists_last in H8.
            destruct H8 as [l' [a ?]]. rewrite app_comm_cons, e in H4. rewrite <- app_cons_assoc, <- app_assoc in H4. simpl in H4. specialize (H3 _ _ _ _ H4).
            assert (a = s) by (apply (is_list_edge_src_the_same root _ d); auto; rewrite <- H1, in_rev, H4, in_app_iff; right; apply in_eq). subst a.
            assert (NoDup (rev l)) by (apply Permutation_NoDup with (l := l); auto; apply Permutation_rev). rewrite H4 in H8. apply NoDup_app_r in H8.
            apply NoDup_cons_2 in H8. apply H8. simpl. right. rewrite in_app_iff. right. apply in_eq.
          }
        * specialize (H3 _ _ _ _ H4). assert (d = v) by (apply (is_list_edge_dst_the_same root s); auto). subst v. exists l2; auto.
      - destruct H4 as [l1 [l2 ?]]. split; [|split]; [apply H1; rewrite in_rev; rewrite H4; rewrite in_app_iff; right ..|]; [apply in_eq | right; apply in_eq |].
        apply (H3 l1 l2); auto.
    + intros; rewrite <- in_rev, H1; tauto.
    + apply Permutation_NoDup with (l := l); auto. apply Permutation_rev.
  Qed.

  (* Print Assumptions is_list_is_list. *)

End LIST_MODEL.


Load loadpath.
Require MSets.
Require Coq.Structures.Orders.
Require Coq.Structures.OrdersFacts.
Require Import Morphisms.
Require Import ProofIrrelevance.
Require Import List.
Require Import Relation_Definitions.
Require Import Sorting.
Require Recdef.
Require Omega.
Require Import msl.Axioms msl.Coqlib2.
Require Import NArith veristar.variables veristar.datatypes veristar.clauses.
Require Import veristar.fresh.
Require Import Finite_sets_facts.
Require Import msl.base.

Definition list_bound {A: Type} (f: A -> Prop) (l: list A):=
  Forall f l /\  NoDup l.

Definition vset := Ensemble var.

Definition expr_bound (n: vset) (e: expr) :=
 match e with Nil => True | Var v => n v end.

Definition pure_bound (n: vset) (a : pure_atom) :=
 match a with
 | Eqv e e' => expr_bound n e /\ expr_bound n e'
 end.

Definition space_bound (n: vset) (a: space_atom) :=
 match a with
 | Next e e' =>  expr_bound n e /\ expr_bound n e'
 | Lseg e e' =>  expr_bound n e /\ expr_bound n e'
 end.

Definition pures_bound n := list_bound (pure_bound n).
Definition spaces_bound n := list_bound (space_bound n).

Definition pures_bound' n := Forall (pure_bound n).
Definition spaces_bound' n := Forall (space_bound n).

Definition clause_bound' (n: vset)  (cl: clause) :=
 match cl with
 | PureClause pi pi' _ _ =>  pures_bound' n pi /\ pures_bound' n pi'
 | PosSpaceClause pi pi' sigma =>
    pures_bound' n pi /\ pures_bound' n pi'/\ spaces_bound' n sigma
 | NegSpaceClause pi sigma pi' =>
    pures_bound' n pi /\ pures_bound' n pi'/\ spaces_bound' n sigma
 end.

Definition clause_bound (n: vset)  (cl: clause) :=
 match cl with
 | PureClause pi pi' _ _ =>  pures_bound n pi /\ pures_bound n pi'
 | PosSpaceClause pi pi' sigma =>
    pures_bound n pi /\ pures_bound n pi'/\ spaces_bound n sigma
 | NegSpaceClause pi sigma pi' =>
    pures_bound n pi /\ pures_bound n pi'/\ spaces_bound n sigma
 end.

Lemma expr_bound_more: forall  n n' e,
    Included _ n n' -> expr_bound n e -> expr_bound n' e.
Proof.
 unfold expr_bound; intros; auto.
 destruct e; auto. apply H; auto.
Qed.

Lemma pure_bound_more:
  forall n n' a, Included _ n n' -> pure_bound n a -> pure_bound n' a.
Proof.
 intros.
 unfold pure_bound in *.
 destruct a;  destruct H0; split; eapply expr_bound_more; eauto.
Qed.

Lemma pures_bound'_more:
  forall n n' gamma, Included _ n n' -> pures_bound' n gamma -> pures_bound' n' gamma.
Proof.
 unfold pures_bound'; intros.
 rewrite Forall_forall in *.
  intros.
 eapply pure_bound_more; eauto.
Qed.

Lemma space_bound_more:
  forall n n' a, Included _ n n' -> space_bound n a -> space_bound n' a.
Proof.
 intros.
 unfold space_bound in *.
 destruct a;  destruct H0; split; eapply expr_bound_more; eauto.
Qed.

Lemma spaces_bound'_more:
  forall n n' gamma, Included _ n n' -> spaces_bound' n gamma -> spaces_bound' n' gamma.
Proof.
 unfold spaces_bound'; intros.
 rewrite Forall_forall in *.
 intros.
 eapply space_bound_more; eauto.
Qed.

Lemma clause_bound'_more:
  forall n n' c, Included _ n n' -> clause_bound' n c -> clause_bound' n' c.
Proof.
 intros.
 destruct c; simpl in *.
  destruct H0; split; eapply pures_bound'_more; eauto.
  destruct H0 as [? [? ?]];
  split; [|split]; try  eapply pures_bound'_more; eauto;  eapply spaces_bound'_more; eauto.
  destruct H0 as [? [? ?]];
  split; [|split]; try  eapply pures_bound'_more; eauto;  eapply spaces_bound'_more; eauto.
Qed.

Definition var_upto (v: var): Ensemble var := fun x => Ile x v.

Lemma expr_bound_freshmax:
  forall e, expr_bound (var_upto (freshmax_expr e)) e.
 Proof.
 destruct e; intros; simpl; auto.
 right; reflexivity.
Qed.

Lemma S_nat_of_P_id2pos_le:
 forall x y, Ile x y -> S (nat_of_P (id2pos x)) <= S (nat_of_P (id2pos y)).
Proof.
 intros.
 generalize (nat_of_P_id2pos_le x y H); intro; omega.
Qed.

Lemma included_var_upto:
  forall a b, Ile a b -> Included _ (var_upto a) (var_upto b).
Proof. unfold var_upto; repeat intro; unfold In in *. eapply Ile_trans; eauto.
Qed.

Lemma pure_bound_freshmax:
 forall a, pure_bound (var_upto (freshmax_pure_atom a)) a.
 unfold pure_bound. destruct a.
 split.
 simpl.
 apply expr_bound_more with (var_upto (freshmax_expr e)).
 apply included_var_upto.  apply Ile_var_max1.
 apply expr_bound_freshmax.
 simpl.
 apply expr_bound_more with (var_upto (freshmax_expr e0)).
 apply included_var_upto.  apply Ile_var_max2.
  apply expr_bound_freshmax.
Qed.

Lemma pures_bound_freshmax:
  forall gamma,
  pures_bound' (var_upto (freshmax_list freshmax_pure_atom gamma)) gamma.
Proof.
 intros.
 unfold pures_bound'.
 induction gamma; simpl; intros.
 constructor.
 constructor; auto.
 eapply pure_bound_more; try apply pure_bound_freshmax.
 apply included_var_upto;  apply Ile_var_max1.
 rewrite Forall_forall in *; intros.
 specialize (IHgamma _ H).
 eapply pure_bound_more; try apply pure_bound_freshmax.
 apply included_var_upto;  eapply Ile_trans; [ | apply Ile_var_max2].
 revert H; clear; induction gamma; simpl; intros; auto.
 contradiction.
 destruct H; subst.
 apply Ile_var_max1.
 eapply Ile_trans; [ auto | apply Ile_var_max2].
Qed.

Lemma space_bound_freshmax:
 forall a, space_bound (var_upto (freshmax_space_atom a)) a.
 unfold space_bound. destruct a.
 split.
 simpl.
 apply expr_bound_more with (var_upto (freshmax_expr e)).
 apply included_var_upto; apply Ile_var_max1.
  apply expr_bound_freshmax.
 simpl.
 apply expr_bound_more with (var_upto (freshmax_expr e0)).
  apply included_var_upto; apply Ile_var_max2.
  apply expr_bound_freshmax.
 split.
 simpl.
 apply expr_bound_more with (var_upto (freshmax_expr e)).
  apply included_var_upto;  apply Ile_var_max1.
  apply expr_bound_freshmax.
 simpl.
 apply expr_bound_more with (var_upto (freshmax_expr e0)).
  apply included_var_upto;  apply Ile_var_max2.
  apply expr_bound_freshmax.
Qed.

Lemma spaces_bound'_freshmax:
  forall gamma,
  spaces_bound' (var_upto (freshmax_list freshmax_space_atom gamma)) gamma.
Proof.
 intros.
 unfold spaces_bound'.
 induction gamma; simpl; intros.
 constructor.
 constructor; auto.
 eapply space_bound_more; try apply space_bound_freshmax.
 apply included_var_upto;  apply Ile_var_max1.
 rewrite Forall_forall in *; intros.
 specialize (IHgamma _ H).
 eapply space_bound_more; try apply space_bound_freshmax.
 eapply included_var_upto; eapply Ile_trans; [ | apply Ile_var_max2].
 revert H; clear; induction gamma; simpl; intros; auto.
 contradiction.
 destruct H; subst.
 apply Ile_var_max1.
 eapply Ile_trans; [ | apply Ile_var_max2].
 auto.
Qed.

Lemma clause_bound'_freshmax:
  forall c, clause_bound' (var_upto (freshmax_clause c)) c.
Proof.
 intros.
 destruct c; simpl.
 split.
 apply pures_bound'_more with
   (var_upto (freshmax_list freshmax_pure_atom gamma)).
 apply included_var_upto.
 apply Ile_var_max1.
 apply pures_bound_freshmax.
 apply pures_bound'_more with
   (var_upto (freshmax_list freshmax_pure_atom delta)).
 apply included_var_upto.
 apply Ile_var_max2.
 apply pures_bound_freshmax.
 split; [|split].
 apply pures_bound'_more
   with (var_upto (freshmax_list freshmax_pure_atom gamma)).
 apply included_var_upto;  eapply Ile_trans; [ | apply Ile_var_max1].
 apply Ile_var_max1.
 apply pures_bound_freshmax.
 apply pures_bound'_more
   with (var_upto (freshmax_list freshmax_pure_atom delta)).
 apply included_var_upto;  eapply Ile_trans; [ | apply Ile_var_max1].
 apply Ile_var_max2.
 apply pures_bound_freshmax.
 apply spaces_bound'_more
   with (var_upto (freshmax_list freshmax_space_atom sigma)).
  apply included_var_upto;  apply Ile_var_max2.
 apply spaces_bound'_freshmax.
 split; [|split].
 apply pures_bound'_more
   with (var_upto (freshmax_list freshmax_pure_atom gamma)).
 apply included_var_upto;  eapply Ile_trans; [ | apply Ile_var_max1].
 apply Ile_var_max1.
 apply pures_bound_freshmax.
 apply pures_bound'_more
   with (var_upto (freshmax_list freshmax_pure_atom delta)).
 apply included_var_upto;  eapply Ile_trans; [ | apply Ile_var_max1].
 apply Ile_var_max2.
 apply pures_bound_freshmax.
 apply spaces_bound'_more
   with (var_upto (freshmax_list freshmax_space_atom sigma)).
  apply included_var_upto;  apply Ile_var_max2.
 apply spaces_bound'_freshmax.
Qed.

Module Type CLAUSE_UNIVERSE_FINITE.

 Axiom Finite_var_upto:  forall v, Finite _ (var_upto v).
 Axiom clause_bound_finite: forall n, Finite _ n -> Finite _ (clause_bound n).
End CLAUSE_UNIVERSE_FINITE.

Module ClauseUniverseFinite : CLAUSE_UNIVERSE_FINITE.

Require Import Image.

Implicit Arguments Finite.
Implicit Arguments Union.
Implicit Arguments Intersection.
Implicit Arguments Im.
Implicit Arguments In.
Implicit Arguments Add.
Implicit Arguments Subtract.
Implicit Arguments Singleton.
Implicit Arguments injective.
Implicit Arguments Included.
Implicit Arguments Power_set.

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

Lemma finite_pair:
  forall U V (S : Ensemble U) (T: Ensemble V),
         Finite S -> Finite T ->
         Finite (fun xy => S (fst xy) /\ T (snd xy)).
Proof.
 intros.
 revert T H0; induction H; intros.
 replace (fun xy : U * V => Empty_set U (fst xy) /\ T (snd xy))
   with (Empty_set (U*V)).
 constructor.
 clear; extensionality x; apply prop_ext; split; intros H; inv H. inv H0.
 unfold Add.
  apply Finite_downward_closed
    with (Union (fun xy => A (fst xy) /\ T (snd xy))
                       (fun xy => Singleton x (fst xy) /\ T (snd xy))).
 apply Union_preserves_Finite.
 auto.
 apply Finite_downward_closed
    with (Im T (fun y => (x,y))).
 apply finite_image; auto.
 clear.
 intros [x' y] [? ?]. inv H. simpl in *. unfold In.
 econstructor; eauto.
 clear.
 intros [x' y] ?. unfold In in *.
 inv H; simpl in *.
 inv H0; [left | right]; unfold In in *; auto.
Qed.

Definition pures_bound2 n pi2 :=
      pures_bound n (fst pi2) /\ pures_bound n (snd pi2).

Lemma finite_unimage :
    forall {U V} (X:Ensemble U) (f:U -> V),
       injective f ->
       Finite (Im X f) -> Finite X.
Proof.
 intros.
 remember (Im X f) as Y.
 assert (Included (Im X f) Y).
subst; intros ? ?; auto.
clear HeqY.
 revert X H1; induction H0; intros.
 apply Finite_downward_closed with (Empty_set U).
 constructor.
 intros ? ?.
 unfold injective in H.
 assert (~ Im X f (f x)). intro.  apply H1 in H2. inv H2.
 contradiction H2.
 apply Im_intro with x; auto.
 apply Finite_downward_closed
   with  (Union (fun z => f z =x) (fun y : U => X y /\ f y <> x)).
 apply Union_preserves_Finite; auto.
 destruct (Classical_Prop.classic (exists z, f z = x)) as [[y ?]|?].
 apply Finite_downward_closed
   with (Singleton y).
 apply Singleton_is_finite.
 intros ? ?; unfold In in *.
 apply Singleton_intro; apply H. congruence.
 apply Finite_downward_closed with (Empty_set _).
 apply Empty_is_finite.
 intros ? ?. unfold In in H4. contradiction H3; eauto.
 apply IHFinite.
 intros ? ?. destruct H3.
 destruct H3.
 specialize (H2 y).
 subst.
 spec H2.
 apply Im_intro with x0; auto.
 unfold In, Add in H2. destruct H2; auto.
 apply Singleton_inv in H2. contradiction H5; auto.
 intros z ?.
 specialize (H2 (f z)).
 destruct (Classical_Prop.classic (x = f z)).
 subst. left. unfold In; auto.
 right.
 split; auto.
Qed.

Lemma Power_set_finite:
  forall U (F: Ensemble U), Finite F -> Finite (Power_set F).
Proof.
 intros.
 induction H.
 apply Finite_downward_closed
  with  (Singleton (Empty_set U)).
 apply Singleton_is_finite.
 intros ? ?. inv H. apply Singleton_intro.
 unfold Included in H0.
 extensionality y. apply prop_ext; intuition. apply H0 in H. inv H.
 apply Finite_downward_closed
   with (Union (Power_set A)
               (Im (Power_set A) (fun s => Add s x))).
 apply Union_preserves_Finite; auto.
 apply finite_image; auto.
 intros y ?.
 unfold In, Add in H1.
 destruct (Classical_Prop.classic (y x)); [right | left].
 unfold In.
 apply Im_intro with (Subtract y x).
Focus 2.
 clear - H2.
 extensionality z; unfold Add, Subtract. unfold Setminus.
 apply prop_ext; intuition.
 destruct (Classical_Prop.classic (x=z)). right. apply Singleton_intro; auto.
 left; auto. split; auto.  intro.  apply Singleton_inv in H1. contradiction.
 destruct H. destruct H. apply H. apply Singleton_inv in H. subst; auto.
 (* End Focus 2 *)
 clear - H1 H2 H0.
 inv H1. constructor.
 intros z ?. specialize (H z).
 unfold In, Subtract in H1. destruct H1.
 specialize (H H1).
 unfold In in H. destruct H; auto.
 contradiction.
 unfold In.
 constructor.
 inv H1.
 intros z H4; specialize (H3 _ H4).
 unfold In in *. destruct H3; auto.
 apply Singleton_inv in H1. subst. contradiction.
Qed.

Definition list2set {U} (l: list U) : Ensemble U :=
  fun x => List.In x l.

Program Definition ff U (F: Ensemble U) (l : sig (@NoDup (sig F))) : sig (@NoDup U) :=
 (map (@proj1_sig _ _) (proj1_sig l)).
 Next Obligation.
 induction H. constructor.
 simpl.
 constructor.
 contradict H.
 clear - H.
 induction l; simpl in H. contradiction.
 destruct H; simpl; [left | right].
 destruct a; destruct x; simpl. apply exist_ext; auto.
 apply IHl. auto.
 auto.
Qed.

Lemma NoDup_finite:
  forall U (F: Ensemble U), Finite F -> Finite (fun l: sig (@NoDup _) => Forall F (proj1_sig l)).
Proof.
intros.
 destruct (finite_cardinal _ _ H) as [n ?].
 apply Finite_downward_closed
  with (Im (fun l => length (proj1_sig l) <= n) (ff _ F)).
 apply finite_image.
 apply finite_unimage with (@proj1_sig _ _).
 intros ? ? ?. destruct x; destruct y; simpl in *; subst; apply exist_ext; auto.
 apply Finite_downward_closed
  with (fun l => length l <= n).
 clear H0.
 induction n.
 apply Finite_downward_closed with (Singleton nil).
 apply Singleton_is_finite.
 intros ? ?. unfold In in *. destruct x; inv H0.
 apply Singleton_intro; auto.
 pose (gg (_: sig F) := True).
 pose (hh (l: list (sig F)) := length l <= n).
 apply Finite_downward_closed
  with (Union (Singleton nil)
           (Im (fun xy => gg (fst xy) /\ hh (snd xy)) (fun xy => fst xy :: snd xy))).
 apply Union_preserves_Finite.
 apply Singleton_is_finite.
 apply finite_image.
 apply finite_pair.
 unfold gg.
 apply finite_unimage with (@proj1_sig _ _).
 intros ? ? ?. destruct x; destruct y; simpl in *; subst; apply exist_ext; auto.
 apply Finite_downward_closed with F; auto.
 intros ? ?.  unfold In in *.  inv H0.  destruct x0; simpl; auto.
 apply IHn.
 intros ? ?. unfold In in *.
 destruct x; [left | right].
 apply Singleton_intro; auto.
 unfold In. apply Im_intro with (s,x); simpl; auto.
 unfold hh, In. simpl.
 simpl in H0. unfold gg. split; auto; omega.
 intros ? ?.
 unfold In in *. inv H1. unfold In in *. auto.

 intros ? ?.
 unfold In in *.
 assert (exists x' : sig (@NoDup (sig F)),
                map (@proj1_sig _ _) (proj1_sig x') = proj1_sig x).
 clear - H1.
 destruct x as [l H].
 revert H H1; induction l; simpl; intros.
  exists (exist (@NoDup _) _ (NoDup_nil _)).
  simpl. auto.
 inv H. inv H1.
  specialize (IHl H4 H5).
 destruct IHl as [l' ?].
  assert (NoDup (exist F a H2 :: (proj1_sig l'))).
 constructor. contradict H3.
 clear - H H3.
 destruct l' as [l' H1].
 revert l H1 H4 H H3; induction l'; simpl; intros. contradiction.
 destruct H3.
 subst. simpl in *. left; auto.
 subst. simpl. right.
 inv H1.
 inv H4.
 apply (IHl' (map (@proj1_sig _ _) l') H6 H7).
 simpl. auto.
 simpl. auto.
 simpl in *. subst.
 clear - H4.
 revert H4; induction l'; simpl; intros; auto.
 exists (exist (@NoDup _) _ H0).
 simpl. f_equal. simpl in H; auto.
 destruct H2 as [x' ?].
 apply Im_intro with x'.
 2: unfold ff; destruct x as [x ?];  simpl in *; apply exist_ext; auto.
 unfold In.
 destruct x as [l' ?].
 simpl in *.
 replace (length (proj1_sig x')) with (length l') by (rewrite <- H2; apply map_length).
 clear - n0 H1 H0.
 rename l' into l.
 revert F n n0 H0 H1; induction l; simpl; intros.
 omega.
 inv n0. inv H1.
 assert (length l <= pred n).
  (apply (IHl (Subtract F a))); auto.
 apply card_soustr_1; auto.
 rewrite Forall_forall in H6|-*.
 intros.
 split; auto. apply H6; auto.
 intro. apply Singleton_inv in H1. subst. contradiction.
 assert (n >0).
 clear - H0 H5.
 eapply inh_card_gt_O; try eassumption. exists a; apply H5.
 omega.
Qed.

Lemma finite_list_bound:
 forall U (F: Ensemble U), Finite F -> Finite (list_bound F).
Proof.
 unfold list_bound; intros.
 apply Finite_downward_closed
    with   (Im (fun l: sig (@NoDup _) => Forall F (proj1_sig l)) (@proj1_sig _ _)).
 apply finite_image.
 apply NoDup_finite; auto.
 intros ? ?. destruct H0; unfold In;
     apply Im_intro with (exist (@NoDup _) x H1); [apply H0 |  reflexivity].
Qed.

Lemma finite_expr_bound:
  forall n, Finite n -> Finite (expr_bound n).
Proof.
 unfold expr_bound; intros.
 apply Finite_downward_closed
   with (Union (Singleton Nil) (Im n Var)).
 apply Union_preserves_Finite.
 apply Singleton_is_finite.
 apply finite_image; auto.
 intros ? ?. destruct x.
 left; apply Singleton_intro; auto.
 right. apply Im_intro with v; auto.
Qed.

Lemma finite_pure_bound: forall n, Finite n -> Finite (pure_bound n).
Proof.
 unfold pure_bound;  intros.
 apply Finite_downward_closed
    with (Im (fun xy => expr_bound n (fst xy) /\ expr_bound n (snd xy))
                  (fun xy => Eqv (fst xy) (snd xy))).
 apply finite_image.
 apply finite_pair; apply finite_expr_bound; auto.
 intros ? ?. destruct x. unfold In in H0. destruct H0.
 unfold In.
 apply Im_intro with (e,e0). split; auto. simpl; auto.
Qed.

Lemma finite_space_bound: forall n, Finite n -> Finite (space_bound n).
Proof. intros n FIN.
 unfold space_bound; intros.
 apply Finite_downward_closed
   with (Union
              (Intersection (space_bound n)
                         (fun a => match a with Next _ _ => True | _ => False end))
              (Intersection (space_bound n)
                         (fun a => match a with Lseg _ _ => True | _ => False end))).
 2: intros a H; unfold In in *; destruct a; [left | right]; unfold In; split; unfold In; simpl; auto.
 apply Union_preserves_Finite.
 apply Finite_downward_closed
    with  (Im (fun xy => expr_bound n (fst xy) /\ expr_bound n (snd xy))
                   (fun xy : expr * expr => Next (fst xy) (snd xy))).
 apply finite_image.
 apply finite_pair; apply finite_expr_bound; auto.
 intros ? ?; unfold In in *. destruct H. destruct x; simpl in H0; try contradiction.
 unfold In, space_bound in H; destruct H.
 apply Im_intro with (e,e0); split; auto.
 apply Finite_downward_closed
    with  (Im (fun xy => expr_bound n (fst xy) /\ expr_bound n (snd xy))
                   (fun xy : expr * expr => Lseg (fst xy) (snd xy))).
 apply finite_image.
 apply finite_pair; apply finite_expr_bound; auto.
 intros ? ?; unfold In in *. destruct H. destruct x; simpl in H0; try contradiction.
 unfold In, space_bound in H; destruct H.
 apply Im_intro with (e,e0); split; auto.
Qed.

Lemma finite_pures_bound: forall n, Finite n -> Finite (pures_bound n).
Proof.
intros. apply finite_list_bound.
apply finite_pure_bound; auto.
Qed.

Lemma finite_spaces_bound: forall n, Finite n -> Finite (spaces_bound n).
Proof.
intros. apply finite_list_bound.
apply finite_space_bound; auto.
Qed.

Lemma clause_bound_finite: forall n, Finite n -> Finite (clause_bound n).
Proof.
intros n FIN.
assert (clause_bound n =
               Union
                   (Intersection (clause_bound n)
                       (fun cl => match cl with PureClause _ _ _ _ => True | _ => False end))
               (Union
                  (Intersection (clause_bound n)
                           (fun cl => match cl with PosSpaceClause _ _ _ => True | _ => False end))
                (Intersection (clause_bound n)
                           (fun cl => match cl with NegSpaceClause _ _ _ => True | _ => False end)))).
 set (g:= clause_bound n); clearbody g.
 extensionality x.
 Hint Unfold In.
 apply prop_ext; destruct x; simpl; intuition. left. split; auto.
 repeat destruct H; auto.
 right; left; split; auto.
 repeat destruct H; auto.
 right; right; split; auto.
 repeat destruct H; auto.
 rewrite H.
 apply Union_preserves_Finite.
 apply Finite_downward_closed
    with  (Im (pures_bound2 n)
                             (fun pi2 : list pure_atom * list pure_atom =>
                                                mkPureClause (fst pi2) (snd pi2))).
  apply finite_image.
  apply finite_pair;   apply finite_pures_bound; auto.
  clear.
  intros x H;  destruct H; unfold In in *; destruct x; try contradiction; simpl in *.
  apply Im_intro with (gamma,delta); auto.
  simpl.
  apply pure_clause_ext.
  apply Union_preserves_Finite.
  apply Finite_downward_closed
    with (Im (fun pi3 => pures_bound2 n (fst pi3) /\ spaces_bound n (snd pi3))
                  (fun pi3 => PosSpaceClause  (fst (fst pi3)) (snd (fst pi3)) (snd pi3))).
   apply finite_image.
   apply finite_pair.
   apply finite_pair; apply finite_pures_bound; auto.
   apply finite_spaces_bound; auto.
   clear.
   intros x H;  destruct H; unfold In in *; destruct x; try contradiction; simpl in *.
  apply Im_intro with ((gamma,delta),sigma); auto.
  unfold In. simpl in H. simpl. unfold pures_bound2; intuition.
  apply Finite_downward_closed
    with (Im (fun pi3 => pures_bound2 n (fst pi3) /\ spaces_bound n (snd pi3))
                  (fun pi3 => NegSpaceClause  (fst (fst pi3)) (snd pi3) (snd (fst pi3)))).
   apply finite_image.
   apply finite_pair.
   apply finite_pair; apply finite_pures_bound; auto.
   apply finite_spaces_bound; auto.
  clear.
  intros x H;  destruct H; unfold In in *; destruct x; try contradiction; simpl in *.
  apply Im_intro with ((gamma,delta),sigma); auto.
  unfold In. simpl in H. simpl. unfold pures_bound2; intuition.
Qed.

Definition var2nat v := nat_of_P (id2pos v).

Lemma Finite_var_upto:
  forall v, Finite (var_upto v).
Proof.
 intros.
 apply finite_unimage with var2nat.
 intros ? ? ?. unfold var2nat in *.
 apply Pnat.nat_of_P_inj in H.
 apply id2pos_inj in H; auto.
 apply Finite_downward_closed
  with (fun i => i <= var2nat v).
remember (var2nat v) as n.
clear.
induction n.
apply Finite_downward_closed with (Add (Empty_set _) O).
repeat constructor.
intro H; inversion H.
intros ? ?; unfold In in *.
assert (x=0) by omega. subst. right. apply Singleton_intro; auto.
apply Finite_downward_closed with (Add (fun i => i<=n) (S n)).
constructor; auto.
unfold In; omega.
repeat intro. unfold In in *.
assert (x <= n \/ x = S n) by omega.
destruct H0; [ left | right]; auto.
apply Singleton_intro; auto.
repeat intro; unfold In in *.
inversion H; clear H; subst.
unfold In, var_upto in *.
apply S_nat_of_P_id2pos_le in H0.
unfold var2nat; omega.
Qed.

End ClauseUniverseFinite.


Require Import S00_setoid_basics S01_Wty S02_PolyFun.

(* Section 3.1 *)

(*------------------------------*)
(* Underlying type of W-setoids *)
(*------------------------------*)

Definition WstdObj {A : setoid}(B : setoidfamily A) : Set
  := Wty (setoidfamilyobj A B).

(*
Definition WstdObjNode {A : setoid}(B : setoidfamily A) : WstdObj B → A
  := WtyNode (setoidfamilyobj A B).

Definition WstdObjIST {A : setoid}(B : setoidfamily A)(w : WstdObj B)
  : B (WtyNode _ w) → WstdObj B
  := @Wty_ist _ (setoidfamilyobj A B) w.
 *)

(*-----------------------------------------------------*)
(* Partial equivalence relation from dependent W-types *)
(*-----------------------------------------------------*)

(* Definition 3.1 *)

Definition WstdPER_aux {A : setoid}(B : setoidfamily A) :
  (WstdObj B) ∧ (WstdObj B) → Set :=
  @DWty ((WstdObj B) ∧ (WstdObj B))
        (λ z : WstdObj B ∧ WstdObj B,
               Wty_node _ (fst z) ≈,{A} Wty_node _ (snd z))
        (λ (z : WstdObj B ∧ WstdObj B)
           (p : Wty_node _ (fst z) ≈,{A} Wty_node _ (snd z)),
         TotStdfamEq B p)
        (λ (z : WstdObj B ∧ WstdObj B)
           (p : Wty_node _ (fst z) ≈,{A} Wty_node _ (snd z))
           (v : TotStdfamEq B p),
         (Wty_ist (fst z) (Unpack1 B p v),
          Wty_ist (snd z) (Unpack2 B p v))).

Definition WstdPER {A : setoid}(B : setoidfamily A) :
  WstdObj B → WstdObj B → Set :=
  λ w w', WstdPER_aux B (w , w').

(* Remark 3.2 *)

Definition isMatch {A : setoid}{B : setoidfamily A}{w w' : WstdObj B}
           (p : Wty_node _ w ≈ Wty_node _ w')
           (df : ∀ b b', b ≈[p] b' →
               WstdPER B (Wty_ist w b)
                         (Wty_ist w' b'))
  : WstdPER B w w'.

  apply (supd (λ (z : WstdObj B ∧ WstdObj B)
                 (p : Wty_node _ (fst z) ≈,{A} Wty_node _ (snd z)),
               TotStdfamEq B p)
              (λ (z : WstdObj B ∧ WstdObj B)
                 (p : Wty_node _ (fst z) ≈,{A} Wty_node _ (snd z))
                 (v : TotStdfamEq B p),
               (Wty_ist (fst z) (Unpack1 B p v),
                Wty_ist (snd z) (Unpack2 B p v)))
              (w , w') p).
  simpl. intro v. apply (df (Unpack1 B p v) (Unpack2 B p v) (UnpackEq B p v)).
Defined.

Definition WstdPER_node {A : setoid}(B : setoidfamily A)
           {w w' : WstdObj B}
  : WstdPER B w w' → Wty_node _ w ≈ Wty_node _ w'
  := DWty_node _ _ (w , w').

Definition WstdPER_ist {A : setoid}{B : setoidfamily A}{w w' : WstdObj B}(r : WstdPER B w w')
  : ∀ b b', b ≈[WstdPER_node B r] b' → WstdPER B (Wty_ist w b) (Wty_ist w' b')
  := λ b b' q, DWty_ist _ _ (w , w') r (PackTotEq _ _ b b' q).

(* Proposition 3.3 - Start *)

Lemma WstdPER_aux_symm {A : setoid}(B : setoidfamily A) :
  ∀ z, WstdPER_aux B z → WstdPER_aux B (snd z , fst z).
Proof.
  intros z r. induction r as [z p feq IH].
  assert (g : (∀ v : TotStdfamEq B (p ˢ),
             WstdPER_aux B (Wty_ist (snd z) (Unpack1 B _ v),
                            Wty_ist (fst z) (Unpack2 B _ v)) )).
  intro v. set (b' := Unpack1 B _ v). set (b := Unpack2 B _ v). set (q := UnpackEq B _ v).
  set (v' := PackTotEq B p b b' (EqRelOverIsIrr _ _ _ _ _ p _ _
                                         (EqRelOverIsSymm _ _ _ _ (p ˢ) _ _ q))).
  apply (IH v').
  apply (supd _ _ (snd z , fst z) p ˢ g).
Qed.

Lemma WstdPER_symm {A : setoid}(B : setoidfamily A) :
  ∀ w w', WstdPER B w w' → WstdPER B w' w.
Proof.
  intros w w'. apply WstdPER_aux_symm.
Qed.

Lemma WstdPER_aux_trans {A : setoid}(B : setoidfamily A) :
  ∀ z, WstdPER_aux B z →
       (∀ w, WstdPER B w (fst z) → WstdPER_aux B (w , snd z)).
Proof.
  intros z r. induction r as [z p' feq' IH].
  intros w r1. set (p := WstdPER_node B r1).
  set (feq := WstdPER_ist r1).
  apply supd with (i := (w , snd z))
                  (a := p'⊙p).
  intro vv. set (b := Unpack1 B _ vv). set (b' := Unpack2 B _ vv). set (q := UnpackEq B _ vv).
  simpl in *|-. simpl.
  specialize IH with (w := Wty_ist w b).
  specialize (feq b (B•p b) (setoidrefl _ _)).
  set (v' := PackTotEq B p' (B•p b) b' (q⊙(setoidfamilycmpgeneral B _ _ _ p p' (p'⊙p) b))).
  specialize (feq' v'). specialize (IH v'). simpl in *|-.
  apply (IH feq).
Qed.

Lemma WstdPER_trans {A : setoid}(B : setoidfamily A) :
  ∀ w w' w'', WstdPER B w w' → WstdPER B w' w'' → WstdPER B w w''.
Proof.
  intros w w' w'' r r'. apply (WstdPER_aux_trans B (w', w'') r' w r).
Qed.

(* Proposition 3.3 - End *)

(*---------------------------------*)
(* The setoid of extensional trees *)
(*---------------------------------*)

(* Definition 3.4 *)

Definition WstdBase {A : setoid}(B : setoidfamily A) : Set :=
  ∃ w, WstdPER B w w.

Definition WstdEq {A : setoid}(B : setoidfamily A) :
  WstdBase B → WstdBase B → Set :=
  λ u u', WstdPER B (projT1 u) (projT1 u').

Definition Wstd {A : setoid}(B : setoidfamily A) : setoid.

  apply (Build_setoid (WstdBase B) (WstdEq B)).
  apply Build_setoidaxioms.
  intro u. apply (projT2 u).
  intros u u' r. apply WstdPER_symm. apply r.
  intros u u' u'' r r'. apply WstdPER_trans with (w' := projT1 u'). apply r. apply r'.
Defined.

(* End Definition 3.4 *)

(* Lemma 3.5 *)

Lemma istExt2Ext {A : setoid}{B : setoidfamily A}{w : WstdObj B}
      (istExt : ∀ b b', b ≈ b' → WstdPER B (Wty_ist w b) (Wty_ist w b'))
  : WstdPER B w w.
Proof.
  apply (isMatch (setoidrefl _ _)). intros b b' q. specialize (istExt b b').
  apply istExt. apply (setoidfamilyrefgeneral_tactical_rev B _ _ _ _ q).
Qed.

Lemma Ext2istExt {A : setoid}{B : setoidfamily A}{w : WstdObj B}(r : WstdPER B w w)
  : ∀ b b', b ≈ b' → WstdPER B (Wty_ist w b) (Wty_ist w b').
Proof.
  intros b b' q. apply (WstdPER_ist r b b').
  apply setoidfamilyrefgeneral_tactical. apply q.
Qed.

(* End Lemma 3.5 *)

Definition node {A : setoid}(B : setoidfamily A) : Wstd B ⇒ A.

  apply (Build_setoidmap _ _ (λ u : Wstd B, Wty_node _ (projT1 u))).
  intros u u' r. apply WstdPER_node. apply r.
Defined.

Definition ist_fnct {A : setoid}{B : setoidfamily A}(u : Wstd B)
  : B (node B u) → Wstd B.

  intro b. exists (Wty_ist (projT1 u) b).
  apply Ext2istExt. apply (projT2 u). apply setoidrefl.
Defined.

Definition ist {A : setoid}{B : setoidfamily A}(u : Wstd B) :
  B (node B u) ⇒ Wstd B.

  apply (Build_setoidmap _ _ (ist_fnct u)).
  intros b b' q. apply Ext2istExt. apply (projT2 u). apply q.
Defined.

(* Lemma 3.6 *)

Lemma easyMatch {A : setoid}{B : setoidfamily A}{u u' : Wstd B}
      (p : node B u ≈ node B u')
  : ist u ≈ ist u' ∘ B•p → u ≈ u'.
Proof.
  intro ISTeq. apply isMatch with (p0 := p). intros b b' q.
  apply WstdPER_trans with (w' := Wty_ist (projT1 u') (B•p b)).
  apply ISTeq. apply Ext2istExt. apply (projT2 u'). apply q.
Qed.

(* Proofs of coherence of the family ist *)

Lemma ist_coh {A : setoid}(B : setoidfamily A){u u' : Wstd B}(r : u ≈ u')
  : ist u ≈ ist u' ∘ B•(node B ↱ r).
Proof.
  intro b. apply (WstdPER_ist r). apply setoidrefl.
Defined.

Definition ist_coh_rev {A : setoid}(B : setoidfamily A){u u' : Wstd B}(r : u ≈ u')
  : ist u' ∘ B•(node B ↱ r) ≈ ist u.
Proof.
  apply setoidsym. apply ist_coh.
Defined.

Lemma ist_coh_tactical {A : setoid}(B : setoidfamily A){u u' : Wstd B}(r : u ≈ u')
  : ∀ b₁ b₂, ist u b₁ ≈ ist u b₂
           → ist u' (B•(node B ↱ r) b₁) ≈ ist u' (B•(node B ↱ r) b₂).
Proof.
  intros b₁ b₂ q.
  apply setoidtra with (y := ist u b₁). apply ist_coh_rev.
  apply setoidtra with (y := ist u b₂). apply q. apply ist_coh.
Qed.

Lemma ist_coh_inv {A : setoid}(B : setoidfamily A)(u u' : Wstd B)(r : u ≈ u')
  : ist u ∘ B•(node B ↱ r ˢ) ≈ ist u'.
Proof.
  apply setoidtra with
      (y := ist u' ∘ (B•(node B ↱ r)) ∘ (B•(node B ↱ r ˢ))).
  intro b. apply (ist_coh B r).
  intro b. apply (setoidmapextensionality _ _ (ist u')).
  apply setoidfamilycmpinvert.
Qed.


Set Implicit Arguments.

Require Import natded_ext nk.

Theorem nk_weakening: forall p q a, is_sub_pre p q -> nk p a -> nk q a.
fix IH 5.
intros p q.
intros a Hpq Tqa.
inversion Tqa.
+ apply nk_from_con.
  apply (is_sub_pre_with_con H Hpq).
+ apply nk_and_i; apply (IH p _ _ Hpq).
  - apply H.
  - apply H0.
+ apply (nk_and_e1 (b := b)).
  exact (IH p _ _ Hpq H).
+ apply (nk_and_e2 (a := a0)).
  apply (IH p _ _ Hpq H).
+ apply nk_or_i1.
  apply (IH p _ _ Hpq H).
+ apply nk_or_i2.
  apply (IH p _ _ Hpq H).
+ apply (IH p _ _ Hpq) in H.
  apply (IH (p ::: a0) (q ::: a0) _) in H0.
  apply (IH (p ::: b) (q ::: b) _) in H1.
  apply (nk_or_e H H0 H1).
  (* prove p::a0 <= q::a0 *)
  apply (is_sub_pre_succ_monotone _ Hpq).
  apply (is_sub_pre_succ_monotone _ Hpq).
+ apply (IH (p ::: a0) (q ::: a0) _) in H.
  apply (nk_imp_i H).
  (* prove p::a0 <= q::a0 *)
  apply (is_sub_pre_succ_monotone _ Hpq).
+ apply (IH p _ _ Hpq) in H, H0.
  apply (nk_imp_e H H0).
+ apply (IH p _ _ Hpq) in H.
  apply (nk_bot_e H).
+ apply (IH p _ _ Hpq) in H.
  apply (nk_dne H).
Qed.