Load FinSets.
Require Import Bool.
Require Import Arith.
Require Import List.
Require Import Notations.

(*A finite set is described using an inductive definition, using 2 constructors.*)

Definition El:=Fin.

(*A word is a list of elements *)
Variable Alphabet : nat.
(*Variable Sigma : Alphabet. *)
(*A word is a list of elements *)
Definition Word := list (El Alphabet).

Definition Language := Word  -> Prop.
(**empty word/string *)
Definition eps :Word :=nil.

(**empty word/string *)
Definition lang_conc(l1:Language)(l2:Language):Language :=
    fun w:Word => exists w1:Word, exists w2:Word,  w1 ++ w2=w /\ l1 w1 /\ l2 w2.

Definition lang_union (l1:Language)(l2:Language):Language :=
    fun w:Word =>  l1 w \/ l2 w.

(* empty language imply [False] *)
Definition empty_lang :Language:= fun w:Word=>False.

(** A language included into another language *)
Definition Included (l1:Language)(l2:Language) :Prop := forall (w:Word), l1 w -> l2 w.
Check Included.

Definition eps_lang :Language := fun w:Word => match w with
   |nil => True
  | _  => False
   end.

(* L1 conc empty = empty *)
Lemma empty_lr : forall (l1:Language)(w:Word) ,  (lang_conc l1 empty_lang) w<->  empty_lang w.
intros.
unfold iff.
split.
simpl.
intro.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
simpl.
simpl in H1.
unfold empty_lang.
unfold empty_lang in H1.
destruct H1.
intro.

unfold empty_lang in H.
destruct H.
Qed.

Definition In_lang(w:Word)(l:Language) := l w.
(* use the properties of existence quantifier to attribute the right values
to the words *)

(** distributivity property *)
Lemma distrib : forall (l1 l2 l3 :Language) (w:Word), In_lang w (lang_conc l1 (lang_union l2 l3)) <-> In_lang w (lang_union (lang_conc l1 l2) (lang_conc l1 l3)).
(** -> *)

intros.
unfold iff.
split.
intro.
unfold In_lang.
unfold In_lang in H.
unfold lang_conc.
unfold lang_union.
unfold lang_conc in H.
unfold lang_union in H.
destruct H.
destruct H.
destruct H.

(* use the properties of existence quantifier to attribute the right values
to the words *)
destruct H0.
destruct H1.
left.
exists x.
exists x0.
split.
assumption.
split.
assumption.
assumption.
right.
exists x.
exists x0.
split.
exact H.
split.
assumption.
assumption.

(**  <- *)
intro.
unfold In_lang in H.
unfold lang_union in H.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H.
destruct H0.
unfold In_lang.
unfold lang_conc.
unfold lang_union.
exists x.
exists x0.
split.
exact H.
split.
exact H0.
left.
exact H1.

destruct H.
destruct H.
destruct H.
destruct H0.
unfold In_lang.
unfold lang_conc.
exists x.
exists x0.
split.
exact H.
split.
exact H0.
unfold lang_union.
right.
exact H1.
Qed.

Variable x:Word.

Lemma eps_implies_nil : forall (w:Word) , eps_lang w -> w=nil.
intros.
induction w.
reflexivity.
unfold eps_lang in H.
destruct H.
Qed.
(** Found in the List library *)
Theorem app_l_nil :  forall (A : Set)(l : list A),
  l ++ nil = l.
intros A l.
induction l.
reflexivity.
simpl.
rewrite IHl.
reflexivity.
Qed.

(* L conc epsilon = L *)

Theorem lang_conc_neutral_left : forall (l:Language)(w:Word), In_lang w (lang_conc l eps_lang) <-> In_lang w l.
intros.
unfold iff.
split.
intro.
unfold In_lang.
unfold In_lang in H.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
rewrite <-H.
assert (x1 = nil).
apply eps_implies_nil.
exact H1.
rewrite H2.
simpl.
rewrite app_l_nil.
exact H0.

intro.
unfold In_lang.
unfold In_lang in H.
unfold lang_conc.
exists w.
exists nil.
split.
rewrite app_l_nil.
reflexivity.
split.
exact H.
split.
Qed.

(** epsilon language belongs to L*, if L belongs to the powerset of the word , L* bleongs to the
powerset of the word (using concatenation) *)

Inductive Star(x:Language) : Language :=
  | nil0: (Star x) nil
  | cons0 : forall (a: Word)(b:Word),Star x a /\ x b -> Star x (app a b).

(** the power of a language L : L^n = LLLL...L n times *)
Fixpoint lang_power (l:Language)(n:nat) : Language :=
     match n with
     | 0 => eps_lang
     | S n => lang_conc l (lang_power l n)
     end.

(** L1 conc(L2 conc L3) =(L1 conc L2) conc L3
assume w= v0++ v1, v0 in L1
v1 in L2 conc L3
v1 = v2++v3,
v2 in L2 /\ v3 in L3,
w = v0++(v2++v3) = (v0++ v2)++v3 (associativity of lists) in L1 L2 L4
*)
Axiom app_ao : forall (A:Set)(l1 l2 l3 : list A) , l1 ++ app l2 l3 = (l1 ++ l2) ++ l3.
Lemma ab : forall (A:Set) (l1 l2 : list A) ,  app l1 l2 = l1 ++ l2.
intros.
reflexivity.
Qed.
Lemma abc : forall (A:Set) (l1 l2 l3: list A), app l1 l2 ++ l3 = l1 ++ (l2 ++l3).
intros.
simpl.
admit.
Qed.
Lemma lang_assoc : forall (l1 l2 l3:Language)(w:Word), In_lang w (lang_conc l1 (lang_conc l2 l3)) <-> In_lang w (lang_conc (lang_conc l1 l2) l3).

intros.
unfold iff.
split.
intro.
unfold In in H.

unfold In_lang.
unfold lang_conc.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
destruct H1.
destruct H1.
destruct H1.
destruct H2.
assert( In_lang x1 (lang_conc l2 l3)).
unfold In_lang.
unfold lang_conc.
exists x2.
exists x3.
split.
exact H1.
split.
assumption.
assumption.
rewrite <-H1 in H.

rewrite app_ao in H.
exists (x0 ++ x2).
exists x3.
split.

rewrite <-H.
simpl.
admit.
(* Coq does not recognise app x0 x2 ++ x3 as (x0 ++ x2) ++ x3 ??*)
split.
exists x0.
exists x2.
split.
reflexivity.
split.
assumption.
assumption.
exact H3.

intro.
unfold In.
unfold In in H.
unfold lang_conc.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
destruct H0.
destruct H0.
destruct H0.
destruct H2.

rewrite <-H0 in H.
rewrite abc in H.
exists x2.
exists (x3++ x1).
split. (* x2 ++ app x3 x1 *)
admit.
split.
exact H2.

exists x3.
exists x1.
split.
reflexivity.
split.
assumption.
assumption.
Qed.

(** Star (Star L) = Star l.  we will prove this by using *)
 Lemma kleene1 : forall (l:Language) (w:Word), In_lang w (Star l) ->In_lang w (Star (Star l)).

unfold In_lang.
intros.
rewrite <- app_nil_l.
assert (Star (Star l) nil).
apply (nil0 ).
assert ((Star (Star l) nil) /\ ((Star l) w)).
split.
assumption.
assumption.
apply (cons0) in H1.
exact H1.
Qed.

Axiom nil_O_r : forall (A:Set)(l:list A), l++nil = l.
Lemma lem : forall ( l:Language) (a b : Word) , In_lang a (Star l) /\ In_lang b (Star l) -> In_lang (a ++ b) (Star l).

intros.
unfold In_lang.
unfold In_lang in H.
destruct H.
induction H0.
simpl.
rewrite nil_O_r.
assumption.
Print Star.
assert(Star l (a0 ++b )).
apply cons0.
assumption.
destruct H0.

intros.
unfold In_lang in H.
unfold In_lang.
destruct H.

induction H.
simpl.
exact H0.

Print Star.

assert(Star l (a++b0)).
apply cons0.
exact H.
destruct H.
assert (Star l b0).

Print Star.
(*induction H0.
simpl.
admit.
simpl.

apply cons0.
split.
destruct H.
exact H.
destruct H.*)
admit.
Qed.

Lemma kleene2: forall (l:Language)(w:Word), In_lang w (Star(Star l)) -> In_lang w (Star l).
intros.
unfold In_lang.
unfold In_lang in H.
induction w.
simpl.
apply nil0.
destruct H.
apply nil0.
destruct H.

apply cons0.
split.

induction H.

apply nil0.
destruct H.

assert(Star (Star l) (a++b)).
apply cons0.
split.
assumption.
assumption.
assert(Star(Star l) b).
apply kleene1.
unfold In_lang.
exact H0.
induction H.
simpl.
assumption.
destruct H.
assert (Star l (b0 ++ b)).
apply lem.
unfold In_lang.
split.
assumption.
assumption.

induction a.
simpl.
exact H4.

Print Star.

destruct H.
simpl.
assumption.
destruct H.

induction H0.
simpl.
assert(a++nil = a).
admit.
rewrite H0.

induction H.

induction H.
exact (nil0 l).
assert(Star (Star l ) (a++b)).
apply cons0.
assumption.

Print Star.

destruct H.
induction H.
simpl.
assumption.
destruct H.
assert(Star l (b0++b)).
apply lem.
unfold In_lang.
split.
assumption.
assumption.
admit.
(*
induction H0.
assert (a++ nil = a).
admit.
rewrite H0.
induction H.
apply nil0.
apply cons0.
split. *)

induction H.
simpl.
exact H0.
Print Star.

assert(Star l (a++b0)).
destruct H.

assert (Star (Star l) (a ++ b0)).
apply cons0.
exact H.
Print Star.

assert (Star (Star l) b).
apply kleene1.
unfold In_lang.
exact H0.
Print Star.

induction H.
simpl.
exact H0.

apply cons0.


Require Import VST.floyd.proofauto.
Require EV.max3 EV.swap EV.tri EV.gcd EV.append.

(* ################################################################# *)
(** * Task 1: The Max of Three *)

Module Verif_max3.

Import EV.max3.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** C function [max3]:

      int max3(int x, int y, int z)
      {
        if (x < y)
          if (y < z)
            return z;
          else
            return y;
        else
          if (x < z)
            return z;
          else
            return x;
      }

    Specification:
*)

Definition max3_spec :=
 DECLARE _max3
  WITH x: Z, y: Z, z: Z
  PRE  [ _x OF tint, _y OF tint, _z OF tint ]
     PROP  (Int.min_signed <= x <= Int.max_signed;
            Int.min_signed <= y <= Int.max_signed;
            Int.min_signed <= z <= Int.max_signed)
     LOCAL (temp _x (Vint (Int.repr x));
            temp _y (Vint (Int.repr y));
            temp _z (Vint (Int.repr z)))
     SEP   ()
  POST [ tint ]
    EX r: Z,
     PROP  (r = x \/ r = y \/ r = z;
            r >= x;
            r >= y;
            r >= z)
     LOCAL (temp ret_temp (Vint (Int.repr r)))
     SEP   ().

Definition Gprog : funspecs := ltac:(with_library prog [ max3_spec ]).

Lemma body_max3: semax_body Vprog Gprog f_max3 max3_spec.
Proof.
  start_function.
  forward_if.
  {
    forward_if.
    {
      forward.
      Exists z.
      entailer!.
    }
    {
      forward.
      Exists y.
      entailer!.
    }
  }
  {
    forward_if.
    {
      forward.
      Exists z.
      entailer!.
    }
    {
      forward.
      Exists x.
      entailer!.
    }
  }
Qed.

End Verif_max3.
(** [] *)

(* ################################################################# *)
(** * Task 2: Swap by Arith *)

Module Verif_swap.

Import EV.swap.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** C function [uint_swap_arith]:

      void uint_swap_arith (unsigned int * px, unsigned int * py) {
        * px = * px + * py;
        * py = * px - * py;
        * px = * px - * py;
      }

    Specification:
*)

Definition uint_swap_arith_spec :=
 DECLARE _uint_swap_arith
  WITH x: Z, y: Z, px: val, py: val
  PRE  [ _px OF (tptr tuint), _py OF (tptr tuint) ]
     PROP  ()
     LOCAL (temp _px px; temp _py py)
     SEP   (data_at Tsh tuint (Vint (Int.repr x)) px;
            data_at Tsh tuint (Vint (Int.repr y)) py)
  POST [ tvoid ]
     PROP  ()
     LOCAL ()
     SEP   (data_at Tsh tuint (Vint (Int.repr x)) py;
            data_at Tsh tuint (Vint (Int.repr y)) px).

Definition Gprog : funspecs :=
  ltac:(with_library prog [ uint_swap_arith_spec ]).

Lemma body_uint_swap_arith: semax_body Vprog Gprog
                              f_uint_swap_arith uint_swap_arith_spec.
Proof.
  start_function.
  repeat forward.
  entailer!.
  autorewrite with sublist.
  entailer!.
Qed.

End Verif_swap.
(** [] *)

(* ################################################################# *)
(** * Task 3: Tri *)

Module Verif_tri.

Import EV.tri.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** C program:

      unsigned int tri_for (int n) {
        unsigned int s;
        int i;
        s = 0;
        for (i = 0; i < n; ++ i)
          s = s + i;
        return s;
      }

      unsigned int tri_while (int n) {
        unsigned int s;
        s = 0;
        while (n > 0) {
          n = n - 1;
          s = s + n;
        }
        return s;
      }

    Specification:
*)

Definition tri_spec (_tri_name: ident) :=
 DECLARE _tri_name
  WITH n: Z
  PRE  [ _n OF tint ]
     PROP  (0 <= n <=Int.max_signed)
     LOCAL (temp _n (Vint (Int.repr n)))
     SEP   ()
  POST [ tuint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (n * (n-1)/2))))
     SEP   ().

Definition Gprog : funspecs :=
  ltac:(with_library prog [ tri_spec _tri_for; tri_spec _tri_while ]).

(** Hint: in your proof, lemma [Z_div_plus_full] and tactic [ring] might be
    helpful. (Ring is just a fancier version of omega which can also handle
    multiplication. *)
Lemma body_tri_for: semax_body Vprog Gprog
                            f_tri_for (tri_spec _tri_for).
Proof.
  start_function.
  forward.
  forward_for_simple_bound n
    (EX i: Z, EX i': nat,
      PROP (i = Z.of_nat i')
      LOCAL (temp _s (Vint (Int.repr (i * (i - 1) / 2)));
             temp _n (Vint (Int.repr n)))
      SEP ()).
  {
    Exists O.
    entailer!.
  }
  {
    rename i'0 into i'.
    forward.
    Exists (S i').
    entailer!.
    split.
    - rewrite Nat2Z.inj_succ; auto.
    - f_equal.
      f_equal.
      replace (Z.of_nat i' + 1 - 1) with (Z.of_nat i'); [ | ring].
      assert (forall z: Z, (z * (z - 1) / 2 + z = (z + 1) * z / 2)%Z).
      {
        intro. rewrite <- Z_div_plus; [ | omega].
        assert (z * (z - 1) + z * 2 = (z + 1) * z)%Z; [ring | ].
        rewrite <- H1; auto.
      }
      symmetry. auto.
  }
  Intros i'.
  subst.
  forward.
Qed.

Lemma body_tri_while: semax_body Vprog Gprog
                            f_tri_while (tri_spec _tri_while).
Proof.
  start_function.
  forward.
  forward_while
    (EX n': Z, EX s': Z,
      (PROP ((n' * (n' - 1) / 2 + s' = n * (n - 1) / 2)%Z; 0 <= n' <= Int.max_signed)
       LOCAL (temp _n (Vint (Int.repr n'));
              temp _s (Vint (Int.repr s')))
       SEP ())).
  {
    Exists n.
    Exists 0.
    entailer!.
  }
  {
    entailer!.
  }
  {
    forward. (* n = n - 1 *)
    forward. (* s = s + n *)
    Exists (n' - 1 , s' + (n' - 1)).
    entailer!.
    split.
    - rewrite <- H0.
      rewrite Z.add_assoc, Z.add_shuffle0.
      apply Z.add_cancel_r.
      rewrite <- Z_div_plus; [ | omega].
      assert ((n' - 1) * (n' - 1 - 1) + (n' - 1) * 2 = n' * (n' - 1))%Z; [ring | ].
      rewrite H2; auto.
    - split; [omega | f_equal; f_equal; omega].
  }
  assert (n' = 0); [omega | ].
  subst.
  replace (0 * (0 - 1) / 2 + s') with s' in H0; auto.
  subst.
  forward.
Qed.

End Verif_tri.
(** [] *)

(* ################################################################# *)
(** * Task 4: Greatst Common Divisor *)

Module Verif_gcd.

Import EV.gcd.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** C function [gcd]:

      int gcd(int n, int m) {
        int r = m % n;
        if (r == 0)
          return n;
        else
          return gcd(r, n);
      }

    This function calculates the greatest common divisor of two integers.
    [Z.gcd] is defined as part of Coq's standard library. Using this definition,
    we can write specification as follows:
*)

Definition gcd_spec :=
 DECLARE _gcd
  WITH n: Z, m: Z
  PRE  [ _n OF tint, _m OF tint ]
     PROP  (0 < n <= Int.max_signed;
            0 <= m <= Int.max_signed)
     LOCAL (temp _n (Vint (Int.repr n));
            temp _m (Vint (Int.repr m)))
     SEP   ()
  POST [ tint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (Z.gcd n m))))
     SEP   ().

Definition Gprog : funspecs := ltac:(with_library prog [ gcd_spec ]).

(** We first provide three useful lemmas. You may use it in your proofs. *)

Lemma aux1: forall n, 0 < n <= Int.max_signed -> Int.repr n <> Int.zero.
Proof.
  intros.
  intro.
  apply repr_inj_signed in H0.
  + omega.
  + rep_omega.
    (* This VST tactic is used to handle linear programming with 32-bit bounds.
       You can use it in your own proofs. *)
  + rep_omega.
Qed.

Lemma aux2: forall m, 0 <= m <= Int.max_signed -> Int.repr m <> Int.repr Int.min_signed.
Proof.
  intros.
  intro.
  apply repr_inj_signed in H0.
  + rep_omega.
    (* [rep_omega] can also solve normal linear proof goals. The proof goal
       does not need to be [repable_signed]. *)
  + rep_omega.
  + rep_omega.
Qed.

Lemma mods_repr: forall n m,
  Int.min_signed <= n <= Int.max_signed ->
  Int.min_signed <= m <= Int.max_signed ->
  Int.mods (Int.repr m) (Int.repr n) = Int.repr (Z.rem m n).
(* Here [Z.rem] is the remainder of [m divides n]. *)
Proof.
  intros.
  unfold Int.mods.
  rewrite Int.signed_repr by rep_omega.
  rewrite Int.signed_repr by rep_omega.
  reflexivity.
Qed.

(** Now, fill in the holes in the following proof. *)
Lemma body_gcd: semax_body Vprog Gprog f_gcd gcd_spec.
Proof.
  start_function.
  forward.
  {
    (* Hint: remember that you can use [aux1] and [aux2]. *)
    entailer!.
    split; [apply aux1; auto | ].
    intro.
    assert (Int.repr m <> Int.repr Int.min_signed) by (apply aux2; auto).
    tauto.
  }
  rewrite mods_repr by rep_omega.
  forward_if.
  {
    (* Hint: you can always use [Search] to find useful theorems in Coq's
       standard library and VST's library. For example, [Z.gcd_rem] may be
       useful. *)
    forward.
    entailer!.
    f_equal.
    f_equal.
    replace (Z.gcd n m) with (Z.gcd (Z.rem m n) n); [ | apply Z.gcd_rem; omega].
    apply repr_inj_signed in H1.
    replace (Z.rem m n) with 0.
    rewrite Z.gcd_0_l.
    symmetry. apply Z.abs_eq.
    omega.
    assert (Z.rem m n <= m); [apply Zquot.Zrem_le; omega | ].
    assert (0 <= Z.rem m n); [apply Z.rem_nonneg; omega | ].
    rep_omega.
    rep_omega.
  }
  {
    assert (Z.rem m n <> 0).
    {
      unfold not; intro.
      rewrite H2 in H1.
      apply H1; reflexivity.
    }
    forward_call (Z.rem m n, n).
    {
      split; [ | omega].
      assert (0 <= Z.rem m n); [apply Z.rem_nonneg; omega | ].
      assert (Z.rem m n <= m); [apply Zquot.Zrem_le; omega | ].
      rep_omega.
    }
    forward.
    entailer!.
    f_equal.
    f_equal.
    apply Z.gcd_rem.
    omega.
  }
Qed.

End Verif_gcd.

Module List_seg.

(* ################################################################# *)
(** * Task 5. List Segments *)

Import EV.append.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** In this part, we will verify two C functions:

      struct list {
        unsigned int head;
        struct list * tail;
      };

      unsigned sumlist (struct list *p) {
        unsigned s = 0;
        struct list * t = p;
        unsigned h;
        while (t) {
           h = t->head;
           t = t->tail;
           s = s + h;
        }
        return s;
      }

      struct list *append (struct list *x, struct list *y) {
        struct list *t, *u;
        if (x==NULL)
          return y;
        else {
          t = x;
          u = t->tail;
          while (u!=NULL) {
            t = u;
            u = t->tail;
          }
          t->tail = y;
          return x;
        }
      }

    Using [listrep], we can state their specification.
*)

Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep (sigma: list Z) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
      data_at Tsh t_struct_list (Vint (Int.repr h),y) x  *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Arguments listrep sigma x : simpl never.

Definition sum_int (sigma: list Z): Z :=
  fold_right Z.add 0 sigma.

Definition sumlist_spec :=
 DECLARE _sumlist
  WITH sigma : list Z, p: val
  PRE [ _p OF (tptr t_struct_list) ]
     PROP  ()
     LOCAL (temp _p p)
     SEP   (listrep sigma p)
  POST [ tuint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (sum_int sigma))))
     SEP   (listrep sigma p).

Definition append_spec :=
 DECLARE _append
  WITH x: val, y: val, s1: list Z, s2: list Z
  PRE [ _x OF (tptr t_struct_list) , _y OF (tptr t_struct_list)]
     PROP()
     LOCAL (temp _x x; temp _y y)
     SEP (listrep s1 x; listrep s2 y)
  POST [ tptr t_struct_list ]
    EX r: val,
     PROP()
     LOCAL(temp ret_temp r)
     SEP (listrep (s1++s2) r).

(** Both C functions traverse a linked list using a while loop. Thus, the
    keypoint of verifying them is to write down the correct loop invariant.
    The following diagram demonstrates an intermediate state in traversing.

        +---+---+            +---+---+   +---+---+   +---+---+
  x ==> |   |  ===> ... ===> |   | y ==> |   | z ==> |   |  ===> ...
        +---+---+            +---+---+   +---+---+   +---+---+

      | <==== Part 1 of sigma =====> |            | <== Part 2 ==> |

      | <========================== sigma =======================> |

    To properly describe loop invariants, we need a predicate to describe
    the partial linked list from address [x] to address [y]. We provide its
    definition for you. But it is your task to prove its important properties.
*)

Fixpoint lseg (sigma: list Z) (x y: val) : mpred :=
  match sigma with
  | nil => !! (x = y) && emp
  | h::hs => EX u:val, data_at Tsh t_struct_list (Vint (Int.repr h), u) x * lseg hs u y
  end.

Arguments lseg sigma x y : simpl never.

Lemma singleton_lseg: forall (a: Z) (x y: val),
  data_at Tsh t_struct_list (Vint (Int.repr a), y) x |-- lseg [a] x y.
Proof.
  intros.
  unfold lseg.
  Exists y.
  entailer!.
Qed.
(** [] *)

(** In the next lemma, try to understand how to use [sep_apply]. *)
Lemma lseg_nullval: forall sigma x,
  lseg sigma x nullval |-- listrep sigma x.
Proof.
  intros.
  revert x; induction sigma; intros.
  + unfold listrep, lseg.
    entailer!.
  + unfold lseg; fold lseg.
    unfold listrep; fold listrep.
    Intros u.
    Exists u.
    (** The following tactic "apply" [IHsigma] on the left side of derivation. *)
    sep_apply (IHsigma u).
    entailer!.
Qed.

Lemma lseg_lseg: forall (s1 s2: list Z) (x y z: val),
  lseg s1 x y * lseg s2 y z |-- lseg (s1 ++ s2) x z.
Proof.
  intros.
  revert x; induction s1; intros.
  - unfold lseg; fold lseg.
    entailer!.
    rewrite app_nil_l.
    entailer!.
  - replace ((a :: s1) ++ s2) with (a :: s1 ++ s2); [ | apply app_comm_cons].
    unfold lseg; fold lseg.
    Intros u.
    Exists u.
    sep_apply (IHs1 u).
    entailer!.
Qed.
(** [] *)

Lemma lseg_list: forall (s1 s2: list Z) (x y: val),
  lseg s1 x y * listrep s2 y |-- listrep (s1 ++ s2) x.
Proof.
  intros.
  revert x; induction s1; intros.
  - unfold listrep; fold listrep.
    unfold lseg; fold lseg.
    rewrite app_nil_l.
    entailer!.
  - replace ((a :: s1) ++ s2) with (a :: s1 ++ s2); [ | apply app_comm_cons].
    unfold lseg; fold lseg.
    unfold listrep; fold listrep.
    Intros u.
    Exists u.
    sep_apply (IHs1 u).
    entailer!.
Qed.
(** [] *)

(** Try to use prove the following assertion derivation use the lemmas above.
    The first step is done for you. *)
Example lseg_ex: forall s1 s2 s3 x y z,
  lseg s1 x y * lseg s2 y z * lseg s3 z nullval |-- listrep (s1 ++ s2 ++ s3) x.
Proof.
  intros.
  sep_apply lseg_lseg.
  sep_apply lseg_nullval.
  sep_apply lseg_list.
  rewrite app_assoc.
  entailer!.
Qed.
(** [] *)

(* ################################################################# *)
(** * Task 6. Sum of a List *)

(** Now, you are going to prove [sumlist] correct. The following lemmas are
    copied from [verif_reverse2] for proof automation. *)

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
  intros.
  revert p; induction sigma;
  unfold listrep; fold listrep; intros; normalize.
  apply prop_right; split; simpl; auto. intuition.
  entailer!.
  split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
  destruct sigma; unfold listrep; fold listrep;
  intros; normalize.
  auto with valid_pointer.
  apply sepcon_valid_pointer1.
  apply data_at_valid_ptr; auto.
  simpl; computable.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

Module sumlist.

(** Another auxiliary lemma. Hint: use [Search] when you need to find a
    lemma. *)
Lemma sum_int_snoc:
  forall a b, sum_int (a++b :: nil) = (sum_int a) + b.
Proof.
  induction a; intros; [simpl; omega | ].
  simpl.
  rewrite <- Z.add_assoc.
  apply Z.add_cancel_l.
  apply IHa.
Qed.
(** [] *)

Definition Gprog : funspecs :=
  ltac:(with_library prog [ sumlist_spec ]).

(** Hint: take a look at Verif_reverse and learn its proof strategy. *)
Lemma body_sumlist: semax_body Vprog Gprog f_sumlist sumlist_spec.
Proof.
  start_function.
  forward.
  forward.
  forward_while
    (EX s1: list Z, EX s2: list Z,
     EX t: val, EX s: Z,
        PROP (sigma = s1 ++ s2; s = sum_int s1)
        LOCAL (temp _t t; temp _p p; temp _s (Vint (Int.repr s)))
        SEP (lseg s1 p t; listrep s2 t)).
  {
    Exists (@nil Z) sigma p 0.
    unfold lseg; fold lseg.
    entailer!.
  }
  {
    entailer!.
  }
  {
    assert_PROP(s2 <> nil). {
      entailer!.
      assert(t = nullval); [apply H1; auto | subst].
      apply HRE.
    }
    destruct s2 as [ | s2a s2b]; [congruence | clear H1].
    unfold listrep.
    Intros y.
    forward.
    forward.
    forward.
    entailer!.
    Exists ((s1 ++ [s2a]), s2b, y, sum_int (s1 ++ [s2a])).
    entailer!.
    - split.
      + induction s1; auto; simpl.
        apply cons_congr; auto.
      + f_equal. f_equal. unfold sum_int.
        apply sum_int_snoc.
    - fold listrep.
      sep_apply singleton_lseg.
      entailer!.
      sep_apply pull_left_special0.
      sep_apply lseg_lseg.
      entailer!.
  }
  forward.
  entailer!.
  f_equal.
  f_equal.
  assert(s2 = []); [apply H1; auto | subst].
  rewrite app_nil_r; auto.
  apply lseg_list.
Qed.
(** [] *)

End sumlist.

(* ################################################################# *)
(** * Task 7: Append *)

Module append.

Definition Gprog : funspecs :=
  ltac:(with_library prog [ append_spec ]).

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
  start_function.
  forward_if.
  {
    forward.
    Exists y.
    assert (s1 = []); [apply H0; auto | subst].
    unfold listrep; fold listrep.
    simpl. entailer!.
  }
  forward.
  assert_PROP (exists s1a s1b, s1 = s1a :: s1b);
    [entailer!; destruct s1; [tauto | eauto] | ].
  destruct H0 as [s1a [s1b ?]].
  subst s1.
  unfold listrep at 1; fold listrep.
  Intros u'.
  forward.
  forward_while
    (EX (s11: list Z) (s12: list Z) (t: val) (u: val) (mid: Z),
        PROP (s1a :: s1b = s11 ++ mid :: s12)
        LOCAL (temp _t t; temp _u u; temp _x x; temp _y y)
        SEP (lseg s11 x t; listrep s12 u; listrep s2 y;
        data_at Tsh t_struct_list (Vint (Int.repr mid), u) t))%assert.
  {
    Exists (@nil Z) s1b x u' s1a.
    unfold lseg.
    entailer!.
  }
  {
    entailer!.
  }
  {
    forward.
    assert_PROP(s12 <> nil); [entailer!; apply HRE, H1; auto | ].
    destruct s12 as [ | s12a s12b]; [tauto | clear H1].
    unfold listrep at 1; fold listrep.
    Intros y0.
    forward.
    entailer!.
    Exists (s11 ++ [mid], s12b, u, y0, s12a).
    entailer!.
    - rewrite H0.
      rewrite <- app_assoc.
      induction s11; auto.
    - entailer!.
      sep_apply singleton_lseg.
      sep_apply pull_left_special0.
      sep_apply lseg_lseg.
      entailer!.
  }
  forward.
  forward.
  Exists x.
  assert(s12 = []); [apply H1; auto | subst].
  sep_apply singleton_lseg.
  unfold listrep at 1; fold listrep.
  sep_apply pull_left_special0.
  sep_apply lseg_lseg.
  sep_apply lseg_list.
  rewrite H0.
  entailer!.
Qed.
(** [] *)

End append.

(* ################################################################# *)
(** * Task 8: List box segments *)

(** Now, consider this alternative implementation of append:

      void append2(struct list * * x, struct list * y) {
        struct list * h;
        h = * x;
        while (h != NULL) {
          x = & (h -> tail);
          h = * x;
        }
        * x = y;
      }

    You should prove:
*)

Module append2.

Definition append2_spec :=
 DECLARE _append2
  WITH x: val, y: val, s1: list Z, s2: list Z, p :val
  PRE [ _x OF (tptr (tptr t_struct_list)) , _y OF (tptr t_struct_list)]
     PROP()
     LOCAL (temp _x x; temp _y y)
     SEP (data_at Tsh (tptr t_struct_list) p x;
          listrep s1 p;
          listrep s2 y)
  POST [ tvoid ]
     EX q: val,
     PROP()
     LOCAL()
     SEP (data_at Tsh (tptr t_struct_list) q x;
          listrep (s1 ++ s2) q).

Definition Gprog : funspecs :=
  ltac:(with_library prog [ append2_spec ]).

(** You may find it inconvenient to complete this proof directly using [listrep]
    and [lseg]. You may need another predicate for [list box segment].

         +---+---+            +---+---+   +---+---+   +---+---+
   p ==> |   |  ===> ... ===> |   |   ==> |   |   ==> |   |  ===> ...
         +---+---+            +---+---+   +---+---+   +---+---+

       | <====            list segment      =====> |

 | <====           list box segment     =====> |

    Try to define this predicate by yourself and prove [lbseg_lseg].
*)

Fixpoint lbseg (sigma: list Z) (x y: val) : mpred :=
  match sigma with
  | nil => !! (x = y) && emp
  | h::hs => EX (u: val), data_at Tsh (tptr t_struct_list) u x *
                          field_at Tsh t_struct_list [StructField _head] (Vint (Int.repr h)) u *
                          lbseg hs (field_address t_struct_list [StructField _tail] u) y
  end.
(** [] *)

Lemma lbseg_lseg: forall s3 x y z,
  lbseg s3 x y * data_at Tsh (tptr t_struct_list) z y |--
  EX y', data_at Tsh (tptr t_struct_list) y' x * lseg s3 y' z.
Proof.
  intros s3.
  induction s3; intros.
  - unfold lbseg; fold lbseg.
    unfold lseg; fold lseg.
    Exists z.
    entailer!.
  - unfold lbseg; fold lbseg.
    unfold lseg; fold lseg.
    Intros u. Exists u.
    sep_apply IHs3.
    Intros y'. Exists y'.
    unfold_data_at (data_at Tsh t_struct_list _ _).
    entailer!.
Qed.
(** [] *)

Lemma lbseg_app_r: forall s v x x' h,
  lbseg s x x' *
  field_at Tsh t_struct_list [StructField _head] (Vint (Int.repr v)) h *
  data_at Tsh (tptr t_struct_list) h x'
  |-- lbseg (s ++ [v]) x
      (field_address t_struct_list [StructField _tail] h).
Proof.
  intros s.
  induction s; intros.
  - rewrite app_nil_l.
    unfold lbseg; fold lbseg.
    Exists h.
    entailer!.
  - unfold lseg; fold lseg.
    rewrite <- app_comm_cons.
    unfold lbseg; fold lbseg.
    Intro u. Exists u.
    entailer!.
    sep_apply IHs.
    entailer!.
Qed.

(** Hint: adding more lemmas for [lbseg] may be useful. *)
Lemma body_append2: semax_body Vprog Gprog f_append2 append2_spec.
  start_function.
  forward.
  forward_while
    (EX (s11 s12: list Z) (h: val) (x': val),
        PROP (s1 = s11 ++ s12)
        LOCAL (temp _h h; temp _x x'; temp _y y)
        SEP (lbseg s11 x x'; listrep s12 h;
             listrep s2 y; data_at Tsh (tptr t_struct_list) h x'))%assert.
  {
    Exists (@nil Z) s1 p x.
    unfold lbseg; fold lbseg.
    entailer!.
  }
  {
    entailer!.
  }
  {
    assert_PROP (s12 <> []); [entailer!; apply HRE, H0; auto | ].
    destruct s12 as [ | s12a s12b]; [exfalso; auto | subst].
    unfold listrep; fold listrep.
    forward.
    - entailer!. unfold is_pointer_or_null in PNh.
      unfold nullval in HRE.
      destruct h; auto.
      destruct (Archi.ptr64) eqn: HArchi; auto.
      rewrite PNh in HRE; exfalso; auto.
    - clear H0. simpl.
      Intros y0.
      unfold_data_at (data_at Tsh t_struct_list _ _).
      Fail forward.
      assert_PROP (offset_val 4 h = field_address t_struct_list [StructField _tail] h). {
        entailer!.
        rewrite field_address_offset; auto.
      }
      forward.
      entailer!.
      Exists (s11 ++ [s12a], s12b, y0, field_address t_struct_list [StructField _tail] h).
      entailer!.
      + rewrite <- app_assoc. induction s11; auto.
      + entailer!. sep_apply lbseg_app_r. entailer!.
  }
  forward.
  sep_apply lbseg_lseg.
  Intro y'.
  Exists y'.
  entailer!.
  assert (s12 = []); [apply H2; auto | subst].
  unfold listrep; fold listrep.
  rewrite app_nil_r.
  entailer!.
  sep_apply lseg_list.
  entailer!.
Qed.
(** [] *)

End append2.

End List_seg.


(* My first theorem. *)

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

Definition lem := forall p, p \/ ~ p.

Theorem pierce_equiv_lem: pierce <-> lem.
Proof.
  unfold pierce, lem.
  firstorder.
  apply H with (q := ~ (p \/ ~ p)).
  tauto.
  firstorder.
  destruct (H p).
  assumption.
  tauto.
Qed.


Require Import Coq.Reals.Reals.
Require Import Coquelicot.Coquelicot.
Require Import Coq.micromega.Psatz.
Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Tactics.Tactics.
Require Import Control.Arithmetic.
Require Import Control.Barrier.
Require Import Control.Syntax.
Require Import Control.BarrierRules.
Require Import SMTC.Tactic.

Set SMT Solver "z3".
Local Transparent ILInsts.ILFun_Ops.

Section DblInt.

  (* The state of the system, position and velocity. *)
  (* Represented as a pair because Coquelicot has a NormedModule instance for pairs. *)
  Definition stateT : Type := R * R.
  Canonical state : NormedModule R_AbsRing :=
    prod_NormedModule R_AbsRing R_NormedModule R_NormedModule.
  Definition x : state -> R := fst.
  Definition v : state -> R := snd.

  (* The controller for the system. We leave it as a variable
     and impose conditions on it, rather than making it a concrete
     function. This allows one to instantiate it with anything
     satisfying those conditions. *)
  Variable u : state -> R.
  (* The maximum control magnitude. *)
  Variable umax : R.
  Hypothesis umax_gt_0 : umax > 0.
  Variable umin : R.
  Hypothesis umin_gt_0 : umin > 0.
  Hypothesis u_le_umax : forall st, u st <= umax.
  Hypothesis neg_umax_le_u : forall st, -umin <= u st.

  (* The bound between sample times. *)
  Variable T : R.
  Hypothesis T_gt_0 : T > 0.

  (* Some design parameters of the control constraints. *)
  Variable gamma : R.
  Hypothesis gamma_gt_0 : gamma > 0.

  (* Upper bound on u to enforce barrier invariance. *)
  Definition u_ub (st : state) :=
    if Rle_dec (v st) (umax * gamma)
    then (-1 / T * (gamma * v st + x st) - v st)/gamma
    else umax*(-1/T * (x st + umax * gamma * gamma/2 + v st * v st / (2 * umax)) - v st)/v st.
  Hypothesis u_barrier_constraint : forall st,
      u st <= u_ub st.

  (* A relationship between the various parameters to ensure
     that a control satisfying all constraints exists. *)
  Hypothesis umax_le_f_umin : umax <= umin/(1 + 2 * T/gamma).

  (* The sampled data evolution of the system, x' = v, v' = u *)
  Definition ODE (st' st smpl : state) : Prop :=
    x st' = v st /\ v st' = u smpl.

  (* The primary barrier function for this system. *)
  (* x + (umaxc*gamma^2)/2 + v^2/(2umaxc^2) *)
  Definition Barrier_sqr : barrier state :=
    x [+] (#umax[*]#gamma[*]#gamma[/]#2) [+] v[*]v[/](#2[*]#umax).
  (* gamma*v + x *)
  Definition Barrier_lin : barrier state :=
    (#gamma[*]v) [+] x.
  Definition Barrier : barrier state :=
    v ?<= umax*gamma [?] Barrier_lin [:] Barrier_sqr.

  Definition violation := 2 * umax * T.
  Lemma zero_le_violation : 0 <= violation.
  Proof.
    unfold violation. psatz R.
  Qed.

  Lemma exists_input :
    forall st, Barrier st <= violation * T ->
                 -umin <= u_ub st.
  Proof.
    unfold Barrier, violation, u_ub. intros. destruct st as [X V]. simpl in *.
    assert (/gamma > 0) as gamma_inv by (apply Rlt_gt; apply Rinv_0_lt_compat; psatzl R).
    assert (/T > 0) as T_inv by (apply Rlt_gt; apply Rinv_0_lt_compat; psatzl R).
    destruct (Rle_dec V (umax * gamma)).
    { unfold Barrier_lin in *. simpl in *.
      transitivity ((-1 / T * 2 * umax * T * T - V) / gamma).
      { unfold Rdiv. rewrite r by psatzl R. field_simplify; try psatzl R.
        assert (-umin / (1 + 2 * T / gamma) <= -umax) by psatzl R.
        unfold Rdiv. unfold Rminus. replace (-2 * T * umax) with (2 * T * -umax) by field.
        replace (- (umax * gamma)) with (-umax * gamma) by field.
        rewrite <- H0 by psatzl R. right. field. psatzl R. }
      { unfold Rdiv. apply Rmult_le_compat_r; try psatzl R. apply Rplus_le_compat_r.
        repeat rewrite Rmult_assoc. apply Rmult_le_compat_neg_l; [ psatzl R | ].
        apply Rmult_le_compat_l; psatzl R. } }
    { unfold Barrier_sqr in *. simpl in *.
      assert (0 <= / V) as V_inv by (left; apply Rlt_gt; apply Rinv_0_lt_compat; psatz R).
      transitivity (umax * (-1 / T * 2 * umax * T * T - V) / V).
      { replace (umax * (-1 / T * 2 * umax * T * T - V) / V)
        with (2 * (- umax) * umax * T * / V + - umax) by (field; psatz R).
        assert (-umin / (1 + 2 * T / gamma) <= -umax) by psatzl R.
        rewrite <- H0; try psatzl R.
        { replace (2 * (- umin / (1 + 2 * T / gamma)) * umax * T * / V)
          with (2 * (umin / (1 + 2 * T / gamma)) * umax * T * (/ -V)) by (field; psatz R).
          assert (/( - umax * gamma) <= / - V).
          { left. apply Rinv_lt_contravar.
            { ring_simplify. repeat apply Rmult_lt_0_compat; psatz R. }
            { psatzl R. } }
          rewrite <- H1.
          { right. field. psatz R. }
          { apply Rle_ge. left. repeat (apply Rmult_lt_0_compat; [ | psatzl R]). psatzl R. } } }
      { apply Rmult_le_compat_r; auto. apply Rmult_le_compat_l; [ psatzl R | ].
        apply Rplus_le_compat_r. repeat rewrite Rmult_assoc.
        apply Rmult_le_compat_neg_l; psatzl R. } }
  Qed.

  (* Derivative of the barrier function. *)
  (* x' + v*v'/umaxc *)
  Definition dBarrier_sqr : dbarrier state :=
    d[x] [[+]] $[v][[*]]d[v][[/]]##umax.
  (* gamma*v' + x' *)
  Definition dBarrier_lin : dbarrier state :=
    ##gamma[*]d[v] [[+]] d[x].
  Definition dBarrier : dbarrier state :=
    $[v] ??<= umax*gamma [?] dBarrier_lin [:] dBarrier_sqr.

  Lemma dBarrier_valid :
      derive_barrier Barrier dBarrier.
  Proof.
    eapply Proper_derive_barrier_dom
    with (G1:=ltrue) (G2:=fun _ => True) (e1:=Barrier).
    { reflexivity. }
    { breakAbstraction. intros. reflexivity. }
    { unfold Barrier, Barrier_sqr, Barrier_lin.
      apply derive_barrier_piecewise.
      { auto_derive_barrier.
        { apply derive_barrier_snd_R. }
        { apply derive_barrier_fst_R. } }
      { auto_derive_barrier.
        { apply derive_barrier_fst_R. }
        { simpl. intros. psatzl R. }
        { apply derive_barrier_snd_R. }
        { apply derive_barrier_snd_R. }
        { simpl. intros. psatzl R. } }
      { simpl. intros. destruct H. rewrite H0. rewrite_R0.
        unfold Rdiv at 1. rewrite_R0. field. psatzl R. }
      { simpl. intros. destruct H. rewrite H0. field. psatzl R. }
      { intros. apply continuous_snd. } }
    { unfold dBarrier, dBarrier_sqr, dBarrier_lin.
      simpl. intros. destruct (Rle_dec (v t0) (umax * gamma)).
      { rewrite_R0. unfold v, x. reflexivity. }
      { rewrite_R0. destruct t. destruct t0. simpl. field. psatzl R. } }
  Qed.

  (* The derivative of the barrier function is continuous. *)
  Lemma continuous_dBarrier :
    continuous_dB ltrue dBarrier.
  Proof.
    unfold dBarrier, dBarrier_sqr, dBarrier_lin.
    apply continuous_dB_piecewise.
    { auto_continuous_dB; try continuous_dB_vars. }
    { auto_continuous_dB; try continuous_dB_vars.
      simpl. intros. psatzl R. }
    { simpl.  intros. rewrite H. field. psatzl R. }
    { intros. apply continuous_snd. }
  Qed.

  (* The relation characterizing intersample behavior of the system. *)
  Definition intersample (smpl st : state) : Prop :=
    if Rle_dec 0 (u smpl)
    then v smpl <= v st <= v smpl + u smpl * T
    else v smpl + u smpl * T <= v st <= v smpl.

  (* The intersample relation is a valid characterization of intersample behavior. *)
  Lemma intersample_valid :
    forall (sample : nat -> R),
      bounded_samples sample T ->
      sampled_data ODE sample |--
      intersample_relation_valid2 intersample sample.
  Proof.
    intros. simpl. unfold sampled_data, intersample_relation_valid2.
    intros F Hsol n t Ht. unfold intersample. destruct Hsol as [D [Dcont [DF DFf]]].
    unfold ODE in DFf.
    assert (forall t,
               sample n <= t < sample (S n) ->
               is_derive (fun t => v (F t)) t (u (F (sample n)))) as Hderive.
    { intros. specialize (DFf n t0 H0). destruct DFf. rewrite <- H2. apply is_derive_snd; auto. }
    assert (is_RInt (fun _ => (u (F (sample n)))) (sample n) t (v (F t) - v (F (sample n)))) as HRInt.
    { apply is_RInt_derive with (f:=fun t => v (F t)).
      { intros. apply Hderive. rewrite Rmin_left in H0 by psatzl R.
        rewrite Rmax_right in H0 by psatzl R. psatzl R. }
      { intros. apply continuous_const. } }
    apply is_RInt_unique in HRInt. rewrite RInt_const in HRInt.
    destruct (Rle_dec 0 (u (F (sample n))));
      specialize (H n); psatz R.
  Qed.

  Lemma intersample_derive_bound :
    forall st' stk' st stk : state,
      intersample stk st ->
      ODE st' st stk -> ODE stk' stk stk ->
      dBarrier st' st <= Rmax (dBarrier stk' stk + violation) 0.
  Proof.
    unfold violation, intersample, ODE, dBarrier. simpl. intros. destruct H0. destruct H1.
    assert (/umax > 0) as umax_inv by (apply Rlt_gt; apply Rinv_0_lt_compat; psatzl R).
    destruct (Rle_dec (v st) (umax * gamma)).
    { destruct (Rle_dec (v stk) (umax * gamma)).
      { unfold dBarrier_lin. simpl. rewrite H0. rewrite H2.
        rewrite H1. rewrite H3. rewrite <- Rmax_l. destruct (Rle_dec 0 (u stk)).
        { destruct H. rewrite H4. rewrite u_le_umax at 2 by psatzl R. psatz R. }
        { destruct H. rewrite H4. rewrite <- zero_le_violation. psatzl R. } }
      { destruct (Rle_dec 0 (u stk)).
        { psatzl R. }
        { destruct (Rle_dec (u stk) (-umax)).
          { rewrite <- Rmax_r. unfold dBarrier_lin. simpl. rewrite H0. rewrite H2.
            rewrite r0 by psatzl R. rewrite r. psatzl R. }
          { rewrite <- Rmax_l. unfold dBarrier_lin, dBarrier_sqr. simpl. rewrite H0.
            rewrite H2. rewrite H3. rewrite H1.
            assert (gamma * u stk - v stk * u stk / umax <= umax * T).
            { replace (gamma * u stk - v stk * u stk / umax)
              with ((- u stk) * (v stk / umax - gamma)) by (field; psatzl R).
              unfold Rdiv. assert (v stk <= v st - u stk * T) by psatzl R. rewrite H4 by psatzl R.
              rewrite r by psatzl R. assert (- u stk <= umax) by psatzl R.
              unfold Rminus. replace (- (u stk * T)) with ((- u stk) * T) by field.
              rewrite H5 at 2 by psatzl R. rewrite H5.
              { field_simplify; try psatzl R. }
              { field_simplify; try psatzl R. rewrite Rmult_comm. field_simplify; try psatzl R. } }
            psatz R. } } } }
    { destruct (Rle_dec (v stk) (umax * gamma)).
      { unfold dBarrier_lin, dBarrier_sqr. simpl. rewrite H0. rewrite H2.
        rewrite H1. rewrite H3. destruct (Rle_dec 0 (u stk)).
        { rewrite <- Rmax_l. destruct H. rewrite H4 at 1.
          assert (v st * u stk / umax + u stk * T - gamma * u stk <= 2 * umax * T).
          { replace (v st * u stk / umax + u stk * T - gamma * u stk)
            with (u stk * (v st / umax + T - gamma)) by (field; psatzl R).
            unfold Rdiv. rewrite H4 by psatzl R. rewrite r by psatzl R.
            rewrite u_le_umax at 1.
            { field_simplify; try psatzl R. repeat rewrite Rdiv_1. rewrite u_le_umax by psatzl R.
              right. field. }
            { apply Rle_ge. rewrite <- r0 by psatzl R. rewrite Rmult_0_l. rewrite Rplus_0_r.
              field_simplify; psatzl R. } }
          psatzl R. }
        { psatzl R. } }
      { unfold dBarrier_sqr. simpl. rewrite H0. rewrite H1. rewrite H2. rewrite H3.
        destruct (Rle_dec 0 (u stk)).
        { rewrite <- Rmax_l. destruct H.
          replace (v st + v st * u stk / umax) with (v st * (1 + u stk / umax)) by (field; psatzl R).
          rewrite H4.
          { replace ((v stk + u stk * T) * (1 + u stk / umax))
            with (v stk + v stk * u stk / umax + u stk * T + u stk * u stk * T / umax)
              by (field; psatzl R).
            repeat rewrite Rplus_assoc. repeat apply Rplus_le_compat_l.
            rewrite u_le_umax at 1 by psatzl R. unfold Rdiv. rewrite u_le_umax at 1 by psatzl R.
            rewrite u_le_umax at 1 by psatzl R. field_simplify; psatzl R. }
          { apply Rle_ge. unfold Rdiv. rewrite <- r by psatzl R. psatzl R. } }
        { destruct (Rle_dec (u stk) (-umax)).
          { rewrite <- Rmax_r. unfold Rdiv. rewrite r by psatz R. right. field. psatzl R. }
          { rewrite <- Rmax_l.
            replace (v st + v st * u stk / umax)
            with (v st * (1 + u stk / umax)) by (field; psatzl R).
            destruct H. rewrite H4.
            { rewrite <- zero_le_violation. right. field. psatzl R.  }
            { assert (-umax <= u stk) by psatzl R. apply Rle_ge. unfold Rdiv.
              rewrite <- H5 by psatzl R. right. field. psatzl R. } } } } }
  Qed.

  (* The "inductive" condition on the barrier function, i.e. its derivative
     is proportional to its value. *)
  Lemma Barrier_inductive :
      |-- exp_condition2 _ Barrier dBarrier ODE (-1/T).
  Proof.
    unfold exp_condition2, Barrier, dBarrier, ODE, u_ub in *.
    simpl. intros x xk Blah H. destruct H. specialize (u_barrier_constraint xk).
    destruct (Rle_dec (v xk) (umax * gamma)).
    { unfold dBarrier_lin, Barrier_lin. simpl. rewrite H. rewrite H0.
      rewrite u_barrier_constraint; try psatzl R. right. field. psatzl R. }
    { unfold dBarrier_sqr, Barrier_sqr. simpl. rewrite H. rewrite H0.
      unfold Rdiv. rewrite u_barrier_constraint.
      { right. field. repeat split; try psatzl R. psatz R. }
      { psatz R. }
      { apply Rgt_lt in umax_gt_0. apply Rinv_0_lt_compat in umax_gt_0. psatzl R. } }
  Qed.

  (* Invariance of the barrier region. *)
  Theorem barrier_inv :
    forall (sample : nat -> R),
      well_formed_samples sample ->
      bounded_samples sample T ->
      sampled_data ODE sample //\\
      !(Barrier [<=] #(violation * T))
      |-- [](Barrier [<=] #(violation * T)).
  Proof.
    intros. eapply barrier_exp_condition_sampled3 with (P:=ltrue); eauto.
    { apply dBarrier_valid. }
    { apply continuous_dBarrier. }
    { charge_tauto. }
    { rewrite intersample_valid; [ charge_tauto | assumption ]. }
    { rewrite <- Barrier_inductive. charge_tauto. }
    { apply intersample_derive_bound. }
    { unfold violation. psatz R. }
    { unfold always. simpl. auto. }
    { charge_tauto. }
  Qed.

  Lemma gamma_inv_gt_0 :
   / gamma > 0.
  Proof.
    apply Rlt_gt; apply Rinv_0_lt_compat; psatzl R.
  Qed.

  Lemma barrier_imp_x_lt_0 :
    forall stk : state,
      $[ Barrier [<=] # (violation * T)]
       |-- exp_inductive state (fun st' st : state => ODE st' st stk)
       (x [-] # (violation * T)) (d[x] [[-]] ## 0)
       (-/gamma).
  Proof.
    unfold Barrier, Barrier_lin, Barrier_sqr, exp_inductive, ODE. simpl. intros.
    destruct H0. rewrite H0. rewrite_R0. pose proof gamma_inv_gt_0.
    destruct (Rle_dec (v t0) (umax * gamma)).
    { replace (- / gamma * (x t0 - violation * T))
      with (/ gamma * (violation * T - x t0)) by (field; psatzl R).
      rewrite <- H by psatzl R. right. field. psatzl R. }
    { rewrite Rmult_comm. rewrite <- Ropp_mult_distr_r. rewrite Ropp_mult_distr_l.
      apply Rle_div_r; [ psatzl R | ].
      replace (- (x t0 - violation * T)) with (violation * T - x t0) by (field; psatzl R).
      rewrite <- H. unfold Rdiv. assert (umax * gamma <= v t0) by psatzl R.
      clear H n H3 H2 H0 H1 umax_le_f_umin u_barrier_constraint T_gt_0 umin_gt_0
            u_le_umax neg_umax_le_u gamma_gt_0. apply Rmult_le_reg_l with (r:=2*umax).
      { psatz R. }
      { field_simplify; try psatzl R. repeat rewrite Rdiv_1. simpl. psatz R. } }
  Qed.

  Theorem x_lt_0 :
    forall (sample : nat -> R),
      well_formed_samples sample ->
      bounded_samples sample T ->
      sampled_data ODE sample //\\
      !(Barrier [<=] #(violation * T)) //\\
      !(x [-] #(violation * T) [<=] #0)
      |-- [](x [-] #(violation * T) [<=] #0).
  Proof.
    intros. eapply barrier_exp_condition_sampled_weak
            with (P:=Barrier [<=] #(violation * T)) (lambda:=(-/gamma)); eauto.
    { apply derive_barrier_minus; [apply derive_barrier_fst_R | apply derive_barrier_pure]. }
    { auto_continuous_dB. apply continuous_dB_dfst. }
    { charge_tauto. }
    { apply barrier_imp_x_lt_0. }
    { rewrite <- barrier_inv; eauto. charge_tauto. }
    { charge_tauto. }
  Qed.

End DblInt.


Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 138 lines to 78 lines. *)
Set Implicit Arguments.
Generalizable All Variables.
Set Universe Polymorphism.
Delimit Scope object_scope with object.
Delimit Scope morphism_scope with morphism.
Delimit Scope category_scope with category.
Record Category (obj : Type) :=
  {
    Object :> _ := obj;
    Morphism : obj -> obj -> Type;

    Identity : forall x, Morphism x x;
    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
  }.

Arguments Identity {obj%type} [!C%category] x%object : rename.
Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
Bind Scope category_scope with Category.

Record Functor `(C : @Category objC) `(D : @Category objD)
  := { ObjectOf :> objC -> objD;
       MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) }.

Record NaturalTransformation `(C : @Category objC) `(D : @Category objD) (F G : Functor C D)
  := { ComponentsOf :> forall c, D.(Morphism) (F c) (G c) }.

Definition ProductCategory `(C : @Category objC) `(D : @Category objD)
: @Category (objC * objD)%type
  := @Build_Category _
                     (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type)
                     (fun o => (Identity (fst o), Identity (snd o)))
                     (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))).

Infix "*" := ProductCategory : category_scope.

Record IsomorphismOf `{C : @Category objC} {s d} (m : C.(Morphism) s d) :=
  { IsomorphismOf_Morphism :> C.(Morphism) s d := m;
    Inverse : C.(Morphism) d s }.

Record NaturalIsomorphism `(C : @Category objC) `(D : @Category objD) (F G : Functor C D)
  := { NaturalIsomorphism_Transformation :> NaturalTransformation F G;
       NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x) }.

Section PreMonoidalCategory.
  Context `(C : @Category objC).
  Definition TriMonoidalProductL : Functor (C * C * C) C.
    admit.
  Defined.
  Definition TriMonoidalProductR : Functor (C * C * C) C.
    admit.
  Defined. (** Replacing [admit. Defined.] with [Admitted.] satisfies the constraints *)
  Variable Associator : NaturalIsomorphism TriMonoidalProductL TriMonoidalProductR.
  (* Toplevel input, characters 15-96:
Error: Unsatisfied constraints:
Coq.Init.Datatypes.28 <= Coq.Init.Datatypes.29
Top.168 <= Coq.Init.Datatypes.29
Top.168 <= Coq.Init.Datatypes.28
Top.169 <= Coq.Init.Datatypes.29
Top.169 <= Coq.Init.Datatypes.28
 (maybe a bugged tactic). *)


From mathcomp Require Import ssreflect ssrbool eqtype.
Require Import Arith List String Lia.
Require Import Program Relations Wellfounded Lexicographic_Product.
From QuickChick Require Import QuickChick.
From QuickChick.stlc Require Import monad.

Import ListNotations.

Definition tvar := nat.
Definition var := nat.

Inductive type : Type :=
| N : type
| Arrow : type -> type -> type.

Definition type_eq_dec (t1 t2 : type) : {t1 = t2} + {t1 <> t2}.
Proof. do 2 decide equality. Defined.

Fixpoint type_size (tau : type) : nat :=
  match tau with
    | N => 0
    | Arrow tau1 tau2 =>
      1 + (type_size tau1 + type_size tau2)
  end.

Definition lt_type (tau1 tau2 : type) : Prop :=
  type_size tau1 < type_size tau2.

Lemma wf_lt_type : well_founded lt_type.
Proof.
  unfold lt_type. apply wf_inverse_image. apply lt_wf.
Qed.

Inductive term : Type :=
| Const : nat -> term
| Id : var -> term
| App : term -> term -> term
| Abs : term -> term.

(* Terms that do not have applications *)
Inductive app_free : term -> Prop :=
| ConsNoApp : forall n, app_free (Const n)
| IdNoApp : forall x, app_free (Id x)
| AbsNoApp : forall (t : term),
               app_free t -> app_free (Abs t).

(* Number of applications in a term *)
Fixpoint app_no (t : term) : nat :=
  match t with
    | Const _ | Id _ => 0
    | Abs t => app_no t
    | App t1 t2 => 1 + (app_no t1 + app_no t2)
  end.

Definition env := list type.

Inductive bind : env -> nat -> type -> Prop :=
| BindNow   : forall tau env, bind (tau :: env) 0 tau
| BindLater : forall tau tau' x env,
    bind env x tau -> bind (tau' :: env) (S x) tau.

Inductive typing (e : env) : term -> type -> Prop :=
| TId :
    forall x tau,
      nth_error e x = Some tau ->
      typing e (Id x) tau
| TConst :
    forall n,
      typing e (Const n) N
| TAbs :
    forall t tau1 tau2,
      typing (tau1 :: e) t tau2 ->
      typing e (Abs t) (Arrow tau1 tau2)
| TApp :
    forall t1 t2 tau1 tau2,
      typing e t1 (Arrow tau1 tau2) ->
      typing e t2 tau1 ->
      typing e (App t1 t2) tau2.

Inductive typing' (e : env) : term -> type -> Prop :=
| TId' :
    forall x tau,
      bind e x tau ->
      typing' e (Id x) tau
| TConst' :
    forall n,
      typing' e (Const n) N
| TAbs' :
    forall t tau1 tau2,
      typing' (tau1 :: e) t tau2 ->
      typing' e (Abs t) (Arrow tau1 tau2)
| TApp' :
    forall t1 t2 tau1 tau2 tau12,
      typing' e t2 tau1 ->
      typing' e t1 tau12 ->
      tau12 = Arrow tau1 tau2 ->
      typing' e (App t1 t2) tau2.

Derive Arbitrary for type.
Instance dec_type (t1 t2 : type) : Dec (t1 = t2).
Proof. dec_eq. Defined.
Derive ArbitrarySizedSuchThat for (fun x => bind env x tau).
Derive ArbitrarySizedSuchThat for (fun t => typing' env t tau).

Instance ESST_A2 (t t1 : type) : EnumSizedSuchThat _ (fun t2 => t = Arrow t1 t2) :=
  { enumSizeST := fun _ => match t with
                           | Arrow t1' t2 =>
                             if t1 = t1'? then
                               returnEnum (Some t2)
                             else returnEnum None
                           | _ => returnEnum None
                           end }.

Derive EnumSized for type.
Derive EnumSizedSuchThat for (fun tau => bind env x tau).
Derive EnumSizedSuchThat for
       (fun tau => typing' env t tau).

Derive DecOpt for (bind env t tau).
Derive DecOpt for (typing' env t tau).

Inductive option_le : option nat -> option nat -> Prop :=
    | opt_le_1 : option_le None None
    | opt_le_2 : forall n, option_le None (Some n)
    | opt_le_3 : forall n m : nat,
                   n <= m -> option_le (Some n) (Some m).

(* The following keeps track of the size of largest type that appears in a cut
   in the derivation tree. Needed for verification purposes *)
Inductive typing_max_tau (e : env) : term -> type -> nat -> Prop :=
| TIdMax :
    forall x tau,
      nth_error e x = Some tau ->
      typing_max_tau e (Id x) tau 0
| TConstMax :
    forall n,
      typing_max_tau e (Const n) N 0
| TAbsMax :
    forall t tau1 tau2 m,
      typing_max_tau (tau1 :: e) t tau2 m ->
      typing_max_tau e (Abs t) (Arrow tau1 tau2) m
| TAppMax :
    forall t1 t2 tau1 tau2 m1 m2,
      typing_max_tau e t1 (Arrow tau1 tau2) m1 ->
      typing_max_tau e t2 tau1 m2 ->
      typing_max_tau e (App t1 t2) tau2 (max (type_size tau1) (max m1 m2)).

Lemma typing_max_tau_correct :
  forall e t tau,
    (exists m, typing_max_tau e t tau m) <->
    typing e t tau.
Proof.
  intros. split.
  - move => [maxt H]. induction H; econstructor; eauto.
  - move => H.
    induction H; (try now eexists; econstructor; eauto).
    destruct IHtyping as [m H']. exists m. constructor; auto.
    destruct IHtyping1 as [m1 H1];
    destruct IHtyping2 as [m2 H2]. eexists. econstructor; eauto.
Qed.

Lemma typing_max_no_app :
  forall e t tau,
    app_free t ->
    typing e t tau ->
    typing_max_tau e t tau 0.
Proof.
  intros e t tau H. generalize e tau. clear e tau.
  induction H; intros e tau H1; inversion H1; subst; constructor; auto.
Qed.

(* Small step CBV semantics *)
Fixpoint is_value (t : term) : bool :=
  match t with
    | Const _ | Abs _ => true
    | _ => false
  end.

Fixpoint subst (y : var) (t1 : term) (t2 : term) : term :=
  match t2 with
    | Const n => Const n
    | Id x =>
      if eq_nat_dec x y then t1 else t2
    | App t t' =>
      App (subst y t1 t) (subst y t1 t')
    | Abs t =>
      subst (S y) t1 t
  end.

Fixpoint step (t : term) : option term :=
  match t with
    | Const _ | Id _ => None | Abs x => None
    | App t1 t2 =>
      if is_value t1 then
        match t1 with
          | Abs t =>
            if is_value t2 then ret (subst 0 t1 t)
            else
              t2' <- step t2;;
              ret (App t1 t2')
          | _ => None
        end
      else
        t1' <- step t1;;
        ret (App t1' t2)
  end.

(* Generators *)
Module DoNotation.
Notation "'do!' X <- A ; B" :=
  (bindGen A (fun X => B))
    (at level 200, X ident, A at level 100, B at level 200).
End DoNotation.
Import DoNotation.

(* Sized generator of simple types *)
Fixpoint gen_type_size (n : nat) : G type :=
  match n with
    | 0 => returnGen N
    | S n' =>
      do! m <- choose (0, n');
          liftGen2 Arrow (gen_type_size (n' - m)) (gen_type_size (n' - (n' - m)))
  end.

(* Generator of simple types *)
Definition gen_type : G type := bindGen arbitrary gen_type_size.

(* Returns the list of bindings that have type tau in e *)
Definition vars_with_type (e : env) (tau : type) : list term :=
  map (fun p => Id (snd p))
      (filter (fun p => proj1_sig (Sumbool.bool_of_sumbool (type_eq_dec tau (fst p))))
              (combine e (seq 0 (List.length e)))).

Definition sigT_of_prod {A B : Type} (p : A * B) : {_ : A & B} :=
  let (a, b) := p in existT (fun _ : A => B) a b.

Definition lt_pair (c1 c2 : (nat * type)) : Prop :=
  lexprod nat (fun _ => type) lt (fun _ => lt_type) (sigT_of_prod c1) (sigT_of_prod c2).

Lemma wf_lt_pair : well_founded lt_pair.
Proof.
  unfold lt_pair. apply wf_inverse_image.
  apply wf_lexprod. now apply Wf_nat.lt_wf. intros _; now apply wf_lt_type.
Qed.

(* Generator of app-free well-typed terms of type tau *)
Fixpoint gen_term_no_app (tau : type)  (e : env) : G term :=
  match vars_with_type e tau with
    | [] =>
      match tau with
        | N => liftGen Const arbitrary
        | Arrow tau1 tau2 =>
          liftGen Abs (gen_term_no_app tau2 (tau1 :: e))
      end
    | def :: vars =>
      oneOf_ (returnGen def)
            [ match tau with
                | N => liftGen Const arbitrary
                | Arrow tau1 tau2 =>
                   liftGen Abs (gen_term_no_app tau2 (tau1 :: e))
              end;
              elems_ def (def :: vars)]
  end.

(* Generator of well-typed terms of type tau. [fst p] is the maximum number of applications *)
Program Fixpoint gen_term_size (p : nat * type) {wf lt_pair p} : env -> G term :=
  fun (e : env) => (* apparently with this trick we get a more manageable term *)
  match p with
    | (0, tau) => gen_term_no_app tau e
    | (S n', tau) =>
      match vars_with_type e tau with
        | [] =>
            oneOf_ (gen_term_no_app tau e)
            [ (do! tau' <- gen_type;
               do! m <- choose (0, n');
               do! m' <- choose (n' -  m, n');
               liftGen2 App (@gen_term_size (n' - m, (Arrow tau' tau)) _ e)
                        (@gen_term_size (n' - m', tau') _ e));
              (match tau with
                 | N => liftGen Const arbitrary
                 | Arrow tau1 tau2 =>
                   liftGen Abs (@gen_term_size (S n', tau2) _ (tau1 :: e))
               end)]
        | def :: vars =>
            oneOf_ (gen_term_no_app tau e)
            [ (do! tau' <- gen_type;
               do! m <- choose (0, n');
               do! m' <- choose (n' - m, n');
               liftGen2 App (@gen_term_size (n' - m, (Arrow tau' tau)) _ e)
                        (@gen_term_size (n' - m', tau') _ e));
              (match tau with
                 | N => liftGen Const arbitrary
                 | Arrow tau1 tau2 =>
                   liftGen Abs (@gen_term_size (S n', tau2) _ (tau1 :: e))
               end);
              elems_ def (def :: vars) ]
      end
  end.
Solve Obligations with
  program_simpl; unfold lt_pair; apply left_lex; lia.
Solve Obligations with
  program_simpl; unfold lt_pair; apply right_lex; unfold lt_type; simpl; lia.
Next Obligation.
  unfold MR. apply wf_inverse_image. apply wf_lt_pair.
Defined.

Definition gen_term_size_unfold (p : nat * type) (e : env) : G term :=
  match p with
    | (0, tau) => gen_term_no_app tau e
    | (S n', tau) =>
      match vars_with_type e tau with
        | [] =>
            oneOf_ (gen_term_no_app tau e)
            [ (do! tau' <- gen_type;
               do! m <- choose (0, n');
               do! m' <- choose (n' - m, n');
               liftGen2 App (gen_term_size (n' - m, (Arrow tau' tau)) e)
                        (gen_term_size (n' - m', tau') e));
              (match tau with
                 | N => liftGen Const arbitrary
                 | Arrow tau1 tau2 =>
                   liftGen Abs (@gen_term_size (S n', tau2) (tau1 :: e))
               end)]
        | def :: vars =>
            oneOf_ (gen_term_no_app tau e)
            [ (do! tau' <- gen_type;
               do! m <- choose (0, n');
               do! m' <- choose (n' - m, n');
               liftGen2 App (gen_term_size (n' - m, (Arrow tau' tau)) e)
                        (@gen_term_size (n' - m', tau') e));
              (match tau with
                 | N => liftGen Const arbitrary
                 | Arrow tau1 tau2 =>
                   liftGen Abs (gen_term_size (S n', tau2) (tau1 :: e))
               end);
              elems_ def (def :: vars) ]
      end
  end.

Import WfExtensionality.

Lemma gen_term_size_eq (e : env) (p : nat * type) :
  gen_term_size p e =
  gen_term_size_unfold p e.
Proof.
  unfold_sub gen_term_size (gen_term_size p e); simpl.
  destruct p as [[|n] [|]]; try reflexivity;
  destruct (vars_with_type e _) eqn:Heq; simpl;
  repeat (rewrite !Heq /=; apply f_equal; try reflexivity).
Qed.

Global Opaque gen_term_size.

Definition gen_term (tau : type) :=
  sized (fun s => gen_term_size (s, tau) []).

Open Scope string.

Fixpoint show_type (tau : type) :=
  match tau with
    | N => "Nat"
    | Arrow tau1 tau2 =>
      "(" ++ show_type tau1 ++ " -> " ++ show_type tau2 ++ ")"
  end.

Instance showType : Show type := { show := show_type }.

Fixpoint show_term (t : term) :=
  match t with
    | Const n => show n
    | Id x => "Id" ++ show x
    | App t1 t2 => "(" ++ show_term t1 ++ " " ++ show_term t2 ++ ")"
    | Abs t => "λ.(" ++ show_term t ++ ")"
  end.

Close Scope string.

Instance showTerm : Show term := { show := show_term }.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.

Section ListLexOrder.
  Variable T : Type.
  Variable cmp : T -> T -> comparison.

  Fixpoint list_lex_cmp (ls rs : list T) : comparison :=
    match ls , rs with
      | nil , nil => Eq
      | nil , _ => Lt
      | _ , nil => Gt
      | l :: ls , r :: rs =>
        match cmp l r with
          | Eq => list_lex_cmp ls rs
          | x => x
        end
    end.
End ListLexOrder.

Section Sorting.
  Variable T : Type.
  Variable cmp : T -> T -> comparison.

  Section insert.
    Variable val : T.

    Fixpoint insert_in_order (ls : list T) : list T :=
      match ls with
        | nil => val :: nil
        | l :: ls' =>
          match cmp val l with
            | Gt => l :: insert_in_order ls'
            | _ => val :: ls
          end
      end.
  End insert.

  Fixpoint sort (ls : list T) : list T :=
    match ls with
      | nil => nil
      | l :: ls =>
        insert_in_order l (sort ls)
    end.

End Sorting.

Lemma insert_in_order_inserts : forall T C x l,
  exists h t, insert_in_order T C x l = h ++ x :: t /\ l = h ++ t.
Proof.
  clear. induction l; simpl; intros.
  exists nil; exists nil; eauto.
  destruct (C x a).
  exists nil; simpl. eauto.
  exists nil; simpl. eauto.
  destruct IHl. destruct H. intuition. subst.
  rewrite H0. exists (a :: x0). exists x1. simpl; eauto.
Qed.

Lemma sort_permutation : forall T (C : T -> T -> _) x,
  Permutation (sort _ C x) x.
Proof.
  induction x; simpl.
  { reflexivity. }
  { destruct (insert_in_order_inserts T C a (sort T C x)) as [ ? [ ? ? ] ].
    destruct H. rewrite H. rewrite <- Permutation_cons_app. reflexivity. rewrite H0 in *. symmetry; auto. }
Qed.


Require Import Coqlib.
Require Import Integers.
Require Import List. Import ListNotations.
Require Import pure_lemmas.

Lemma skipn_add {A}: forall t n (ch:list A),
      skipn (t+n) ch = skipn n (skipn t ch).
Proof.
  induction t; simpl. trivial.
  intros. destruct ch.
    rewrite skipn_nil; trivial.
  rewrite IHt; trivial.
Qed.

Lemma firstn_app1 {A}: forall n (l t:list A),
   (n >= length l)%nat -> firstn n (l++t) = l ++ firstn (n-length l) t.
Proof. intros n; induction n; simpl; intros.
  destruct l; simpl in *; trivial. omega.
  destruct l; simpl in *. trivial. rewrite IHn. trivial. omega.
Qed.

Lemma firstn_nil {A}: forall m, firstn m (nil:list A) = (nil:list A).
Proof. intros. rewrite firstn_same. trivial. simpl. omega. Qed.

Lemma skipn_all {A}: forall l, skipn (length l) l = (nil:list A).
Proof. intros l.
  induction l; simpl; trivial.
Qed.
Lemma skipn_all' {A}: forall n l, (n>=length l)%nat -> skipn n l = (nil:list A).
Proof. intros n.
  induction n; simpl; trivial. intros. destruct l; simpl in *; trivial. omega.
  intros. destruct l; simpl in *; trivial. apply IHn. omega.
Qed.

Lemma firstn_list_repeat1 {A} k n (x:A) (N: (n>=k)%nat):
      firstn n (list_repeat k x) = list_repeat k x.
Proof.
  intros. specialize (firstn_app1 n (list_repeat k x) nil).
  rewrite app_nil_r. intros. rewrite H.
   rewrite firstn_nil. apply app_nil_r.
  rewrite length_list_repeat. apply N.
Qed.

Lemma firstn_list_repeat2 {A}: forall k n (x:A) (N: (n<=k)%nat),
      firstn n (list_repeat k x) = list_repeat n x.
Proof.
  intros k.
  induction k. simpl. intros. destruct n; simpl. trivial. omega.
  simpl; intros. destruct n; simpl in *.  trivial.
  rewrite IHk. trivial. omega.
Qed.

Lemma firstn_geq {A}: forall k (l:list A),
    (k>=length l)%nat ->  firstn k l = l.
Proof.
  induction k; simpl; intros. destruct l; trivial. simpl in *; omega.
destruct l. trivial. f_equal. apply IHk. simpl in *; omega.
Qed.

Lemma rev_list_repeat {A} (a:A): forall n, rev (list_repeat n a) = list_repeat n a.
Proof. induction n; simpl; trivial. rewrite IHn; clear IHn.
specialize (list_repeat_app A); intros Q.
rewrite (Q n (1%nat)).
specialize (Q (1%nat) n). rewrite plus_comm in Q. simpl in Q. rewrite Q; trivial.
Qed.

Lemma zadd_zero_nonneg p q: 0 = p + q -> 0 <=p -> q>= 0 -> p=0 /\ q=0.
Proof. omega. Qed.

Lemma list_nil_length {A} (l:list A): l= [] -> (length l <= 0)%nat.
Proof. intros. subst. trivial. Qed.


Require Import Bool.Bvector.
Require Import ZArith.
Require Import QArith.
Require Import ZArith.Znumtheory.
Require Import ZArith.BinInt.
Require Import QArith.Qabs.
Require Import Vectors.Fin.
Require Import Vectors.VectorDef.
Require Import Vectors.VectorSpec.
Require Import Vectors.Vector.

Open Scope nat_scope.

Definition div_eucl_z := BinIntDef.Z.div_eucl.

Fixpoint getAcc (n:nat) : Q :=
match n with
|O => 1#1
|S m => Qmult (1#10) (getAcc m)
end.

(*double*)

Definition lenExp : nat := 11.
Definition lenSign : nat :=52.
Definition sqrtEps : Q := getAcc 50.

(*single*)
(*
Definition lenExp : nat := 8.
Definition lenSign : nat :=23.
(*1e-10*)
Definition sqrtEps : Q := getAcc 25.
*)
Fixpoint getPowerTwo (power : nat) :=
match power with
|O => 1
|S m => 2* (getPowerTwo m)
end.

Fixpoint getMaxExp (lenExp : nat) : nat :=
match lenExp with
|O => O
|S m => let result := getPowerTwo m in
        match result with
        |O => O
        |S n => n
        end
end.

Fixpoint getAllFalseVector (len : nat) : Bvector len :=
match len with
|O => Vector.nil bool
|S m => Vector.cons bool false m (getAllFalseVector m)
end.

Fixpoint getAllTrueVector (len : nat) : Bvector len :=
match len with
|O => Vector.nil bool
|S m => Vector.cons bool true m (getAllTrueVector m)
end.

Fixpoint getNotAllFalseVector (len:nat) : Bvector len :=
match len with
|O => Vector.nil bool
|S m => Vector.cons bool true m (getAllFalseVector m)
end.

Fixpoint getBiasVector (len:nat) : Bvector len :=
match len with
|O => Vector.nil bool
|S m => Vector.cons bool false m (getAllTrueVector m)
end.

Definition shiftExp : nat := getMaxExp lenExp.
Definition maxExp : nat := getMaxExp lenExp.

Definition allTrueExp : Bvector lenExp := getAllTrueVector lenExp.

Definition allFalseExp : Bvector lenExp := getAllFalseVector lenExp.

Definition zeroExp : Bvector lenExp := getBiasVector lenExp.

Definition bias : Bvector lenExp := getBiasVector lenExp.

Definition allFalseSignificant : Bvector lenSign := getAllFalseVector lenSign.

Definition notAllFalseSignificant : Bvector lenSign :=
getNotAllFalseVector lenSign.

Record fp_num : Set := mkFp
{
 sign : bool;
 exp : Bvector lenExp;
 significant : Bvector lenSign
}.

Definition NaN : fp_num := mkFp true allTrueExp notAllFalseSignificant.
Definition plusInfinity : fp_num := mkFp false allTrueExp allFalseSignificant.
Definition minusInfinity : fp_num := mkFp true allTrueExp allFalseSignificant.
Definition plusZero : fp_num := mkFp false allFalseExp allFalseSignificant.
Definition minusZero : fp_num := mkFp true allFalseExp allFalseSignificant.

(* BEGIN *)
(* determine type number *)
Fixpoint isVectAllTrue (n:nat) (v : Bvector n) : bool :=
 match v with
  | Vector.nil => true
  | Vector.cons h m w => if h then (isVectAllTrue m w) else false
 end.

Fixpoint isVectAllFalse (n:nat) (v : Bvector n) : bool :=
 match v with
  | Vector.nil => true
  | Vector.cons h m w => if h  then false else (isVectAllFalse m w)
 end.

Fixpoint isExpforZero (v : Bvector lenExp) : bool :=
 isVectAllFalse lenExp v.

Fixpoint isNaN (fp : fp_num) : bool :=
if isVectAllTrue lenExp fp.(exp) then
  negb (isVectAllFalse lenSign fp.(significant) )
else false.

Fixpoint isInfinite (fp : fp_num) : bool :=
if isVectAllTrue lenExp fp.(exp) then
  isVectAllFalse lenSign fp.(significant)
else false.

Fixpoint isFinite (fp : fp_num) : bool := negb (isNaN fp || isInfinite fp).

Fixpoint isZero (fp : fp_num) : bool :=
 (isExpforZero fp.(exp) && isVectAllFalse lenSign fp.(significant)).

(* determine type number *)
(* END *)

(* BEGIN *)
(* compare fp_num *)
Fixpoint compareSys (n:nat) (m:nat) (v1 : Bvector n) (v2 : Bvector m) : comparison :=
match v1 with
  | Vector.nil => Eq
  | Vector.cons h1 m1 w1 =>
  match v2 with
   | Vector.nil => Eq
   | Vector.cons h2 m2 w2 => if eqb h1 h2 then compareSys m1 m2 w1 w2 else if h1 then Gt else Lt
  end
 end.

Fixpoint compareVect (n:nat) (v1 v2 : Bvector n) : comparison := compareSys n n v1 v2.

Fixpoint compareExp (fp1 fp2 : fp_num) : comparison := compareVect lenExp fp1.(exp) fp2.(exp).

Fixpoint compareSignificant (fp1 : fp_num) (fp2 : fp_num) : comparison :=
compareVect lenSign fp1.(significant) fp2.(significant).

Fixpoint compareSign (fp1 fp2 : fp_num) : comparison :=
if eqb fp1.(sign) fp2.(sign) then Eq
else if fp1.(sign) then Lt else Gt.

Fixpoint compareAbs (fp1 fp2 : fp_num) : comparison :=
match compareExp fp1 fp2 with
   | Lt => Lt
   | Gt => Gt
   | Eq => compareSignificant fp1 fp2
end.

Fixpoint compare (fp1 fp2 : fp_num) : comparison :=
match compareSign fp1 fp2 with
| Lt => Lt
| Gt => Gt
| Eq => match compareExp fp1 fp2 with
   | Lt => Lt
   | Gt => Gt
   | Eq => compareSignificant fp1 fp2
  end
end.

(*<*)
Fixpoint isLt (c:comparison) : bool :=
match c with
|Lt => true
|_ => false
end.

(*==*)
Fixpoint isEq (c:comparison) : bool :=
match c with
|Eq => true
|_ => false
end.

(*>*)
Fixpoint isGt (c:comparison) : bool :=
match c with
|Gt => true
|_ => false
end.

(*<=*)
Fixpoint isLE (c:comparison) : bool :=
match c with
|Gt => false
|_ => true
end.

(*!=*)
Fixpoint isNE (c:comparison) : bool :=
match c with
|Eq => false
|_ => true
end.

(*>=*)
Fixpoint isGE (c:comparison) : bool :=
match c with
|Lt => false
|_ => true
end.

Fixpoint isGeFp_bool (x y :fp_num) : bool := isGE (compare x y).
Fixpoint isNeFp_bool (x y :fp_num) : bool := isNE (compare x y).
Fixpoint isLeFp_bool (x y :fp_num) : bool := isLE (compare x y).
Fixpoint isGtFp_bool (x y :fp_num) : bool := isGt (compare x y).
Fixpoint isLtFp_bool (x y :fp_num) : bool := isLt (compare x y).
Fixpoint isEqFp_bool (x y :fp_num) : bool := isEq (compare x y).

(* compare fp_num *)
(* END *)

(* compare Q*)
(* BEGIN *)
Fixpoint isGeQ_bool (x y :Q) : bool := isGE (Qcompare x y).
Fixpoint isNeQ_bool (x y :Q) : bool := isNE (Qcompare x y).
Fixpoint isLeQ_bool (x y :Q) : bool := isLE (Qcompare x y).
Fixpoint isGtQ_bool (x y :Q) : bool := isGt (Qcompare x y).
Fixpoint isLtQ_bool (x y :Q) : bool := isLt (Qcompare x y).
Fixpoint isEqQ_bool (x y :Q) : bool := isEq (Qcompare x y).
(* compare Q*)
(* END *)

Definition invertV (n : nat) := nat_rect (fun n => Bvector n -> Bvector n)
(fun v => Bnil)
(fun k x v => Bcons (Vector.last v) _ (x (Vector.shiftout v))).

Definition neg (fp : fp_num) : fp_num := mkFp (negb fp.(sign)) fp.(exp) fp.(significant).

Fixpoint abs (fp:fp_num) : fp_num := mkFp false fp.(exp) fp.(significant).

Definition sumDigits (carry a b : bool) : bool * bool :=
if carry then
  if a then
   if b then (true,true)
   else (true,false)
  else
   if b then (true,false)
   else (false,true)
else
 if a then
   if b then (true,false)
   else (false,true)
 else
   if b then (false,true)
   else (false,false).

(* a -(b+carry) *)
Definition diffDigits (carry a b : bool) : bool * bool :=
if carry then
  if b then
    if a then (true,true)
    else (true,false)
  else
    if a then (false,false)
    else (true,true)
else
 if b then
   if a then (false,false)
   else (true,true)
 else
   if a then (false,true)
   else (false,false).

Fixpoint plusBoolInvV (n:nat) (b:bool) (v :Bvector n) : Bvector n :=
if b then
 match v with
  | Vector.nil => []
  | Vector.cons h m w => let res := sumDigits b h false in
     if fst res
     then Vector.cons bool (snd res) m  (plusBoolInvV m (fst res) w)
     else Vector.cons bool (snd res) m w
 end
else v.

Fixpoint minusBoolInvV (n:nat) (b:bool) (v :Bvector n) : Bvector n :=
if b then
 match v with
  | Vector.nil => []
  | Vector.cons h m w => let res:=diffDigits b h false in
     if fst res
     then Vector.cons bool (snd res) m (minusBoolInvV m (fst res) w)
     else Vector.cons bool (snd res) m w
 end
else v.

Fixpoint plusBoolV (n:nat) (b:bool) (v :Bvector n) : Bvector n :=
invertV n n (plusBoolInvV n b (invertV n n v)).

Fixpoint minusBoolV (n:nat) (b:bool) (v :Bvector n) : Bvector n :=
invertV n n (minusBoolInvV n b (invertV n n v)).

Fixpoint plusTrueToExp (fp : fp_num) : fp_num :=
mkFp fp.(sign) (plusBoolV lenExp true fp.(exp) ) fp.(significant).

Fixpoint minusTrueFromExp (fp : fp_num) : fp_num :=
mkFp fp.(sign) (minusBoolV lenExp true fp.(exp) ) fp.(significant).

(* remove last shift right add head *)
Definition shiftReplaceR (val : bool) : forall n : nat, (Bvector n -> Bvector n) :=
nat_rect (fun n => (Bvector n -> Bvector n))
(fun x => Bnil)
(fun k x w => Bcons val _ (Vector.shiftout w)).

(* remove head shift left add last *)
Definition shiftReplaceL (val : bool) (n:nat) (v : Bvector n) : Bvector n :=
invertV n n (shiftReplaceR val n (invertV n n v)).

Definition shiftSignificantR (val : bool) (fp:fp_num) : fp_num :=
mkFp fp.(sign) fp.(exp) (shiftReplaceR val lenSign fp.(significant)).

Definition shiftSignificantL (val : bool) (fp:fp_num) : fp_num :=
mkFp fp.(sign) fp.(exp) (shiftReplaceL val lenSign fp.(significant)).

Fixpoint vect2NatSys (pow :nat) (n:nat) (v:Bvector n) : nat :=
match v with
 |Vector.nil => O
 |Vector.cons h m w => if h then pow + (vect2NatSys (2*pow) m w)%nat else vect2NatSys (2*pow) m w
end.

Fixpoint vect2Nat (n:nat) (v:Bvector n) : nat := vect2NatSys 1 n (invertV n n v).

Fixpoint exp2Nat (fp: fp_num) : nat := vect2Nat lenExp  fp.(exp).

Fixpoint nat2Vect (n len:nat) (v:Bvector len) (minus:bool) :Bvector len :=
match n with
|O => v
|S m => let newV := if minus then
                       minusBoolV len true v
                    else plusBoolV len true v
        in nat2Vect m len newV minus
end.

(* fp1.(exp) < fp2.(exp) *)
Fixpoint difExp (fp1 fp2 : fp_num) : nat :=(exp2Nat fp2 - exp2Nat fp1)%nat.

Fixpoint countZero (n:nat) (v: Bvector n) : nat :=
match v with
|Vector.nil => O
|Vector.cons h m w => if h then O else S (countZero m w)
end.

Fixpoint alignmentExpSys (n:nat) (val:bool) (fp: fp_num) : fp_num :=
match n with
| O => fp
| S m => alignmentExpSys m false (shiftSignificantR val (plusTrueToExp fp))
end.

Fixpoint normalizeFpSys (n:nat) (val:bool) (fp: fp_num) : fp_num :=
match n with
| O => fp
| S m => normalizeFpSys m false (shiftSignificantL val (minusTrueFromExp fp))
end.

(* fp1.(exp) < fp2.(exp)*)
Fixpoint alignmentExp (fp1 fp2 :fp_num) : fp_num :=
alignmentExpSys (difExp fp1 fp2) true fp1.

Fixpoint normalizeFp (count:nat) (fp : fp_num) : fp_num :=
normalizeFpSys count false fp.

Fixpoint sumVectors (n : nat) := Vector.rect2 (n:=n) (fun n l r => prod bool (Bvector n))
(false, [])
(fun n l r prev a b => let (carry, result) := (sumDigits (fst prev) a b) in (carry, result :: (snd prev))).

(* abs fp1 > abs fp2 *)
Fixpoint diffVectors (n : nat) := Vector.rect2 (n:=n) (fun n l r => prod bool (Bvector n))
(false, [])
(fun n l r prev a b => let (carry, result) := (diffDigits (fst prev) a b) in (carry, result :: (snd prev))).

(* fp1.(exp) < fp2.(exp) *)
Fixpoint sumOneSignFpSysNotEq (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
let sumRes := sumVectors lenSign (alignmentExp fp1 fp2).(significant) fp2.(significant) in
if fst sumRes then mkFp fp1.(sign) (plusBoolV lenExp true fp2.(exp) ) (shiftReplaceR false lenSign (snd sumRes))
else mkFp fp2.(sign) fp2.(exp) (snd sumRes).

(* fp1.(exp) = fp2.(exp) *)
Fixpoint sumOneSignFpSysEq (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
let sumRes := sumVectors lenSign fp1.(significant) fp2.(significant) in
if fst sumRes then mkFp fp1.(sign) (plusBoolV lenExp true fp1.(exp) ) (shiftReplaceR true lenSign (snd sumRes))
else mkFp fp1.(sign) (plusBoolV lenExp true fp1.(exp) ) (shiftReplaceR false lenSign (snd sumRes)).

Fixpoint sumOneSignFp (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
match compareExp fp1 fp2 with
|Lt => sumOneSignFpSysNotEq fp1 fp2
|Gt => sumOneSignFpSysNotEq fp2 fp1
|Eq => sumOneSignFpSysEq fp2 fp1
end.

(* abs fp1 > abs fp2 *)
Fixpoint diffNotEqExpFp (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
let res := diffVectors lenSign fp1.(significant) (alignmentExp fp2 fp1).(significant)  in
if fst res then normalizeFp (S (countZero lenSign (snd res))) (mkFp fp1.(sign) fp1.(exp) (snd res))
else normalizeFp (countZero lenSign (snd res)) (mkFp fp1.(sign) fp1.(exp) (snd res)).

(* abs fp1 > abs fp2 *)
Fixpoint diffEqExpFp (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
let res := diffVectors lenSign  fp1.(significant) fp2.(significant) in
normalizeFp (S (countZero lenSign (snd res))) (mkFp fp1.(sign) fp1.(exp) (snd res)).

(* abs fp1 > abs fp2 *)
Fixpoint diffFpSys (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
match compareExp fp1 fp2 with
|Lt =>  diffNotEqExpFp fp2 fp1
|Gt =>  diffNotEqExpFp fp1 fp2
|Eq =>  diffEqExpFp fp1 fp2
end.

Fixpoint diffFp2 (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
match compareAbs fp1 fp2 with
     | Lt => diffFpSys fp2 fp1
     | Gt => diffFpSys fp1 fp2
     | Eq => if fp1.(sign) then minusZero else plusZero
end.

Fixpoint sumFinite (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
if isZero fp1 then
   fp2
else
   if isZero fp2 then
      fp1
   else
      match compareSign fp1 fp2 with
      |Eq => sumOneSignFp fp1 fp2
      | _ => diffFp2 fp1 fp2
      end.

Fixpoint sumInfinite (fp1 : fp_num) (fp2 : fp_num) : fp_num :=
if isInfinite fp1 then
   if isInfinite fp2 then
      match compareSign fp1 fp2 with
       | Eq => fp1
       | _ => NaN
      end
   else fp1
else fp2.

Fixpoint sumFp (fp1 fp2 : fp_num) : fp_num :=
if isNaN fp1 || isNaN fp2 then NaN
else if isInfinite fp1 || isInfinite fp2 then sumInfinite fp1 fp2
     else sumFinite fp1 fp2.

Fixpoint diffFp (fp1 fp2 : fp_num) : fp_num := sumFp fp1 (neg fp2).

Fixpoint minusExponents (v1:Bvector lenExp) (v2 : Bvector lenExp) : Bvector lenExp :=
let v2New := Vector.cons bool false lenExp v2 in
let v1New := Vector.cons bool false lenExp v1 in
let biasNew := Vector.cons bool false lenExp bias in
let tmp := snd (sumVectors (S lenExp) v1New biasNew) in
let result := snd (diffVectors (S lenExp) tmp v2New) in
Vector.tl result.

Fixpoint SSVector (lenV:nat) (w:Bvector 2) (v:Bvector lenV)  : Bvector (S (S lenV)) :=
let v1 := Vector.cons bool (Vector.last w) lenV v in
Vector.cons bool (Vector.hd w) (S lenV) v1.

Fixpoint PPVector (v:Bvector (S (S lenSign))) : (Bvector 2)*(Bvector lenSign) :=
let v1 := Vector.tl v in
([(Vector.hd v);(Vector.hd v1)],(Vector.tl v1)).

Fixpoint divBit (n:nat) (div1:Bvector n) (div2:Bvector n) :bool*(Bvector n):=
match compareVect n div1 div2 with
|Lt => let w := shiftReplaceL false n div1 in
       (false,w)
|_ => let tmp := snd (diffVectors n div1 div2) in
      (true,(shiftReplaceL false n tmp))
end.

(*head - number before floating point
  last - for accuracy*)
Fixpoint divSys (m:nat) (div1:Bvector m) (div2:Bvector m) (result:Bvector m) (n:nat):
         Bvector m :=
let res := divBit m div1 div2 in
match n with
|O =>  shiftReplaceL (fst res) m result
|S l => divSys m (snd res) div2 (shiftReplaceL (fst res) m result) l
end.

Fixpoint removeLast (n:nat) (v:Bvector (S n)) : Bvector n :=
let vv := invertV (S n) (S n) v in
invertV n n (Vector.tl vv).

Fixpoint divFinite (fp1 fp2: fp_num) : fp_num :=
let n := S (S lenSign) in
let v1 := SSVector lenSign [false;true] fp1.(significant) in
let v2 := SSVector lenSign [false;true] fp2.(significant) in
let zeroRes := SSVector lenSign [false;false] allFalseSignificant in
let res:= divSys n v1 v2 zeroRes (S lenSign) in
let resExp:= minusExponents fp1.(exp) fp2.(exp) in
let leftPart := Vector.hd res in
if leftPart then
 let significantRes := removeLast lenSign (Vector.tl res) in
 mkFp (xorb fp1.(sign) fp2.(sign)) resExp significantRes
else
 let significantRes := Vector.tl (Vector.tl res) in
 mkFp (xorb fp1.(sign) fp2.(sign)) (minusBoolV lenExp true resExp) significantRes.

Fixpoint divideFp (fp1 fp2: fp_num) : fp_num :=
if((isNaN fp1) || (isNaN fp2)) then NaN
else
 if (isZero fp1 && isZero fp2) then NaN
 else
  if isZero fp2 then mkFp (xorb fp2.(sign) fp1.(sign)) plusInfinity.(exp) plusInfinity.(significant)
  else
   if isZero fp1 then
      fp1
   else
      divFinite fp1 fp2.

(**********************************MULTIPLICATION**********************************)

Fixpoint sumExponents (v1:Bvector lenExp) (v2 : Bvector lenExp) : Bvector lenExp :=
let v2New := Vector.cons bool false lenExp v2 in
let v1New := Vector.cons bool false lenExp v1 in
let biasNew := Vector.cons bool false lenExp bias in
let tmp := snd (sumVectors (S lenExp) v1New v2New) in
let result := snd (diffVectors (S lenExp) tmp biasNew) in
Vector.tl result.

(*num*bit+result
  leftPoint,significant *)
Fixpoint multOnBitSignificant  (num:Bvector lenSign) (bit:bool) (result:Bvector lenSign)
(leftPoint:Bvector 2) :(Bvector 2)*(Bvector lenSign) :=
let shiftResult := shiftReplaceR (Vector.last leftPoint) lenSign result in
match bit with
|false => ([false;Vector.hd leftPoint],shiftResult)
|true =>
 let sum := sumVectors lenSign shiftResult num in
 let resultLeft := sumDigits true (fst sum) (Vector.hd leftPoint) in
 ([fst resultLeft;snd resultLeft],snd sum)
end.

(* num1*num2
   num2 - reverse*)
Fixpoint multSignificantSysR (num1:Bvector lenSign) (n:nat) (num2:Bvector n)
(result:Bvector lenSign) (leftPoint:Bvector 2) : (Bvector 2)*(Bvector lenSign) :=
match num2 with
|Vector.nil => multOnBitSignificant  num1 true result leftPoint
|Vector.cons h m w =>
let nextResult := multOnBitSignificant num1 h result leftPoint in
multSignificantSysR num1 m w (snd nextResult) (fst nextResult)
end.

Fixpoint getAllFalseVect (n:nat) : Bvector n :=
match n with
|O => []
|S m => Vector.cons bool false m (getAllFalseVect m)
end.

Fixpoint multSignificant (num1 num2 : Bvector lenSign):Bvector (S (S lenSign)):=
let num2R:= invertV lenSign lenSign num2 in
let res := multSignificantSysR num1 lenSign num2R allFalseSignificant [false;false] in
SSVector lenSign (fst res) (snd res).

Fixpoint multFinite (fp1 fp2 : fp_num) : fp_num:=
let signRes := xorb fp1.(sign) fp2.(sign) in
let expRes := sumExponents fp1.(exp) fp2.(exp) in
let multRes := multSignificant fp1.(significant) fp2.(significant) in
let newRes := Vector.tl multRes in
let needShift := Vector.hd multRes in
if needShift then
 let newExpRes := plusBoolV lenExp true expRes in
 let newSignificant :=
     shiftReplaceR (Vector.hd newRes) lenSign (Vector.tl newRes) in
 mkFp signRes newExpRes newSignificant
else
 mkFp signRes expRes (Vector.tl newRes).

Fixpoint multFp (fp1 fp2 :fp_num) : fp_num :=
if (isNaN fp1) || (isNaN fp2) then NaN
else
 if(isInfinite fp1) then
  if(isInfinite fp2) then
   mkFp (xorb fp1.(sign) fp2.(sign)) fp1.(exp) fp1.(significant)
  else
   if(isZero fp2) then
    NaN
   else
    fp1
 else
  if(isInfinite fp2) then
   if(isZero fp1) then
    NaN
   else
    fp2
  else
   if isZero fp1 || isZero fp2 then
      plusZero
   else
      multFinite fp1 fp2.

(*******************************SQRT*******************************)

Fixpoint expSqrt (v:Bvector lenExp) : bool*(Bvector lenExp) :=
match compareVect lenExp v bias with
|Lt => let res := diffVectors lenExp bias v in
       let tmp := shiftReplaceR false lenExp (snd res) in
       let newRes := diffVectors lenExp bias tmp in
       if (Vector.last v) then
           (false,snd newRes)
       else
          (true,minusBoolV lenExp true (snd newRes))
|_ =>  let res := diffVectors lenExp v bias in
       let tmp := shiftReplaceR false lenExp (snd res) in
       let newRes := sumVectors lenExp bias tmp in
       if (Vector.last v) then
           (false,snd newRes)
       else
           (true,snd newRes)
end.

Fixpoint setValToNPositionVect (n:nat) (val:bool) (lenV:nat) (v:Bvector lenV) : Bvector lenV :=
match nat_compare lenV n with
|Lt => v
|Eq => match v with
       |Vector.nil => []
       |Vector.cons h m w => Vector.cons bool val m w
       end
|Gt => match v with
       |Vector.nil => []
       |Vector.cons h m w =>
        let ww:= setValToNPositionVect n val m w in
        Vector.cons bool h m ww
       end
end.

Fixpoint setTrueToNPositionVect (n:nat) (lenV:nat) (v:Bvector lenV) : Bvector lenV :=
setValToNPositionVect n true lenV v.

Fixpoint significantSqrtSys (evenExp:bool) (stepNum:nat) (num res:Bvector lenSign)
                            : Bvector lenSign :=
match stepNum with
|O=> res
|S m => let newRes := setTrueToNPositionVect (S m) lenSign res in
        let tmp :=  multSignificant newRes newRes in
        let head := Vector.hd tmp in
        let tmp2 := Vector.tl tmp in
        if eqb head evenExp then
           let squaredRes := shiftReplaceR (Vector.hd tmp2) lenSign (Vector.tl tmp2) in
           match compareVect lenSign num squaredRes with
              |Lt => significantSqrtSys evenExp m num res
              |_ => significantSqrtSys evenExp m num newRes
           end
        else if(evenExp) then
           significantSqrtSys evenExp m num newRes
        else
           significantSqrtSys evenExp m num res
end.

Fixpoint significantSqrt (evenExp:bool) (significant:Bvector lenSign) : Bvector lenSign :=
significantSqrtSys evenExp lenSign significant allFalseSignificant.

Fixpoint sqrtFpPos (fp:fp_num) : fp_num :=
let newExp := expSqrt fp.(exp) in
let evenExp := fst newExp in
let newSignificant := significantSqrt evenExp fp.(significant) in
mkFp false (snd newExp) newSignificant.

Fixpoint sqrtFp(fp:fp_num) : fp_num :=
if isNaN fp then fp
else
 if isZero fp then
  fp
 else
  if fp.(sign) then
   NaN
  else
   if isInfinite fp then
    fp
   else
    sqrtFpPos fp.

(***************************CONVERSATION***************************)

Open Scope Z_scope.
Open Scope positive_scope.
Open Scope Q_scope.

Fixpoint Qgcd (q:Q) : Q :=
let qnum := q.(Qnum) in
let qden := Zpos q.(Qden) in
let gcdRes := Z.gcd qnum qden in
match Z.compare gcdRes 1 with
|Eq => q
|_ =>
  let newNum := fst (div_eucl_z qnum gcdRes) in
  let newDen := fst (div_eucl_z qden gcdRes) in
  Qmake newNum (Z.to_pos newDen)
end.

Close Scope  Z_scope.
Close Scope positive_scope.

Fixpoint vector2QSys (res:Q) (pow:Q) (n:nat) (v: Bvector n) : Q :=
match v with
|Vector.nil => res
|Vector.cons h m w => let newPow := Qmult (1#2) pow in
let newRes :=
 if h then
  Qplus res newPow
 else
  res
in if h then
 vector2QSys (Qgcd newRes) newPow m w
else
 vector2QSys newRes newPow m w
end.

Fixpoint vector2Q (n:nat) (v:Bvector n) : Q := vector2QSys 1 1 n v.

Fixpoint significant2Q (fp : fp_num) : Q :=
vector2Q lenSign fp.(significant).

Fixpoint power (base: Q) (pow:nat) : Q :=
match pow with
|O => 1
|S m => Qmult base (power base m)
end.

Fixpoint exp2Q (fp: fp_num) : Q :=
if isExpforZero fp.(exp) then
 0#1
else
 let expNat := exp2Nat fp in
 let biasNat := vect2Nat lenExp bias in
 match nat_compare expNat biasNat with
  |Lt => power (1#2) (biasNat - expNat)
  |_ => power (2#1) (expNat-biasNat)
 end.

Fixpoint fp2Q (fp:fp_num) : Q :=
let qsign := significant2Q fp in
let qexp := exp2Q fp in
let res := Qgcd (Qmult qsign qexp) in
if fp.(sign) then
 Qmult (-1#1) res
else
 res.

Fixpoint getSignificantFromQSys (num curPow:Q) (iter:nat)  : Bvector iter :=
let newPow := Qmult (1#2) curPow in
match iter with
|O => []
|S m => match Qcompare num curPow with
       |Lt => Vector.cons bool false m (getSignificantFromQSys num newPow m)
       |_  => let newNum := Qgcd (Qminus num curPow) in
           Vector.cons bool true m (getSignificantFromQSys newNum newPow m)
       end
end.

Fixpoint getSignificantFromQ (num:Q) : Bvector lenSign :=
getSignificantFromQSys num (1#2) lenSign.

Fixpoint computeExpSmallSys (num:Q) (iter:nat) :nat*Q :=
match iter with
|O => (O,num)
|S m => let newNum := Qmult num (2#1) in
   match Qcompare newNum (1#1) with
      |Lt => let res := computeExpSmallSys newNum m in (S (fst res),snd res)
      |_ => (S O, newNum)
   end
end.

Fixpoint computeExpSmall (num:Q) : (Bvector lenExp)*Q :=
let res := computeExpSmallSys num shiftExp in
let secondRes := nat2Vect (fst res) lenExp bias true in
(secondRes,snd res).

Fixpoint computeExpBigSys (num:Q) (iter:nat) :nat*Q :=
match iter with
|O => (O,num)
|S m => let newNum := Qmult num (1#2) in
   match Qcompare newNum (2#1) with
      |Lt => (S O,newNum)
      | _ => let res := computeExpBigSys newNum m in (S (fst res),snd res)
   end
end.

Fixpoint computeExpBig (num:Q) : (Bvector lenExp)*Q :=
let res :=computeExpBigSys num shiftExp in
let secondRes := nat2Vect (fst res) lenExp bias false in
(secondRes,snd res).

Fixpoint getExp (num:Q) : (Bvector lenExp)*Q :=
let newNum := Qabs num in
match Qcompare newNum (2#1) with
|Lt => match Qcompare newNum (1#1) with
       |Lt => computeExpSmall newNum
       | _ => (bias,num)
       end
| _ => computeExpBig newNum
end.

Fixpoint Q2Fp (num:Q): fp_num :=
match Qcompare num (0#1) with
|Eq => plusZero
|_ =>
  let sign := match Qcompare num (0#1) with
    |Lt => true
    | _ => false
   end in
  let res := getExp num in
  let significant := getSignificantFromQ (Qminus (snd res) (1#1)) in
  mkFp sign (fst res) significant
end.

Fixpoint sqrtStepQ (a res eps : Q) (step:nat) : Q :=
let gcdRes := Qgcd res in
match step with
|O => gcdRes
|S m => let sq:=Qabs (gcdRes*gcdRes-a) in
 match  Qcompare sq eps with
  |Lt => gcdRes
  | _ => let newRes := (1#2)*(gcdRes + a/gcdRes) in sqrtStepQ a newRes eps m
 end
end.

Fixpoint sqrtAccQ ( acc a : Q) : Q :=
match Qcompare a (0#1) with
|Lt => (-1#1)
| _ => match Qcompare acc (0#1) with
 |Gt => sqrtStepQ  a a acc lenSign
 | _ => (-1#1)
 end
end.

Definition sqrtQ(a:Q) : Q :=
sqrtAccQ  sqrtEps a.

Definition sqrtAccFp (acc:Q) (fp:fp_num) : fp_num:=
sqrtFp fp.

Fixpoint reflectQ (num:Q) : Q := num.

Fixpoint max (n m:nat) : nat :=
match n, m with
  | O, _ => m
  | S n', O => n
  | S n', S m' => S (max n' m')
end.

Record ApproxArith := mkApproxArith
{
 Num : Set;
 sum  : Num -> Num -> Num;
 diff : Num -> Num -> Num;
 mult : Num -> Num -> Num;
 div  : Num -> Num -> Num;
 sqrt : Num -> Num;
 from_rational : Q -> Num;
 to_rational : Num -> Q;
 lt : Num -> Num -> bool;
 le : Num -> Num -> bool;
 eq : Num -> Num -> bool;
 ge : Num -> Num -> bool;
 gt : Num -> Num -> bool
}.

Definition approxFp := mkApproxArith fp_num sumFp diffFp multFp divideFp sqrtFp Q2Fp fp2Q
                                     isLtFp_bool isLeFp_bool isEqFp_bool isGeFp_bool isGtFp_bool.
Definition approxQ := mkApproxArith Q Qplus Qminus Qmult Qdiv sqrtQ reflectQ reflectQ
                                      isLtQ_bool isLeQ_bool isEqQ_bool isGeQ_bool isGtQ_bool.

Inductive ArithExp (n: nat):=
|Get (i: Fin.t n)
|Const (c: Q)
|Add(a b :ArithExp n)
|Diff(a b:ArithExp n)
|Mult(a b:ArithExp n)
|Div(a b:ArithExp n)
|Sqrt(a :ArithExp n)
|Noting
|If(cond:BoolExp n) (onTrue: ArithExp n) (onFalse: ArithExp n)
with BoolExp(n:nat) :=
|And (a b : BoolExp n)
|Or (a b :BoolExp n)
|Eq (a b : ArithExp n)
|Gt (a b : ArithExp n)
|Ge (a b : ArithExp n)
|Lt (a b : ArithExp n)
|Le (a b : ArithExp n).

Close Scope Q_scope.
(*result_code,result*)
(*result_code: 0-ok,1-don't put,x>1 - error *)
Definition ok_code: nat := 0.
Definition nothing_code : nat := 1.
Definition error_code : nat := 2.

Fixpoint computeExp (n:nat) (arith: ApproxArith) (exp: ArithExp n)
                       (init : t (Num arith) n) : nat*(Num arith) :=
let error:= from_rational arith (-1#1) in
let zero := from_rational arith 0 in
match exp with
 |Get x => (0,nth init x)
 |Const x => (0,from_rational arith x)
 |Add x1 x2 =>
  let res1 := computeExp n arith x1 init in
  let code_1 := fst res1 in
  let result_1 := snd res1 in
  let res2 := computeExp n arith x2 init in
  let code_2 := fst res2 in
  let result_2 := snd res2 in
  if andb (leb code_1 ok_code) (leb code_2 ok_code) then
   (ok_code, sum arith result_1 result_2)
  else
   (max code_1 code_2,error)
 |Diff x1 x2 =>
  let res1 := computeExp n arith x1 init in
  let code_1 := fst res1 in
  let result_1 := snd res1 in
  let res2 := computeExp n arith x2 init in
  let code_2 := fst res2 in
  let result_2 := snd res2 in
  if andb (leb code_1 ok_code) (leb code_2 ok_code) then
   (ok_code, diff arith result_1 result_2)
  else
   (max code_1 code_2,error)
 |Mult x1 x2 =>
  let res1 := computeExp n arith x1 init in
  let code_1 := fst res1 in
  let result_1 := snd res1 in
  let res2 := computeExp n arith x2 init in
  let code_2 := fst res2 in
  let result_2 := snd res2 in
  if andb (leb code_1 ok_code) (leb code_2 ok_code) then
   (ok_code, mult arith result_1 result_2)
  else
   (max code_1 code_2,error)
 |Div x1 x2 =>
  let res1 := computeExp n arith x1 init in
  let code_1 := fst res1 in
  let result_1 := snd res1 in
  let res2 := computeExp n arith x2 init in
  let code_2 := fst res2 in
  let result_2 := snd res2 in
  if andb (leb code_1 ok_code) (leb code_2 ok_code) then
   if (eq arith result_2 zero) then
    (error_code,error)
   else
   (ok_code, div arith result_1 result_2)
  else
   (max code_1 code_2,error)
 |Sqrt x =>
  let res := computeExp n arith x init in
  let code := fst res in
  let result := snd res in
  if (leb code ok_code) then
   if (ge arith result zero) then
    (ok_code,sqrt arith result)
   else
    (error_code,error)
  else
   (code,error)
 |If cond onTrue onFalse =>
  let cond_res := computeBoolExp n arith cond init in
  let cond_code := fst cond_res in
  let cond_val := snd cond_res in
  if (leb cond_code ok_code) then
   if cond_val then
    computeExp n arith onTrue init
   else
    computeExp n arith onFalse init
  else
   (error_code,error)
 |Nothing => (nothing_code,error)
end
with computeBoolExp (n:nat) (arith: ApproxArith) (exp: BoolExp n)
                     (init : t (Num arith) n) : nat*bool :=
match exp with
|And x y =>
 let res1 := computeBoolExp n arith x init in
 let res2 := computeBoolExp n arith y init in
 let code_1 := fst res1 in
 let code_2 := fst res2 in
 let result_1 := snd res1 in
 let result_2 := snd res2 in
 if  andb (leb code_1 ok_code) (leb code_2 ok_code) then
  (ok_code,andb result_1 result_2)
 else
  (error_code,false)
|Or x y =>
 let res1 := computeBoolExp n arith x init in
 let res2 := computeBoolExp n arith y init in
 let code_1 := fst res1 in
 let code_2 := fst res2 in
 let result_1 := snd res1 in
 let result_2 := snd res2 in
 if  andb (leb code_1 ok_code) (leb code_2 ok_code) then
  (ok_code,orb result_1 result_2)
 else
  (error_code,false)
|Eq x y =>
 let res1 := computeExp n arith x init in
 let code_1 := fst res1 in
 let result_1 := snd res1 in
 let res2 := computeExp n arith y init in
 let code_2 := fst res2 in
 let result_2 := snd res2 in
 if andb (leb code_1 ok_code) (leb code_2 ok_code) then
  (ok_code, eq arith result_1 result_2)
 else
  (error_code,false)
|Gt x y =>
 let res1 := computeExp n arith x init in
 let code_1 := fst res1 in
 let result_1 := snd res1 in
 let res2 := computeExp n arith y init in
 let code_2 := fst res2 in
 let result_2 := snd res2 in
 if andb (leb code_1 ok_code) (leb code_2 ok_code) then
  (ok_code, gt arith result_1 result_2)
 else
  (error_code,false)
|Ge x y =>
 let res1 := computeExp n arith x init in
 let code_1 := fst res1 in
 let result_1 := snd res1 in
 let res2 := computeExp n arith y init in
 let code_2 := fst res2 in
 let result_2 := snd res2 in
 if andb (leb code_1 ok_code) (leb code_2 ok_code) then
  (ok_code, ge arith result_1 result_2)
 else
  (error_code,false)
|Lt x y =>
 let res1 := computeExp n arith x init in
 let code_1 := fst res1 in
 let result_1 := snd res1 in
 let res2 := computeExp n arith y init in
 let code_2 := fst res2 in
 let result_2 := snd res2 in
 if andb (leb code_1 ok_code) (leb code_2 ok_code) then
  (ok_code, lt arith result_1 result_2)
 else
  (error_code,false)
|Le x y =>
 let res1 := computeExp n arith x init in
 let code_1 := fst res1 in
 let result_1 := snd res1 in
 let res2 := computeExp n arith y init in
 let code_2 := fst res2 in
 let result_2 := snd res2 in
 if andb (leb code_1 ok_code) (leb code_2 ok_code) then
  (ok_code, le arith result_1 result_2)
 else
  (error_code,false)
end.

Fixpoint interp (n:nat) (arith :ApproxArith) (prog : list ((Fin.t n) *(ArithExp n)))
                  (init: t (Num arith) n) : nat*(t (Num arith) n)  :=
match prog with
|List.nil => (ok_code,init)
|List.cons h tl =>
 let pos := fst h in
 let exp := snd h in
 let res := computeExp n arith exp init in
 let code := fst res in
 let val := snd res in
 if leb code ok_code then
  interp n arith tl (replace init pos val)
 else
  if leb code nothing_code then
   interp n arith tl init
  else
   (error_code,init)
end.