Require Import Bintree.
Require Import Bool.
Require Import Env.
Require Import Free_algebra.

Unset Boxed Definitions.

Section with_env.

Variable Denv: domain_env.

Record pred_entry : Type :=
mkP{P_arity: arity;
           P_it: abstract Denv P_arity Prop}.

Definition signature := Store pred_entry.

Inductive form : Set :=
  Atom : positive -> args -> form
| Equal : domain -> term -> term -> form
| Absurd : form
| Arrow : form  -> form -> form
| And : form -> form -> form
| Or : form -> form -> form
| Forall : domain -> form -> form
| Exists : domain -> form -> form.

Inductive occ_form : Set :=
  Stop : occ_form
| In_Atom : occ_args -> occ_form
| In_Eq : occ_term -> occ_term -> occ_form
| In_Bin : occ_form -> occ_form -> occ_form
| In_Quant : occ_form -> occ_form.

Definition hyp_ctx := Store form.

Notation "A =>> B":= (Arrow A B) (at level 58, right associativity) : form_scope.
Infix "//\\" := And (at level 56, right associativity).
Infix "\\//" := Or (at level 57, right associativity).
Notation " !! d , F" := (Forall d F) (at level 59, right associativity) : form_scope.
Notation " ?? d , F" := (Exists d F) (at level 59, right associativity) : form_scope.
Notation "#" := Absurd.

Open Scope form_scope.

Fixpoint form_eq (p q:form) {struct p} :bool :=
match p, q with
  Atom hp argsp, Atom hq argsq =>
     if pos_eq hp hq then args_eq argsp argsq else false
 | Arrow p1 p2, Arrow q1 q2 =>
     if form_eq p1 q1 then form_eq p2 q2 else false
 | And p1 p2,And q1 q2 =>
     if form_eq p1 q1 then form_eq p2 q2 else false
 | Or p1 p2,Or q1 q2 =>
     if form_eq p1 q1 then form_eq p2 q2 else false
 | Forall dp p0, Forall dq q0 =>
     if pos_eq dp dq then form_eq p0 q0 else false
 | Exists dp p0, Exists dq q0 =>
    if pos_eq dp dq then form_eq p0 q0 else false
 | Absurd,Absurd => true
 | Equal dp tp1 tp2, Equal dq tq1 tq2 =>
    if pos_eq dp dq then
    if term_eq tp1 tq1 then
       term_eq tp2 tq2 else false else false
 | _,_ => false
end.

Lemma refl_form_eq : forall f:form, form_eq f f = true.
induction f;simpl;
repeat (rewrite refl_pos_eq|| rewrite refl_args_eq || rewrite refl_term_eq||
rewrite IHf1||rewrite IHf2||rewrite IHf );reflexivity.
Qed.

Fixpoint inst_form (t:term) (n:nat) (f:form) {struct f} :form :=
 match f with
  Atom p a => Atom p (inst_args t n a)
| Equal d t1 t2 => Equal d (inst_term t n t1) (inst_term t n t2)
| Absurd => Absurd
| Arrow f1 f2 => Arrow (inst_form t n f1) (inst_form t n f2)
| And f1 f2 => And (inst_form t n f1) (inst_form t n f2)
| Or f1 f2 => Or (inst_form t n f1) (inst_form t n f2)
| Forall d f0 => Forall d (inst_form t (S n) f0)
| Exists d f0 => Exists d (inst_form t (S n) f0)
end.

Fixpoint rewrite_form (ta tb:term) (occ:occ_form) (G:form) {struct G} :
 option form :=
  match occ,G with
    Stop, _ => Some G
  | In_Atom aocc, Atom p a =>
    match rewrite_args ta tb aocc a with None => None
    | Some ra => Some (Atom p ra)
    end
  | In_Eq occ1 occ2, Equal d t1 t2 =>
    match rewrite_term ta tb occ1 t1,rewrite_term ta tb occ2 t2 with
      Some rt1,Some rt2 => Some (Equal d rt1 rt2)
    | _,_ => None
    end
  | In_Bin occ1 occ2, Arrow G1 G2 =>
    match rewrite_form ta tb occ1 G1,rewrite_form ta tb occ2 G2 with
      Some rG1,Some rG2 => Some (Arrow rG1 rG2)
    | _,_ => None
    end
  | In_Bin occ1 occ2, And G1 G2 =>
    match rewrite_form ta tb occ1 G1,rewrite_form ta tb occ2 G2 with
      Some rG1,Some rG2 => Some (And rG1 rG2)
    | _,_ => None
    end
  | In_Bin occ1 occ2, Or G1 G2 =>
    match rewrite_form ta tb occ1 G1,rewrite_form ta tb occ2 G2 with
      Some rG1,Some rG2 => Some (Or rG1 rG2)
    | _,_ => None
    end
  | In_Quant occ0, Forall d G0 =>
    match rewrite_form ta tb occ0 G0 with None => None
    | Some rG0 => Some (Forall d rG0)
    end
  | In_Quant occ0, Exists d G0 =>
    match rewrite_form ta tb occ0 G0 with None => None
    | Some rG0 => Some (Exists d rG0)
    end
  | _,_ => None
end.

Variable Sigma : Free_algebra.signature Denv.
Variable Pi : signature.

Fixpoint interp_form (vars:var_env Denv) (rels:rel_env Denv) (f:form) {struct f}: Prop:=
match f with
  Atom hd a =>
  match get hd Pi with
    PNone => True
  | PSome (mkP rge head) =>
    match interp_args Denv Sigma vars rels a rge Prop head with
      PNone => True
    | PSome P => P
    end
  end
| Equal dom t1 t2 =>
  match interp_term Denv Sigma vars rels t1 dom,
               interp_term Denv Sigma vars rels t2 dom with
    Some x1, Some x2 => x1=x2
   | _,_ => True
  end
| Absurd => False
| Arrow f1 f2 => interp_form vars rels f1 -> interp_form vars rels f2
| And f1 f2 => interp_form vars rels f1 /\ interp_form vars rels f2
| Or f1 f2 => interp_form vars rels f1 \/ interp_form vars rels f2
| Forall dom f0 => forall rel:interp_domain Denv dom,
   interp_form vars (mkE Denv dom rel::rels) f0
| Exists dom f0 => exists rel:interp_domain Denv dom,
   interp_form vars (mkE Denv dom rel::rels) f0
end.

Inductive WF_form (gamma:var_ctx) : (list domain) ->  form -> Prop :=
  WF_Atom : forall rels n a rge p,
    get n Pi = PSome (mkP rge p) ->
    WF_args Denv Sigma gamma rels a rge ->
    WF_form gamma rels (Atom n a)
| WF_Equal : forall rels dom t1 t2,
    WF_term Denv Sigma gamma rels t1 dom ->
    WF_term Denv Sigma gamma rels t2 dom ->
    WF_form gamma rels (Equal dom t1 t2)
| WF_Absurd : forall rels,WF_form gamma rels Absurd
| WF_Arrow : forall rels f1 f2,
    WF_form gamma rels f1 ->
    WF_form gamma rels f2 ->
    WF_form gamma rels (Arrow f1 f2)
| WF_And : forall rels f1 f2,
    WF_form gamma rels f1 ->
    WF_form gamma rels f2 ->
    WF_form gamma rels (And f1 f2)
| WF_Or : forall rels f1 f2,
    WF_form gamma rels f1 ->
    WF_form gamma rels f2 ->
    WF_form gamma rels (Or f1 f2)
| WF_Forall : forall rels dom f0,
  WF_form gamma (dom::rels) f0 ->
  WF_form gamma rels (Forall dom f0)
| WF_Exists : forall rels dom f0,
  WF_form gamma (dom::rels) f0 ->
  WF_form gamma rels (Exists dom f0).

Fixpoint check_form (gamma:var_ctx) (rels:list domain) (f:form)
{struct f}: bool :=
match f with
  Atom p a =>
  match get p Pi with
    PNone => false
  | PSome (mkP rge _) =>
          check_args Denv Sigma gamma rels a rge
  end
| Equal dom t1 t2 =>
  if check_term Denv Sigma gamma rels t1 dom
  then check_term Denv Sigma gamma rels t2 dom else false
| Absurd => true
| Arrow f1 f2 | And f1 f2 | Or f1 f2 =>
  if check_form gamma rels f1 then check_form gamma rels f2 else false
| Forall dom f | Exists dom f =>
  check_form gamma (dom::rels) f
end.

Lemma WF_checked_form : forall hyps f rels,
check_form hyps rels f = true ->
WF_form hyps rels f.
induction f;simpl.
caseq (get p Pi).
intros [rge head].
intros eget rels Hargs.
constructor 1 with rge head;try assumption.
apply WF_checked_args;assumption.
congruence.
intro rels;caseq (check_term Denv Sigma hyps rels t d);clean.
intros et1 et2;constructor 2.
apply WF_checked_term;assumption.
apply WF_checked_term;assumption.
constructor.
intro rels;caseq (check_form hyps rels f1);clean;intros;constructor;auto.
intro rels;caseq (check_form hyps rels f1);clean;intros;constructor;auto.
intro rels;caseq (check_form hyps rels f1);clean;intros;constructor;auto.
constructor;apply IHf;assumption.
constructor;apply IHf;assumption.
Qed.

Theorem form_eq_refl: forall p q ,form_eq p q = true ->
forall vars rels ,
 (interp_form vars rels p <-> interp_form vars rels q).
induction p;destruct q;simpl;try congruence.
caseq (pos_eq p p0);simpl;try congruence.
intros ep ea vars rels;rewrite <-(pos_eq_refl _ _ ep);clear ep.
case (get p Pi).
intros [doms hd].
rewrite (args_eq_refl Denv Sigma vars rels doms Prop hd a a0);auto.
apply iff_refl.
apply iff_refl.
caseq (pos_eq d d0);simpl;try congruence.
caseq (term_eq t t1);simpl;try congruence.
intros et1 ed et2 vars rels.
rewrite <- (pos_eq_refl _ _ ed);clear ed.
rewrite (term_eq_refl Denv Sigma vars rels d t t1);auto.
rewrite (term_eq_refl Denv Sigma vars rels d t0 t2);auto.
apply iff_refl.
intros;apply iff_refl.
caseq (form_eq p1 q1);clean.
intros e1 e2 vars rels.
generalize (IHp1 q1 e1 vars rels) (IHp2 q2 e2 vars rels).
intros [h1 h2] [h3 h4];split ;auto.
caseq (form_eq p1 q1);clean.
intros e1 e2 vars rels.
generalize (IHp1 q1 e1 vars rels) (IHp2 q2 e2 vars rels).
intros [h1 h2] [h3 h4];split ; intros [h5 h6];split;auto.
caseq (form_eq p1 q1);clean.
intros e1 e2 vars rels.
generalize (IHp1 q1 e1 vars rels) (IHp2 q2 e2 vars rels ).
intros [h1 h2] [h3 h4];split.
intros [h5 | h5];[left | right];auto.
intros [h5 | h5];[left | right];auto.
caseq (pos_eq d d0);try congruence;intros ed ep vars rels.
rewrite <- (pos_eq_refl _ _ ed);clear ed.
split; intros h x; assert (hh:=h x);
elim (IHp q ep vars ((mkE Denv d x) :: rels));auto.
caseq (pos_eq d d0);try congruence;intros ed ep vars rels.
rewrite <- (pos_eq_refl _ _ ed);clear ed.
split; intros [x h];split with x;
elim (IHp q ep vars ((mkE Denv d x) :: rels));auto.
Qed.

Lemma WF_Forall_instx : forall V (F:Full V) dom G,
WF_form V nil (!!dom, G) ->
WF_form (V \ dom) nil (inst_form (mkVar (index V)) 0 G).
intros V F dom G W.
inversion_clear W.
change (WF_form V (app nil (dom::nil)) G) in H.
replace O with (@length domain nil);trivial.
generalize H.
pattern (@nil domain) at -2.
apply  (fun (P: list domain -> Prop) (H:forall p, P p) => H nil).
clear H;induction G;intros rc W;inversion W;subst;simpl inst_form.
constructor 1 with rge p0;trivial.
apply WF_args_instx;auto.
constructor 2;apply WF_term_instx;auto.
constructor 3.
simpl;constructor;auto.
simpl;constructor;auto.
simpl;constructor;auto.
replace (S (length rc)) with (length (d :: rc));constructor;auto.
replace (S (length rc)) with (length (d :: rc));constructor;auto.
Qed.

Lemma WF_Exists_instx : forall V (F:Full V) dom G,
WF_form V nil (??dom, G) ->
WF_form (V \ dom) nil (inst_form (mkVar (index V)) 0 G).
intros V F dom G W.
inversion_clear W.
change (WF_form V (app nil (dom::nil)) G) in H.
replace O with (@length domain nil);trivial.
generalize H.
pattern (@nil domain) at -2.
apply  (fun (P: list domain -> Prop) (H:forall p, P p) => H nil).
clear H;induction G;intros rc W;inversion W;subst;simpl inst_form.
constructor 1 with rge p0;trivial.
apply WF_args_instx;auto.
constructor 2;apply WF_term_instx;auto.
constructor 3.
simpl;constructor;auto.
simpl;constructor;auto.
simpl;constructor;auto.
replace (S (length rc)) with (length (d :: rc));constructor;auto.
replace (S (length rc)) with (length (d :: rc));constructor;auto.
Qed.

Notation "[ T ; i ]" := (mkE Denv i T).

Lemma form_instx :
 forall hyps F Venv, Instanceof Denv hyps F Venv ->
 forall dom rel G rc, WF_form hyps
(List.map (E_domain Denv) (rc ++ [rel;dom] :: nil)) G ->
(interp_form (Venv\ [rel;dom])
       rc (inst_form (mkVar (index hyps)) (length rc) G) <->
interp_form Venv (rc ++ [rel;dom] :: nil) G).
intros hyps F Venv Inst dom rel.
induction G;intros rc W;inversion W;subst;simpl.
rewrite H2.
rewrite (args_instx _ Sigma _ F Venv);trivial.
split;trivial.
rewrite (term_instx  _ Sigma _ F Venv);trivial.
case (interp_term Denv Sigma Venv (rc ++ [rel; dom] :: nil) t d).
intro x1.
rewrite (term_instx _ Sigma _ F Venv);trivial.
split;trivial.
split;trivial.
split;trivial.
assert (HG1:=IHG1 rc H2).
assert (HG2:=IHG2 rc H3).
destruct HG1.
destruct HG2.
split;auto.
assert (HG1:=IHG1 rc H2).
assert (HG2:=IHG2 rc H3).
destruct HG1.
destruct HG2.
split;intros [HH1 HH2];split;auto.
assert (HG1:=IHG1 rc H2).
assert (HG2:=IHG2 rc H3).
destruct HG1.
destruct HG2.
split;(intro HH;destruct HH ; [left|right];auto).
split;intros H rel0;assert (H0:= IHG ([rel0;d] :: rc) H1);destruct H0;
simpl in H2;auto.
split; intros [rel0 H0];split with rel0;
assert (H:= IHG ([rel0;d] :: rc) H1);
destruct H;auto.
Qed.

Lemma WF_form_inst : forall hyps t dom,
WF_ground_term Denv Sigma hyps t dom ->
forall G rc,
WF_form hyps (rc ++ dom::nil)  G ->
WF_form hyps rc (inst_form t (length rc) G).
intros hyps t dom Wgt; induction G;intros rc W;inversion W; subst;simpl inst_form.
constructor 1 with rge p0;trivial.
apply WF_args_inst with dom;auto.
constructor 2;auto.
apply WF_term_inst with dom;auto.
apply WF_term_inst with dom;auto.
constructor 3.
constructor;auto.
constructor;auto.
constructor;auto.
replace (S (length rc)) with (length (d :: rc));trivial;constructor;auto.
replace (S (length rc)) with (length (d :: rc));trivial;constructor;auto.
Qed.

Lemma form_inst : forall hyps F Venv t dom x, Instanceof Denv hyps F Venv ->
WF_ground_term Denv Sigma hyps t dom ->
interp_term Denv Sigma Venv nil t dom = Some x ->
forall G rc,
WF_form hyps
(List.map (E_domain Denv) (rc ++ [x;dom] :: nil)) G ->
(interp_form Venv (rc ++ [x;dom] :: nil) G <->
interp_form Venv rc (inst_form t (length rc) G)).
intros hyps F Venv t dom x Inst Wgt et G;induction G;intros rc W;inversion W;
subst;simpl.
rewrite H2.
replace
(interp_args Denv Sigma Venv rc (inst_args t (length rc) a) rge Prop p0)
with
(interp_args Denv Sigma Venv (rc ++ [x;dom] :: nil) a rge Prop p0).
split;trivial.
apply args_inst with hyps F;trivial.
replace
(interp_term Denv Sigma Venv rc (inst_term t (length rc) t0) d)
with
(interp_term Denv Sigma Venv (rc ++ [x; dom] :: nil) t0 d).
replace
(interp_term Denv Sigma Venv rc (inst_term t (length rc) t1) d)
with
(interp_term Denv Sigma Venv (rc ++ [x; dom] :: nil) t1 d).
split;trivial.
apply term_inst with hyps F;trivial.
apply term_inst with hyps F;trivial.
split;trivial.
elim (IHG1 rc H2);elim (IHG2 rc H3);split;auto.
elim (IHG1 rc H2);elim (IHG2 rc H3);split;intros [HH1 HH2];split;auto.
elim (IHG1 rc H2);elim (IHG2 rc H3);split;(intros [HH1 | HH2];[left| right];auto).
split;intros HH rel;elim (IHG (mkE Denv d rel :: rc) H1);simpl length.
intros h _;apply h;apply (HH rel).
auto.
split;intros [rel HH];split with rel;elim (IHG (mkE Denv d rel :: rc) H1);auto.
Qed.

Lemma Weak_WF_form : forall hyps H G rc,
Full hyps ->
WF_form hyps rc G ->
WF_form (hyps\H) rc G.
induction G;intros rc F W;inversion W;subst;try (constructor;auto).
constructor 1 with rge p0;auto;apply Weak_WF_args;auto.
apply Weak_WF_term;auto.
apply Weak_WF_term;auto.
Qed.

Lemma Weak_interp_form: forall hyps F  Venv var G rc,
Instanceof Denv hyps F Venv ->
WF_form hyps (List.map (E_domain Denv) rc) G ->
(interp_form Venv rc G <->
 interp_form (Venv\var) rc G).
intros hyps F Venv var.
induction G;intros rc Inst W;inversion_clear W;subst;simpl interp_form.
rewrite H.
clear p H.
rewrite <- (Weak_interp_args _ Sigma _ F Venv);trivial.
split;trivial.
simpl interp_form.
rewrite <- (Weak_interp_term _ Sigma _ F Venv);trivial.
rewrite <- (Weak_interp_term _ Sigma _ F Venv);trivial.
split;trivial.
split;trivial.
generalize (IHG1 rc Inst H) (IHG2 rc Inst H0);tauto.
generalize (IHG1 rc Inst H) (IHG2 rc Inst H0);tauto.
generalize (IHG1 rc Inst H) (IHG2 rc Inst H0);tauto.
simpl interp_form;split;
intros H0 varx;generalize (H0 varx) (IHG ([varx;d] :: rc) Inst);tauto.
split;intros [varx H0];split with varx;
generalize (IHG ([varx;d] :: rc) Inst H);tauto.
Qed.

Lemma Bind_WF_form : forall hyps delta G rc,
WF_form hyps rc G ->
WF_form hyps (rc ++ delta) G.
induction G;intros rc W;inversion W;subst;try constructor;auto.
constructor 1 with rge p0;trivial.
apply Bind_WF_args;trivial.
apply Bind_WF_term;trivial.
apply Bind_WF_term;trivial.
replace (d :: rc ++ delta) with ((d :: rc) ++ delta);auto.
replace (d :: rc ++ delta) with ((d :: rc) ++ delta);auto.
Qed.

Lemma Bind_interp_form : forall hyps F Venv delta G rc,
Instanceof Denv hyps F Venv ->
WF_form hyps (List.map (E_domain Denv) rc) G ->
(interp_form Venv rc G <->
 interp_form Venv (rc ++ delta) G).
induction G;intros rc Inst W;inversion W;subst;simpl.
rewrite H2;rewrite (Bind_interp_args _ Sigma _ F Venv delta);trivial.
split;auto.
rewrite (Bind_interp_term _ Sigma _ F Venv delta);trivial.
case (interp_term Denv Sigma Venv (rc ++ delta) t d);trivial.
rewrite (Bind_interp_term _ Sigma _ F Venv delta);trivial.
split;trivial.
split;trivial.
split;trivial.
elim (IHG1 _ Inst H2).
elim (IHG2 _ Inst H3).
split;auto.
elim (IHG1 _ Inst H2).
elim (IHG2 _ Inst H3).
split;intros [h1 h2];split;auto.
elim (IHG1 _ Inst H2).
elim (IHG2 _ Inst H3).
split;(intros [ h | h ];[left | right];auto).
split;intros h rel;assert (hh:=h rel);clear h.
change
(WF_form hyps (List.map (E_domain Denv) ([rel;d]::rc)) G) in H1.
change (interp_form Venv (([rel; d] :: rc) ++ delta) G).
elim (IHG _ Inst H1);auto.
change
(WF_form hyps (List.map (E_domain Denv) ([rel;d]::rc)) G) in H1.
change (interp_form Venv (([rel; d] :: rc) ++ delta) G) in hh.
elim (IHG _ Inst H1);auto.
split;intros [rel h];split with rel.
change
(WF_form hyps (List.map (E_domain Denv) ([rel;d]::rc)) G) in H1.
change (interp_form Venv (([rel; d] :: rc) ++ delta) G).
elim (IHG _ Inst H1);auto.
change
(WF_form hyps (List.map (E_domain Denv) ([rel;d]::rc)) G) in H1.
change (interp_form Venv (([rel; d] :: rc) ++ delta) G) in h.
elim (IHG _ Inst H1);auto.
Qed.

Lemma WF_rewrite_form : forall hyps dom t1 t2,
WF_ground_term Denv Sigma hyps t1 dom ->
WF_ground_term Denv Sigma hyps t2 dom ->
forall G occ rG rc,
rewrite_form t1 t2 occ G = Some rG ->
WF_form hyps rc G ->
WF_form hyps rc rG.
intros hyps dom t1 t2 Wt1 Wt2.
induction G;intros [ | occa |occ1 occ2 | occ1 occ2 | occ0];simpl;
clean;intros rG rc e W;inversion_clear W;
generalize e;clear e.
caseq (rewrite_args t1 t2 occa a);clean.
intros ra era e;injection e;clear e;intro e;subst.
apply WF_Atom with rge p0;trivial.
apply WF_rewrite_args with dom t1 t2 a occa;trivial.
caseq (rewrite_term t1 t2 occ1 t);clean.
intros rt et.
caseq (rewrite_term t1 t2 occ2 t0);clean.
intros rt0 et0 e;injection e;clear e;intro e;subst.
apply WF_Equal.
apply WF_rewrite_term with dom t1 t2 t occ1;trivial.
apply WF_rewrite_term with dom t1 t2 t0 occ2;trivial.
caseq (rewrite_form t1 t2 occ1 G1);clean.
intros rG1 e1.
caseq (rewrite_form t1 t2 occ2 G2);clean.
intros rG2 e2 e;injection e;clear e;intro e;subst.
constructor;eauto.
caseq (rewrite_form t1 t2 occ1 G1);clean.
intros rG1 e1.
caseq (rewrite_form t1 t2 occ2 G2);clean.
intros rG2 e2 e;injection e;clear e;intro e;subst.
constructor;eauto.
caseq (rewrite_form t1 t2 occ1 G1);clean.
intros rG1 e1.
caseq (rewrite_form t1 t2 occ2 G2);clean.
intros rG2 e2 e;injection e;clear e;intro e;subst.
constructor;eauto.
caseq (rewrite_form t1 t2 occ0 G);clean.
intros rG0 e0 e;injection e;clear e;intro e;subst.
constructor;eauto.
caseq (rewrite_form t1 t2 occ0 G);clean.
intros rG0 e0 e;injection e;clear e;intro e;subst.
constructor;eauto.
Qed.

Lemma WF_eq_members : forall hyps dom t1 t2,
WF_form hyps nil (Equal dom t1 t2) ->
WF_ground_term Denv Sigma hyps t1 dom /\
WF_ground_term Denv Sigma hyps t2 dom.
intros hyps dom t1 t2 W;inversion W;split;apply WF_term_nil_ground_term;trivial.
Qed.

Lemma form_rewrite :
forall hyps F Venv,
Instanceof Denv hyps F Venv ->
forall dom t1 t2 it1 it2,
WF_ground_term Denv Sigma hyps t1 dom ->
WF_ground_term Denv Sigma hyps t2 dom ->
interp_term Denv Sigma Venv nil t1 dom = Some it1 ->
interp_term Denv Sigma Venv nil t2 dom = Some it2 ->
it1 = it2 ->
forall G occ rc rG,
rewrite_form t1 t2 occ G = Some rG ->
WF_form hyps (List.map (E_domain Denv) rc) G ->
(interp_form Venv rc G <-> interp_form Venv rc rG).
induction G;intros [ |occa | occ1 occ2 | occ1 occ2 | occ0] rc rG;simpl rewrite_form;
try solve [intro e;inversion e;split;trivial].
caseq (rewrite_args t1 t2 occa a);clean.
intros ra era e W;inversion e;inversion_clear W.
simpl.
rewrite H5.
replace
(interp_args Denv Sigma Venv rc ra rge Prop p0)
with
(interp_args Denv Sigma Venv rc a rge Prop p0).
split;trivial.
apply args_rewrite with hyps F dom t1 t2 it1 it2 occa;trivial.
caseq (rewrite_term t1 t2 occ1 t);clean.
intros rt et.
caseq (rewrite_term t1 t2 occ2 t0);clean.
intros rt0 et0 e W;inversion e;inversion_clear W.
simpl.
replace
(interp_term Denv Sigma Venv rc rt d)
with
(interp_term Denv Sigma Venv rc t d).
replace
(interp_term Denv Sigma Venv rc rt0 d)
with
(interp_term Denv Sigma Venv rc t0 d).
split;trivial.
apply term_rewrite with hyps F dom t1 t2 it1 it2 occ2;trivial.
apply term_rewrite with hyps F dom t1 t2 it1 it2 occ1;trivial.
caseq (rewrite_form t1 t2 occ1 G1);clean.
caseq (rewrite_form t1 t2 occ2 G2);clean.
intros rG2 e2 rG1 e1 e W;inversion e;inversion_clear W.
elim (IHG1 occ1 rc rG1 e1 H5).
elim (IHG2 occ2 rc rG2 e2 H7).
simpl;split;auto.
caseq (rewrite_form t1 t2 occ1 G1);clean.
caseq (rewrite_form t1 t2 occ2 G2);clean.
intros rG2 e2 rG1 e1 e W;inversion e;inversion_clear W.
elim (IHG1 occ1 rc rG1 e1 H5).
elim (IHG2 occ2 rc rG2 e2 H7).
simpl;tauto.
caseq (rewrite_form t1 t2 occ1 G1);clean.
caseq (rewrite_form t1 t2 occ2 G2);clean.
intros rG2 e2 rG1 e1 e W;inversion e;inversion_clear W.
elim (IHG1 occ1 rc rG1 e1 H5).
elim (IHG2 occ2 rc rG2 e2 H7).
simpl;tauto.
caseq (rewrite_form t1 t2 occ0 G);clean.
intros rG0 eG0 e W;inversion e;inversion_clear W.
simpl;split;intros h x;
elim (IHG occ0 (mkE Denv d x :: rc) rG0 eG0 H5);auto.
caseq (rewrite_form t1 t2 occ0 G);clean.
intros rG0 eG0 e W;inversion e;inversion_clear W.
simpl;split;intros [x h];split with x;
elim (IHG occ0 (mkE Denv d x :: rc) rG0 eG0 H5);auto.
Qed.

End with_env.


Require Import Reals Psatz.
From discprob.basic Require Export Series_Ext.
From discprob.measure Require Export borel integral.
Local Open Scope R_scope.
Require Import ClassicalEpsilon SetoidList.

Section measure_of_dens.

Context `{F: measurable_space X}.
Context `(μ: measure X).
Context (f: X → R).
Context (fnonneg: ∀ x, 0 <= f x).
Context (fintegrable: ex_integral μ f).

Definition measure_of_density_fun : (X → Prop) → R :=
  λ U, Integral_over μ U f.

Instance measure_of_density_fun_Proper :
  Proper (eq_prop ==> eq) (measure_of_density_fun).
Proof.
  intros U V Heq. rewrite /measure_of_density_fun/Integral_over.
  eapply Integral_ext => x0. specialize (Heq x0).
  destruct (excluded_middle_informative (U x0)) as [|n];
  destruct (excluded_middle_informative (V x0)) as [|n']; eauto;
    exfalso.
  - eapply n'; eapply Heq; eauto.
  - eapply n; eapply Heq; eauto.
Qed.

Lemma measure_of_density_fun_nonneg :
  ∀ U, measure_of_density_fun U >= 0.
Proof.
  intros U.
  rewrite /measure_of_density_fun/Integral_over.
  apply Integral_ge0. intros x. specialize (fnonneg x).
  destruct (excluded_middle_informative (U x)); nra.
Qed.

Lemma measure_of_density_fun_emptyset:
  measure_of_density_fun empty_set = 0.
Proof.
  rewrite /measure_of_density_fun/Integral_over.
  etransitivity; [ eapply Integral_ext | eapply Integral_0 ].
  intros x.
  destruct (excluded_middle_informative (empty_set x)) as [[]|]; try nra.
Qed.

Lemma indicator_ext P Q:
  (P ↔ Q) →
  match excluded_middle_informative P with
    | left _ => 1
    | _ => 0
  end =
  match excluded_middle_informative Q with
    | left _ => 1
    | _ => 0
  end.
Proof.
  clear. intros HPQ.  do 2 destruct (excluded_middle_informative _); eauto; try exfalso; firstorder.
Qed.

Lemma sum_n_disjoint_indicator {A} Us n (x : A):
  disjointF Us →
  sum_n (λ m : nat,
               match excluded_middle_informative (Us m x) with
               | left _ => 1
               | _ => 0
               end) n =
  match excluded_middle_informative (∃ m, m ≤ n ∧ Us m x) with
    | left _ => 1
    | _ => 0
  end.
Proof.
  intros Hdisj. induction n.
  - rewrite sum_O. eapply indicator_ext.
    split.
    * intros ?. exists O; split; eauto.
    * intros (m&Hle&?). inversion Hle. subst. eauto.
  - rewrite sum_Sn /plus /=.
    rewrite IHn.
    destruct (excluded_middle_informative _) as [(m1&?&?)|n1];
    destruct (excluded_middle_informative _) as [e2|n2]; try nra.
    * exfalso.
      eapply (Hdisj m1 (S n)); last (split; eassumption). lia.
    * destruct (excluded_middle_informative _) as [e3|n3]; first nra.
      exfalso. eapply n3. exists m1; split; eauto.
    * destruct (excluded_middle_informative _) as [e3|n3]; first nra.
      exfalso. eapply n3. exists (S n); split; eauto.
    * destruct (excluded_middle_informative _) as [(m&Hle&?)|n3]; last nra.
      exfalso. inversion Hle; subst; eauto.
Qed.

Lemma sum_n_disjoint_indicator_le_1 {A} Us n (x : A):
  disjointF Us →
  sum_n (λ m : nat,
               match excluded_middle_informative (Us m x) with
               | left _ => 1
               | _ => 0
               end) n <= 1.
Proof.
  intros. rewrite sum_n_disjoint_indicator; auto. destruct (excluded_middle_informative _); nra.
Qed.

Lemma measure_of_density_fun_additivity :
  ∀ U : nat → X → Prop,
    (∀ i : nat, F (U i)) → disjointF U →
    is_series (λ n : nat, measure_of_density_fun (U n)) (measure_of_density_fun (unionF U)).
Proof.
  intros Us Hin Hdisj.
  edestruct (is_integral_levi_series_ae_ex μ
              (λ n x, f x * (match excluded_middle_informative (Us n x) with | left _ => 1 | _ => 0 end))).
  { eapply almost_everywhere_meas_True'. intros x.
    eapply ex_series_single_non_zero.
    intros i j Hneq0i Hneq0j.
    destruct (excluded_middle_informative (Us i x));
    destruct (excluded_middle_informative (Us j x)); try nra.
    destruct (decide (i = j)) as [|Hneq]; first eauto.
    specialize (Hdisj i j Hneq). exfalso. eapply Hdisj; split; eauto.
  }
  { intros n x; specialize (fnonneg x); destruct (excluded_middle_informative _); nra. }
  { intros n. edestruct (ex_integral_ex_integral_over μ (Us n) f) as (?&?&?); eauto.
    eexists; eauto. }
  { destruct fintegrable as (v&His). exists v.
    intros r (n&His'). eapply is_integral_mono; eauto.
    intros x => /=. rewrite sum_n_scal_l /scal/=/mult//=.
    specialize (sum_n_disjoint_indicator_le_1 Us n x Hdisj). specialize (fnonneg x). intros.
    rewrite -[a in _ <= a](Rmult_1_r).
    apply Rmult_le_compat_l; try nra. eauto.
  }
  assert (measure_of_density_fun (unionF Us) =
          (Integral μ (λ x : X, Series (λ n : nat, f x * (match excluded_middle_informative (Us n x) with
                                                            | left _ => 1
                                                            | _ => 0
                                                          end))))) as ->.
  {
    rewrite /measure_of_density_fun/Integral_over. eapply Integral_ext.
    intros x. rewrite Series_scal_l; f_equal.
    destruct (excluded_middle_informative (unionF Us x)) as [Hin_union|Hnin_union].
    * symmetry. destruct Hin_union as (n&?). rewrite (Series_single_non_zero _ n) //=.
      { destruct (excluded_middle_informative _); eauto; try exfalso; eauto. }
      intros j. destruct (excluded_middle_informative _) => ?; last nra.
      destruct (decide (n = j)) as [?|Hneq]; eauto.
      exfalso. eapply (Hdisj n j); eauto.
    * symmetry. rewrite Series_0 //.
      intros m. destruct (excluded_middle_informative _); try nra.
      exfalso. eapply Hnin_union; eauto. exists m. eauto.
  }
  eapply is_series_ext; try eassumption; eauto.
Qed.

Definition measure_of_density : measure X.
Proof.
  refine {| measure_fun := measure_of_density_fun |}.
  - apply measure_of_density_fun_nonneg.
  - apply measure_of_density_fun_emptyset.
  - apply measure_of_density_fun_additivity.
Defined.

End measure_of_dens.


Module Termination.

Parameter T : Set.

Parameter R : T -> T -> Prop.

Fixpoint terminates (n : nat) (gamma : T) : Prop :=
  match n with
    | O => False
    | S n' =>
      forall gamma' : T,
        (R gamma gamma' -> terminates n' gamma')
  end.

Require Import CpdtTactics.

Theorem terminates_monotone : forall n gamma,
  terminates n gamma -> terminates (S n) gamma.
  induction n.
  inversion 1.
  intros.
  simpl.
  intros.
  simpl in H.
  specialize (H gamma' H0).
  specialize (IHn gamma' H).
  simpl in IHn.
  specialize (IHn gamma'0 H1).
  assumption.
Qed.

End Termination.


Require Coq.setoid_ring.Ncring.
Require Coq.setoid_ring.Cring.
Require Import Coq.ZArith.ZArith Coq.PArith.PArith.
Require Import Coq.Classes.Morphisms
  Coq.micromega.Lia Sigma.Algebra.Hierarchy
  Sigma.Algebra.Monoid Sigma.Algebra.Group.

Section Ring.

  Context
    {T : Type}
    {eq : T -> T -> Prop}
    {zero one : T}
    {opp : T -> T}
    {add sub mul : T -> T -> T}
    {Hr : @ring T eq zero one opp add sub mul}.

  Local Infix "=" := eq : type_scope.
  Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Notation "0" := zero.
  Local Notation "1" := one.
  Local Infix "+" := add.
  Local Infix "-" := sub.
  Local Infix "*" := mul.

  Global Instance Ncring_ops :
    @Ncring.Ring_ops T 0 1 add mul sub opp eq.
  Defined.

  Global Instance Ncring_ring :
    @Ncring.Ring T 0 1 add mul sub opp eq Ncring_ops.
  Proof.
    split; try (typeclasses eauto).
    + intros ?.
      rewrite left_identity;
      reflexivity.
    + intros ? ?.
      rewrite commutative;
      reflexivity.
    + intros ? ? ?.
      rewrite associative;
      reflexivity.
    + intros ?;
      rewrite left_identity;
      reflexivity.
    + intros ?;
      rewrite right_identity;
      reflexivity.
    + intros ? ? ?;
      rewrite associative;
      reflexivity.
    + intros ? ? ?;
      rewrite right_distributive;
      reflexivity.
    + intros ? ? ?;
      rewrite left_distributive;
      reflexivity.
    + intros ? ?;
      rewrite ring_sub_definition;
      reflexivity.
    + intros ?;
      rewrite right_inverse;
      reflexivity.
  Defined.

  Lemma ring_mul_0_l : forall x, 0 * x = 0.
  Proof.
    apply Ncring.ring_mul_0_l.
  Qed.

  Lemma ring_mul_0_r : forall x, x * 0 = 0.
  Proof.
    apply Ncring.ring_mul_0_r.
  Qed.

  Lemma ring_sub_0_l : forall x, 0 - x = opp x.
  Proof.
    intros ?.
    rewrite ring_sub_definition.
    rewrite commutative.
    apply Ncring.ring_add_0_r.
  Qed.

  Lemma ring_mul_opp_r : forall x y, x * opp y = opp (x * y).
  Proof.
    intros ? ?.
    symmetry.
    apply Ncring.ring_opp_mul_r.
  Qed.

  Lemma ring_mul_opp_l : forall x y, opp x * y = opp (x * y).
  Proof.
    intros ? ?.
    symmetry.
    apply Ncring.ring_opp_mul_l.
  Qed.

  Lemma ring_opp_zero_iff : forall x, opp x = 0 <-> x = 0.
  Proof.
    apply Group.group_inv_id_iff.
  Qed.

  Global Instance is_left_distributive_sub :
    is_left_distributive (eq := eq)(add := sub)(mul := mul).
  Proof.
    intros ? ? ?.
    rewrite !ring_sub_definition.
    rewrite
      left_distributive,
      ring_mul_opp_r;
    reflexivity.
  Qed.

  Global Instance is_right_distributive_sub :
    is_right_distributive (eq := eq)(add := sub)(mul := mul).
  Proof.
    intros ? ? ?.
    repeat rewrite ring_sub_definition.
    rewrite
      right_distributive,
      ring_mul_opp_l;
    reflexivity.
  Qed.

  Lemma ring_sub_zero_iff :
    forall x y, x - y = 0 <-> x = y.
  Proof.
    intros ? ?;
    split;
    intros H.
    rewrite ring_sub_definition,
    group_inv_unique,
    group_inv_inv in H.
    exact H.
    rewrite H,
    ring_sub_definition,
    right_inverse;
    reflexivity.
  Qed.

  Lemma ring_neq_sub_neq_zero :
    forall x y, x <> y -> x-y <> 0.
  Proof.
    intros ? ? H Hsub.
    pose proof (proj1 (ring_sub_zero_iff _ _) Hsub) as Ht.
    unfold not in H.
    apply H in Ht.
    inversion Ht.
  Qed.

  Lemma ring_zero_product_iff_zero_factor
    {Hzpzf : @is_zero_product_zero_factor T eq zero mul} :
    forall x y : T, x * y = 0 <-> x = 0 \/ y = 0.
  Proof.
    intros ? ?; split; intros H.
    apply zero_product_zero_factor; exact H.
    destruct H; rewrite H;
     [apply ring_mul_0_l | apply ring_mul_0_r].
  Qed.

  Lemma nonzero_product_iff_nonzero_factor
    {Hzpzf : @is_zero_product_zero_factor T eq zero mul} :
    forall x y : T,  x * y <> 0 <-> x <> 0 /\ y <> 0.
  Proof.
    intros ? ?;
    split;
    intros H.
    split;
    intro Ht; apply H;
    rewrite Ht;
    [rewrite ring_mul_0_l | rewrite ring_mul_0_r];
    reflexivity.
    intro Ht.
    destruct H as [H1 H2].
    apply ring_zero_product_iff_zero_factor in Ht.
    destruct Ht as [Ht | Ht].
    apply H1 in Ht.
    exact Ht.
    apply H2 in Ht.
    exact Ht.
  Qed.

End Ring.

Section Cring.

  Context
    {T eq zero one opp add sub mul}
    {Hcring : @commutative_ring T eq zero one opp add sub mul}.

  Global Instance Cring_commutative_ring :
   @Cring.Cring T zero one add mul sub opp eq Ncring_ops Ncring_ring.
  Proof.
    intros ? ?.
    apply commutative.
  Defined.

  Lemma ring_theory_for_stdlib_tactic :
    Ring_theory.ring_theory zero one add mul sub opp eq.
  Proof.
    split; intros; try (typeclasses eauto).
    + apply left_identity.
    + apply commutative.
    + apply associative.
    + apply left_identity.
    + apply commutative.
    + apply associative.
    + apply right_distributive.
    + apply ring_sub_definition.
    + apply right_inverse.
  Qed.

End Cring.

Section of_Z.

  Local Open Scope Z_scope.
  Context {R Req Rzero Rone Ropp Radd Rsub Rmul}
        {Rring : @ring R Req Rzero Rone Ropp Radd Rsub Rmul}.
  Local Infix "=" := Req : type_scope.

  Fixpoint of_nat (n : nat) : R :=
    match n with
    | 0%nat => Rzero
    | S n' => Radd Rone (of_nat n')
    end.

  Definition of_Z (n : Z) : R :=
    match n with
    | Z0 => Rzero
    | Zpos p => of_nat (Pos.to_nat p)
    | Zneg p => Ropp (of_nat (Pos.to_nat p))
    end.

  Lemma of_Z_0 : of_Z 0 = Rzero.
  Proof. reflexivity. Qed.

  Lemma of_nat_add : forall n,
    of_nat (Nat.add n 1) = Radd (of_nat n) Rone.
  Proof.
    unfold of_nat.
    induction n.
    + simpl. rewrite commutative; reflexivity.
    + simpl. rewrite IHn, associative; reflexivity.
  Qed.

End of_Z.


(***************************************************************************)
(*   This is part of FA_Completeness, it is distributed under the terms    *)
(*           of the GNU Lesser General Public License version 3            *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*           Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.              *)
(***************************************************************************)

Require Import t5.
Require Export Seq.

Lemma SL1: ∀ a, fin (SeqEns a) -> ∃ r, r ∈ (SeqEns a)
  /\ ~ fin /{ z | z ∈ (AllSeq a) /\ (snd z) = r /}.
Proof.
  intros; Absurd.
  pose proof (not_ex_all_not _ H0); simpl in H1.
  assert (∀ n, (n ∈ (SeqEns a) ->
    fin /{ z | z ∈ (AllSeq a) /\ snd z = n /})).
  { intros; pose proof (H1 n).
    apply property_not in H3; destruct H3; try tauto.
    apply property_not'; auto. } clear H0 H1.
  assert (∀ m, fin /{ z | z ∈ (AllSeq a) /\ snd z = m /}).
  { intros; destruct (classic (m ∈ (SeqEns a))) as [H0 | H0]; auto.
    apply Fin_Empty; intro; destruct H1, H1, H1, H1, H1.
    subst x; simpl in H3; apply H0; constructor; eauto. } clear H2.
  assert (fin (AllSeq a)).
  { rewrite AllSeq_eq; apply Fin_EleUnion; intros.
    - destruct H as [x [f H]]; pose proof (comp H (SeqEns_P1 _)).
      red; eauto.
    - destruct H1, H1, H1; rewrite H2; auto. }
  destruct (Infin_AllSeq _ H1).
Qed.

Lemma SL2 : ∀ a, fin (SeqEns a) -> ∃ N, ∀ n, (∃ m, IGT_N m n /\ a m = a N).
Proof.
  intros; destruct (SL1 a H) as [r [H0 H1 ]].
  destruct H0 as [[N H0]]; subst r.
  exists N; intros; Absurd; elim H1.
  apply Fin_Included with
    (B:=/{ z | z ∈ (AllSeq a) /\ (~ (IGT_N (fst z) n)) /}).
  - red; intros; destruct H2, H2, x. constructor; split; auto.
    intro; destruct H2, H2; rewrite H2 in H3, H4.
    simpl fst in H4; simpl snd in H3. elim H0; eauto.
  - set (A:=/{z | z ∈ (AllSeq a) /\ (~ (IGT_N (fst z) n))/}).
    exists n`, (λ n p, RelNtoAllS A p n).
    red; repeat split; try red; intros.
    + destruct H2, H2, H2, H2, H2, H3, H3, H3, H3, H3.
      subst x y z; simpl in H6; subst x0; auto.
    + exists (x, (a x)); constructor; simpl; auto.
      constructor; split; try constructor; eauto.
      intro; destruct H2; simpl in H3.
      apply Theorem26 in H2; LEGN H2 H3.
    + destruct H2, H2, H2, H2; subst y; simpl in H3.
      exists x; constructor; simpl; auto.
      constructor; split; try constructor; eauto.
    + destruct H2,H2,H2, H2, H2; subst y; simpl in H3, H4; subst x.
      apply Theorem26'; red. destruct (Theorem10 x0 n); try tauto.
    + destruct H2, H2, H2, H2; auto.
    + destruct H2, H2; tauto.
Qed.

Section Extract_Seq.

Variable (N :Nat) (f :Relation Nat Nat) (l :∀ y, ∃ x, f y x).

Fixpoint Extract_Seq n :=
  match n with
  | 1 => N
  | m` => proj1_sig (Cid (l (Extract_Seq m)))
end.

End Extract_Seq.

Theorem SCT_fin : ∀ a,
  fin (SeqEns a) -> ∃ b, (SubSeq b a) /\ (∃ ξ, Limit b ξ).
Proof.
  intros; destruct (SL2 _ H) as [N H0].
  set (Extract_Seq0 := Extract_Seq N _ H0).
  exists (λ n, a (Extract_Seq0 n)); split.
  - red; exists Extract_Seq0; split; intros; auto.
    generalize dependent n; induction m; intros; [N1F H1|].
    rename H1 into H2. rename IHm into H1.
    apply Theorem26 in H2; destruct H2.
    + apply H1 in H2; eapply Theorem15; eauto.
      simpl; destruct (Cid (H0 (Extract_Seq0 m))), a0; simpl; auto.
    + subst m; simpl.
      destruct (Cid (H0 (Extract_Seq0 n))), a0; simpl; auto.
  - set (c := a N). assert (∀ m, a (Extract_Seq0 m) = c); intros.
    { rename m into p; destruct p; simpl; auto.
      destruct (Cid (H0 (Extract_Seq0 p))), a0; simpl; auto. }
    exists c; red; intros.
    exists 1; intros; rewrite H1; Simpl_R.
Qed.

Inductive Relsubseq N (a :Seq) x y :Prop :=
  | Relsubseq_in : ILT_N x N -> y = a x -> Relsubseq N a x y.

Lemma SL3 : ∀ {e a}, AccumulationPoint e (SeqEns a) ->
  ∀  n k, k > O -> ∃ m, IGT_N m n /\ (a m) ∈ (e|-k).
Proof.
  intros; Absurd; elim (Cor_acc _ _ H _ H0).
  assert (fin /{ z | ∃ m, ILE_N m n /\ z = a m /}).
  { exists n`, (Relsubseq n` a); red; intros;
    repeat split; try red; intros.
    - destruct H2, H3; rewrite H4; auto.
    - destruct H2; exists (a x); constructor; auto.
    - destruct H2, H2, H2; exists x; constructor; auto.
      apply Theorem26'; auto.
    - destruct H2; auto.
    - destruct H2; apply Theorem26 in H2; eauto. }
  eapply Fin_Included; eauto; red; intros. destruct H3, H3, H4, H4.
  constructor; exists x0; split; auto; red; subst x.
  destruct (Theorem10 x0 n) as [H4 | [H4 | H4]]; auto. elim H1; eauto.
Qed.

Lemma RNGO : ∀ {n :Nat}, (1/n) NoO_N > O.
Proof.
  intros; apply Theorem203_1' with (Θ:=n); Simpl_R; simpl; auto.
Qed.

Section Extract_Seq'.

Variable (N :Nat) (P :Nat -> ∀ y, y > O -> Nat -> Prop).
Variable l :∀ z y (l: y >O), ∃ x, P z y l x.

Fixpoint Extract_Seq' n :=
  match n with
  | 1 => N
  | m` => proj1_sig (Cid (l (Extract_Seq' m) ((1/n) NoO_N) RNGO))
end.

End Extract_Seq'.

Theorem SCT_infin : ∀ a x y, x < y -> ~ fin (SeqEns a) ->
  Bounddown_Seq x a -> Boundup_Seq y a ->
  ∃ b, (SubSeq b a) /\ (∃ ξ, Limit b ξ).
Proof.
  intros. apply BoundSeqEns in H1. apply BoundSeqEns in H2.
  destruct (APT _ _ _ H H0 H1 H2) as [e H3].
  destruct H3 with 1; simpl; auto. destruct H4, H5, H5, H5 as [N H5].
  pose proof (SL3 H3). set (Extract_Seq0' := Extract_Seq' N _ H7).
  exists (λ n, a (Extract_Seq0' n)); split.
  - red; exists Extract_Seq0'; split; intros; auto.
    generalize dependent n; induction m; intros; [N1F H8|].
    rename H8 into H9. rename IHm into H8.
    apply Theorem26 in H9; destruct H9.
    + apply H8 in H9; eapply Theorem15; eauto.
      replace (Extract_Seq0' m`) with (proj1_sig
        (Cid (H7 (Extract_Seq0' m) ((1/m`) NoO_N) RNGO))); auto.
      destruct Cid. simpl; tauto.
    + subst n. replace (Extract_Seq0' m`) with (proj1_sig
        (Cid (H7 (Extract_Seq0' m) ((1/m`) NoO_N) RNGO))); auto.
      destruct Cid. simpl; tauto.
  - assert (∀ n, (a (Extract_Seq0' n)) ∈ (e|-((1/n) NoO_N))).
    { intros; destruct n; Simpl_R.
      - simpl; constructor; Simpl_R; subst x0.
        destruct H4; auto.
      - replace (Extract_Seq0' n`) with (proj1_sig
          (Cid (H7 (Extract_Seq0' n) ((1/n`) NoO_N) RNGO))); auto.
        destruct Cid. simpl; tauto. }
    exists e; red; intros.
    assert (neq_zero ε). { destruct ε; simpl; auto. }
    destruct (Archimedes ((1/ε) H10)) as [M H11]. exists M; intros.
    apply OrderNRlt in H12. eapply Theorem171 in H12; eauto.
    destruct H8 with n;  apply Ab1'' in H13. eapply Theorem171; eauto.
    apply Theorem203_1 with (Θ:=ε) in H12; Simpl_Rin H12.
    rewrite Theorem194 in H12.
    apply Theorem203_1' with (Θ:=n); Simpl_R; simpl; auto.
Qed.

Theorem SCT : ∀ a x y, x < y -> Bounddown_Seq x a ->
  Boundup_Seq y a -> ∃ b, (SubSeq b a) /\ (∃ ξ, Limit b ξ).
Proof.
  intros; destruct (classic (fin (SeqEns a))).
  - apply SCT_fin; auto.
  - eapply SCT_infin; eauto.
Qed.


(** SimpleSepTheory.v
 **
 ** A simple implementation of a separation theory based on functional
 ** extensionality.
 **)
Require Import Coq.Classes.RelationClasses.
Require Import MirrorShard.SepTheory.

Set Implicit Arguments.
Set Strict Implicit.

Module SimpleSepLog_Kernel <: SepTheory_Kernel.
  Require Import FunctionalExtensionality.

  Definition heap := nat -> option nat.

  Definition hprop := heap -> Prop.

  Definition himp (l r : hprop) : Prop :=
    forall h, l h -> r h.

  Global Instance Refl_himp : Reflexive himp.
  Proof. repeat red; intuition. Qed.

  Global Instance Trans_himp : Transitive himp.
  Proof. repeat red; intuition. Qed.

  Definition inj (p : Prop) : hprop := fun m => p /\ forall p, m p = None.

  Definition emp : hprop := inj True.

  Definition split (h hl hr : heap) : Prop :=
    forall p, (hl p = None \/ hr p = None) /\
      h p = match hl p with
              | None => hr p
              | Some x => Some x
            end.

  Definition star (l r : hprop) : hprop :=
    fun h =>
      exists h1 h2, split h h1 h2 /\
        l h1 /\ r h2.

  Definition ex (T : Type) (p : T -> hprop) : hprop :=
    fun h => exists x, p x h.

  Ltac doIt :=
    unfold himp, star, emp, split, ex, inj; intros;
    repeat match goal with
             | [ H : exists x, _ |- _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H
           end.

  Theorem himp_star_comm : forall P Q : hprop, himp (star P Q) (star Q P).
  Proof.
    doIt. do 2 eexists; doIt. split. 2: eauto.
    intro. specialize (H p). intuition; rewrite H in *.
    destruct (x0 p); auto.
    destruct (x p); auto.
  Qed.

  Theorem himp_star_assoc :
    forall P Q R : hprop, himp (star (star P Q) R) (star P (star Q R)).
  Proof.
    doIt; intuition; doIt.
    exists x1. exists (fun p => match x2 p with
                                  | None => x0 p
                                  | Some x => Some x
                                end); intuition.
    specialize (H p); specialize (H0 p); intuition; doIt.
    rewrite H0 in *. rewrite H4 in *. destruct (x1 p); eauto.
    rewrite H0 in *; rewrite H4 in *. auto.
    specialize (H p); specialize (H0 p); intuition;
    rewrite H0 in *; rewrite H4 in *; eauto.
    rewrite <- H6 in *; auto.
    destruct (x1 p); auto; congruence.
    rewrite H6 in *; auto.
    destruct (x1 p); auto. destruct (x p); eauto; try congruence.
    rewrite H6 in *; auto.

    exists x2. exists x0. intuition.
    specialize (H p); specialize (H0 p); intuition; doIt.
    rewrite H0 in *; rewrite H4 in *; auto.
  Qed.

  Theorem himp_star_emp_p : forall P : hprop, himp (star emp P) P.
  Proof.
    doIt.
    cutrewrite (h = x0); auto.

    eapply functional_extensionality; intros.
    specialize (H x1). specialize (H2 x1). rewrite H2 in *. intuition.
  Qed.

  Theorem himp_star_emp_c : forall P : hprop, himp P (star emp P).
  Proof.
    doIt. exists (fun _ => None). exists h. intuition.
  Qed.

  Theorem himp_star_frame : forall P Q R S,
    himp P Q -> himp R S -> himp (star P R) (star Q S).
  Proof.
    doIt. exists x; exists x0. intuition.
  Qed.

  Theorem himp_star_pure_p :
    forall (P Q : hprop) (F : Prop),
      himp (star (inj F) P) Q -> F -> himp P Q.
  Proof.
    doIt. eapply H. exists (fun _ => None). exists h.
    intuition.
  Qed.

  Theorem himp_star_pure_c :
    forall (P Q : hprop) (F : Prop),
      (F -> himp P Q) -> himp (star (inj F) P) Q.
  Proof.
    doIt. eapply H; auto.
    cutrewrite (h = x0); auto.
    eapply functional_extensionality; intros.
    specialize (H3 x1). specialize (H0 x1).
    rewrite H3 in *. intuition.
  Qed.

  Theorem himp_star_pure_cc :
    forall (P Q : hprop) (p : Prop),
      p -> himp P Q -> himp P (star (inj p) Q).
  Proof.
    doIt. eapply H0 in H1; clear H0.
    exists (fun _ => None). exists h.
    intuition.
  Qed.

  Theorem himp_ex_p :
    forall (T : Type) (P : T -> hprop) (Q : hprop),
      (forall v : T, himp (P v) Q) -> himp (ex P) Q.
  Proof.
    doIt. eauto.
  Qed.

  Theorem himp_ex_c :
    forall (T : Type) (P : T -> hprop) (Q : hprop),
      (exists v : T, himp Q (P v)) -> himp Q (ex P).
  Proof.
    doIt; eauto.
  Qed.

  Theorem himp_ex_star : forall T (P : T -> _) Q,
    himp (star (ex P) Q) (ex (fun x => star (P x) Q)).
  Proof.
    doIt. exists x1. exists x. exists x0. intuition.
  Qed.

  Theorem himp_star_ex : forall T (P : T -> _) Q,
    himp (ex (fun x => star (P x) Q)) (star (ex P) Q).
  Proof.
    doIt. exists x0; exists x1. intuition eauto.
  Qed.

End SimpleSepLog_Kernel.

Module SimpleSepLog := SepTheory_From_Kernel SimpleSepLog_Kernel.


Set Warnings "-notation-overridden, -parsing".
From Coq Require Import Strings.String.
Add LoadPath "/Users/jikl/demos/coq/software-foundation-exercise/logic_foundation" as LF.
From LF Require Import Maps.
From PLF Require Import SmallStep.

Module STLC.

  Inductive ty : Type :=
  | Bool : ty
  | Arrow : ty -> ty -> ty.

  Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm.

  Open Scope string_scope.

  Definition x := "x".
  Definition y := "y".
  Definition z := "z".

  Hint Unfold x : db.
  Hint Unfold y : db.
  Hint Unfold z : db.

  (* idB = \x.Bool.x *)
  Notation idB := (abs x Bool (var x)).

  (* idBB = \x:Bool -> Bool.x *)
  Notation idBB := (abs x (Arrow Bool Bool) (var x)).

  (* idBBBB = \x:(Bool -> Bool) -> (Bool -> Bool).x *)
  Notation idBBBB :=
    (abs x (Arrow (Arrow Bool Bool)
                  (Arrow Bool Bool))
         (var x)).

  (* k = \x:Bool.\y:bool.x *)
  Notation k := (abs x Bool (abs y Bool (var x))).

  (* notB = \x:Bool.test x then fls else tru *)
  Notation notB := (abs x Bool (test (var x) fls tru)).

  Inductive value : tm -> Prop :=
  | v_abs : forall x T t, value (abs x T t)
  | v_tru : value tru
  | v_fls : value fls.

  Hint Constructors value : db.

  Reserved Notation "'[' x ':=' s ']' t" (at level 20).

  Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
    match t with
    | var x' =>
      if eqb_string x x' then s else t
    | abs x' T t1 =>
      abs x' T (if eqb_string x x' then t1 else ([x:=s] t1))
    | app t1 t2 =>
      app ([x:=s] t1) ([x:=s] t2)
    | tru => tru
    | fls => fls
    | test t1 t2 t3 =>
      test ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
    end
  where "'[' x ':=' s ']' t" := (subst x s t).

  Inductive substi (s : tm) (x : string) : tm -> tm -> Prop :=
  | s_var1 : substi s x (var x) s
  | s_var2 (x' : string) :
      x <> x' -> substi s x (var x') (var x')
  | s_abs1 (x' : string) (T : ty) (t : tm):
      eqb_string x x' = true ->
      substi s x (abs x' T t) (abs x' T t)
  | s_abs2 (x' : string) (T : ty) (t : tm) (t' : tm):
      eqb_string x x' = false ->
      substi s x t t' ->
      substi s x (abs x' T t) (abs x' T t')
  | s_app (t1 t1' t2 t2': tm) :
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x (app t1 t2) (app t1' t2')
  | s_tru :
      substi s x tru tru
  | s_fls :
      substi s x fls fls
  | s_test (t1 t1' t2 t2' t3 t3' : tm) :
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x t3 t3' ->
      substi s x (test t1 t2 t3) (test t1' t2' t3')
  .

  Hint Constructors substi : db.

  Theorem substi_correct : forall s x t t',
      [x:=s]t = t' <-> substi s x t t'.
  Proof.
    split; generalize dependent t'.
    - induction t; intros t' H; simpl in H.
      + destruct (eqb_string x0 s0) eqn: E.
        * subst. apply eqb_string_true_iff in E. subst. apply s_var1.
        * subst. apply s_var2. apply eqb_string_false_iff. apply E.
      + rewrite <- H. apply s_app.
        * apply IHt1. reflexivity.
        * apply IHt2. reflexivity.
      + destruct (eqb_string x0 s0) eqn:E.
        * rewrite <- H. apply s_abs1. apply E.
        * rewrite <- H. apply s_abs2.
          apply E.
          apply IHt. reflexivity.
      + rewrite <- H. apply s_tru.
      + rewrite <- H. apply s_fls.
      + rewrite <- H. apply s_test.
        * apply IHt1. reflexivity.
        * apply IHt2. reflexivity.
        * apply IHt3. reflexivity.
    - intros t' H. induction H; simpl.
      + rewrite <- eqb_string_refl. reflexivity.
      + rewrite <- eqb_string_false_iff in H. rewrite H.
        reflexivity.
      + rewrite H. reflexivity.
      + rewrite H. rewrite IHsubsti. reflexivity.
      + rewrite IHsubsti1, IHsubsti2. reflexivity.
      + reflexivity.
      + reflexivity.
      + rewrite IHsubsti1, IHsubsti2, IHsubsti3. reflexivity.
  Qed.

  Reserved Notation "t1 '-->' t2" (at level 40).

  Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
      value v2 ->
      (app (abs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
      t1 --> t1' ->
      app t1 t2 --> app t1' t2
  | ST_App2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      app v1 t2 --> app v1 t2'
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)
  where "t1 '-->' t2" := (step t1 t2).

  Hint Constructors step : db.

  Notation multistep := (multi step).
  Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

  (* idBB idB -->* idB *)
  Lemma step_example1 :
    (app idBB idB) -->* idB.
  Proof.
    eapply multi_step.
    - apply ST_AppAbs. apply v_abs.
    - simpl. apply multi_refl.
  Qed.

  (* (idBB (idBB idB)) -->* idB *)
  Lemma step_example2 :
    (app idBB (app idBB idB)) -->* idB.
  Proof.
    eapply multi_step.
    - apply ST_App2. apply v_abs. apply ST_AppAbs. apply v_abs.
    - simpl. apply step_example1.
  Qed.

  (* (idBB notB) tru -->* fls. *)
  Lemma step_example3 :
    app (app idBB notB) tru -->* fls.
  Proof.
    eapply multi_step.
    - apply ST_App1. apply ST_AppAbs. apply v_abs.
    - simpl. eapply multi_step.
      + apply ST_AppAbs. apply v_tru.
      + simpl. eapply multi_step.
        * apply ST_TestTru.
        * apply multi_refl.
  Qed.

  (* idBB (notB tru) -->* fls *)
  Lemma step_example4 :
    app idBB (app notB tru) -->* fls.
  Proof.
    eapply multi_step.
    - apply ST_App2.
      + apply v_abs.
      + apply ST_AppAbs. apply v_tru.
    - eapply multi_step.
      + simpl. apply ST_App2.
        * apply v_abs.
        * apply ST_TestTru.
      + eapply multi_step.
        * apply ST_AppAbs. apply v_fls.
        * simpl. apply multi_refl.
  Qed.

  Lemma step_example1' :
    app idBB idB -->* idB.
  Proof. normalize. Qed.
  Lemma step_example2' :
    app idBB (app idBB idB) -->* idB.
  Proof. normalize. Qed.
  Lemma step_example3' :
    app (app idBB notB) tru -->* fls.
  Proof. normalize. Qed.
  Lemma step_example4' :
    app idBB (app notB tru) -->* fls.
  Proof. normalize. Qed.

  Lemma step_example5 :
       app (app idBBBB idBB) idB
           -->* idB.
  Proof.
    eapply multi_step.
    - apply ST_App1. apply ST_AppAbs. apply v_abs.
    - simpl. eapply multi_step.
      + apply ST_AppAbs. apply v_abs.
      + simpl. apply multi_refl.
  Qed.

  Lemma step_example5_with_normalize :
    app (app idBBBB idBB) idB
        -->* idB.
  Proof. normalize. Qed.

  Definition context := partial_map ty.

  Reserved Notation "Gamma '|-' t '?' T" (at level 40).

  Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- var x ? T
  | T_Abs : forall Gamma x T11 T12 t12,
      (x |-> T11; Gamma) |- t12 ? T12 ->
      Gamma |- abs x T11 t12 ? Arrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 ? Arrow T11 T12 ->
      Gamma |- t2 ? T11 ->
      Gamma |- app t1 t2 ? T12
  | T_Tru : forall Gamma,
      Gamma |- tru ? Bool
  | T_Fls : forall Gamma,
      Gamma |- fls ? Bool
  | T_Test : forall t1 t2 t3 T Gamma,
      Gamma |- t1 ? Bool ->
      Gamma |- t2 ? T ->
      Gamma |- t3 ? T ->
      Gamma |- test t1 t2 t3 ? T
  where "Gamma '|-' t '?' T" := (has_type Gamma t T).

  Hint Constructors has_type : db.

  Example typing_example1 :
    empty |- abs x Bool (var x) ? Arrow Bool Bool.
  Proof.
    apply T_Abs. apply T_Var. rewrite update_eq. reflexivity.
  Qed.

  Example typing_example_1' :
    empty |- abs x Bool (var x) ? Arrow Bool Bool.
  Proof. auto with db. Qed.

  Example typing_example_2 :
    empty |-
      (abs x Bool
         (abs y (Arrow Bool Bool)
            (app (var y) (app (var y) (var x))))) ?
      (Arrow Bool (Arrow (Arrow Bool Bool) Bool)).
  Proof.
    apply T_Abs.
    apply T_Abs.
    eapply T_App.
    - apply T_Var. rewrite update_eq. reflexivity.
    - eapply T_App.
      + apply T_Var. rewrite update_eq. reflexivity.
      + apply T_Var. rewrite update_neq.
        * rewrite update_eq. reflexivity.
        * intro H. inversion H.
  Qed.

  Example typing_example_2_full :
    empty |-
      (abs x Bool
         (abs y (Arrow Bool Bool)
            (app (var y) (app (var y) (var x))))) ?
      (Arrow Bool (Arrow (Arrow Bool Bool) Bool)).
  Proof.
    apply T_Abs.
    apply T_Abs.
    apply (T_App Bool).
    - apply T_Var. rewrite update_eq. reflexivity.
    - apply T_App with Bool.
      + apply T_Var. rewrite update_eq. reflexivity.
      + apply T_Var. rewrite update_neq.
        * rewrite update_eq. reflexivity.
        * intro H. inversion H.
  Qed.

  Example typing_example_3 :
    exists T,
      empty |-
        (abs x (Arrow Bool Bool)
           (abs y (Arrow Bool Bool)
              (abs z Bool
                 (app (var y) (app (var x) (var z)))))) ? T.
  Proof.
    eapply ex_intro.
    apply T_Abs.
    apply T_Abs.
    apply T_Abs.
    eapply T_App.
    - apply T_Var. rewrite update_neq.
      + rewrite update_eq. reflexivity.
      + intro Hzy. inversion Hzy.
    - eapply T_App.
      + apply T_Var. rewrite update_neq.
        * rewrite update_neq.
            rewrite update_eq. reflexivity.
            intro Hyx. inversion Hyx.
        * intro Hzx. inversion Hzx.
      + apply T_Var. rewrite update_eq. reflexivity.
  Qed.

  Example typing_nonexample_1 :
    ~ exists T,
        empty |-
          (abs x Bool
             (abs y Bool
                (app (var x) (var y)))) ? T.
  Proof.
    intros Hc. inversion Hc.
    inversion H. subst. clear H.
    inversion H5. subst. clear H5.
    inversion H4. subst. clear H4.
    inversion H2. subst. clear H2.
    inversion H5. subst. clear H5.
    inversion H1.
  Qed.

  Fixpoint ty_length (t : ty) :=
    match t with
    | Bool => 1
    | Arrow t1 t2 => 1 + ty_length t1 + ty_length t2
    end.

  Example typing_nonexample_3:
    ~(exists S T,
         empty |-
           (abs x S
              (app (var x) (var x))) ? T).
  Proof.
    intro Hc. inversion Hc.
    inversion H. clear H.
    inversion H0. subst. clear H0.
    inversion H5. subst. clear H5.
    inversion H2. subst. clear H2.
    inversion H1.
    inversion H4. subst. clear H4.
    inversion H3.
    assert (Heq : ty_length (Arrow T11 T12) = ty_length T11).
    { rewrite H0. reflexivity. }
    inversion Heq.
    apply eq_sym in H2.
    rewrite PeanoNat.Nat.add_comm in H2.
    generalize H2. apply Plus.succ_plus_discr.
  Qed.

End STLC.


Set Asymmetric Patterns.

(* define nonnegative dyadic rationals *)
Inductive dyadic_rational : Type :=
  | m_over_2_to_n: forall m n:nat, dyadic_rational.
Inductive dr_eq : dyadic_rational -> dyadic_rational -> Prop :=
  | dr_eq_refl: forall x:dyadic_rational, dr_eq x x
  | dr_eq_sym: forall x y:dyadic_rational, dr_eq x y -> dr_eq y x
  | dr_eq_trans: forall x y z:dyadic_rational,
    dr_eq x y -> dr_eq y z -> dr_eq x z
  | dr_eq_scale: forall (m n:nat),
    dr_eq (m_over_2_to_n m n)
          (m_over_2_to_n (2*m) (S n)).
Inductive dr_lt : dyadic_rational -> dyadic_rational -> Prop :=
  | intro_dr_lt: forall m m' n:nat, m < m' ->
    dr_lt (m_over_2_to_n m n) (m_over_2_to_n m' n)
  | dr_lt_wd: forall x x' y y':dyadic_rational,
    dr_lt x y -> dr_eq x x' -> dr_eq y y' -> dr_lt x' y'.

Lemma dr_incr_denom: forall (m n n':nat), n<=n' ->
  exists m':nat, dr_eq (m_over_2_to_n m' n')
                       (m_over_2_to_n m n).
Proof.
induction 1.
exists m.
apply dr_eq_refl.
destruct IHle as [m'].
exists (2*m').
apply dr_eq_trans with (m_over_2_to_n m' m0); trivial.
apply dr_eq_sym.
apply dr_eq_scale.
Qed.

Lemma dr_total_order: forall x y:dyadic_rational,
  dr_lt x y \/ dr_eq x y \/ dr_lt y x.
Proof.
intros.
destruct x as [m n].
destruct y as [m' n'].
Require Import Arith.
destruct (le_or_lt n n').
destruct (dr_incr_denom m n n') as [m0]; trivial.
destruct (le_or_lt m0 m').
destruct (le_lt_or_eq _ _ H1).
left.
apply dr_lt_wd with
  (m_over_2_to_n m0 n') (m_over_2_to_n m' n'); trivial.
apply intro_dr_lt; trivial.
apply dr_eq_refl.
right; left.
apply dr_eq_trans with (m_over_2_to_n m0 n').
apply dr_eq_sym; trivial.
rewrite H2; apply dr_eq_refl.
right; right.
apply dr_lt_wd with
  (m_over_2_to_n m' n') (m_over_2_to_n m0 n'); trivial.
apply intro_dr_lt; trivial.
apply dr_eq_refl.

assert (n' <= n) by auto with arith.
destruct (dr_incr_denom m' n' n) as [m0]; trivial.
destruct (le_or_lt m m0).
destruct (le_lt_or_eq _ _ H2).
left.
apply dr_lt_wd with
  (m_over_2_to_n m n) (m_over_2_to_n m0 n).
apply intro_dr_lt; trivial.
apply dr_eq_refl.
trivial.
right; left.
apply dr_eq_trans with (m_over_2_to_n m0 n); trivial.
rewrite H3; apply dr_eq_refl.
right; right.
apply dr_lt_wd with
  (m_over_2_to_n m0 n) (m_over_2_to_n m n); trivial.
apply intro_dr_lt; trivial.
apply dr_eq_refl.
Qed.

Require Export QArith.
Local Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.

Fixpoint pos_power2 (n:nat) : positive := match n with
  | O => 1%positive
  | S m => ((pos_power2 m)~0)%positive
end.

Definition dr2Q (x:dyadic_rational) : Q :=
  match x with
  | m_over_2_to_n m n => (Z_of_nat m) # (pos_power2 n)
  end.

Lemma dr2Q_wd: forall x y:dyadic_rational,
  dr_eq x y -> dr2Q x == dr2Q y.
Proof.
intros.
induction H.
auto with qarith.
auto with qarith.
transitivity (dr2Q y); trivial.
simpl.
unfold Qeq.
simpl.
replace ((' (pos_power2 n)~0)%Z) with
  ((2 * ' pos_power2 n)%Z) by trivial.
repeat rewrite inj_plus.
simpl Z_of_nat.
ring.
Qed.

Lemma dr2Q_incr: forall x y:dyadic_rational,
  dr_lt x y -> dr2Q x < dr2Q y.
Proof.
induction 1.
unfold dr2Q.
unfold Qlt.
simpl.
apply Zmult_lt_compat_r.
now unfold Zlt.
auto with zarith.

rewrite <- (dr2Q_wd _ _ H0).
rewrite <- (dr2Q_wd _ _ H1).
trivial.
Qed.

Lemma Qlt_dr_lt: forall x y:dyadic_rational,
  (dr2Q x < dr2Q y)%Q -> dr_lt x y.
Proof.
intros.
destruct (dr_total_order x y) as [|[|]]; trivial.
apply dr2Q_wd in H0.
contradict H0.
auto with qarith.
apply dr2Q_incr in H0.
contradict H0.
auto with qarith.
Qed.

Require Export Qreals.
Open Scope R_scope.
Lemma dyadic_rationals_dense_in_reals: forall x y:R,
  0 <= x < y -> exists q:dyadic_rational,
  x < Q2R (dr2Q q) < y.
Proof.
intros.
assert (forall m:Z, exists n:nat, ((m < ' pos_power2 n)%Z)).
intros.
case m; intros.
exists O.
unfold Zlt; trivial.
induction p.
destruct IHp as [n].
exists (S n).
unfold Zlt.
simpl. rewrite Pos.compare_xI_xO.
unfold Zlt in H0.
simpl in H0.
now rewrite H0.
destruct IHp as [n].
exists (S n).
unfold Zlt; simpl.
unfold Zlt in H0; simpl in H0.
trivial.
exists (1%nat).
unfold Zlt; trivial.
exists O.
unfold Zlt; trivial.

destruct (H0 (up (1/(y-x)))) as [n].
Require Import RationalsInReals.
destruct (rational_interpolation x y (pos_power2 n)) as [m].
apply H.
apply Rlt_trans with (IZR (up (1/(y-x)))).
apply archimed.
apply IZR_lt; trivial.

destruct m as [|m|].
unfold Q2R in H2.
simpl in H2.
replace (0 * _) with 0 in H2 by ring.
destruct H; destruct H2.
contradict H.
auto with real.

exists (m_over_2_to_n (nat_of_P m) n).
unfold dr2Q.
rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P.
trivial.

assert (x < 0).
apply Rlt_trans with (Q2R (Zneg p # pos_power2 n)).
apply H2.
replace 0 with (Q2R 0).
apply Qlt_Rlt.
auto with *.
unfold Q2R; simpl; ring.
destruct H.
contradict H.
auto with real.
Qed.

Section Urysohns_Lemma_construction.

Require Export TopologicalSpaces.
Require Export InteriorsClosures.

Variable X:TopologicalSpace.
Variable normal_sep_fun: forall F U:Ensemble (point_set X),
  closed F -> open U -> Included F U ->
  { V:Ensemble (point_set X) | open V /\ Included F V /\
    Included (closure V) U }.
Variable U0 U1:Ensemble (point_set X).
Hypothesis U0_open: open U0.
Hypothesis U1_open: open U1.
Hypothesis U0_in_U1: Included (closure U0) U1.

Definition Un (n:nat) : Ensemble (point_set X) :=
  match n with
  | O => U0
  | S O => U1
  | S (S _) => Full_set
  end.

Lemma Un_open: forall n:nat, open (Un n).
Proof.
destruct n as [|[|]]; trivial.
simpl.
apply open_full.
Qed.

Lemma Un_incr: forall n:nat, Included (closure (Un n))
                                    (Un (S n)).
Proof.
destruct n as [|].
simpl.
trivial.
simpl.
red; intros; constructor.
Qed.

Require Import Div2.
Require Import Even.
Definition expand_U_dyadic (f:nat->Ensemble (point_set X))
  (Hopen: forall n:nat, open (f n))
  (Hincr: forall n:nat, Included (closure (f n)) (f (S n)))
  (n:nat) : Ensemble (point_set X) :=
if (even_odd_dec n) then f (div2 n) else
let m := div2 n in proj1_sig
  (normal_sep_fun (closure (f m)) (f (S m))
     (closure_closed _) (Hopen _) (Hincr _)).

Lemma expand_U_dyadic_open: forall f Hopen Hincr n,
  open (expand_U_dyadic f Hopen Hincr n).
Proof.
intros.
unfold expand_U_dyadic.
destruct even_odd_dec.
apply Hopen.
destruct normal_sep_fun.
simpl.
apply a.
Qed.

Lemma expand_U_dyadic_incr: forall f Hopen Hincr n,
  Included (closure (expand_U_dyadic f Hopen Hincr n))
     (expand_U_dyadic f Hopen Hincr (S n)).
Proof.
intros.
unfold expand_U_dyadic.
simpl.
destruct even_odd_dec.
destruct normal_sep_fun.
simpl.
destruct n.
simpl.
apply a.
rewrite <- odd_div2.
apply a.
now inversion e.

simpl.
destruct normal_sep_fun.
simpl.
destruct o.
rewrite even_div2.
now apply a.
trivial.
Qed.

Definition packaged_expand_U_dyadic :
  { f:nat->Ensemble (point_set X) |
    (forall m:nat, open (f m)) /\
    (forall m:nat, Included (closure (f m)) (f (S m))) } ->
  { f:nat->Ensemble (point_set X) |
    (forall m:nat, open (f m)) /\
    (forall m:nat, Included (closure (f m)) (f (S m))) }.
refine (fun fsig => match fsig with
  | exist f (conj Hopen Hincr as a) => exist _ (expand_U_dyadic f Hopen Hincr) _
  end).
destruct a.
split.
apply expand_U_dyadic_open.
apply expand_U_dyadic_incr.
Defined.

Definition U_dyadic_level_n (n:nat) :
  { f:nat->Ensemble (point_set X) |
    (forall m:nat, open (f m)) /\
    (forall m:nat, Included (closure (f m)) (f (S m))) }.
refine (let lev_n := fix lev_n (n:nat) :
  { f:nat->Ensemble (point_set X) |
    (forall m:nat, open (f m)) /\
    (forall m:nat, Included (closure (f m)) (f (S m))) } :=
  match n with
  | O => exist _ Un _
  | S n' => packaged_expand_U_dyadic (lev_n n')
  end in lev_n n).
split.
apply Un_open.
apply Un_incr.
Defined.

Definition U_dyadic (x:dyadic_rational) :
  Ensemble (point_set X) :=
match x with
| m_over_2_to_n m n => (proj1_sig (U_dyadic_level_n n)) m
end.

Lemma U_dyadic_wd: forall x y:dyadic_rational, dr_eq x y ->
  U_dyadic x = U_dyadic y.
Proof.
intros.
induction H.
trivial.
auto.
transitivity (U_dyadic y); trivial.
simpl.
unfold packaged_expand_U_dyadic.
destruct U_dyadic_level_n.
destruct a.
simpl.
unfold expand_U_dyadic.
replace ((m + (m + 0))%nat) with ((2*m)%nat) by reflexivity.
rewrite div2_double.
assert (forall m:nat, even (2*m)).
induction m0.
constructor.
Require Import Arith.
replace ((2 * S m0)%nat) with ((S (S (2 * m0)))%nat) by ring.
constructor; constructor; trivial.
destruct even_odd_dec.
trivial.
contradiction not_even_and_odd with ((2 * m)%nat).
apply H.
Qed.

Lemma U_dyadic_open: forall x:dyadic_rational,
  open (U_dyadic x).
Proof.
intro.
destruct x.
unfold U_dyadic.
destruct U_dyadic_level_n.
simpl.
apply a.
Qed.

Lemma U_dyadic_incr: forall x y:dyadic_rational, dr_lt x y ->
  Included (closure (U_dyadic x)) (U_dyadic y).
Proof.
intros.
induction H.
induction H.
unfold U_dyadic.
destruct U_dyadic_level_n.
simpl.
apply a.
cut (Included (closure (U_dyadic (m_over_2_to_n m0 n)))
   (U_dyadic (m_over_2_to_n (S m0) n))).
intro.
pose proof (closure_inflationary
  (U_dyadic (m_over_2_to_n m0 n))).
auto with sets.
unfold U_dyadic.
destruct U_dyadic_level_n.
simpl.
apply a.

rewrite <- (U_dyadic_wd _ _ H0).
rewrite <- (U_dyadic_wd _ _ H1).
trivial.
Qed.

Require Export RTopology.
Definition Urysohns_Lemma_function : point_set X -> point_set RTop.
refine (fun x:point_set X => proj1_sig (inf
 (Add
  (Im [ alpha:dyadic_rational | In (U_dyadic alpha) x ]
      (fun alpha:dyadic_rational => Q2R (dr2Q alpha)))
  1)
  _ _)).
exists 0.
red; intros.
destruct H.
destruct H.
destruct x0.
simpl in H0.
rewrite H0.
replace 0 with (Q2R 0).
cut (Q2R 0 <= Q2R (Z_of_nat m # pos_power2 n)); auto with real.
apply Qle_Rle.
unfold Qle.
simpl.
auto with zarith.
unfold Q2R.
simpl.
ring.
destruct H.
left.
red.
auto with real.

exists 1.
right.
constructor.
Defined.

Lemma Urysohns_Lemma_function_range:
  forall x:point_set X, 0 <= Urysohns_Lemma_function x <= 1.
Proof.
intros.
unfold Urysohns_Lemma_function; destruct inf as [y].
simpl.
split.
apply i.
red; intros.
destruct H.
destruct H.
rewrite H0.
replace 0 with (Q2R 0).
cut (Q2R 0 <= Q2R (dr2Q x0)); auto with real.
apply Qle_Rle.
destruct x0.
unfold dr2Q.
unfold Qle.
simpl.
auto with zarith.
unfold Q2R.
simpl.
ring.
destruct H.
left.
red; auto with real.
cut (1 >= y); auto with real.
apply i.
right; constructor.
Qed.

Lemma Urysohns_Lemma_function_0: forall x:point_set X,
  In U0 x -> Urysohns_Lemma_function x = 0.
Proof.
intros.
apply Rle_antisym.
unfold Urysohns_Lemma_function; destruct inf as [y].
simpl.
cut (0 >= y); auto with real.
apply i.
left.
exists (m_over_2_to_n 0 0).
constructor.
simpl.
trivial.
simpl.
unfold Q2R.
simpl.
ring.
apply Urysohns_Lemma_function_range.
Qed.

Lemma Urysohns_Lemma_function_1: forall x:point_set X,
  ~ In U1 x -> Urysohns_Lemma_function x = 1.
Proof.
intros.
apply Rle_antisym.
apply Urysohns_Lemma_function_range.
unfold Urysohns_Lemma_function; destruct inf as [y].
simpl.
apply i.
red; intros.
destruct H0.
destruct H0.
destruct x0.
destruct H0.
assert (~ (m < (nat_of_P (pos_power2 n)))%nat).
intro.
assert (forall n:nat, dr_eq
  (m_over_2_to_n (nat_of_P (pos_power2 n)) n)
  (m_over_2_to_n 1 0)).
induction n0.
simpl.
unfold nat_of_P.
simpl.
apply dr_eq_refl.
apply dr_eq_trans with (2:=IHn0).
apply dr_eq_sym.
replace (nat_of_P (pos_power2 (S n0))) with
  ((2 * nat_of_P (pos_power2 n0))%nat).
apply dr_eq_scale.
simpl pos_power2.
symmetry. apply Pos2Nat.inj_xO.
assert (dr_lt (m_over_2_to_n m n) (m_over_2_to_n 1 0)).
apply dr_lt_wd with (m_over_2_to_n m n)
  (m_over_2_to_n (nat_of_P (pos_power2 n)) n).
apply intro_dr_lt.
exact H2.
apply dr_eq_refl.
apply H3.
pose proof (U_dyadic_incr _ _ H4).
simpl (U_dyadic (m_over_2_to_n 1 0)) in H5.
assert (Included (U_dyadic (m_over_2_to_n m n)) U1).
red; intros.
apply H5.
apply closure_inflationary; trivial.
contradiction H.
apply H6.
trivial.
assert ((m >= nat_of_P (pos_power2 n))%nat).
auto with *.
red in H3.
assert ((nat_of_P (pos_power2 n) < m \/
        (nat_of_P (pos_power2 n) = m))%nat).
apply le_lt_or_eq; trivial.
rewrite H1.
replace 1 with (Q2R (dr2Q (m_over_2_to_n 1 0))).
match goal with |- ?a >= ?b =>
  cut (b <= a); auto with real end.
apply Qle_Rle.
unfold dr2Q.
unfold Qle.
simpl.
ring_simplify.
rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
auto with *.
simpl.
unfold Q2R.
simpl.
field.
destruct H0.
right; trivial.
Qed.

Lemma Urysohns_Lemma_function_continuous:
  continuous Urysohns_Lemma_function.
Proof.
apply continuous_subbasis with (order_topology_subbasis _ Rle).
apply Build_TopologicalSpace_from_subbasis_subbasis.
intros.
destruct H.

(* proving that inverse image of lower open interval is open *)
destruct (classic (x>1)).

(* if x>1, inverse image is everything *)
match goal with |- open ?U => assert (U = Full_set) end.
apply Extensionality_Ensembles; split; red; intros.
constructor.
constructor.
constructor.
cut (Urysohns_Lemma_function x0 < x); auto with real.
apply Rle_lt_trans with 1; trivial.
apply Urysohns_Lemma_function_range.
rewrite H0; apply open_full.

(* if x<=1, inverse image is union of U_alpha for alpha < x *)
assert (x<=1) by (apply Rnot_gt_le; trivial).
match goal with |- open ?U => assert (U =
  IndexedUnion (fun alpha:{alpha:dyadic_rational |
                           Q2R (dr2Q alpha) < x} =>
                U_dyadic (proj1_sig alpha))) end.
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
destruct H1.
assert (Urysohns_Lemma_function x0 < x).
destruct H1.
destruct (Rdichotomy _ _ H2); trivial.
contradict H3.
auto with real.
clear H1.
remember (Urysohns_Lemma_function x0) as y.
unfold Urysohns_Lemma_function in Heqy.
destruct inf in Heqy; simpl in Heqy.
destruct Heqy.
destruct (glb_approx _ _ (x-y) i).
apply Rgt_minus; trivial.
destruct H1.
destruct H1.
destruct H1 as [alpha].
destruct H1.
destruct H3.
ring_simplify in H5.
rewrite H4 in H5.
exists (exist (fun beta:dyadic_rational => Q2R (dr2Q beta) < x)
  alpha H5).
trivial.
destruct H1.
destruct H3.
ring_simplify in H3.
contradiction H.

destruct H1 as [[alpha]].
simpl in H1.
constructor.
constructor.
cut (Urysohns_Lemma_function x0 < x); auto with real.
apply Rle_lt_trans with (2:=r).
unfold Urysohns_Lemma_function; destruct inf; simpl.
cut (Q2R (dr2Q alpha) >= x1); auto with real.
apply i.
left.
exists alpha; trivial.
constructor; trivial.

rewrite H1.
apply open_indexed_union.
intro.
apply U_dyadic_open.

(* proving that inverse image of upper open interval is open *)
destruct (classic (x<0)).
(* if x<0, inverse image is everything *)
match goal with |- open ?U => assert (U = Full_set) end.
apply Extensionality_Ensembles; split; red; intros.
constructor.
constructor.
constructor.
cut (x < Urysohns_Lemma_function x0); auto with real.
apply Rlt_le_trans with (1:=H).
apply Urysohns_Lemma_function_range.
rewrite H0; apply open_full.
assert (x >= 0) by now apply Rnot_lt_ge.
clear H.

(* if x>=1, inverse image is empty *)
destruct (classic (x>=1)).
match goal with |- open ?U => assert (U = Empty_set) end.
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
destruct H1.
destruct H1.
assert (x < Urysohns_Lemma_function x0).
destruct (total_order_T x (Urysohns_Lemma_function x0)) as
  [[|]|]; trivial.
contradiction H2.
symmetry; trivial.
contradict r.
apply Rle_not_gt; trivial.
absurd (x < x).
apply Rlt_irrefl.
apply Rlt_le_trans with (Urysohns_Lemma_function x0); trivial.
apply Rle_trans with 1; auto with real.
apply Urysohns_Lemma_function_range.
destruct H1.
rewrite H1; apply open_empty.

(* if 0 <= x < 1, inverse image is union of
   Complement (closure U_alpha) for x < alpha < 1 *)
assert (x < 1) by now apply Rnot_ge_lt.
clear H.
match goal with |- open ?U => assert (U =
  IndexedUnion (fun alpha:{alpha:dyadic_rational |
                     x < Q2R (dr2Q alpha) < 1} =>
             (Complement (closure (U_dyadic (proj1_sig alpha))))))
 end.
apply Extensionality_Ensembles; split; red; intros.
destruct H.
destruct H.
destruct H.
remember (Urysohns_Lemma_function x0) as y.
assert (y <= 1) by (rewrite Heqy; apply Urysohns_Lemma_function_range).
unfold Urysohns_Lemma_function in Heqy;
  destruct inf in Heqy; simpl in Heqy.
destruct Heqy.
assert (x < y).
destruct (total_order_T x y) as [[|]|]; trivial.
contradiction H2.
symmetry; trivial.
contradict r.
apply Rle_not_gt; trivial.
destruct (dyadic_rationals_dense_in_reals x y) as [alpha].
split; auto with real.
assert (~ In (U_dyadic alpha) x0).
intro.
absurd (Q2R (dr2Q alpha) >= y).
destruct H5.
apply Rlt_not_ge; trivial.
apply i.
left.
exists alpha.
constructor; trivial.
trivial.
destruct (dyadic_rationals_dense_in_reals x (Q2R (dr2Q alpha)))
  as [beta].
split; auto with real.
apply H5.
assert (dr_lt beta alpha).
apply Qlt_dr_lt.
apply Rlt_Qlt.
apply H7.
pose proof (U_dyadic_incr _ _ H8).
assert (x < Q2R (dr2Q beta) < 1).
split.
apply H7.
apply Rlt_trans with (Q2R (dr2Q alpha)).
apply H7.
apply Rlt_le_trans with y; trivial.
apply H5.
exists (exist (fun alpha0:dyadic_rational =>
               x < Q2R (dr2Q alpha0) < 1)
        beta H10).
simpl.
intro.
contradiction H6.
apply H9; trivial.

destruct H.
destruct a as [alpha].
simpl in H.
constructor.
constructor.
cut (x < Urysohns_Lemma_function x0); auto with real.
apply Rlt_le_trans with (Q2R (dr2Q alpha)).
apply a.
unfold Urysohns_Lemma_function; destruct inf as [y]; simpl.
apply i.
red; intros.
destruct H2.
destruct H2 as [beta].
assert (dr_lt alpha beta \/ dr_eq alpha beta).
cut (~ dr_lt beta alpha).
destruct (dr_total_order alpha beta) as [|[|]]; auto.
intro.
contradiction H5.
intro.
pose proof (U_dyadic_incr _ _ H4).
destruct H2.
contradiction H.
apply closure_inflationary.
apply H5.
apply closure_inflationary; trivial.
destruct H4.
rewrite H3.
pose proof (dr2Q_incr _ _ H4).
cut (Q2R (dr2Q alpha) <= Q2R (dr2Q beta)); auto with *.
apply Qle_Rle.
auto with qarith.
rewrite H3.
cut (Q2R (dr2Q alpha) <= Q2R (dr2Q beta)); auto with *.
apply Qle_Rle.
pose proof (dr2Q_wd _ _ H4).
auto with *.
destruct H2.
destruct a.
auto with *.

rewrite H.
apply open_indexed_union.
intros.
apply closure_closed.
Qed.

End Urysohns_Lemma_construction.

Theorem UrysohnsLemma: forall X:TopologicalSpace, normal_sep X ->
  forall F G:Ensemble (point_set X),
  closed F -> closed G -> Intersection F G = Empty_set ->
  exists f:point_set X -> point_set RTop,
  continuous f /\ (forall x:point_set X, 0 <= f x <= 1) /\
  (forall x:point_set X, In F x -> f x = 0) /\
  (forall x:point_set X, In G x -> f x = 1).
Proof.
intros.
destruct H.
destruct (H3 F G H0 H1 H2) as [U [V [? [? [? [? ?]]]]]].
assert (Included (closure U) (Complement G)).
assert (Included (closure U) (Complement V)).
apply closure_minimal; trivial.
red; rewrite Complement_Complement; trivial.
red; intros.
intro.
absurd (In Empty_set x).
intro.
destruct H11.
rewrite <- H8; constructor; trivial.
assert (Included (Complement V) (Complement G)).
red; intros.
intro.
contradiction H10.
apply H7.
trivial.
auto with sets.

assert (inhabited (forall F U:Ensemble (point_set X), closed F ->
  open U -> Included F U ->
  { V:Ensemble (point_set X) | open V /\ Included F V /\
                               Included (closure V) U })).
Require Import ClassicalChoice.
destruct (choice (fun (FU_pair:
  {p:Ensemble (point_set X) * Ensemble (point_set X) |
   closed (fst p) /\ open (snd p) /\ Included (fst p) (snd p)})
  (V0:Ensemble (point_set X)) =>
   open V0 /\ Included (fst (proj1_sig FU_pair)) V0 /\
   Included (closure V0) (snd (proj1_sig FU_pair)))) as
  [pre_choice_fun].
intro p.
destruct p as [[F0 U0]].
simpl in a.
simpl.
destruct a as [? []].
destruct (H3 F0 (Complement U0)) as [U1 [V1 []]]; trivial.
red; rewrite Complement_Complement; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H13.
contradiction H14.
apply H12; trivial.
destruct H13.
destruct H14 as [? [? []]].
exists U1.
repeat split; trivial.
assert (Included (closure U1) (Complement V1)).
apply closure_minimal; trivial.
red; rewrite Complement_Complement; trivial.
red; intros.
intro.
absurd (In Empty_set x).
intro H20; destruct H20.
rewrite <- H17; constructor; trivial.
assert (Included (Complement V1) U0).
red; intros.
apply NNPP; intro.
contradiction H19.
apply H16.
exact H20.
auto with sets.
exists.
intros.
exists (pre_choice_fun (exist _ (F0,U0)
  (conj H11 (conj H12 H13)))).
apply H10.
destruct H10 as [normal_sep_fun].

exists (Urysohns_Lemma_function _ normal_sep_fun
  U (Complement G) H4 H1 H9).
split.
apply Urysohns_Lemma_function_continuous.
split.
apply Urysohns_Lemma_function_range.
repeat split.
intros.
apply Urysohns_Lemma_function_0; auto.
intros.
apply Urysohns_Lemma_function_1; auto.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Sorting.Permutation.

Require Import GenericTactics.
Require Import GenericLemmas.
Require Import Unique.
Require Import Sublist.

Fixpoint zipWith {A B C : Type} (f : A -> B -> C) (la : list A) (lb : list B) {struct la} : list C :=
  match la, lb with
  | [], _ => []
  | _, [] => []
  | (a::la'), (b::lb') => (f a b) :: zipWith f la' lb'
  end.

Fixpoint sort_by_index_list {A B : Type} (f : A -> B -> bool) (index : list A) (to_sort : list B) : list B :=
  match index with
  | [] => []
  | (i::is) =>
    filter (f i) to_sort ++ sort_by_index_list f is (filter (fun x => negb (f i x)) to_sort)
  end.

Lemma sort_by_index_list_empty: forall {A B : Type} (f : A -> B -> bool) (index : list A),
    sort_by_index_list f index [] = [].
Proof.
  intros A B f index.
  induction index; auto.
Qed.

Lemma sort_by_index_list_filter_false: forall {A B : Type} (f : A -> B -> bool) (p : B -> bool) (index : list A) (to_sort : list B) (b : B),
    p b = false ->
    filter p (sort_by_index_list f index (b :: to_sort)) = filter p (sort_by_index_list f index to_sort).
Proof.
  intros A B f p index to_sort b H.
  gen_induction to_sort index; simpl; auto.
  match_destruct_tac; simpl; try rewrite H; auto.
  repeat rewrite filter_app; f_equal; auto.
Qed.

Lemma sort_by_index_list_filter: forall {A B : Type} (f : A -> B -> bool) (p : B -> bool) (index : list A) (to_sort : list B),
    sort_by_index_list f index (filter p to_sort) = filter p (sort_by_index_list f index to_sort).
Proof.
  intros A B f p index to_sort.
  gen_induction to_sort index; destruct to_sort; simpl; auto.
  - rewrite sort_by_index_list_empty; auto.
  - rewrite filter_app. f_equal.
    + do 2 match_destruct_tac; simpl; try rewrite E_match in *; try rewrite E_match0 in *; try rewrite filter_filter; auto.
    + do 2 match_destruct_tac; simpl;
        try rewrite E_match in *; try rewrite E_match0 in *; simpl; rewrite filter_filter; auto.
      * match goal with
        | [  |- _ = filter _ (_ _ _ ?ls) ] =>
          specialize (IHindex ls)
        end.
        simpl in IHindex; rewrite E_match in IHindex; auto.
      * rewrite sort_by_index_list_filter_false; auto.
Qed.

Lemma permutation_filter_div: forall {A : Type} (p : A -> bool) (l : list A),
    Permutation l (filter p l ++ filter (fun x => negb (p x)) l).
Proof.
  intros A p l.
  induction l; simpl; auto.
  match_destruct_tac; simpl.
  - apply perm_skip; auto.
  - apply Permutation_cons_app; auto.
Qed.

Lemma permutation_filter: forall {A : Type} (p : A -> bool) (l r : list A),
    Permutation l r ->
    Permutation (filter p l) (filter p r).
Proof.
  intros A p l r H.
  induction H; auto; simpl in *.
  - match_destruct_tac; auto.
  - do 2 match_destruct_tac; auto. apply perm_swap.
  - eapply perm_trans; eauto.
Qed.

Lemma Permutation_Forall: forall {A : Type} (P : A -> Prop) (ls ls' : list A),
    Permutation ls ls' ->
    Forall P ls ->
    Forall P ls'.
Proof.
  intros A P ls ls' H H0.
  induction H; auto.
  - inversion_clear H0; apply Forall_cons; auto.
  - repeat match goal with
           | [ H: Forall _ (_ :: _) |- _ ] =>
             inversion_clear H
           end;
      repeat apply Forall_cons; auto.
Qed.

Lemma Permutation_concat: forall {A : Type} (l r : list (list A)),
    Permutation l r ->
    Permutation (concat l) (concat r).
Proof.
  intros A l r H.
  induction H; auto; simpl in *.
  - apply Permutation_app; auto.
  - match goal with
    | [  |- Permutation (?x ++ ?y ++ ?z) (?x' ++ ?y' ++ ?z') ] =>
      reassoc_lists (x ++ y ++ z) ((x ++ y) ++ z);
        reassoc_lists (x' ++ y' ++ z') ((x' ++ y') ++ z')
    end.
    apply Permutation_app; auto.
    apply Permutation_app_comm.
  - eapply perm_trans; eauto.
Qed.

Lemma Permutation_sublist: forall {A : Type} (l r sub : list A),
    Permutation l r ->
    sublist sub r ->
    exists sub_l, Permutation sub_l sub /\ sublist sub_l l.
Proof.
  intros A l r sub H_per H_sub.
  gen_induction sub H_per; auto.
  - inversion H_sub; subst; eauto.
  - inversion H_sub; subst; eauto.
    + exists []; split; auto. apply sublist_nil.
    + specialize (IHH_per sub H1).
      inversion IHH_per. inversion H.
      exists x0; split; auto.
      apply sublist_skip; auto.
    + specialize (IHH_per _ H1).
      inversion IHH_per. inversion H.
      exists (x :: x0); split; auto.
      sublist_tac.
  - inversion H_sub; subst; try solve [exists []; split; auto; sublist_tac].
    + inversion H1; subst; try solve [exists []; split; auto; sublist_tac].
      * exists sub; split; auto. do 2 apply sublist_skip; assumption.
      * exists (y :: sub0); split; auto. apply sublist_cons; apply sublist_skip; assumption.
    + inversion H1; subst.
      * exists [x]; split; auto. apply sublist_skip; apply sublist_cons; sublist_tac.
      * exists (x :: sub0); split; auto. apply sublist_skip; apply sublist_cons; auto.
      * exists (y :: x :: sub); split; auto; try apply perm_swap.
        do 2 apply sublist_cons; auto.
  - specialize (IHH_per2 _ H_sub).
    inversion IHH_per2 as [sub_l1 [H_perm1 H_sub1]].
    specialize (IHH_per1 _ H_sub1).
    inversion IHH_per1 as [sub_l2 [H_perm2 H_sub2]].
    exists sub_l2; split; auto.
    apply (Permutation_trans H_perm2 H_perm1).
Qed.
Lemma Permutation_middle_rem: forall {A : Type} (l r : list A) (a : A),
    Permutation (a :: l) r ->
    exists r1 r2, r = r1 ++ a :: r2 /\ Permutation l (r1 ++ r2).
Proof.
  intros A l r a H_per.
  assert (In a r);
    [ eapply Permutation_in; eauto; left; auto |].
  apply in_split in H; double_exists H.
  split; auto.
  apply Permutation_cons_inv with (a := a).
  eapply (perm_trans H_per _).
  Unshelve. subst.
  apply Permutation_sym.
  apply Permutation_middle.
Qed.

Lemma Permutation_unique: forall {A : Type} (l r : list A),
    Permutation l r ->
    unique l ->
    unique r.
Proof.
  intros A l r H_per H_uniq.
  induction H_per; auto.
  - inversion_clear H_uniq.
    apply Unique_cons; auto.
    intro H_in; apply H.
    apply Permutation_in with (l := l'); auto.
    apply Permutation_sym; assumption.
  - repeat apply Unique_cons;
      repeat match goal with
             | [ H: unique (_ :: _) |- _ ] =>
               inversion_clear H
             end;
      auto.
    + intro H_in; inversion_clear H_in; subst.
      * apply H; left; auto.
      * apply H1; auto.
    + intro H_in; apply H; right; auto.
Qed.

Lemma sort_by_index_list_permutes_helper:forall {A B : Type} (f : A -> B -> bool) (index sub : list A) (to_sort : list B) (g : B -> A),
    sublist sub index ->
    Permutation sub (map g to_sort) ->
    (forall a b, a = g b <-> f a b = true) ->
    Permutation to_sort (sort_by_index_list f index to_sort).
Proof.
  intros A B f index sub to_sort g H_sub H_per E.
  gen_induction (sub, to_sort) index; simpl in *.
  - inversion H_sub; subst. apply Permutation_nil in H_per.
    apply map_eq_nil in H_per; subst; auto.
  - inversion H_sub; subst; simpl in *.
    + apply Permutation_nil in H_per. apply map_eq_nil in H_per; subst; simpl.
      clear; induction index; auto; simpl.
    + apply (perm_trans (permutation_filter_div (f a) to_sort)).
      apply Permutation_app; auto.
      match goal with
      | [ H: Permutation ?sub (map ?g ?ls) |- Permutation (filter ?p ?ls) _ ] =>
        let H_f := fresh in
        pose proof (sublist_filter p ls) as H_f;
          apply (sublist_map _ _ g) in H_f;
          eapply (Permutation_sublist _ _ _ H_per) in H_f;
          inversion H_f as [sub_l [Hl Hr]]
      end.
      eapply IHindex; [| eauto].
      apply (sublist_trans _ _ _ Hr H1).
    + apply (perm_trans (permutation_filter_div (f a) to_sort)).
      apply Permutation_app; auto.
      apply Permutation_middle_rem in H_per.
      repeat match goal with
             | [ H: exists _,_ |- _ ] =>
               inversion_clear H
             | [ H: _ /\ _ |- _ ] =>
               inversion_clear H
             end.
      apply map_app2 in H.
      repeat match goal with
             | [ H: exists _,_ |- _ ] =>
               inversion_clear H
             | [ H: _ /\ _ |- _ ] =>
               inversion_clear H
             end.
      subst.
      destruct x2; inversion H; subst.
      rewrite filter_elem_false; [ | rewrite Bool.negb_false_iff; apply E; reflexivity].
      pose proof (sublist_filter (fun x => negb (f (g b) x)) (x1 ++ x2)) as H_sub_filter.
      apply (sublist_map _ _ g) in H_sub_filter.
      rewrite <- map_app in H2.
      pose proof (Permutation_sublist _ _ _ H2 H_sub_filter).
      repeat match goal with
             | [ H: exists _,_ |- _ ] =>
               inversion_clear H
             | [ H: _ /\ _ |- _ ] =>
               inversion_clear H
             end.
      eapply IHindex.
      * eapply sublist_trans; [eapply H4 | eauto].
      * auto.
Qed.

Lemma sort_by_index_list_permutes: forall {A B : Type} (f : A -> B -> bool) (index : list A) (to_sort : list B),
    (exists (g : B -> A), Permutation index (map g to_sort) /\
                    forall a b, a = g b <-> f a b = true) ->
    Permutation to_sort (sort_by_index_list f index to_sort).
Proof.
  intros.
  inversion_clear H as [g [H_per H_eq]].
  eapply sort_by_index_list_permutes_helper with (g0 := g).
  - eapply sublist_refl.
  - auto.
  - auto.
Qed.

Lemma sort_by_index_list_sorted_like_index:
  forall {A B : Type} (f : A -> B -> bool) (index : list A) (to_sort : list B) (g : B -> A),
    unique index ->
    Permutation index (map g to_sort) ->
    (forall (a : A) (b : B), a = g b <-> f a b = true) ->
    (map g (sort_by_index_list f index to_sort) = index).
Proof.
  intros A B f index to_sort g H_uniq H_per E.
  pose proof (Permutation_unique _ _ H_per H_uniq) as H_uniq_to_sort.
  gen_induction to_sort index; [ inversion H_per; easy |].
  simpl.
  assert (Hx: exists b, In b to_sort /\ g b = a).
  { apply (Permutation_in a) in H_per; [ | left; easy].
    clear - H_per. induction to_sort; simpl in *; inversion H_per; subst.
    - exists a0; split; auto.
    - specialize (IHto_sort H).
      inversion IHto_sort as (b & H_in & E).
      exists b; split; auto.
  }
  inversion_clear Hx as (b & H_in_b & E_g).
  assert (E_in: forall bx, In bx to_sort -> f a bx = true <-> b = bx).
  { clear IHindex H_uniq H_per; intros bx H_in.
    induction to_sort; inversion H_in; inversion H_in_b; subst.
    - split; intro; auto.
      rewrite <- E; easy.
    - symmetry. split; intro; subst.
      + rewrite <- E; easy.
      + rewrite <- E in H.
        apply (in_map g) in H0.
        inversion H_uniq_to_sort; subst.
        rewrite H in *. contradiction.
    - split; intro; subst.
      + rewrite <- E in H0.
        apply (in_map g) in H.
        inversion H_uniq_to_sort; subst.
        rewrite H0 in *.
        contradiction.
      + rewrite <- E; easy.
    - inversion H_uniq_to_sort; auto.
  }
  assert (E_b: filter (f a) to_sort = [b]).
  { clear - E E_g H_in_b E_in H_uniq_to_sort.
    induction to_sort; inversion H_in_b; subst; simpl.
    - rewrite (proj1 (E (g b) b)); [ |easy].
      f_equal.
      inversion_clear H_uniq_to_sort.
      assert (Forall (fun bx => f (g b) bx = false) to_sort).
      { clear IHto_sort H_in_b.
        induction to_sort as [|bx to_sort]; auto.
        apply Forall_cons.
        - simpl map in H; rewrite not_in_cons in H. inversion H.
          rewrite <- Bool.not_true_iff_false.
          contradict H1.
          rewrite <- E in H1; easy.
        - inversion_clear H0. apply IHto_sort; auto.
          + intros; apply E_in.
            inversion H0; subst; [ left | right; right ]; easy.
          + contradict H. right; easy.
      }
      apply Forall_false_filter_nil; easy.
    - inversion_clear H_uniq_to_sort.
      match_destruct_tac.
      + rewrite <- E in E_match; subst.
        contradict H0.
        apply (in_map g) in H; rewrite <- E_match; easy.
      + apply IHto_sort; auto.
        intros; apply E_in; auto.
        right; easy.
  }
  rewrite E_b in *; rewrite map_app; simpl.
  f_equal; auto.
  inversion_clear H_uniq.
  apply IHindex; auto;
    [ |  apply (uniqueness_sublist _ (map g to_sort)); auto; sublist_tac ].
  pose proof (permutation_filter_div (f a) to_sort).
  apply (Permutation_map g) in H1.
  pose proof (perm_trans H_per H1).
  rewrite E_b in H2; simpl in H2.
  rewrite E_g in H2.
  apply Permutation_cons_inv in H2; easy.
Qed.


(* Check dependencies in the matching predicate (was failing in V8.0pl1) *)

Inductive t : forall x : 0 = 0, x = x -> Prop :=
    c : forall x : 0 = 0, t x (refl_equal x).

Definition a (x : t _ (refl_equal (refl_equal 0))) :=
  match x return match x with
                 | c y => Prop
                 end with
  | c y => y = y
  end.


Require Export Classes.interfaces.abstract_algebra.
Require Import Pointed WildCat.
Require Import Truncations.Connectedness.

Local Open Scope pointed_scope.
Local Open Scope trunc_scope.
Local Open Scope mc_mult_scope.

(** * H-spaces *)

(** A (noncoherent) H-space [X] is a pointed type with a binary operation for which the base point is a both a left and a right identity. (See Coherent.v for the notion of a coherent H-space.) We say [X] is left-invertible if left multiplication by any element is an equivalence, and dually for right-invertible. *)

Class IsHSpace (X : pType) := {
  hspace_op : SgOp X;
  hspace_left_identity : LeftIdentity hspace_op pt;
  hspace_right_identity : RightIdentity hspace_op pt;
}.
#[export] Existing Instances hspace_left_identity hspace_right_identity hspace_op.

Global Instance hspace_mon_unit {X : pType} `{IsHSpace X} : MonUnit X := pt.

Definition issig_ishspace {X : pType}
  : { mu : X -> X -> X & prod (forall x, mu pt x = x) (forall x, mu x pt = x) }
      <~> IsHSpace X := ltac:(make_equiv).

(** Left and right multiplication by the base point is always an equivalence. *)
Global Instance isequiv_hspace_left_op_pt {X : pType} `{IsHSpace X}
  : IsEquiv (pt *.).
Proof.
  apply (isequiv_homotopic idmap); intro x.
  exact (left_identity x)^.
Defined.

Global Instance isequiv_hspace_right_op_pt {X : pType} `{IsHSpace X}
  : IsEquiv (.* pt).
Proof.
  apply (isequiv_homotopic idmap); intro x.
  exact (right_identity x)^.
Defined.

Definition equiv_hspace_left_op {X : pType} `{IsHSpace X}
  (x : X) `{IsEquiv _ _ (x *.)} : X <~> X
  := Build_Equiv _ _ (x *.) _.

Definition equiv_hspace_right_op {X : pType} `{IsHSpace X}
  (x : X) `{IsEquiv _ _ (.* x)} : X <~> X
  := Build_Equiv _ _ (.* x) _.

(** Any element of an H-space defines a pointed self-map by left multiplication, in the following sense. *)
Definition pmap_hspace_left_op {X : pType} `{IsHSpace X} (x : X)
  : X ->* [X, x] := Build_pMap X [X,x] (x *.) (right_identity x).

(** We make [(x *.)] into a pointed equivalence (when possible). In particular, this makes [(pt *.)] into a pointed self-equivalence. We could have also used the left identity to make [(pt *.)] into a pointed self-equivalence, and then we would get a map that's equal to the identity as a pointed map; but without coherence (see Coherent.v) this is not necessarily the case for this map. *)
Definition pequiv_hspace_left_op {X : pType} `{IsHSpace X}
  (x : X) `{IsEquiv _ _ (x *.)} : X <~>* [X,x]
  := Build_pEquiv' (B:=[X,x]) (equiv_hspace_left_op x) (right_identity x).

(** ** Connected H-spaces *)

(** For connected H-spaces, left and right multiplication by an element is an equivalence. This is because left and right multiplication by the base point is one, and being an equivalence is a proposition. *)

Global Instance isequiv_hspace_left_op `{Univalence} {A : pType}
  `{IsHSpace A} `{IsConnected 0 A}
  : forall (a : A), IsEquiv (a *.).
Proof.
  nrapply conn_point_elim; exact _.
Defined.

Global Instance isequiv_hspace_right_op `{Univalence} {A : pType}
  `{IsHSpace A} `{IsConnected 0 A}
  : forall (a : A), IsEquiv (.* a).
Proof.
  nrapply conn_point_elim; exact _.
Defined.

(** ** Left-invertible H-spaces are homogeneous *)

(** A homogeneous structure on a pointed type [A] gives, for any point [a : A], a self-equivalence of [A] sending the base point to [a]. (This is the same data as a left-invertible right-unital binary operation.) *)
Class IsHomogeneous (A : pType)
  := ishomogeneous : forall a, A <~>* [A, a].

(** Any homogeneous structure can be modified so that the base point is mapped to the pointed identity map. *)

Definition homogeneous_pt_id {A : pType} `{IsHomogeneous A}
  : forall a, A <~>* [A,a]
  := fun a => ishomogeneous a o*E (ishomogeneous (point A))^-1*.

Definition homogeneous_pt_id_beta `{Funext} {A : pType} `{IsHomogeneous A}
  : homogeneous_pt_id (point A) = pequiv_pmap_idmap
  := ltac:(apply path_pequiv, peisretr).

(** This modified structure makes any homogeneous type into a (left-invertible) H-space. *)
Global Instance ishspace_homogeneous {A : pType} `{IsHomogeneous A}
  : IsHSpace A.
Proof.
  snrapply Build_IsHSpace.
  - exact (fun a b => homogeneous_pt_id a b).
  - intro a; cbn.
    apply eisretr.
  - intro a; cbn.
    exact (ap _ (point_eq (ishomogeneous pt)^-1*)
                   @ point_eq (ishomogeneous a)).
Defined.

(** Left-invertible H-spaces are homogeneous, giving a logical equivalence between left-invertible H-spaces and homogeneous types. (In fact, the type of homogeneous types with the base point sent to the pointed identity map is equivalent to the type of left-invertible coherent H-spaces, but we don't prove that here.) *)
Global Instance ishomogeneous_hspace {A : pType} `{IsHSpace A}
  `{forall a, IsEquiv (a *.)}
  : IsHomogeneous A
  := (fun a => pequiv_hspace_left_op a).

(** ** Promoting unpointed homotopies to pointed homotopies *)

(** Two pointed maps [f g : Y ->* X] into an H-space are equal if and only if they are equal as unpointed maps. (Note: This is a logical "iff", not an equivalence of types.) This was first observed by Evan Cavallo for homogeneous types. Below we show a generalization due to Egbert Rijke, which we then specialize to H-spaces. Notably, the specialization does not require left-invertibility. This appears as Lemma 2.6 in https://arxiv.org/abs/2301.02636v1 *)

(** First a version that assumes an equality of the unpointed maps. *)
Definition phomotopy_from_path_arrow {A B : pType}
  (m : forall (a : A), (point A) = (point A) -> a = a)
  (q : m pt == idmap) {f g : B ->* A} (K : pointed_fun f = pointed_fun g)
  : f ==* g.
Proof.
  nrapply issig_phomotopy.
  destruct f as [f fpt], g as [g gpt]; cbn in *.
  induction K.
  destruct A as [A a0]; cbn in *.
  induction fpt.
  exists (fun b => m (f b) (idpath @ gpt^)).
  apply q.
Defined.

(** Assuming [Funext], we may take [K] to be a homotopy. With a more elaborate proof, [Funext] could be avoided here and therefore in the next result as well. *)
Definition phomotopy_from_homotopy `{Funext} {A B : pType}
  (m : forall (a : A), (point A) = (point A) -> a = a)
  (q :  m pt == idmap) {f g : B ->* A} (K : f == g)
  : f ==* g
  := (phomotopy_from_path_arrow m q (path_forall _ _ K)).

(** We specialize to H-spaces. *)
Definition hspace_phomotopy_from_homotopy `{Funext} {A B : pType}
  `{IsHSpace A} {f g : B ->* A} (K : f == g)
  : f ==* g.
Proof.
  snrapply (phomotopy_from_homotopy _ _ K).
  - intro a.
    exact (fmap loops (pmap_hspace_left_op a o* (pequiv_hspace_left_op pt)^-1*)).
  - lazy beta.
    transitivity (fmap (b:=A) loops pmap_idmap).
    2: rapply (fmap_id loops).
    rapply (fmap2 loops).
    nrapply peisretr.
Defined.

(** A version with actual paths. *)
Definition hspace_path_pforall_from_path_arrow `{Funext} {A B : pType}
  `{IsHSpace A} {f g : B ->* A} (K : pointed_fun f = pointed_fun g)
  : f = g.
Proof.
  apply path_pforall, hspace_phomotopy_from_homotopy.
  apply (path_arrow _ _)^-1.
  exact K.
Defined.