Require Import Coq.micromega.Lia.
Require Import Coq.Init.Nat.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Local Open Scope Z_scope.

Require Import Crypto.Algebra.Nsatz.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Util.LetIn Crypto.Util.CPSUtil.
Require Import Crypto.Util.Tuple Crypto.Util.ListUtil.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Decidable Crypto.Util.ZUtil.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Tactics.SpecializeBy.
Local Notation "A ^ n" := (tuple A n) : type_scope.

(***

Arithmetic on bignums that handles carry bits; this is useful for
saturated limbs. Compatible with mixed-radix bases.

Uses "columns" representation: a bignum has type [tuple (list Z) n].
Associated with a weight function w, the bignum B represents:

    \sum_{i=0}^{n}{w[i] * sum{B[i]}}

Example: ([a21, a20],[],[a0]) with weight function (fun i => 10^i)
represents

    a0 + 10*0 + 100 * (a20 + a21)

If you picture this representation with the weights on the bottom and
the terms in each list stacked above the corresponding weight,

                a20
    a0          a21
    ---------------
     1    10    100

it's easy to see how the lists can be called "columns".

This is a particularly useful representation for adding partial
products after multiplication, particularly when we want to do this
using a carrying add. We want to add together the terms from each
column, accumulating the carries together along the way. Then we want
to add the carry accumulator to the next column, and repeat, producing
a [tuple Z n] as output. This operation is called "compact".

As an example, let's compact the product of 571 and 645 in base 10.
At first, the partial products look like this:

                   1*6
            1*4    7*4     7*6
     1*5    7*5    5*5     5*4      5*6
    ------------------------------------
       1     10    100    1000    10000

                     6
              4     28      42
       5     35     25      20       30
    ------------------------------------
       1     10    100    1000    10000

Now, we process the first column:

     {carry_acc = 0; output =()}
     STEP [5]
     {carry_acc = 0; output=(5,)}

Since we have only one term, there's no addition to do, and no carry
bit. We add a 0 to the next column and continue.

     STEP [0,4,35] (0 + 4 = 4)
     {carry_acc = 0; output=(5,)}
     STEP [4,35] (4 + 35 = 39)
     {carry_acc = 3; output=(9,5)}

This time, we have a carry. We add it to the third column and process
that:

     STEP [3,6,28,25] (3 + 6  = 9)
     {carry_acc = 0; output=(9,5)}
     STEP [9,28,25] (9 + 28 = 37)
     {carry_acc = 3; output=(9,5)}
     STEP [7,25] (7 + 25 = 32)
     {carry_acc = 6; output=(2,9,5)}

You're probably getting the idea, but here are the fourth and fifth
columns:

     STEP [6,42,20] (6 + 42 = 48)
     {carry_acc = 4; output=(2,9,5)}
     STEP [8,20] (8 + 20 = 28)
     {carry_acc = 6; output=(8,2,9,5)}

     STEP [6,30] (6 + 30 = 36)
     {carry_acc = 3; output=(6,8,2,9,5)}

The final result is the output plus the final carry, so we produce
(6,8,2,9,5) and 3, representing the number 368295. A quick calculator
check confirms our result.

 ***)

Module Columns.
  Section Columns.
    Context (weight : nat->Z)
            {weight_0 : weight 0%nat = 1}
            {weight_nonzero : forall i, weight i <> 0}
            {weight_positive : forall i, weight i > 0}
            {weight_multiples : forall i, weight (S i) mod weight i = 0}
            {weight_divides : forall i : nat, weight (S i) / weight i > 0}
            (* add_get_carry takes in a number at which to split output *)
            {add_get_carry_cps: forall {T}, Z ->Z -> Z -> (Z * Z -> T) -> T}
            {div_cps modulo_cps : forall {T}, Z -> Z -> (Z -> T) -> T}.
    Let add_get_carry s x y := add_get_carry_cps _ s x y id.
    Let div x y := div_cps _ x y id.
    Let modulo x y := modulo_cps _ x y id.
    Context {add_get_carry_cps_id : forall {T} s x y f,
                @add_get_carry_cps T s x y f = f (add_get_carry s x y)}
            {add_get_carry_mod : forall s x y,
                fst (add_get_carry s x y)  = (x + y) mod s}
            {add_get_carry_div : forall s x y,
                snd (add_get_carry s x y)  = (x + y) / s}
            {div_cps_id : forall {T} x y f,
                @div_cps T x y f = f (div x y)}
            {modulo_cps_id : forall {T} x y f,
                @modulo_cps T x y f = f (modulo x y)}
            {div_correct : forall a b, div a b = a / b}
            {modulo_correct : forall a b, modulo a b = a mod b}
    .
    Hint Rewrite div_correct modulo_correct add_get_carry_mod add_get_carry_div : div_mod.
    Hint Rewrite add_get_carry_cps_id div_cps_id modulo_cps_id : uncps.

    Definition eval {n} (x : (list Z)^n) : Z :=
      B.Positional.eval weight (Tuple.map sum x).

    Lemma eval_unit (x:unit) : eval (n:=0) x = 0.
    Proof. reflexivity. Qed.
    Hint Rewrite eval_unit : push_basesystem_eval.

    Lemma eval_single (x:list Z) : eval (n:=1) x = sum x.
    Proof.
      cbv [eval]. simpl map. cbv - [Z.mul Z.add sum].
      rewrite weight_0; ring.
    Qed. Hint Rewrite eval_single : push_basesystem_eval.

    Definition eval_from {n} (offset:nat) (x : (list Z)^n) : Z :=
      B.Positional.eval (fun i => weight (i+offset)) (Tuple.map sum x).

    Lemma eval_from_0 {n} x : @eval_from n 0 x = eval x.
    Proof using Type. cbv [eval_from eval]. auto using B.Positional.eval_wt_equiv. Qed.

    Lemma eval_from_S {n}: forall i (inp : (list Z)^(S n)),
        eval_from i inp = eval_from (S i) (tl inp) + weight i * sum (hd inp).
    Proof using Type.
      intros i inp; cbv [eval_from].
      replace inp with (append (hd inp) (tl inp))
        by (simpl in *; destruct n; destruct inp; reflexivity).
      rewrite map_append, B.Positional.eval_step, hd_append, tl_append.
      autorewrite with natsimplify; ring_simplify; rewrite Group.cancel_left.
      apply B.Positional.eval_wt_equiv; intros; f_equal; omega.
    Qed.

    (* Sums a list of integers using carry bits.
     Output : carry, sum
     *)
    Section compact_digit_cps.
      Context (n : nat) {T : Type}.

      Fixpoint compact_digit_cps (digit : list Z) (f:Z * Z->T) :=
        match digit with
        | nil => f (0, 0)
        | x :: nil => div_cps _ x (weight (S n) / weight n) (fun d =>
                      modulo_cps _ x (weight (S n) / weight n) (fun m =>
                      f (d, m)))
        | x :: y :: nil =>
            add_get_carry_cps _ (weight (S n) / weight n) x y (fun sum_carry =>
            dlet sum_carry := sum_carry in
            dlet carry := snd sum_carry in
            f (carry, fst sum_carry))
        | x :: tl =>
          compact_digit_cps tl
            (fun rec =>
              add_get_carry_cps _ (weight (S n) / weight n) x (snd rec) (fun sum_carry =>
              dlet sum_carry := sum_carry in
              dlet carry' := (fst rec + snd sum_carry)%RT in
              f (carry', fst sum_carry)))
        end.
    End compact_digit_cps.

    Definition compact_digit n digit := compact_digit_cps n digit id.
    Lemma compact_digit_id n digit: forall {T} f,
        @compact_digit_cps n T digit f = f (compact_digit n digit).
    Proof using add_get_carry_cps_id div_cps_id modulo_cps_id.
      induction digit; intros; cbv [compact_digit]; [reflexivity|].
      simpl compact_digit_cps; break_match; rewrite ?IHdigit; clear IHdigit;
        cbv [Let_In]; autorewrite with uncps; reflexivity.
    Qed.
    Hint Opaque compact_digit : uncps.
    Hint Rewrite compact_digit_id : uncps.

    Definition compact_step_cps (index:nat) (carry:Z) (digit: list Z)
               {T} (f:Z * Z->T) :=
      compact_digit_cps index (carry::digit) f.

    Definition compact_step i c d := compact_step_cps i c d id.
    Lemma compact_step_id i c d T f :
      @compact_step_cps i c d T f = f (compact_step i c d).
    Proof using add_get_carry_cps_id div_cps_id modulo_cps_id. cbv [compact_step_cps compact_step]; autorewrite with uncps; reflexivity. Qed.
    Hint Opaque compact_step : uncps.
    Hint Rewrite compact_step_id : uncps.

    Definition compact_cps {n} (xs : (list Z)^n) {T} (f:Z * Z^n->T) :=
      Tuple.mapi_with_cps compact_step_cps 0 xs f.

    Definition compact {n} xs := @compact_cps n xs _ id.
    Lemma compact_id {n} xs {T} f : @compact_cps n xs T f = f (compact xs).
    Proof using add_get_carry_cps_id div_cps_id modulo_cps_id. cbv [compact_cps compact]; autorewrite with uncps; reflexivity. Qed.

    Lemma compact_digit_mod i (xs : list Z) :
      snd (compact_digit i xs)  = sum xs mod (weight (S i) / weight i).
    Proof using add_get_carry_div add_get_carry_mod div_correct modulo_correct add_get_carry_cps_id div_cps_id modulo_cps_id.
      induction xs; cbv [compact_digit]; simpl compact_digit_cps;
        cbv [Let_In];
        repeat match goal with
               | _ => progress autorewrite with div_mod
               | _ => rewrite IHxs, <-Z.add_mod_r
               | _ => progress (rewrite ?sum_cons, ?sum_nil in * )
               | _ => progress (autorewrite with uncps push_id cancel_pair in * )
               | _ => progress break_match; try discriminate
               | _ => reflexivity
               | _ => f_equal; ring
               end.
    Qed. Hint Rewrite compact_digit_mod : div_mod.

    Lemma compact_digit_div i (xs : list Z) :
      fst (compact_digit i xs)  = sum xs / (weight (S i) / weight i).
    Proof using add_get_carry_div add_get_carry_mod div_correct modulo_correct weight_0 weight_divides add_get_carry_cps_id div_cps_id modulo_cps_id.
      induction xs; cbv [compact_digit]; simpl compact_digit_cps;
        cbv [Let_In];
        repeat match goal with
               | _ => progress autorewrite with div_mod
               | _ => rewrite IHxs
               | _ => progress (rewrite ?sum_cons, ?sum_nil in * )
               | _ => progress (autorewrite with uncps push_id cancel_pair in * )
               | _ => progress break_match; try discriminate
               | _ => reflexivity
               | _ => f_equal; ring
               end.
      assert (weight (S i) / weight i <> 0) by auto using Z.positive_is_nonzero.
      match goal with |- _ = (?a + ?X) / ?D =>
                      transitivity  ((a + X mod D + D * (X / D)) / D);
                        [| rewrite (Z.div_mod'' X D) at 3; f_equal; auto; ring]
      end.
      rewrite Z.div_add' by auto; nsatz.
    Qed.

    Lemma small_mod_eq a b n: a mod n = b mod n -> 0 <= a < n -> a = b mod n.
    Proof. intros; rewrite <-(Z.mod_small a n); auto. Qed.

    (* helper for some of the modular logic in compact *)
    Lemma compact_mod_step a b c d: 0 < a -> 0 < b ->
      a * ((c / a + d) mod b) + c mod a = (a * d + c) mod (a * b).
    Proof.
      clear.
      intros Ha Hb. assert (a <= a * b) by (apply Z.le_mul_diag_r; omega).
      pose proof (Z.mod_pos_bound c a Ha).
      pose proof (Z.mod_pos_bound (c/a+d) b Hb).
      apply small_mod_eq.
      { rewrite <-(Z.mod_small (c mod a) (a * b)) by omega.
        rewrite <-Z.mul_mod_distr_l with (c:=a) by omega.
        rewrite Z.mul_add_distr_l, Z.mul_div_eq, <-Z.add_mod_full by omega.
        f_equal; ring. }
      { split; [zero_bounds|].
        apply Z.lt_le_trans with (m:=a*(b-1)+a); [|ring_simplify; omega].
        apply Z.add_le_lt_mono; try apply Z.mul_le_mono_nonneg_l; omega. }
    Qed.

    Lemma compact_div_step a b c d : 0 < a -> 0 < b ->
      (c / a + d) / b = (a * d + c) / (a * b).
    Proof.
      clear. intros Ha Hb.
      rewrite <-Z.div_div by omega.
      rewrite Z.div_add_l' by omega.
      f_equal; ring.
    Qed.

    Lemma compact_div_mod {n} inp :
      (B.Positional.eval weight (snd (compact inp))
       = (eval inp) mod (weight n))
        /\ (fst (compact inp) = eval (n:=n) inp / weight n).
    Proof.
      cbv [compact compact_cps compact_step compact_step_cps];
        autorewrite with uncps push_id.
      change (fun i s a => compact_digit_cps i (s :: a) id)
        with (fun i s a => compact_digit i (s :: a)).

      apply mapi_with'_linvariant; [|tauto].

      clear n inp. intros n st x0 xs ys Hst Hys [Hmod Hdiv].
      pose proof (weight_positive n). pose proof (weight_divides n).
      autorewrite with push_basesystem_eval.
      destruct n; cbv [mapi_with] in *; simpl tuple in *;
        [destruct xs, ys; subst; simpl| cbv [eval] in *];
        repeat match goal with
               | _ => rewrite mapi_with'_left_step
               | _ => rewrite compact_digit_div, sum_cons
               | _ => rewrite compact_digit_mod, sum_cons
               | _ => rewrite map_left_append
               | _ => rewrite B.Positional.eval_left_append
               | _ => rewrite weight_0, ?Z.div_1_r, ?Z.mod_1_r
               | _ => rewrite Hdiv
               | _ => rewrite Hmod
               | _ => progress subst
               | _ => progress autorewrite with natsimplify cancel_pair push_basesystem_eval
               | _ => solve [split; ring_simplify; f_equal; ring]
               end.
        remember (weight (S (S n)) / weight (S n)) as bound.
        replace (weight (S (S n))) with (weight (S n) * bound)
          by (subst bound; rewrite Z.mul_div_eq by omega;
              rewrite weight_multiples; ring).
        split; [apply compact_mod_step | apply compact_div_step]; omega.
    Qed.

    Lemma compact_mod {n} inp :
      (B.Positional.eval weight (snd (compact inp))
       = (eval (n:=n) inp) mod (weight n)).
    Proof. apply (proj1 (compact_div_mod inp)). Qed.
    Hint Rewrite @compact_mod : push_basesystem_eval.

    Lemma compact_div {n} inp :
      fst (compact inp) = eval (n:=n) inp / weight n.
    Proof. apply (proj2 (compact_div_mod inp)). Qed.
    Hint Rewrite @compact_div : push_basesystem_eval.

    (* TODO : move to tuple *)
    Lemma hd_to_list {A n} a (t : A^(S n)) : List.hd a (to_list (S n) t) = hd t.
    Proof.
      rewrite (subst_append t), to_list_append, hd_append. reflexivity.
    Qed.

    Definition cons_to_nth_cps {n} i (x:Z) (t:(list Z)^n)
               {T} (f:(list Z)^n->T) :=
      @on_tuple_cps _ _ nil (update_nth_cps i (cons x)) n n t _ f.

    Definition cons_to_nth {n} i x t := @cons_to_nth_cps n i x t _ id.
    Lemma cons_to_nth_id {n} i x t T f :
      @cons_to_nth_cps n i x t T f = f (cons_to_nth i x t).
    Proof using Type.
      cbv [cons_to_nth_cps cons_to_nth].
      assert (forall xs : list (list Z), length xs = n ->
                 length (update_nth_cps i (cons x) xs id) = n) as Hlen.
      { intros. autorewrite with uncps push_id distr_length. assumption. }
      rewrite !on_tuple_cps_correct with (H:=Hlen)
        by (intros; autorewrite with uncps push_id; reflexivity). reflexivity.
    Qed.
    Hint Opaque cons_to_nth : uncps.
    Hint Rewrite @cons_to_nth_id : uncps.

    Lemma map_sum_update_nth l : forall i x,
      List.map sum (update_nth i (cons x) l) =
      update_nth i (Z.add x) (List.map sum l).
    Proof using Type.
      induction l as [|a l IHl]; intros i x; destruct i; simpl; rewrite ?IHl; reflexivity.
    Qed.

    Lemma cons_to_nth_add_to_nth n i x t :
      map sum (@cons_to_nth n i x t) = B.Positional.add_to_nth i x (map sum t).
    Proof using weight.
      cbv [B.Positional.add_to_nth B.Positional.add_to_nth_cps cons_to_nth cons_to_nth_cps on_tuple_cps].
      induction n; [simpl; rewrite !update_nth_cps_correct; reflexivity|].
      specialize (IHn (tl t)). autorewrite with uncps push_id in *.
      apply to_list_ext. rewrite <-!map_to_list.
      erewrite !from_list_default_eq, !to_list_from_list.
      rewrite map_sum_update_nth. reflexivity.
      Unshelve.
      distr_length.
      distr_length.
    Qed.

    Lemma eval_cons_to_nth n i x t : (i < n)%nat ->
      eval (@cons_to_nth n i x t) = weight i * x + eval t.
    Proof using Type.
      cbv [eval]; intros. rewrite cons_to_nth_add_to_nth.
      auto using B.Positional.eval_add_to_nth.
    Qed.
    Hint Rewrite eval_cons_to_nth using omega : push_basesystem_eval.

    Definition nils n : (list Z)^n := Tuple.repeat nil n.

    Lemma map_sum_nils n : map sum (nils n) = B.Positional.zeros n.
    Proof using Type.
      cbv [nils B.Positional.zeros]; induction n as [|n]; [reflexivity|].
      change (repeat nil (S n)) with (@nil Z :: repeat nil n).
      rewrite Tuple.map_repeat, sum_nil. reflexivity.
    Qed.

    Lemma eval_nils n : eval (nils n) = 0.
    Proof using Type. cbv [eval]. rewrite map_sum_nils, B.Positional.eval_zeros. reflexivity. Qed. Hint Rewrite eval_nils : push_basesystem_eval.

    Definition from_associational_cps n (p:list B.limb)
               {T} (f:(list Z)^n -> T) :=
      fold_right_cps2
        (fun t st T' f' =>
           B.Positional.place_cps weight t (pred n)
             (fun p=> cons_to_nth_cps (fst p) (snd p) st f'))
        (nils n) p f.

    Definition from_associational n p := from_associational_cps n p id.
    Lemma from_associational_id n p T f :
      @from_associational_cps n p T f = f (from_associational n p).
    Proof using Type.
      cbv [from_associational_cps from_associational].
      autorewrite with uncps push_id; reflexivity.
    Qed.
    Hint Opaque from_associational : uncps.
    Hint Rewrite from_associational_id : uncps.

    Lemma eval_from_associational n p (n_nonzero:n<>0%nat):
      eval (from_associational n p) = B.Associational.eval p.
    Proof using weight_0 weight_nonzero.
      cbv [from_associational_cps from_associational]; induction p;
        autorewrite with uncps push_id push_basesystem_eval; [reflexivity|].
        pose proof (B.Positional.weight_place_cps weight weight_0 weight_nonzero a (pred n)).
        pose proof (B.Positional.place_cps_in_range weight a (pred n)).
        rewrite Nat.succ_pred in * by assumption. simpl.
        autorewrite with uncps push_id push_basesystem_eval in *.
        rewrite eval_cons_to_nth by omega. nsatz.
    Qed.
  End Columns.
End Columns.
Hint Rewrite
     @Columns.compact_digit_id
     @Columns.compact_step_id
     @Columns.compact_id
     using (assumption || (intros; autorewrite with uncps; reflexivity))
  : uncps.
Hint Rewrite
     @Columns.cons_to_nth_id
     @Columns.from_associational_id
  : uncps.
Hint Rewrite
     @Columns.compact_mod
     @Columns.compact_div
     @Columns.eval_cons_to_nth
     @Columns.eval_from_associational
     @Columns.eval_nils
  using (assumption || omega): push_basesystem_eval.

Hint Unfold
     Columns.eval Columns.eval_from
     Columns.compact_digit_cps Columns.compact_digit
     Columns.compact_step_cps Columns.compact_step
     Columns.compact_cps Columns.compact
     Columns.cons_to_nth_cps Columns.cons_to_nth
     Columns.nils
     Columns.from_associational_cps Columns.from_associational
  : basesystem_partial_evaluation_unfolder.

Ltac basesystem_partial_evaluation_unfolder t :=
  let t :=
      (eval
         cbv
         delta [
           (* this list must contain all definitions referenced by t that reference [Let_In], [runtime_add], [runtime_opp], [runtime_mul], [runtime_shr], or [runtime_and] *)
           Columns.eval Columns.eval_from
                   Columns.compact_digit_cps Columns.compact_digit
                   Columns.compact_step_cps Columns.compact_step
                   Columns.compact_cps Columns.compact
                   Columns.cons_to_nth_cps Columns.cons_to_nth
                   Columns.nils
                   Columns.from_associational_cps Columns.from_associational
         ] in t) in
  let t := Arithmetic.Core.basesystem_partial_evaluation_unfolder t in
  t.

Ltac Arithmetic.Core.basesystem_partial_evaluation_default_unfolder t ::=
  basesystem_partial_evaluation_unfolder t.


Require Import Coq.NArith.NArith.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Crypto.Util.NatUtil Crypto.Util.Decidable.
Require bbv.WordScope.
Require Import bbv.NatLib.
Require Crypto.Util.WordUtil.

Module N.
  Lemma size_le a b : (a <= b -> N.size a <= N.size b)%N.
  Proof.
    destruct (dec (a=0)%N), (dec (b=0)%N); subst; auto using N.le_0_l.
    { destruct a; auto. }
    { rewrite !N.size_log2 by assumption.
      rewrite <-N.succ_le_mono.
      apply N.log2_le_mono. }
  Qed.

  Lemma le_to_nat a b : (a <= b)%N <-> (N.to_nat a <= N.to_nat b)%nat.
  Proof.
    rewrite <-N.lt_succ_r.
    rewrite <-Nat.lt_succ_r.
    rewrite <-Nnat.N2Nat.inj_succ.
    rewrite <-NatUtil.Nat2N_inj_lt.
    rewrite !Nnat.N2Nat.id.
    reflexivity.
  Qed.

  Lemma size_nat_equiv : forall n, N.size_nat n = N.to_nat (N.size n).
  Proof.
    destruct n as [|p]; auto; simpl; induction p as [p IHp|p IHp|]; simpl; auto; rewrite IHp, Pnat.Pos2Nat.inj_succ; reflexivity.
  Qed.

  Lemma size_nat_le a b : (a <= b)%N -> (N.size_nat a <= N.size_nat b)%nat.
  Proof.
    rewrite !size_nat_equiv.
    rewrite <-le_to_nat.
    apply size_le.
  Qed.

  Lemma shiftr_size : forall n bound, N.size_nat n <= bound ->
    N.shiftr_nat n bound = 0%N.
  Proof.
    intros n bound H.
    rewrite <- (Nat2N.id bound).
    rewrite Nshiftr_nat_equiv.
    destruct (N.eq_dec n 0); subst; [apply N.shiftr_0_l|].
    apply N.shiftr_eq_0.
    rewrite size_nat_equiv in *.
    rewrite N.size_log2 in * by auto.
    apply N.le_succ_l.
    rewrite <- N.compare_le_iff.
    rewrite N2Nat.inj_compare.
    rewrite <- Compare_dec.nat_compare_le.
    rewrite Nat2N.id.
    auto.
  Qed.

  Hint Rewrite
    N.succ_double_spec
    N.add_1_r
    Nat2N.inj_succ
    Nat2N.inj_mul
    N2Nat.id: N_nat_conv
 .

  Lemma succ_double_to_nat : forall n,
    N.succ_double n = N.of_nat (S (2 * N.to_nat n)).
  Proof.
    intros.
    replace 2 with (N.to_nat 2) by auto.
    autorewrite with N_nat_conv.
    reflexivity.
  Qed.

  Lemma double_to_nat : forall n,
    N.double n = N.of_nat (2 * N.to_nat n).
  Proof.
    intros.
    replace 2 with (N.to_nat 2) by auto.
    autorewrite with N_nat_conv.
    reflexivity.
  Qed.

  Lemma shiftr_succ : forall n i,
    N.to_nat (N.shiftr_nat n i) =
    if N.testbit_nat n i
    then S (2 * N.to_nat (N.shiftr_nat n (S i)))
    else (2 * N.to_nat (N.shiftr_nat n (S i))).
  Proof.
    intros n i.
    rewrite Nshiftr_nat_S.
    case_eq (N.testbit_nat n i); intro testbit_i;
      pose proof (Nshiftr_nat_spec n i 0) as shiftr_n_odd;
      rewrite Nbit0_correct in shiftr_n_odd; simpl in shiftr_n_odd;
      rewrite testbit_i in shiftr_n_odd.
    + pose proof (Ndiv2_double_plus_one (N.shiftr_nat n i) shiftr_n_odd) as Nsucc_double_shift.
      rewrite succ_double_to_nat in Nsucc_double_shift.
      apply Nat2N.inj.
      rewrite Nsucc_double_shift.
      apply N2Nat.id.
    + pose proof (Ndiv2_double (N.shiftr_nat n i) shiftr_n_odd) as Nsucc_double_shift.
      rewrite double_to_nat in Nsucc_double_shift.
      apply Nat2N.inj.
      rewrite Nsucc_double_shift.
      apply N2Nat.id.
  Qed.

  Section ZN.
    Import Coq.ZArith.ZArith.
    Lemma ZToN_NPow2_lt : forall z n, (0 <= z < 2 ^ Z.of_nat n)%Z ->
                                      (Z.to_N z < Npow2 n)%N.
    Proof.
      intros.
      apply WordUtil.bound_check_nat_N.
      apply Znat.Nat2Z.inj_lt.
      rewrite Znat.Z2Nat.id by omega.
      rewrite ZUtil.Z.pow_Zpow.
      replace (Z.of_nat 2) with 2%Z by reflexivity.
      omega.
    Qed.

    Let ZNWord sz x := Word.NToWord sz (BinInt.Z.to_N x).
    Lemma combine_ZNWord : forall sz1 sz2 z1 z2,
        (0 <= Z.of_nat sz1)%Z ->
        (0 <= Z.of_nat sz2)%Z ->
        (0 <= z1 < 2 ^ (Z.of_nat sz1))%Z ->
        (0 <= z2 < 2 ^ (Z.of_nat sz2))%Z ->
        Word.combine (ZNWord sz1 z1) (ZNWord sz2 z2) =
        ZNWord (sz1 + sz2) (Z.lor z1 (Z.shiftl z2 (Z.of_nat sz1))).
    Proof using Type.
      cbv [ZNWord]; intros.
      rewrite !Word.NToWord_nat.
      match goal with |- ?a = _ => rewrite <- (Word.natToWord_wordToNat a) end.
      rewrite WordUtil.wordToNat_combine.
      rewrite !Word.wordToNat_natToWord_idempotent by (rewrite Nnat.N2Nat.id; auto using ZToN_NPow2_lt).
      f_equal.
      rewrite ZUtil.Z.lor_shiftl by auto.
      rewrite !Z_N_nat.
      rewrite Znat.Z2Nat.inj_add by (try apply Z.shiftl_nonneg; omega).
      f_equal.
      rewrite Z.shiftl_mul_pow2 by auto.
      rewrite Znat.Z2Nat.inj_mul by omega.
      rewrite <-ZUtil.Z.pow_Z2N_Zpow by omega.
      rewrite Nat.mul_comm.
      f_equal.
    Qed.
  End ZN.

End N.


Require Import Reals Psatz.
Require Import Coquelicot.Hierarchy.
Require Import Coquelicot.Rbar.
Require Import Top.linear_map.
Require Import Top.continuous_linear_map.
Require Import Coquelicot.Coquelicot.
Require Import Decidable.
Require Import Coquelicot.Rbar.

Open Scope R_scope.

(* Defining X, Y , Xh, Yh as Banach spaces (complete normed spaces)*)
Context {X: CompleteNormedModule R_AbsRing}.
Context {Xh: R -> CompleteNormedModule R_AbsRing}.
Context {Y: CompleteNormedModule R_AbsRing}.
Context {Yh: R -> CompleteNormedModule R_AbsRing}.

(* Defining a linear mapping on Banach space*)
Definition is_linear_mapping (E F: CompleteNormedModule R_AbsRing) (phi: E -> F) :=
  (forall (x y :E), phi (plus x y) = plus (phi x) (phi y))
     /\ (forall (x : E) (l:R_AbsRing), phi (scal l x) = scal l (phi x)).

(* Defining linear bounded restriction operator from E to F*)
Definition is_bounded_linear (E F: CompleteNormedModule R_AbsRing)(phi:E->F):=
     is_linear_mapping E F phi /\ (exists K:R, 0<=K /\ (forall x:E, norm(phi x) <= K* norm x)).

Context {E : CompleteNormedModule R_AbsRing}.
Context {F : CompleteNormedModule R_AbsRing}.

(* Defining uniformly bounded opaartor from E to F*)
Definition is_uniformly_bounded (E F: CompleteNormedModule R_AbsRing) (phi:E->F):=
 (is_bounded_linear E F phi) /\ (exists c1:Rbar ,forall h:R,(operator_norm (phi)) <= c1).

Variable Aop: X->Y.
Variable Ah_op: (forall (h:R), (Xh h)->(Yh h)).

(*** This lemma uses the property of linear operator to prove that phi(x-y)= phi(x)-phi(y) ,
      where x and Y belong to Banach spaces E and F respectively and phi: E->F ***************)

Lemma composition (E F:CompleteNormedModule R_AbsRing):
forall (x y: E) (phi: E->F), is_linear_mapping E F phi ->  phi( minus x y) = minus (phi x) (phi y).
Proof.
intros.
destruct H.
unfold minus.
specialize (H x (opp y)).
cut (opp(phi y)= phi(opp y)).
+ intros. rewrite H1. apply  H.
+ cut (scal (opp one) y= opp y).
  * intros. rewrite <- H1.
    cut (phi(scal (opp one) y)= scal (opp one) (phi y)).
    - intros. rewrite H2.
      cut (scal (opp one) (phi y)=opp (phi y)).
      + intros. rewrite H3. reflexivity.
      + apply (scal_opp_one (phi y)).
    - apply (H0 y (opp one)).
  * apply (scal_opp_one y).
Qed.

(*Lemma as an argument for posreal*)
Lemma two_zero: 0<2.
Proof.
apply Rlt_R0_R2.
Qed.

(* Define f=Au , u=Ef and EhAh=I*)

(* Lax equivalence theorem to prove the convergence*)
Theorem is_convergent:
forall (u:X) (f:Y) (h:R) (uh: Xh h) (rh: forall (h:R), X -> (Xh h)) (sh: forall (h:R), Y->(Yh h))
 (E: Y->X) (Eh:forall (h:R), (Yh h)->(Xh h)),
 is_linear_mapping X Y Aop -> f=Aop u-> (* Hypothesis that A is a linear mapping from X to Y*)
  (forall (h:R), is_linear_mapping (Xh h) (Yh h) (Ah_op h) )-> (* Hypothesis that Ah is a linear
   mapping from Xh to Yh for each h*)
  (forall (h:R), is_bounded_linear X (Xh h) (rh h))->(* Hypothesis that rh is a bounded linear
  operatior (restriction) from X to Xh for each h*)
  (forall (h:R), is_bounded_linear Y (Yh h) (sh h))-> (* Hypothesis that sh is a bounded linear
  operator (restriction) from Y to Yh*)
  is_bounded_linear Y X E -> (* Hypothesis that E is a bounded linear operator from Y to X*)
  u=E f-> (* Defining solution in continuous space (true solution)*)
  (forall (h:R), is_bounded_linear (Yh h) (Xh h) (Eh h))-> (* Hypotheis that Eh is a bounded
  linear operator from Yh to Xh for each h*)
 (forall h:R, is_finite (operator_norm(Eh h))) -> (* Hypothesis that ||Eh|| is finite*)
   (uh= Eh h (sh h f))-> (* Defining a discrete solution uh*)
   ( Ah_op h uh = sh h f)-> (*f =fh*)
  (forall (h:R), rh h u= Eh h (Ah_op h (rh h u)))-> (*uh =Eh *Ah *uh, where Eh*Ah=I*)
  (forall h:R,  minus (Ah_op h (rh h u)) (sh h (Aop u)) <> zero )->

  (is_lim (fun h:R =>
      norm (minus (Ah_op h (rh h u)) (sh h (Aop u)))) 0 0 (*Consistency*) /\
  ( exists K:R , forall (h:R), operator_norm(Eh h)<=K ) (* Stability*)->
  is_lim (fun h:R=>
      norm (minus (rh h (E(f))) (Eh h (sh h (f))))) 0 0) (*Convergence*).

Proof.
intros.

destruct H12 as [H12 H13].
destruct H13 as [p H13].
apply (is_lim_ext ((fun h0 : R => norm (minus (Eh h0 (Ah_op h0 (rh h0 u))) (Eh h0 (sh h0 f)))))
        (fun h0 : R => norm (minus (rh h0 (E0 f)) (Eh h0 (sh h0 f)))) 0 0).
+ intros.
  cut(Eh y (Ah_op y (rh y u)) = (rh y (E0 f))).
  - intros. rewrite H14. reflexivity.
  - symmetry. specialize (H10 y). rewrite <- H5. apply H10.
+ apply (is_lim_ext (fun h0 : R => norm (Eh h0 (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u)))))
          (fun h0 : R => norm (minus (Eh h0 (Ah_op h0 (rh h0 u))) (Eh h0 (sh h0 f)))) 0 0).
  - intros.
    cut(Eh y (minus (Ah_op y (rh y u)) (sh y (Aop u)))= minus (Eh y (Ah_op y (rh y u))) (Eh y (sh y f))).
    * intros. rewrite H14. reflexivity.
    * rewrite H0. apply (composition (Yh y) (Xh y) (Ah_op y (rh y u)) (sh y (Aop u)) (Eh y)).
      unfold is_bounded_linear in H6. specialize (H6 y). destruct H6 as [H14 H15]. apply H14.
  -  cut (Rbar_locally' 0 (fun h0:R => 0 <=norm (Eh h0 (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u))))
                  <= operator_norm (Eh h0) * norm (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u))))).
     * intros.
      (* Applying the sandwich theorem for limits
              In Coq, this is expressed as:
              Lemma is_lim_le_le_loc (f g h: R -> R) (x: Rbar) (l:Rbar):
                Rbar_locally' x (fun y=> f y<= h y <= g y) ->
                    is_lim f x l -> is_lim g x l -> is_lim h x l

              Here, since the function g  is chosen as:
                    ||Eh||*||Ah (rh u) - sh (A(u))|| (upper bound)
                    and the function f is a constant function O since from property of
                    norm 0<= ||.|| *)
        apply (is_lim_le_le_loc (fun _ => 0)
                    (fun h0:R =>operator_norm (Eh h0) * norm (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u))))
                        (fun h0:R => norm (Eh h0 (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u))))) 0 0).
        apply H14.
        apply (is_lim_const 0 0). (* Applying property of limits for a constant function*)
        cut(Rbar_locally' (Rbar_mult p 0) (fun h0:R => 0 <= operator_norm (Eh h0) * norm (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u)))
                              <= p* norm (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u))))).
        { intros.
          cut(Rbar_mult p 0 = 0).
          + intros. rewrite <-H16.
             apply (is_lim_le_le_loc (fun _  =>0) (fun h0:R  => p* norm(minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u))))
                        (fun h0:R  => operator_norm (Eh h0) * norm (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u)))) (Rbar_mult p 0) (Rbar_mult p 0)).
             apply H15.
             rewrite H16.
             apply (is_lim_const 0 0).
              (* Applying the property of limit:
                      lim_{x-> a} K*f(x)= K* lim_{x->a} f(x) *)
             apply (is_lim_scal_l (fun h0:R => norm (minus (Ah_op h0 (rh h0 u)) (sh h0 (Aop u))))
                         p (Rbar_mult p 0) 0).
             rewrite H16.
             apply H12.
          + apply (Rbar_mult_0_r p).
        }
        {
             unfold Rbar_locally'.
                unfold locally'.
                unfold within.
                unfold locally.
                exists (mkposreal 2 two_zero).
                intros.
                split.
                cut(0*0=0).
                + intros. rewrite <- H17.
                  apply (Rmult_le_compat 0 (operator_norm (Eh y)) 0 (norm (minus (Ah_op y (rh y u)) (sh y (Aop u))))).
                  apply Rle_refl. apply Rle_refl.
                 (* Applying the property that operator norm of Eh >=0*)
                  apply (operator_norm_ge_0' (Eh y)).
                  (* Proving that ||a-b|| >=0 *)
                  cut (Rabs (norm (Ah_op y (rh y u))- norm (sh y (Aop u)))<= norm (minus (Ah_op y (rh y u)) (sh y (Aop u)))).
                  - intros.
                    apply (Rle_trans 0 (Rabs (norm (Ah_op y (rh y u)) - norm (sh y (Aop u))))
                            (norm (minus (Ah_op y (rh y u)) (sh y (Aop u))))).
                    apply Rabs_pos.
                    apply H18.
                  - apply (norm_triangle_inv (Ah_op y (rh y u))(sh y (Aop u))).
                + nra.

            (* Proof that ||Eh||*||Ah (rh u) - sh (A u)|| <= K* ||Ah (rh u) -sh (A u)||
                when ||Eh||<=K*)
              apply (Rmult_le_compat_r (norm (minus (Ah_op y (rh y u)) (sh y (Aop u))))
                    (operator_norm (Eh y)) p).
              cut (Rabs (norm (Ah_op y (rh y u))- norm (sh y (Aop u)))<= norm (minus (Ah_op y (rh y u)) (sh y (Aop u)))).
              - intros.
                apply (Rle_trans 0 (Rabs (norm (Ah_op y (rh y u)) - norm (sh y (Aop u))))
                        (norm (minus (Ah_op y (rh y u)) (sh y (Aop u))))).
                apply Rabs_pos.
                apply H17.
              - apply (norm_triangle_inv (Ah_op y (rh y u))(sh y (Aop u))).
              apply H13.
        }
        (* Proof that 0<=||Eh(Ah (rh u)- sh (A u)||<= ||Eh||||Ah rh u- sh A u||
              in an open neighborhood of 0*)
      *  unfold Rbar_locally'.
            unfold locally'.
            unfold within.
            unfold locally.
            exists (mkposreal 2 two_zero).
            intros.
            split.
            (* Proof that 0 <= norm (Eh h (minus (Ah h (rh h u)) (sh h (A u)))) *)
            cut(Eh y (minus (Ah_op y (rh y u)) (sh y (Aop u)))= minus (Eh y (Ah_op y (rh y u))) (Eh y (sh y f))).
            { intros. rewrite H16.
              cut( Rabs(norm (Eh y (Ah_op y (rh y u))) - norm (Eh y (sh y (Aop u)))) <= norm (minus (Eh y (Ah_op y (rh y u))) (Eh y (sh y (Aop u))))).
              + intros. rewrite H0.
                apply (Rle_trans 0 (Rabs (norm (Eh y (Ah_op y (rh y u))) - norm (Eh y (sh y (Aop u)))))
                                    ( norm (minus (Eh y (Ah_op y (rh y u))) (Eh y (sh y (Aop u)))))).
                apply Rabs_pos.
                apply H17.
              + apply (norm_triangle_inv (Eh y (Ah_op y (rh y u))) (Eh y (sh y (Aop u)))).
            }
            { rewrite H0. apply (composition (Yh y) (Xh y) (Ah_op y (rh y u)) (sh y (Aop u)) (Eh y)).
              unfold is_bounded_linear in H6. specialize (H6 y). destruct H6 as [H16 H17]. apply H16.
            }

            (* Applying the lemma that ||Eh(Ah (rh u)- sh (A u)||<= ||Eh||||Ah rh u- sh A u||*)
            apply (operator_norm_helper' (Eh y)).
            specialize (H7 y). apply H7.
            specialize (H11 y). apply H11.
Qed.


Definition LEM : Prop := forall (p:Prop), p \/ ~p.

Definition PropExt : Prop := forall (p q:Prop), p <-> q -> p = q.

Lemma L1 : LEM -> forall (p:Prop), (p <-> True) \/ (p <-> False).
Proof.
    intros L p. destruct (L p) as [H1|H1].
    - left. split; intros H2.
        + trivial.
        + assumption.
    - right. split; intros H2.
        +  apply H1. assumption.
        + contradiction.
Qed.

Lemma PropostionalCompleteness : LEM -> PropExt ->
    forall (p:Prop), p = True \/ p = False.
Proof.
    intros L P p. destruct (L1 L p) as [H|H].
    - left. apply P. assumption.
    - right. apply P. assumption.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf1 : natural) : natural :=
  plus (Succ Zero) y.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Theorem theorem0 : forall (x : Lst) (y : Nat), eq (rev (append (append x (cons y nil)) nil)) (cons y (rev (append x nil))).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.


(**********************************************************************************
 * PredomFix.v                                                                    *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(*==========================================================================
  Definition of fixpoints and associated lemmas
  ==========================================================================*)
Require Import PredomCore.
Require Import PredomLift.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** ** Fixpoints *)

Section Fixpoints.
 Variable D : cppoType.

Variable f : cpoCatType D D.

Fixpoint iter_ n : D := match n with O => PBot | S m => f (iter_ m) end.

Lemma iter_incr : forall n, iter_ n <= f (iter_ n).
elim ; first by apply: leastP.
move => n L. simpl. apply: fmonotonic. by apply L.
Save.

Hint Resolve iter_incr.

Lemma iter_m : monotonic iter_.
move => n n'. elim: n' n.
- move => n. move => L. unfold Ole in L. simpl in L.
  rewrite -> (leqn0 n) in L. by rewrite (eqP L).
- move => n IH n' L. unfold Ole in L. simpl in L. rewrite leq_eqVlt in L.
  case_eq (n' == n.+1) => E ; rewrite E in L. by rewrite (eqP E).
  specialize (IH _ L). by rewrite -> IH ; simpl.
Qed.

Definition iter : natO =-> D := mk_fmono (iter_m).

Definition fixp : D := lub iter.

Lemma fixp_le : fixp <= f fixp.
unfold fixp.
apply Ole_trans with (lub (ocomp f iter)).
- apply: lub_le_compat. move => x. simpl. by apply iter_incr.
- by rewrite -> lub_comp_le.
Save.
Hint Resolve fixp_le.

Lemma fixp_eq : fixp =-= f fixp.
apply: Ole_antisym; first by [].
unfold fixp. rewrite {2} (lub_lift_left iter (S O)).
rewrite -> (fcontinuous f iter). by apply: lub_le_compat => i.
Save.

Lemma fixp_inv : forall g, f g <= g -> fixp <= g.
unfold fixp; intros g l.
apply: lub_le. elim. simpl. by apply: leastP.
move => n L. apply: (Ole_trans _ l). apply: (fmonotonic f). by apply L.
Save.

End Fixpoints.
Hint Resolve fixp_le fixp_eq fixp_inv.

Definition fixp_cte (D:cppoType) : forall (d:D), fixp (const D d) =-= d.
intros; apply fixp_eq with (f:=const D d); red; intros; auto.
Save.
Hint Resolve fixp_cte.

Add Parametric Morphism (D:cppoType) : (@fixp D)
with signature (@Ole _ : ((D:cpoType) =-> D) -> (D =-> D) -> Prop) ++> (@Ole _)
as fixp_le_compat.
move => x y l. unfold fixp.
apply: lub_le_compat. elim ; first by [].
move => n IH. simpl. rewrite -> IH. by apply l.
Qed.
Hint Resolve fixp_le_compat.

Add Parametric Morphism (D:cppoType) : (@fixp D)
with signature (@tset_eq _) ==> (@tset_eq D)
as fixp_eq_compat.
by intros x y H; apply Ole_antisym ; apply: (fixp_le_compat _) ; case: H.
Save.
Hint Resolve fixp_eq_compat.

Lemma fixp_mon (D:cppoType) : monotonic (@fixp D).
move => x y e. by rewrite -> e.
Qed.

Definition Fixp (D:cppoType) : ordCatType (D -=> D) D := Eval hnf in mk_fmono (@fixp_mon D).

Lemma Fixp_simpl (D:cppoType) : forall (f:D =-> D), Fixp D f = fixp f.
trivial.
Save.

Lemma iter_mon (D:cppoType) : monotonic (@iter D).
move => x y l. elim ; first by [].
move => n IH. simpl. rewrite -> IH. by apply l.
Qed.

Definition Iter (D:cppoType) : ordCatType (D -=> D) (fmon_cpoType natO D) :=
  Eval hnf in mk_fmono (@iter_mon D).

Lemma IterS_simpl (D:cppoType) : forall f n, Iter D f (S n) = f (Iter _ f n).
trivial.
Save.

Lemma iterS_simpl (D:cppoType) : forall (f:cpoCatType D D) n, iter f (S n) = f (iter  f n).
trivial.
Save.

Lemma iter_continuous (D:cppoType) :
    forall h : natO =-> D -=> D,
                  iter (lub h) <= lub (Iter D << h).
move => h. elim ; first by apply: leastP.
move => n IH. simpl. rewrite fcont_app_eq. rewrite -> IH. rewrite <- fcont_app_eq.
rewrite fcont_app_continuous. rewrite lub_diag. by apply lub_le_compat => i.
Qed.

Hint Resolve iter_continuous.

Lemma iter_continuous_eq (D:cppoType) :
    forall h : natO =-> (D -=> D),
                  iter (lub h) =-= lub (Iter _ << h).
intros; apply: Ole_antisym; auto.
exact (lub_comp_le (Iter _ (*D*)) h).
Save.

Lemma fixp_continuous (D:cppoType) : forall (h : natO =-> (D -=> D)),
       fixp (lub h) <= lub (Fixp D << h).
move => h. unfold fixp. rewrite -> iter_continuous_eq.
apply: lub_le => n. simpl.
apply: lub_le => m. simpl. rewrite <- (le_lub _ m). simpl. unfold fixp. by rewrite <- (le_lub _ n).
Save.
Hint Resolve fixp_continuous.

Lemma fixp_continuous_eq (D:cppoType) : forall (h : natO =-> (D -=> D)),
        fixp (lub h) =-= lub (Fixp D << h).
intros; apply: Ole_antisym; auto.
by apply (lub_comp_le (Fixp D) h).
Save.

Lemma Fixp_cont (D:cppoType) : continuous (@Fixp D).
move => c.
rewrite Fixp_simpl. by rewrite -> fixp_continuous_eq.
Qed.

Definition FIXP (D:cppoType) : (D -=> D) =-> D := Eval hnf in  mk_fcont (@Fixp_cont D).
Implicit Arguments FIXP [D].

Lemma FIXP_simpl (D:cppoType) : forall (f:D=->D), FIXP f = fixp f.
trivial.
Save.

Lemma FIXP_le_compat (D:cppoType) : forall (f g : D =-> D),
            f <= g -> FIXP f <= FIXP g.
move => f g l. by rewrite -> l.
Save.
Hint Resolve FIXP_le_compat.

Lemma FIXP_eq (D:cppoType) : forall (f:D=->D), FIXP f =-= f (FIXP f).
intros; rewrite FIXP_simpl.
by apply: (fixp_eq).
Save.
Hint Resolve FIXP_eq.

Lemma FIXP_com: forall E D (f:E =-> (D -=> D)) , FIXP << f =-= ev << <| f, FIXP << f |>.
intros E D f. apply: fmon_eq_intro. intros e. simpl. by rewrite {1} fixp_eq.
Qed.

Lemma FIXP_inv (D:cppoType) : forall (f:D=->D)(g : D), f g <= g -> FIXP f <= g.
intros; rewrite FIXP_simpl; apply: fixp_inv; auto.
Save.

(** *** Iteration of functional *)
Lemma FIXP_comp_com (D:cppoType) : forall (f g:D=->D),
       g << f <= f << g-> FIXP g <= f (FIXP g).
intros; apply FIXP_inv.
apply Ole_trans with (f (g (FIXP g))).
assert (X:=H (FIXP g)). simpl. by apply X.
apply: fmonotonic.
case (FIXP_eq g); trivial.
Save.

Lemma FIXP_comp (D:cppoType) : forall (f g:D=->D),
       g << f <= f << g -> f (FIXP g) <= FIXP g -> FIXP (f << g) =-= FIXP g.
intros; apply: Ole_antisym.
- apply FIXP_inv. simpl.
  apply Ole_trans with (f (FIXP g)) ; last by []. by rewrite <- (FIXP_eq g).
- apply: FIXP_inv.
  assert (g (f (FIXP  (f << g))) <= f (g (FIXP  (f << g)))).
  specialize (H (FIXP (f << g))). apply H.
  case (FIXP_eq (f<<g)); intros.
  apply Ole_trans with (2:=H3).
  apply Ole_trans with (2:=H1).
  apply: fmonotonic.
  apply FIXP_inv. simpl. apply: fmonotonic.
  apply Ole_trans with (1:=H1); auto.
Save.

Fixpoint fcont_compn (D:cppoType) (f:D =->D) (n:nat) {struct n} : D =->D :=
             match n with O => f | S p => fcont_compn f p << f end.

Add Parametric Morphism (D1 D2 D3 : cpoType) : (@ccomp D1 D2 D3)
with signature (@Ole (D2 -=> D3) : (D2 =-> D3) -> (D2 =-> D3) -> Prop ) ++> (@Ole (D1 -=> D2)) ++> (@Ole (D1 -=> D3))
as fcont_comp_le_compat.
move => f g l h k l' x. simpl. rewrite -> l. by rewrite -> l'.
Save.

Lemma fcont_compn_com (D:cppoType) : forall (f:D =->D) (n:nat),
            f << (fcont_compn f n) <= fcont_compn f n << f.
induction n; first by [].
simpl fcont_compn. rewrite -> comp_assoc. by apply: (fcont_comp_le_compat _ (Ole_refl f)).
Save.

Lemma FIXP_compn (D:cppoType) :
     forall  (f:D =->D) (n:nat), FIXP (fcont_compn f n) =-= FIXP f.
move => f. case ; first by []. simpl.
move => n. apply: FIXP_comp ; first by apply fcont_compn_com.
elim: n. simpl. by rewrite <- (FIXP_eq f).
move => n IH. simpl. rewrite <- (FIXP_eq f). by apply IH.
Save.

Lemma fixp_double (D:cppoType) : forall (f:D=->D), FIXP (f << f) =-= FIXP f.
intros; exact (FIXP_compn f (S O)).
Save.

(** *** Induction principle *)
(*=Adm *)
Definition admissible (D:cpoType) (P:D -> Prop) :=
             forall f : natO =-> D, (forall n, P (f n)) -> P (lub f).
Lemma fixp_ind (D:cppoType) : forall  (F: D =-> D)(P:D -> Prop),
             admissible P -> P PBot -> (forall x, P x -> P (F x)) -> P (fixp F). (*CLEAR*)
move => F P Adm B I.
apply Adm. by elim ; simpl ; auto.
Qed.
(*CLEARED*)
(*=End *)

Definition admissibleT (D:cpoType) (P:D -> Type) :=
          forall f : natO =-> D, (forall n, P (f n)) -> P (lub f).

Section SubCPO.
Variable D E:cpoType.
Variable P : D -> Prop.
Variable I:admissible P.

Definition Subchainlub (c:natO =-> (sub_ordType P)) : sub_ordType P.
exists (@lub D (Forgetm P << c)).
unfold admissible in I. specialize (@I (Forgetm P << c)).
apply I. intros i. simpl. case (c i). auto.
Defined.

Lemma subCpoAxiom : CPO.axiom Subchainlub.
intros c e n. unfold Subchainlub. split. case_eq (c n). intros x Px cn.
refine (Ole_trans _ (@le_lub _ (Forgetm P << c) n)).
simpl. rewrite cn. auto.
intros C. simpl.
case_eq e. intros dd pd de.
refine (lub_le _). intros i. simpl. specialize (C i).
case_eq (c i). intros d1 pd1 cn. rewrite cn in C.
simpl in C. rewrite de in C. auto.
Qed.

Canonical Structure sub_cpoMixin := CpoMixin subCpoAxiom.
Canonical Structure sub_cpoType := Eval hnf in CpoType sub_cpoMixin.

Lemma InheritFun_cont (f:E =-> D) (p:forall d, P (f d)) : continuous (InheritFunm _ p).
move => c. simpl. unfold Ole. simpl. rewrite (fcontinuous f). by apply lub_le_compat => i.
Qed.

Definition InheritFun (f:E =-> D) (p:forall d, P (f d)) : E =-> sub_cpoType :=
  Eval hnf in mk_fcont (InheritFun_cont p).

Lemma InheritFun_simpl (f:E =-> D) (p:forall d, P (f d)) d : InheritFun p d = InheritFunm _ p d.
by [].
Qed.

Lemma Forgetm_cont : continuous (Forgetm P).
by move => c.
Qed.

Definition Forget : sub_cpoType =-> D := Eval hnf in mk_fcont Forgetm_cont.

Lemma forgetlub (c:natO =-> (sub_ordType P)) :
  Forget (Subchainlub c) = (@lub D (Forgetm P << c)).
auto.
Qed.

Lemma ForgetP d : P (Forget d).
intros. case d. auto.
Qed.

End SubCPO.

Lemma Forget_leinj: forall (D:cpoType) (P:D -> Prop) (I:admissible P) (d:sub_cpoType I) e, Forget I d <= Forget I e -> d <= e.
intros D P I d e. case e. clear e. intros e Pe. case d. clear d. intros d Pd.
auto.
Qed.

Hint Resolve Forget_leinj.

Lemma Forget_inj : forall (D:cpoType) (P:D -> Prop) (I:admissible P) (d:sub_cpoType I) e, Forget I d =-= Forget I e -> d =-= e.
intros. by split ; case: H ; case: d ; case: e.
Qed.

Hint Resolve Forget_inj.

Lemma Forget_leinjp: forall (D E:cpoType) (P:D -> Prop) (I:admissible P) (d:E =-> sub_cpoType I) e,
      Forget I << d <= Forget I << e -> d <= e.
intros D E P I d e C x. specialize (C x). simpl in C. unfold FCont.fmono. simpl.
case: (e x) C => e' Pe. case: (d x) => d' Pd l. by apply l.
Qed.

Lemma Forget_injp: forall (D E:cpoType) (P:D -> Prop) (I:admissible P) (d:E =-> sub_cpoType I) e,
      Forget I << d =-= Forget I << e -> d =-= e.
intros D E P I d e C.
apply: fmon_eq_intro. intros x. assert (CC:=fmon_eq_elim C x). simpl in CC.
unfold FCont.fmono. simpl. clear C.
case: (e x) CC. clear e. intros e Pe. case (d x). clear d. intros d Pd.
auto.
Qed.

Lemma InheritFun_eq_compat D E Q Qcc f g X XX : f =-= g ->
    (@InheritFun D E Q Qcc f X) =-= (@InheritFun D E Q Qcc g XX).
intros. refine (fmon_eq_intro _). intros d. have A:=fmon_eq_elim H d. clear H. by split ; case: A.
Qed.

Lemma ForgetInherit (D E:cpoType) (P:D -> Prop) PS f B : Forget PS << @InheritFun D E P PS f B =-= f.
by refine (fmon_eq_intro _).
Qed.

Lemma InheritFun_comp: forall D E F P I (f:E =-> F) X (g:D =-> E) XX,
      @InheritFun F _ P I f X << g =-= @InheritFun _ _ P I (f << g) XX.
intros. refine (fmon_eq_intro _). intros d. simpl.
split ; simpl ; by [].
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Plus.
Require Import Mult.
Require Import Lt.
Open Local Scope nat_scope.

(** Factorial *)

Fixpoint fact (n:nat) : nat :=
  match n with
    | O => 1
    | S n => S n * fact n
  end.

Arguments Scope fact [nat_scope].

Lemma lt_O_fact : forall n:nat, 0 < fact n.
Proof.
  simple induction n; unfold lt in |- *; simpl in |- *; auto with arith.
Qed.

Lemma fact_neq_0 : forall n:nat, fact n <> 0.
Proof.
  intro.
  apply sym_not_eq.
  apply lt_O_neq.
  apply lt_O_fact.
Qed.

Lemma fact_le : forall n m:nat, n <= m -> fact n <= fact m.
Proof.
  induction 1.
  apply le_n.
  assert (1 * fact n <= S m * fact m).
  apply mult_le_compat.
  apply lt_le_S; apply lt_O_Sn.
  assumption.
  simpl (1 * fact n) in H0.
  rewrite <- plus_n_O in H0.
  assumption.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 6: Transition Systems
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

Set Implicit Arguments.
(* This command will treat type arguments to functions as implicit, like in
 * Haskell or ML. *)

(* Here's a classic recursive, functional program for factorial. *)
Fixpoint fact (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => fact n' * S n'
  end.

(* But let's reformulate factorial relationally, as an example to explore
 * treatment of inductive relations in Coq.  First, these are the states of our
 * state machine. *)
Inductive fact_state :=
| AnswerIs (answer : nat)
| WithAccumulator (input accumulator : nat).

(* *Initial* states *)
Inductive fact_init (original_input : nat) : fact_state -> Prop :=
| FactInit : fact_init original_input (WithAccumulator original_input 1).

(** *Final* states *)
Inductive fact_final : fact_state -> Prop :=
| FactFinal : forall ans, fact_final (AnswerIs ans).

(** The most important part: the relation to step between states *)
Inductive fact_step : fact_state -> fact_state -> Prop :=
| FactDone : forall acc,
  fact_step (WithAccumulator O acc) (AnswerIs acc)
| FactStep : forall n acc,
  fact_step (WithAccumulator (S n) acc) (WithAccumulator n (acc * S n)).

(* We care about more than just single steps.  We want to run factorial to
 * completion, for which it is handy to define a general relation of
 * *transitive-reflexive closure*, like so. *)
Inductive trc {A} (R : A -> A -> Prop) : A -> A -> Prop :=
| TrcRefl : forall x, trc R x x
| TrcFront : forall x y z,
  R x y
  -> trc R y z
  -> trc R x z.

(* Transitive-reflexive closure is so common that it deserves a shorthand notation! *)
Set Warnings "-notation-overridden". (* <-- needed while we play with defining one
                                      * of the book's notations ourselves locally *)
Notation "R ^*" := (trc R) (at level 0).

(* Now let's use it to execute the factorial program. *)
Example factorial_3 : fact_step^* (WithAccumulator 3 1) (AnswerIs 6).
Proof.
Admitted.

(* It will be useful to give state machines more first-class status, as
 * *transition systems*, formalized by this record type.  It has one type
 * parameter, [state], which records the type of states. *)
Record trsys state := {
  Initial : state -> Prop;
  Step : state -> state -> Prop
}.

(* The example of our factorial program: *)
Definition factorial_sys (original_input : nat) : trsys fact_state := {|
  Initial := fact_init original_input;
  Step := fact_step
|}.

(* A useful general notion for transition systems: reachable states *)
Inductive reachable {state} (sys : trsys state) (st : state) : Prop :=
| Reachable : forall st0,
  sys.(Initial) st0
  -> sys.(Step)^* st0 st
  -> reachable sys st.

(* To prove that our state machine is correct, we rely on the crucial technique
 * of *invariants*.  What is an invariant?  Here's a general definition, in
 * terms of an arbitrary transition system. *)
Definition invariantFor {state} (sys : trsys state) (invariant : state -> Prop) :=
  forall s, sys.(Initial) s
            -> forall s', sys.(Step)^* s s'
                          -> invariant s'.
(* That is, when we begin in an initial state and take any number of steps, the
 * place we wind up always satisfies the invariant. *)

(* Here's a simple lemma to help us apply an invariant usefully,
 * really just restating the definition. *)
Lemma use_invariant' : forall {state} (sys : trsys state)
  (invariant : state -> Prop) s s',
  invariantFor sys invariant
  -> sys.(Initial) s
  -> sys.(Step)^* s s'
  -> invariant s'.
Proof.
  unfold invariantFor.
  simplify.
  eapply H.
  eassumption.
  assumption.
Qed.

Theorem use_invariant : forall {state} (sys : trsys state)
  (invariant : state -> Prop) s,
  invariantFor sys invariant
  -> reachable sys s
  -> invariant s.
Proof.
  simplify.
  invert H0.
  eapply use_invariant'.
  eassumption.
  eassumption.
  assumption.
Qed.

(* What's the most fundamental way to establish an invariant?  Induction! *)
Lemma invariant_induction' : forall {state} (sys : trsys state)
  (invariant : state -> Prop),
  (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
  -> forall s s', sys.(Step)^* s s'
     -> invariant s
     -> invariant s'.
Proof.
  induct 2; propositional.
  (* [propositional]: simplify the goal according to the rules of propositional
   *   logic. *)

  apply IHtrc.
  eapply H.
  eassumption.
  assumption.
Qed.

Theorem invariant_induction : forall {state} (sys : trsys state)
  (invariant : state -> Prop),
  (forall s, sys.(Initial) s -> invariant s)
  -> (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
  -> invariantFor sys invariant.
Proof.
  unfold invariantFor; intros.
  eapply invariant_induction'.
  eassumption.
  eassumption.
  apply H.
  assumption.
Qed.

Definition fact_invariant (original_input : nat) (st : fact_state) : Prop :=
  True.
(* We must fill in a better invariant. *)

Theorem fact_invariant_ok : forall original_input,
  invariantFor (factorial_sys original_input) (fact_invariant original_input).
Proof.
Admitted.

(* Therefore, every reachable state satisfies this invariant. *)
Theorem fact_invariant_always : forall original_input s,
  reachable (factorial_sys original_input) s
  -> fact_invariant original_input s.
Proof.
  simplify.
  eapply use_invariant.
  apply fact_invariant_ok.
  assumption.
Qed.

(* Therefore, any final state has the right answer! *)
Lemma fact_ok' : forall original_input s,
  fact_final s
  -> fact_invariant original_input s
  -> s = AnswerIs (fact original_input).
Admitted.

Theorem fact_ok : forall original_input s,
  reachable (factorial_sys original_input) s
  -> fact_final s
  -> s = AnswerIs (fact original_input).
Proof.
  simplify.
  apply fact_ok'.
  assumption.
  apply fact_invariant_always.
  assumption.
Qed.

(** * A simple example of another program as a state transition system *)

(* We'll formalize this pseudocode for one thread of a concurrent, shared-memory program.
  lock();
  local = global;
  global = local + 1;
  unlock();
*)

(* This inductive state effectively encodes all possible combinations of two
 * kinds of *local*state* in a thread:
 * - program counter
 * - values of local variables that may be read eventually *)
Inductive increment_program :=
| Lock
| Read
| Write (local : nat)
| Unlock
| Done.

(* Next, a type for state shared between threads. *)
Record inc_state := {
  Locked : bool; (* Does a thread hold the lock? *)
  Global : nat   (* A shared counter *)
}.

(* The combined state, from one thread's perspective, using a general
 * definition. *)
Record threaded_state shared private := {
  Shared : shared;
  Private : private
}.

Definition increment_state := threaded_state inc_state increment_program.

(* Now a routine definition of the three key relations of a transition system.
 * The most interesting logic surrounds saving the counter value in the local
 * state after reading. *)

Inductive increment_init : increment_state -> Prop :=
| IncInit :
  increment_init {| Shared := {| Locked := false; Global := O |};
                    Private := Lock |}.

Inductive increment_step : increment_state -> increment_state -> Prop :=
| IncLock : forall g,
  increment_step {| Shared := {| Locked := false; Global := g |};
                    Private := Lock |}
                 {| Shared := {| Locked := true; Global := g |};
                    Private := Read |}
| IncRead : forall l g,
  increment_step {| Shared := {| Locked := l; Global := g |};
                    Private := Read |}
                 {| Shared := {| Locked := l; Global := g |};
                    Private := Write g |}
| IncWrite : forall l g v,
  increment_step {| Shared := {| Locked := l; Global := g |};
                    Private := Write v |}
                 {| Shared := {| Locked := l; Global := S v |};
                    Private := Unlock |}
| IncUnlock : forall l g,
  increment_step {| Shared := {| Locked := l; Global := g |};
                    Private := Unlock |}
                 {| Shared := {| Locked := false; Global := g |};
                    Private := Done |}.

Definition increment_sys := {|
  Initial := increment_init;
  Step := increment_step
|}.

(** * Running transition systems in parallel *)

(* That last example system is a cop-out: it only runs a single thread.  We want
 * to run several threads in parallel, sharing the global state.  Here's how we
 * can do it for just two threads.  The key idea is that, while in the new
 * system the type of shared state remains the same, we take the Cartesian
 * product of the sets of private state. *)

Inductive parallel_init shared private1 private2
  (init1 : threaded_state shared private1 -> Prop)
  (init2 : threaded_state shared private2 -> Prop)
  : threaded_state shared (private1 * private2) -> Prop :=
| Pinit : forall sh pr1 pr2,
  init1 {| Shared := sh; Private := pr1 |}
  -> init2 {| Shared := sh; Private := pr2 |}
  -> parallel_init init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.

Inductive parallel_step shared private1 private2
          (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
          (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
          : threaded_state shared (private1 * private2)
            -> threaded_state shared (private1 * private2) -> Prop :=
| Pstep1 : forall sh pr1 pr2 sh' pr1',
  (* First thread gets to run. *)
  step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
  -> parallel_step step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1', pr2) |}
| Pstep2 : forall sh pr1 pr2 sh' pr2',
  (* Second thread gets to run. *)
  step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
  -> parallel_step step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1, pr2') |}.

Definition parallel shared private1 private2
           (sys1 : trsys (threaded_state shared private1))
           (sys2 : trsys (threaded_state shared private2)) := {|
  Initial := parallel_init sys1.(Initial) sys2.(Initial);
  Step := parallel_step sys1.(Step) sys2.(Step)
|}.

(* Example: composing two threads of the kind we formalized earlier *)
Definition increment2_sys := parallel increment_sys increment_sys.

(* Let's prove that the counter is always 2 when the composed program terminates. *)

(** We must write an invariant. *)
Inductive increment2_invariant :
  threaded_state inc_state (increment_program * increment_program) -> Prop :=
| Inc2Inv : forall sh pr1 pr2,
  increment2_invariant {| Shared := sh; Private := (pr1, pr2) |}.
(* This isn't it yet! *)

(* Now, to show it really is an invariant. *)
Theorem increment2_invariant_ok : invariantFor increment2_sys increment2_invariant.
Proof.
Admitted.

(* Now, to prove our final result about the two incrementing threads, let's use
 * a more general fact, about when one invariant implies another. *)
Theorem invariant_weaken : forall {state} (sys : trsys state)
  (invariant1 invariant2 : state -> Prop),
  invariantFor sys invariant1
  -> (forall s, invariant1 s -> invariant2 s)
  -> invariantFor sys invariant2.
Proof.
  unfold invariantFor; simplify.
  apply H0.
  eapply H.
  eassumption.
  assumption.
Qed.

(* Here's another, much weaker invariant, corresponding exactly to the overall
 * correctness property we want to establish for this system. *)
Definition increment2_right_answer
  (s : threaded_state inc_state (increment_program * increment_program)) :=
  s.(Private) = (Done, Done)
  -> s.(Shared).(Global) = 2.

(** Now we can prove that the system only runs to happy states. *)
Theorem increment2_sys_correct : forall s,
  reachable increment2_sys s
  -> increment2_right_answer s.
Proof.
Admitted.
(*simplify.
  eapply use_invariant.
  apply invariant_weaken with (invariant1 := increment2_invariant).
  (* Note the use of a [with] clause to specify a quantified variable's
   * value. *)

  apply increment2_invariant_ok.

  simplify.
  invert H0.
  unfold increment2_right_answer; simplify.
  invert H0.
  (* Here we use inversion on an equality, to derive more primitive
   * equalities. *)
  simplify.
  equality.

  assumption.
Qed.*)


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2019   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require BuiltIn.
Require real.Real.

Import R_sqrt.

(* Why3 goal *)
Lemma sqr_def :
  forall (x:Reals.Rdefinitions.R), ((Reals.RIneq.Rsqr x) = (x * x)%R).
reflexivity.
Qed.

(* Why3 comment *)
(* sqrt is replaced with (Reals.R_sqrt.sqrt x) by the coq driver *)

(* Why3 goal *)
Lemma Sqrt_positive :
  forall (x:Reals.Rdefinitions.R), (0%R <= x)%R ->
  (0%R <= (Reals.R_sqrt.sqrt x))%R.
intros x _.
apply sqrt_pos.
Qed.

(* Why3 goal *)
Lemma Sqrt_square :
  forall (x:Reals.Rdefinitions.R), (0%R <= x)%R ->
  ((Reals.RIneq.Rsqr (Reals.R_sqrt.sqrt x)) = x).
exact sqrt_sqrt.
Qed.

(* Why3 goal *)
Lemma Square_sqrt :
  forall (x:Reals.Rdefinitions.R), (0%R <= x)%R ->
  ((Reals.R_sqrt.sqrt (x * x)%R) = x).
exact sqrt_square.
Qed.

(* Why3 goal *)
Lemma Sqrt_mul :
  forall (x:Reals.Rdefinitions.R) (y:Reals.Rdefinitions.R),
  (0%R <= x)%R /\ (0%R <= y)%R ->
  ((Reals.R_sqrt.sqrt (x * y)%R) =
   ((Reals.R_sqrt.sqrt x) * (Reals.R_sqrt.sqrt y))%R).
intros x y (hx & hy); now apply sqrt_mult.
Qed.

(* Why3 goal *)
Lemma Sqrt_le :
  forall (x:Reals.Rdefinitions.R) (y:Reals.Rdefinitions.R),
  (0%R <= x)%R /\ (x <= y)%R ->
  ((Reals.R_sqrt.sqrt x) <= (Reals.R_sqrt.sqrt y))%R.
intros x y (h1 & h2); apply sqrt_le_1; auto.
apply Rle_trans with x; auto.
Qed.


Section Ejercicio1.

Variable U  : Set.
Variable A B: U -> Prop.
Variable P Q: Prop.
Variable R S: U -> U -> Prop.

Theorem e11 : (forall x:U, A(x)) -> forall y:U, A(y).
Proof.
auto.
Qed.

Theorem e12 : (forall x y:U, (R x y)) -> forall x y:U, (R y x).
Proof.
auto.
Qed.

Theorem e13 : (forall x: U, ((A x)->(B x)))
                        -> (forall y:U, (A y))
                          -> (forall z:U, (B z)).
Proof.
auto.
Qed.

End Ejercicio1.

Section Ejercicio2.

Variable U  : Set.
Variable A B: U -> Prop.
Variable P Q: Prop.
Variable R S: U -> U -> Prop.

Theorem e21 : (forall x:U, ((A x)-> ~(forall x:U, ~ (A x)))).
Proof.
intros.
unfold not.
intro.
apply (H0 x).
assumption.
Qed.

Theorem e22 : (forall x y:U, ((R x y)))-> (forall x:U, (R x x)).
Proof.
intros.
apply (H x x).
Qed.

Theorem e23 : (forall x:U, ((P -> (A x))))
                        -> (P -> (forall x: U, (A x))).
Proof.
intros.
apply (H x).
assumption.
Qed.

Theorem e24 : (forall x:U, ((A x) /\ (B x)))
                        -> (forall x:U, (A x))
                          -> (forall x:U, (B x)).
Proof.
intros.
apply (H x).
Qed.

End Ejercicio2.

Section Ejercicio3.

Variable U   : Set.
Variable A B : U -> Prop.
Variable P Q : Prop.
Variable R S : U -> U -> Prop.

Hypothesis H1: forall x:U, (R x x).
Hypothesis H2: forall x y z:U, (R x y) /\ (R x z) -> (R y z).

Theorem reflexiva: forall x : U, R x x.
Proof.
auto.
Qed.

Theorem simetrica: forall x y : U, R x y -> R y x.
Proof.
intros.
apply (H2 x y x).
split; [ assumption | trivial ].
Qed.

Theorem transitiva: forall x y z : U, R x y /\ R y z -> R x z.
Proof.
intros.
apply (H2 y x z).
split; [ apply simetrica | idtac ]; elim H; auto.
Qed.

End Ejercicio3.

Section Ejercicio4.

Variable U : Set.
Variable A : U->Prop.
Variable R : U->U->Prop.

Theorem e41: (exists x:U, exists y:U, (R x y)) -> exists y:U, exists x:U, (R x y).
Proof.
intros.
elim H.
intros.
elim H0.
intros.
exists x0.
exists x.
assumption.
Qed.

Theorem e42: (forall x:U, A(x)) -> ~ exists x:U, ~ A(x).
Proof.
unfold not.
intros.
elim H0.
intros.
apply (H1 (H x)).
Qed.

Theorem e43: (exists x:U, ~(A x)) -> ~(forall x:U, (A x)).
Proof.
unfold not.
intros.
elim H.
intros.
apply (H1 (H0 x)).
Qed.

End Ejercicio4.

Section Ejercicio5.

Variable nat      : Set.
Variable S        : nat -> nat.
Variable a b c    : nat.
Variable odd even : nat -> Prop.
Variable P Q      : nat -> Prop.
Variable f        : nat -> nat.

Theorem e51: forall x:nat, exists y:nat, (P(x)->P(y)).
Proof.
intros.
exists x.
trivial.
Qed.

Theorem e52: exists x:nat, (P x)
                            -> (forall y:nat, (P y)->(Q y))
                               -> (exists z:nat, (Q z)).
Proof.
exists a.
intros.
exists a.
apply ((H0 a) H).
Qed.

Theorem e53: even(a) -> (forall x:nat, (even(x)->odd (S(x)))) -> exists y: nat, odd(y).
Proof.
intros.
exists (S a).
apply ((H0 a) H).
Qed.

Theorem e54: (forall x:nat, P(x) /\ odd(x) ->even(f(x)))
                            -> (forall x:nat, even(x)->odd(S(x)))
                            -> even(a)
                            -> P(S(a))
                            -> exists z:nat, even(f(z)).
Proof.
intros.
exists (S a).
apply (H (S a)).
split; [ idtac | apply (H0 a)]; assumption.
Qed.

End Ejercicio5.

Section Ejercicio6.

Variable nat : Set.
Variable S   : nat -> nat.
Variable le  : nat -> nat -> Prop.
Variable f   : nat -> nat.
Variable P   : nat -> Prop.

Axiom le_n: forall n:nat, (le n n).
Axiom le_S: forall n m:nat, (le n m) -> (le n (S m)).
Axiom monoticity: forall n m:nat, (le n m) -> (le (f n) (f m)).

Lemma le_x_Sx: forall x:nat, (le x (S x)).
Proof.
intro.
apply le_S.
apply le_n.
Qed.

Lemma le_x_SSx: forall x:nat, (le x (S (S x))).
Proof.
intro.
apply le_S.
apply le_x_Sx.
Qed.

Theorem T1_1: forall a:nat, exists b:nat, (le (f a) b).
Proof.
intros.
exists (f a).
apply monoticity.
apply le_n.
Qed.

Theorem T1_2: forall a:nat, exists b:nat, (le (f a) b).
Proof.
intros.
exists (f (S a)).
apply monoticity.
apply le_x_Sx.
Qed.

Theorem T1_3: forall a:nat, exists b:nat, (le (f a) b).
Proof.
intros.
exists (f (S (S a))).
apply monoticity.
apply le_x_SSx.
Qed.

Theorem T1_a: forall a:nat, exists b:nat, (le (f a) b).
Proof.
intros.
exists ((S (S (S (S (S (f a))))))).
repeat apply le_S.
apply le_n.
Qed.

Theorem T1_b: forall a:nat, exists b:nat, (le (f a) b).
Proof.
intros.
exists ((S (S (S (S (S (f a))))))).
do 5 apply le_S.
apply le_n.
Qed.

End Ejercicio6.

Section Ejercicio7.

Variable U   : Set.
Variable A B : U -> Prop.

Theorem e71: (forall x:U, ((A x) /\ (B x)))
                       -> (forall x:U, (A x)) /\ (forall x:U, (B x)).
Proof.
intro; split; intro num; apply (H num).
Qed.

Theorem e72: (exists x:U, (A x \/ B x))->(exists x:U, A x )\/(exists x:U, B x).
Proof.
intro; elim H; intros; elim H0; intro; [left | right]; exists x; assumption.
Qed.

End Ejercicio7.

Section Ejercicio8.

Variable U  : Set.

Variable R : U -> U -> Prop.
Variable T : U -> Prop.
Variable V : U -> Prop.

Theorem ej8_1 : (exists y : U, forall x : U, R x y) -> (forall x : U, exists y : U, R x y).
Proof.
intros.
elim H.
intros.
exists x0.
apply (H0 x).
Qed.

Theorem ej8_2: (exists y:U, True)/\(forall x:U, (T x) \/ (V x)) ->
(exists z:U, (T z)) \/ (exists w:U, (V w)).
Proof.
intros.
apply e72.
elim H.
intros.
elim H0.
intros.
exists x.
trivial.
Qed.

(**
  En la siguiente demostración pruebo que (exists y:U, True) es condición necesaria
  para demostrar el teorema de arriba.
**)
Theorem ej8_3: (exists z:U, (T z)) \/ (exists w:U, (V w)) -> (exists y:U, True).
Proof.
intros.
elim H; intro; elim H0; intros; exists x; trivial.
Qed.

End Ejercicio8.

Section Ejercicio9.
Require Import Classical.
Variables U : Set.
Variables A : U -> Prop.

Lemma not_ex_not_forall: (~exists x :U, ~A x) -> (forall x:U, A x).
Proof.
unfold not.
intros.
elim (classic (A x));intro; [ | elim H; exists x ]; assumption.
Qed.

Lemma not_forall_ex_not: (~forall x :U, A x) -> (exists x:U,  ~A x).
Proof.
unfold not.
intros.
elim (classic (exists x : U, not (A x))); [ trivial | intro ].
assert (forall x:U, A x); [ apply not_ex_not_forall | elim H ]; assumption.
Qed.

End Ejercicio9.

Section Ejercicio10y11.

Variable nat : Set.
Variable  O  : nat.
Variable  S  : nat -> nat.

Axiom disc   : forall n:nat, ~O=(S n).
Axiom inj    : forall n m:nat, (S n)=(S m) -> n=m.

Variable sum prod : nat->nat->nat.
Axiom sum0   : forall n :nat, (sum n O)=n.
Axiom sumS   : forall n m :nat, (sum n (S m))=(S (sum n m)).
Axiom prod0  : forall n :nat, (prod n O)=O.
Axiom prodS  : forall n m :nat, (prod n (S m))=(sum n (prod n m)).

Lemma L10_1: (sum (S O) (S O)) = (S (S O)).
Proof.
rewrite sumS.
rewrite sum0.
reflexivity.
Qed.

Lemma L10_2: forall n :nat, ~(O=n /\ (exists m :nat, n = (S m))).
Proof.
unfold not.
intros.
elim H.
intros.
elim H1.
rewrite <- H0.
apply disc.
Qed.

Lemma prod_neutro: forall n :nat, (prod n (S O)) = n.
Proof.
intros.
rewrite prodS.
rewrite prod0.
apply sum0.
Qed.

Lemma diff: forall n:nat, ~(S (S n))=(S O).
Proof.
unfold not.
intros.
cut (O = S n); [ apply disc | symmetry; apply inj; assumption ].
Qed.

Axiom induccion: forall (P : nat -> Prop) , P O -> (forall x , P
x -> P (S x)) -> forall x , P x .

Variable le : nat->nat->Prop.
Axiom leinv: forall n m:nat, (le n m) -> n=O \/
      (exists p:nat, (exists q:nat, n=(S p)/\ m=(S q) /\ (le p q))).

Lemma notle_s_o: forall n:nat, ~(le (S n) O).
Proof.
unfold not.
intros.
elim (leinv (S n) O); intros;
  [ apply (disc n); auto
  | elim H0;
    intros;
    elim H1;
    intros;
    elim H2;
    elim (disc x0);
    elim H2;
    intros;
    elim H4;
    trivial
  | assumption].
Qed.

End Ejercicio10y11.


(** 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 :=
| Zero : natural
| Succ : natural -> natural.

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) : natural := plus (Succ lf2) Zero.


(* fields *)

(*
Set Implicit Arguments.
*)

Require Import Utf8.
Require Import Semiring.

Class field_op T :=
  { fld_inv : T → T }.

Definition fld_div T {fo : field_op T} {so : semiring_op T} a b :=
  srng_mul a (fld_inv b).

Declare Scope field_scope.

Delimit Scope field_scope with F.
Notation "0" := (@srng_zero _ _) : field_scope.
Notation "1" := (@srng_one _ _) : field_scope.
Notation "- a" := (@rng_opp _ _ a) : field_scope.
Notation "/ a" := (@fld_inv _ _ a) : field_scope.
Notation "a + b" := (@srng_add _ _ a b) : field_scope.
Notation "a - b" := (@rng_sub _ _ _ a b) : field_scope.
Notation "a * b" := (@srng_mul _ _ a b) : field_scope.
Notation "a / b" := (@fld_div _ _ _ a b) : field_scope.

Class field_prop A {so : semiring_op A} {fo : field_op A} :=
  { fld_mul_inv_l : ∀ a : A, a ≠ 0%F → (/ a * a = 1)%F }.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Compare_dec.
Import ListNotations.
Set Implicit Arguments.

Inductive Regex (n : Set) :=
 | Elem  : n -> Regex n
 | Empty :      Regex n
 | Seq   :      Regex n -> Regex n -> Regex n
 | Alt   :      Regex n -> Regex n -> Regex n
 | Star  :      Regex n -> Regex n
 .

Inductive Match (n : Set) : Regex n -> list n -> Prop :=
 | MElem  : forall e:n, Match (Elem e)  [e]
 | MEmpty :             Match (Empty _) []

 | MSeq   : forall r1 r2 l1 l2,
            Match r1 l1
         -> Match r2 l2
         -> Match (Seq r1 r2) (l1 ++ l2)

 | MAlt_L : forall r1 r2 l,
            Match r1 l
         -> Match (Alt r1 r2) l
 | MAlt_R : forall r1 r2 l,
            Match r2 l
         -> Match (Alt r1 r2) l

 | MStar_0: forall r,
            Match (Star r) []
 | MStar_1: forall r l l',
            Match r l
         -> Match (Star r) l'
         -> Match (Star r) (l ++ l')
 .

Definition RegexEq (n : Set) (r1 r2 : Regex n) :=
  forall l, Match r1 l -> Match r2 l
   /\       Match r2 l -> Match r1 l.

(* I promise! *)
Axiom RegexEq_dec : forall (n : Set) (r1 r2 : Regex n), RegexEq r1 r2 \/ ~ RegexEq r1 r2.

Check filter.

Fixpoint filterRx (A : Set) (f : A -> bool) (rx : Regex A) :=
 match rx with
 | Empty => Empty _
 | Elem n => if f n then Elem n else Empty _
 | Seq p q => Seq (filterRx f p) (filterRx f q)
 | Alt p q => Alt (filterRx f p) (filterRx f q)
 | Star p  => Star (filterRx f p)
 end.

Theorem filter_app_dist (A : Set) (f : A -> bool) (a b : list A) :
   filter f (a ++ b) = filter f a ++ filter f b.
Proof.
 induction a; simpl;
   try destruct (f a);
   try rewrite IHa;
   eauto.
Qed.

Theorem filter_same (A : Set) (f : A -> bool) (rx : Regex A) (w : list A) :
 Match rx w -> Match (filterRx f rx) (filter f w).
Proof.
 intros.
 induction H; eauto; simpl;
  try rewrite filter_app_dist;
  try (destruct (f e));
  try solve [constructor; eauto];
  eauto.

 apply MAlt_R; eauto.
Qed.


Require Import init.

Require Export ord_order.
Require Import ord_plus.
Require Import ord_mult.
Require Import set.
Require Import nat.

Theorem transfinite_induction :
    ∀ S : ord → Prop, (∀ α, (∀ β, β < α → S β) → S α) → ∀ α, S α.
Proof.
    intros S S_all α.
    classic_contradiction contr.
    pose (S' α := ¬S α).
    assert (∃ β, S' β) as S'_nempty by (exists α; exact contr).
    pose proof (well_ordered S' S'_nempty) as [β [S'β β_min]].
    apply S'β.
    apply S_all.
    intros γ γ_lt.
    classic_contradiction S'γ.
    specialize (β_min _ S'γ).
    destruct (lt_le_trans γ_lt β_min); contradiction.
Qed.

Definition suc_ord α := ∃ β, α = β + 1.
Definition lim_ord α := 0 ≠ α ∧ ¬suc_ord α.

Theorem transfinite_induction2 :
    ∀ S : ord → Prop,
    (∀ α, suc_ord α → (∀ β, β < α → S β) → S α) →
    (∀ α, ¬suc_ord α → (∀ β, β < α → S β) → S α) →
    ∀ α, S α.
Proof.
    intros S sucs lims α.
    induction α using transfinite_induction.
    classic_case (suc_ord α).
    -   apply sucs; assumption.
    -   apply lims; assumption.
Qed.

Theorem transfinite_induction3 :
    ∀ S : ord → Prop,
    S 0 →
    (∀ α, suc_ord α → (∀ β, β < α → S β) → S α) →
    (∀ α, lim_ord α → (∀ β, β < α → S β) → S α) →
    ∀ α, S α.
Proof.
    intros S S0 sucs lims α.
    induction α using transfinite_induction2.
    -   apply sucs; assumption.
    -   classic_case (0 = α) as [eq|neq].
        +   rewrite <- eq.
            exact S0.
        +   apply lims; try assumption.
            split; assumption.
Qed.

Theorem ord_lt_plus1 : ∀ α, α < α + 1.
Proof.
    intros α.
    apply ord_lt_self_rplus.
    apply ord_not_trivial.
Qed.