(* week-02_backward-and-forward.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 25 Aug 2017 *)

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

(* Learning goals:

   * using assert to declare a new assumption

   * using apply among the assumptions
*)

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

(* Prove foo:

   (1) backward, in a goal-directed way

   (2) forward, from the assumptions
*)

Proposition foo :
  forall P Q R1 R2 : Prop,
    P -> (P -> Q) -> (Q -> R1) /\ (Q -> R2) -> R1 /\ R2.
Proof.
  intros P Q R1 R2.
  intros H_P H_P_implies_Q [H_Q_implies_R1 H_Q_implies_R2].

  split.

  apply H_Q_implies_R1.
  apply H_P_implies_Q.
  apply H_P.

  apply H_Q_implies_R2.
  apply H_P_implies_Q.
  apply H_P.

Restart.

  intros P Q R1 R2.
  intros H_P H_P_implies_Q [H_Q_implies_R1 H_Q_implies_R2].

  assert (H1 := H_P).
  apply H_P_implies_Q in H1.
  apply H_Q_implies_R1 in H1.
  assert (H2 := H_P).
  apply H_P_implies_Q in H2.
  apply H_Q_implies_R2 in H2.
  split.
    apply H1.
  apply H2.
Qed.

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

(* Prove bar:

   (1) by using the split tactic as early as possible

   (2) by using the split tactic as late as possible
*)

Proposition bar :
  forall P1 P2 Q R1 R2 T1 T2 : Prop,
    P1 -> (P1 -> P2) -> (P2 -> Q) -> (Q -> R1) -> (R1 -> T1) -> (Q -> R2) -> (R2 -> T2) -> T1 /\ T2.
Proof.

  (* Here, use the split tactic as early as possible. *)
  intros P1 P2 Q R1 R2 T1 T2.
  intros H_P1 H_P1_implies_P2 H_P2_implies_Q H_Q_implies_R1 H_R1_implies_T1 H_Q_implies_R2 H_R2_implies_T2.

  split.

  apply H_R1_implies_T1.
  apply H_Q_implies_R1.
  apply H_P2_implies_Q.
  apply H_P1_implies_P2.
  apply H_P1.

  apply H_R2_implies_T2.
  apply H_Q_implies_R2.
  apply H_P2_implies_Q.
  apply H_P1_implies_P2.
  apply H_P1.

  Restart.
  (* Here, use the split tactic as late as possible. *)

  intros P1 P2 Q R1 R2 T1 T2.
  intros H_P1 H_P1_implies_P2 H_P2_implies_Q H_Q_implies_R1 H_R1_implies_T1 H_Q_implies_R2 H_R2_implies_T2.

  assert (H1 := H_P1).
  apply H_P1_implies_P2 in H1.
  apply H_P2_implies_Q in H1.
  apply H_Q_implies_R1 in H1.
  apply H_R1_implies_T1 in H1.

  assert (H2 := H_P1).
  apply H_P1_implies_P2 in H2.
  apply H_P2_implies_Q in H2.
  apply H_Q_implies_R2 in H2.
  apply H_R2_implies_T2 in H2.

  split.
    apply H1.
  apply H2.

Qed.

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

(* Prove baz:

   (1) by using the split tactic as early as possible

   (2) by using the split tactic as late as possible
*)

Proposition baz :
  forall P Q R T U1 U2 : Prop,
    P -> (P -> Q) -> (Q -> R) -> (R -> T) -> (T -> U1) -> (T -> U2) -> U1 /\ U2.
Proof.
  intros P Q R T U1 U2.
  intros H_P H_P_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U1 H_T_implies_U2.

  (* Here, use the split tactic as early as possible. *)

  split.

  apply H_T_implies_U1.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  apply H_P_implies_Q.
  apply H_P.

  apply H_T_implies_U2.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  apply H_P_implies_Q.
  apply H_P.

  Restart.

  (* Here, use the split tactic as late as possible. *)

  intros P Q R T U1 U2.
  intros H_P H_P_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U1 H_T_implies_U2.

  assert (H1 := H_P).
  apply H_P_implies_Q in H1.
  apply H_Q_implies_R in H1.
  apply H_R_implies_T in H1.
  assert (H2 := H1).

  apply H_T_implies_U1 in H1.
  apply H_T_implies_U2 in H2.

  split.
    apply H1.
  apply H2.
Qed.

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

(* Complete the proofs of baz_dual,
   and then compare them.
*)

Proposition baz_dual_early :
  forall P1 P2 Q R T U : Prop,
    (P1 \/ P2) -> (P1 -> Q) -> (P2 -> Q) -> (Q -> R) -> (R -> T) -> (T -> U) -> U.
Proof.
  intros P1 P2 Q R T U.
  intros H_P1_or_P2 H_P1_implies_Q H_P2_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.
  (* use "destruct H_P1_or_P2 as [H_P1 | H_P2]." as early as you can *)

  destruct H_P1_or_P2 as [H_P1 | H_P2].

  apply H_T_implies_U.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  apply H_P1_implies_Q.
  apply H_P1.

  apply H_T_implies_U.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  apply H_P2_implies_Q.
  apply H_P2.

Qed.

Proposition baz_dual_late :
  forall P1 P2 Q R T U : Prop,
    (P1 \/ P2) -> (P1 -> Q) -> (P2 -> Q) -> (Q -> R) -> (R -> T) -> (T -> U) -> U.
Proof.
  intros P1 P2 Q R T U.
  intros H_P1_or_P2 H_P1_implies_Q H_P2_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.

  (* use "destruct H_P1_or_P2 as [H_P1 | H_P2]." as late as you can *)
  apply H_T_implies_U.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  destruct H_P1_or_P2 as [H_P1 | H_P2].
    apply H_P1_implies_Q.
    apply H_P1.
  apply H_P2_implies_Q.
  apply H_P2.
Qed.

(* Complete the following proof.
   What do you end up with?
   A proof close to that of Proposition baz_dual_early,
   or to that of Proposition baz_dual_late?
   What do you conclude?
*)
Proposition baz_dual_early_or_late :
  forall P1 P2 Q R T U : Prop,
    (P1 \/ P2) -> (P1 -> Q) -> (P2 -> Q) -> (Q -> R) -> (R -> T) -> (T -> U) -> U.
Proof.
  intros P1 P2 Q R T U.
  intros [H_P1 | H_P2] H_P1_implies_Q H_P2_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.

  apply H_T_implies_U.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  apply H_P1_implies_Q.
  apply H_P1.

  apply H_T_implies_U.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  apply H_P2_implies_Q.
  apply H_P2.
Qed.

  (*You get a proof close to that of Proposition baz_dual_early, since the introduction of (P1 \/ P2) as [H_P1 | H_P2] is equivalent to the step 'destruct H_P1_or_P2 as [H_P1 | H_P2]'. Hence we should be wary of splitting disjunctions when introducing variables since they might close of our options and force us to use a longer approach.*)

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

(* How would you prove the following propositions?
   Forward or backward?
*)

Proposition ladidah :
  forall P1 P2 P3 P4 Q R T U : Prop,
    (P1 \/ P2) \/ (P3 \/ P4) -> (P1 -> Q) -> (P2 -> Q) -> (P3 -> Q) -> (P4 -> Q) -> (Q -> R) -> (R -> T) -> (T -> U) -> U.

  intros P1 P2 P3 P4 Q R T U.
  intros H_P1_or_P2_or_P3_or_P4.
  intros H_P1_implies_Q H_P2_implies_Q H_P3_implies_Q H_P4_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.

  apply H_T_implies_U.
  apply H_R_implies_T.
  apply H_Q_implies_R.

  destruct H_P1_or_P2_or_P3_or_P4 as [H_P1_or_P2 | H_P3_or_P4].
    destruct H_P1_or_P2 as [H_P1 | H_P2].
      apply H_P1_implies_Q.
      apply H_P1.
    apply H_P2_implies_Q.
    apply H_P2.
  destruct H_P3_or_P4 as [H_P3 | H_P4].
    apply H_P3_implies_Q.
    apply H_P3.
  apply H_P4_implies_Q.
  apply H_P4.

Proposition toodeloo :
  forall P Q R T U1 U2 U3 U4: Prop,
    P -> (P -> Q) -> (Q -> R) -> (R -> T) -> (T -> U1) -> (T -> U2) -> (T -> U3) -> (T -> U4) -> (U1 /\ U2) /\ (U3 /\ U4).
Abort.

(* How complex could the size of such proofs be
   (relative to the number of hypotheses P1, P2, P3, etc.
   and to the number of conclusions U1, U2, U3, etc.)?
*)

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

(* end of week-02_backward-and-forward.v *)


(***************************************************************************
* Safety for Simply Typed Lambda Calculus (CBV) - Definitions              *
* Arthur Chargueraud, January 2009                                         *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive val : Set :=
  | val_bvar : nat -> val
  | val_fvar : var -> val
  | val_abs  : trm -> val

with trm : Set :=
  | trm_val  : val -> trm
  | trm_app  : val -> trm -> trm.

Notation "'\' v" := (trm_val v) (at level 69).
Coercion trm_val : val >-> trm.
Implicit Types v : val.

(** Opening up abstractions *)

Fixpoint trm_open_rec (k : nat) (u : val) (t : trm) {struct t} : trm :=
  match t with
  | trm_val v1    => trm_val (val_open_rec k u v1)
  | trm_app v1 t2 => trm_app (val_open_rec k u v1) (trm_open_rec k u t2)
  end
with val_open_rec (k : nat) (u : val) (v : val) {struct v} : val :=
  match v with
  | val_bvar i  => If k = i then u else v
  | val_fvar x  => v
  | val_abs t1  => val_abs (trm_open_rec (S k) u t1)
  end.

Definition open t u := trm_open_rec 0 u t.

Notation "{ k ~> u } t" := (trm_open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (val_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_val : forall v,
      value v ->
      term (trm_val v)
  | term_app : forall v1 t2,
      value v1 ->
      term t2 ->
      term (trm_app v1 t2)
with value : val -> Prop :=
  | value_var : forall x,
      value (val_fvar x)
  | value_abs : forall L t1,
      (forall x, x \notin L -> term (t1^x)) ->
      value (val_abs t1).

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).
Reserved Notation "E \= v ~: T" (at level 69).

Inductive typing_trm : env -> trm -> typ -> Prop :=
  | typing_trm_val : forall E v T,
      E \= v ~: T ->
      E |= (trm_val v) ~: T
  | typing_trm_app : forall S T E v1 t2,
      E \= v1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app v1 t2) ~: T

where "E |= t ~: T" := (typing_trm E t T)

with typing_val : env -> val -> typ -> Prop :=
  | typing_val_var : forall E x T,
      ok E ->
      binds x T E ->
      E \= (val_fvar x) ~: T
  | typing_val_abs : forall L E U T t1,
      (forall x, x \notin L ->
        (E & x ~ U) |= t1 ^ x ~: T) ->
      E \= (val_abs t1) ~: (typ_arrow U T)

where "E \= t ~: T" := (typing_val E t T).

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 v2,
      value (val_abs t1) ->
      value v2 ->
      red (trm_app (val_abs t1) v2) (t1 ^^ v2)
  | red_app_2 : forall v1 t2 t2',
      red t2 t2' ->
      red (trm_app v1 t2) (trm_app v1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     exists v, t = trm_val v
  \/ exists t', t --> t'.


Require Import Arith.
Require Import fol.
Require Import folProof.
Require Import cPair.

Section Code_Term_Formula_Proof.

Variable L : Language.
Variable codeF : Functions L -> nat.
Variable codeR : Relations L -> nat.
Hypothesis codeFInj : forall f g : Functions L, codeF f = codeF g -> f = g.
Hypothesis codeRInj : forall R S : Relations L, codeR R = codeR S -> R = S.

Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let var := var L.
Let apply := apply L.
Let equal := equal L.
Let atomic := atomic L.
Let impH := impH L.
Let notH := notH L.
Let forallH := forallH L.
Let orH := orH L.
Let andH := andH L.
Let existH := existH L.
Let iffH := iffH L.
Let ifThenElseH := ifThenElseH L.
Let Prf := Prf L.
Let SysPrf := SysPrf L.

Fixpoint codeTerm (t : Term) : nat :=
  match t with
  | fol.var n => cPair 0 n
  | fol.apply f ts => cPair (S (codeF f)) (codeTerms _ ts)
  end

 with codeTerms (n : nat) (ts : Terms n) {struct ts} : nat :=
  match ts with
  | Tnil => 0
  | Tcons n t ss => S (cPair (codeTerm t) (codeTerms n ss))
  end.

Lemma codeTermInj : forall t s : Term, codeTerm t = codeTerm s -> t = s.
Proof.
intro.
elim t using
 Term_Terms_ind
  with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
           forall ss : Terms n, codeTerms n ts = codeTerms n ss -> ts = ss).
intros.
destruct s.
simpl in H.
replace n with n0.
auto.
eapply cPairInj2.
symmetry  in |- *.
apply H.
simpl in H.
assert (0 = S (codeF f)).
eapply cPairInj1.
apply H.
discriminate H0.
intros.
destruct s.
simpl in H0.
assert (S (codeF f) = 0).
eapply cPairInj1.
apply H0.
discriminate H1.
simpl in H0.
assert (f = f0).
apply codeFInj.
apply eq_add_S.
eapply cPairInj1.
apply H0.
cut
 (cPair (S (codeF f)) (codeTerms (arity L (inr (Relations L) f)) t0) =
  cPair (S (codeF f0)) (codeTerms (arity L (inr (Relations L) f0)) t1)).
generalize t1.
rewrite <- H1.
clear H1 H0 t1.
intros.
rewrite (H t1).
reflexivity.
eapply cPairInj2.
apply H0.
apply H0.
intros.
rewrite <- nilTerms.
reflexivity.
intros.
induction (consTerms L n ss).
induction x as (a, b).
simpl in p.
rewrite <- p.
rewrite <- p in H1.
simpl in H1.
rewrite (H a).
rewrite (H0 b).
reflexivity.
eapply cPairInj2.
apply eq_add_S.
apply H1.
eapply cPairInj1.
apply eq_add_S.
apply H1.
Qed.

Lemma codeTermsInj :
 forall (n : nat) (ts ss : Terms n),
 codeTerms n ts = codeTerms n ss -> ts = ss.
Proof.
intros n ts.
induction ts as [| n t ts Hrects].
intros.
rewrite <- (nilTerms L ss).
reflexivity.
intros.
induction (consTerms L n ss).
induction x as (a, b).
simpl in p.
rewrite <- p.
rewrite <- p in H.
simpl in H.
rewrite (Hrects b).
rewrite (codeTermInj t a).
reflexivity.
eapply cPairInj1.
apply eq_add_S.
apply H.
eapply cPairInj2.
apply eq_add_S.
apply H.
Qed.

Fixpoint codeFormula (f : Formula) : nat :=
  match f with
  | fol.equal t1 t2 => cPair 0 (cPair (codeTerm t1) (codeTerm t2))
  | fol.impH f1 f2 => cPair 1 (cPair (codeFormula f1) (codeFormula f2))
  | fol.notH f1 => cPair 2 (codeFormula f1)
  | fol.forallH n f1 => cPair 3 (cPair n (codeFormula f1))
  | fol.atomic R ts => cPair (4+(codeR R)) (codeTerms _ ts)
  end.

Lemma codeFormulaInj :
 forall f g : Formula, codeFormula f = codeFormula g -> f = g.
Proof.
intro.
induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf]; intros;
 [ destruct g as [t1 t2| r t1| f f0| f| n f]
 | destruct g as [t0 t1| r0 t0| f f0| f| n f]
 | destruct g as [t t0| r t| f f2| f| n f]
 | destruct g as [t t0| r t| f0 f1| f0| n f0]
 | destruct g as [t t0| r t| f0 f1| f0| n0 f0] ];
 (simpl in H;
   try
    match goal with
    | h:(cPair ?X1 ?X2 = cPair ?X3 ?X4) |- _ =>
        elimtype False; cut (X1 = X3);
         [ discriminate | eapply cPairInj1; apply h ]
    end).
rewrite (codeTermInj t t1).
rewrite (codeTermInj t0 t2).
reflexivity.
eapply cPairInj2.
eapply cPairInj2.
apply H.
eapply cPairInj1.
eapply cPairInj2.
apply H.
assert (r = r0).
apply codeRInj.
do 4 apply eq_add_S.
eapply cPairInj1.
apply H.
cut
 (cPair (S (S (S (S (codeR r)))))
    (codeTerms (arity L (inl (Functions L) r)) t) =
  cPair (S (S (S (S (codeR r0)))))
    (codeTerms (arity L (inl (Functions L) r0)) t0)).
generalize t0.
rewrite <- H0.
clear H0 H t0.
intros.
rewrite (codeTermsInj _ t t0).
reflexivity.
eapply cPairInj2.
apply H.
apply H.
rewrite (Hrecf1 f).
rewrite (Hrecf0 f2).
reflexivity.
eapply cPairInj2.
eapply cPairInj2.
apply H.
eapply cPairInj1.
eapply cPairInj2.
apply H.
rewrite (Hrecf f0).
reflexivity.
eapply cPairInj2.
apply H.
rewrite (Hrecf f0).
replace n0 with n.
reflexivity.
eapply cPairInj1.
eapply cPairInj2.
apply H.
eapply cPairInj2.
eapply cPairInj2.
apply H.
Qed.

Fixpoint codePrf (Z : Formulas) (f : Formula) (prf : Prf Z f) {struct prf} :
 nat :=
  match prf with
  | AXM A => cPair 0 (codeFormula A)
  | MP Axm1 Axm2 A B rec1 rec2 =>
      cPair 1
        (cPair
           (cPair (cPair 1 (cPair (codeFormula A) (codeFormula B)))
              (codePrf _ _ rec1)) (cPair (codeFormula A) (codePrf _ _ rec2)))
  | GEN Axm A v _ rec =>
      cPair 2 (cPair v (cPair (codeFormula A) (codePrf _ _ rec)))
  | IMP1 A B => cPair 3 (cPair (codeFormula A) (codeFormula B))
  | IMP2 A B C =>
      cPair 4 (cPair (codeFormula A) (cPair (codeFormula B) (codeFormula C)))
  | CP A B => cPair 5 (cPair (codeFormula A) (codeFormula B))
  | FA1 A v t => cPair 6 (cPair (codeFormula A) (cPair v (codeTerm t)))
  | FA2 A v _ => cPair 7 (cPair (codeFormula A) v)
  | FA3 A B v => cPair 8 (cPair (codeFormula A) (cPair (codeFormula B) v))
  | EQ1 => cPair 9 0
  | EQ2 => cPair 10 0
  | EQ3 => cPair 11 0
  | EQ4 r => cPair 12 (codeR r)
  | EQ5 f => cPair 13 (codeF f)
  end.

Lemma codePrfInjAxm :
 forall (a b : Formula) (A B : Formulas) (p : Prf A a) (q : Prf B b),
 codePrf A a p = codePrf B b q -> A = B.
Proof.
intros a b A B p.
generalize B b.
clear B b.
induction p
 as
  [A|
   Axm1 Axm2 A B p1 Hrecp1 p0 Hrecp0|
   Axm A v n p Hrecp|
   A B|
   A B C|
   A B|
   A v t|
   A v n|
   A B v|
   |
   |
   |
   R|
   f]; intros;
 [ destruct q
    as
     [A0|
      Axm1 Axm2 A0 B p p0|
      Axm A0 v n p|
      A0 B|
      A0 B C|
      A0 B|
      A0 v t|
      A0 v n|
      A0 B v|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A0|
      Axm0 Axm3 A0 B0 p p2|
      Axm A0 v n p|
      A0 B0|
      A0 B0 C|
      A0 B0|
      A0 v t|
      A0 v n|
      A0 B0 v|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A0|
      Axm1 Axm2 A0 B p0 p1|
      Axm0 A0 v0 n0 p0|
      A0 B|
      A0 B C|
      A0 B|
      A0 v0 t|
      A0 v0 n0|
      A0 B v0|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A0|
      Axm1 Axm2 A0 B0 p p0|
      Axm A0 v n p|
      A0 B0|
      A0 B0 C|
      A0 B0|
      A0 v t|
      A0 v n|
      A0 B0 v|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A0|
      Axm1 Axm2 A0 B0 p p0|
      Axm A0 v n p|
      A0 B0|
      A0 B0 C0|
      A0 B0|
      A0 v t|
      A0 v n|
      A0 B0 v|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A0|
      Axm1 Axm2 A0 B0 p p0|
      Axm A0 v n p|
      A0 B0|
      A0 B0 C|
      A0 B0|
      A0 v t|
      A0 v n|
      A0 B0 v|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A0|
      Axm1 Axm2 A0 B p p0|
      Axm A0 v0 n p|
      A0 B|
      A0 B C|
      A0 B|
      A0 v0 t0|
      A0 v0 n|
      A0 B v0|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A0|
      Axm1 Axm2 A0 B p p0|
      Axm A0 v0 n0 p|
      A0 B|
      A0 B C|
      A0 B|
      A0 v0 t|
      A0 v0 n0|
      A0 B v0|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A0|
      Axm1 Axm2 A0 B0 p p0|
      Axm A0 v0 n p|
      A0 B0|
      A0 B0 C|
      A0 B0|
      A0 v0 t|
      A0 v0 n|
      A0 B0 v0|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A|
      Axm1 Axm2 A B p p0|
      Axm A v n p|
      A B|
      A B C|
      A B|
      A v t|
      A v n|
      A B v|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A|
      Axm1 Axm2 A B p p0|
      Axm A v n p|
      A B|
      A B C|
      A B|
      A v t|
      A v n|
      A B v|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A|
      Axm1 Axm2 A B p p0|
      Axm A v n p|
      A B|
      A B C|
      A B|
      A v t|
      A v n|
      A B v|
      |
      |
      |
      R|
      f]
 | destruct q
    as
     [A|
      Axm1 Axm2 A B p p0|
      Axm A v n p|
      A B|
      A B C|
      A B|
      A v t|
      A v n|
      A B v|
      |
      |
      |
      R0|
      f]
 | destruct q
    as
     [A|
      Axm1 Axm2 A B p p0|
      Axm A v n p|
      A B|
      A B C|
      A B|
      A v t|
      A v n|
      A B v|
      |
      |
      |
      R|
      f0] ];
 (simpl in H;
   try
    match goal with
    | h:(cPair ?X1 ?X2 = cPair ?X3 ?X4) |- _ =>
        elimtype False; cut (X1 = X3);
         [ discriminate | eapply cPairInj1; apply h ]
    end); try reflexivity.
replace A0 with A.
reflexivity.
apply codeFormulaInj.
eapply cPairInj2.
apply H.
replace Axm0 with Axm1.
replace Axm3 with Axm2.
reflexivity.
eapply Hrecp0 with A0 p2.
do 3 eapply cPairInj2.
apply H.
eapply Hrecp1 with (fol.impH L A0 B0) p.
eapply cPairInj2.
eapply cPairInj1.
eapply cPairInj2.
apply H.
eapply Hrecp with A0 p0.
do 3 eapply cPairInj2.
apply H.
Qed.

Definition codeImp (a b : nat) := cPair 1 (cPair a b).

Lemma codeImpCorrect :
 forall a b : Formula,
 codeImp (codeFormula a) (codeFormula b) = codeFormula (impH a b).
Proof.
auto.
Qed.

Definition codeNot (a : nat) := cPair 2 a.

Lemma codeNotCorrect :
 forall a : Formula, codeNot (codeFormula a) = codeFormula (notH a).
Proof.
auto.
Qed.

Definition codeForall (n a : nat) := cPair 3 (cPair n a).

Lemma codeForallCorrect :
 forall (n : nat) (a : Formula),
 codeForall n (codeFormula a) = codeFormula (forallH n a).
Proof.
auto.
Qed.

Definition codeOr (a b : nat) := codeImp (codeNot a) b.

Lemma codeOrCorrect :
 forall a b : Formula,
 codeOr (codeFormula a) (codeFormula b) = codeFormula (orH a b).
Proof.
auto.
Qed.

Definition codeAnd (a b : nat) := codeNot (codeOr (codeNot a) (codeNot b)).

Lemma codeAndCorrect :
 forall a b : Formula,
 codeAnd (codeFormula a) (codeFormula b) = codeFormula (andH a b).
Proof.
auto.
Qed.

Definition codeIff (a b : nat) := codeAnd (codeImp a b) (codeImp b a).

Lemma codeIffCorrect :
 forall a b : Formula,
 codeIff (codeFormula a) (codeFormula b) = codeFormula (iffH a b).
Proof.
auto.
Qed.

End Code_Term_Formula_Proof.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__3__6b.
Require Export lemma__congruencesymmetric.
Require Export lemma__lessthancongruence.
Require Export lemma__partnotequalwhole.
Require Export logic.
Definition lemma__trichotomy2 : forall A B C D, (euclidean__defs.Lt A B C D) -> (~(euclidean__defs.Lt C D A B)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (exists E, (euclidean__axioms.BetS C E D) /\ (euclidean__axioms.Cong C E A B)) as H0 by exact H.
destruct H0 as [E H1].
destruct H1 as [H2 H3].
assert (* Cut *) (euclidean__axioms.Cong A B C E) as H4.
- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A C E B H3).
- assert (* Cut *) (~(euclidean__defs.Lt C D A B)) as H5.
-- intro H5.
assert (* Cut *) (euclidean__defs.Lt C D C E) as H6.
--- apply (@lemma__lessthancongruence.lemma__lessthancongruence C D A B C E H5 H4).
--- assert (exists F, (euclidean__axioms.BetS C F E) /\ (euclidean__axioms.Cong C F C D)) as H7 by exact H6.
destruct H7 as [F H8].
destruct H8 as [H9 H10].
assert (* Cut *) (euclidean__axioms.BetS C F D) as H11.
---- apply (@lemma__3__6b.lemma__3__6b C F E D H9 H2).
---- assert (* Cut *) (~(euclidean__axioms.Cong C F C D)) as H12.
----- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole C F D H11).
----- apply (@H12 H10).
-- exact H5.
Qed.


Require Import Coq.Bool.Bool.
Require Import Coq.derive.Derive.
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Crypto.COperationSpecifications. Import COperationSpecifications.BarrettReduction.
Require Import Rewriter.Language.Language. Import Language.Compilers.
Require Import Crypto.Language.API. Import Language.API.Compilers.
Require Import Rewriter.Language.Wf. Import Language.Wf.Compilers.
Require Import Crypto.PushButtonSynthesis.BarrettReduction.
Require Import Crypto.Fancy.Compiler.
Require Import Crypto.Fancy.Prod.
Require Import Crypto.Fancy.Spec.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Notations.
Local Open Scope Z_scope.

Module Barrett256.

  Definition M := Eval lazy in (2^256-2^224+2^192+2^96-1).
  Definition machine_wordsize := 256.

  Derive barrett_red256
         SuchThat (barrett_red M machine_wordsize = ErrorT.Success barrett_red256)
         As barrett_red256_eq.
  Proof. lazy; reflexivity. Qed.

  Lemma Wf_barrett_red256 : API.Wf barrett_red256.
  Proof using Type. eapply Wf_barrett_red, barrett_red256_eq. Qed.

  Lemma barrett_red256_correct :
    COperationSpecifications.BarrettReduction.barrett_red_correct machine_wordsize M (API.Interp barrett_red256).
  Proof.
    apply barrett_red_correct with (machine_wordsize:=machine_wordsize).
    { lazy. reflexivity. }
    { apply barrett_red256_eq. }
  Qed.

  Definition muLow := Eval lazy in (2 ^ (2 * machine_wordsize) / M) mod (2^machine_wordsize).

  Definition barrett_red256_fancy' (xLow xHigh RegMuLow RegMod RegZero error : positive) :=
    of_Expr 6%positive
            (make_consts [(RegMuLow, muLow); (RegMod, M); (RegZero, 0)])
            barrett_red256
            (xLow, (xHigh, tt))
            error.
  Derive barrett_red256_fancy
         SuchThat (forall xLow xHigh RegMuLow RegMod RegZero,
                      barrett_red256_fancy xLow xHigh RegMuLow RegMod RegZero = barrett_red256_fancy' xLow xHigh RegMuLow RegMod RegZero)
         As barrett_red256_fancy_eq.
  Proof.
    intros.
    lazy - [ADD ADDC SUB SUBC MUL128LL MUL128LU MUL128UL MUL128UU RSHI SELC SELM SELL ADDM].
    reflexivity.
  Qed.

  Local Ltac wf_subgoal :=
    repeat first [ progress cbn [List.In type.and_for_each_lhs_of_arrow fst snd List.app List.map]
                 | apply expr.wf_smart_App_curried
                 | progress intros
                 | exfalso; assumption
                 | apply conj
                 | exact I
                 | solve [ eauto 50 using or_introl, or_intror, eq_refl with nocore ] ].
  Local Ltac valid_expr_subgoal :=
    repeat match goal with
           | _ => progress intros
           | |- context [valid_ident] => econstructor
           | |- context[valid_scalar] => econstructor
           | |- context [valid_carry] => econstructor
           | _ => reflexivity
           | |- _ <> None => cbn; congruence
           | |- of_prefancy_scalar _ _ _ _ = _ => cbn; solve [eauto]
           end.

  Lemma barrett_red256_fancy_correct :
    forall xLow xHigh error,
      0 <= xLow < 2 ^ machine_wordsize ->
      0 <= xHigh < M ->
      let RegZero := 1%positive in
      let RegMod := 2%positive in
      let RegMuLow := 3%positive in
      let RegxHigh := 4%positive in
      let RegxLow := 5%positive in
      let consts_list := [(RegMuLow, muLow); (RegMod, M); (RegZero, 0)] in
      let arg_list := [(RegxHigh, xHigh); (RegxLow, xLow)] in
      let ctx := make_ctx (consts_list ++ arg_list) in
      let carry_flag := false in
      let last_wrote := (fun x : CC.code =>
                           match x with
                           | CC.C => RegZero
                           | _ => RegxHigh (* xHigh needs to have written M; others unused *)
                           end) in
      let cc := make_cc last_wrote ctx carry_flag in
      interp Pos.eqb wordmax cc_spec (barrett_red256_fancy RegxLow RegxHigh RegMuLow RegMod RegZero error) cc ctx = (xLow + 2 ^ machine_wordsize * xHigh) mod M.
  Proof.
    intros.
    rewrite barrett_red256_fancy_eq.
    cbv [barrett_red256_fancy'].
    rewrite <-barrett_red256_correct by auto.
    eapply of_Expr_correct with (x2 := (xLow, (xHigh, tt))).
    { cbn; intros; subst RegZero RegMod RegMuLow RegxHigh RegxLow.
      intuition; Prod.inversion_prod; subst; cbv. break_innermost_match; congruence. }
    { cbn; intros; subst RegZero RegMod RegMuLow RegxHigh RegxLow.
      intuition; Prod.inversion_prod; subst; cbv; congruence. }
    { cbn; intros; subst RegZero RegMod RegMuLow RegxHigh RegxLow. tauto. }
    { cbn; intros; subst RegZero RegMod RegMuLow RegxHigh RegxLow.
      intuition; Prod.inversion_prod; subst; cbv; congruence. }
    { cbn; intros; subst RegZero RegMod RegMuLow RegxHigh RegxLow.
      match goal with |- context [_ mod ?m] => change m with (2 ^ machine_wordsize) end.
      assert (M < 2 ^ machine_wordsize) by (cbv; congruence).
      assert (0 <= muLow < 2 ^ machine_wordsize) by (split; cbv; congruence).
      intuition; Prod.inversion_prod; subst; apply Z.mod_small; lia. }
    { cbn; intros; subst RegZero RegMod RegMuLow RegxHigh RegxLow.
      match goal with |- context [_ mod ?m] => change m with (2 ^ machine_wordsize) end.
      assert (M < 2 ^ machine_wordsize) by (cbv; congruence).
      assert (0 <= muLow < 2 ^ machine_wordsize) by (split; cbv; congruence).
      intuition; Prod.inversion_prod; subst; apply Z.mod_small; lia. }
    { repeat first [ eapply expr.wf_Proper_list, Wf_barrett_red256
                   | progress cbv [make_pairs consts_list arg_list]
                   | wf_subgoal ]. }
    { cbn. cbv [muLow M].
      repeat (match goal with
             | _ => eapply valid_LetInZZ
             | _ => eapply valid_LetInZ
              end; [ solve [valid_expr_subgoal] | intros ]).
      econstructor. valid_expr_subgoal. }
    { reflexivity. }
  Qed.

  Import Spec.Registers.

  Definition barrett_red256_alloc' xLow xHigh RegMuLow :=
    fun errorP errorR =>
      allocate register
               positive Pos.eqb
               errorR
               (barrett_red256_fancy 1000%positive 1001%positive 1002%positive 1003%positive 1004%positive errorP)
               [r2;r3;r4;r5;r6;r7;r8;r9;r10;r5;r11;r6;r12;r13;r14;r15;r16;r17;r18;r19;r20;r21;r22;r23;r24;r25;r26;r27;r28;r29]
               (fun n => if n =? 1000 then xLow
                         else if n =? 1001 then xHigh
                              else if n =? 1002 then RegMuLow
                                   else if n =? 1003 then RegMod
                                        else if n =? 1004 then RegZero
                                             else errorR)%positive.
  Derive barrett_red256_alloc
         SuchThat (barrett_red256_alloc = barrett_red256_alloc')
         As barrett_red256_alloc_eq.
  Proof.
    intros.
    cbv [barrett_red256_alloc' barrett_red256_fancy].
    cbn. subst barrett_red256_alloc.
    reflexivity.
  Qed.

  Local Notation interp := (interp reg_eqb wordmax cc_spec).
  Lemma barrett_red256_alloc_equivalent errorP errorR cc_start_state start_context :
    forall x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5 extra_reg,
      NoDup [x; xHigh; RegMuLow; scratchp1; scratchp2; scratchp3; scratchp4; scratchp5; extra_reg; RegMod; RegZero] ->
      0 <= start_context x < 2^machine_wordsize ->
      0 <= start_context xHigh < 2^machine_wordsize ->
      0 <= start_context RegMuLow < 2^machine_wordsize ->
      0 <= start_context RegZero < 2^machine_wordsize ->
      interp
        (barrett_red256_alloc r0 r1 r30 errorP errorR) cc_start_state
                          (fun r => if reg_eqb r r0
                                    then start_context x
                                    else if reg_eqb r r1
                                         then start_context xHigh
                                         else if reg_eqb r r30
                                              then start_context RegMuLow
                                              else start_context r)
    = interp (Prod.MulMod x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5) cc_start_state start_context.
  Proof.
    intros.
    let r := eval compute in (2^machine_wordsize) in
        replace (2^machine_wordsize) with r in * by reflexivity.
    cbv [Prod.MulMod barrett_red256_alloc].

    (* Extract proofs that no registers are equal to each other *)
    repeat match goal with
           | H : NoDup _ |- _ => inversion H; subst; clear H
           | H : ~ In _ _ |- _ => cbv [In] in H
           | H : ~ (_ \/ _) |- _ => apply Decidable.not_or in H; destruct H
           | H : ~ False |- _ => clear H
           end.

    Time repeat match goal with
                | _ => progress prove_programs_equivalent
                | _ => rewrite interp_Mul256x256 with (tmp2 := extra_reg) by
                      (match goal with
                       | |- _ <> _ => assumption || congruence
                       | _ => push_value_unused
                       end)
                | _ =>
                  rewrite swap_add_chain by
                      repeat match goal with
                             | |- _ <> _ => assumption || congruence
                             | _ => progress simplify_with_register_properties
                             | |- _ = 2 ^ 256 => reflexivity
                             | |- flags_unused _ _ =>
                               cbv [flags_unused]; intros; prove_programs_equivalent (* TODO: there is probably a faster way to do this one *)
                             end
                end.

    cbv [Spec.interp].
    simplify_with_register_properties.
    reflexivity.
  Qed.

  Lemma prod_barrett_red256_correct :
    forall (cc_start_state : CC.state) (* starting carry flags *)
           (start_context : register -> Z)   (* starting register values *)
           (x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5 extra_reg : register), (* registers to use in computation *)
      NoDup [x; xHigh; RegMuLow; scratchp1; scratchp2; scratchp3; scratchp4; scratchp5; extra_reg; RegMod; RegZero] -> (* registers are unique *)
             0 <= start_context x < 2^machine_wordsize ->
             0 <= start_context xHigh < M ->
             start_context RegMuLow = muLow ->
             start_context RegMod = M ->
             start_context RegZero = 0 ->
             cc_start_state.(CC.cc_m) = cc_spec CC.M (start_context xHigh) ->
             let X := start_context x + 2^machine_wordsize * start_context xHigh in
             interp (Prod.MulMod x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5) cc_start_state start_context = X mod M.
  Proof.
    intros. subst X.
    assert (0 <= start_context xHigh < 2^machine_wordsize) by (cbv [M] in *; cbn; lia).
    let r := (eval compute in (2 ^ machine_wordsize)) in
    replace (2^machine_wordsize) with r in * by reflexivity.

    erewrite <-barrett_red256_fancy_correct with (error:=100000%positive) by eauto.
    rewrite <-barrett_red256_alloc_equivalent with (errorR := RegZero) (errorP := 1%positive) (extra_reg:=extra_reg)
      by (auto; cbv [M muLow] in *; cbn; auto with lia).

    match goal with
      |- context [make_cc ?last_wrote ?ctx ?carry] =>
      let e := fresh in
      let He := fresh in
      remember (make_cc last_wrote ctx carry) as e eqn:He;
        cbv [make_ctx app make_cc] in He;
        cbn [Pos.eqb] in He; autorewrite with zsimplify in He;
          subst e
    end.

    repeat match goal with
             H : context [start_context] |- _ =>
             rewrite <-H end.

    cbv [barrett_red256_alloc barrett_red256_fancy].
    repeat step.
    reflexivity.
  Qed.
End Barrett256.

Section with_notations.
  Import Crypto.Language.IdentifiersBasicGENERATED.Compilers.
  Import Crypto.Util.ZRange.
  Local Open Scope zrange_scope.
  Local Open Scope Z_scope.
  Local Open Scope expr_scope.
  Local Notation uint256 := r[0 ~> 115792089237316195423570985008687907853269984665640564039457584007913129639935]%zrange.
  Local Set Printing Width 500.
  Redirect "Crypto.Fancy.Barrett256.barrett_red256" Print Barrett256.barrett_red256.
End with_notations.

Import Registers.

(* Notations to make code more readable *)
Local Notation "i rd x y ; cont" := (Instr i rd (x, y) cont) (at level 40, cont at level 200, format "i  rd  x  y ; '//' cont").
Local Notation "i rd x y z ; cont" := (Instr i rd (x, y, z) cont) (at level 40, cont at level 200, format "i  rd  x  y  z ; '//' cont").

(* Barrett reference code: *)
Local Set Printing Width 150.
Redirect "Crypto.Fancy.Barrett256.Prod.MulMod" Eval cbv beta iota delta [Prod.MulMod Prod.Mul256x256] in Prod.MulMod.
(*
     = fun x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5 : register =>
       let q1Bottom256 := scratchp1 in
       let muSelect := scratchp2 in
       let q2 := scratchp3 in
       let q2High := scratchp4 in
       let q2High2 := scratchp5 in
       let q3 := scratchp1 in
       let r2 := scratchp2 in
       let r2High := scratchp3 in
       let maybeM := scratchp1 in
       SELM muSelect RegMuLow RegZero;
       RSHI 255 q1Bottom256 xHigh x;
       MUL128LL q2 q1Bottom256 RegMuLow;
       MUL128UU q2High q1Bottom256 RegMuLow;
       MUL128UL scratchp5 q1Bottom256 RegMuLow;
       ADD 128 q2 q2 scratchp5;
       ADDC (-128) q2High q2High scratchp5;
       MUL128LU scratchp5 q1Bottom256 RegMuLow;
       ADD 128 q2 q2 scratchp5;
       ADDC (-128) q2High q2High scratchp5;
       RSHI 255 q2High2 RegZero xHigh;
       ADD 0 q2High q2High q1Bottom256;
       ADDC 0 q2High2 q2High2 RegZero;
       ADD 0 q2High q2High muSelect;
       ADDC 0 q2High2 q2High2 RegZero;
       RSHI 1 q3 q2High2 q2High;
       MUL128LL r2 RegMod q3;
       MUL128UU r2High RegMod q3;
       MUL128UL scratchp4 RegMod q3;
       ADD 128 r2 r2 scratchp4;
       ADDC (-128) r2High r2High scratchp4;
       MUL128LU scratchp4 RegMod q3;
       ADD 128 r2 r2 scratchp4;
       ADDC (-128) r2High r2High scratchp4;
       SUB 0 muSelect x r2;
       SUBC 0 xHigh xHigh r2High;
       SELL maybeM RegMod RegZero;
       SUB 0 q3 muSelect maybeM;
       ADDM x q3 RegZero RegMod;
       Ret x
 *)

(* Remove Redirect to see proof statement and remaining admitted statements. *)
Redirect "Crypto.Fancy.Barrett256.prod_barrett_red256_correct" Check Barrett256.prod_barrett_red256_correct.
Redirect "Crypto.Fancy.Barrett256.prod_barrett_red256_correct.Assumptions" Print Assumptions Barrett256.prod_barrett_red256_correct.


Require Export NArithRing.
Require Import Ring.
Require Import BinPos.
Require Import BinNat.

Local Open Scope positive_scope.
Local Open Scope N_scope.

Lemma plusMorphism : forall a b, (Npos (a+b)%positive) = (Npos a)+(Npos b).
Proof.
auto.
Qed.

Lemma multMorphism : forall a b, (Npos (a*b)%positive) = (Npos a)*(Npos b).
Proof.
auto.
Qed.

Lemma eqMorphism : forall a b, (Npos a) = (Npos b) -> a = b.
Proof.
congruence.
Qed.

Ltac Pring :=
(try apply eqMorphism);
repeat (rewrite plusMorphism || rewrite multMorphism);
ring.


Require Import Ordinal.

(* 接下来给出与序数函数的不动点相关的构造：ε,ζ,η,二元φ,Γ,序数元φ *)

(* iter_lim(f,x) 表示 x, f(x), f(f(x)), ... 的极限 *)
Definition iter_lim(f:On->On)(x:On):On := Lim (fun n=>iter f n x).

(* f(0,x), f(1,x), ... 的极限 *)
Definition seq_lim(f:nat->On->On)(x:On):On := Lim (fun n=>f n x).

(* oiter_Suc(f,0), oiter_Suc(f,1), oiter_Suc(f,2), ... 可以用于枚举f(0), f(f(0)+1), f(f(f(0)+1)+1)... *)
Definition oiter_Suc(f:On->On)(x:On):On := oiter (f 0) (fun a=>(f (Suc a))) x.

(* 用序数乘方的迭代作为后继操作 *)
Definition ε_suc := iter_lim ωpow.

(* 序数乘方的不动点 *)
Definition ε_0 := ε_suc Zero.
Definition ε_1 := ε_suc (Suc ε_0).
Definition ε_2 := ε_suc (Suc ε_1).

(* 每个序数都对应序数乘方的不动点 *)
Definition ε:On->On := oiter_Suc ε_suc.

(* 用ε的迭代作为后继操作 *)
Definition ζ_suc := iter_lim ε.

(* ε的不动点 *)
Definition ζ_0 := ζ_suc Zero.
Definition ζ_1 := ζ_suc (Suc ζ_0).
Definition ζ_2 := ζ_suc (Suc ζ_1).

(* 每个序数都对应ε的不动点 *)
Definition ζ:On->On := oiter_Suc ζ_suc.

(* 用ζ的迭代作为后继操作 *)
Definition η_suc := iter_lim ζ.

(* ζ的不动点 *)
Definition η_0 := η_suc Zero.
Definition η_1 := η_suc (Suc η_0).
Definition η_2 := η_suc (Suc η_1).

(* 每个序数都对应ζ的不动点 *)
Definition η:On->On := oiter_Suc η_suc.

(* 重复上面的过程 *)
(* 用f的迭代作为后继操作 *)

(* f的前几个不动点 *)
Definition fixpoint_0(f:On->On):On := iter_lim f Zero.
Definition fixpoint_1(f:On->On):On := iter_lim f (Suc (fixpoint_0 f)).
Definition fixpoint_2(f:On->On):On := iter_lim f (Suc (fixpoint_1 f)).

(* 希望第一个f是ωpow，然后是ε,ζ,η,... *)
(* 二元φ函数 *)
Fixpoint φ(a:On):On->On :=
match a with
| Zero => ωpow
| Suc a0 => oiter_Suc (iter_lim (φ a0))
| Lim f => oiter_Suc (seq_lim (fun n=>(φ (f n))))
end.

(* 验证 φ(1,_)=ε(_) *)
Goal ωpow=(φ 0) /\ ε=(φ 1) /\ ζ=(φ 2) /\ η=(φ 3).
repeat split.
Qed.

(* Γ(x)=φ(1,0,x) *)
Definition Γ := oiter_Suc (iter_lim (fun x=>φ x 0)).

(* 以F为起点的二元φ函数 *)
Definition φ2(F:On->On):On->On->On :=
fix FIX(a:On):On->On :=
match a with
| Zero => F
| Suc a0 => oiter_Suc (iter_lim (FIX a0))
| Lim f => oiter_Suc (seq_lim (fun n=>(FIX (f n))))
end.

(* 以F为起点的三元φ函数 φ(x,y,z) *)
Definition φ3(F:On->On):On->On->On->On :=
fix FIX(a:On):On->On->On :=
match a with
| Zero => φ2 F
| Suc a0 => φ2 (oiter_Suc (iter_lim (fun x=>FIX a0 x 0)))
| Lim f => φ2 (oiter_Suc (seq_lim (fun n x=>FIX (f n) x 0)))
end.

(* 以F为起点的四元φ函数 φ(a,b,c,d) *)
Definition φ4(F:On->On):On->On->On->On->On :=
fix FIX(a:On):On->On->On->On :=
match a with
| Zero => φ3 F
| Suc a0 => φ3 (oiter_Suc (iter_lim (fun x=>FIX a0 x 0 0)))
| Lim f => φ3 (oiter_Suc (seq_lim (fun n x=>FIX (f n) x 0 0)))
end.

(* 验证和前面的定义的相容性 *)
Goal (φ2 ωpow)=φ /\ (φ3 ωpow 0)=φ /\ (φ4 ωpow 0 0)=φ /\ (φ3 ωpow 1 0)=Γ.
repeat split.
Qed.

(* φn_suc用于将n元φ函数变为n+1元 *)
(* φ(xxx, 0, 0...0, y) 由递归时传入的表示起点的F决定 *)
(* φ(xxx, a+1, 0...0, y) = x→φ(xxx, a, x, 0...0) 的第y个不动点 *)
(* φ(xxx, a, 0...0, y) = x→sup φ(xxx, a[n], x, 0...0) 迭代1+y次 *)
Definition φn_suc{T}(prev:((On->On)->On->T->On)*T):((On->On)->On->(On*T)->On)*(On*T) :=
let (φn,T0):=prev in
let f0 :=
  fun (F:On->On) =>
  fix FIX(a:On):On->T->On :=
  match a with
  | Zero => φn F
  | Suc a0 => φn (oiter_Suc (iter_lim (fun x=>FIX a0 x T0)))
  | Lim f => φn (oiter_Suc (seq_lim (fun n x=>FIX (f n) x T0)))
  end
in (
  (fun (F:On->On) (a:On) (b:On*T) => let (b1,b2):=b in f0 F a b1 b2),
  (Zero,T0)
).

Definition φ1' := (fun (f:On->On)(x:On)(y:True) => f x, I).
Definition φ2' := (φn_suc φ1').
Definition φ3' := (φn_suc φ2').
Definition φ4' := (φn_suc φ3').

Inductive ex_Set (A : Set) (P : A -> Set) : Set :=
| existSet(x:A)(y:P x) : ex_Set A P.

(* φn_lim用于对一列参数列表长度不同的φ函数进行对角化操作 *)
(* φ(xxx, (a+1)@b, y@0) = x→sup φ(xxx, a@b, x@b[n]) 迭代1+y次，b为极限序数 *)
(* φ(xxx, a@b, y@0) = x→sup φ(xxx, a[n]@b, x@b[n]) 迭代1+y次，a,b为极限序数 *)
Definition φn_lim{T:nat->Set} (prev:forall n:nat, let Tn := T n in ((On->On)->On->Tn->On)*Tn)
  :let Tn := (ex_Set nat T) in ((On->On)->On->(On*Tn)->On)*(On*Tn)
 :=
let f0 :=
  fun (F:On->On) =>
  fix FIX(a:On)(b:On)(e:ex_Set nat T):On :=
  match e with (existSet _ _ n0 Tn) =>
    let F' :=
      match a with
      | Zero => F
      | Suc a0 => (oiter_Suc (seq_lim (fun n x => let (_,T0):=(prev n) in (FIX a0 x (existSet _ _ n T0)))))
      | Lim f => (oiter_Suc (seq_lim (fun n x => let (_,T0):=(prev n) in (FIX (f n) x (existSet _ _ n T0)))))
      end
    in let (φn,_):=(prev n0) in
    φn F' b Tn
  end
in (
  fun (F:On->On)(a:On)(bc:On*(ex_Set nat T)) => let (b,c):=bc in f0 F a b c,
  (Zero, existSet _ _ 0 (let (_,T0):=(prev 0) in T0))
).

(* Ta(a)辅助计算1+a元φ函数的参数列表的类型 *)
Fixpoint Ta(a:On):Set :=
match a with
| Zero => True (* 零个参数，占位 *)
| Suc a0 => On*(Ta a0) (* 对每个后继序数，在左边增加一个参数 *)
| Lim f => On*(ex_Set nat (fun n=>(Ta (f n)))) (* 对极限序数a，有最左参数，以及对应Ta(a[n])的右侧参数 *)
end.

(* φa(a)构造 1+a元φ函数 以及 表示a个0的参数列表 *)
Fixpoint φa(a:On):(((On->On)->On->(Ta a)->On)*(Ta a)) :=
match a with
| Zero => φ1'
| Suc a0 => φn_suc (φa a0)
| Lim f => φn_lim (fun n => φa (f n))
end.

(* φ_at(a,b) 表示 φ(a @ b) *)
Definition φ_at(a b:On):On :=
let (f,z):=(φa b) in
f ωpow a z.

Definition SVO : On := (φ_at 1 ω).
Definition LVO : On := iter_lim (φ_at 1) 0.

Goal φ1'=(φa 0) /\ φ2'=(φa 1) /\ φ3'=(φa 2) /\ φ4'=(φa 3).
repeat split.
Qed.

Definition φ2'' := let (f,_):=φ2' in f.
Definition φ3'' := let (f,_):=φ3' in f.
Definition φ4'' := let (f,_):=φ4' in f.

Section CheckEq.
(* 为了方便，引入函数外延公理 *)
Hypothesis func_ext : forall {A B: Type} {f g : A->B},
  (forall x, f x = g x) -> f = g.

(* 验证和前面的定义是相容的 *)
Lemma φ2''_eq_φ2 : forall F x y, φ2'' F x (y,I) = φ2 F x y.
intros F x.
unfold φ2'',φ2',φ1',φn_suc,φ2.
induction x; auto.
all: intro y.
all: apply (inv (fun x=>oiter_Suc x y)),inv,func_ext.
- intro x0.
  apply IHx.
- intro x.
  apply func_ext.
  intro x0.
  apply H.
Qed.

(* 验证和前面的定义是相容的 *)
Lemma φ3''_eq_φ3 : forall F x y z, φ3'' F x (y,(z,I)) = φ3 F x y z.
intros F x.
unfold φ3'',φ3',φ3,φn_suc,φ2',φ2,φn_suc,φ1'.
induction x.
- apply φ2''_eq_φ2.
- intro y.
  induction y.
  all: intros.
  all: apply (inv (fun x=>oiter_Suc x z)),inv,func_ext.
  all: intro.
  + apply IHx.
  + apply IHy.
  + intros.
    apply func_ext. intros.
    apply H.
- intro y.
  induction y.
  all: intros.
  all: apply (inv (fun x=>oiter_Suc x z)),inv,func_ext.
  all: intro.
  + apply func_ext. intros.
    apply H.
  + apply IHy.
  + apply func_ext. intros.
    apply H0.
Qed.

(* 验证SVO的基本列的前几项 *)
Goal (φ_at 1 0) = (FS SVO 0) /\ (φ_at 1 1) = (FS SVO 1) /\ (φ_at 1 2) = (FS SVO 2).
auto.
Qed.

(* 验证φ(x@0)=ω^x *)
Goal (fun x=>φ_at x 0)=ωpow.
auto.
Qed.

End CheckEq.


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

Require Import Arith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_nat gcd crt sums.

From Undecidability.Shared.Libs.DLW.Vec Require Import pos vec.

From Undecidability.MuRec Require Import recalg recomp prim_min ra_utils.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).
Local Notation power := (mscal mult 1).

Opaque ra_cst_n ra_iter_n ra_iter ra_prim_min ra_prim_max.
Opaque ra_plus ra_pred ra_minus ra_mult ra_exp ra_div ra_rem.
Opaque ra_ite ra_eq.
Opaque ra_div2 ra_mod2 ra_pow2 ra_notdiv_pow2.

(* We build a primitive recursive bijection nat <-> nat*nat
    by implementing decomp_[lr] & recomp

    see recomp.v *)

Section ra_recomp.

  (* given n, find a such that S n = 2^a*(2*b+1)
     to get a bijection nat -> nat * nat *)

  (* first, given n, find the first a such that 2^(S a) does not divide S n *)

  Definition ra_decomp_l : recalg 1.
  Proof.
    apply ra_comp with 2; [ | fill_vec ].
    + apply ra_prim_min.
      ra root ra_notdiv_pow2.
      * ra root ra_succ.
        ra arg pos0.
      * ra arg pos1.
    + ra root ra_succ.
      ra arg pos0.
    + ra root ra_succ.
      ra arg pos0.
  Defined.

  Fact ra_decomp_l_prim_rec : prim_rec ra_decomp_l.
  Proof.
    ra prim rec.
    apply ra_prim_min_prim_rec.
    ra prim rec.
  Qed.

  Fact ra_decomp_l_val_0 n : ⟦ra_decomp_l⟧ (n##vec_nil) (prim_min (fun i => notdiv_pow2 (S i) (S n)) (S n)).
  Proof.
    exists (S n##S n##vec_nil); split.
    + apply ra_prim_min_val with (f := fun v i => notdiv_pow2 (S i) (vec_head v)).
      intros i v; vec split v with j; vec nil v.
      exists (S i##j##vec_nil); split; auto.
      pos split; simpl; auto.
      exists (i##vec_nil); split; simpl; auto.
      pos split; simpl; auto.
    + pos split; simpl; auto;
        exists (n##vec_nil); split; simpl; auto;
        pos split; simpl; auto.
  Qed.

  Fact ra_decomp_l_rel n : { a | ⟦ra_decomp_l⟧ (n##vec_nil) a
                              /\   divides (power a 2) (S n)
                              /\ ~ divides (power (S a) 2) (S n) }.
  Proof.
    exists (prim_min (fun i => notdiv_pow2 (S i) (S n)) (S n)); split.
    1: { apply ra_decomp_l_val_0. }
    generalize (prim_min_spec (fun i => notdiv_pow2 (S i) (S n)) (S n));
      intros (H1 & H2).
    1: { apply notdiv_pow2_spec_2; intros C.
         apply divides_le in C; try discriminate.
         generalize (@power_ge_n (S (S n)) 2); intros; lia. }
    apply notdiv_pow2_spec_2 in H1; split; auto.
    revert H2; generalize (prim_min (fun i : nat => notdiv_pow2 (S i) (S n)) (S n)); intros [ | k ] Hk.
    + rewrite power_0; apply divides_1.
    + apply notdiv_pow2_spec_1, Hk; lia.
  Qed.

  Hint Resolve ra_decomp_l_prim_rec : core.
  Opaque ra_decomp_l.

  Definition ra_decomp_r : recalg 1.
  Proof.
    ra root ra_div.
    + ra root ra_succ.
      ra arg pos0.
    + ra root ra_pow2.
      ra root ra_succ.
      ra root ra_decomp_l.
      ra arg pos0.
  Defined.

  Fact ra_decomp_r_prim_rec : prim_rec ra_decomp_r.
  Proof. ra prim rec. Qed.

  Fact ra_decomp_r_rel n : { b | ⟦ra_decomp_r⟧ (n##vec_nil) b
                              /\ exists a, ⟦ra_decomp_l⟧ (n##vec_nil) a
                                        /\ S n = power a 2 * (2*b+1) }.
  Proof.
    destruct (ra_decomp_l_rel n) as (a & H1 & H2 & H3).
    exists (div (S n) (power (S a) 2)); split.
    + exists (S n##power (S a) 2##vec_nil); split.
      { apply ra_div_val; generalize (@power_ge_1 (S a) 2); intros; lia. }
      pos split; simpl; auto.
      * exists (n##vec_nil); split; simpl; auto.
        pos split; simpl; auto.
      * exists (S a##vec_nil); split; auto.
        pos split; simpl; auto.
        exists (a##vec_nil); split; simpl; auto.
        pos split; simpl; auto.
        exists (n##vec_nil); split; auto.
        pos split; simpl; auto.
    + exists a; split; auto.
      generalize (div_rem_spec1 (S n) (power a 2)).
      apply divides_rem_eq in H2; rewrite H2, Nat.add_0_r.
      rewrite power_S in *.
      clear H1; revert H2 H3.
      generalize (S n) (power a 2) (power2_gt_0 a); clear n a; intros n p H1 H2 H3 H4.
      rewrite H4 at 1; rewrite mult_comm; f_equal.
      rewrite divides_rem_eq in H3.
      rewrite (mult_comm _ p), div_mult; try lia.
      rewrite mult_comm, rem_mult in H3; try lia.
      rewrite (@div_rem_spec1 (div n p) 2) at 1.
      rewrite H2 in H3; simpl in H3.
      generalize (@div_rem_spec2 (div n p) 2); intros H5.
      rewrite mult_comm in H3.
      destruct (rem (div n p) 2) as [ | [ | ] ]; lia.
  Qed.

  Fact ra_decomp_lr_val n : ⟦ra_decomp_l⟧ (n##vec_nil) (decomp_l n) /\ ⟦ra_decomp_r⟧ (n##vec_nil) (decomp_r n).
  Proof.
    destruct (ra_decomp_r_rel n) as (b & H1 & a & H2 & H3).
    rewrite (decomp_lr_spec n) in H3.
    apply decomp_uniq in H3; destruct H3; subst a b; auto.
  Qed.

  Fact ra_decomp_l_val n : ⟦ra_decomp_l⟧ (n##vec_nil) (decomp_l n).
  Proof. apply ra_decomp_lr_val. Qed.

  Fact ra_decomp_r_val n : ⟦ra_decomp_r⟧ (n##vec_nil) (decomp_r n).
  Proof. apply ra_decomp_lr_val. Qed.

  Definition ra_recomp : recalg 2.
  Proof.
    ra root ra_pred.
    ra root ra_mult.
    + ra root ra_pow2.
      ra arg pos0.
    + ra root ra_succ.
      ra root ra_mult.
      * ra cst 2.
      * ra arg pos1.
  Defined.

  Fact ra_recomp_prim_rec : prim_rec ra_recomp.
  Proof. ra prim rec. Qed.

  Fact ra_recomp_val a b : ⟦ra_recomp⟧ (a##b##vec_nil) (recomp a b).
  Proof.
    unfold recomp.
    rewrite plus_comm.
    exists (power a 2 * (S (2*b)) ## vec_nil); split; auto.
    pos split; simpl.
    exists (power a 2##S (2*b)##vec_nil); split; auto.
    pos split; simpl; auto.
    + exists (a##vec_nil); split; auto.
      pos split; simpl; auto.
    + exists (2*b##vec_nil); split; simpl; auto.
      pos split; simpl; auto.
      exists (2##b##vec_nil); split; auto.
      { apply ra_mult_val. }
      pos split; simpl; auto.
  Qed.

End ra_recomp.

#[export] Hint Resolve ra_decomp_l_prim_rec ra_decomp_r_prim_rec ra_recomp_prim_rec
             ra_decomp_l_val ra_decomp_r_val ra_recomp_val : core.
Opaque ra_decomp_l ra_decomp_r ra_recomp.

Section ra_inject_project.

  (* isomorphism vec nat n <-> nat *)

  Fixpoint ra_inject n : recalg n.
  Proof.
    destruct n as [ | n ].
    + ra cst 0.
    + ra root ra_recomp.
      * ra arg pos0.
      * apply ra_comp with (1 := ra_inject n).
        apply vec_set_pos.
        intros p; apply ra_proj, pos_nxt, p.
  Defined.

  Fact ra_inject_prim_rec n : prim_rec (ra_inject n).
  Proof.
    induction n as [ | n IHn ]; simpl; split; auto.
    + pos split.
    + pos split; ra prim rec.
      intro; vec pos simpl.
  Qed.

  Fact ra_inject_val n v : ⟦ra_inject n⟧ v (inject v).
  Proof.
    induction n as [ | n IHn ]; simpl.
    + vec nil v; simpl; auto.
    + vec split v with x.
      exists (x##inject v##vec_nil); split.
      * apply ra_recomp_val.
      * pos split; simpl; auto.
        exists v; split; auto.
        intro; vec pos simpl.
  Qed.

  Fixpoint ra_project n (p : pos n) : recalg 1 :=
    match p with
      | pos_fst   => ra_decomp_l
      | pos_nxt p => ra_comp (ra_project p) (ra_decomp_r##vec_nil)
    end.

  Fact ra_project_prim_rec n p : prim_rec (@ra_project n p).
  Proof.
    induction p as [ | n p IHp ]; simpl; auto; split; auto.
    pos split; auto.
  Qed.

  Fact ra_project_val n p x : ⟦@ra_project n p⟧ (x##vec_nil) (vec_pos (@project n x) p).
  Proof.
    revert x; induction p as [ | n p IHp ]; intros x; simpl; auto.
    exists (decomp_r x##vec_nil); split.
    + apply IHp.
    + pos split; simpl; auto.
  Qed.

  Fact ra_project_rel n p v x : ⟦@ra_project n p⟧ v x <-> x = vec_pos (@project n (vec_head v)) p.
  Proof.
    vec split v with a; vec nil v.
    split.
    + intros H; apply ra_rel_fun with (1 := H), ra_project_val.
    + intros; subst; apply ra_project_val.
  Qed.

  Definition ra_vec_project n : vec (recalg 1) n.
  Proof. apply vec_set_pos, ra_project. Defined.

End ra_inject_project.

(* Now we have inject/project implemented as primitive recursive algorithms *)

#[export] Hint Resolve ra_project_prim_rec ra_inject_prim_rec
             ra_project_val ra_inject_val : core.


Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import ListExt.

Require Import folProp.
Require Import folProof.
Require Export folLogic.
Require Import subProp.
Require Import folReplace.
Require Import Arith.

Section More_Logic_Rules.

Variable L : Language.
Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let var := var L.
Let apply := apply L.
Let equal := equal L.
Let atomic := atomic L.
Let impH := impH L.
Let notH := notH L.
Let forallH := forallH L.
Let orH := orH L.
Let andH := andH L.
Let existH := existH L.
Let iffH := iffH L.
Let ifThenElseH := ifThenElseH L.
Let Prf := Prf L.
Let SysPrf := SysPrf L.

Lemma rebindForall :
 forall (T : System) (a b : nat) (f : Formula),
 ~ In b (freeVarFormula L (forallH a f)) ->
 SysPrf T (iffH (forallH a f) (forallH b (substituteFormula L f a (var b)))).
Proof.
intros.
eapply (sysExtend L) with (Empty_set Formula).
unfold Included in |- *.
intros.
induction H0.
apply (iffI L).
apply (impI L).
apply (forallI L).
unfold not in |- *; intros.
induction H0 as (x, H0); induction H0 as (H0, H1).
induction H1 as [x H1| x H1]; [ induction H1 | induction H1 ].
auto.
apply forallE.
apply Axm; right; constructor.
apply (impI L).
apply (forallI L).
unfold not in |- *; intros.
induction H0 as (x, H0); induction H0 as (H0, H1).
induction H1 as [x H1| x H1]; [ induction H1 | induction H1 ].
assert (In a (freeVarFormula L (substituteFormula L f a (var b)))).
eapply In_list_remove1.
apply H0.
induction (freeVarSubFormula3 _ _ _ _ _ H1).
elim (In_list_remove2 _ _ _ _ _ H2).
auto.
elim (In_list_remove2 _ _ _ _ _ H0).
induction H2 as [H2| H2].
auto.
elim H2.
set (A1 := forallH b (substituteFormula L f a (var b))) in *.
rewrite <- (subFormulaId L f a).
apply
 (impE L)
  with
    (substituteFormula L (substituteFormula L f a (var b)) b (fol.var L a)).
apply (iffE1 L).
apply (subFormulaTrans L).
apply H.
apply forallE.
apply Axm; right; constructor.
Qed.

Lemma rebindExist :
 forall (T : System) (a b : nat) (f : Formula),
 ~ In b (freeVarFormula L (existH a f)) ->
 SysPrf T (iffH (existH a f) (existH b (substituteFormula L f a (var b)))).
Proof.
intros.
unfold existH in |- *.
unfold fol.existH in |- *.
apply (reduceNot L).
eapply (iffTrans L).
apply (rebindForall T a b (notH f)).
apply H.
rewrite (subFormulaNot L).
apply (iffRefl L).
Qed.

Lemma subSubTerm :
 forall (t : Term) (v1 v2 : nat) (s1 s2 : Term),
 v1 <> v2 ->
 ~ In v1 (freeVarTerm L s2) ->
 substituteTerm L (substituteTerm L t v1 s1) v2 s2 =
 substituteTerm L (substituteTerm L t v2 s2) v1 (substituteTerm L s1 v2 s2).
Proof.
intros.
elim t using
 Term_Terms_ind
  with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
           substituteTerms L n (substituteTerms L n ts v1 s1) v2 s2 =
           substituteTerms L n (substituteTerms L n ts v2 s2) v1
             (substituteTerm L s1 v2 s2)); simpl in |- *;
 intros.
induction (eq_nat_dec v1 n).
induction (eq_nat_dec v2 n).
elim H.
transitivity n; auto.
simpl in |- *.
induction (eq_nat_dec v1 n).
reflexivity.
elim b0.
auto.
simpl in |- *.
induction (eq_nat_dec v2 n).
rewrite subTermNil.
reflexivity.
auto.
simpl in |- *.
induction (eq_nat_dec v1 n).
elim b; auto.
reflexivity.
rewrite H1.
reflexivity.
reflexivity.
rewrite H1.
rewrite H2.
reflexivity.
Qed.

Lemma subSubTerms :
 forall (n : nat) (ts : Terms n) (v1 v2 : nat) (s1 s2 : Term),
 v1 <> v2 ->
 ~ In v1 (freeVarTerm L s2) ->
 substituteTerms L n (substituteTerms L n ts v1 s1) v2 s2 =
 substituteTerms L n (substituteTerms L n ts v2 s2) v1
   (substituteTerm L s1 v2 s2).
Proof.
intros.
induction ts as [| n t ts Hrects].
reflexivity.
simpl in |- *.
rewrite Hrects.
rewrite subSubTerm.
reflexivity.
auto.
auto.
Qed.

Lemma subSubFormula :
 forall (f : Formula) (v1 v2 : nat) (s1 s2 : Term),
 v1 <> v2 ->
 ~ In v1 (freeVarTerm L s2) ->
 forall T : System,
 SysPrf T
   (iffH (substituteFormula L (substituteFormula L f v1 s1) v2 s2)
      (substituteFormula L (substituteFormula L f v2 s2) v1
         (substituteTerm L s1 v2 s2))).
Proof.
intros.
apply (sysExtend L) with (Empty_set Formula).
unfold Included in |- *.
intros.
induction H1.
elim f using Formula_depth_ind2; intros.
repeat rewrite (subFormulaEqual L).
rewrite subSubTerm; auto.
rewrite (subSubTerm t0); auto.
apply (iffRefl L).
repeat rewrite (subFormulaRelation L).
rewrite subSubTerms; auto.
apply (iffRefl L).
repeat rewrite (subFormulaImp L).
apply (reduceImp L); auto.
repeat rewrite (subFormulaNot L).
apply (reduceNot L); auto.
set
 (v' :=
  newVar
    (v1
     :: v2
        :: freeVarFormula L (fol.forallH L v a) ++
           freeVarTerm L s1 ++ freeVarTerm L s2)) in *.
assert (v' <> v1).
unfold not in |- *; intros.
elim
 (newVar1
    (v1
     :: v2
        :: freeVarFormula L (fol.forallH L v a) ++
           freeVarTerm L s1 ++ freeVarTerm L s2)).
fold v' in |- *.
simpl in |- *.
auto.
assert (v' <> v2).
unfold not in |- *; intros.
elim
 (newVar1
    (v1
     :: v2
        :: freeVarFormula L (fol.forallH L v a) ++
           freeVarTerm L s1 ++ freeVarTerm L s2)).
fold v' in |- *.
simpl in |- *.
auto.
assert (~ In v' (freeVarFormula L (fol.forallH L v a))).
unfold not in |- *; intros.
elim
 (newVar1
    (v1
     :: v2
        :: freeVarFormula L (fol.forallH L v a) ++
           freeVarTerm L s1 ++ freeVarTerm L s2)).
fold v' in |- *.
simpl in |- *.
auto with datatypes.
assert (~ In v' (freeVarTerm L s1)).
unfold not in |- *; intros.
elim
 (newVar1
    (v1
     :: v2
        :: freeVarFormula L (fol.forallH L v a) ++
           freeVarTerm L s1 ++ freeVarTerm L s2)).
fold v' in |- *.
simpl in |- *.
repeat right.
auto with datatypes.
assert (~ In v' (freeVarTerm L s2)).
unfold not in |- *; intros.
elim
 (newVar1
    (v1
     :: v2
        :: freeVarFormula L (fol.forallH L v a) ++
           freeVarTerm L s1 ++ freeVarTerm L s2)).
fold v' in |- *.
simpl in |- *.
repeat right.
auto with datatypes.
apply
 impE
  with
    (iffH
       (substituteFormula L
          (substituteFormula L
             (fol.forallH L v' (substituteFormula L a v (var v'))) v1 s1) v2
          s2)
       (substituteFormula L
          (substituteFormula L
             (fol.forallH L v' (substituteFormula L a v (var v'))) v2 s2) v1
          (substituteTerm L s1 v2 s2))).
apply (iffE2 L).
assert
 (folProof.SysPrf L (Empty_set Formula)
    (iffH (fol.forallH L v a)
       (fol.forallH L v' (substituteFormula L a v (var v'))))).
apply rebindForall.
auto.
repeat first
 [ apply (reduceIff L)
 | apply (reduceSub L)
 | apply (notInFreeVarSys L) ]; auto.
assert
 (forall (f : Formula) (x v : nat) (s : Term),
  x <> v ->
  ~ In x (freeVarTerm L s) ->
  substituteFormula L (forallH x f) v s =
  forallH x (substituteFormula L f v s)).
intros.
rewrite (subFormulaForall L).
induction (eq_nat_dec x v0).
elim H7; auto.
induction (In_dec eq_nat_dec x (freeVarTerm L s)).
elim H8; auto.
reflexivity.
repeat rewrite H7; auto.
apply (reduceForall L).
apply (notInFreeVarSys L).
apply H1.
apply eqDepth with a.
symmetry  in |- *.
apply subFormulaDepth.
apply depthForall.
unfold not in |- *; intros.
induction (freeVarSubTerm3 _ _ _ _ _ H8).
elim H5.
eapply In_list_remove1.
apply H9.
auto.
Qed.

End More_Logic_Rules.


From Coq Require Import Setoid.
From Coq Require Import Streams.

(** Additional streams utilities *)

Delimit Scope stream_scope with Stream.
Infix "⋅" := Cons (at level 60, right associativity) : stream_scope.
Infix "≡" := EqSt (at level 70, no associativity) : stream_scope.
Notation "s # n " := (Str_nth n s) (at level 9) : stream_scope.
Open Scope stream_scope.

Fact Str_nth_0:
  forall {A} (xs: Stream A) x,
    (x ⋅ xs) # 0 = x.
Proof. reflexivity. Qed.

Fact Str_nth_S:
  forall {A} (xs: Stream A) x n,
    (x ⋅ xs) # (S n) = xs # n.
Proof. reflexivity. Qed.

Fact Str_nth_S_tl:
  forall {A} (xs: Stream A) n,
    xs # (S n) = (tl xs) # n.
Proof. reflexivity. Qed.

Section map.
  Context {A B : Type}.

  Variable (f : (A -> B)).

  Lemma map_Cons : forall a (sa : Stream A),
      (map f (a ⋅ sa)) = ((f a) ⋅ (map f sa)).
  Proof.
    intros a sa; simpl.
    rewrite unfold_Stream at 1; reflexivity.
  Qed.
End map.

Section map2.
  Context {A B C : Type}.

  Variable (f : (A -> B -> C)).

  CoFixpoint map2 (sa : Stream A) (sb : Stream B) : Stream C :=
    match sa, sb with
    | hda ⋅ tla, hdb ⋅ tlb =>
      (f hda hdb) ⋅ (map2 tla tlb)
    end.

  Lemma map2_Cons : forall a b (sa : Stream A) (sb : Stream B),
      (map2 (a ⋅ sa) (b ⋅ sb)) = ((f a b) ⋅ (map2 sa sb)).
  Proof.
    intros a b sa sb; simpl.
    rewrite unfold_Stream at 1; reflexivity.
  Qed.

  Lemma map2_hd : forall (sa : Stream A) (sb : Stream B),
      f (hd sa) (hd sb) = hd (map2 sa sb).
  Proof. intros [a sa] [b sb]; reflexivity. Qed.

  Lemma map2_tl : forall (sa : Stream A) (sb : Stream B),
      map2 (tl sa) (tl sb) = tl (map2 sa sb).
  Proof. intros [a sa] [b sb]; reflexivity. Qed.

  Lemma Str_nth_tl_map2 : forall n (sa : Stream A) (sb : Stream B),
      Str_nth_tl n (map2 sa sb) = map2 (Str_nth_tl n sa) (Str_nth_tl n sb).
  Proof.
    induction n; intros sa sb; simpl.
    - reflexivity.
    - destruct sa. destruct sb. simpl.
      auto.
  Qed.

  Lemma Str_nth_map2 : forall n (sa : Stream A) (sb : Stream B),
      Str_nth n (map2 sa sb) = f (Str_nth n sa) (Str_nth n sb).
  Proof.
    unfold Str_nth.
    induction n; intros [hda tla] [hdb tlb].
    - reflexivity.
    - simpl. auto.
  Qed.
End map2.

Add Parametric Relation A : (Stream A) (@EqSt A)
    reflexivity proved by (@EqSt_reflex A)
    symmetry proved by (@sym_EqSt A)
    transitivity proved by (@trans_EqSt A)
      as EqStrel.

Add Parametric Morphism A B C f : (@map2 A B C f)
    with signature (@EqSt A) ==> (@EqSt B) ==> (@EqSt C) as map2_EqSt.
Proof.
  cofix map2_EqSt.
  intros [? ?] [? ?] Eqa [? ?] [? ?] Eqb.
  inversion Eqa; simpl in *; subst; clear Eqa.
  inversion Eqb; simpl in *; subst; clear Eqb.
  rewrite map2_Cons. rewrite map2_Cons.
  constructor; simpl; auto.
Qed.

Section Forall.
  Context {A : Type}.
  Variable (P : A -> Prop).

  CoInductive SForall : Stream A -> Prop :=
  | Forall_Cons : forall a sa,
      P a ->
      SForall sa ->
      SForall (a ⋅ sa).

  Lemma SForall_forall : forall sa,
      SForall sa <-> forall n, P (Str_nth n sa).
  Proof with auto.
    intros sa.
    split; intros H.
    - intro n; revert n sa H.
      induction n; intros [a sa] Hf; inversion Hf; subst.
      + rewrite Str_nth_0...
      + rewrite Str_nth_S...
    - revert sa H.
      cofix forall_Forall.
      intros [a sa] H. constructor.
      + specialize (H 0). rewrite Str_nth_0 in H...
      + apply forall_Forall.
        intro n. specialize (H (S n)).
        rewrite Str_nth_S in H...
  Qed.
End Forall.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Naturals -- TODO: use typeclasses                                       *
**************************************************************************)

Set Implicit Arguments.
Require Export Arith Div2 Omega.
Require Import Psatz.
Require Import LibTactics LibReflect LibBool LibOperation LibRelation LibOrder.
Require Export LibOrder.
Global Close Scope positive_scope.

(* ********************************************************************** *)
(** * Inhabited and comparable *)

Instance nat_inhab : Inhab nat.
Proof using. intros. apply (prove_Inhab 0). Qed.

Fixpoint nat_compare (x y : nat) :=
  match x, y with
  | O, O => true
  | S x', S y' => nat_compare x' y'
  | _, _ => false
  end.

Instance nat_comparable : Comparable nat.
Proof using.
  applys (comparable_beq nat_compare).
  induction x; destruct y; simpl.
  autos*.
  auto_false.
  auto_false.
  asserts_rewrite ((S x = S y) = (x = y)).
    extens. iff; omega.
  autos*.
Qed.

(* ********************************************************************** *)
(** * Order on natural numbers *)

Instance le_nat_inst : Le nat := Build_Le Peano.le.

(* ---------------------------------------------------------------------- *)
(** ** Relation to Peano, for tactic [omega] *)

Lemma le_peano : le = Peano.le.
Proof using. extens*. Qed.

Global Opaque le_nat_inst.

Lemma lt_peano : lt = Peano.lt.
Proof using.
  extens. rew_to_le. rewrite le_peano.
  unfold strict. intros. omega.
Qed.

Lemma ge_peano : ge = Peano.ge.
Proof using.
  extens. rew_to_le. rewrite le_peano.
  unfold flip. intros. omega.
Qed.

Lemma gt_peano : gt = Peano.gt.
Proof using.
  extens. rew_to_le. rewrite le_peano.
  unfold strict, flip. intros. omega.
Qed.

Hint Rewrite le_peano lt_peano ge_peano gt_peano : rew_nat_comp.
Ltac nat_comp_to_peano :=
  autorewrite with rew_nat_comp in *.

(** [nat_math] calls [omega] after basic pre-processing
    ([intros] and [split]) and after replacing comparison
    operators with the ones defined in [Peano] library. *)

Ltac nat_math_setup :=
  intros;
  try match goal with |- _ /\ _ => split end;
  try match goal with |- _ = _ :> Prop => apply prop_ext; iff end;
  nat_comp_to_peano.

Ltac nat_math :=
  nat_math_setup; omega.

Ltac nat_math_lia :=
  nat_math_setup; lia.

Ltac nat_math_nia :=
  nat_math_setup; nia.

(* ---------------------------------------------------------------------- *)
(** ** Hint externs for calling nat_math{_lia,_nia} in the hint base
       [nat_maths]. *)

Ltac nat_math_hint := nat_math.

Hint Extern 3 (_ = _ :> nat) => nat_math_hint : nat_maths.
Hint Extern 3 (_ <> _ :> nat) => nat_math_hint : nat_maths.
Hint Extern 3 (istrue (isTrue (_ = _ :> nat))) => nat_math_hint : nat_maths.
Hint Extern 3 (istrue (isTrue (_ <> _ :> nat))) => nat_math_hint : nat_maths.
Hint Extern 3 (_ <= _) => nat_math_hint : nat_maths.
Hint Extern 3 (_ >= _) => nat_math_hint : nat_maths.
Hint Extern 3 (_ < _) => nat_math_hint : nat_maths.
Hint Extern 3 (_ > _) => nat_math_hint : nat_maths.
Hint Extern 3 (@le nat _ _ _) => nat_math_hint : nat_maths.
Hint Extern 3 (@lt nat _ _ _) => nat_math_hint : nat_maths.
Hint Extern 3 (@ge nat _ _ _) => nat_math_hint : nat_maths.
Hint Extern 3 (@gt nat _ _ _) => nat_math_hint : nat_maths.

(* ********************************************************************** *)
(** * Operations *)

Definition div (n q : nat) :=
  match q with
  | 0 => 0
  | S predq =>
  let aux := fix aux (m r : nat) {struct m} :=
    match m,r with
    | 0, _ => 0
    | S m',0 => (1 + aux m' predq)%nat
    | S m', S r' => aux m' r'
    end in
  aux n predq
  end.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | 0 => 1
  | S n' => n * (factorial n')
  end.

(* ********************************************************************** *)
(** * Induction *)

Lemma peano_induction :
  forall (P:nat->Prop),
    (forall n, (forall m, m < n -> P m) -> P n) ->
    (forall n, P n).
Proof using.
  introv H. cuts* K: (forall n m, m < n -> P m).
  nat_comp_to_peano.
  induction n; introv Le. inversion Le. apply H.
  intros. apply IHn. nat_math.
Qed.

Lemma measure_induction :
  forall (A:Type) (mu:A->nat) (P:A->Prop),
    (forall x, (forall y, mu y < mu x -> P y) -> P x) ->
    (forall x, P x).
Proof using.
  introv IH. intros x. gen_eq n: (mu x). gen x.
  induction n using peano_induction. introv Eq. subst*.
Qed.

(* ********************************************************************** *)
(** * Simplification lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Addition and substraction *)

Lemma plus_zero_r : forall n,
  n + 0 = n.
Proof using. nat_math. Qed.
Lemma plus_zero_l : forall n,
  0 + n = n.
Proof using. nat_math. Qed.
Lemma minus_zero : forall n,
  n - 0 = n.
Proof using. nat_math. Qed.

Hint Rewrite plus_zero_r plus_zero_l minus_zero : rew_nat.

(* ---------------------------------------------------------------------- *)
(** ** Comparison *)

Section CompProp.
Implicit Types a b c n m : nat.

Lemma le_SS : forall n m, (S n <= S m) = (n <= m).
Proof using. nat_math. Qed.
Lemma ge_SS : forall n m, (S n >= S m) = (n >= m).
Proof using. nat_math. Qed.
Lemma lt_SS : forall n m, (S n < S m) = (n < m).
Proof using. nat_math. Qed.
Lemma gt_SS : forall n m, (S n > S m) = (n > m).
Proof using. nat_math. Qed.

Lemma plus_le_l : forall a b c,
  (a + b <= a + c) = (b <= c).
Proof using. nat_math. Qed.
Lemma plus_ge_l : forall a b c,
  (a + b >= a + c) = (b >= c).
Proof using. nat_math. Qed.
Lemma plus_lt_l : forall a b c,
  (a + b < a + c) = (b < c).
Proof using. nat_math. Qed.
Lemma plus_gt_l : forall a b c,
  (a + b > a + c) = (b > c).
Proof using. nat_math. Qed.

Lemma plus_le_r : forall a b c,
  (b + a <= c + a) = (b <= c).
Proof using. nat_math. Qed.
Lemma plus_ge_r : forall a b c,
  (b + a >= c + a) = (b >= c).
Proof using. nat_math. Qed.
Lemma plus_lt_r : forall a b c,
  (b + a < c + a) = (b < c).
Proof using. nat_math. Qed.
Lemma plus_gt_r : forall a b c,
  (b + a > c + a) = (b > c).
Proof using. nat_math. Qed.

End CompProp.

(* todo: negation *)

(* ---------------------------------------------------------------------- *)
(** ** Simplification tactic *)

(** [rew_nat] performs some basic simplification on
    expressions involving natural numbers *)

Hint Rewrite le_SS ge_SS lt_SS gt_SS : rew_nat.
Hint Rewrite plus_le_l plus_ge_l plus_lt_l plus_gt_l : rew_nat.
Hint Rewrite plus_le_r plus_ge_r plus_lt_r plus_gt_r : rew_nat.

Tactic Notation "rew_nat" :=
  autorewrite with rew_nat.
Tactic Notation "rew_nat" "~" :=
  rew_nat; auto_tilde.
Tactic Notation "rew_nat" "*" :=
  rew_nat; auto_star.
Tactic Notation "rew_nat" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_nat).
  (* autorewrite with rew_nat in *. *)

Tactic Notation "rew_nat" "~" "in" "*" :=
  rew_nat in *; auto_tilde.
Tactic Notation "rew_nat" "*" "in" "*" :=
  rew_nat in *; auto_star.
Tactic Notation "rew_nat" "in" hyp(H) :=
  autorewrite with rew_nat in H.
Tactic Notation "rew_nat" "~" "in" hyp(H) :=
  rew_nat in H; auto_tilde.
Tactic Notation "rew_nat" "*" "in" hyp(H) :=
  rew_nat in H; auto_star.

(* ---------------------------------------------------------------------- *)
(* Total order instance *)

Instance nat_le_total_order : Le_total_order (A:=nat).
Proof using.
  constructor. constructor. constructor; unfolds.
  nat_math. nat_math. unfolds. nat_math. unfolds.
  intros. tests: (x <= y). left~. right. nat_math.
Qed.

(* ********************************************************************** *)
(** * Other lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Div2 *)

Lemma div2_lt : forall n m, m <= n -> n > 0 -> div2 m < n.
Proof using. (* using stdlib *)
  nat_comp_to_peano. introv Le Gt.
  forwards: Nat.div2_decr m (n-1). omega. omega.
Qed.

Lemma div2_grows : forall n m, m <= n -> div2 m <= div2 n.
Proof using.
  nat_comp_to_peano.
  induction n using peano_induction. introv Le.
  destruct~ m. simpl. omega.
  destruct~ n. simpl. omega.
  destruct~ m. simpl. omega.
  destruct~ n. simpl. omega.
  simpl. rew_nat. apply~ H. nat_math. nat_math.
Qed.


Theorem forward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
 intros A B C.
 intros proof_of_A A_implies_B A_imp_B_imp_C.
 pose (proof_of_B := A_implies_B proof_of_A).
 pose (proof_of_C := A_imp_B_imp_C proof_of_A proof_of_B).
 exact proof_of_C.
Show Proof.
Qed.


Require Import init.

Require Export linear_base.
Require Import unordered_list.
Require Import set.

Definition linear_combination_set {U V : Type} (l : ulist (U * V))
    := ulist_unique (ulist_image snd l).
Definition linear_combination {U V}
    `{VZ : Zero V, VP : Plus V, @PlusComm V VP,
        @PlusAssoc V VP, @PlusLid V VP VZ, ScalarMult U V}
    (l : set_type (@linear_combination_set U V))
    := ulist_sum (ulist_image (λ x, fst x · snd x) [l|]).
Definition linear_list_in {U V}
    (S : V → Prop) (l : set_type (@linear_combination_set U V))
    := ulist_prop (λ v, S (snd v)) [l|].
Definition linear_combination_of {U V}
    `{VZ : Zero V, VP : Plus V, @PlusComm V VP,
        @PlusAssoc V VP, @PlusLid V VP VZ, ScalarMult U V}
    (S : V → Prop) (v : V) :=
    ∃ l, v = linear_combination l ∧ linear_list_in S l.

(* begin hide *)
Section LinearBase.

Context {U V} `{AlgebraField U V}.

Theorem linear_combination_add : ∀ x l H1 H2,
    linear_combination [x ː l | H1] =
    fst x · snd x + linear_combination [l | H2].
Proof.
    intros x l HH1 HH2.
    unfold linear_combination; cbn.
    rewrite ulist_image_add, ulist_sum_add.
    reflexivity.
Qed.

Theorem linear_combination_of_zero : ∀ S, linear_combination_of S 0.
Proof.
    intros S.
    assert (@linear_combination_set U V ulist_end) as end_in.
    {
        unfold linear_combination_set.
        rewrite ulist_image_end.
        apply ulist_unique_end.
    }
    exists [ulist_end|end_in].
    split.
    -   unfold linear_combination; cbn.
        rewrite ulist_image_end, ulist_sum_end.
        reflexivity.
    -   unfold linear_list_in; cbn.
        apply ulist_prop_end.
Qed.

Theorem linear_combination_of_combination : ∀ S l,
    (∀ v, (∃ α, in_ulist [l|] (α, v)) → linear_combination_of S v) →
    linear_combination_of S (linear_combination l).
Proof.
    intros S [l l_comb] v_combs.
    induction l using ulist_induction.
    {
        unfold linear_combination; cbn.
        rewrite ulist_image_end, ulist_sum_end.
        apply linear_combination_of_zero.
    }
    cbn in v_combs.
    assert (linear_combination_set l) as l_comb'.
    {
        unfold linear_combination_set in l_comb.
        rewrite ulist_image_add, ulist_unique_add in l_comb.
        apply l_comb.
    }
    specialize (IHl l_comb').
    cbn in IHl.
    assert (∀ v, (∃ α, in_ulist l (α, v)) → linear_combination_of S v)
        as v_combs'.
    {
        intros v [α v_in].
        apply v_combs.
        exists α.
        rewrite in_ulist_add.
        right.
        exact v_in.
    }
    specialize (IHl v_combs').
    assert (linear_combination_of S (snd a)) as Sa.
    {
        apply v_combs.
        exists (fst a).
        rewrite in_ulist_add.
        left.
        destruct a; reflexivity.
    }
    unfold linear_combination; cbn.
    unfold linear_combination in IHl; cbn in IHl.
    clear v_combs v_combs' l_comb l_comb'.
    destruct IHl as [bl [bl_eq Sbl]].
    rewrite ulist_image_add, ulist_sum_add.
    rewrite bl_eq; clear bl_eq l.
    destruct Sa as [al [al_eq Sal]].
    rewrite al_eq; clear al_eq.
    destruct a as [α v]; cbn; clear v.
    destruct al as [al al_comb].
    induction al using ulist_induction.
    {
        unfold linear_combination at 1; cbn.
        rewrite ulist_image_end, ulist_sum_end.
        rewrite scalar_ranni.
        rewrite plus_lid.
        exists bl.
        split.
        -   reflexivity.
        -   exact Sbl.
    }
    unfold linear_combination at 1; cbn.
    unfold linear_combination_set in al_comb.
    unfold linear_list_in in Sal; cbn in Sal.
    rewrite ulist_image_add, ulist_unique_add in al_comb.
    assert (linear_combination_set al) as al_comb'.
    {
        apply al_comb.
    }
    assert (linear_list_in S [al|al_comb']) as Sal'.
    {
        rewrite ulist_prop_add in Sal.
        apply Sal.
    }
    specialize (IHal al_comb' Sal').
    rewrite ulist_image_add, ulist_sum_add.
    rewrite scalar_ldist.
    rewrite <- plus_assoc.
    destruct IHal as [l [l_eq Sl]].
    destruct a as [β v]; cbn in *.
    assert (S v) as Sv.
    {
        rewrite ulist_prop_add in Sal.
        apply Sal.
    }
    unfold linear_combination in l_eq at 1; cbn in l_eq.
    rewrite l_eq; clear al al_comb bl Sbl l_eq al_comb' Sal Sal'.
    destruct l as [l l_comb].
    unfold linear_list_in in Sl; cbn in Sl.
    rewrite scalar_comp.
    classic_case (∃ a, in_ulist l (a, v)) as [v_in|v_nin].
    -   destruct v_in as [a v_in].
        apply in_ulist_split in v_in as [l1 l1_eq].
        subst l.
        remember (α * β + a) as a'.
        pose (l' := (a', v) ː l1).
        assert (linear_combination_set l') as l'_comb.
        {
            unfold linear_combination_set in *.
            unfold l'.
            rewrite ulist_image_add, ulist_unique_add; cbn.
            rewrite ulist_image_add, ulist_unique_add in l_comb; cbn in l_comb.
            exact l_comb.
        }
        exists [l'|l'_comb].
        split.
        +   unfold l', linear_combination; cbn.
            do 2 rewrite ulist_image_add, ulist_sum_add.
            cbn.
            rewrite Heqa'.
            rewrite scalar_rdist.
            apply plus_assoc.
        +   unfold linear_list_in, l'; cbn.

            rewrite ulist_prop_add; cbn.
            rewrite ulist_prop_add in Sl; cbn in Sl.
            exact Sl.
    -   pose (l' := (α * β, v) ː l).
        assert (linear_combination_set l') as l'_comb.
        {
            unfold l', linear_combination_set; cbn.
            rewrite ulist_image_add, ulist_unique_add; cbn.
            split.
            2: exact l_comb.
            intros v_in.
            apply v_nin.
            apply image_in_ulist in v_in as [[a v'] [v_eq v_in]].
            cbn in v_eq.
            subst v'.
            exists a.
            exact v_in.
        }
        exists [l'|l'_comb].
        split.
        +   unfold l', linear_combination; cbn.
            rewrite ulist_image_add, ulist_sum_add; cbn.
            reflexivity.
        +   unfold linear_list_in, l'; cbn.
            rewrite ulist_prop_add; cbn.
            split; assumption.
Qed.

Theorem linear_combination_of_scalar : ∀ S a v,
    linear_combination_of S v → linear_combination_of S (a · v).
Proof.
    intros S a v v_comb.
    pose (l := (a, v) ː ulist_end).
    assert (linear_combination_set l) as l_comb.
    {
        unfold linear_combination_set, l.
        rewrite ulist_image_add, ulist_unique_add, ulist_image_end.
        split.
        -   apply in_ulist_end.
        -   apply ulist_unique_end.
    }
    pose proof (linear_combination_of_combination S [l|l_comb]) as eq.
    unfold linear_combination, l in eq; cbn in eq.
    rewrite ulist_image_add, ulist_sum_add in eq.
    rewrite ulist_image_end, ulist_sum_end in eq.
    rewrite plus_rid in eq.
    apply eq; clear eq.
    setoid_rewrite in_ulist_add.
    intros u [b [u_eq|contr]].
    2: contradiction (in_ulist_end _ contr).
    inversion u_eq.
    subst.
    exact v_comb.
Qed.

Theorem linear_combination_of_plus : ∀ S u v,
    linear_combination_of S u → linear_combination_of S v →
    linear_combination_of S (u + v).
Proof.
    intros S u v u_comb v_comb.
    classic_case (u = v) as [eq|neq].
    {
        subst.
        rewrite <- (scalar_id v).
        rewrite <- scalar_rdist.
        apply linear_combination_of_scalar.
        exact v_comb.
    }
    pose (l := (1, u) ː (1, v) ː ulist_end : ulist (U * V)).
    assert (linear_combination_set l) as l_comb.
    {
        unfold linear_combination_set, l; cbn.
        do 2 rewrite ulist_image_add, ulist_unique_add.
        rewrite in_ulist_add.
        rewrite ulist_image_end.
        rewrite not_or.
        cbn.
        repeat split.
        -   rewrite neq_sym; exact neq.
        -   apply in_ulist_end.
        -   apply in_ulist_end.
        -   apply ulist_unique_end.
    }
    pose proof (linear_combination_of_combination S [l|l_comb]) as eq.
    unfold linear_combination, l in eq; cbn in eq.
    do 2 rewrite ulist_image_add, ulist_sum_add in eq; cbn in eq.
    rewrite ulist_image_end, ulist_sum_end in eq.
    do 2 rewrite scalar_id in eq.
    rewrite plus_rid in eq.
    apply eq; clear eq.
    setoid_rewrite in_ulist_add.
    setoid_rewrite in_ulist_add.
    intros w [a [w_eq|[w_eq|contr]]].
    3: contradiction (in_ulist_end _ contr).
    all: inversion w_eq; subst.
    -   exact u_comb.
    -   exact v_comb.
Qed.

Definition linear_remove_zeros_base (l : set_type (@linear_combination_set U V))
    := ulist_filter (λ x, 0 ≠ fst x) [l|].

Lemma linear_remove_zeros_comb :
    ∀ l, linear_combination_set (linear_remove_zeros_base l).
Proof.
    intros l.
    apply ulist_filter_image_unique.
    exact [|l].
Qed.

Definition linear_remove_zeros l :=
    [linear_remove_zeros_base l|linear_remove_zeros_comb l].

Theorem linear_combination_remove_zeros : ∀ l,
    linear_combination l = linear_combination (linear_remove_zeros l).
Proof.
    intros [l l_uni].
    unfold linear_combination, linear_remove_zeros, linear_remove_zeros_base.
    cbn.
    clear l_uni.
    induction l using ulist_induction.
    -   rewrite ulist_filter_end.
        reflexivity.
    -   rewrite ulist_image_add, ulist_sum_add.
        rewrite IHl; clear IHl.
        classic_case (0 ≠ fst a).
        +   rewrite ulist_filter_add_in by exact n.
            rewrite ulist_image_add, ulist_sum_add.
            reflexivity.
        +   rewrite ulist_filter_add_nin by exact n.
            rewrite not_not in n.
            rewrite <- n.
            rewrite scalar_lanni.
            rewrite plus_lid.
            reflexivity.
Qed.

Theorem linear_list_in_remove_zeros : ∀ l S,
    linear_list_in S l → linear_list_in S (linear_remove_zeros l).
Proof.
    intros l S Sl.
    apply ulist_prop_other_filter.
    exact Sl.
Qed.

(* begin hide *)
End LinearBase.
(* end hide *)


Require Import BinInt.

Require Import Flocq.IEEE754.Binary.
Require Import Flocq.IEEE754.Bits.

Require Import FloatishDef.

Definition IEEE_float := binary64.
Definition IEEE_zero := B754_zero 53 1024 false.
Definition IEEE_opp := b64_opp.
Definition IEEE_plus := b64_plus mode_NE.
Definition IEEE_minus := b64_minus mode_NE.
Definition IEEE_mult := b64_mult mode_NE.
Definition IEEE_div := b64_div mode_NE.
Definition IEEE_sqrt := b64_sqrt mode_NE.
Definition IEEE_abs := b64_abs.

Definition IEEE_fromZ i := binary_normalize 53 1024 (eq_refl _) (eq_refl _) mode_NE i 0 false.

Definition IEEE_eq (x y:IEEE_float)
  := (match b64_compare x y with
      | Some Eq => true
      | _ => false
      end).

Definition IEEE_neq (x y:IEEE_float)
  := (match b64_compare x y with
      | Some Eq => false
      | Some _ => true
      | _ => false
      end).

Definition IEEE_lt (x y:IEEE_float)
  := (match b64_compare x y with
      | Some Lt => true
      | _ => false
      end).

Definition IEEE_le (x y:IEEE_float)
  := (match b64_compare x y with
      | Some Lt => true
      | Some Eq => true
      | _ => false
      end).

Definition IEEE_gt (x y:IEEE_float)
  := (match b64_compare x y with
      | Some Gt => true
      | _ => false
      end).

Definition IEEE_ge (x y:IEEE_float)
  := (match b64_compare x y with
      | Some Gt => true
      | Some Eq => true
      | _ => false
      end).

(* following function will be defined only via extraction *)
Axiom IEEE_exp : IEEE_float -> IEEE_float.
Axiom IEEE_ln : IEEE_float -> IEEE_float.
Axiom IEEE_pi : IEEE_float.
Axiom IEEE_sin : IEEE_float -> IEEE_float.
Axiom IEEE_cos : IEEE_float -> IEEE_float.

Local Instance floatish_IEEE : floatish :=
  {
    float := IEEE_float
    ; Fzero := IEEE_zero
    ; Fopp := IEEE_opp
    ; Fplus := IEEE_plus
    ; Fminus := IEEE_minus
    ; Fmult := IEEE_mult
    ; Fdiv := IEEE_div
    ; Fsqrt := IEEE_sqrt
    ; Fabs := IEEE_abs

    ; Fexp := IEEE_exp
    ; Fln  := IEEE_ln

    ; Fpi := IEEE_pi
    ; Fsin := IEEE_sin
    ; Fcos := IEEE_cos

    ; FfromZ := IEEE_fromZ

    ; Feq  := IEEE_eq
    ; Fneq := IEEE_neq
    ; Flt  := IEEE_lt
    ; Fle  := IEEE_le
    ; Fgt  := IEEE_gt
    ; Fge  := IEEE_ge
  }.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals ZArith Psatz.
From Flocq Require Import Core.

Require Import Xreal.

Inductive rounding_mode : Set :=
  rnd_UP | rnd_DN | rnd_ZR | rnd_NE.

Definition Rnearbyint mode r :=
  match mode with
  | rnd_UP => IZR (Zceil r)
  | rnd_DN => IZR (Zfloor r)
  | rnd_ZR => IZR (Ztrunc r)
  | rnd_NE => IZR (ZnearestE r)
  end.

Notation Xnearbyint := (fun mode => Xlift (Rnearbyint mode)).

Lemma Rnearbyint_le :
  forall mode x y,
  (x <= y)%R ->
  (Rnearbyint mode x <= Rnearbyint mode y)%R.
Proof.
intros mode x y Hxy.
destruct mode ; simpl.
now apply IZR_le, Zceil_le.
now apply IZR_le, Zfloor_le.
now apply IZR_le, Ztrunc_le.
now apply IZR_le; destruct (valid_rnd_N (fun x => negb (Z.even x))); auto.
Qed.

Lemma Rnearbyint_error_DN x :
  (-1 <= Rnearbyint rnd_DN x - x <= 0)%R.
Proof.
assert (H := (Zfloor_ub x, Zfloor_lb x)).
case H; simpl; lra.
Qed.

Lemma Rnearbyint_error_UP x :
  (0 <= Rnearbyint rnd_UP x - x <= 1)%R.
Proof.
assert (H := (Zfloor_ub (- x), Zfloor_lb (- x))).
simpl; unfold Zceil; rewrite opp_IZR.
case H; simpl; lra.
Qed.

Lemma Rnearbyint_error_ZR_neg x :
  (x <= 0 ->
   0 <= Rnearbyint rnd_ZR x - x <= 1)%R.
Proof.
simpl; unfold Ztrunc.
case Rlt_bool_spec; try lra.
intros; apply Rnearbyint_error_UP.
intros H H0.
assert (H1 : x = 0%R) by lra.
assert (H2 := Zfloor_IZR 0); simpl in H2.
rewrite H1, H2; simpl; lra.
Qed.

Lemma Rnearbyint_error_ZR_pos x :
  (0 <= x ->
   -1 <= Rnearbyint rnd_ZR x - x <= 0)%R.
Proof.
simpl; unfold Ztrunc.
case Rlt_bool_spec; try lra.
now intros; apply Rnearbyint_error_DN.
Qed.

Lemma Rnearbyint_error_ZR x :
  (-1 <= Rnearbyint rnd_ZR x - x <= 1)%R.
Proof.
assert (H := (Rnearbyint_error_ZR_neg x, Rnearbyint_error_ZR_pos x)).
case H; simpl; lra.
Qed.

Lemma Rnearbyint_error_NE x :
  (- (1/2) <= Rnearbyint rnd_NE x - x <= 1/2)%R.
Proof.
simpl.
assert (H := Znearest_half (fun x => negb (Z.even x)) x).
split_Rabs; lra.
Qed.

Lemma Rnearbyint_error m x :
  (-1 <= Rnearbyint m x - x <= 1)%R.
Proof.
assert (H1 := Rnearbyint_error_DN x).
assert (H2 := Rnearbyint_error_UP x).
assert (H3 := Rnearbyint_error_ZR x).
assert (H4 := Rnearbyint_error_NE x).
case m; lra.
Qed.

Notation radix2 := Zaux.radix2 (only parsing).

Section Definitions.

Variable beta : radix.

Fixpoint count_digits_aux nb pow (p q : positive) { struct q } : positive :=
  if Zlt_bool (Zpos p) pow then nb
  else
    match q with
    | xH => nb
    | xI r => count_digits_aux (Pos.succ nb) (Zmult beta pow) p r
    | xO r => count_digits_aux (Pos.succ nb) (Zmult beta pow) p r
    end.

Definition count_digits n :=
  count_digits_aux 1 beta n n.

Definition FtoR (s : bool) m e :=
  let sm := if s then Zneg m else Zpos m in
  match e with
  | Zpos p => IZR (sm * Zpower_pos beta p)
  | Z0 => IZR sm
  | Zneg p => (IZR sm / IZR (Zpower_pos beta p))%R
  end.

End Definitions.

Definition rnd_of_mode mode :=
  match mode with
  | rnd_UP => rndUP
  | rnd_DN => rndDN
  | rnd_ZR => rndZR
  | rnd_NE => rndNE
  end.

Definition round beta mode prec :=
  round beta (FLX_exp (Zpos prec)) (rnd_of_mode mode).

Definition Xround beta mode prec := Xlift (round beta mode prec).

Inductive float (beta : radix) : Set :=
  | Fnan : float beta
  | Fzero : float beta
  | Float : bool -> positive -> Z -> float beta.

Arguments Fnan {beta}.
Arguments Fzero {beta}.
Arguments Float {beta} _ _ _.

Definition FtoX {beta} (f : float beta) :=
  match f with
  | Fzero => Xreal 0
  | Fnan => Xnan
  | Float s m e => Xreal (FtoR beta s m e)
  end.

Instance zpos_gt_0 : forall prec, Prec_gt_0 (Zpos prec).
Proof.
easy.
Qed.

Instance valid_rnd_of_mode : forall mode, Valid_rnd (rnd_of_mode mode).
Proof.
destruct mode ; simpl ; auto with typeclass_instances.
Qed.

Lemma FtoR_split :
  forall beta s m e,
  FtoR beta s m e = F2R (Defs.Float beta (cond_Zopp s (Zpos m)) e).
Proof.
intros.
unfold FtoR, F2R, cond_Zopp. simpl.
case e.
now rewrite Rmult_1_r.
intros p.
now rewrite mult_IZR.
now intros p.
Qed.

Lemma is_zero_correct_float :
  forall beta s m e,
  is_zero (FtoR beta s m e) = false.
Proof.
intros beta s m e.
rewrite FtoR_split.
case is_zero_spec ; try easy.
intros H.
apply eq_0_F2R in H.
now destruct s.
Qed.


Require Import List.
Require Import Parametricity.

Lemma nat_R_equal :
  forall x y, nat_R x y -> x = y.
intros x y H; induction H; subst; trivial.
Defined.

Lemma equal_nat_R :
  forall x y, x = y -> nat_R x y.
intros x y H; subst.
induction y; constructor; trivial.
Defined.

Definition full_relation {A B} (x : A) (y : B) := True.

Definition same_length {A B} := list_R A B full_relation.

Lemma same_length_length :
  forall A B (l1 : list A) (l2 : list B),
    same_length l1 l2 -> length l1 = length l2.
intros A B l1 l2 H.
induction H; simpl.
reflexivity.
exact (f_equal S IHlist_R).
Qed.

Lemma length_same_length :
  forall A B (l1 : list A) (l2 : list B),
    length l1 = length l2 -> same_length l1 l2.
admit. (* exercise :) *)
Admitted.

Module LengthType.

Definition T := forall X, list X -> nat.
Parametricity T.

Definition FREE_THEOREM (f : T) :=
  forall A l1 l2,  same_length l1 l2 -> f A l1 = f A l2.

Lemma param_length_type :
  forall f (f_R  : T_R f f), FREE_THEOREM f.
repeat intro.
apply nat_R_equal.
apply (f_R A A (fun _ _ => True)).
assumption.
Qed.

Parametricity length.
Definition length_rev : T := fun A l => length (rev l).

Parametricity Recursive length_rev.
Definition double_length : T := fun A l => length (l ++ l).

Parametricity Recursive double_length.
Definition constant : T := fun A l => 42.
Parametricity constant.

Definition length_free_theorem : FREE_THEOREM length
  := param_length_type length length_R.
Definition double_length_free_theorem : FREE_THEOREM double_length
  := param_length_type double_length double_length_R.
Definition constant_free_theorem : FREE_THEOREM constant
  := param_length_type constant constant_R.

End LengthType.

Definition graph {A B} (f : A -> B) := fun x y => f x = y.

Definition map_rel {A B} (f : A -> B) :=
  list_R A B (graph f).

Lemma map_rel_map A B (f : A -> B) :
   forall (l : list A), map_rel f l (map f l).
induction l; constructor; compute; auto.
Defined.

Lemma rel_map_map A B (f : A -> B) :
   forall (l: list A) fl, map_rel f l fl -> fl = map f l.
intros; induction X; unfold graph in *; subst; reflexivity.
Defined.

Module RevType.

Definition T := forall X, list X -> list X.
Parametricity T.

Definition FREE_THEOREM (F : T) :=
 forall A B (f : A -> B) l,
      F B (map f l) = map f (F A l).

Lemma param_naturality :
   forall F (F_R : T_R F F), FREE_THEOREM F.
repeat intro.
apply rel_map_map.
apply F_R.
apply map_rel_map.
Defined.

Parametricity rev.

Definition tail : T := fun A l =>
  match l with
    | nil => nil
    | hd :: tl => tl
  end.
Parametricity tail.

Definition rev_rev : T := fun A l => rev (rev l).
Parametricity rev_rev.

Definition rev_naturality : FREE_THEOREM rev
 := param_naturality rev rev_R.
Definition rev_rev_naturality : FREE_THEOREM rev_rev
 := param_naturality rev_rev rev_rev_R.
Definition tail_naturality : FREE_THEOREM tail
 := param_naturality tail tail_R.

End RevType.

Parametricity prod.

Definition prod_map {A B} (f : A -> B)
                  {A' B'} (f' : A' -> B') :=
           prod_R A B (graph f) A' B' (graph f').

Definition pair {A B} (f : A -> B) {A' B'} (f' : A' -> B') : A * A' -> B * B' :=
  fun c => let (x, x') := c in (f x, f' x').

Lemma pair_prod_map :
  forall A B (f : A -> B)
         A' B' (f' : A' -> B') xy xy',
       graph (pair f f') xy xy' -> prod_map f f' xy xy'.
intros ? ? f ? ? f' [x y] [x' y'].
intro H.
compute in H.
injection H.
intros; subst.
constructor; reflexivity.
Defined.

Lemma prod_map_pair :
  forall A B (f : A -> B)
         A' B' (f' : A' -> B') xy xy',
       prod_map f f' xy xy' -> graph (pair f f') xy xy'.
intros ? ? f ? ? f' [x y] [x' y'].
intro H.
compute in H.
induction H; subst.
reflexivity.
Defined.

Lemma list_R_prod_map A B (f : A -> B) A' B' (f' : A' -> B') l1 l2 :
  list_R _ _ (prod_map f f') l1 l2 -> list_R _ _ (graph (pair f f')) l1 l2.
intro H; induction H; constructor; [ apply prod_map_pair|]; auto.
Defined.

Module ZipType.

Definition T :=
  forall X Y, list X -> list Y -> list (X * Y).
Parametricity T.

Definition FREE_THEOREM (F : T) := forall
     A B (f : A -> B)
     A' B' (f' : A' -> B') l l',
      F B B' (map f l) (map f' l') = map (pair f f') (F A A' l l').

Lemma param_ZIP_naturality :
   forall F (F_R : T_R F F), FREE_THEOREM F.
repeat intro.
specialize (F_R A B (graph f) A' B' (graph f') l (map f l) (map_rel_map _ _ _ _) l' (map f' l') (map_rel_map _ _ _ _)).
apply rel_map_map.
unfold map_rel.
apply list_R_prod_map.
unfold prod_map.
assumption.
Defined.

Fixpoint zip {X Y} (l1 : list X) (l2 : list Y) : list (X * Y) :=
  match l1, l2 with
   | nil, _ => nil
   | _, nil => nil
   | x::tl1, y::tl2 => (x,y)::(zip tl1 tl2)
  end.
Parametricity zip.
Definition zip_free_theorem : FREE_THEOREM (@zip) := param_ZIP_naturality _ zip_R.

End ZipType.