From Theories Require Import
  Tactics Chap_2_Framework.

(** * Specification *)

(** ** Syntax *)

Inductive Mul :=
  | aff
  | unr.

Inductive Typ :=
  | t_void
  | t_arr (m : Mul) (t1 t2 : Typ).

Inductive Exp :=
  | e_var (x : nat)
  | e_app (e1 e2 : Exp)
  | e_abs (m : Mul) (e : Exp).

(** ** Type System *)

Inductive Acc :=
  | here
  | gone.

Inductive Bind :=
  | bind (a : Acc) (m : Mul) (t : Typ).

Definition TypEnv := List Bind.

Inductive Split : TypEnv -> TypEnv -> TypEnv -> Prop :=
  | sp_nil :
      Split [] [] []
  | sp_gone :
      forall bs bs1 bs2 t m,
      Split bs bs1 bs2 ->
      Split (bind gone m t :: bs) (bind gone m t :: bs1) (bind gone m t :: bs2)
  | sp_left :
      forall bs bs1 bs2 t,
      Split bs bs1 bs2 ->
      Split (bind here aff t :: bs) (bind here aff t :: bs1) (bind gone aff t :: bs2)
  | sp_right :
      forall bs bs1 bs2 t,
      Split bs bs1 bs2 ->
      Split (bind here aff t :: bs) (bind gone aff t :: bs1) (bind here aff t :: bs2)
  | sp_both :
      forall bs bs1 bs2 t,
      Split bs bs1 bs2 ->
      Split (bind here unr t :: bs) (bind here unr t :: bs1) (bind here unr t :: bs2).

Definition restrict_entry (b : Bind) : Bind :=
  match b with
  | bind here aff t => bind gone aff t
  | b               => b
  end.

Definition restrict (m : Mul) (bs : TypEnv) : TypEnv :=
  match m with
  | unr => map restrict_entry bs
  | aff => bs
  end.

(* FIXME: Sub-kinding is not used yet. *)
Inductive SubKind : Mul -> Mul -> Prop :=
  | sk_refl : forall m, SubKind m m
  | sk_aff  :      SubKind unr aff.

Inductive HasKind : Typ -> Mul -> Prop :=
  | hk_void :            HasKind t_void unr
  | hk_arr  : forall m t1 t2, HasKind (t_arr m t1 t2) m.

Inductive ExpTyp : TypEnv -> Exp -> Typ -> Prop :=
  | et_var :
      forall x te t m,
      indexr x te = some (bind here m t) ->
      ExpTyp te (e_var x) t
  | et_app :
      forall te te1 te2 e1 e2 t1 t2 m,
      Split te te1 te2 ->
      ExpTyp te1 e1 (t_arr m t1 t2) ->
      ExpTyp te2 e2 t1 ->
      ExpTyp te (e_app e1 e2) t2
  | et_abs :
      forall te e t1 t2 m m1,
      HasKind t1 m1 ->
      ExpTyp (bind here m1 t1 :: restrict m te) e t2 ->
      ExpTyp te (e_abs m e) (t_arr m t1 t2).

(** ** Semantics *)

Inductive Val :=
  | v_abs (ve : List Val) (m : Mul) (e : Exp).

Definition ValEnv := List Val.

Fixpoint eval (n : nat) (ve : ValEnv) (e : Exp) : CanTimeout (CanErr Val) :=
  match n with
  | 0 => timeout
  | S n =>
      match e with
      | e_var x => done (indexr x ve)
      | e_abs m e => done (noerr (v_abs ve m e))
      | e_app e1 e2 =>
          ' v_abs env1' m' e1' <- eval n ve e1;
          ' v2 <- eval n ve e2;
          eval n (v2 :: env1') e1'
      end
  end.

(** ** Type Soundness *)

Definition bind_typ (b : Bind) : Typ :=
  match b with
  | bind a m t => t
  end.

Inductive ValTyp : Val -> Typ -> Prop :=
  | vt_abs :
      forall ve te e t1 t2 m m1,
      Forall2 (fun v b => ValTyp v (bind_typ b)) ve te ->
      HasKind t1 m1 ->
      ExpTyp (bind here m1 t1 :: te) e t2 ->
      ValTyp (v_abs ve m e) (t_arr m t1 t2).

Definition WfEnv : ValEnv -> TypEnv -> Prop :=
  Forall2 (fun v b => ValTyp v (bind_typ b)).

(* Inductive ValTyp : Val -> Bind -> Prop := *)
(*   | vt_abs : *)
(*       forall a ve te e t1 t2 m m1, *)
(*       Forall2 ValTyp ve te -> *)
(*       HasKind t1 m1 -> *)
(*       ExpTyp (bind here m1 t1 :: te) e t2 -> *)
(*       ValTyp (v_abs ve m e) (bind a m (t_arr m t1 t2)). *)

(* Definition WfEnv : ValEnv -> TypEnv -> Prop := *)
(*   Forall2 ValTyp. *)

(* Inductive WfEnv : ValEnv -> TypEnv -> Prop := *)
(*   | wfe_nil : *)
(*       WfEnv [] [] *)
(*   | wfe_cons : *)
(*       forall v t ve te m, *)
(*       HasKind t m -> *)
(*       ValTyp v t -> *)
(*       WfEnv ve te -> *)
(*       WfEnv (v :: ve) (bind here m t :: te) *)
(*   | wfe_none : *)
(*       forall v t ve te m, *)
(*       HasKind t m -> *)
(*       ValTyp v t -> *)
(*       WfEnv ve te -> *)
(*       WfEnv (v :: ve) (bind gone m t :: te) *)
(* with ValTyp : Val -> Typ -> Prop := *)
(*   | vt_abs : *)
(*       forall ve te e t1 t2 m m1, *)
(*       WfEnv ve te -> *)
(*       HasKind t1 m1 -> *)
(*       ExpTyp (bind here m1 t1 :: te) e t2 -> *)
(*       ValTyp (v_abs ve m e) (t_arr m t1 t2). *)

(** * Theorems *)

Hint Constructors Typ Exp Val Split ExpTyp ValTyp Opt List Forall2.
Hint Unfold indexr length ValEnv TypEnv map restrict_entry restrict WfEnv.
Hint Resolve ex_intro.

Lemma split_preserves_wf :
  forall ve te te1 te2,
  WfEnv ve te ->
  Split te te1 te2 ->
  WfEnv ve te1 /\ WfEnv ve te2.
Proof.
  intros ? ? ? ? ? HSplit.
  generalize dependent ve.
  induction HSplit; intros ve HWf.
  Case "sp_nil".
    auto.
  Case "sp_gone". {
    inversion HWf; subst.
    destruct (IHHSplit xs H3) as [HWf1 HWf2].
    split; eauto.
    (* split. *)
    (* - econstructor. eauto. auto. exact HWf1. *)
    (* - econstructor. eauto. auto. exact HWf2. *)
  }
  Case "sp_left".
    inversion HWf; subst.
    destruct (IHHSplit xs H3) as [HWf1 HWf2].
    split; eauto.
  Case "sp_right".
    inversion HWf; subst.
    destruct (IHHSplit xs H3) as [HWf1 HWf2].
    split; eauto.
  Case "sp_both".
    inversion HWf; subst.
    destruct (IHHSplit xs H3) as [HWf1 HWf2].
    split; eauto.
Qed.

Lemma split_append_comm :
  forall (i1 i2 l r : TypEnv),
  Split (i1 ++ i2) l r ->
  exists l1 r1 l2 r2,
    Split i1 l1 r1 /\
    Split i2 l2 r2 /\
    l1 ++ l2 = l /\
    r1 ++ r2 = r.
Proof.
  intros i1.
  induction i1; intros.
  - simpl in H. exists []. exists []. exists l. exists r. intuition.
  - simpl in H.
    inversion H; subst.
    (* Exact same proofs except for constructor [eapply sp_*]. *)
    + destruct (IHi1 _ _ _ H4) as
        [l1' [r1' [l2' [r2' [HSplit1 [HSplit2 [HEq1 HEq2]]]]]]].
      eexists. eexists. eexists. eexists.
      repeat split.
      * eapply sp_gone. eapply HSplit1.
      * eapply HSplit2.
      * rewrite <- HEq1. rewrite <- app_comm_cons. reflexivity.
      * rewrite <- HEq2. rewrite <- app_comm_cons. reflexivity.
    + destruct (IHi1 _ _ _ H4) as
        [l1' [r1' [l2' [r2' [HSplit1 [HSplit2 [HEq1 HEq2]]]]]]].
      eexists. eexists. eexists. eexists.
      repeat split.
      * eapply sp_left. eapply HSplit1.
      * eapply HSplit2.
      * rewrite <- HEq1. rewrite <- app_comm_cons. reflexivity.
      * rewrite <- HEq2. rewrite <- app_comm_cons. reflexivity.
    + destruct (IHi1 _ _ _ H4) as
        [l1' [r1' [l2' [r2' [HSplit1 [HSplit2 [HEq1 HEq2]]]]]]].
      eexists. eexists. eexists. eexists.
      repeat split.
      * eapply sp_right. eapply HSplit1.
      * eapply HSplit2.
      * rewrite <- HEq1. rewrite <- app_comm_cons. reflexivity.
      * rewrite <- HEq2. rewrite <- app_comm_cons. reflexivity.
    + destruct (IHi1 _ _ _ H4) as
        [l1' [r1' [l2' [r2' [HSplit1 [HSplit2 [HEq1 HEq2]]]]]]].
      eexists. eexists. eexists. eexists.
      repeat split.
      * eapply sp_both. eapply HSplit1.
      * eapply HSplit2.
      * rewrite <- HEq1. rewrite <- app_comm_cons. reflexivity.
      * rewrite <- HEq2. rewrite <- app_comm_cons. reflexivity.
Qed.

Lemma split_append_comm_back :
  forall (i1 l1 r1 i2 l2 r2 : TypEnv),
  Split i1 l1 r1 ->
  Split i2 l2 r2 ->
  Split (i1 ++ i2) (l1 ++ l2) (r1 ++ r2).
Proof.
  induction i1; intros l1 r1 i2 l2 r2 HSplit1 HSplit2.
  - inversion HSplit1; subst. simpl. exact HSplit2.
  - inversion HSplit1; subst; rename bs1 into l1; rename bs2 into r1.
    + simpl. apply sp_gone. eapply IHi1; assumption.
    + simpl. apply sp_left. eapply IHi1; assumption.
    + simpl. apply sp_right. eapply IHi1; assumption.
    + simpl. apply sp_both. eapply IHi1; assumption.
Qed.

Lemma split_restr' :
  forall (i l r : TypEnv),
  Split (map restrict_entry i) l r ->
  exists l' r',
    Split i l' r' /\
    map restrict_entry l' = l /\
    map restrict_entry r' = r.
Proof.
  induction i; intros.
  Case "i = []".
    simpl in H. inversion H; subst.
    exists []. exists []. intuition.
  Case "i = a :: i".
    destruct a.
    destruct a.
    Case2 "a = here".
      destruct m.
      Case3 "m = aff". (* We arbitrarily choose [sp_left]. *)
        simpl in *. inversion H; subst.
        destruct (IHi _ _ H5) as [l' [r' [HSplit' [HEq1' HEq2']]]].
        subst. exists (bind here aff t :: l'). exists (bind gone aff t :: r').
        repeat split. eapply sp_left. exact HSplit'.
      Case3 "m = unr".
        simpl in *. inversion H; subst.
        destruct (IHi _ _ H4) as [l' [r' [HSplit' [HEq1' HEq2']]]].
        subst. exists (bind here unr t :: l'). exists (bind here unr t :: r').
        repeat split. eapply sp_both. exact HSplit'.
    Case2 "a = gone".
      simpl in *. inversion H; subst.
      destruct (IHi _ _ H5) as [l' [r' [HSplit' [HEq1' HEq2']]]].
      subst. exists (bind gone m t :: l'). exists (bind gone m t :: r').
      repeat split. eapply sp_gone. exact HSplit'.
Qed.

Lemma split_restr :
  forall (i1 i2 l r : TypEnv),
  Split (i1 ++ map restrict_entry i2) l r ->
  exists l1 r1 l2 r2,
    Split (i1 ++ i2) (l1 ++ l2) (r1 ++ r2) /\
    l1 ++ map restrict_entry l2 = l /\
    r1 ++ map restrict_entry r2 = r.
Proof.
  intros i1 i2 l r HSplit.
  destruct (split_append_comm _ _ _ _ HSplit) as
    [l1 [r1 [l2 [r2 [HSplit1 [HSplit2 [Eq_l Eq_r]]]]]]].
  destruct (split_restr' i2 l2 r2 HSplit2) as
    [l2' [r2' [HSplit2' [Eq_l2' Eq_r2']]]].
  subst.
  pose (HSplit' := split_append_comm_back _ _ _ _ _ _ HSplit1 HSplit2');
  clearbody HSplit'.
  repeat eexists. intuition.
Qed.

Lemma restr_append_comm :
  forall (xs1 xs2 : TypEnv) m,
  restrict m (xs1 ++ xs2) = restrict m xs1 ++ restrict m xs2.
Proof.
  intros. destruct m.
  - simpl. reflexivity.
  - simpl. rewrite <- map_append_comm. reflexivity.
Qed.

Lemma restrict_entry_idempotent :
  forall (b : Bind),
  restrict_entry (restrict_entry b) = restrict_entry b.
Proof. destruct b. destruct a; destruct m; reflexivity. Qed.

Lemma map_idempotent :
  forall {X} (f : X -> X),
  (forall x, f (f x) = f x) ->
  (forall xs, map f (map f xs) = map f xs).
Proof.
  intros. induction xs.
  - simpl. reflexivity.
  - simpl. rewrite H. rewrite IHxs. reflexivity.
Qed.

Lemma restr_unr_idempotent :
  forall (bs : TypEnv) m,
  restrict m (restrict unr bs) = restrict unr bs.
Proof.
  intros. destruct m.
  - simpl in *. reflexivity.
  - simpl in *. apply map_idempotent. exact restrict_entry_idempotent.
Qed.

Lemma length_app_comm :
  forall {X} (xs1 xs2 : List X),
  length (xs1 ++ xs2) = length xs1 + length xs2.
Proof.
  intros.
  induction xs1.
  - simpl in *. reflexivity.
  - simpl in *. rewrite <- IHxs1. reflexivity.
Qed.

Lemma restr_preserves_indexr :
  forall (te te' : TypEnv) (i : nat) m t ,
  indexr i (te' ++ restrict unr te) = some (bind here m t) ->
  indexr i (te' ++ te) = some (bind here m t).
Proof.
  induction te'; intros.
  - simpl in *.
    induction te.
    + simpl in *. assumption.
    + simpl in *.
      rewrite map_preserves_length in H.
      destruct (i =? length te).
      * destruct a. destruct a.
          destruct m0.
            simpl in *. inversion H.
            simpl in *. inversion H; subst. reflexivity.
          simpl in *. inversion H.
      * apply IHte. assumption.
  - simpl in *.
    rewrite length_app_comm in H.
    rewrite map_preserves_length in H.
    rewrite <- length_app_comm in H.
    destruct (i =? length (te' ++ te)).
    + exact H.
    + apply IHte'; assumption.
Qed.

(** For the safety proof, we only need the special case where [te' ~= [here m1 t1]],
    but we generalize to get a strong enough induction hypothesis. *)
Lemma restr_preserves_hastype :
  forall m e t te te',
  ExpTyp (te' ++ restrict m te) e t ->
  ExpTyp (te' ++ te) e t.
Proof.
  intros m.
  destruct m.
  Case "m = unr". intros ? ? ? ? HExpTyp. simpl in HExpTyp. exact HExpTyp.
  Case "m = aff".
    dependent induction e; intros t te te' HExpTyp.
    - inversion HExpTyp as [? ? ? m Hindex | |]; subst.
      apply et_var with (m := m).
      apply restr_preserves_indexr.
      exact Hindex.
    - inversion HExpTyp as
        [| te'' te1 te2 f x t0 t2 m HSplit HExpTyp1 HExpTyp2|]; subst.
      destruct (split_restr te' te te1 te2 HSplit) as
        [te1' [te2' [te1'' [te2'' [HSplit'' [EQ1 EQ2]]]]]].
      subst.
      eapply et_app with (m := m) (t1 := t0).
      + exact HSplit''.
      + exact (IHe1 (t_arr m t0 t) _ _ HExpTyp1).
      + exact (IHe2 t0 _ _ HExpTyp2).
    - inversion HExpTyp as
        [| | te'' e' t1 t2 m0 m1 HHasKind' HExpTyp']; subst.
      apply et_abs with (m1 := m1).
      + exact HHasKind'.
      + rewrite restr_append_comm in HExpTyp'.
        destruct m.
        * simpl in *.
          exact (IHe t2 te (bind here m1 t1 :: te') HExpTyp').
        * rewrite restr_unr_idempotent in HExpTyp'.
          rewrite <- restr_append_comm in HExpTyp'.
          exact HExpTyp'.
Qed.

Theorem type_soundness :
  forall n e te ve res t,
  eval n ve e = some res ->
  ExpTyp te e t ->
  WfEnv ve te ->
  exists v, res = some v /\ ValTyp v t.
Proof.
  intros n. induction n.
  Case "n = 0". intros ? ? ? ? ? Heval ? ?. inversion Heval.
  Case "n = S n". intros ? ? ? ? ? H H0 H1. destruct e.
    Case2 "var".
      inversion H as [H'].
      inversion H0.
      destruct (fa2_indexr H1 H4) as [v [I V]].
      rewrite I. eexists. eexists. split. exact V.
    Case2 "app".
      simpl in H.
      inversion H0. subst e0 e3 te0 t.
      destruct (split_preserves_wf _ _ _ _ H1 H4) as [HWf1 HWf2].
      remember (eval n ve e1) as mmv1.
      remember (eval n ve e2) as mmv2.
      destruct mmv1 as [mv1|].
      Case3 "mmv1 = some mv1".
        destruct mmv2 as [mv2|].
        Case4 "mmv2 = some mv2".
          (** Apply [IHn] to [e1] *)
          assert (exists v1, mv1 = some v1 /\ ValTyp v1 (t_arr m t1 t2)) as [v1 [E1 HV1]].
            { eapply IHn; eauto. }
          (** Apply [IHn] to [e2] *)
          assert (exists v2, mv2 = some v2 /\ ValTyp v2 t1) as [v2 [E2 HV2]].
            { eapply IHn; eauto. }
          (** Invert [v1] to closure [v_abs ve0 e] with [ExpTyp] evidence. *)
          inversion HV1.
          (** Apply [IHn] to closure body [e] *)
          subst. eapply IHn; eauto.
        Case4 "mmv2 = none  [contradiction]".
          (** Apply [IHn] to [e1] *)
          assert (exists v1, mv1 = some v1 /\ ValTyp v1 (t_arr m t1 t2)) as [v1 [E1 HV1]].
            { eapply IHn; eauto. }
          subst. inversion HV1. subst.
          (** Contradict. *)
          inversion H.
      Case3 "mmv1 = none  [contradiction]".
        solve by inversion.
    Case2 "abs".
      inversion H. inversion H0.
      eexists. split. eauto. eapply vt_abs; eauto.
      eapply restr_preserves_hastype with (te' := [bind here m1 t1]) (m := m).
      exact H8.
Qed.


(*
Axiom comA : forall x y, A x y = A y x.
Axiom assocA : forall x y z,  A (A x y) z = A x (A y z).
Axiom invA : forall x, A x x = zero.
AxiomidA : forall x, A zero x = x.

Axiom comM : forall x y, M x y = M y x.
Axiom assocM : forall x y z, M (M x y) z = M x (M y z).
Axiom o2M : forall x, M x x = x.
Axiom zeroM : forall x, M zero x = zero.  Axiom idM : forall x, M one x = x.
Axiom dist : forall x y z, M x (A y z) = A (M x y) (M x z).

 *)

Require Export Omega.
Require Export List.
Export ListNotations.
Export Setoid.

Require Export Utilities.
Require Export TheoryDef.
Require Export TermsUtilities.
Require Export Substitutions.
Require Export Factoring.
Require Export EquivalenceAndUnifiability.

(**  * The Variable Elimination algorithm *)

(** We build on the Factoring module, where, for any term t and
variable x we define a quotient q and remainder r, such that t == qx +
r.   Then the variable elimination algorithm for solvability is

- choose a variable x from vars of t, and write t as qx + r

-  set t' to be (q+1) r

- compute a reproductive sigma' solving t'

- then the following sigma is a reproductive unifier of t

  << sigma' + {x |-> x * (sigma' q) + x + (sigma r) | x in vars t}
  >>

 *)

(** * Computing a unifier *)
(*

(** ** Preparing for the recursive call *)

(** *** Write t as x * q + r *)

Definition factor  (t: term) (x: var) : term :=
  ( (V x) *' (quotient t x)  +' (remainder t x)).
 *)

(** *** The term for the recursive call: (q+1) * r  *)

Definition derived_term (t: term) (x: var) : term :=
  ((quotient t x) +' T1 ) *' (remainder t x).

(** *** The binding for  x after the recursive call
 *)

Definition var_image  (sigma: subL) (x: var) (q r: term) : term :=
  ( (V x) *' ( (sigma @ q) +' T1) ) +' (sigma @ r).

(** *** The updated substitution from the answer to the recursive call *)

Definition var_elim_update (sigma: subL) (x: var) (q r: term) : subL :=
  (update_subL sigma x (var_image sigma x  q r)).

(** ** Main Function *)

(** Familiar pattern: helper defined for an arbitrary list of vars,
    real function specializies to vars in the terms *)

Fixpoint varElimX (t: term) (vars: list var) : option subL :=
  match vars with
  |  [] => if decision (t == T0) then Some id_sub else None
  | (x::xs) =>
    match varElimX (((quotient t x) +' T1) *' (remainder t x) ) xs with
    | None => None
    | Some sigma =>
      Some (var_elim_update sigma x (quotient t x) (remainder t x))
    end
  end.

(*
Fixpoint varElimX' (t: term) (vars: list var) : option subL :=
  match vars with
  |  [] => if decision (t == T0) then Some id_sub else None
  (* WAS : |  [] => if beqv0_ground t then Some id_sub else None *)
  | (x::xs) =>
    match quotRem t x with
      (q,r) =>
      match varElimX ( (q +' T1) *' r) xs with
      | None => None
      | Some sigma =>
        Some (var_elim_update sigma x q r)
      end
    end
  end.

(** *** for now don't bother with simplify_sub *)
 *)

Definition varElim (t: term) : option subL :=
  varElimX t (vars_term t).

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

(** * Correctness Argument *)

(** Proof outline:

- As we go from t down through the recursive calls, if t is solvable
  then each derived term is solvable.  ([Lemma solvability_preserved])

- The base case, of a closed term, is either unsolvable or has the
  identity as an mgu

- If sigma is an mgu the derived term, then the
  updated sub is a reproductive solution to the original term [Lemma
  ??]

- So if t is solvable at all, it has an mgu, found by
  the algorithm

 *)

(** ** Behavior of the updated sub *)

(** *** Action of the updated sub on the chosen var x *)

Lemma update_on_var  sigma x q r :
  (var_elim_update sigma x q r) @ (V x) ==
  (var_image sigma x q r).

Proof.
  unfold var_elim_update.
  now rewrite apply_updated_sub_on.
Qed.

(** ***  Updated sub agrees with the old sub on the quotient and remainder *)

Lemma update_on_quotient : forall x sigma t,
    (var_elim_update sigma x (quotient t x) (remainder t x)) @ (quotient t x) ==
    sigma @ (quotient t x).
Proof.
  intros x sigma t.
  unfold var_elim_update.
  now rewrite (apply_updated_sub_off sigma x _ (quotient t x) (not_in_vars_quotient t x)).
Qed.

Lemma update_on_remainder : forall x sigma t,
    (var_elim_update sigma x (quotient t x) (remainder t x)) @ (remainder t x) ==
    sigma @ (remainder t x).
Proof.
  intros x sigma t.
  unfold var_elim_update.
  now rewrite (apply_updated_sub_off sigma x _ (remainder t x) (not_in_vars_remainder t x)).
Qed.

(** ** Variables in the derived term *)

Lemma derived_term_vars (x: var) (xs: list var) (t: term) :
  vars_term t <<=  x :: xs ->
  vars_term (derived_term t x) <<=  xs .
Proof.
  intros H.
  unfold derived_term.
  simpl; rewrite app_nil_r.
  apply incl_app.
  - assert (A:= cons_rem_swap x (vars_term t) xs H).
    assert (B:= vars_quotient_rem t x).
    now apply incl_tran with (rem (vars_term t) x).

  - assert (A:= cons_rem_swap x (vars_term t) xs H).
    assert (B:= vars_remainder_rem t x).
    now apply incl_tran with (rem (vars_term t) x).
Qed.

(** ** Solvability preserved in derived term *)

(**  Helper for [solvability-preserved]  *)

Lemma solvability_preserved_helper: forall q x r ,
    x *' q +' r == T0 ->
    (q +' T1) *' r == T0.
Proof.
  intros q x r H.
  cut ((q +' T1) *' (x *' q +' r) == (q +' T1) *' T0).
  intros.
  bsimp.
  - ring_simplify in H0.
    rewrite ord2M in H0.
    rewrite invA in H0.
    now rewrite idA in H0.
  - rewrite H.
    bsimp.
Qed.

Proposition solvability_preserved (t: term) (x: var) (tau: subL) :
  solves tau t ->
  solves tau (derived_term t x).
Proof.
  intros Hsolves.
  unfold solves in *.

  rewrite (factor_correct t x) in Hsolves.
  unfold factor in Hsolves.

  rewrite apply_sub_A_hom in Hsolves.
  rewrite apply_sub_M_hom in Hsolves.

  unfold derived_term.
  rewrite apply_sub_M_hom.
  now apply solvability_preserved_helper in Hsolves.
Qed.

Corollary unsolvability_reflected (t: term) (x: var) :
  ~ solvable (derived_term t x) ->   ~ solvable t.
Proof.
  intros H1 H2.
  unfold solvable in *.
  destruct H2 as [tau H21].
  assert (A:= solvability_preserved t x tau H21).
  firstorder.
Qed.

(**  NOTE! sigma' is the unifier at the recursive call, sigma is the updated one *)

(** Proof:

- (sigma t) = (sigma (x q + r) =

 (x * ((sigma' q) + 1) + (sigma' r) * (sigma' r) * (sigma' s))

- multiply that out, eventually get to

(sigma (q+1)* r) = (sigma t') = 0

 *)

(** ** Solvability reflected by  derived term *)

Lemma new_unifier_works : forall (t: term) (x: var) (delta: subL),
    solves delta (derived_term t x)  ->
    solves (var_elim_update delta x (quotient t x) (remainder t x )) t.
Proof.
  intros t x delta Hsolves.

  remember (quotient t x) as q.
  remember (remainder t x) as r.
  remember (var_elim_update delta x (quotient t x) (remainder t x)) as sigma'.

  (** suffices to show updated solves (factor t) *)

  apply (solves_compat (var_elim_update delta x q r) (factor t x)).

  - symmetry; apply factor_correct.
  - unfold factor. unfold solves.
    rewrite <- Heqq; rewrite <- Heqr.
    rewrite apply_sub_A_hom; rewrite apply_sub_M_hom.
    assert (a:= (update_on_var delta x q r )).
    rewrite a.
    unfold var_image.

    assert (b:= (update_on_quotient x delta t )).
    rewrite Heqq. rewrite Heqr.
    rewrite b.

    assert (c:= (update_on_remainder x delta t)).
    rewrite c.

    bsimp; rewrite assocM; rewrite ord2M; rewrite invA; bsimp.

    assert (tmp: forall q r, (q *' r +' r) == (q +' T1) *' r).
    intros; bsimp.
    rewrite tmp.

    unfold derived_term in Hsolves.
    rewrite <- Heqq in Hsolves.
    rewrite <- Heqr in Hsolves.

    rewrite <- Heqq. rewrite <- Heqr.
    apply Hsolves.
Qed.

(** Proof:

- let tau solve t

- assuming sigma' mgu , show that for all vars y,
(tau (sigma y)) = tau y

- since sigma' mgu, have, for all y,
(tau (sigma' y)) = tau y

- in case: y is not x: sigma agrees with sigma'.  OK

- in case y is x:

(tau (sigma x)) = ...multiply it out

 *)

(** The update of sigma agrees with sigma away from x *)

Lemma sigma_sigma'_agree (sigma: subL) x q r y:
  ~ (x = y) ->
  sigma @ (V y) = (var_elim_update sigma x q r) @ (V y).
Proof.
  intros Hneq.
  unfold var_elim_update.
  symmetry.
  apply (apply_updated_sub_off_var sigma x y _ Hneq).
Qed.

(** Helper: the interesting case for showing mgu *)

(** Another example of something that is just routine equational
  reasoning, but is manifest here as tedious rewriting.  Need a
  boolean-ring version of the ring tactic!! *)

Lemma new_unifier_mgu_help t tau sigma x :
  mgu sigma (derived_term t x) ->
  solves tau t ->
  tau @ (var_elim_update sigma x (quotient t x) (remainder t x) @ V x)
  == tau @ V x.
Proof.
  intros Hmgu_sigma Hsolves_tau_t.

  assert (Hfactor:= factor_correct t x).
  unfold factor in Hfactor.

  unfold var_elim_update.
  unfold var_image.
  rewrite apply_updated_sub_on.

  rewrite apply_sub_A_hom.
  rewrite apply_sub_M_hom.
  rewrite apply_sub_A_hom.
  rewrite apply_sub_T1_hom.

  assert (Hsolves_tau_t' := solvability_preserved t x tau Hsolves_tau_t).

  unfold mgu in Hmgu_sigma.
  unfold mgu_strong_all in Hmgu_sigma.
  destruct Hmgu_sigma.
  assert (b:= leq_on_terms tau sigma (H0 tau Hsolves_tau_t')).
  repeat rewrite b.

  rewrite dist'. rewrite idM'.
  rewrite assocA.
  rewrite 5 comA.
  rewrite assocA.

  unfold solves in Hsolves_tau_t.
  rewrite Hfactor in Hsolves_tau_t.
  rewrite <- apply_sub_M_hom.
  rewrite <- apply_sub_A_hom.

  assert (c: (remainder t x +' V x *' quotient t x) ==
             (V x *' quotient t x +' remainder t x) ).
  bsimp.

  rewrite c. rewrite Hsolves_tau_t.
  now rewrite idA'.
Qed.

Proposition new_unifier_mgu : forall (t: term) (x: var) (sigma: subL),
    mgu sigma (derived_term t x) ->
    mgu (var_elim_update sigma x (quotient t x) (remainder t x )) t.
Proof.
  intros t x sigma H_mgu_sigma.

  unfold mgu in H_mgu_sigma.
  unfold mgu_strongX in H_mgu_sigma.

  destruct H_mgu_sigma.

  set (q := (quotient t x)).
  set (r := (remainder t x)).
  split.
  - subst.  now apply new_unifier_works.
  - intros tau H_tau_solves_t y.

    (** since tau solves t, it solves t' *)

    assert (H_tau_solves_t' :=
              solvability_preserved t x tau H_tau_solves_t).

    assert (a:= H0 tau H_tau_solves_t').

    decide (y = x).
    + (** Case x=y *)

      rewrite e.
      apply (new_unifier_mgu_help t).
      unfold mgu. unfold mgu_strong_all.
      firstorder. easy.

    + (** Case x <> y *)

      assert (ugh := neq_comm y x n).
      assert (b:= sigma_sigma'_agree sigma x q r).
      assert (c:= b y ugh).
      rewrite <- c.
      apply a.
Qed.

(** ** Correctness of the None case *)

Lemma varElimX_None_backwards  (x: var) (xs: list var) (t: term) :
  varElimX t (x::xs) = None ->
  varElimX (derived_term t x) xs = None.
Proof.
  intros H.
  inversion H.
  unfold derived_term.
  destruct ( varElimX ((quotient t x +' T1) *' remainder t x) xs ).
  inversion H1.
  easy.
Qed.

Lemma varElimX_correct_None  (vars: list var) :
  forall (t: term),
    varElimX t vars = None ->
    (vars_term t) <<= vars ->
    ~ solvable t.
Proof.
  induction vars as [| v vars' IH].
  - intros t H1 H2 H3.
    apply incl_nil_eq in H2.
    assert (A:= no_vars_Ground t H2).
    simpl in H1.
    decide (t==T0).
    + inversion H1.
    + apply characterizing_solvability_2 in H3.
      assert (B:= Ground_T0_or_T1 t A).
      now inversion B.
  - intros t H1 H2.
    apply varElimX_None_backwards in H1.
    assert (A:= derived_term_vars v vars' t H2).
    assert (B:= IH (derived_term t v) H1 A).
    now apply (unsolvability_reflected t v).
Qed.

Proposition varElim_correct_None t :
  varElim t = None ->
  ~ solvable t.
Proof.
  intros H.
  unfold varElim in H.
  now apply varElimX_correct_None with (vars_term t).
Qed.

(** ** Correctness of the Some case *)

Lemma varElimX_Some_backwards  (x: var) (xs: list var) (t: term) sigma :
  varElimX t (x::xs) = Some sigma ->
  (exists sigma', varElimX (derived_term t x) xs = Some sigma'
                  /\ sigma = (var_elim_update sigma'
                                              x
                                              (quotient t x)
                                              (remainder t x))).
Proof.
  intros H.
  inversion H.
  unfold derived_term.
  destruct ( varElimX ((quotient t x +' T1) *' remainder t x) xs ).
  inversion H1.
  - exists s; easy.
  - easy.
Qed.

Lemma varElimX_correct_Some  (vars: list var) :
  forall (t: term) (upd: subL),
    varElimX t vars = Some upd ->
    (vars_term t) <<= vars ->
    mgu upd t.
Proof.
  induction vars as [| x xs IH].
  - intros t upd H1 H2.
    apply incl_nil_eq in H2.
    assert (A:= no_vars_Ground t H2).
    simpl in H1.
    decide (t==T0).
    + inversion H1.
      now apply mgu_T0.
    + easy.

  (* apply characterizing_solvability_2 in H3. *)
  (* assert (B:= Ground_T0_or_T1 t A). *)
  (* now inversion B. *)
  - intros t upd H1 H2.
    apply varElimX_Some_backwards in H1.
    destruct H1 as [sigma' H11].
    destruct H11 as [l r].

    assert (A:= derived_term_vars x xs t H2).
    assert (B:= IH (derived_term t x) sigma' l A ).
    rewrite r.
    now apply new_unifier_mgu in B.
Qed.

Proposition varElim_correct_Some t sigma :
  varElim t = Some sigma ->
  mgu sigma t.
Proof.
  intros H.
  unfold varElim in H.
  now apply varElimX_correct_Some with (vars_term t).
Qed.

(** ** Put the pieces together *)

Theorem varElim_correctness  (t: term) :
  match (varElim t) with
  | None => ~ solvable t
  | Some sigma => mgu sigma t
  end.
Proof.
  case_eq (varElim t).
  - intros sigma.
    exact (varElim_correct_Some t sigma ).
  - exact (varElim_correct_None t).
Qed.


(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses>                       *)
(************************************************************************)

Require Import digits.
Require Import ub.
Require Import rep.
Require Import Rseries.
Require Import Rdefinitions.
Require Import RIneq.
Require Import Rcomplete.
 Require Import R_addenda.
Require Import Fourier_solvable_ineqs.

(** This file deals with the correctness of the representation predicate [rep]. *)

Lemma lb_Cauchy:forall alpha, Rseries.Cauchy_crit (lb alpha).
Proof.
 intros alpha.
 intros eps H_eps_pos.
 set (N:=Zabs_nat (up (2 / eps))).
 exists N.
 intros m n Hn Hm.
 unfold Rfunctions.R_dist.
 apply Raxioms.Rlt_trans with (Qminus (ub alpha N)(lb alpha N)).
 set (u_N:=ub alpha N); set (l_N:=lb alpha N); set (l_n:=lb alpha n);set (l_m:=lb alpha m).

  apply Rbasic_fun.Rabs_def1.

   repeat rewrite <- Q_to_Rminus; apply Q_to_Rlt.
   apply Qlt_Zero_Qminus.
   stepr (Qplus (Qminus u_N l_m)(Qminus l_n l_N)); try ring.
   apply Qlt_le_reg_pos.
    apply Qlt_Qminus_Zero; subst u_N l_m; apply lb_lt_ub.
    apply Qle_Qminus_Zero; subst l_N l_n; apply lb_nondecreasing; auto.

   apply RIneq.Ropp_lt_cancel; rewrite RIneq.Ropp_involutive; rewrite RIneq.Ropp_minus_distr.
   repeat rewrite <- Q_to_Rminus; apply Q_to_Rlt.
   apply Qlt_Zero_Qminus.
   stepr (Qplus(Qminus u_N l_n)(Qminus l_m l_N)); try ring.
   apply Qlt_le_reg_pos.
    apply Qlt_Qminus_Zero; subst u_N l_n; apply lb_lt_ub.
    apply Qle_Qminus_Zero; subst l_N l_m; apply lb_nondecreasing; auto.

   apply RIneq.Rle_lt_trans with (Qdiv (Z_to_Q (Z_of_nat 2)) (Qplus (Z_to_Q (Z_of_nat N)) (Z_to_Q (Z_of_nat 1)))).

    apply Q_to_Rle; apply thesis_5_7_9.

    (* TP: 0 < IZR N +1 *)
    assert (H_N_plus_one_pos:(0 < Raxioms.IZR N +1)%R);
    [ apply RIneq.Rle_lt_trans with (Raxioms.IZR N); rewrite <- INR_IZR_INZ; auto with real| ].
    (* TP: IZR N +1 <> 0 *)
    assert (H_N_plus_one_nonzero:(Raxioms.IZR N +1<>0)%R); auto with real.

    elim (Raxioms.archimed (2/eps)); intros H_N _.
    rewrite <- (Z_of_nat_Zabs_nat_pos (up(2/eps))) in H_N.
    rewrite Q_to_Rdiv.
    rewrite Q_to_Rplus.
    repeat rewrite Z_to_Q_to_R_IZR.
    assert (2/eps-1<(Raxioms.IZR N))%R.

     apply Raxioms.Rlt_trans with (2/eps)%R; auto.
      apply RIneq.Rminus_lt.
      stepl (Ropp (Raxioms.IZR 1%nat)).
      simpl.
      apply RIneq.Ropp_lt_gt_0_contravar.
      apply Fourier_util.Rlt_zero_1.
      simpl; ring.

     simpl.
     apply Rmult_lt_reg_l with ((Raxioms.IZR N + 1)*(Rinv eps))%R.
     apply Fourier_util.Rlt_mult_inv_pos; auto.

      stepl (2/eps)%R.
       stepr (Raxioms.IZR N+1)%R.
        apply Rplus_lt_reg_r with (Ropp 1).
	stepl (2/eps -1)%R; try ring.
	stepr (Raxioms.IZR N)%R; auto; try ring.
       field; auto with real.
      field; auto with real.

    natq_S N; natq_zero; apply Z_to_Q_not_eq; apply inj_neq; discriminate.

    apply le_O_IZR.
    apply RIneq.Rlt_le.
    apply Raxioms.Rlt_trans with (2 / eps)%R; auto;
    unfold Rdiv; apply Fourier_util.Rlt_mult_inv_pos; auto; apply DiscrR.Rlt_R0_R2.
Qed.

(** This is the real number in #[#-1,+1#]# represented by [alpha] *)
Definition real_value alpha := (proj1_sig (Rcomplete.R_complete (lb alpha) (lb_Cauchy alpha))).

Lemma rep_lb: forall (k:nat) alpha r, rep alpha r -> ((lb alpha k)<=r)%R.
Proof.
 induction k.
  (* 0 *)
  intros alpha r H_rep.
  simpl; rewrite Q_to_R_Qneg_One.
  elim (rep_inv_interval _ _ H_rep); trivial.
  (* S k *)
  intros [[ | | ] alpha] r H_rep; rewrite lb_S_n; unfold hd,tl; set (l':=(lb alpha k)).
   (* L *)
   (* TP: Zero <= l'+ 1 *)
   assert (H_l'_one_nonneg: Zero <= l'+1);
   [ stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_low|].
   (* TP: Zero < l'+3 *)
   assert (H_l'_three_pos: Zero < l'+3);
   [ apply Qle_lt_trans with (l'+1); auto; apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|].

   generalize (Q_to_Rle _ _ H_l'_one_nonneg);
   generalize (Q_to_Rlt _ _ H_l'_three_pos);
   do 2 rewrite Q_to_Rplus; rewrite Q_to_R_Zero;
   do 2 rewrite Z_to_Q_to_R_IZR; intros H1 H2; simpl in H1,H2.

   rewrite as_Moebius_Q_L; trivial; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   rewrite Q_to_Rplus; rewrite Q_to_Rminus;
   repeat rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_L_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_L_inv _ _ H_rep)); clear IHk; fold l'; intro IHk;
   apply rep_lb_auxiliary_L; auto; stepr (l'+(2+1))%R; auto; ring.
   (* R *)
   (* TP: Zero <= -l'+ 1 *)
   assert (H_min_l'_one_nonneg: Zero <= -l'+1);
   [stepr (1-l'); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_up|].
   (* TP: Zero < -l'+3 *)
   assert (H_min_l'_three_pos: Zero < -l'+3);
   [ apply Qle_lt_trans with ((-l')+1); auto;
     apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|].

   generalize (Q_to_Rle _ _ H_min_l'_one_nonneg);
   generalize (Q_to_Rlt _ _ H_min_l'_three_pos);
   do 2 rewrite Q_to_Rplus; rewrite Q_to_R_Zero; rewrite Q_to_Ropp;
   do 2 rewrite Z_to_Q_to_R_IZR; intros H1 H2; simpl in H1,H2.

   rewrite as_Moebius_Q_R; trivial; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   repeat rewrite Q_to_Rplus; rewrite Q_to_Ropp;
   repeat rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_R_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_R_inv _ _ H_rep)); clear IHk; fold l'; intro IHk;
   apply rep_lb_auxiliary_R; auto; stepr (-l'+(2+1))%R; auto; ring.
   (* M *)
   rewrite as_Moebius_Q_M; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_M_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_M_inv _ _ H_rep)); clear IHk; fold l'; intro IHk;
   apply rep_lb_auxiliary_M; auto.
Qed.

Lemma rep_ub: forall (k:nat) alpha r, rep alpha r -> (r<=(ub alpha k))%R.
Proof.
 induction k.
  (* 0 *)
  intros alpha r H_rep;
  unfold ub; rewrite Z_to_Q_to_R_IZR; simpl;
  elim (rep_inv_interval _ _ H_rep); trivial.
  (* S k *)
  intros [[ | | ] alpha] r H_rep; rewrite ub_S_n; unfold hd,tl; set (u':=(ub alpha k)).
   (* L *)
   (* TP: Zero <= u'+ 1 *)
   assert (H_u'_one_nonneg: Zero <= u'+1);
   [ stepr (u'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst u'; apply ub_is_in_base_interval_low|].
   (* TP: Zero < u'+3 *)
   assert (H_u'_three_pos: Zero < u'+3);
   [ apply Qle_lt_trans with (u'+1); auto; apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|].

   generalize (Q_to_Rle _ _ H_u'_one_nonneg);
   generalize (Q_to_Rlt _ _ H_u'_three_pos);
   do 2 rewrite Q_to_Rplus; rewrite Q_to_R_Zero;
   do 2 rewrite Z_to_Q_to_R_IZR; intros H1 H2; simpl in H1,H2.

   rewrite as_Moebius_Q_L; trivial; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   rewrite Q_to_Rplus; rewrite Q_to_Rminus;
   repeat rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_L_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_L_inv _ _ H_rep)); clear IHk; fold u'; intro IHk;
   apply rep_ub_auxiliary_L; auto; stepr (u'+(2+1))%R; auto; ring.
   (* R *)
   (* TP: Zero <= -u'+ 1 *)
   assert (H_min_u'_one_nonneg: Zero <= -u'+1);
   [stepr (1-u'); try ring; apply Qle_Qminus_Zero; subst u'; apply ub_is_in_base_interval_up|].
   (* TP: Zero < -u'+3 *)
   assert (H_min_u'_three_pos: Zero < -u'+3);
   [ apply Qle_lt_trans with ((-u')+1); auto;apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|].

   generalize (Q_to_Rle _ _ H_min_u'_one_nonneg);
   generalize (Q_to_Rlt _ _ H_min_u'_three_pos);
   do 2 rewrite Q_to_Rplus; rewrite Q_to_R_Zero; rewrite Q_to_Ropp;
   do 2 rewrite Z_to_Q_to_R_IZR; intros H1 H2; simpl in H1,H2.

   rewrite as_Moebius_Q_R; trivial; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   repeat rewrite Q_to_Rplus; rewrite Q_to_Ropp;
   repeat rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_R_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_R_inv _ _ H_rep)); clear IHk; fold u'; intro IHk;
   apply rep_ub_auxiliary_R; auto; stepr (-u'+(2+1))%R; auto; ring.
   (* M *)
   rewrite as_Moebius_Q_M; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_M_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_M_inv _ _ H_rep)); clear IHk; fold u'; intro IHk;
   apply rep_ub_auxiliary_M; auto.
Qed.

Lemma rep_interval : forall (k:nat) alpha r1 r2, rep alpha r1 -> rep alpha r2 ->  (-2/(k+1) <= r1-r2 <= 2/(k+1))%R.
Proof.
 intros k alpha r1 r2 Hr1 Hr2.
 (* TP: O <= k  *)
 assert (H_k_nonneg:  0 <= k); [ apply Z_to_Qle; apply inj_le; auto with arith|];
 (* TP: Zero < k + 1 *)
 assert (H_k_one_pos: Zero < k + 1); [natq_zero; qnat_one; natq_S k; natq_S (S k); auto|].

 generalize (rep_lb k _ _ Hr1); generalize (rep_lb k _ _ Hr2); generalize (rep_ub k _ _ Hr1); generalize (rep_ub k _ _ Hr2);
 intros H_r2_u H_r1_u H_r2_l H_r1_l;
 generalize (Q_to_Rle _ _ (thesis_5_7_9 k alpha));
 rewrite Q_to_Rdiv; auto; rewrite Q_to_Rminus; rewrite Q_to_Rplus;
 rewrite Z_to_Q_to_R_IZR; simpl; fold Qone; rewrite Q_to_R_Qone; intro H_ub_lb; rewrite Rdiv_Ropp_numerator.
  apply rep_interval_auxiliary with (lb alpha k) (ub alpha k); trivial.
  rewrite <- Q_to_R_Qone; rewrite <- Q_to_R_Zero; rewrite <- Q_to_Rplus; apply Rlt_not_eq'; apply Q_to_Rlt; auto.
Qed.

Lemma real_value_base_interval:forall alpha, (-1 <= real_value alpha <= 1)%R.
Proof.
 intros alpha; unfold real_value.
 destruct (R_complete (fun n : nat => lb alpha n) (lb_Cauchy alpha)) as [y Hy]; simpl;
 generalize RiemannInt.Rle_cv_lim; intro H_sandwich; split.

  apply (H_sandwich (fun (n:nat)=>(-1)%R) (fun n : nat => lb alpha n) (-1)%R y); trivial.
   intros n; rewrite <- Q_to_R_Qneg_One; apply Q_to_Rle; apply lb_is_in_base_interval_low.
   apply CV_const.
  apply (H_sandwich (fun n : nat => lb alpha n) (fun (n:nat)=>(1)%R) y (1)%R); trivial.
   intros n; rewrite <- Q_to_R_Qone; apply Q_to_Rle; apply lb_is_in_base_interval_up.
   apply CV_const.
Qed.

Lemma real_value_L:forall alpha, real_value (Cons LL alpha) = (((real_value alpha) -1 )/((real_value alpha)+ 3))%R.
Proof.
 intros alpha; unfold real_value;
 destruct (R_complete (fun n : nat => lb (Cons LL alpha) n) (lb_Cauchy (Cons LL alpha))) as [x H_x];
 destruct (R_complete (fun n : nat => lb alpha n) (lb_Cauchy alpha)) as [y Hy]; simpl;
 apply SeqProp.UL_sequence with (fun n : nat => lb (Cons LL alpha) n); trivial;
 apply CV_shift_S';
 apply CV_extensionality with (fun n=>(((lb alpha n) - 1) / ((lb alpha n) + 3))%R).

  intro n;
  rewrite lb_S_n;
   set (l':=lb alpha n);
   (* TP: Zero <= l'+ 1 *)
   assert (H_l'_one_nonneg: Zero <= l'+1);
   [ stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_low|];
   (* TP: Zero < l'+3 *)
   assert (H_l'_three_pos: Zero < l'+3);
   [ apply Qle_lt_trans with (l'+1); auto; apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|];
   auto.

  unfold hd, tl; fold l';
  rewrite as_Moebius_Q_L; trivial; unfold tl; rewrite Q_to_Rdiv; auto;
   rewrite Q_to_Rminus; rewrite Q_to_Rplus;  do 2 rewrite Z_to_Q_to_R_IZR; simpl; replace (2+1)%R with 3%R; trivial; ring.

  apply (Rsqrt_def.continuity_seq (fun y=>((y - 1) / (y + 3))%R) (lb alpha) y); trivial;
  unfold Ranalysis1.continuity_pt; unfold Rderiv.continue_in; unfold Rdiv;
  apply (Rlimit.limit_mul (fun y=>(y-1)%R) (fun y=>(Rinv (y+3)))).
   apply (Rlimit.limit_minus (fun y=>y) (fun y=>1%R)).
    apply Rlimit.lim_x.
    apply (Rlimit.limit_free (fun y=>1%R)); exact y.
   apply (Rlimit.limit_inv (fun y=>(y+3)%R)).
    apply (Rlimit.limit_plus (fun y=>y) (fun y=>3%R)).
     apply Rlimit.lim_x.
     apply (Rlimit.limit_free (fun y=>3%R)); exact y.
    apply Rlt_not_eq';
    unfold Un_cv in Hy;
    destruct (Hy 2%R) as [N H_N]; try red; auto;
    assert (H_N_le:N>=N); auto; destruct (Rbasic_fun.Rabs_def2 _ _ (H_N N H_N_le)) as [H1 H2];
    generalize (Q_to_Rle _ _ (lb_is_in_base_interval_low N alpha));
    rewrite Q_to_Ropp; rewrite Q_to_R_Qone;
    apply very_sepcific_0; trivial.
Qed.

Lemma real_value_R:forall alpha, real_value (Cons RR alpha) = (((real_value alpha) +1 )/(-(real_value alpha)+ 3))%R.
Proof.
 intros alpha; unfold real_value;
 destruct (R_complete (fun n : nat => lb (Cons RR alpha) n) (lb_Cauchy (Cons RR alpha))) as [x H_x];
 destruct (R_complete (fun n : nat => lb alpha n) (lb_Cauchy alpha)) as [y Hy]; simpl;
 apply SeqProp.UL_sequence with (fun n : nat => lb (Cons RR alpha) n); trivial;
 apply CV_shift_S';
 apply CV_extensionality with (fun n=>(((lb alpha n) + 1) / (-(lb alpha n) + 3))%R).
  intro n;
  rewrite lb_S_n;
   set (l':=lb alpha n);
   (* TP: Zero <= -l'+ 1 *)
   assert (H_min_l'_one_nonneg: Zero <= -l'+1);
   [stepr (1-l'); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_up|];
   (* TP: Zero < -l'+3 *)
   assert (H_min_l'_three_pos: Zero < -l'+3);
   [ apply Qle_lt_trans with ((-l')+1); auto;
     apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|];
   auto.

  unfold hd, tl; fold l'; rewrite as_Moebius_Q_R; trivial; unfold tl;
   rewrite Q_to_Rdiv; auto; do 2 rewrite Q_to_Rplus;  rewrite Q_to_Ropp; do 2 rewrite Z_to_Q_to_R_IZR; simpl;
   replace (2+1)%R with 3%R; trivial; ring.

  apply (Rsqrt_def.continuity_seq (fun y=>((y + 1) / (-y + 3))%R) (lb alpha) y); trivial;
  unfold Ranalysis1.continuity_pt; unfold Rderiv.continue_in; unfold Rdiv;
  apply (Rlimit.limit_mul (fun y=>(y+1)%R) (fun y=>(Rinv (-y+3)))).
   apply (Rlimit.limit_plus (fun y=>y) (fun y=>1%R)).
    apply Rlimit.lim_x.
    apply (Rlimit.limit_free (fun y=>1%R)); exact y.
   apply (Rlimit.limit_inv (fun y=>(-y+3)%R)).
    apply (Rlimit.limit_plus (fun y=>(Ropp y)) (fun y=>3%R)).
     apply (Rlimit.limit_Ropp (fun y=>y)); apply Rlimit.lim_x.
     apply (Rlimit.limit_free (fun y=>3%R)); exact y.
    apply Rlt_not_eq';
    unfold Un_cv in Hy;
    destruct (Hy 2%R) as [N H_N]; try red; auto;
    assert (H_N_le:N>=N); auto; destruct (Rbasic_fun.Rabs_def2 _ _ (H_N N H_N_le)) as [H1 H2];
    generalize (Q_to_Rle _ _ (lb_is_in_base_interval_up N alpha));
    rewrite Q_to_R_Qone.
    apply very_sepcific_1; trivial.
Qed.

Lemma real_value_M:forall alpha, real_value (Cons MM alpha) = ((real_value alpha)/3)%R.
Proof.
 intros alpha; unfold real_value;
 destruct (R_complete (fun n : nat => lb (Cons MM alpha) n) (lb_Cauchy (Cons MM alpha))) as [x H_x];
 destruct (R_complete (fun n : nat => lb alpha n) (lb_Cauchy alpha)) as [y Hy]; simpl;
 apply SeqProp.UL_sequence with (fun n : nat => lb (Cons MM alpha) n); trivial;
 apply CV_shift_S';
 apply CV_extensionality with (fun n=>((lb alpha n)/3)%R).
  intro n;
  rewrite lb_S_n;
  rewrite as_Moebius_Q_M; unfold tl; rewrite Q_to_Rdiv; auto.
   rewrite Z_to_Q_to_R_IZR; simpl; replace (2+1)%R with 3%R; trivial; ring.

  apply (Rsqrt_def.continuity_seq (fun y=>(y/3)%R) (lb alpha) y); trivial;
  unfold Ranalysis1.continuity_pt; unfold Rderiv.continue_in; unfold Rdiv;
  apply (Rlimit.limit_mul (fun y=>y) (fun y=>(Rinv 3))).
   apply Rlimit.lim_x.
   apply (Rlimit.limit_inv (fun y=>(3)%R)); auto.
   apply (Rlimit.limit_free (fun y=>3%R)); exact y.
Qed.

Lemma real_value_digits: forall d alpha, real_value (Cons d alpha) = as_Moebius d (real_value alpha).
Proof.
 intros [ | | ] alpha; unfold as_Moebius, fst, snd, map_digits;
 [ rewrite real_value_L
 | rewrite real_value_R
 | rewrite real_value_M
 ];
 qZ_numerals; realify_Q; auto; field.
 assert (H_alpha_base:=proj1 (real_value_base_interval alpha)); auto.
 assert (H_alpha_base:=proj2 (real_value_base_interval alpha)); apply Rlt_not_eq'; Fourier.fourier.
Qed.

Theorem rep_real_value : forall alpha, rep alpha (real_value alpha).
Proof.
 cofix.
 intros [[ | | ] alpha].
  rewrite real_value_L; apply rep_L with alpha;
   [ apply real_value_base_interval
   | apply rep_real_value
   | unfold bisim; apply EqSt_reflex].
  rewrite real_value_R; apply rep_R with alpha;
   [ apply real_value_base_interval
   | apply rep_real_value
   | unfold bisim; apply EqSt_reflex].
  rewrite real_value_M; apply rep_M with alpha;
   [ apply real_value_base_interval
   | apply rep_real_value
   | unfold bisim; apply EqSt_reflex].
Qed.

Theorem real_value_implies_rep: forall alpha r, real_value alpha = r -> rep alpha r.
Proof.
 intros [[ | | ] alpha] r Hrep.
  rewrite real_value_L in Hrep; rewrite <- Hrep;
  apply (rep_L alpha (Cons LL alpha) (real_value alpha) (real_value_base_interval alpha) (rep_real_value alpha) (EqSt_reflex _)).
  rewrite real_value_R in Hrep; rewrite <- Hrep;
  apply (rep_R alpha (Cons RR alpha) (real_value alpha) (real_value_base_interval alpha) (rep_real_value alpha) (EqSt_reflex _)).
  rewrite real_value_M in Hrep; rewrite <- Hrep;
  apply (rep_M alpha (Cons MM alpha) (real_value alpha) (real_value_base_interval alpha) (rep_real_value alpha) (EqSt_reflex _)).
Qed.

Theorem rep_implies_real_value: forall alpha r, rep alpha r -> real_value alpha = r.
Proof.
 intros alpha r H_rep.
 apply SeqProp.cond_eq.
 intros eps H_eps.
 set (N:=Zabs_nat (up (2 / eps))).
 destruct (rep_interval N _ _ _  (rep_real_value alpha) H_rep) as [H1 H2].
 elim (Raxioms.archimed (2/eps)); intros H_N _.
 rewrite <- (Z_of_nat_Zabs_nat_pos (up(2/eps))) in H_N; [|apply Zlt_le_weak; auto].
 apply Rbasic_fun.Rabs_def1.

   apply Rle_lt_trans with (2/((Raxioms.IZR N)+1))%R.
    stepr (2 / (N + 1))%R; auto.
    rewrite Z_to_Q_to_R_IZR; trivial.
    apply N_2_epsilon_plus_one; auto.

   apply Rlt_le_trans with (-(2/((Raxioms.IZR N)+1)))%R.
    apply Ropp_lt_contravar; apply N_2_epsilon_plus_one; auto.
    stepl (-2 / (N + 1))%R; auto.
    rewrite Z_to_Q_to_R_IZR; unfold Rdiv; rewrite Ropp_mult_distr_l_reverse; trivial.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : natural) (lf2 : lst) : natural := len (append lf2 Nil).


From Hammer Require Import Hammer.

From Topology Require Export TopologicalSpaces.
From Topology Require Export Subbases.
From Topology Require Export Continuity.
From Topology Require Export Nets.
From ZornsLemma Require Export InverseImage.
From ZornsLemma Require Import FiniteIntersections.

Section WeakTopology.

Variable X:Type.
Variable A:Type.
Variable Y:A->TopologicalSpace.
Variable f:forall a:A, X->point_set (Y a).

Inductive weak_topology_subbasis : Family X :=
| intro_fa_inv_image: forall (a:A) (V:Ensemble (point_set (Y a))),
open V -> In weak_topology_subbasis (inverse_image (f a) V).

Definition WeakTopology : TopologicalSpace :=
Build_TopologicalSpace_from_subbasis X weak_topology_subbasis.

Lemma weak_topology_makes_continuous_funcs:
forall a:A, continuous (f a) (X:=WeakTopology).
Proof. hammer_hook "WeakTopology" "WeakTopology.weak_topology_makes_continuous_funcs".
intro.
red; intros.
pose proof (Build_TopologicalSpace_from_subbasis_subbasis
_ weak_topology_subbasis).
apply H0.
constructor; trivial.
Qed.

Lemma weak_topology_is_weakest: forall (T':Family X)
(H1:_) (H2:_) (H3:_),
(forall a:A, continuous (f a)
(X := Build_TopologicalSpace X T' H1 H2 H3)) ->
forall U:Ensemble X, @open WeakTopology U -> T' U.
Proof. hammer_hook "WeakTopology" "WeakTopology.weak_topology_is_weakest".
intros.
destruct H0.
apply H1.
intros.
apply H0 in H4.
induction H4.
exact H3.
destruct H4.
apply H; trivial.
apply H2; trivial.
Qed.

Section WeakTopology_and_Nets.

Variable I:DirectedSet.
Hypothesis I_nonempty: inhabited (DS_set I).
Variable x:Net I WeakTopology.
Variable x0:X.

Lemma net_limit_in_weak_topology_impl_net_limit_in_projections :
net_limit x x0 ->
forall a:A, net_limit (fun i:DS_set I => (f a) (x i)) ((f a) x0).
Proof. hammer_hook "WeakTopology" "WeakTopology.net_limit_in_weak_topology_impl_net_limit_in_projections".
intros.
apply continuous_func_preserves_net_limits; trivial.
apply continuous_func_continuous_everywhere.
apply weak_topology_makes_continuous_funcs.
Qed.

Lemma net_limit_in_projections_impl_net_limit_in_weak_topology :
(forall a:A, net_limit (fun i:DS_set I => (f a) (x i))
((f a) x0)) ->
net_limit x x0.
Proof. hammer_hook "WeakTopology" "WeakTopology.net_limit_in_projections_impl_net_limit_in_weak_topology".
intros.
red; intros.
assert (@open_basis WeakTopology
(finite_intersections weak_topology_subbasis)).
apply Build_TopologicalSpace_from_open_basis_basis.
destruct (open_basis_cover _ H2 x0 U) as [V [? [? ?]]]; trivial.
assert (for large i:DS_set I, In V (x i)).
clear H4.
induction H3.
destruct I_nonempty.
exists X0; constructor.

destruct H3.
destruct H5.
apply eventually_impl_base with (fun i:DS_set I => In V (f a (x i))).
intros.
constructor; trivial.
apply H; trivial.

apply eventually_impl_base with
(fun i:DS_set I => In U0 (x i) /\ In V (x i)).
intros.
destruct H6.
constructor; trivial.
destruct H5.
apply eventually_and;
(apply IHfinite_intersections || apply IHfinite_intersections0);
trivial.

refine (eventually_impl_base _ _ _ H6).
intro; apply H4.
Qed.

End WeakTopology_and_Nets.

End WeakTopology.

Arguments WeakTopology {X} {A} {Y}.
Arguments weak_topology_subbasis {X} {A} {Y}.

Require Import ClassicalChoice.

Section WeakTopology1.

Variable X:Type.
Variable Y:TopologicalSpace.
Variable f:X->point_set Y.

Definition WeakTopology1 := WeakTopology (True_rect f).

Lemma weak_topology1_topology:
forall U:Ensemble X, @open WeakTopology1 U ->
exists V:Ensemble (point_set Y), open V /\ U = inverse_image f V.
Proof. hammer_hook "WeakTopology" "WeakTopology.weak_topology1_topology".
intros.
red in H.
simpl in H.
destruct H.
assert (forall U:Ensemble X,
In (finite_intersections (weak_topology_subbasis (True_rect f))) U ->
exists V:Ensemble (point_set Y), open V /\ U = inverse_image f V).
intros.
induction H0.
exists Full_set.
split.
apply open_full.
rewrite inverse_image_full.
trivial.
destruct H0.
destruct a.
simpl.
exists V.
split; trivial.

destruct IHfinite_intersections as [V1 [? ?]].
destruct IHfinite_intersections0 as [V2 [? ?]].
exists (Intersection V1 V2).
split.
auto with topology.
rewrite H3; rewrite H5.
rewrite inverse_image_intersection.
trivial.

destruct (choice (fun (U:{U:Ensemble X | In F U}) (V:Ensemble (point_set Y))
=> open V /\ proj1_sig U = inverse_image f V)) as [choice_fun].
intros.
destruct x as [U].
simpl.
apply H0; auto with sets.
exists (IndexedUnion choice_fun).
split.
apply open_indexed_union.
apply H1.
apply Extensionality_Ensembles; split; red; intros.
destruct H2.
constructor.
exists (exist _ S H2).
pose proof (H1 (exist _ S H2)).
destruct H4.
simpl in H5.
rewrite H5 in H3.
destruct H3.
exact H3.

destruct H2.
inversion H2.
pose proof (H1 a).
destruct H5.
destruct a as [U].
exists U; trivial.
simpl in H6.
rewrite H6.
constructor.
exact H3.
Qed.

Lemma weak_topology1_makes_continuous_func:
continuous f (X:=WeakTopology1).
Proof. hammer_hook "WeakTopology" "WeakTopology.weak_topology1_makes_continuous_func".
exact (weak_topology_makes_continuous_funcs _ _ _ (True_rect f) I).
Qed.

End WeakTopology1.

Arguments WeakTopology1 {X} {Y}.