(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2021 Sylvie Boldo
#<br />#
Copyright (C) 2010-2021 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Helper function and theorem for computing the rounded sum of two floating-point numbers. *)

From Coq Require Import ZArith Reals Lia.

Require Import Core Bracket Operations Round.

Section Plus.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { monotone_exp : Monotone_exp fexp }.

Definition Fplus_core m1 e1 m2 e2 e :=
  let k := (e - e2)%Z in
  let '(m2', _, l) :=
    if Zlt_bool 0 k then truncate_aux beta (m2, e2, loc_Exact) k
    else (m2 * Zpower beta (-k), e, loc_Exact)%Z in
  let m1' := (m1 * Zpower beta (e1 - e))%Z in
  (m1' + m2', l)%Z.

Theorem Fplus_core_correct :
  forall m1 e1 m2 e2 e,
  (e <= e1)%Z ->
  let '(m, l) := Fplus_core m1 e1 m2 e2 e in
  inbetween_float beta m e (F2R (Float beta m1 e1) + F2R (Float beta m2 e2)) l.
Proof.
intros m1 e1 m2 e2 e He1.
unfold Fplus_core.
case Zlt_bool_spec ; intros He2.
- unfold truncate_aux.
  unfold inbetween_float, F2R. simpl.
  rewrite 3!plus_IZR.
  rewrite Rplus_assoc.
  rewrite 2!Rmult_plus_distr_r.
  replace (IZR (m1 * Zpower beta (e1 - e)) * bpow e)%R with (IZR m1 * bpow e1)%R.
  2: {
    rewrite mult_IZR, IZR_Zpower by lia.
    rewrite Rmult_assoc, <- bpow_plus.
    apply (f_equal (fun v => IZR m1 * bpow v)%R).
    ring.
  }
  rewrite <- 3!(Rplus_comm _ (IZR m1 * bpow e1)).
  apply inbetween_plus_compat.
  set (k := (e - e2)%Z).
  rewrite <- (plus_IZR _ 1).
  replace e with (e2 + k)%Z by (unfold k ; ring).
  apply inbetween_float_new_location.
  exact He2.
  now constructor 1.
- constructor 1.
  unfold F2R. simpl.
  rewrite plus_IZR, Rmult_plus_distr_r.
  rewrite 2!mult_IZR, 2!IZR_Zpower by lia.
  rewrite 2!Rmult_assoc, <- 2!bpow_plus.
  apply (f_equal2 (fun v w => IZR m1 * bpow v + IZR m2 * bpow w)%R) ; ring.
Qed.

Definition Fplus (f1 f2 : float beta) :=
  let (m1, e1) := f1 in
  let (m2, e2) := f2 in
  if Zeq_bool m1 0 then
    (m2, e2, loc_Exact)
  else if Zeq_bool m2 0 then
    (m1, e1, loc_Exact)
  else
  let p1 := (Zdigits beta m1 + e1)%Z in
  let p2 := (Zdigits beta m2 + e2)%Z in
  if Zle_bool 2 (Z.abs (p1 - p2)) then
    let e := Z.min (Z.max e1 e2) (fexp (Z.max p1 p2 - 1)) in
    let (m, l) :=
      if Zlt_bool e1 e then
        Fplus_core m2 e2 m1 e1 e
      else
        Fplus_core m1 e1 m2 e2 e in
    (m, e, l)
  else
    let (m, e) := Fplus f1 f2 in
    (m, e, loc_Exact).

Theorem Fplus_correct :
  forall x y,
  let '(m, e, l) := Fplus x y in
  (l = loc_Exact \/ e <= cexp beta fexp (F2R x + F2R y))%Z /\
  inbetween_float beta m e (F2R x + F2R y) l.
Proof.
intros [m1 e1] [m2 e2].
unfold Fplus.
case Zeq_bool_spec ; intros Hm1.
{ rewrite Hm1.
  split.
  now left.
  rewrite F2R_0, Rplus_0_l.
  now constructor 1. }
case Zeq_bool_spec ; intros Hm2.
{ rewrite Hm2.
  split.
  now left.
  rewrite F2R_0, Rplus_0_r.
  now constructor 1. }
set (p1 := (Zdigits beta m1 + e1)%Z).
set (p2 := (Zdigits beta m2 + e2)%Z).
set (e := Z.min (Z.max e1 e2) (fexp (Z.max p1 p2 - 1))).
case Zle_bool_spec ; intros Hp ; cycle 1.
{ rewrite <- F2R_plus.
  destruct Operations.Fplus as [m' e'].
  split.
  now left.
  now constructor 1. }
set (z := (F2R _ + F2R _)%R).
assert (Hz: (e <= cexp beta fexp z)%Z).
{ apply Z.le_trans with (fexp (Z.max p1 p2 - 1)).
  apply Z.le_min_r.
  unfold cexp.
  apply monotone_exp.
  unfold z.
  revert Hp.
  unfold p1, p2.
  rewrite <- 2!mag_F2R_Zdigits by easy.
  clear -Hm1 Hm2.
  destruct (Zle_or_lt (mag beta (F2R (Float beta m1 e1))) (mag beta (F2R (Float beta m2 e2)))) as [Hp'|Hp'].
  - rewrite Z.max_r by easy.
    rewrite Z.abs_neq by (clear -Hp'; lia).
    rewrite Rplus_comm.
    intros H.
    apply mag_plus_ge.
    now apply F2R_neq_0.
    clear -H ; lia.
  - rewrite Z.max_l, Z.abs_eq by (clear -Hp'; lia).
    intros H.
    apply mag_plus_ge.
    now apply F2R_neq_0.
    clear -H ; lia. }
case Zlt_bool_spec ; intros He.
- assert (He': (e <= e2)%Z) by (clear -He ; lia).
  generalize (Fplus_core_correct m2 e2 m1 e1 e He').
  rewrite Rplus_comm.
  fold z.
  destruct Fplus_core as [m' l].
  refine (fun H => conj _ H).
  now right.
- assert (He': (e <= e1)%Z) by (clear -He ; lia).
  generalize (Fplus_core_correct m1 e1 m2 e2 e He').
  fold z.
  destruct Fplus_core as [m' l].
  refine (fun H => conj _ H).
  now right.
Qed.

End Plus.


Require Export Iron.Language.SystemF2Store.ExpBase.
Require Export Iron.Language.SystemF2Store.ExpAlt.

(********************************************************************)
(* Lift type indices in expressions. *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx
  |  XLoc _     => xx

  |  XLAM x
  => XLAM (liftTX (S d) x)

  |  XAPP x t
  => XAPP (liftTX d x)  (liftTT 1 d t)

  |  XLam t x
  => XLam (liftTT 1 d t)  (liftTX d x)

  |  XApp x1 x2
  => XApp (liftTX d x1) (liftTX d x2)

  |  XCon dc ts xs
  => XCon dc (map (liftTT 1 d) ts) (map (liftTX d) xs)

  |  XCase xx alts
  => XCase (liftTX d xx) (map (liftTA d) alts)

  |  XUpdate c i ts x1 x2
  => XUpdate c i (map (liftTT 1 d) ts) (liftTX d x1) (liftTX d x2)

 end

 with liftTA (d: nat) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (liftTX d xx)
  end.

(********************************************************************)
(* Lift expression indices in expressions *)
Fixpoint liftXX (n:  nat) (d:  nat) (xx: exp) {struct xx} : exp :=
 match xx with
    |  XVar ix
    => if le_gt_dec d ix
        (* index was pointing into env, lift it across new elems *)
        then XVar (ix + n)
        (* index was locally bound, leave it be *)
        else xx

    |  XLoc l
    => XLoc l

    |  XLAM x
    => XLAM (liftXX n d x)

    |  XAPP x t
    => XAPP (liftXX n d x) t

    (* increase the depth as we move across a lambda *)
    |  XLam t1 x1
    => XLam t1 (liftXX n (S d) x1)

    |  XApp x1 x2
    => XApp   (liftXX n d x1) (liftXX n d x2)

    (* lift all the arguments of a data constructor *)
    |  XCon dc ts xs
    => XCon dc ts (map (liftXX n d) xs)

    (* lift all the alternatives in a case-expression *)
    |  XCase x alts
    => XCase (liftXX n d x) (map (liftXA n d) alts)

    |  XUpdate c i ts x1 x2
    => XUpdate c i ts (liftXX n d x1) (liftXX n d x2)
    end

 with liftXA (n: nat) (d: nat) (aa: alt) {struct aa}:=
  match aa with
  (* When we enter into the right of an alternative, a new type
     is pushed onto the environment for each of the arguments
     of the data constructor. We need to increase the current
     binding depth by the number of arguments. *)
  |  AAlt (DataCon tag arity) x
  => AAlt (DataCon tag arity) (liftXX n (d + arity) x)
  end.

(* The data constructor of an alternative is unchanged
   by lifting. *)
Lemma dcOfAlt_liftXA
 : forall n d a
 , dcOfAlt (liftXA n d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftXA : global.

Lemma dcOfAlt_liftTA
 : forall d a
 , dcOfAlt (liftTA d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftTA : global.

Lemma dcOfAlt_liftTA_map
 :  forall ix aa
 ,  map dcOfAlt (map (liftTA ix) aa)
 =  map dcOfAlt aa.
Proof.
 intros. induction aa; simpl; burn.
Qed.
Hint Rewrite dcOfAlt_liftTA_map : global.

(* When we lift an expression by zero places,
   then the expression is unchanged. *)
Lemma liftXX_zero
 : forall d x
 , liftXX 0 d x = x.
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA 0 d a = a)
  ; intros; simpl; try burn.

 Case "XVar".
  lift_cases; burn.

 Case "XCon".
  nforall.
  rewrite (map_ext_in (liftXX 0 d) id); auto.
  rewrite map_id; auto.

 Case "XCase".
  nforall.
  rewrite (map_ext_in (liftXA 0 d) id); auto.
  rewrite map_id. burn.

 Case "XAlt".
  destruct dc. burn.
Qed.
Hint Rewrite liftXX_zero : global.

(* Commutivity of lifting. *)
Lemma liftXX_comm
 : forall n m x d
 , liftXX n d (liftXX m d x)
 = liftXX m d (liftXX n d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA n d (liftXA m d a)
      =  liftXA m d (liftXA n d a))
  ; intros; simpl; try burn.

 Case "XVar".
  repeat (simple; lift_cases; intros); burn.

 Case "XCon".
  f_equal. lists.
  nforall.
  rewrite (map_ext_in
   (fun x0 => liftXX n d (liftXX m d x0))
   (fun x0 => liftXX m d (liftXX n d x0))); burn.

 Case "XCase".
  f_equal. eauto.
  lists.
  nforall.
  rewrite (map_ext_in
   (fun a1 => liftXA n d (liftXA m d a1))
   (fun a1 => liftXA m d (liftXA n d a1))); burn.

 Case "XAlt".
  destruct dc. burn.
Qed.

(* When consecutively lifting an expression, we can lift by one
   more place in the first lifting and but one less in the second. *)
Lemma liftXX_succ
 : forall n m d x
 , liftXX (S n) d (liftXX m     d x)
 = liftXX n     d (liftXX (S m) d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA (S n) d (liftXA  m    d a)
      =  liftXA n     d (liftXA (S m) d a))
  ; intros; simpl; try burn.

 Case "XVar".
  repeat (simple; lift_cases; intros); burn.

 Case "XCon".
  f_equal. lists. nforall.
  rewrite (map_ext_in
   (fun x0 => liftXX (S n) d (liftXX m d x0))
   (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.

 Case "XCase".
  f_equal; auto. lists. nforall.
  rewrite (map_ext_in
   (fun x1 => liftXA (S n) d (liftXA m d x1))
   (fun x1 => liftXA n d (liftXA (S m) d x1))); burn.
  auto. auto.

 Case "XAlt".
  destruct dc; burn.
Qed.
Hint Rewrite liftXX_succ : global.

(* We can collapse two consecutive lifting expressions by lifting
   just onces by the sum of the places, provided the lifting
   occurs at depth zero.
   (TODO: we may be able to weaken this second requirement. *)
Lemma liftXX_plus
 : forall n m x
 , liftXX n 0 (liftXX m 0 x) = liftXX (n + m) 0 x.
Proof.
 intros. gen n.
 induction m; intros.
  burn.

  intros.
  rrwrite (n + S m = S n + m).
  rewrite liftXX_comm.
  rewrite <- IHm.
  rewrite liftXX_comm.
  burn.
Qed.


Require Import Pact.Data.Eq.

Generalizable All Variables.
Set Primitive Projections.

Inductive Ordering := LT | EQ | GT.

Class Ord (A : Type) `{Eq A} := {
  compare : A -> A -> Ordering;
  ltb : A -> A -> bool;
  lteb : A -> A -> bool;
  gtb : A -> A -> bool;
  gteb : A -> A -> bool;
  max : A -> A -> A;
  min : A -> A -> A
}.

Infix "<" := ltb (at level 70).
Infix "<=" := lteb (at level 70).
Infix ">" := gtb (at level 70).
Infix ">=" := gteb (at level 70).


Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import CUnit.All.
Require Conversion.

Require Case.
Require Char.
Require Conversion.
Require Etc.
Require Trim.

Import ListNotations.
Local Open Scope char.
Local Open Scope N.

Definition s := Conversion.s.

Module Case.
  Import ListString.Case.

  Definition test_capitalize :
    List.map ListString.Case.capitalize [s ""; s "A"; s "aAgZ,3%"] = [s ""; s "A"; s "AAgZ,3%"] :=
    eq_refl.

  Definition test_down_case :
    List.map down_case [s ""; s "aAgZ,3%"] = [s ""; s "aagz,3%"] :=
    eq_refl.

  Definition test_up_case :
    List.map up_case [s ""; s "aAgZ,3%"] = [s ""; s "AAGZ,3%"] :=
    eq_refl.
End Case.

Module Char.
  Import ListString.Char.

  Definition test_of_N :
    List.map of_N [0; 1; 5; 9; 10; 12; 23] =
      ["0"; "1"; "5"; "9"; "A"; "C" ; "N"] :=
    eq_refl.

  Definition test_to_N :
    List.map to_N ["0"; "1"; "5"; "9"; "A"; "C" ; "N"; "."] =
      [Some 0; Some 1; Some 5; Some 9; Some 10; Some 12; Some 23; None] :=
    eq_refl.

  Definition test_is_ascii :
    List.map is_ascii ["A"; "?"; """"; "010"; "127"; "128"; "255"] =
      [true; true; true; true; true; false; false] :=
      eq_refl.

  Definition test_is_white_space :
    List.map is_white_space [" "; "010"; "r"; ","] =
      [true; true; false; false] :=
      eq_refl.

  Definition test_down_case :
    List.map down_case ["a"; "A"; "g"; "Z"; ","; """"; "128"; "255"] =
      ["a"; "a"; "g"; "z"; ","; """"; "128"; "255"] :=
      eq_refl.

  Definition test_up_case :
    List.map up_case ["a"; "A"; "g"; "Z"; ","; """"; "128"; "255"] =
      ["A"; "A"; "G"; "Z"; ","; """"; "128"; "255"] :=
      eq_refl.
End Char.

Module Comparison.
  (* TODO *)
End Comparison.

Module Conversion.
  Import ListString.Conversion.

  Definition test_to_string :
    List.map to_string [
      [];
      ["h"; "e"; "l"; "l"; "o"]] = [
      "";
      "hello"] % string :=
    eq_refl.

  Definition test_of_string :
    List.map of_string [
      "";
      "hello"] % string = [
      [];
      ["h"; "e"; "l"; "l"; "o"]] :=
    eq_refl.

  Definition test_of_N :
    List.map_quad of_N [
      (10, 0%nat, None, 0);
      (10, 0%nat, None, 10);

      (2, 10%nat, None, 0);
      (2, 10%nat, None, 1);
      (2, 10%nat, None, 2);
      (2, 10%nat, None, 3);
      (2, 10%nat, None, 12);
      (2, 10%nat, None, 23);

      (8, 10%nat, None, 0);
      (8, 10%nat, None, 1);
      (8, 10%nat, None, 2);
      (8, 10%nat, None, 3);
      (8, 10%nat, None, 12);
      (8, 10%nat, None, 23);

      (10, 10%nat, None, 0);
      (10, 10%nat, None, 1);
      (10, 10%nat, None, 2);
      (10, 10%nat, None, 3);
      (10, 10%nat, None, 12);
      (10, 10%nat, None, 23);

      (16, 10%nat, None, 0);
      (16, 10%nat, None, 1);
      (16, 10%nat, None, 2);
      (16, 10%nat, None, 3);
      (16, 10%nat, None, 12);
      (16, 10%nat, None, 23);

      (2, 3%nat, None, 0);
      (2, 3%nat, None, 1);
      (2, 3%nat, None, 2);
      (2, 3%nat, None, 3);
      (2, 3%nat, None, 12);
      (2, 3%nat, None, 23);

      (10, 0%nat, Some "*", 0);
      (10, 0%nat, Some "*", 10);

      (2, 5%nat, Some "*", 0);
      (2, 5%nat, Some "*", 1);
      (2, 5%nat, Some "*", 2);
      (2, 5%nat, Some "*", 3);
      (2, 5%nat, Some "*", 12);
      (2, 5%nat, Some "*", 23);

      (8, 5%nat, Some "*", 0);
      (8, 5%nat, Some "*", 1);
      (8, 5%nat, Some "*", 2);
      (8, 5%nat, Some "*", 3);
      (8, 5%nat, Some "*", 12);
      (8, 5%nat, Some "*", 23);

      (10, 5%nat, Some "*", 0);
      (10, 5%nat, Some "*", 1);
      (10, 5%nat, Some "*", 2);
      (10, 5%nat, Some "*", 3);
      (10, 5%nat, Some "*", 12);
      (10, 5%nat, Some "*", 23);

      (16, 5%nat, Some "*", 0);
      (16, 5%nat, Some "*", 1);
      (16, 5%nat, Some "*", 2);
      (16, 5%nat, Some "*", 3);
      (16, 5%nat, Some "*", 12);
      (16, 5%nat, Some "*", 23);

      (2, 3%nat, Some "0", 0);
      (2, 3%nat, Some "0", 1);
      (2, 3%nat, Some "0", 2);
      (2, 3%nat, Some "0", 3);
      (2, 3%nat, Some "0", 12);
      (2, 3%nat, Some "0", 23)] = [
      s "";
      s "";

      s "0";
      s "1";
      s "10";
      s "11";
      s "1100";
      s "10111";

      s "0";
      s "1";
      s "2";
      s "3";
      s "14";
      s "27";

      s "0";
      s "1";
      s "2";
      s "3";
      s "12";
      s "23";

      s "0";
      s "1";
      s "2";
      s "3";
      s "C";
      s "17";

      s "0";
      s "1";
      s "10";
      s "11";
      s "100";
      s "111";

      s "";
      s "";

      s "****0";
      s "****1";
      s "***10";
      s "***11";
      s "*1100";
      s "10111";

      s "****0";
      s "****1";
      s "****2";
      s "****3";
      s "***14";
      s "***27";

      s "****0";
      s "****1";
      s "****2";
      s "****3";
      s "***12";
      s "***23";

      s "****0";
      s "****1";
      s "****2";
      s "****3";
      s "****C";
      s "***17";

      s "000";
      s "001";
      s "010";
      s "011";
      s "100";
      s "111"] :=
    eq_refl.

  Definition test_of_Z :
    List.map_triple of_Z [
      (2, 10%nat, 0%Z);
      (2, 10%nat, 1%Z);
      (2, 10%nat, 2%Z);
      (2, 10%nat, (-3)%Z);
      (2, 10%nat, (-12)%Z);
      (2, 10%nat, 23%Z);

      (8, 10%nat, 0%Z);
      (8, 10%nat, 1%Z);
      (8, 10%nat, 2%Z);
      (8, 10%nat, (-3)%Z);
      (8, 10%nat, (-12)%Z);
      (8, 10%nat, 23%Z);

      (10, 10%nat, 0%Z);
      (10, 10%nat, 1%Z);
      (10, 10%nat, 2%Z);
      (10, 10%nat, (-3)%Z);
      (10, 10%nat, (-12)%Z);
      (10, 10%nat, 23%Z);

      (16, 10%nat, 0%Z);
      (16, 10%nat, 1%Z);
      (16, 10%nat, 2%Z);
      (16, 10%nat, (-3)%Z);
      (16, 10%nat, (-12)%Z);
      (16, 10%nat, 23%Z);

      (2, 3%nat, 0%Z);
      (2, 3%nat, 1%Z);
      (2, 3%nat, 2%Z);
      (2, 3%nat, (-3)%Z);
      (2, 3%nat, (-12)%Z);
      (2, 3%nat, 23%Z)] = [
      s "0";
      s "1";
      s "10";
      s "-11";
      s "-1100";
      s "10111";

      s "0";
      s "1";
      s "2";
      s "-3";
      s "-14";
      s "27";

      s "0";
      s "1";
      s "2";
      s "-3";
      s "-12";
      s "23";

      s "0";
      s "1";
      s "2";
      s "-3";
      s "-C";
      s "17";

      s "0";
      s "1";
      s "10";
      s "-11";
      s "-100";
      s "111"] :=
    eq_refl.

  Definition test_to_N :
    List.map_pair to_N [
      (2, s "0");
      (2, s "1");
      (2, s "10");
      (2, s "11");
      (2, s "1100");
      (2, s "10111");

      (8, s "0");
      (8, s "1");
      (8, s "2");
      (8, s "3");
      (8, s "14");
      (8, s "27");

      (10, s "0");
      (10, s "1");
      (10, s "2");
      (10, s "3");
      (10, s "12");
      (10, s "23");

      (16, s "0");
      (16, s "1");
      (16, s "2");
      (16, s "3");
      (16, s "C");
      (16, s "17");

      (2, s "2");
      (8, s "8");
      (10, s "A");
      (16, s "G");
      (10, s "G")] = [
      Some 0; Some 1; Some 2; Some 3; Some 12; Some 23;
      Some 0; Some 1; Some 2; Some 3; Some 12; Some 23;
      Some 0; Some 1; Some 2; Some 3; Some 12; Some 23;
      Some 0; Some 1; Some 2; Some 3; Some 12; Some 23;
      None; None; None; None; None] :=
    eq_refl.
End Conversion.

Module Etc.
  Import ListString.Etc.

  Definition test_is_ascii :
    List.map is_ascii [s ""; s "ahah"; "128" :: s "ahah"] = [true; true; false] :=
    eq_refl.

  Definition test_is_empty :
    List.map is_empty [s ""; s "aAgZ"] = [true; false] :=
    eq_refl.

  Definition test_repeat :
    List.map_pair repeat [(s "", 0); (s "", 2); (s "ab", 0); (s "ab", 2)] % nat =
      [s ""; s ""; s ""; s "abab"] :=
      eq_refl.

  Definition test_center :
    List.map_pair center [(s "", 4); (s "a", 4); (s "ab", 4); (s "abcd", 4);
      (s "abcde", 4); (s "ab", 0)] % nat = [
      s "    "; s " a  "; s " ab "; s "abcd"; s "abcde"; s "ab"] :=
    eq_refl.

  Definition test_join :
    List.map_pair join [
      (s "", []);
      (s ", ", []);
      (s "", [s "hello"; s "world"]);
      (s ", ", [s "hello"; s "world"])] = [
      s "";
      s "";
      s "helloworld";
      s "hello, world"] :=
    eq_refl.

  Definition test_split :
    List.map_pair split [
      (s "", " ");
      (s "go stop go", " ");
      (s "go stop go ", " ");
      (s "go stop go  ", " ");
      (s "grr", " ")] = [
      [s ""];
      [s "go"; s "stop"; s "go"];
      [s "go"; s "stop"; s "go"; s ""];
      [s "go"; s "stop"; s "go"; s ""; s ""];
      [s "grr"]] :=
    eq_refl.

  Definition test_split_limit :
    List.map_triple split_limit [
      (s "", " ", 2);
      (s "go stop go", " ", 0);
      (s "go stop go ", " ", 3);
      (s "go stop go  ", " ", 1);
      (s "grr", " ", 4)] % nat = [
      [s ""];
      [];
      [s "go"; s "stop"; s "go "];
      [s "go stop go  "];
      [s "grr"]] :=
    eq_refl.

  Definition test_escape_html :
    List.map escape_html [
      s "";
      s "hello";
      s "&";
      s "'""&<>"] = [
      s "";
      s "hello";
      s "&";
      s "'"&<>"] :=
    eq_refl.
End Etc.

Module Trim.
  Import ListString.Trim.

  Definition test_chomp :
    List.map chomp [s ""; s "aa"; s "aa "; s "aa" ++ ["010"];
      s "aa" ++ ["010"; "013"]; s "aa" ++ ["013"; "010"]] =
      [s ""; s "aa"; s "aa "; s "aa"; s "aa" ++ ["010"]; s "aa"] :=
    eq_refl.

  Definition test_trim_head :
    List.map trim_head [s ""; s "aa"; s "a "; s " aa"; s "  a"; "011" :: s "aa"] =
      [s ""; s "aa"; s "a "; s "aa"; s "a"; s "aa"] :=
    eq_refl.

  Definition test_trim_tail :
    List.map trim_tail [s ""; s "aa"; s "a "; s " aa"; s "a  "; "011" :: s "aa"] =
      [s ""; s "aa"; s "a"; s " aa"; s "a"; "011" :: s "aa"] :=
    eq_refl.

  Definition test_trim :
    List.map trim [s ""; s "aa"; s "a "; s " aa"; s "a  "; "011" :: s "aa"] =
      [s ""; s "aa"; s "a"; s "aa"; s "a"; s "aa"] :=
    eq_refl.
End Trim.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals ssreflect.

Require Import Rcomplements Derive RInt Hierarchy Derive_2d AutoDerive.

(** This file aims at proving that d'Alembert's formula defines a
function that is solution to the one-dimensional wave equation. We
also need to prove the regularity of this function. *)

Local Open Scope R_scope.

Ltac auto_derive_2 :=
  match goal with
  | |- is_derive_n ?f 2 ?x ?d =>
    auto_derive_fun f ;
    match goal with
    | |- (forall x, _ -> is_derive _ x (@?d x)) -> _ =>
      let H := fresh "H" in
      let u := fresh "u" in
      intro H ;
      apply (is_derive_ext d) ;
      [ intro u ;
        apply sym_eq, is_derive_unique ;
        apply H
      | auto_derive ] ;
      clear H
    end
  end.

Section DAlembert.

Parameter c : R.

Hypothesis Zc : c <> 0.

Parameter u0 : R -> R.

Hypothesis Du0 : forall x, ex_derive (fun u => u0 u) x.
Hypothesis D2u0 : forall x, ex_derive_n (fun u => u0 u) 2 x.

Section Alpha.

Definition alpha x t := 1/2 * (u0 (x + c * t) + u0 (x - c * t)).
Definition alpha20 x t := 1/2 * (Derive_n u0 2 (x + c * t) + Derive_n u0 2 (x - c * t)).
Definition alpha02 x t := c^2/2 * (Derive_n u0 2 (x + c * t) + Derive_n u0 2 (x - c * t)).

Lemma alpha_20_lim :
  forall x t, is_derive_n (fun u => alpha u t) 2 x (alpha20 x t).
Proof.
intros x t.
unfold alpha.
auto_derive_2.
repeat split ; apply Du0.
repeat split ; apply D2u0.
unfold alpha20, Derive_n, Rminus.
ring.
Qed.

Lemma alpha_02_lim :
  forall x t, is_derive_n (fun u => alpha x u) 2 t (alpha02 x t).
Proof.
intros x t.
unfold alpha.
auto_derive_2.
repeat split ; apply Du0.
repeat split ; apply D2u0.
unfold alpha02, Derive_n, Rminus, Rdiv.
ring.
Qed.

End Alpha.

Parameter u1 : R -> R.

Hypothesis Du1 : forall x, ex_derive (fun u => u1 u) x.

Lemma Cu1 : forall x, continuity_pt (fun u => u1 u) x.
intros x.
destruct (Du1 x) as (l,Hl).
apply derivable_continuous_pt.
unfold derivable_pt, derivable_pt_abs.
exists l.
now apply is_derive_Reals.
Qed.

Lemma continuity_implies_ex_Rint: forall f a b,
   (forall x, continuity_pt f x) -> ex_RInt f a b.
intros f a b H.
case (Rle_or_lt a b); intros H1.
apply ex_RInt_Reals_1.
apply continuity_implies_RiemannInt.
exact H1.
intros x _; apply H.
apply ex_RInt_swap.
apply ex_RInt_Reals_1.
apply continuity_implies_RiemannInt.
left; exact H1.
intros x _; apply H.
Qed.

Lemma Iu1: forall a b, ex_RInt (fun u => u1 u) a b.
intros a b.
apply continuity_implies_ex_Rint.
apply Cu1.
Qed.

Section Beta.

Definition beta (x t : R) := 1/(2*c) * RInt (fun u => u1 u) (x - c * t) (x + c * t).
Definition beta20 x t := 1/(2*c) * (Derive (fun u => u1 u) (x + c * t) - Derive (fun u => u1 u) (x - c * t)).
Definition beta01 x t := 1/2 * (u1 (x + c * t) + u1 (x - c * t)).
Definition beta02 x t := c/2 * (Derive (fun u => u1 u) (x + c * t) - Derive (fun u => u1 u) (x - c * t)).

Lemma beta20_lim :
  forall x t, is_derive_n (fun u => beta u t) 2 x (beta20 x t).
Proof.
intros x t.
unfold beta.
auto_derive_2.
(* . *)
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
repeat split ; apply Du1.
unfold beta20, Rminus.
ring.
Qed.

Lemma beta01_lim :
  forall x t, is_derive (fun u => beta x u) t (beta01 x t).
Proof.
intros x t.
unfold beta.
auto_derive.
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
unfold beta01, Rminus, Rdiv.
now field.
Qed.

Lemma beta02_lim :
  forall x t, is_derive_n (fun u => beta x u) 2 t (beta02 x t).
Proof.
intros x t.
unfold beta.
auto_derive_2.
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
repeat split ; apply Du1.
unfold beta02, Rminus, Rdiv.
now field.
Qed.

End Beta.

Hypothesis f : R -> R -> R.

Section Gamma.

Definition gamma x t := 1/(2*c) * RInt (fun tau => RInt (fun xi => f xi tau) (x - c * (t - tau)) (x + c * (t - tau))) 0 t.
Definition gamma20 x t := 1/(2*c) * RInt (fun tau => Derive (fun u => f u tau) (x + c * (t - tau)) - Derive (fun u => f u tau) (x - c * (t - tau))) 0 t.
Definition gamma02 x t := (f x t + c/2 * RInt (fun tau => Derive (fun u => f u tau) (x + c * (t - tau)) - Derive (fun u => f u tau) (x - c * (t - tau))) 0 t).

Lemma gamma20_lim :
  forall x t, is_derive_n (fun u => gamma u t) 2 x (gamma20 x t).
Proof.
intros x t.
unfold gamma.
auto_derive_2.
repeat split.
exists (mkposreal _ Rlt_0_1).
simpl.
intros t' u' _ _.
repeat split.
apply continuity_implies_ex_Rint => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
apply derivable_continuous_pt.
admit. (* ??? *)
intros t' _.
admit.
repeat split.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
repeat split.
admit.
admit.
apply filter_forall => y.
admit.
intros t' _.
admit.
unfold gamma20.
apply f_equal.
apply RInt_ext => z _.
now rewrite 4!Rmult_1_l.
Admitted.

Lemma gamma02_lim :
  forall x t, is_derive_n (fun u => gamma x u) 2 t (gamma02 x t).
Proof.
intros x t.
unfold gamma.
auto_derive_2.
repeat split.
apply locally_2d_forall => y z.
admit.
intros t' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
simpl.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
simpl.
intros t' u' _ _.
repeat split.
apply continuity_implies_ex_Rint => y.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
admit.
repeat split.
apply locally_2d_forall => y z.
admit.
apply locally_2d_forall => y z.
admit.
intros x' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
admit.
apply locally_2d_forall => y z.
admit.
intros t' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
repeat split.
admit.
admit.
unfold gamma02.
ring_simplify.
rewrite Rplus_opp_r Rmult_0_r Ropp_0 Rplus_0_r.
rewrite RInt_point Rmult_0_r Rplus_0_r.
apply Rplus_eq_reg_l with (- f x t).
field_simplify.
2: exact Zc.
rewrite Rmult_1_r.
rewrite /Rdiv Rmult_comm.
rewrite Rmult_assoc (Rmult_comm _ (/2)) -Rmult_assoc.
rewrite -[Rmult]/(@scal _ R_ModuleSpace) -RInt_scal.
rewrite -RInt_scal.
apply RInt_ext => u _.
rewrite /scal /= /mult /= /Rminus.
now field.
admit.
admit.
Admitted.

End Gamma.

End DAlembert.


(*|
#####################################
Does Gallina have holes like in Agda?
#####################################

:Link: https://stackoverflow.com/q/60662078
|*)

(*|
Question
********

When proving in Coq, it's nice to be able to prove one little piece at
a time, and have Coq help keep track of the obligations.
|*)

Theorem ModusPonens: forall (A B : Prop), ((A -> B) /\ A) -> B.
Proof.
  intros A B [H1 H2].
  apply H1. (* .unfold *)
  exact H2. (* .none *)
Qed. (* .none *)

(*|
At this point I can see the proof state to know what is required to
finish the proof.

But when writing Gallina, do we have to solve the whole thing in one
bang, or make lots of little helper functions? I'd love to be able to
put use a question mark to ask Coq what it's looking for:

.. coq:: fails
|*)

Fail Definition ModusPonens' :=
  fun (A B : Prop) (H : (A -> B) /\ A) =>
    match H with
    | conj H1 H2 => H1 _ (* hole of type B *)
    end.

(*|
It really seems like Coq should be able to do this, because I can even
put ltac in there and Coq will find what it needs:
|*)

Definition ModusPonens' := fun (A B : Prop) (H : (A -> B) /\ A) =>
  match H with
    | conj H1 H2 => H1 ltac:(assumption)
  end.

(*|
If Coq is smart enough to finish writing the definition for me, it's
probably smart enough to tell me what I need to write in order to
finish the function myself, at least in simple cases like this.

So how do I do this? Does Coq have this kind of feature?
|*)

(*|
Answer (larsr)
**************

You can use ``refine`` for this. You can write underscores which will
turn into obligations for you to solve later.
|*)

Reset Initial. (* .none *)
Definition ModusPonens: forall (A B : Prop), ((A -> B) /\ A) -> B.
  refine (fun A B H =>
            match H with
            | conj H1 H2 => H1 _ (* hole of type A *)
            end).

(*|
Now your goal is to provide an ``A``. This can be discharged with
|*)

  exact H2. Defined.

(*|
Answer (Li-yao Xia)
*******************

Use an underscore

.. coq:: unfold fails
|*)

Fail Definition ModusPonens' :=
  fun (A B : Prop) (H : (A -> B) /\ A) =>
    match H with
    | conj H1 H2 => H1 _ (* hole of type A *)
    end.

(*| or use ``Program`` |*)

Require Import Program.
Obligation Tactic := idtac.
(* By default Program tries to be smart and solve simple obligations
   automatically. This commands disables it. *)

Program Definition ModusPonens' :=
  fun (A B : Prop) (H : (A -> B) /\ A) =>
    match H with
    | conj H1 H2 => H1 _ (* hole of type A *)
    end.

Next Obligation. intros. (* See the type of the hole *) (* .unfold *)
Abort. (* .none *)