(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2014: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations Axioms Derived_Terms Derived_Pairs
        Derived_Products Derived_Rules.
Set Implicit Arguments.
Require Import ZArith.
Open Scope Z_scope.

Module Make(Import M: Memory.T).
  Module Export ProofsExp := Derived_Rules.Make(M).

(* --- Main Proofs --- *)

 Theorem annihilation_update_lookup: forall i: Loc,
         update i o lookup i == id.
         (* Prop: 2.1: All Cases *)
 Proof.
     intro. remember observation. apply observation. intro k.
     destruct (Loc_dec i k). rewrite <- e.
     (*Case k = i*)
     rewrite assoc. setoid_rewrite -> id_src. setoid_rewrite <- id_tgt at 6.
     apply wsc. apply axiom_1. apply strong_refl.
     (*Case k <> i*)
     rewrite assoc. remember wsc. rewrite axiom_2; try decorate.
     apply strong_to_weak. rewrite <- assoc. apply sc. apply strong_refl.
     apply E_1_4; decorate.
 Qed.

 Theorem interaction_lookup_lookup: forall i,
         lookup i o forget o lookup i == lookup i.
         (* Prop: 2.2: All Cases: Simplified Version *)
 Proof.
     intros. setoid_rewrite <- id_src at 6. rewrite <- assoc. apply sc.
     apply strong_refl. apply E_1_4; decorate.
 Qed.

 Theorem interaction_update_lookup: forall i: Loc,
         lookup i o update i ~~ id. (* Prop: 2.4: All Cases *)
 Proof. intros. apply axiom_1. Qed.

 Theorem commutation_lookup_lookup: forall i j: Loc, i<>j ->
         (prod id (lookup j)) o (inv_pi1 o lookup i)
         ==
         permut o ((prod id (lookup i)) o (inv_pi1 o lookup j)).
         (* Prop: 2.5: All Cases *)
 Proof.
    intros. remember strong_unicity.
    specialize (@strong_unicity _ _ _
    (prod id (lookup j) o (inv_pi1 o lookup i))
    ((permut) o ((prod id (lookup i)) o (inv_pi1 o lookup j)))).
    intros. apply H0.
    (*Case pi1*)
    setoid_rewrite assoc at 1. remember wsc.
    rewrite strong_proj_pi1_purero_rect; try decorate. rewrite id_tgt.
    rewrite assoc. unfold inv_pi1. rewrite strong_proj_pi1_purero; try decorate.
    rewrite id_tgt. apply weak_sym.
    (*Step 2*)
    rewrite assoc. apply strong_to_weak. remember sc.
    rewrite strong_pi1_permut__pi2. rewrite assoc.
    rewrite strong_proj_pi2_purero_rect; try decorate. rewrite assoc.
    setoid_rewrite <- assoc at 2. rewrite strong_proj_pi2_purero; try decorate.
    rewrite <- assoc. rewrite E_1_4; try decorate. rewrite id_src. apply strong_refl.
    (*Case pi2*)
    rewrite assoc. remember sc. rewrite strong_proj_pi2_purero_rect; try decorate.
    rewrite assoc. setoid_rewrite <- assoc at 2. rewrite strong_pi2_inv_pi1__unit.
    rewrite <- assoc. rewrite E_1_4; try decorate. rewrite id_src. apply strong_sym.
    (*Step 2*)
    rewrite assoc. rewrite strong_pi2_permut__pi1. rewrite assoc.
    rewrite strong_proj_pi1_purero_rect; try decorate. rewrite id_tgt.
    rewrite assoc. unfold inv_pi1. rewrite strong_proj_pi1_purero; try decorate.
    rewrite id_tgt. apply strong_refl.
 Qed.

 Theorem commutation_lookup_constant: forall i: Loc, forall c: Z,
         (lookup i o (update i o (constant c)))
         ==
         (constant c) o update i o (constant c).
         (*Prop 2.8: All Cases*)
 Proof.
     intros. remember comp_final_unique. specialize (@comp_final_unique _ _
     (lookup i o (update i o (constant c)))
     ((constant c) o (update i o (constant c)))).
     intros. setoid_rewrite <- assoc at 1. apply H.
     (* Case 1: <> o f == <> o g *)
     rewrite assoc. specialize (@E_1_4 _ (lookup i)). intros. remember sc.
     rewrite H0; try decorate. rewrite id_tgt. apply strong_sym. rewrite assoc.
     specialize (@E_0_4 _ (constant c)).  intros. rewrite H1; try decorate.
     rewrite id_tgt. apply strong_refl.
     (* Case 2: f ~ g *)
     rewrite assoc. remember wsc. rewrite axiom_1. rewrite id_tgt.
     rewrite <- id_src at 1. apply wrc; try decorate. apply weak_final_unique.
 Qed.

 Lemma commutation_lookup_constant_update: forall (m: Loc) (p q: Z),
      (pair (lookup m) (constant q)) o (update m o constant p)
      ==
      (pair (constant p) (constant q)) o (update m o constant p).
 Proof.
      intros. apply strong_unicity. repeat rewrite assoc. remember wrc.
      rewrite weak_proj_pi1_rorw;  try decorate. rewrite axiom_1.
      rewrite id_tgt. apply weak_sym.
      repeat rewrite assoc. rewrite weak_proj_pi1_rorw;  try decorate.
      setoid_rewrite <- id_src at 6. rewrite <- assoc.
      apply wrc; (solve[decorate] || idtac). apply weak_final_unique.
      repeat rewrite assoc. remember sc.
      rewrite strong_proj_pi2_rorw;  try decorate. apply strong_sym.
      rewrite strong_proj_pi2_rorw;  try decorate. apply strong_refl.
 Qed.

 Lemma commutation_constant_lookup_update: forall (m: Loc) (p q: Z),
      (pair (constant q) (lookup m)) o (update m o constant p)
      ==
      (pair (constant q) (constant p)) o (update m o constant p).
 Proof.
      intros. apply strong_unicity. repeat rewrite assoc. remember wrc.
      rewrite weak_proj_pi1_rorw;  try decorate. apply weak_sym.
      rewrite weak_proj_pi1_rorw;  try decorate. apply weak_refl.
      repeat rewrite assoc. remember sc.
      rewrite strong_proj_pi2_rorw;  try decorate.
      specialize(@commutation_lookup_constant m p). intros.
      rewrite <- assoc. rewrite H. apply strong_sym.
      rewrite strong_proj_pi2_rorw;  try decorate. apply strong_refl.
 Qed.

Lemma commutation_update_update: forall {x y: Loc}, forall (n m: Z), x<>y ->
	(update y o constant m) o (update x o constant n) ==
        (update x o constant n) o (update y o constant m).
 Proof.
    intros. apply observation. intros.
    (* i = y *)
    destruct (Loc_dec i y). rewrite e. repeat rewrite assoc. rewrite axiom_1.
    intros. apply weak_sym. rewrite  axiom_2; try decorate. specialize(@E_0_4 _ (constant n)).
    intros. setoid_rewrite <- assoc at 3. rewrite H0; try decorate.
    setoid_rewrite id_src. rewrite axiom_1. rewrite id_tgt. apply weak_sym.
    specialize(@weak_final_unique _ (update x o (constant n)) (@id unit)).
    intros. rewrite <- assoc. rewrite H1. rewrite id_src. apply weak_refl.
    (* i = x *)
    destruct (Loc_dec i x). rewrite e. repeat rewrite assoc. rewrite  axiom_2.
    specialize(@E_0_4 _ (constant m)). intros. setoid_rewrite <- assoc at 3.
    rewrite H0; try decorate. setoid_rewrite id_src. rewrite axiom_1. rewrite id_tgt.
    setoid_rewrite <- id_src at 1. rewrite <- assoc. apply wrc; try decorate.
    apply weak_final_unique. auto.
    (* i <> x and i <> y *)
    repeat rewrite assoc. rewrite axiom_2; (auto || idtac). specialize(@E_0_4 _ (constant m)).
    intros. setoid_rewrite <- assoc at 3. rewrite H0; (solve[decorate] || idtac).
    rewrite id_src. rewrite axiom_2; (auto || idtac). rewrite <- assoc. apply weak_sym.
    remember E_0_4. specialize(@E_0_4 _ (constant n)). intros.
    remember wsc. rewrite H1 at 1; try decorate. rewrite id_src. rewrite assoc.
    rewrite axiom_2; auto. repeat rewrite <- assoc. apply strong_to_weak. apply sc.
    apply strong_refl. apply one_weak_to_strong; try decorate. apply weak_final_unique.
 Qed.

(* -------------------- End of Main Proofs -------------------- *)

End Make.


From mathcomp Require Import all_ssreflect.
From mathcomp.analysis Require Import classical_sets boolp.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevanceFacts ProofIrrelevance.

Lemma funext (A B : Type) (f g : A -> B) : f =1 g -> f = g.
Proof.
  move=> H. extensionality x. apply: H.
Qed.

Export classical_sets boolp FunctionalExtensionality ProofIrrelevance ProofIrrelevanceFacts.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Properties of [abs] and [sgn] *)

Require Import ZMulOrder.

(** Since we already have [max], we could have defined [abs]. *)

Module GenericAbs (Import Z : ZAxiomsMiniSig')
                  (Import ZP : ZMulOrderProp Z) <: HasAbs Z.
 Definition abs n := max n (-n).
 Lemma abs_eq : forall n, 0<=n -> abs n == n.
 Proof.
  intros. unfold abs. apply max_l.
  apply le_trans with 0; auto.
  rewrite opp_nonpos_nonneg; auto.
 Qed.
 Lemma abs_neq : forall n, n<=0 -> abs n == -n.
 Proof.
  intros. unfold abs. apply max_r.
  apply le_trans with 0; auto.
  rewrite opp_nonneg_nonpos; auto.
 Qed.
End GenericAbs.

(** We can deduce a [sgn] function from a [compare] function *)

Module Type ZDecAxiomsSig := ZAxiomsMiniSig <+ HasCompare.
Module Type ZDecAxiomsSig' := ZAxiomsMiniSig' <+ HasCompare.

Module Type GenericSgn (Import Z : ZDecAxiomsSig')
                       (Import ZP : ZMulOrderProp Z) <: HasSgn Z.
 Definition sgn n :=
  match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end.
 Lemma sgn_null : forall n, n==0 -> sgn n == 0.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
 Lemma sgn_pos : forall n, 0<n -> sgn n == 1.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
 Lemma sgn_neg : forall n, n<0 -> sgn n == -1.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
End GenericSgn.

(** Derived properties of [abs] and [sgn] *)

Module Type ZSgnAbsProp (Import Z : ZAxiomsSig')
                        (Import ZP : ZMulOrderProp Z).

Ltac destruct_max n :=
 destruct (le_ge_cases 0 n);
  [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto].

Instance abs_wd : Proper (eq==>eq) abs.
Proof.
 intros x y EQ. destruct_max x.
 rewrite abs_eq; trivial. now rewrite <- EQ.
 rewrite abs_neq; try order. now rewrite opp_inj_wd.
Qed.

Lemma abs_max : forall n, abs n == max n (-n).
Proof.
 intros n. destruct_max n.
 rewrite max_l; auto with relations.
 apply le_trans with 0; auto.
 rewrite opp_nonpos_nonneg; auto.
 rewrite max_r; auto with relations.
 apply le_trans with 0; auto.
 rewrite opp_nonneg_nonpos; auto.
Qed.

Lemma abs_neq' : forall n, 0<=-n -> abs n == -n.
Proof.
 intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos.
Qed.

Lemma abs_nonneg : forall n, 0 <= abs n.
Proof.
 intros n. destruct_max n; auto.
 now rewrite opp_nonneg_nonpos.
Qed.

Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n.
Proof.
 split; try apply abs_eq. intros EQ.
 rewrite <- EQ. apply abs_nonneg.
Qed.

Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0.
Proof.
 split; try apply abs_neq. intros EQ.
 rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg.
Qed.

Lemma abs_opp : forall n, abs (-n) == abs n.
Proof.
 intros. destruct_max n.
 rewrite (abs_neq (-n)), opp_involutive. reflexivity.
 now rewrite opp_nonpos_nonneg.
 rewrite (abs_eq (-n)). reflexivity.
 now rewrite opp_nonneg_nonpos.
Qed.

Lemma abs_0 : abs 0 == 0.
Proof.
 apply abs_eq. apply le_refl.
Qed.

Lemma abs_0_iff : forall n, abs n == 0 <-> n==0.
Proof.
 split. destruct_max n; auto.
 now rewrite eq_opp_l, opp_0.
 intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl.
Qed.

Lemma abs_pos : forall n, 0 < abs n <-> n~=0.
Proof.
 intros. rewrite <- abs_0_iff. split; [intros LT| intros NEQ].
 intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0).
 assert (LE : 0 <= abs n) by apply abs_nonneg.
 rewrite lt_eq_cases in LE; destruct LE; auto.
 elim NEQ; auto with relations.
Qed.

Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n.
Proof.
 intros. destruct_max n; auto with relations.
Qed.

Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n.
Proof.
 intros. destruct_max n; rewrite ? opp_involutive; auto with relations.
Qed.

Lemma abs_involutive : forall n, abs (abs n) == abs n.
Proof.
 intros. apply abs_eq. apply abs_nonneg.
Qed.

Lemma abs_spec : forall n,
  (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n).
Proof.
 intros. destruct (le_gt_cases 0 n).
 left; split; auto. now apply abs_eq.
 right; split; auto. apply abs_neq. now apply lt_le_incl.
Qed.

Lemma abs_case_strong :
  forall (P:t->Prop) n, Proper (eq==>iff) P ->
    (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n).
Proof.
 intros. destruct_max n; auto.
Qed.

Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P ->
 P n -> P (-n) -> P (abs n).
Proof. intros. now apply abs_case_strong. Qed.

Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m.
Proof.
 intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn].
 rewrite EQn, EQ. apply abs_eq_or_opp.
 rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp.
Qed.

Lemma abs_lt : forall a b, abs a < b <-> -b < a < b.
Proof.
 intros a b.
 destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ.
 split; try split; try destruct 1; try order.
 apply lt_le_trans with 0; trivial. apply opp_neg_pos; order.
 rewrite opp_lt_mono, opp_involutive.
 split; try split; try destruct 1; try order.
 apply lt_le_trans with 0; trivial. apply opp_nonpos_nonneg; order.
Qed.

Lemma abs_le : forall a b, abs a <= b <-> -b <= a <= b.
Proof.
 intros a b.
 destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ.
 split; try split; try destruct 1; try order.
 apply le_trans with 0; trivial. apply opp_nonpos_nonneg; order.
 rewrite opp_le_mono, opp_involutive.
 split; try split; try destruct 1; try order.
 apply le_trans with 0. order. apply opp_nonpos_nonneg; order.
Qed.

(** Triangular inequality *)

Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m.
Proof.
 intros. destruct_max n; destruct_max m.
 rewrite abs_eq. apply le_refl. now apply add_nonneg_nonneg.
 destruct_max (n+m); try rewrite opp_add_distr;
  apply add_le_mono_l || apply add_le_mono_r.
 apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos.
 apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg.
 destruct_max (n+m); try rewrite opp_add_distr;
  apply add_le_mono_l || apply add_le_mono_r.
 apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos.
 apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg.
 rewrite abs_neq, opp_add_distr. apply le_refl.
 now apply add_nonpos_nonpos.
Qed.

Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m).
Proof.
 intros.
 rewrite le_sub_le_add_l, add_comm.
 rewrite <- (sub_simpl_r n m) at 1.
 apply abs_triangle.
Qed.

(** Absolute value and multiplication *)

Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m.
Proof.
 assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m).
  intros. destruct_max m.
  rewrite abs_eq. apply eq_refl. now apply mul_nonneg_nonneg.
  rewrite abs_neq, mul_opp_r. reflexivity. now apply mul_nonneg_nonpos .
 intros. destruct_max n. now apply H.
 rewrite <- mul_opp_opp, H, abs_opp. reflexivity.
 now apply opp_nonneg_nonpos.
Qed.

Lemma abs_square : forall n, abs n * abs n == n * n.
Proof.
 intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square.
Qed.

(** Some results about the sign function. *)

Ltac destruct_sgn n :=
 let LT := fresh "LT" in
 let EQ := fresh "EQ" in
 let GT := fresh "GT" in
 destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]];
 [rewrite (sgn_pos n) by auto|
  rewrite (sgn_null n) by auto with relations|
  rewrite (sgn_neg n) by auto].

Instance sgn_wd : Proper (eq==>eq) sgn.
Proof.
 intros x y Hxy. destruct_sgn x.
 rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto.
 rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations.
 rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto.
Qed.

Lemma sgn_spec : forall n,
  0 < n /\ sgn n == 1 \/
  0 == n /\ sgn n == 0 \/
  0 > n /\ sgn n == -1.
Proof.
 intros n.
 destruct_sgn n; [left|right;left|right;right]; auto with relations.
Qed.

Lemma sgn_0 : sgn 0 == 0.
Proof.
 now apply sgn_null.
Qed.

Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0<n.
Proof.
 split; try apply sgn_pos. destruct_sgn n; auto.
 intros. elim (lt_neq 0 1); auto. apply lt_0_1.
 intros. elim (lt_neq (-1) 1); auto.
 apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1.
Qed.

Lemma sgn_null_iff : forall n, sgn n == 0 <-> n==0.
Proof.
 split; try apply sgn_null. destruct_sgn n; auto with relations.
 intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1.
 intros. elim (lt_neq (-1) 0); auto.
 rewrite opp_neg_pos. apply lt_0_1.
Qed.

Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0.
Proof.
 split; try apply sgn_neg. destruct_sgn n; auto with relations.
 intros. elim (lt_neq (-1) 1); auto with relations.
 apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1.
 intros. elim (lt_neq (-1) 0); auto with relations.
 rewrite opp_neg_pos. apply lt_0_1.
Qed.

Lemma sgn_opp : forall n, sgn (-n) == - sgn n.
Proof.
 intros. destruct_sgn n.
 apply sgn_neg. now rewrite opp_neg_pos.
 setoid_replace n with 0 by auto with relations.
  rewrite opp_0. apply sgn_0.
 rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg.
Qed.

Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n.
Proof.
 split.
 destruct_sgn n; intros.
 now apply lt_le_incl.
 order.
 elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1.
  now rewrite <- opp_nonneg_nonpos.
 rewrite lt_eq_cases; destruct 1.
 rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1.
 rewrite sgn_null by auto with relations. apply le_refl.
Qed.

Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0.
Proof.
 intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg.
Qed.

Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m.
Proof.
 intros. destruct_sgn n; nzsimpl.
 destruct_sgn m.
  apply sgn_pos. now apply mul_pos_pos.
  apply sgn_null. rewrite eq_mul_0; auto with relations.
  apply sgn_neg. now apply mul_pos_neg.
 apply sgn_null. rewrite eq_mul_0; auto with relations.
 destruct_sgn m; try rewrite mul_opp_opp; nzsimpl.
  apply sgn_neg. now apply mul_neg_pos.
  apply sgn_null. rewrite eq_mul_0; auto with relations.
  apply sgn_pos. now apply mul_neg_neg.
Qed.

Lemma sgn_abs : forall n, n * sgn n == abs n.
Proof.
 intros. symmetry.
 destruct_sgn n; try rewrite mul_opp_r; nzsimpl.
 apply abs_eq. now apply lt_le_incl.
 rewrite abs_0_iff; auto with relations.
 apply abs_neq. now apply lt_le_incl.
Qed.

Lemma abs_sgn : forall n, abs n * sgn n == n.
Proof.
 intros.
 destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto.
 apply abs_eq. now apply lt_le_incl.
 rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl.
Qed.

Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x.
Proof.
 intros.
 destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ.
 apply sgn_pos, lt_0_1.
 now apply sgn_null.
 apply sgn_neg. rewrite opp_neg_pos. apply lt_0_1.
Qed.

End ZSgnAbsProp.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

Require Import Coq.MSets.MSets.
Require Import CoqMSetInterface.

(* *********************************************************************** *)
(** * Interface *)

Module Type WSfun (X : DecidableType).

  Include CoqMSetInterface.WSetsOn X.

  (** Definition of when two sets are disjoint. *)

  Definition disjoint E F := inter E F [=] empty.

  (** We make [notin] a definition for [~ In x L].  We use this
      definition whenever possible, so that the [intuition] tactic
      does not turn [~ In x L] into [In x L -> False]. *)

  Definition notin x L := ~ In x L.

  (** The predicate [fresh_list L n xs] holds when [xs] is a list of
      length [n] such that the elements are distinct from each other
      and from the elements of [L]. *)

  Fixpoint fresh_list
      (L : t) (n : nat) (xs : list X.t) {struct xs} : Prop :=
    match xs, n with
      | nil, O =>
        True
      | cons x xs', S n' =>
        notin x L /\ fresh_list (union L (singleton x)) n' xs'
      | _, _ =>
        False
    end.

End WSfun.

(* *********************************************************************** *)
(** * Implementation *)

Module Make (X : DecidableType) <: WSfun X.

  Include Coq.MSets.MSetWeakList.Make X.

  Definition disjoint E F := Equal (inter E F) empty.

  Definition notin x L := ~ In x L.

  Fixpoint fresh_list
      (L : t) (n : nat) (xs : list X.t) {struct xs} : Prop :=
    match xs, n with
      | nil, O =>
        True
      | cons x xs', S n' =>
        notin x L /\ fresh_list (union L (singleton x)) n' xs'
      | _, _ =>
        False
    end.

End Make.


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (C) 2010-2012, ENS de Lyon.
Copyright (C) 2010-2016, Inria.
Copyright (C) 2014-2016, IRIT.

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 ZArith Rfunctions NaryFunctions.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop tuple.

Require Import MathComp.

(*
This library defines polymorphic definitions rec1up (resp. rec2up) that
make it possible to compute the list [:: u(0); u(1);...; u(n)] for
a given function u defined by an order-1 (resp. order-2) recurrence.
*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Ltac flatten := repeat
  first[rewrite<-pred_of_minus in *| rewrite<-plusE in *|rewrite<-minusE in *].
Ltac iomega := intros; flatten; (omega || apply/leP; omega).
Ltac iomega_le := (repeat move/leP=>?); iomega.

(** * Additional lemmas about [seq] *)

Notation nth_defaults := set_nth_default. (* for backward compatibility *)

Lemma behead_rcons (T : Type) (s : seq T) (x : T) :
  s <> [::] -> behead (rcons s x) = rcons (behead s) x.
Proof. by case: s. Qed.

Lemma behead_rev_take (T : Type) (s : seq T) (n : nat) :
  n <= size s -> behead (rev (take n s)) = rev (take n.-1 s).
Proof.
elim: n s =>[//|n IHn] [//|x s] H //.
rewrite ltnS -/size in H.
rewrite /=.
case: n IHn H =>[//|n] /= IHn H; first by rewrite take0 //.
rewrite [in RHS]rev_cons -IHn // rev_cons behead_rcons //.
move/(f_equal size).
fold (@take T); fold (@size T) in H.
rewrite size_rev size_take.
case: leq =>//=.
by move=> top; rewrite top in H.
Qed.

(** * Order-1 recurrences *)

Section Defix1.

Variable T : Type.

Variable F : T -> nat -> T.
(** to be instantiated by a function satisfying u(n) = F(u(n-1), n). *)

Fixpoint loop1 (n p : nat) (a : T) (s : seq T) {struct n} : seq T :=
  match n with
    | 0 => s
    | m.+1 => let c := F a p in loop1 m p.+1 c (c :: s)
  end.

Variable a0 : T.

Definition rec1down n := loop1 n 1 a0 [:: a0].

Definition rec1up n := rev (rec1down n).

Lemma size_loop1 n p a s : size (loop1 n p a s) = n + size s.
Proof. by elim: n p a s => [//|n IHn] *; rewrite IHn addSnnS. Qed.

Lemma size_rec1down n : size (rec1down n) = n.+1.
Proof. by case: n => [//|n]; rewrite size_loop1 addn1. Qed.

Lemma size_rec1up n : size (rec1up n) = n.+1.
Proof. by rewrite size_rev size_rec1down. Qed.

Variable d : T.

Lemma head_loop1S n s a p :
  head d s = a ->
  head d (loop1 n.+1 p a s) = F (head d (loop1 n p a s)) (n+p).
Proof.
by elim: n s a p => [_ _ _->//|n IHn s a p H]; rewrite !IHn // addSnnS.
Qed.

Theorem head_loop1 (n p : nat) a s :
  head d s = a ->
  head d (loop1 n p a s) = iteri n (fun i c => F c (i + p)) a.
Proof.
elim: n p a s =>[//|n IHn] p a s H.
move E: (n.+1) => n'.
rewrite /= -{}E IHn //.
clear; elim: n =>[//=|n IHn].
by rewrite /= IHn /= addSnnS.
Qed.

Lemma head_rec1downS n :
  head d (rec1down n.+1) = F (head d (rec1down n)) n.+1.
Proof. by rewrite head_loop1S ?addn1. Qed.

Lemma nth_rec1up_last k : nth d (rec1up k) k = last d (rec1up k).
Proof. by rewrite (last_nth d) size_rec1up. Qed.

Lemma last_rec1up k : last d (rec1up k) = head d (loop1 k 1 a0 [:: a0]).
Proof. by rewrite /rec1up /rec1down last_rev. Qed.

Lemma nth_rec1upS k :
  nth d (rec1up k.+1) k.+1 = F (nth d (rec1up k) k) k.+1.
Proof. by rewrite !nth_rec1up_last !last_rev head_rec1downS. Qed.

Lemma loop1S_ex n p a s :
  exists c, loop1 n.+1 p a s = c :: (loop1 n p a s).
Proof.
elim: n p a s=> [|n IH] p a s; first by exists (F a p).
remember (S n) as n'; simpl.
case: (IH p.+1 (F a p) (F a p :: s))=> [c Hc].
rewrite Hc {}Heqn' /=.
by exists c.
Qed.

Lemma behead_rec1down n : behead (rec1down n.+1) = rec1down n.
Proof. by rewrite /rec1down; case: (loop1S_ex n 1 a0 [:: a0])=> [c ->]. Qed.

Lemma nth_rec1downD d1 p q n :
  nth d1 (rec1down (p+q+n)) (p+q) = nth d1 (rec1down (p+n)) p.
Proof.
elim: q=> [|q IH]; first by rewrite addn0.
by rewrite !addnS addSn -nth_behead behead_rec1down.
Qed.

Lemma nth_rec1downD_dflt2 d1 d2 p q n :
  nth d1 (rec1down (p+q+n)) (p+q) = nth d2 (rec1down (p+n)) p.
Proof.
rewrite nth_rec1downD (nth_defaults d1 d2) // size_rec1down.
by iomega.
Qed.

Lemma nth_rec1down_indep d1 d2 m1 m2 n :
  n <= m1 -> n <= m2 ->
  nth d1 (rec1down m1) (m1 - n) = nth d2 (rec1down m2) (m2 - n).
Proof.
move=> h1 h2.
have h1' := subnKC h1; have h2' := subnKC h2.
case: (ltngtP m1 m2)=> Hm; last first.
- by rewrite Hm (nth_defaults d1 d2) // size_rec1down; iomega.
- set p := m2 - n in h2' *.
  rewrite -h2' addnC.
  pose q := m1 - m2.
  have Hpq : m1 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m1 = p + q + n by rewrite -Hpq subnK.
  exact: nth_rec1downD_dflt2.
set p := m1 - n in h1' *.
rewrite -h1' addnC.
pose q := m2 - m1.
have Hpq : m2 - n = p + q.
  rewrite /p /q in h2' *.
  by rewrite addnC addnBA // subnK // ltnW.
rewrite Hpq.
have->: m2 = p + q + n by rewrite -Hpq subnK.
symmetry; exact: nth_rec1downD_dflt2.
Qed.

Lemma nth_rec1up_indep d1 d2 m1 m2 n :
  n <= m1 -> n <= m2 ->
  nth d1 (rec1up m1) n = nth d2 (rec1up m2) n.
Proof.
move=> h1 h2.
rewrite !nth_rev; first last.
- by rewrite size_loop1 /=; move: h1 h2; iomega_le.
- by rewrite size_loop1 /=; move: h1 h2; iomega_le.
rewrite !size_loop1 /= !addn1 !subSS.
exact: nth_rec1down_indep.
Qed.

Theorem nth_rec1up n k :
  nth d (rec1up n) k =
  if n < k then d
  else iteri k (fun i c => F c (i + 1)) a0.
Proof.
case: (ltnP n k) => H; first by rewrite nth_default // size_rec1up.
rewrite (@nth_rec1up_indep d d n k k) //.
by rewrite nth_rec1up_last last_rec1up head_loop1.
Qed.

(** For the base case *)

Lemma rec1down_co0 n: nth d (rec1down n) n = a0.
Proof.
elim: n=> [//|n IH].
by rewrite /rec1down; have [c ->] := loop1S_ex n 1 a0 [:: a0].
Qed.

Lemma rec1up_co0 n : nth d (rec1up n) 0 = a0.
Proof. by rewrite nth_rev size_rec1down // subn1 rec1down_co0. Qed.

End Defix1.

Section GenDefix1.

Variables A T : Type.

Variable F : A -> nat -> A. (* may involve symbolic differentiation *)
(** to be instantiated by a function satisfying a(n+1)=F(a(n),n+1). *)

Variable G : A -> nat -> T.
(** to be instantiated by a function satisfying u(N+n)=G(a(n),N+n).
Here, N is the size of the list [init]. *)

Fixpoint gloop1 (n p : nat) (a : A) (s : seq T) {struct n} : seq T :=
  match n with
    | 0 => s
    | m.+1 => let r := G a p in
              let p1 := p.+1 in
              let c := F a p1 in gloop1 m p1 c (r :: s)
  end.

Variable a0 : A.

Variable init : seq T.
(** Remark: [init] can be nil *)

Definition grec1down n :=
  if (n.+1 - size init) is n'.+1
    then gloop1 n'.+1 (size init) a0 (rev init)
    else rev (take n.+1 init).

Lemma grec1downE (n : nat) :
  grec1down n =
  if n >= size init
    then gloop1 (n - size init).+1 (size init) a0 (rev init)
    else rev (take n.+1 init).
Proof.
rewrite /grec1down.
case: (leqP (size init) n)=>H; first by rewrite subSn //.
by move: H; rewrite -subn_eq0; move/eqP->.
Qed.

Definition grec1up n := rev (grec1down n).

Lemma size_gloop1 n p a s : size (gloop1 n p a s) = n + size s.
Proof. by elim: n p a s => [//|n IHn] *; rewrite IHn addSnnS. Qed.

Lemma size_grec1down n : size (grec1down n) = n.+1.
Proof.
rewrite /grec1down.
case E: (n.+1 - size init) =>[|k].
  rewrite size_rev size_take.
  move/eqP: E; rewrite subn_eq0 leq_eqVlt.
  case/orP; last by move->.
  move/eqP->; rewrite ifF //.
  by rewrite ltnn.
rewrite size_gloop1 /= -E.
by rewrite size_rev subnK // ltnW // -subn_gt0 E.
Qed.

Lemma size_grec1up n : size (grec1up n) = n.+1.
Proof. by rewrite size_rev size_grec1down. Qed.

Theorem grec1up_init n :
  n < size init ->
  grec1up n = take n.+1 init.
Proof. by rewrite /grec1up /grec1down -subn_eq0; move/eqP ->; rewrite revK. Qed.

Theorem last_grec1up (d : T) (n : nat) :
  size init <= n ->
  last d (grec1up n) =
  head d (gloop1 (n - size init).+1 (size init) a0 (rev init)).
Proof. by move=> Hn; rewrite /grec1up /grec1down subSn // last_rev. Qed.

Theorem head_gloop1 (d : T) (n p : nat) (a : A) (s : seq T):
  head d (gloop1 n.+1 p a s) = G (iteri n (fun i c => F c (i + p).+1) a) (n + p).
Proof.
elim: n p a s =>[//|n IHn] p a s.
move E: (n.+1) => n'.
rewrite /= -{}E IHn.
congr G; last by rewrite addSnnS.
clear; elim: n =>[//=|n IHn].
by rewrite /= IHn /= addSnnS.
Qed.

Lemma gloop1S_ex n p a s :
  exists c, gloop1 n.+1 p a s = c :: (gloop1 n p a s).
Proof.
elim: n p a s => [|n IH] p a s; first by exists (G a p).
remember (S n) as n'; simpl.
case: (IH p.+1 (F a p.+1) (G a p :: s))=> [c Hc].
rewrite Hc {}Heqn' /=.
by exists c.
Qed.

Theorem behead_grec1down (n : nat) :
  behead (grec1down n.+1) = grec1down n.
Proof.
pose s := rev init.
pose m := size init.
rewrite !grec1downE.
case: (leqP (size init) n) => H.
  rewrite leqW // subSn //.
  have [c Hc] := gloop1S_ex (n - m).+1 m a0 s.
  by rewrite Hc.
rewrite leq_eqVlt in H; case/orP: H; [move/eqP|] => H.
  rewrite -H subnn /= ifT H //.
  by rewrite take_oversize.
rewrite ifF 1?leqNgt ?H //.
by rewrite behead_rev_take.
Qed.

Lemma nth_grec1downD d1 p q n:
  nth d1 (grec1down (p+q+n)) (p+q) = nth d1 (grec1down (p+n)) p.
Proof.
elim: q=> [|q IH]; first by rewrite addn0.
by rewrite !addnS addSn -nth_behead behead_grec1down.
Qed.

Lemma nth_grec1downD_dflt2 d1 d2 p q n:
  nth d1 (grec1down (p+q+n)) (p+q) = nth d2 (grec1down (p+n)) p.
Proof.
rewrite nth_grec1downD (set_nth_default d1 d2) //.
by rewrite size_grec1down ltnS leq_addr.
Qed.

Theorem nth_grec1down_indep (d1 d2 : T) (m1 m2 n : nat) :
  n <= m1 -> n <= m2 ->
  nth d1 (grec1down m1) (m1 - n) = nth d2 (grec1down m2) (m2 - n).
Proof.
move=> h1 h2.
have h1' := subnKC h1; have h2' := subnKC h2.
case: (ltngtP m1 m2)=> Hm.
- set p := m1 - n in h1' *.
  rewrite -h1' addnC.
  pose q := m2 - m1.
  have Hpq : m2 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m2 = p + q + n.
    by rewrite -Hpq subnK.
  symmetry; exact: nth_grec1downD_dflt2.
- set p := m2 - n in h2' *.
  rewrite -h2' addnC.
  pose q := m1 - m2.
  have Hpq : m1 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m1 = p + q + n.
    by rewrite -Hpq subnK.
  exact: nth_grec1downD_dflt2.
- rewrite Hm (nth_defaults d1 d2) // size_grec1down.
  exact: leq_ltn_trans (@leq_subr n m2) _.
Qed.

Theorem nth_grec1up_indep (d1 d2 : T) (m1 m2 n : nat) :
  n <= m1 -> n <= m2 ->
  nth d1 (grec1up m1) n = nth d2 (grec1up m2) n.
Proof.
move=> h1 h2; rewrite !nth_rev; try by rewrite size_grec1down.
rewrite !size_grec1down !subSS; exact: nth_grec1down_indep.
Qed.

Arguments nth_grec1up_indep [d1 d2 m1 m2 n] _ _.

Lemma nth_grec1up_last (d : T) k : nth d (grec1up k) k = last d (grec1up k).
Proof. by rewrite (last_nth d) size_grec1up. Qed.

Theorem nth_grec1up d n k :
  nth d (grec1up n) k =
  if n < k then d
  else
    if k < size init then nth d init k
    else G (iteri (k - size init) (fun i c => F c (i + size init).+1) a0) k.
Proof.
case: (ltnP n k) => H; first by rewrite nth_default // size_grec1up.
rewrite (nth_grec1up_indep (d2 := d) (m2 := k)) //.
case: (ltnP k (size init)) => H'; first by rewrite grec1up_init // nth_take.
rewrite nth_grec1up_last last_grec1up // head_gloop1; congr G.
by rewrite subnK.
Qed.

Arguments nth_grec1up [d] n k.

End GenDefix1.

Section Defix2.

Variable T : Type.

Variable F : T -> T -> nat -> T.
(** to be instantiated by a function satisfying u(n) = F(u(n-2), u(n-1), n). *)

Fixpoint loop2 (n p : nat) (a b : T) (s : seq T) {struct n} : seq T :=
  match n with
    | 0 => s
    | m.+1 => let c := F a b p in loop2 m p.+1 b c (c :: s)
  end.

Variables a0 a1 : T.

Definition rec2down n :=
  if n is n'.+1 then (loop2 n' 2 a0 a1 [:: a1; a0]) else [:: a0].

Definition rec2up n := rev (rec2down n).

Lemma size_loop2 n p a b s : size (loop2 n p a b s) = n + size s.
Proof. by elim: n p a b s => [//|n IHn] *; rewrite IHn !addSnnS. Qed.

Lemma size_rec2down n : size (rec2down n) = n.+1.
Proof. by case: n => [//|[//|n]]; rewrite size_loop2 addn2. Qed.

Lemma size_rec2up n : size (rec2up n) = n.+1.
Proof. by rewrite size_rev size_rec2down. Qed.

Variable d : T.

Lemma head_loop2S n s a b p :
  hb d s = a -> head d s = b ->
  let s' := (loop2 n p a b s) in
  head d (loop2 n.+1 p a b s) = F (hb d s') (head d s') (n+p).
Proof.
elim: n s a b p => [|n IHn] s a b p Ha Hb; first by rewrite /= Ha Hb.
by rewrite IHn // addSnnS.
Qed.

Lemma head_rec2downSS n :
  head d (rec2down n.+2) =
  F (hb d (rec2down n.+1)) (head d (rec2down n.+1)) n.+2.
Proof. by case: n => [//|n]; rewrite head_loop2S ?addn2. Qed.

Lemma behead_loop2 n s a b p : behead (loop2 n.+1 p a b s) = loop2 n p a b s.
Proof. by elim: n s a b p => [//|n IHn] s a b p; rewrite IHn. Qed.

Lemma behead_rec2down n : behead (rec2down n.+1) = rec2down n.
Proof. by case: n => [//|n]; rewrite behead_loop2. Qed.

(* Let coa k := nth d (rec2up k) k.
Let coa' k := last d (rec2up k). *)

Lemma nth_rec2up_last k : nth d (rec2up k) k = last d (rec2up k).
Proof. by case: k => [//|k]; rewrite (last_nth d) size_rec2up. Qed.

Theorem last_rec2up k :
  last d (rec2up k.+1) = head d (loop2 k 2 a0 a1 [:: a1; a0]).
Proof. by rewrite /rec2up /rec2down last_rev. Qed.

Lemma nth_rec2downSS' k :
  nth d (rec2down k.+2) 0 =
  F (nth d (rec2down k) 0) (nth d (rec2down k.+1) 0) k.+2.
Proof. by rewrite !nth0 -[rec2down k]behead_rec2down head_rec2downSS. Qed.

Lemma nth_rec2upSS' k :
  nth d (rec2up k.+2) k.+2 =
  F (nth d (rec2up k) k) (nth d (rec2up k.+1) k.+1) k.+2.
Proof.
by rewrite /rec2up !nth_rev ?size_rec2down // !subnn nth_rec2downSS'.
Qed.

Lemma nth_rec2downD d1 p q n :
  nth d1 (rec2down (p+q+n)) (p+q) = nth d1 (rec2down (p+n)) p.
Proof.
elim: q=> [|q IH]; first by rewrite addn0.
by rewrite !addnS addSn -nth_behead behead_rec2down.
Qed.

Lemma nth_rec2downD_dflt2 d1 d2 p q n :
  nth d1 (rec2down (p+q+n)) (p+q) = nth d2 (rec2down (p+n)) p.
Proof.
rewrite nth_rec2downD (nth_defaults d1 d2) // size_rec2down.
by iomega.
Qed.

Lemma nth_rec2down_indep d1 d2 m1 m2 n : n <= m1 -> n <= m2 ->
  nth d1 (rec2down m1) (m1 - n) = nth d2 (rec2down m2) (m2 - n).
Proof.
move=> h1 h2.
have h1' := subnKC h1; have h2' := subnKC h2.
case: (ltngtP m1 m2)=> Hm; last first.
- rewrite Hm (nth_defaults d1 d2) //.
  by rewrite size_rec2down; iomega.
- set p := m2 - n in h2' *.
  rewrite -h2' addnC.
  pose q := m1 - m2.
  have Hpq : m1 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m1 = p + q + n by rewrite -Hpq subnK.
  exact: nth_rec2downD_dflt2.
- set p := m1 - n in h1' *.
  rewrite -h1' addnC.
  pose q := m2 - m1.
  have Hpq : m2 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m2 = p + q + n by rewrite -Hpq subnK.
symmetry; exact: nth_rec2downD_dflt2.
Qed.

Lemma nth_rec2up_indep d1 d2 m1 m2 n : n <= m1 -> n <= m2 ->
  nth d1 (rec2up m1) n = nth d2 (rec2up m2) n.
Proof.
move=> h1 h2.
rewrite !nth_rev; first last.
- by rewrite size_rec2down /=; move: h1 h2; iomega_le.
- by rewrite size_rec2down /=; move: h1 h2; iomega_le.
rewrite !size_rec2down /= !subSS.
exact: nth_rec2down_indep.
Qed.

End Defix2.

Section RecZ.

(* Helper functions to compute
[1/0!; p/1!; ...; p*(p-1)*...*(p-n+1)/n!] *)

Definition fact_rec (a : Z) (n : nat) : Z := Z.mul a (Z.of_nat n).
Definition fact_seq := rec1up fact_rec 1%Z.

Theorem fact_seq_correct (d : Z) (n k : nat) :
  k <= n ->
  nth d (fact_seq n) k = Z.of_nat (fact k).
Proof.
elim: k => [|k IHk] Hkn; first by rewrite rec1up_co0.
move/(_ (ltnW Hkn)) in IHk.
move: IHk.
rewrite /fact_seq.
rewrite (@nth_rec1up_indep _ _ _ d d _ k); try exact: ltnW || exact: leqnn.
move => IHk.
rewrite (@nth_rec1up_indep _ _ _ d d _ k.+1) //.
rewrite nth_rec1upS IHk /fact_rec.
rewrite fact_simpl.
zify; ring.
Qed.

Lemma size_fact_seq n : size (fact_seq n) = n.+1.
Proof. by rewrite size_rec1up. Qed.

Definition falling_rec (p : Z) (a : Z) (n : nat) : Z :=
  (a * (p - (Z.of_nat n) + 1))%Z.
Definition falling_seq (p : Z) := rec1up (falling_rec p) 1%Z.

Canonical Zmul_monoid := Monoid.Law Z.mul_assoc Z.mul_1_l Z.mul_1_r.

Theorem falling_seq_correct (d : Z) (p : Z) (n k : nat) :
  k <= n ->
  nth d (falling_seq p n) k =
  \big[Z.mul/1%Z]_(0 <= i < k) (p - Z.of_nat i)%Z.
Proof.
elim: k => [|k IHk] Hkn; first by rewrite rec1up_co0 big_mkord big_ord0.
move/(_ (ltnW Hkn)) in IHk.
move: IHk.
rewrite /falling_seq.
rewrite (@nth_rec1up_indep _ _ _ d d _ k); try exact: ltnW || exact: leqnn.
move => IHk.
rewrite (@nth_rec1up_indep _ _ _ d d _ k.+1) //.
rewrite nth_rec1upS IHk /falling_rec.
rewrite big_nat_recr //=.
congr Z.mul.
zify; ring.
Qed.

Lemma size_falling_seq p n : size (falling_seq p n) = n.+1.
Proof. by rewrite size_rec1up. Qed.

End RecZ.

(** Refinement proofs for rec1, rec2, grec1 *)

Section rec_proofs.
Variables (V T : Type).
Variable Rel : V -> T -> Prop.
Variables (dv : V) (dt : T).
Hypothesis H0 : Rel dv dt.
Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing).

Lemma grec1up_correct (A := seq V) Fi (F : A -> nat -> A) Gi (G : A -> nat -> V) ai a si s n :
  (forall qi q m, RelP q qi -> RelP (F q m) (Fi qi m)) ->
  (forall qi q m, RelP q qi -> Rel (G q m) (Gi qi m)) ->
  RelP a ai ->
  RelP s si ->
  size s = size si ->
  RelP (grec1up F G a s n) (grec1up Fi Gi ai si n).
Proof.
move=> HF HG Ha Hs Hsize k.
pose s1 := (size (grec1up F G a s n)).-1.
case: (ltnP n k) => Hnk; first by rewrite !nth_default ?size_grec1up.
have H1 : k = (size (grec1up F G a s k)).-1 by rewrite size_grec1up.
have H2 : k = (size (grec1up Fi Gi ai si k)).-1 by rewrite size_grec1up.
rewrite ?(@nth_grec1up_indep _ _ _ _ _ _ dv dv n k k)
  ?(@nth_grec1up_indep _ _ _ _ _ _ dt dt n k k) //.
case: (ltnP k (size s)) => Hk.
- have Hki : k < size si by rewrite -Hsize.
  rewrite ?(grec1up_init _ _ _ Hk, grec1up_init _ _ _ Hki) ?nth_take_dflt ltnn.
  exact: Hs.
- have Hki : size si <= k by rewrite -Hsize.
  rewrite {4}H2 {2}H1 !nth_last !last_grec1up ?head_gloop1 // Hsize.
  apply: HG => j; set l := k - size si.
  elim: l j => [|l IHl] j /=; by [apply: Ha | apply: HF; apply: IHl].
Qed.

Lemma rec1up_correct fi f fi0 f0 n :
  (forall ai a m, Rel a ai -> Rel (f a m) (fi ai m)) ->
  Rel f0 fi0 ->
  RelP (rec1up f f0 n) (rec1up fi fi0 n).
Proof.
move=> Hf Hf0 k.
case: (ltnP n k) => Hnk; first by rewrite !nth_default ?size_rec1up.
have H1 : k = (size (rec1up f f0 k)).-1 by rewrite size_rec1up.
have H2 : k = (size (rec1up fi fi0 k)).-1 by rewrite size_rec1up.
rewrite (@nth_rec1up_indep _ _ _ dv dv n k k) //
        (@nth_rec1up_indep _ _ _ dt dt n k k) //.
rewrite !(nth_rec1up_last, last_rec1up).
rewrite !head_loop1 //.
elim: k Hnk {H1 H2} => [|k IHk] Hnk //=.
apply: Hf; apply: IHk; exact: ltnW.
Qed.

Lemma rec2up_correct fi f fi0 f0 fi1 f1 n :
  (forall ai bi a b m, Rel a ai -> Rel b bi -> Rel (f a b m) (fi ai bi m)) ->
  Rel f0 fi0 ->
  Rel f1 fi1 ->
  RelP (rec2up f f0 f1 n) (rec2up fi fi0 fi1 n).
Proof.
move=> Hf Hf0 Hf1 k.
case: (ltnP n k) => Hn; first by rewrite !nth_default ?size_rec2up.
have H1 : k = (size (rec2up f f0 f1 k)).-1 by rewrite size_rec2up.
have H2 : k = (size (rec2up fi fi0 fi1 k)).-1 by rewrite size_rec2up.
rewrite (@nth_rec2up_indep _ _ _ _ dv dv n k k) //
        (@nth_rec2up_indep _ _ _ _ dt dt n k k) //.
case: k Hn {H1 H2} => [//|k] Hn.
rewrite !(nth_rec2up_last, last_rec2up).
elim: k {-2}k (leqnn k) Hn => [|k IHk] k' Hk' Hn.
- by rewrite leqn0 in Hk'; move/eqP: Hk'->.
- rewrite leq_eqVlt in Hk'; case/orP: Hk'=> Hk'; last exact: IHk =>//.
  move/eqP: (Hk')->; rewrite !head_loop2S //; apply: Hf.
  + case: k IHk Hn Hk' => [|k] IHk Hn Hk' //.
    rewrite /hb !behead_loop2.
    apply: IHk =>//.
    move/eqP in Hk'; rewrite Hk' in Hn; apply: ltnW; exact: ltnW.
  + apply: IHk =>//.
    move/eqP in Hk'; rewrite Hk' in Hn; exact: ltnW.
Qed.

End rec_proofs.


Require Import init.

Require Import analysis_topology.

(* begin hide *)
Section IVT.

Existing Instance real_order_topology.
Existing Instance subspace_topology.
(* end hide *)
(* TODO: Make the domain of this better *)
Theorem real_ivt : ∀ f : real → real, continuous f →
    ∀ a b r, a < b → f a < r → r < f b → ∃ c, f c = r ∧ a ≤ c ∧ c ≤ b.
Proof.
    intros f f_cont a b r ab r_gt r_lt.
    pose (S := closed_interval a b).
    pose (g (x : set_type S) := f [x|]).
    assert (continuous g) as g_cont.
    {
        unfold g.
        apply comp_continuous.
        -   intros x A [A_open Ax].
            exists (λ x, A [x|]).
            split.
            +   split.
                *   exists A.
                    split; try exact A_open.
                    reflexivity.
                *   exact Ax.
            +   intros y y_in.
                destruct y_in as [y' [Ay' y_eq]].
                rewrite y_eq.
                exact Ay'.
        -   exact f_cont.
    }
    assert (closed_interval a b a) as a_in.
    {
        split.
        -   apply refl.
        -   apply ab.
    }
    assert (closed_interval a b b) as b_in.
    {
        split.
        -   apply ab.
        -   apply refl.
    }
    pose proof (ivt
        (closed_interval_connected a b)
        g
        g_cont
        [a|a_in]
        [b|b_in]
        r
        r_gt
        r_lt
    ) as [[c [c_gt c_lt]] eq].
    exists c.
    repeat split; assumption.
Qed.
(* begin hide *)
End IVT.
(* end hide *)


CoInductive Tree (A : Type) : Type :=
{
  root  : A;
  trees : TreeStream A;
}

with TreeStream (A : Type) : Type :=
{
  hd : Tree A;
  tl : TreeStream A;
}.

Arguments root  {A} _.
Arguments trees {A} _.

Arguments hd {A} _.
Arguments tl {A} _.

CoFixpoint stmap {A B : Type} (f : A -> B) (t : Tree A) : Tree B :=
{|
  root  := f (root t);
  trees := smap f (trees t);
|}

with smap {A B : Type} (f : A -> B) (s : TreeStream A) : TreeStream B :=
{|
  hd := stmap f (hd s);
  tl := smap  f (tl s);
|}.

CoInductive TreeStreamSim {A : Type} (TS : Tree A -> Tree A -> Type) (s1 s2 : TreeStream A) : Type :=
{
  hds : TS (hd s1) (hd s2);
  tls : TreeStreamSim TS (tl s1) (tl s2);
}.

CoInductive TreeSim {A : Type} (t1 t2 : Tree A) : Type :=
{
  roots  : root t1 = root t2;
  treess : TreeStreamSim TreeSim (trees t1) (trees t2);
}.

Fail CoInductive TreeSim {A : Type} (t1 t2 : Tree A) : Type :=
{
  roots  : root t1 = root t2;
  treess : TreeStreamSim (trees t1) (trees t2);
}

with TreeStreamSim {A : Type} (s1 s2 : TreeStream A) : Type :=
{
    hds : TreeSim (hd s1) (hd s2);
    tls : TreeStreamSim (tl s1) (tl s2);
}.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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

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

Definition synth (lf1 : lst) (x : lst) : natural := double (len x).


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

(* ** Object-level encoding of bounded universal quantification II *)

Require Import Arith List Bool.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd prime binomial sums bool_nat.

From Undecidability.H10.Matija
  Require Import cipher.

From Undecidability.H10.Dio
  Require Import dio_logic dio_expo dio_binary.

Set Implicit Arguments.

Local Infix "≲" := binary_le (at level 70, no associativity).
Local Notation power := (mscal mult 1).
Local Notation "∑" := (msum plus 0).
Local Infix "⇣" := nat_meet (at level 40, left associativity).
Local Infix "⇡" := nat_join (at level 50, left associativity).

(* seqs_of_ones l q u u1 iff

            l+1 < q
       and  u  = ∑(i<l) r^(2^(1+i))
       and  u1 = ∑(i<l) r^(2^(2+i))
       with r := 2^(4q)

  *)

Theorem dio_rel_seqs_of_ones l q u u1 : 𝔻F l -> 𝔻F q -> 𝔻F u -> 𝔻F u1
          -> 𝔻R (fun v => seqs_of_ones (l v) (q v) (u v) (u1 v)).
Proof.
  dio by lemma (fun v => seqs_of_ones_dio (l v) (q v) (u v) (u1 v)).
Defined.

#[export] Hint Resolve dio_rel_seqs_of_ones : dio_rel_db.

(* a is the q-cipher of some l-tuple *)

Theorem dio_rel_Code l q a : 𝔻F l -> 𝔻F q -> 𝔻F a
                          -> 𝔻R (fun v => Code (l v) (q v) (a v)).
Proof.
  dio by lemma (fun v => Code_dio (l v) (q v) (a v)).
Defined.

#[export] Hint Resolve dio_rel_Code : dio_rel_db.

(* c is the q-cipher of the l-tuple <x,...,x> *)

Theorem dio_rel_Const l q c x : 𝔻F l -> 𝔻F q -> 𝔻F c -> 𝔻F x
                             -> 𝔻R (fun v => Const (l v) (q v) (c v) (x v)).
Proof.
  dio by lemma (fun v => Const_dio (l v) (q v) (c v) (x v)).
Defined.

#[export] Hint Resolve dio_rel_Const : dio_rel_db.

(* a is the q-cipher of the l-tuple <0,...,l-1> *)

Theorem dio_rel_CodeNat l q a : 𝔻F l -> 𝔻F q -> 𝔻F a
                             -> 𝔻R (fun v => CodeNat (l v) (q v) (a v)).
Proof.
  dio by lemma (fun v => CodeNat_dio (l v) (q v) (a v)).
Defined.

#[export] Hint Resolve dio_rel_CodeNat : dio_rel_db.

(* Testing whether a is the q cipher of the sum of the tuples of q-ciphers b and c *)

Theorem dio_rel_Code_plus a b c : 𝔻F a -> 𝔻F b -> 𝔻F c
                               -> 𝔻R (fun v => Code_plus (a v) (b v) (c v)).
Proof. intros; unfold Code_plus; dio auto. Defined.

(* Testing whether a is the q cipher of the product of the tuples of q-ciphers b and c *)

Theorem dio_rel_Code_mult l q a b c : 𝔻F l -> 𝔻F q -> 𝔻F a -> 𝔻F b -> 𝔻F c
                                   -> 𝔻R (fun v => Code_mult (l v) (q v) (a v) (b v) (c v)).
Proof. intros; unfold Code_mult; dio auto. Defined.

#[export] Hint Resolve dio_rel_Code_plus dio_rel_Code_mult : dio_rel_db.

(* Now we have diophantine representations of q-cipher of the following l-tuple

    1) <x,...,x>  (for x < 2^q)
    2) <0,...,l-1>
    3) testing whether some code is a q-cipher of some tuple
    4) testing sum and product equality among q-ciphers

*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable rE_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cR_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defrectangle_1 : (forall A B C D : Universe, (rE_ A B C D -> (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ (per_ C D A /\ cR_ A C B D)))))).
Variable defrectangle2_2 : (forall A B C D : Universe, ((per_ D A B /\ (per_ A B C /\ (per_ B C D /\ (per_ C D A /\ cR_ A C B D)))) -> rE_ A B C D)).
Variable lemma_rightangleNC_3 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable defcross_4 : (forall A B C D : Universe, (exists X : Universe, (cR_ A B C D -> (betS_ A X B /\ betS_ C X D)))).
Variable defcross2_5 : (forall A B C D X : Universe, ((betS_ A X B /\ betS_ C X D) -> cR_ A B C D)).
Variable defmeet_6 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_7 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable lemma_collinearorder_8 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_8_2_9 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable lemma_inequalitysymmetric_10 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinearright_11 : (forall A B C D : Universe, ((per_ A B D /\ (col_ A B C /\ C <> B)) -> per_ C B D)).
Variable lemma_8_7_12 : (forall A B C : Universe, (per_ C B A -> ~(per_ A C B))).
Variable lemma_NCdistinct_13 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable defcollinear_14 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_15 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_16 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_17 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_18 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_19 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_20 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable axiom_betweennesssymmetry_21 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defparallel_22 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_23 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable defparallelogram_24 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_25 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).

Theorem lemma_rectangleparallelogram_26 : (forall A B C D : Universe, (rE_ A B C D -> pG_ A B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Definition plus (n:nat)(m:nat):nat:=n+m.

Definition id:forall(A:Type),A->A:=fun A x =>x.

Definition prop0:forall(A:Prop),A->A:=fun A x=>x.

Definition prop1:forall(A B C:Prop), (B->C)->(A->B)->(A->C) :=
 fun A B C f g x => f(g x).