Require Import Ascii String Nat List.
Open Scope nat_scope.
Open Scope string_scope.
Import ListNotations.
Inductive t: Set:=
  |ess : t
  |fdsfsd (a:t).

Inductive dict : Set :=
  | empty_dict : dict
  | add_dict (s:string) (n:nat) (d : dict): dict.
Check dict.
Check empty_dict.

Open Scope string_scope.
Fixpoint assoc1 (key: string) (mydict: dict) : option nat:=
  match mydict with
  |empty_dict => None
  |add_dict s v d => match s =? key with
                     |true => Some v
                     |false => assoc1 key d
                    end
  end.

Open Scope nat_scope.
Fixpoint assoc2 (key: nat) (mydict: dict) : option string :=
  match mydict with
  |empty_dict => None%string
  |add_dict s v d => match key =? v with
                     |true => Some s
                     |false => assoc2 key d
                    end
  end.
(* Les dictionnaires seront bijectifs, c’est-`a-dire qu’une chaˆıne ou un nombre n’y apparaˆıt qu’au plus une fois.*)
Fixpoint is_bijectif (mydict : dict) : bool :=
  match mydict with
  |empty_dict => true
  |add_dict s v mydict' => match (assoc1 s mydict', assoc2 v mydict') with
                           | (None, None) => is_bijectif mydict'
                           | _ => false
                           end
  end.

Open Scope char_scope.
Fixpoint cons_init_dict (m : nat) :=
  match m with
  |0 => add_dict (String (ascii_of_nat m) EmptyString) m empty_dict
  |S m => add_dict (String (ascii_of_nat m) EmptyString) m (cons_init_dict m)
  end.

Definition init_dict := cons_init_dict 256.
Check init_dict.

(* Les dictionnaires contiendront des associations pour au moins toutes les chaˆınes de taille 1 (c.`a.d les
caract`eres) *)
Fixpoint contain_str_len_1_aux (m:nat) (mydict : dict) :=
  match m with
  |0 => match assoc1 (String (ascii_of_nat m) EmptyString) mydict with
        |Some _ => true
        |None   => false
        end
  |S m => match assoc1 (String (ascii_of_nat m) EmptyString) mydict with
          |Some _ => contain_str_len_1_aux m mydict
          |None   => false
          end
  end.
Definition contain_str_len_1 (mydict : dict) : bool :=
  contain_str_len_1_aux 256 mydict.

(* les nombres pr ́esents rempliront exactement tout un intervalle entre 0 inclus et un certain
nombre max exclus. *)

Fixpoint list_nb_contained (mydict : dict) : list nat :=
  match mydict with
  | empty_dict => nil
  | add_dict _ v mydict => cons v (list_nb_contained mydict)
  end.
Fixpoint max_list_nat (l : list nat) : nat :=
  match l with
  |nil => 0
  |cons n l => max n (max_list_nat l)
  end.

Open Scope nat.
Definition contain_an_interval (mydict : dict) : bool :=
  let l := list_nb_contained mydict
  in max_list_nat l =? (List.length l)-2.

Compute list_nb_contained init_dict.
Compute List.length (list_nb_contained init_dict).
Compute contain_an_interval init_dict.


Add LoadPath "~/LocalSoftware/CoqAST/plugin/src/".
Require Import PrintAST.ASTPlugin.

Variables P Q : nat -> Prop.

Theorem t1 : (forall (x : nat), (P x) -> (Q x)) -> (forall (x : nat), P x) -> forall (x : nat), Q x.
Proof.
  intros hxpx hxp n.
  pose (hpn := hxp n).
  pose (hpnqn := hxpx n).
  apply (hpnqn hpn).
Qed.

Print ex.

Theorem t2 : (exists (x : nat), P x) -> exists (x : nat), P x \/ Q x.
Proof.
  intros hpx.
  destruct hpx as [x hpx].

  pose (hpqx := or_introl hpx : P x \/ Q x).


Require Export D.

(* Subtask 1 *)

Theorem double_negation_excluded_middle : 이중부정 -> 배중률.
Proof.
  (* FILL IN HERE *)
  intros NNPP P. apply NNPP. intros Hc.
  eassert (P -> False) by (intros HP; destruct (Hc (@or_introl P (~P) HP))).
  destruct (Hc (@or_intror P (~P) H)).
Qed.

(* Subtask 2 *)

Fixpoint is_square' (fuel : nat) (n : nat) (m : nat) (k : nat) : bool :=
  match fuel with
  | 0 => false
  | S fuel' =>
    if Nat.ltb m n then
      is_square' fuel' n (S (2 * k + m)) (S k)
    else Nat.eqb n m
  end
.
Definition is_square (n : nat) : bool := is_square' (S n) n 0 0.

Lemma is_square'_trefl : forall fuel n m k,
  m = k * k -> is_square' fuel n m k = true -> n 이 제곱수이다.
Proof.
  intro fuel; induction fuel; intros.
  + inv H0.
  + unfold is_square' in H0. fold is_square' in H0.
    destruct (Nat.ltb m n) eqn: Hmn; reflection.
    - apply (IHfuel _ (S (2 * k + m)) (S k)); try assumption. simpl_arith.
    - subst m. exists k. congruence.
Qed.

Lemma is_square_trefl : forall n, is_square n = true -> n 이 제곱수이다.
Proof.
  intros. unfold is_square in H.
  apply is_square'_trefl in H; eauto.
Qed.

Lemma sq_inc' : forall n, n * n <= S n * S n.
Proof.
  intros. replace (S n * S n) with (S (n + n) + n * n) by simpl_arith.
  remember (n * n) as x. remember (S (n + n)) as y. clear.
  induction y; simpl; eauto.
Qed.

Lemma sq_inc : forall x y, x <= y -> x * x <= y * y.
Proof.
  intros x y; revert x. induction y; intros; inv H; eauto.
  apply (le_trans _ (y * y)).
  + apply IHy. assumption.
  + apply sq_inc'.
Qed.

Lemma is_square'_frefl : forall fuel n m k,
  fuel > n - m -> m = k * k
  -> is_square' fuel n m k = false -> forall x, x >= k -> x * x <> n.
Proof.
  intro fuel; induction fuel; intros.
  + inv H.
  + unfold is_square' in H1. fold is_square' in H1.
    destruct (Nat.ltb m n) eqn: Hmn; reflection.
    - inv H2; try (intro Hc; subst; le_contra).
      apply le_prog in H3. remember (S m0) as x; clear m0 Heqx.
      apply (IHfuel _ (S (2 * k + k * k)) (S k)); try assumption; try (
        simpl_arith; fail
      ). apply le_rev in H. apply (le_trans _ (n - k * k)); try assumption.
      remember (k * k) as y. remember (2 * k) as z. revert Hmn; clear; intros.
      destruct n; try (inv Hmn; fail).
      assert (minus_eq : forall x y, x <= y -> S y - x = S (y - x)). {
        clear; induction x; intros; try (induction y; simpl; eauto; fail).
        simpl. destruct y; try (inv H; eauto). apply IHx.
        apply le_S in H1. apply le_rev. assumption.
      } rewrite (minus_eq _ _ (le_rev _ _ Hmn)). apply le_prog. simpl.
      revert n y Hmn; induction z; intros; eauto. destruct n; eauto.
      inv Hmn.
      * replace (S n - S n) with 0 by (clear; induction n; eauto).
        replace (S n - (S z + S n)) with 0 by (
          clear; induction n; simpl_arith; eauto
        ). eauto.
      * replace (S n - (S z + y)) with (n - (z + y)) by eauto.
        rewrite (minus_eq _ _ (le_rev _ _ H0)).
        apply (le_trans _ (n - y)); try assumption; eauto.
    - intros Hc. apply sq_inc in H2. rewrite <- H0 in H2.
      rewrite Hc in H2. clear H0 Hc x k H. inv Hmn.
      * destruct (H1 eq_refl).
      * apply le_prog in H. remember (S m0) as m; clear Heqm m0. le_contra.
Qed.

Lemma is_sqaure_frefl : forall n, is_square n = false -> ~n 이 제곱수이다.
Proof.
  intros. unfold is_square in H.
  assert (n_Sn : S n > n - 0). {
    replace (n - 0) with n by (clear; induction n; eauto). eauto.
  } assert (FACT := is_square'_frefl (S n) n 0 0 n_Sn eq_refl H).
  intro Hc. destruct Hc as [x Heqx].
  eassert (x >= 0) by (clear; induction x; eauto). destruct (FACT x H0 Heqx).
Qed.

Theorem excluded_middle_square : 제곱수 는 극단적이야! .
Proof.
  (* FILL IN HERE *)
  intros x. destruct (is_square x) eqn: Heqx.
  + left. apply is_square_trefl; assumption.
  + right. apply is_sqaure_frefl; assumption.
Qed.

(* Subtask 3 *)

Fixpoint divides' (fuel : nat) (n : nat) (m : nat) : bool :=
  match fuel with
  | 0 => false
  | S fuel' =>
    if Nat.ltb n m then match n with 0 => true | _ => false end
    else divides' fuel' (n - m) m
  end
.

Definition divides (n : nat) (m : nat) := divides' (S n) n m.

Lemma divides'_trefl : forall fuel n m,
  divides' fuel n m = true -> m 이 n 을 나눈다.
Proof.
  intro fuel; induction fuel; intros.
  + inv H.
  + simpl in H. destruct (Nat.ltb n m) eqn: Hnm; reflection.
    - destruct n; try (inv H; fail). exists 0; eauto.
    - apply IHfuel in H. destruct H as [x Heqx].
      assert (n = m * (S x)). {
        revert Hnm Heqx; clear; intros.
        assert (n - m + m = n). {
          clear x Heqx; revert m Hnm. induction n; intros.
          * inv Hnm. eauto.
          * destruct m; eauto. simpl. rewrite <- plus_n_Sm.
            apply le_rev in Hnm. rewrite (IHn _ Hnm). refl.
        } rewrite <- H. rewrite Heqx. rewrite add_comm. simpl_arith.
      } exists (S x); assumption.
Qed.

Lemma divides_trefl : forall n m, divides n m = true -> m 이 n 을 나눈다.
Proof.
  intros. eapply divides'_trefl; eassumption.
Qed.

Lemma divides'_frefl : forall fuel n m, m > 0 -> fuel > n ->
  divides' fuel n m = false -> ~m 이 n 을 나눈다.
Proof.
  intro fuel; induction fuel; intros.
  + inv H0.
  + simpl in H1. destruct (Nat.ltb n m) eqn: Hnm; reflection.
    - destruct n; inv H1. intro Hc.
      destruct Hc as [x Heqx]. destruct x; simpl_arith; try (inv Heqx; fail).
      rewrite Heqx in Hnm. unfold lt in Hnm.
      replace (S (m + m * x)) with (m + S (m * x)) in Hnm by simpl_arith.
      rewrite add_comm in Hnm; le_contra.
    - intro Hc. destruct Hc as [x Heqx]. destruct x.
      * simpl_arith. subst n. inv Hnm. inv H.
      * assert (m 이 n - m 을 나눈다). {
          exists x. subst. simpl_arith. rewrite add_comm.
          remember (m * x) as y; clear. revert y. induction m; intros;
          simpl_arith; induction y; eauto.
        } apply IHfuel in H2; try assumption; try (destruct (Heqx H2); fail).
        destruct m; try (inv H; fail). revert H0 Hnm; clear; intros.
        destruct n; try (inv Hnm; fail). simpl. apply le_rev in H0.
        clear Hnm. apply (le_trans _ (S n)); try assumption. apply le_prog.
        clear. revert n; induction m; intros; induction n; eauto.
Qed.

Lemma divides_frefl : forall n m, m > 0 ->
  divides n m = false -> ~m 이 n 을 나눈다.
Proof.
  intros. eapply divides'_frefl; try eassumption; eauto.
Qed.

Fixpoint is_prime' (n : nat) (m : nat) :=
  match m with
  | 0 => false
  | S m' => match m' with
    | 0 => true
    | S _ => if divides n m then false else is_prime' n m'
    end
  end
.

Definition is_prime (n : nat) :=
  match n with
  | 0 => false
  | S n' => is_prime' n n'
  end
.

Lemma is_prime'_trefl : forall n m,
  is_prime' n m = true -> forall x, 1 < x <= m -> ~x 가 n 을 나눈다.
Proof.
  intros n m; revert n. induction m; intros.
  + destruct H0; le_contra.
  + simpl in H. destruct m.
    - destruct H0; le_contra.
    - destruct (divides n (S (S m))) eqn: HnSSm; try (inv H; fail).
      destruct H0. inv H1.
      * apply divides_frefl; try assumption. clear; induction m; eauto.
      * apply IHm; try assumption. split; assumption.
Qed.

Lemma is_prime_trefl : forall n, is_prime n = true -> n 이 소수이다.
Proof.
  intros. unfold is_prime in H.
  destruct n; try destruct n.
  + inv H.
  + inv H.
  + split.
    - clear; induction n; eauto.
    - intros. apply (is_prime'_trefl _ (S n)); try assumption.
      destruct H0. split; try assumption. apply le_rev; assumption.
Qed.

Lemma is_prime'_frefl : forall n m,
  1 < m < n -> is_prime' n m = false -> ~n 이 소수이다.
Proof.
  intros n m; revert n. induction m; intros; destruct H; try le_contra.
  simpl in H0. destruct m; try le_contra.
  destruct (divides n (S (S m))) eqn: HnSSm.
  + apply divides_trefl in HnSSm. destruct HnSSm. intro Hc.
    unfold 소수 in Hc. destruct Hc as [_ Hc].
    specialize (Hc (S (S m)) (conj H H1)). apply Hc. eexists; eauto.
  + destruct m; try (inv H0; fail). apply IHm; try split.
    - clear. induction m; eauto.
    - eapply le_trans; try eassumption; eauto.
    - assumption.
Qed.

Lemma is_prime_frefl : forall n, is_prime n = false -> ~n 이 소수이다.
Proof.
  intros. unfold is_prime in H.
  destruct n; try destruct n.
  + clear. intro Hc. destruct Hc as [Hc _]. le_contra.
  + clear. intro Hc. destruct Hc as [Hc _]. le_contra.
  + eapply is_prime'_frefl; try eassumption; split; eauto.
    destruct n.
    - inv H.
    - clear; induction n; eauto.
Qed.

Theorem excluded_middle_prime : 소수 는 극단적이야! .
Proof.
  (* FILL IN HERE *)
  intros n. destruct (is_prime n) eqn: EQ.
  + left. apply is_prime_trefl; assumption.
  + right. apply is_prime_frefl; assumption.
Qed.


From mathcomp.ssreflect Require Import all_ssreflect.

Structure sset (T:eqType) := SSet {
                                    seqOf :> seq T;
                                    uniqueness    : uniq seqOf }.

Canonical  sset_subType T := Eval hnf in [subType for seqOf T ].
Canonical  sset_eqMixin T:= Eval hnf in [eqMixin of sset T by <:].
Canonical  sset_eqType T := Eval hnf in  EqType (sset T) (sset_eqMixin T).

Lemma undup_preserves_in {T:eqType} (a:T) (l:seq T) : (a \in l) == (a \in undup l).
  move: l.
  elim =>//=.
  move=> a0 l IH.
  rewrite in_cons.
  case_eq (a == a0).
  move /eqP =><-.

  simpl.
  case_eq (a \in l).
    by move=><-.
      by rewrite in_cons eq_refl.
  move=> Ha.
  simpl.
  case_eq (a0 \in l) =>//=.
  by rewrite in_cons Ha.
Qed.

  Definition union {T:eqType} (x y:sset T) : sset T.
  refine (SSet _ (undup (x++y)) _).

  destruct x,y.
  simpl.
  move: (undup_uniq seqOf0) => H0.
  move: (undup_uniq seqOf1) => H1.

  elim seqOf0. by exact H1.

  move=> a l IH.
  apply undup_uniq.
  Defined.

  Definition intersect {T:eqType} (x y: sset T) : sset T.
    refine (SSet _ ( filter (fun e => e \in seqOf _ y) x ) _ ).
    apply filter_uniq.
    exact: uniqueness x.
  Defined.

  Definition EmptySet t: sset t.
    refine (SSet _ [::] _).
    done.
  Defined.

  Definition mk_set {T:eqType} (x:T) : sset T. by refine ( SSet _ [:: x ] _ ).
  Defined.


(* Deletion *)
(*
 * This deletion function was written in the beginning with the start pointer
 * data structure. It was tested to work but nothing was ever proved about it
 * due to time constraints.
 *)
(*
Fixpoint delete_from_list {X: Type} (sk: nat) (lst: list (nat * X))
                          : list (nat * X) :=
  match lst with
  | nil => nil
  | (k, v) :: xs => if beq_nat k sk
                    then xs
                    else (k,v) :: delete_from_list sk xs

  end.

Definition node_length {X: Type} {b: nat} (tree: bplustree b X): nat :=
  match tree with
  | bptLeaf kvl => length kvl
  | bptNode sp nodes => length nodes
  end.

Eval simpl in node_length root.

Definition merge_trees {X: Type} {b:nat} (t1 t2: bplustree b X)
                       : bplustree b X :=
  match (t1, t2) with
  | (bptNode sp1 lst1, bptNode sp2 lst2) =>
      bptNode b X sp1 (app lst1 ((peek_key_deep sp2, sp2) :: lst2))
  | (bptLeaf lst1, bptLeaf lst2) => bptLeaf b X (app lst1 lst2)
  | _ => t1
  end.

Definition distr_betweentwo {X: Type} {b: nat} (t1 t2: bplustree b X)
                             : (bplustree b X * bplustree b X) :=
  match (t1, t2) with
  | (bptNode sp1 lst1, bptNode sp2 lst2) =>
    if blt_nat (length lst1) b (*the list of t1 is too small*)
    then
      (* Here I plus by 1 as the sp2 is being added to lst1 no matter what *)
      let index_to_split_list2 := minus b (S (length lst1)) in
      let (part1, part2) := split_at_index lst2 index_to_split_list2 in

      let ret_tree1 := bptNode b X sp1 ((snoc lst1 (peek_key_deep sp2, sp2)) ++ part1) in

      let new_list2_sp := match head part2 with
                          | None => sp2
                          | Some p => snd p
                          end in
      let new_list2 := match tail part2 with
                       | None => nil
                       | Some xs => xs
                       end in

      let ret_tree2 := bptNode b X new_list2_sp new_list2 in
      (ret_tree1, ret_tree2)

    else (* the list of t2 is too small*)
      let index_to_split_list1 := minus (length lst1) (minus b (length lst2)) in
      let (part1, part2) := split_at_index lst1 index_to_split_list1 in

      let ret_tree1 := bptNode b X sp1 part1 in

      let new_list2_sp := match head part2 with
                          | None => sp2
                          | Some p => snd p
                          end in
      let tail_of_part2 := match tail part2 with
                       | None => nil
                       | Some xs => xs
                       end in

      let ret_tree2 := bptNode b X new_list2_sp (app (tail_of_part2) ((peek_key_deep sp2, sp2) :: lst2)) in

      (ret_tree1, ret_tree2)
  | (bptLeaf kvl1, bptLeaf kvl2) =>
    let (first_half, second_half) := split_in_half (app kvl1 kvl2) in
    (bptLeaf b X first_half, bptLeaf b X second_half)
  | _ => (t1, t2)
  end.

Definition leaf := bptLeaf 1 nat [(1, 1)].
Definition emptyNode := bptNode 1 nat left [].
Definition twoEntriesNode := bptNode 1 nat leaf [(peek_key centre, centre), (peek_key right, right)].

Eval compute in twoEntriesNode.
Eval compute in emptyNode.
Eval compute in distr_betweentwo twoEntriesNode emptyNode.

Fixpoint redistribute_list {X: Type} {b: nat} (nodes: list (nat * bplustree b X))
                     : (list (nat * bplustree b X) * bool) :=
  match nodes with
  | nil => (nil, false)
  | x1 :: xs1 =>
         match xs1 with
	     | nil => ([x1], false)
	     | x2 :: nil => if blt_nat (node_length (snd x1)) b
	                    then
	             		  if beq_nat (node_length (snd x2)) b
	             		  then
	               			let merge_res := merge_trees (snd x1) (snd x2) in
	               			([(peek_key_deep merge_res, merge_res)], true)
	             		  else
	               			let (a, b) := distr_betweentwo (snd x1) (snd x2) in
	               			((peek_key_deep a, a) :: (peek_key_deep b, b) :: nil, false)
	           			else if blt_nat (node_length (snd x2)) b
	                	then
	                  	  if beq_nat (node_length (snd x1)) b
	                  	  then
	                    	let merge_res := merge_trees (snd x1) (snd x2) in
	                    	([(peek_key_deep merge_res, merge_res)], true)
	                  	  else
	                    	let (a, b) := distr_betweentwo (snd x1) (snd x2) in
	                    	((peek_key_deep a, a) :: (peek_key_deep b, b) :: nil, false)
	                	else
	                  	  (x1 :: x2 :: nil, false)
	     | x2 :: xs2 => if blt_nat (node_length (snd x1)) b
	                    then
	                      if beq_nat (node_length (snd x2)) b
	                      then
	                        let merge_res := merge_trees (snd x1) (snd x2) in
	                        ((peek_key_deep merge_res, merge_res) :: xs2, true)
	                      else
	                        let (a, b) := distr_betweentwo (snd x1) (snd x2) in
	                        ((peek_key_deep a, a) :: (peek_key_deep b, b) :: xs2, false)
	                    else
	                      let (res, should_balance) := redistribute_list xs1 in
	                      (x1 :: res, should_balance)
	     end
  end.

Definition redistribute {X: Type} {b: nat} (tree: bplustree b X)
                            : (bplustree b X * bool) :=
  match tree with
  | bptLeaf kvl => (tree, false)
  | bptNode sp nil => (tree, true)
  | bptNode sp lst =>
    let (res, should_balance) := redistribute_list ((peek_key_deep sp, sp) :: lst) in
    match res with
    | nil => (bptNode b X sp res, should_balance) (*Should never be a possibility*)
    | (k, v) :: xs => (bptNode b X v xs, should_balance)
    end
  end.

Definition balance {X: Type} {b: nat} (tree_ind: bplustree b X * bool)
                            : bplustree b X * bool :=
  match snd tree_ind with
  | false => (fst tree_ind, false)
  | true  => redistribute (fst tree_ind)
  end.

(* Returns a tree that it has deleted an entry from, a bool indicating if balancing should
   be performed *)
Fixpoint delete' {X: Type} {b: nat} (sk: nat) (tree: (bplustree b X))
                : (bplustree b X * bool) :=

  let fix traverse_node (nptrs: list (nat * (bplustree b X)))
                   : (list (nat * (bplustree b X)) * bool) :=
    match nptrs with
    | nil => (nil, false)
    | (k1,t1) :: xs => match xs with
                       | nil => let (new_tree, should_balance) := delete' sk t1 in
                                  (((peek_key_deep new_tree, new_tree) :: xs), should_balance)

                       | (k2, t2) :: xs' => if blt_nat sk k2
                                            then
                                              let (new_tree, should_balance) := delete' sk t1 in
                                			    (((peek_key_deep new_tree, new_tree) :: xs), should_balance)

                                            else
                                              let (traversed, should_balance) := traverse_node xs in
                       						  ((k1,t1) :: traversed, should_balance)
                       end
    end

  in

  match tree with
  | bptLeaf kvl => let deletion_lst := delete_from_list sk kvl in
                     if blt_nat (length deletion_lst) b
                     then (bptLeaf b X deletion_lst, true)
                     else (bptLeaf b X deletion_lst, false)
  | bptNode sp nil =>
                let (new_sp, should_balance) := delete' sk sp in
  			      let new_node := (bptNode b X new_sp nil) in
  			        balance (new_node, should_balance)

  | bptNode sp ((k, child) :: xs) =>
                if blt_nat sk k
  			    then
  			      let (new_sp, should_balance) := delete' sk sp in
  			      let new_node := (bptNode b X new_sp ((k, child) :: xs)) in
  			        balance (new_node, should_balance)

  			    else
  			      let (new_node_list, should_balance) := traverse_node ((k, child) :: xs) in
  			      let new_node := (bptNode b X sp (new_node_list)) in
  			        balance (new_node, should_balance)
  end.

Definition delete {X: Type} {b: nat} (sk: nat) (tree: (bplustree b X))
                : bplustree b X :=
  match fst (delete' sk tree) with
  | bptNode sp nil => sp
  | t => t
  end.

Definition empty2Tree := bptLeaf 1 nat [].
Definition atree:= insert 17 117 (insert 6 106 (insert 31 131 (insert 4 104 (insert 20 120 (insert 15 115
                   (insert 1 101 (insert 7 107 (insert 3 103 empty2Tree)))))))).
Eval compute in atree.

(*Definition missing_some := delete 31 (delete 20 (delete 6 (delete 3 (delete 4 atree)))).
Eval compute in missing_some.
Definition missing_17 := delete 17 missing_some.
Eval compute in delete 15 (delete 7 (delete 1 missing_17)).*)

  *)


Require Import CoqCompile.Cps.
(* must import ZArith first, otherwise coq wont recognize Z type *)
Require Import ZArith List String Bool.
Require Import ExtLib.Sets.ListSet.
Require Import ExtLib.Decidables.Decidable.

Set Implicit Arguments.
Set Strict Implicit.

(* implements Abstracting Abstract Machines from class 2012-10-22 *)

Module AAMach.
  Import CPS.

  (********** type definitions **********)

  (* abstract values *)
  Inductive hval : Type :=
  | Con_h : constructor -> hval
  | Z_h : Z -> hval
  | Tup_h : list var -> hval
  (* | Clo_h : env_t (lset (@eq hval)) -> list var -> exp -> hval. *)
  (* dont need closures? *)
  | Lam_h : list var -> exp -> hval.

  Definition is_Z_h (v:hval) :bool:=
    match v with
      | Z_h _ => true
      | _ => false
    end.
  Definition is_Tup_h (v:hval): bool:=
    match v with
      | Tup_h _ => true
      | _ => false
    end.
  Definition is_Lam_h (v:hval):bool:=
    match v with
      | Lam_h _ _ => true
      | _ => false
    end.
  Definition is_Con_h (v:hval):bool:=
    match v with
      | Con_h _ => true
      | _ => false
    end.

  (* sets of abstract values *)
  Definition hset := lset (@eq hval).

  (* abstract environment mapping variables to sets of abstract values *)
  Definition henv := env_t hset.

(********** equality functions **********)

  Definition exp_eq_dec : forall (x y:exp), {x=y}+{x<>y}.
    fix exp_eq_dec 1
      with (decl_eq_dec (x y:decl) {struct x}: {x=y}+{x<>y}).
    repeat decide equality.
    repeat decide equality.
  Defined.

  Definition exp_eq_bool (e1 e2: exp) : bool :=
    if exp_eq_dec e1 e2 then true else false.

  Definition string_dec_bool (s1 s2: string) : bool :=
    if string_dec s1 s2 then true else false.

Section eq_list.
  Context {A:Type}.
  Variable (eqA:A->A->bool).
  Fixpoint eq_list (l1 l2: list (A)): bool:=
    match l1,l2 with
      | nil,nil => true
      | (a1)::q1,(a2)::q2=> eqA a1 a2 && eq_list q1 q2
      | _,_ => false
    end.
End eq_list.

(* Section eq_pair. *)
(*   Context {A B :Type}. *)
(*   Variable (eqA:A->A->bool). *)
(*   Variable (eqB:B->B->bool). *)
(*   Fixpoint eq_pair (p1 p2: A*B): bool := *)
(*     match p1,p2 with *)
(*       | (p1a,p1b),(p2a,p2b) => eqA p1a p2a && eqB p1b p2b *)
(*     end. *)
(* End eq_pair. *)

(* Section eq_env. *)
(*   Context {A:Type}. *)
(*   Variable (eqA:A->A->bool). *)
(*   Definition eq_env (env1 env2: env_t A):bool:= *)
(*     eq_list (eq_pair string_dec_bool eqA) env1 env2. *)
(* End eq_env. *)

(* Section eq_set. *)
(*   Context{A:Type}. *)
(*   Variable(eqA:A->A->bool). *)
(*   Definition eq_set (set1 set2: lset (@eq A)):bool:= *)
(*     eq_list eqA set1 set2. *)
(* End eq_set. *)

  Fixpoint hval_eq (h1 h2: hval) : bool :=
    match h1, h2 with
      | Con_h c1, Con_h c2 => string_dec_bool c1 c2
      | Z_h z1, Z_h z2 => Zeq_bool z1 z2
      | Tup_h xs1, Tup_h xs2 => eq_list string_dec_bool xs1 xs2
      (* | Clo_h env1 xs1 e1, Clo_h env2 xs2 e2 =>  *)
      (*   eq_env (eq_set hval_eq) env1 env2 && *)
      (*   eq_list string_dec_bool xs1 xs2 && *)
      (*   exp_eq_bool e1 e2 *)
      | Lam_h xs1 e1, Lam_h xs2 e2 =>
        eq_list string_dec_bool xs1 xs2 && exp_eq_bool e1 e2
      | _,_  => false
    end.
  Definition hval_eq_prop (h1 h2:hval):Prop:=
    if hval_eq h1 h2 then True else False.

(********** set functions **********)

(* returns union of vs1 and vs2 *)
Fixpoint hset_union (vs1:hset) (vs2:hset):hset:=
  match vs1 with
    | nil => vs2
    | v::vs => hset_union vs (lset_add hval_eq v vs2)
  end.

(* filters out elements x of vs where f(x) = false *)
Fixpoint hset_filter (f:hval->bool) (vs:hset) : hset :=
  match vs with
    | nil => nil
    | v::rest => if f v then v::hset_filter f rest else hset_filter f rest
  end.

(********** env functions **********)

(* extend env(x) with v, ie env(x) = env(x) \cup {v} *)
Fixpoint extend_env (env:henv) (x:var) (v:hval): henv:=
  match env with
    | nil => (x,(lset_add hval_eq v (lset_empty hval_eq_prop)))::nil
    | (y,vs)::rest =>
      if string_dec x y
        then (x,(lset_add hval_eq v vs))::rest
        else (y,vs)::extend_env rest x v
  end.

(* extend env(x) with vs, ie env(x) = env(x) \cup vs *)
Fixpoint extend_envs (env:henv) (x:var) (vs:hset):henv:=
  match env with
    | nil => (x,vs)::nil
    | (y,vs2)::rest =>
      if string_dec x y
        then (x,hset_union vs vs2)::rest
        else (y,vs2)::extend_envs rest x vs
  end.

Local Open Scope string_scope.

Definition h1 := Con_h "A".
Definition h2 := Con_h "B".
Definition h3 := Tup_h ("x"::"y"::"z"::nil).
Definition h4 := Tup_h ("a"::"b"::nil).
Definition h5 := Z_h 2.

Definition env1 := extend_env nil "x" h1.
Definition env2 := extend_env env1 "x" h2.
Definition env3 := extend_env env2 "x" h1.
(* h1 ("A") should only appear once *)
Eval compute in env3.
Definition env4 := extend_env env3 "y" h1.
Definition env5 := extend_env env4 "y" h3.
Eval compute in env5.

(* extracts var from Op *)
Definition o2x (o:op):var :=
  match o with
    | Var_o x => x
    | _ => "x" (* shouldnt get here bc we are assuming only vars *)
  end.

Local Close Scope string_scope.

(* non-option version of env lookup, return emptyset if x\notin dom(env)*)
Fixpoint env_lookup (env:henv) (x:var):hset:=
  match env with
    | nil => (lset_empty hval_eq_prop)
    | (y,vs)::rest => if string_dec x y then vs else env_lookup rest x
  end.

(* env(x) = env(x) \cup env(\pi i tup) *)
Fixpoint extend_env_proj_tup (env:henv) (x:var) (i:Z) (tup:list var): henv:=
  extend_envs env x (env_lookup env (nth (Z.abs_nat i) tup x)).

(* extend env(x) with ith element of every tuple in tups *)
Fixpoint extend_env_proj (env:henv) (x:var) (i:Z) (tups:hset):henv:=
  match tups with
    | nil => env
    | (Tup_h xs)::rest =>
      extend_env_proj (extend_env_proj_tup env x i xs) x i rest
    | _ => env (* can get here bc tups is all Tup_h *)
  end.

(* for x in xs, extend env(x) with env(arg), for corresponding arg in args *)
Fixpoint extend_env_xs (env:henv) (xs:list var) (args:list var):henv:=
  match xs,args with
    | nil,nil => env
    | x::rest,y::restargs =>
      extend_env_xs (extend_envs env x (env_lookup env y)) rest restargs
    | _,_ => env
  end.

(* merge two environments, extending when appropriate, and adding otherwise *)
Fixpoint merge_envs (env1:henv) (env2:henv):henv:=
  match env1,env2 with
    | nil,nil => nil
    | nil,_ => env2
    | _,nil => env1
    | (x,vs)::rest,_ => merge_envs rest (extend_envs env2 x vs)
  end.

Local Open Scope string_scope.

(********** Abstracting Abstract Machines **********)

(* extend env with decl d *)
Fixpoint extend (env:henv) (d:decl) : henv :=
  match d with
    | Op_d x (Con_o c) => extend_env env x (Con_h c)
    | Op_d x (Int_o z) => extend_env env x (Z_h z)
    | Prim_d x Plus_p xs => extend_env env x (Con_h "Int")
    | Prim_d x MkTuple_p os => extend_env env x (Tup_h (map o2x os))
    | Prim_d x Proj_p ((Int_o i)::tup::nil) =>
      extend_env_proj env x i (hset_filter is_Tup_h (env_lookup env (o2x tup)))
    | Fn_d f xs e => extend_env env f (Lam_h xs e)
    | Rec_d ds =>
      (fix map_extend (ds:list decl) (env:henv): henv :=
        match ds with
          | nil => env
          | d::rest => map_extend rest (extend env d)
        end) ds env
    | _ => env
  end.

Local Close Scope string_scope.

(* given machine state of e and env, compute list of envs,
   one for each possible final state *)
Fixpoint aeval (fuel:nat) (e:exp) (env:henv) : list henv:=
  match fuel with
    | 0 => nil
    | S n =>
      match e with
        | App_e o os =>
          let lams := hset_filter is_Lam_h (env_lookup env (o2x o)) in
          let args := map o2x os in
            flat_map
            (fun v =>
              match v with
                | Lam_h xs e => aeval n e (extend_env_xs env xs args)
                | _ => nil
              end)
            lams
        | Let_e d e => aeval n e (extend env d)
        | Switch_e o arms def =>
          (flat_map
            (fun arm =>
              match arm with
                | (_,e) => aeval n e env
              end)
            arms) ++
          (match def with
             | None => nil
             | Some e => aeval n e env
           end)
        | Halt_e o => env::nil
      end
  end.

(* computes abstract env for given program e
   by merging all envs from possible states *)
Definition inj (e:exp) : henv := fold_left merge_envs (aeval 100 e nil) nil.

Local Open Scope string_scope.

Definition e1 := Halt_e (Var_o "x").
Eval compute in inj e1.

Definition e2 := Let_e (Op_d "x" (Var_o "y")) e1.
Eval compute in inj e2.

(* test projection *)
Definition e3 := Let_e (Op_d "x" (Con_o "A"))
                  (Let_e (Op_d "y" (Con_o "B"))
                   (Let_e (Prim_d "z" MkTuple_p (Var_o "x"::Var_o "y"::nil))
                     (Let_e (Op_d "w" (Con_o "C"))
                       (Let_e (Prim_d "w" Proj_p (Int_o 0::Var_o "z"::nil))
                         (Halt_e (Var_o "w")))))).
(* env(w) should be "C" and either "A" or "B",
   depending on whether e3 gets the 1st or 2nd element from tuple "z" *)
Eval compute in inj e3.

Definition e4 :=
  Let_e (Op_d "1" (Int_o 1))
   (Let_e (Op_d "2" (Int_o 2))
     (Let_e (Op_d "3" (Int_o 3))
       (Let_e (Op_d "4" (Int_o 4))
         (Let_e (Fn_d "f" ("x"::"y"::nil)
                  (Let_e (Prim_d "z" Plus_p (Var_o "x"::Var_o "y"::nil))
                    (Halt_e (Var_o "z"))))
           (App_e (Var_o "f") (Var_o "1"::Var_o "2"::nil)))))).
(* result "z" should have abstract value "Int" *)
Eval compute in inj e4.

(* test combining of fn parameters of the same name*)
Definition e5 :=
  Let_e (Op_d "1" (Int_o 1))
   (Let_e (Op_d "2" (Int_o 2))
     (Let_e (Op_d "3" (Int_o 3))
       (Let_e (Op_d "4" (Int_o 4))
         (Let_e (Fn_d "g" ("x"::"y"::nil)
                  (Let_e (Prim_d "z" Plus_p (Var_o "x"::Var_o "y"::nil))
                    (Halt_e (Var_o "z"))))
           (Let_e (Fn_d "f" ("x"::"y"::nil)
                    (App_e (Var_o "g") (Var_o "3"::Var_o "4"::nil)))
             (App_e (Var_o "f") (Var_o "1"::Var_o "2"::nil))))))).
(* env(x) and env(y) should have multiple values: 1 and 3, and 2 and 4 *)
Eval compute in inj e5.

(* test multiple possible tuples in a projection *)
Definition e6 :=
  Let_e (Op_d "1" (Int_o 1))
   (Let_e (Op_d "2" (Int_o 2))
     (Let_e (Op_d "3" (Int_o 3))
       (Let_e (Op_d "4" (Int_o 4))
         (Let_e (Prim_d "tup1" MkTuple_p (Var_o "1"::Var_o "2"::nil))
           (Let_e (Prim_d "tup2" MkTuple_p (Var_o "3"::Var_o "4"::nil))
             (Let_e (Fn_d "g" ("x"::nil)
                      (Let_e (Prim_d "z" Proj_p (Int_o 1::Var_o "x"::nil))
                        (Halt_e (Var_o "z"))))
               (Let_e (Fn_d "f" ("x"::nil)
                        (App_e (Var_o "g") (Var_o "tup2"::nil)))
                 (App_e (Var_o "f") (Var_o "tup1"::nil))))))))).
(* env(x) should have both tuples,
    and "z" should have two values, one from each tuple *)
Eval compute in inj e6.

(* test multiple possible lambdas in app *)
Definition e7 :=
  Let_e (Op_d "1" (Int_o 1))
   (Let_e (Op_d "2" (Int_o 2))
     (Let_e (Op_d "3" (Int_o 3))
       (Let_e (Op_d "4" (Int_o 4))
         (Let_e (Fn_d "g1" ("x1"::"y1"::nil)
                  (Let_e (Prim_d "z1" Plus_p (Var_o "x1"::Var_o "y1"::nil))
                    (Halt_e (Var_o "z1"))))
           (Let_e (Fn_d "g2" ("x2"::"y2"::nil)
                    (Let_e (Prim_d "z2" Plus_p (Var_o "x2"::Var_o "y2"::nil))
                      (Halt_e (Var_o "z2"))))
             (Let_e (Fn_d "g3" ("x3"::"y3"::nil)
                      (Let_e (Prim_d "z3" Plus_p (Var_o "x3"::Var_o "y3"::nil))
                        (Halt_e (Var_o "z3"))))
               (Let_e (Fn_d "f" ("g"::"x"::"y"::nil)
                        (App_e (Var_o "g") (Var_o "x"::Var_o "y"::nil)))
                 (Switch_e (Var_o "1")
                   ((Int_p 1,(App_e (Var_o "f") (Var_o "g1"::Var_o "1"::Var_o "2"::nil)))::
                    (Int_p 2,(App_e (Var_o "f") (Var_o "g2"::Var_o "3"::Var_o "4"::nil)))::nil)
                   (Some (App_e (Var_o "f") (Var_o "g3"::Var_o "2"::Var_o "3"::nil))))))))))).
(* g should be bound to three lambdas,
   all of x1-3, y1-3, z1-3 should be bound,
   and x and y should be bound to three values each *)
Eval compute in inj e7.

Close Scope string_scope.

End AAMach.


From Coq Require Import
  PArith.PArith Program.Wf.
From DEZ Require Export
  Init.

From Coq Require Import Lia List Recdef.
Import ListNotations Pos.

Local Open Scope positive_scope.

Definition seq (n p : positive) : list positive :=
  map of_nat (seq (to_nat n) (to_nat p)).

(** A deep dive into "efficient pairing functions".
    Positive domain constraints make them even more horrifying. *)

(** * Cantor (triangle shell) *)

Definition tri (n : positive) : positive :=
  div2 (n * (1 + n)).

Definition tri_inverse_lb (n : positive) : positive :=
  sqrt (2 * n) - 1.

Definition tri_inverse_ub (n : positive) : positive :=
  sqrt (2 * n).

Definition tri_search (n p q : positive) : positive :=
  if q <? tri p then n else p.

Definition tri_inverse (n : positive) : positive :=
  tri_search (tri_inverse_lb n) (tri_inverse_ub n) n.

Definition c_unpair (n p : positive) : positive :=
  div2 (3 + (n + p - 1) ^ 2 - n - p) + p - 1.
  (* div2 (4 + (n + p) ^ 2 - 3 * (n + p)) + p - 1. *)

Definition c_pair (n : positive) : positive * positive :=
  match peanoView n with
  | PeanoOne => (1, 1)
  | PeanoSucc p _ =>
  let q := tri_inverse p in
  let r := n - tri q in
  (2 + q - r, r)
  end.

(* Compute map (prod_uncurry c_unpair o c_pair) (map of_nat (seq 1%nat 64%nat)). *)

(** * Szudzik (square shell) *)

Definition s_unpair (n p : positive) : positive :=
  if p <? n then
  1 + n * n + p - 2 * n else
  p * p + n + p - 2 * p.

Definition s_pair (n : positive) : positive * positive :=
  match peanoView n with
  | PeanoOne => (1, 1)
  | PeanoSucc p _ =>
    let q := sqrt p in
    let r := q * q in
    let s := 1 + q in
    if n <? s + r then
    (s, n - r) else
    (n - r - q, s)
  end.

(** * Rosenberg--Strong (square shell) *)

Definition rs_unpair (n p : positive) : positive :=
  let q := max n p in
  (** We now know [n <= q] and [p <= q], so [n < 1 + q].
      Therefore [1 + n < 1 + 1 + q], leading to
      [1 < 1 + 1 + q - n] and thus [1 <= 1 + q - n].
      Similarly [1 <= 1 + q - p].
      This is probably useless information. *)
  let r := q * q in
  (** We now know [q <= r], so [q < 1 + r].
      Therefore [1 + q < 1 + 1 + r], leading to
      [1 < 1 + 1 + r - q] and thus [1 <= 1 + r - q].
      This is the tightest we can cut it. *)
  1 + r - q + p - n.

Definition rs_pair (n : positive) : positive * positive :=
  match peanoView n with
  | PeanoOne => (1, 1)
  | PeanoSucc p _ =>
    let q := sqrt p in
    let r := q * q in
    let s := 1 + q in
    if n <? s + r then
    (s, n - r) else
    (2 * s + r - n, s)
  end.

(* Compute map (prod_uncurry rs_unpair o rs_pair)
  (map of_nat (seq (S O) 64%nat)). *)


Require Import A1_Plan A2_Orientation A3_Metrique .
Require Import B5_BetweenProp B7_Tactics .
Require Import C1_Distance C3_SumDistance.

Section DISTANCE_LE.

Definition DistanceLe := fun M N : Point => Segment Oo N M.

Lemma DistanceLeRefl : forall A : Point, DistanceLe A A.
Proof.
	unfold DistanceLe in |- *; intros.
	immediate1.
Qed.

Lemma DistanceLeOo : forall A : Point, DistanceLe Oo A.
Proof.
	unfold DistanceLe in |- *; intros.
	immediate1.
Qed.

Lemma SegmentDistanceLe : forall A B C : Point,
	Segment A B C ->
	DistanceLe (Distance A C) (Distance A B).
Proof.
	intros; unfold DistanceLe in |- *.
	apply (EquiDistantSegment A B C Oo (Distance A B) (Distance A C) Uu).
	 trivial.
	 apply EquiDistantSym; apply EquiDistantDistance.
	 apply EquiDistantSym; apply EquiDistantDistance.
	 immediate1.
	 apply IsDistanceDistance.
	 apply IsDistanceDistance.
Qed.

Lemma DistanceLeSegment : forall A B C D : Point,
	DistanceLe (Distance A C) (Distance A B) ->
	A <> D ->
	ClosedRay A D B ->
	ClosedRay A D C ->
	Segment A B C.
Proof.
	unfold DistanceLe in |- *; intros.
	apply (EquiDistantSegment Oo (Distance A B) (Distance A C) A B C D).
	 trivial.
	 apply EquiDistantDistance.
	 apply EquiDistantDistance.
	 trivial.
	 trivial.
	 trivial.
Qed.

Lemma DistanceLeTrans : forall A B C : Point,
	DistanceLe A B ->
	DistanceLe B C ->
	DistanceLe A C.
Proof.
	unfold DistanceLe in |- *; intros.
	apply (SegmentTransADB Oo A B C); trivial.
Qed.

Lemma DistanceLeDistancePlus : forall A B : Point,
	IsDistance A ->
	DistanceLe A (DistancePlus A B).
Proof.
	intros; unfold DistanceLe in |- *.
	pattern A at 2 in |- *; rewrite <- (IsDistanceEqDistance A H).
	rewrite DistancePlusOoM; apply IsDistanceSegmentDistancePlus.
	apply IsDistanceDistance.
Qed.

Lemma DistanceLeDistancePlusDistance : forall A B C: Point,
	DistanceLe (Distance A B) (DistancePlus (Distance A B) C).
Proof.
	intros; apply DistanceLeDistancePlus.
	apply IsDistanceDistance.
Qed.

Lemma DistanceLeDistancePlusDistancePlus : forall A B C: Point,
	DistanceLe (DistancePlus A B) (DistancePlus (DistancePlus A B) C).
Proof.
	intros; apply DistanceLeDistancePlus.
	apply IsDistanceDistancePlus.
Qed.

Lemma LeftRegularDistanceLe : forall A B C : Point,
	DistanceLe A B ->
	DistanceLe (DistancePlus C A) (DistancePlus C B).
Proof.
	intros.
	rewrite (DistancePlusOoN C B).
	rewrite <- (Chasles Oo A B).
	 rewrite DistancePlusAssoc.
	   rewrite <- (DistancePlusOoN C A).
	   apply DistanceLeDistancePlusDistancePlus.
	 exact H.
Qed.

End DISTANCE_LE.


Require Import Sorting.Permutation.
Require Import Lia.
Require Import List.
Export ListNotations.
Require Import Arith Arith.EqNat.
Require Extraction.

Fixpoint is_sorted' (l : list nat) : bool :=
  match l with
  | []      => true
  | a :: l' =>
      match l' with
      | []       => true
      | b :: l'' => leb a b && is_sorted' l'
      end
  end.

Inductive is_smallest : nat -> list nat -> Prop :=
| smallest_unit : forall a, is_smallest a [a]
| smallest_head : forall a b tl
                         (LE  : a <= b)
                         (SST : is_smallest b tl),
    is_smallest a (a :: tl)
| smallest_tail : forall a b tl
                         (LT : a < b)
                         (SST : is_smallest a tl),
    is_smallest a (b :: tl)
.

Inductive is_sorted : list nat -> Prop :=
| sorted_nil   : is_sorted []
| sorted_one a : is_sorted [a]
| sorted_cons a tl
              (SORTED : is_sorted tl)
              (SST : is_smallest
                       a (a :: tl))
  :
    is_sorted (a :: tl)
.

Theorem sort l :
  { l' | Permutation l l' & is_sorted l' }.
Proof.
  induction l.
  { exists [].
    { apply perm_nil. }
    apply sorted_nil. }
  inversion IHl.
  rename x into l'.
  rename H into PERM.
  rename H0 into SORT.
Abort.

Inductive is_inserted : nat -> list nat -> list nat -> Prop
  :=
| ins_head : forall n tl, is_inserted n tl (n :: tl)
| ins_tail : forall n m tl tl'
                    (INS : is_inserted n tl tl'),
    is_inserted n (m :: tl) (m :: tl')
.

Lemma is_inserted_perm a tl tl'
  (INS : is_inserted a tl tl') :
  Permutation (a :: tl) tl'.
Proof.
  generalize dependent a.
  generalize dependent tl'.
  induction tl.
  { intros.
    inversion INS.
    apply Permutation_refl. }
    (* Search Permutation. *)
    (* apply perm_skip. *)
    (* apply perm_nil. *)
  intros.
  inversion INS.
  { apply Permutation_refl. }
  apply IHtl in INS0.
  (* apply perm_trans with (l' := (a :: a0 :: tl)). *)
  eapply perm_trans.
  { apply perm_swap. }
  apply perm_skip. apply INS0.
Qed.

Lemma insert_sorted a l (SORT : is_sorted l) :
  { l' | is_inserted a l l' & is_sorted l'}.
Proof.
  induction l.
  { exists [a]; constructor. }
  edestruct IHl as [l'].
  { clear -SORT. inversion SORT; subst.
    { constructor. }
    assumption. }
  destruct (le_gt_dec a a0).
  { exists (a::a0::l).
    { constructor. }
    apply sorted_cons; auto.
    eapply smallest_head; eauto.
    inversion SORT; subst.
    { constructor. }
    assumption. }

  exists (a0::l').
  { constructor. assumption. }

  clear -SORT i i0 g.
  induction i.
  { constructor; auto.
    eapply smallest_head with (b:=n).
    { lia. }
    inversion i0; subst.
    { constructor. }
    assumption. }

  constructor; auto.
  apply smallest_head with (b:=m).
  2: { inversion i0; subst.
       { constructor. }
       assumption. }

  clear -SORT.
  inversion SORT; subst.
  inversion SST; subst.
  2: lia.
  inversion SST0; subst.
  { assumption. }
  { assumption. }
  lia.
Defined.

Theorem sort l :
  { l' | Permutation l l' & is_sorted l' }.
Proof.
  induction l.
  { exists [].
    { apply perm_nil. }
    apply sorted_nil. }
  inversion IHl.
  rename x into l'.
  rename H into PERM.
  rename H0 into SORT.
  apply (insert_sorted a l') in SORT.
  destruct SORT as [l'' AA BB].
  exists l''.
  2: { apply BB. }
  apply is_inserted_perm in AA.
  eapply perm_trans.
  2: apply AA.
  apply perm_skip.
  apply PERM.
Defined.

Print sort.

Extraction Language OCaml.


Set Warnings "-notation-overridden,-parsing".

Fixpoint leb (n m : nat) : bool :=
  match n with
  | 0 => true
  | S n' =>
    match m with
    | 0 => false
    | S m' => leb n' m'
    end
  end.

Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Inductive list' {X:Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').

Definition mynil : list nat := nil.

Check @nil.
Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Definition list123''' := [1; 2; 3].

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X l.
  induction l as [|n l' IHl'].
  - reflexivity.
  - simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n.
  induction l as [|h t IHt].
  - reflexivity.
  - simpl. rewrite-> IHt. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1 as [|h1 t1 IHt1'].
  - reflexivity.
  - simpl. rewrite -> IHt1'. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l1 as [|h1 t1 IHt1'].
  - simpl. rewrite -> app_nil_r.  reflexivity.
  - simpl. rewrite -> IHt1'.
    rewrite <- app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l.
  induction l as [|h t IHt].
  - reflexivity.
  - simpl. rewrite -> rev_app_distr.
    rewrite -> IHt. reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

 Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t =>
    match (split t) with
    | (f, s) => (x :: f, y :: s)
    end
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

Module OptionPlayground.

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.
Arguments Some {X} _.
Arguments None {X}.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if n =? O then Some a else nth_error l' (pred n)
  end.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | h :: t => Some h
  end.

Check @hd_error.
Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

End OptionPlayground.

Definition doit3times {X:Type} (f:X -> X) (n:X) : X :=
  f (f (f n)).

Fixpoint filter {X:Type} (test: X -> bool) (l:list X)
                : (list X) :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter test t)
                        else filter test t
  end.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.
Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Definition oddb (n:nat) : bool := negb (evenb n).

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity. Qed.

Example test_filter2':
    filter (fun l => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => if evenb n then 7 <=? n else false) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
  (filter test l, filter (fun x => negb (test x)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y: Type} (f:X -> Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Theorem map_app : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof.
  intros X Y f l1 l2.
  induction l1 as [|h t IHl1].
  - reflexivity.
  - simpl. rewrite -> IHl1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l as [|h t IHt].
  - reflexivity.
  - simpl. rewrite <- IHt.
    rewrite -> map_app.
    reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y) :=
  match l with
  | nil => []
  | h :: t => (f h) ++ (flat_map f t)
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint fold {X Y: Type} (f: X -> Y -> Y) (l: list X) (b: Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Definition constfun {X: Type} (x: X) : nat -> X :=
  fun (k:nat) => x.
Definition ftrue := constfun true.

Definition plus3 := plus 3.
Check plus3.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l.
  induction l as [|h t IHl].
  - reflexivity.
  - simpl. rewrite <- IHl. reflexivity.
Qed.

Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
  fold (fun x l => (f x) :: l) l [].

Example test_fold_map1:
  fold_map (fun n => S n) [1;5;4]
  = [2; 6; 5].
Proof. reflexivity. Qed.

Theorem fold_map_correct : forall (X Y : Type)
  (f: X -> Y) (l : list X),
  fold_map f l = map f l.
Proof.
  intros X Y f l.
  induction l as [|h t IHl].
  - reflexivity.
  - simpl. rewrite <- IHl. reflexivity.
Qed.

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
  match p with
  | (x, y) => f x y
  end.

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros.
  reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros.
  destruct p as (x, y).
  simpl. reflexivity.
Qed.

Module Church.
Definition cnat := forall X : Type,
  (X -> X) -> X -> X.

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : cnat := @doit3times.

Definition succ (n : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) =>
    f (n X f x).

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.
Example succ_2 : succ one = two.
Proof. reflexivity. Qed.
Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) =>
    n X f (m X f x).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.
Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.
Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

Definition mult (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) =>
    m X (n X f) x.
Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.
Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.
Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

Definition exp (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) =>
    (n ((X -> X)-> X -> X)
      (fun y =>
        fun (f : X -> X) (x : X) =>
          m X (y f) x) (one X)) f x.

(*
Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.
Example exp_2 : exp three zero = one.
Proof. reflexivity. Qed.
Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.
*)

End Church.

Inductive id : Type :=
  | Id (n : nat).

(** Internally, an [id] is just a number.  Introducing a separate type
    by wrapping each nat with the tag [Id] makes definitions more
    readable and gives us the flexibility to change representations
    later if we wish. *)

(** We'll also need an equality test for [id]s: *)

Definition eqb_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => n1 =? n2
  end.


Set Implicit Arguments.

(* Import the core FCF definitions and theory. *)
Require Import otp.FCF.

(* Matches our OTP definition in OTP_verif.v *)
Definition OTP_encrypt_FCF {SP : nat} (key msg : Bvector SP) : Bvector SP :=
  BVxor SP key msg.

(* Indistinguishability security property *)
Definition rand_indist {SP : nat} (x : Comp (Bvector SP)) :=
  forall (n : Bvector SP),
    evalDist x n == evalDist ({0,1}^SP) n.

Lemma allow_assumption :
  forall SP input (f : Bvector SP -> Bvector SP) n,
    rand_indist (ret input) ->
    evalDist (ret (f input)) n == evalDist (x <-$ {0,1}^SP; ret (f x)) n.
Proof.
  intros.
  unfold rand_indist in *.
  rewrite <- evalDist_left_ident_eq with (c2 := fun x => ret f x).
  eapply evalDist_seq_eq. intros. apply H.
  intros. reflexivity.
Qed.

Lemma OTP_encrypt_indist :
  forall SP (msg key : Bvector SP),
    rand_indist (ret key) ->
    rand_indist (ret (OTP_encrypt_FCF key msg)).
Proof.
  intros.
  unfold rand_indist.
  intros.
  unfold OTP_encrypt_FCF.
  unfold rand_indist in *.
  symmetry.
  rewrite <- evalDist_right_ident.
  symmetry.
  erewrite allow_assumption with (f := fun x => BVxor SP x msg).

  eapply evalDist_iso.
  - intuition.
  - instantiate (1:= BVxor SP msg).
    instantiate (1:= BVxor SP msg).
    intros.
    rewrite <- BVxor_assoc.
    rewrite BVxor_same_id.
    rewrite BVxor_id_l.
    reflexivity.
  - intros.
    rewrite <- BVxor_assoc.
    rewrite BVxor_same_id.
    rewrite BVxor_id_l.
    reflexivity.
  - intros.
    simpl.
    apply in_getAllBvectors.
  - intros.
    simpl. reflexivity.
  - intros.
    rewrite BVxor_comm.
    rewrite <- BVxor_assoc.
    rewrite BVxor_same_id.
    rewrite BVxor_id_l.
    reflexivity.
  - exact H.
Qed.

Definition OTP {SP : nat} (msg : Bvector SP) : Comp (Bvector SP) :=
  key <-$ {0,1}^SP;
  ret (OTP_encrypt_FCF key msg).

(* Assuming the key is drawn uniformly at random (assumption added by OTP),
 OTP_encrypt is indistinguishable from random bits *)
Theorem OTP_indist : forall SP (msg : Bvector SP),
    rand_indist (OTP msg).
Proof.
  intros.
  unfold rand_indist.
  intros.
  unfold OTP.
  unfold OTP_encrypt_FCF.

  symmetry.
  rewrite <- evalDist_right_ident.
  eapply evalDist_iso.
  - intuition.
  - instantiate (1:= BVxor SP msg).
    instantiate (1:= BVxor SP msg).
    intros.
    rewrite <- BVxor_assoc.
    rewrite BVxor_same_id.
    rewrite BVxor_id_l.
    reflexivity.
  - intros.
    rewrite <- BVxor_assoc.
    rewrite BVxor_same_id.
    rewrite BVxor_id_l.
    reflexivity.
  - intros.
    simpl.
    apply in_getAllBvectors.
  - intros.
    simpl. reflexivity.
  - intros.
    rewrite BVxor_comm.
    reflexivity.
Qed.


(*
   Anarchy Proof

   Peirce
   http://as305.dyndns.org/aps/problem/view/3

   Converse Peirce
   http://as305.dyndns.org/aps/problem/view/4

   call/cc
   http://as305.dyndns.org/aps/problem/view/5
*)

Require Import Classical.                   (* 古典論理パッケージ *)

(****************)
(* Prove 'Peirce's law'. *)
(* 「パースの論理式」を証明する。*)
(* 古典論理では証明できるが、直観論理では証明できない。*)
(* 「パースの論理式」を排中律で証明する。*)
(****************)

Theorem Peirce : forall (P Q: Prop), ((P -> Q) -> P) -> P.
Proof.
  intros p q H.
  Check classic.                            (* 排中律の公理 *)
  (* Logic/Classical_Prop.v で定義されている。*)
  elim (classic p).
  intros P.
  assumption.

  intros H0.
  apply H0 in H.
  elim H.
  intros H1.
  (* H0 : ~P と H1 : P から Falseを求める *)
  apply H0 in H1.
  case H1.                                  (* 前提がFalseで証明は終了。 *)
Qed.

(* 「パースの論理式」を二重否定除去で証明する。*)

Theorem Peirce' : forall (P Q: Prop), ((P -> Q) -> P) -> P.
Proof.
  intros p q H.
  Check NNPP.                               (* 二重否定の除去 *)
  apply NNPP.
  intros nHp.
  apply nHp in H.
  apply H.
  intros Hp.
  case (nHp Hp).
Qed.

(* Verifier *)
Definition check_Peirce: forall (P Q: Prop), ((P -> Q) -> P) -> P := Peirce.

(* Classical パッケージを使用しない。*)

(****************)
(* パースの論理式を使って、排中律を証明する。*)
(****************)

(* 古典論理で(Classicalパッケージを使う)、パースの論理式の証明は、
   coq_classical.v を参照せよ。*)
(* Axiom Peirce : forall (P Q: Prop), ((P -> Q) -> P) -> P. *)

Theorem Excluded_Middle : forall (P: Prop), P \/ ~P.
Proof.
  intros p.
  Check (Peirce p False).
  apply (Peirce _ False).                   (* apply Peirce with False. *)
  intros H.
  right.
  intros Hp.                                (* ~ p に対して、さらにintrosする！ *)
  apply H.
  left.
  apply Hp.
Qed.

(* Verifier *)
Definition check_Excluded_Middle : forall (P: Prop), P \/ ~P := Excluded_Middle.

(****************)
(* Prove 'call/cc implies excluded middle'. *)
(* call/cc を使って、排中律 (law of the excluded middle) を証明する。*)
(****************)

Axiom callcc: forall (P: Prop), ((P -> False) -> P) -> P.

Theorem Excluded_Middle' : forall (P: Prop), P \/ ~P.
Proof.
  intros p.
  apply callcc.                             (* パースの論理式の特別な形。 *)
  (* パースの論理式による証明と同じだが、
     auto で済ますこともできる。*)
  auto.
Qed.

(* Verifier *)
Definition check_Excluded_Middle' : forall (P: Prop), P \/ ~P := Excluded_Middle'.

(* END *)


(****** Pointwise consistency for the central difference approximation of the 2nd derivative ********)

Require Import Reals Psatz.
Require Import Coquelicot.Hierarchy.
Require Import Coquelicot.Rbar.
Require Import Coquelicot.Coquelicot.
Require Import Omega Init.Nat Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Interval.Interval_missing.
Require Import Interval.coqapprox.taylor_thm.

(*Defining a real valued function u(x)*)
Parameter u: R->R.

(*Defining an operator for derivatives. The operator D takes a natural number for the order of derivative and a real , x (point at which the derivative
is to be computed. The return type is real. *)
Variable D:nat->R->R.

(* Checking for continuity and differentiability of u at x*)

Definition continuity u := forall x:R, continuity_pt u x.
Definition derivable u := forall x:R, derivable_pt u x.

(* [a b] is the interval in which the Taylor Lagrange is studied*)
Variables l r :R.

(* n is the order of derivative when the differentiability property is to verified and n is the order of continuity of u when its continuity property
is considered *)

Variable n:nat.

(* Cab x means x lies in the closed interval [a b] *)
Notation Cab x:= (l<=x<=r).
(* Oab x means x lies in the open interval (a b) *)
Notation Oab x:=(l<x<r).

(* Define a hypothesis that \frac {d^k (u}{d x^k} at x is \frac{d^(k+1) (f)}{d x^(k+1)} in (a b)*)
Hypothesis derivable_pt_lim_Dp :
  forall k x n, (k <= n)%nat -> Oab x ->
  derivable_pt_lim (D k) x (D (S k) x).

(*Define a hypothesis that f is C^(k) continuous in [a b]*)
Hypothesis continuity_pt_Dp :
  forall k x n, (k <= n)%nat -> Cab x ->
  continuity_pt (D k) x.

(* Tcoeff is defined as \frac {d^(n) (u)}{d x^n} *)
Notation Tcoeff n x :=(D n x/(INR (fact n)) )(only parsing).

(* Tterm is defined as Tcoeff * (x-x0)^n *)
Notation Tterm n x0 x := (Tcoeff n x0 * ((x-x0)^n))(only parsing).

(* Tsum is the truncated Taylor polynomial of degree n*)
Notation Tsum n x0 x := (sum_f_R0 (fun i => Tterm i x0  x) n)(only parsing).

(* instantiate Taylor_Lagrange for u(x+dx) with n=2*)
(* Lemma statement: for x lies in (a b) , dx>0, (x+dx) in (a b), there exists a real c, such that u(x+dx)-u(x)-(du/dx)*(dx)- (1/2!)*(d^2 u / dx^2)*(dx^2)= (1/3!)*(d^3 u(c)/dx^3)*(dx^3)
                    where c in (x x+dx) *)

(* D 0 (x+dx) means u(x+dx)
  S 2 means (2+1) or 3 , S is a successor operator in Peano arithemtic for natural numbers *)

Lemma Inst_nat_upper (x dx:R):
Oab x-> dx>0-> Oab (x+dx) -> exists c:R, D 0 (x+dx) - Tsum 3 x (x+dx) = Tcoeff (S 3) c * (x+dx-x)^(S 3) /\ (x <> x+dx -> x < c < x+dx \/ x+dx < c < x).
Proof.
intros.
(* Cor_Taylor_Lagrange is the Taylor Lagrange remainder theorem:

  Cab x0 -> Cab x ->
  exists c,
  D 0 x - Tsum n x0 x =
  Tcoeff (S n) c * (x - x0)^(S n)
  /\ (x0 <> x -> x0 < c < x \/ x < c < x0).

Theorem statement:
for x0 in [a b], x in [a b], there exists c in R, such that u(x)- u(x0)-(du(x0)/dx)*(dx)- .... - (1/n!)*(d^n u(x0)/ dx^n)*(dx^n)= (1/(n+1)!)*(d^(n+1) u(c)/dx^(n+1)
where c in (x0 x) or (x x0).

Here x0 is the point of expansion.

The theorem takes as argument, x (x+dx) and the order of expansion which in this case is 2.
*)
apply (Cor_Taylor_Lagrange x (x+dx) 3).
intros.
apply (derivable_pt_lim_Dp k x0 3). apply H2.
nra. nra. nra.
Qed.

(* instantiate Taylor_Lagrange for u(x-dx) with n=3*)
Lemma Inst_nat_lower(x dx: R):
Oab x->dx>0-> Oab (x-dx) -> exists c:R, D 0 (x-dx) - Tsum 3 x (x-dx) = Tcoeff (S 3) c * (x-dx-x)^(S 3)/\ (x <> x-dx -> x < c < x-dx \/ x-dx < c < x).
Proof.
intros.
apply (Cor_Taylor_Lagrange (x-dx) x 3).
intros.
apply (derivable_pt_lim_Dp k x0 3). apply H2.
nra. nra. nra.
Qed.

(* Proof of Taylor Lagrange for u(x+dx)*)
(* Lemma statement:

for x in (a b),
there exists eta >0 in R, M>0 in R , such that forall dx in R, dx>0,
(x+dx) in (a b) and dx < eta,

| u(x+dx) - u(x)- (du/dx)*(dx)- (1/2!)*(d^2 u/ dx^2)*(dx^2)- (1/3!) * (d^3 u/dx^3)* (dx ^3)| <= M* (dx^4).
i.e. The truncation error is big O (dx^4)

*)
Lemma taylor_uupper (x:R):
Oab x-> exists eta: R, eta>0 /\ exists M :R, M>0  /\forall dx:R, dx>0 ->Oab (x+dx)->  (dx<eta ->  Rabs(D 0 (x+dx) - Tsum 3 x (x+dx)) <=M*(dx^4)).
Proof.
intros.

(* here we provide an evidence for eta, i.e. existential quantification for eta.

Here i have chosen eta to be (b-x) . Reason for chosing so will be explained later *)
exists (r-x).

(* whenever there is an "and" operator in the goal, the "split" tactic splits the goal into two subgoals *)
split.
- nra. (* since x in (a b), b-x >0, nra does this mathematical reasoning to prove the subgoal *)
-
  (* We have to provide an evidence for M to continue the proof. We chose M to be max (d^4 u /dx) in the interval [x b] since
    we are studying for u(x+dx) in (x b).
    Thus, we use a lemma in COQ, which establishes the existence of a maximum in a compact interval for a continuous function.
    Lemma statement: there exists a point F in R, F in [p1 p2] such that for all y in R , y in [p1 p2], f y <= f F.
                     where f is a real valued function. The maximum is f F.
    Thus, we use this lemma for d^4 u/dx^4 to get an evidence for M.
  *)
  cut( exists F:R , (forall y:R, x<=y<=x+(r-x) ->(D 4 y) <= (D 4 F)) /\ x<=F<=x+(r-x)).
  { intros.  destruct H0 as [F H0]. (* In a hypothesis, destruct breaks it into two sub hypothesis. Since this is an
                                        existential hypotheis, an evidence F is provided. This introduces F in the environment
                                        which will later be used. *)
    (* here, we used a lemma in COQ, which establishes the existence of a minimum in a compact interval for a continuous function.
      Lemma statement: there exists a point G in R, G in [p1 p2] such that for all y in R, y in [p1 p2], f G <= f y,
                       where f is a real valued function. The minimum is f G.
      Thus, we have introduced two lemmas so far to establish the existence of a maximum and a minimum in the interval [x b].
      These bounds will later be used to prove that the lagrange remainder d^4 u(c)/dx^4 <= M.
     *)
    cut( exists G:R , (forall y:R, x<=y<=x+(r-x) ->(D 4 G) <= (D 4 y)) /\ x<=G<=x+(r-x)).
    - intros. destruct H1 as [G H1]. (* G (the point at which d^4 u/dx^4 attains a minimum value) is introduced into the environment*)

      (* We instantiate M with maximum of |d^4 u(G)/dx^4| and |d^4 u(F)/dx^4| *)
      exists (Rmax 1 (Rmax (Rabs( D 4 G/ INR (fact 4))) (Rabs(D 4 F/ INR (fact 4))))).
      split.
       + (* Rlt_le_trans: fforall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3.
            This lemma is used to establish that M instantiated as before is greater than 0 *)

        apply (Rlt_le_trans 0 1 (Rmax 1 (Rmax (Rabs( D 4 G/ INR (fact 4))) (Rabs(D 4 F/ INR (fact 4)))))).
          * lra. (*apply Rlt_0_1.*)
          * (*Rmax_l:  forall x y:R, x <= Rmax x y.*)
            apply Rmax_l.
       + intros. (*introduces dx and its properties into the environment*)
      cut(Oab x-> dx>0-> Oab (x+dx) -> exists c:R, D 0 (x+dx) - Tsum 3 x (x+dx) = Tcoeff (S 3) c * (x+dx-x)^(S 3)/\ (x <> x+dx -> x < c < x+dx \/ x+dx < c < x)).
      (* We introduce the lemma defined earlier, Inst_nat_upper into the proof context. The idea is to get information on "c" which
         to be used in taylor lagrange for u(x+dx) and instantiate the order of truncation as well *)
      { intros.
        specialize (H5 H H2 H3).
        destruct H5 as [c H5]. (* destruct introduces c in the environment *)
        destruct H5 as [H5 H6]. (* destruct breaks the hypothesis H5 into two separate hypothesis which were connected by the "and" operator*)
        destruct H0 as [H0 H7]. specialize (H0 c). (* instantiate y with c *)
        assert (H8: x<=c<=x+(r-x)). {  nra. }  (* assert: This tactic introduces new hypothesis in the context.
        Purpose of doing so is to break the hypotheis H0, which is done using "specialize" tactic in the next step.
        Since this hypotheis is a reasoning on interval, "nra" is used to prove it *)
        specialize (H0 H8).
        destruct H1 as [H1 H9]. specialize (H1 c). specialize (H1 H8). (* Similarly, we break the hypothesis H1*)
        (* Now we have the information that (d^4 u(c)/dx^4) is bounded below by (d^4 u(G)/dx^4) and bounded above by
           (d^4 u(F)/dx^4). This information will be used later to prove that |d^4 u(c)/dx^4| <= M *)

        (* Now we are in a position to prove the lemma for taylor_lagrange of u(x+dx) *)
        (* Here, we write the truncated taylor series in terms of lagrange remainder.
          This will lead us to prove that |(d^4 u(c)/dx^4)* (dx^4)| <= M * (dx^4) i.e. the lagrange remainder is big O (dx^4) *)
        cut ( D 0 (x+dx) - Tsum 3 x (x+dx) =  Tcoeff (S 3) c * ((x+dx) -x)^(S 3)).
        * intros. rewrite H10.
          cut( (x+dx)-x = dx). intros. rewrite H11.
          cut (Rabs (D 4 c / INR (fact 4) * dx ^ 4) = Rabs (D 4 c / INR (fact 4)) * dx ^ 4).
          - intros. rewrite H12.
            (*Lemma Rmult_le_compat_r :forall r r1 r2, 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r.
              Purpose of introducing this lemma is to get rid of dx^4 on both sides. This is equivalent to dividing dx^4 on both sides
              since dx >0 (hypothesis H2)*)
            apply Rmult_le_compat_r. (* Applying this tactic introduces the premise that dx^3>=0 *)
            apply Rlt_le. (*Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2.
            Purpose of doing this is to reduce the goal to dx^3>0 which can be proved by applying the hypotheis H2: dx>0*)
             apply pow_lt. apply H2.

          -  (* Start of proof that |d^u(c)/dx^3| <= M *)
             apply Rle_trans with  (Rmax (Rabs (D 4 G / INR (fact 4))) (Rabs (D 4 F / INR (fact 4)))).
             apply RmaxAbs.
             (*Lemma RmaxAbs :
                forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).

              Purpose of using this lemma is to reduce the goal into following 2 subgoals:
              D 4 G / INR (fact 4) <= D 4 c / INR (fact 4)
              ______________________________________(2/6)
              D 4 c / INR (fact 4) <= D 4 F / INR (fact 4)

              This reduction will further help in application of the hypothesis H0 and H1 (these hypothesis gives information on the
              bounds for the lagrange remainder *)

             cut(D 4 G / INR (fact 4)= (D 4 G)*(/ INR (fact 4))).
             (* Here, we follow the process for reduction of
                D 4 G / INR (fact 4) <= D 4 c / INR (fact 4) to D 4 G <= D 4 c.
                In the following steps,we perform a relatively long process for a basic operation of eliminating 1/4! on boh sides *)
             { intros.  rewrite H13.
               cut(D 4 c / INR (fact 4)= (D 4 c)*(/ INR (fact 4))).
               + intros. rewrite H14. apply Rmult_le_compat_r. apply Rlt_le.
                 apply Rinv_0_lt_compat. (*Lemma Rinv_0_lt_compat : forall r, 0 < r -> 0 < / r. *)
                 apply lt_0_INR. (*Lemma lt_0_INR : forall n:nat, (0 < n)%nat -> 0 < INR n.*)
                 simpl. (*simpl: This tactic performs mathematical simplification, i.e. it simplifies 4! to 24. *)
                 omega. (*The tactic omega, due to Pierre Crégut, is an automatic decision procedure for Presburger arithmetic.
                 It solves quantifier-free formulas built with ~, /, /`, `-> on top of equalities, inequalities and disequalities
                 on both the type nat of natural numbers and Z of binary integers. *)
                 apply H1.
               + trivial.
              }
              { trivial. }
             (* Similarly, we carry the same process for reducing  D 4 c / INR (fact 4) <= D 4 F / INR (fact 4) to D 4 c <= D 4 F and proving it*)
             cut(D 4 c / INR (fact 4) = (D 4 c)*(/ INR(fact 4))).
             { intros. rewrite H13.
               cut(D 4 F / INR(fact 4)= (D 4 F)*(/INR (fact 4))).
               + intros. rewrite H14. apply Rmult_le_compat_r. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_0_INR.  simpl. omega. apply H0.
               + trivial.
            }
            { trivial. }
            apply Rmax_r. (*Lemma Rmax_r : forall x y:R, y <= Rmax x y.*)

        * rewrite Rabs_mult. (*Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.*)
          cut (dx^4 = (Rabs (dx^4))).
          { intros. rewrite <- H12. reflexivity. (* reflexivity is used to prove goals of type A=B *) }
          { cut (Rabs(dx ^ 4) = dx ^ 4).
            - intros. rewrite H12. reflexivity.
            - apply Rabs_right. (*Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r. This is applicable since dx>0*)
              apply Rgt_ge. (*Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2.
              Purpose is to reduce the goal, dx^4>=0 to dx^4>0 so that we can apply H2.*)
              apply pow_lt. apply H2.
         }
      + lra. apply H5.
    }
    { apply (Inst_nat_upper x dx). } (* Here we apply the lemma Inst_nat_upper since the goal statement matche with the lemma statement*)
  - (* Here we apply the lemma on the lower bound for the 3rd derivative in the interval [x b], and prove the non-dependent premises*)
    apply (continuity_ab_min (D 4) x (x+(r-x))). nra. intros. apply (continuity_pt_Dp 4 c 4). omega. nra.
  }
  {
   (* Here we apply the lemma on the upper bound for the 4th derivative in the interval [x b], and prove the non-dependent premises*)
  apply (continuity_ab_maj (D 4) x (x+(r-x))). nra. intros. apply (continuity_pt_Dp 4 c 4). omega. nra.
  }
Qed. (* The lemma on the taylor lagrange for u(x+dx) is proved and defined*)

(*Proof of Taylor Lagrange for u(x-dx)*)
Lemma taylor_ulower (x:R):
Oab x -> exists delta: R, delta>0 /\ exists K :R, K>0 /\ forall dx:R, dx>0 ->Oab (x-dx)-> (dx<delta -> Rabs(D 0 (x-dx) - Tsum 3 x (x-dx)) <=K*(dx^4)).
Proof.
(* instantiate eta with (x-a)*)
exists (x-l).
split.
- nra.
- (* Introduce lemma to establish maximum of (d^4 u(y)/dx^4) in the interval [a x].*)
  cut( exists F:R , (forall y:R, x-(x-l)<=y<=x ->(D 4 y) <= (D 4 F)) /\ x-(x-l)<=F<=x).
  { intros. destruct H0 as [F H0]. (* destruct introduces F in the environment *)
    (* Introduce lemma to establish minimum of (d^4 u(y)/dx^4) in the inteval [a x]*)
    cut( exists G:R , (forall y:R, x-(x-l)<=y<=x ->(D 4 G) <= (D 4 y)) /\ x-(x-l)<=G<=x).
    - intros. destruct H1 as [G H1]. (*destruct introduces G in the environment *)

      (*instantiate K*)
      exists (Rmax 1 (Rmax (Rabs( D 4 G/ INR (fact 4))) (Rabs(D 4 F/ INR (fact 4))))).
      split.
      + apply (Rlt_le_trans 0 1 (Rmax 1 (Rmax (Rabs( D 4 G/ INR (fact 4))) (Rabs(D 4 F/ INR (fact 4)))))).
          * lra. (*apply Rlt_0_1.*)
          *  apply Rmax_l.
      + intros.
        (* Introduce the lemma Inst_nat_lower to extract information about "c" and also to instantiate the order of approximation
        in taylor lagrange for u(x-dx) to 2*)
        cut(Oab x-> dx>0-> Oab (x-dx) -> exists c:R, D 0 (x-dx) - Tsum 3 x (x-dx) = Tcoeff (S 3) c * (x-dx-x)^(S 3)/\ (x <> x-dx -> x < c < x-dx \/ x-dx < c < x)).
        { intros. specialize (H5 H H2 H3). (*break the hypothesis by using the information about dx already present in the environment
                                            in form of hypothesis *)
          destruct H5 as [c H5]. (* introduce "c" in the environment*)
          destruct H5 as [H5 H6]. (* Break the hypothesis into separate hypothesis connected by the "and" operator *)
          destruct H0 as [H0 H7]. specialize (H0 c).
          assert (H8: x-(x-l)<=c<=x). {  nra. } (* Introduce a new hypothesis establishing that c lies in [a x]*)
          specialize (H0 H8). (* reduce hypothesis H0 into inequality D 4 c <= D 4 F *)
          destruct H1 as [H1 H9]. specialize (H1 c). specialize (H1 H8). (* reduce hypothesis H1 into inequality D 4 G<= D 4 c*)
        (* Now we have the information that (d^4 u(c)/dx^4) is bounded below by (d^4 u(G)/dx^4) and bounded above by
           (d^4 u(F)/dx^4). This information will be used later to prove that |d^4 u(c)/dx^4| <= M *)

        (* Now we are in a position to prove the lemma for taylor_lagrange of u(x-dx) *)
        (* Here, we write the truncated taylor series in terms of lagrange remainder.
          This will lead us to prove that |(d^4 u(c)/dx^4)* (dx^3)| <= K * (dx^4) i.e. the lagrange remainder is big O (dx^4) *)
          cut ( D 0 (x-dx) - Tsum 3 x (x-dx) =  Tcoeff (S 3) c * ((x-dx) - x)^(S 3)).
          { intros. rewrite H10.
            cut((x-dx)-x = -dx).
            + intros. rewrite H11.
              cut (Rabs (D 4 c / INR (fact 4) * (- dx) ^ 4)= (Rabs ( D 4 c / INR (fact 4))) * dx ^ 4).
              - intros. rewrite  H12.
                apply  Rmult_le_compat_r.
                apply Rlt_le. apply pow_lt. apply H2.

             (* Start of proof that |d^4u(c)/dx^4| <= K *)
                   apply Rle_trans with  (Rmax (Rabs (D 4 G / INR (fact 4))) (Rabs (D 4 F / INR (fact 4)))).
                   apply RmaxAbs.
                  (*Lemma RmaxAbs :
                    forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).

                  Purpose of using this lemma is to reduce the goal into following 2 subgoals:
                  D 4 G / INR (fact 4) <= D 4 c / INR (fact 4)
                  ______________________________________(2/6)
                  D 4 c / INR (fact 4) <= D 4 F / INR (fact 4)

                  This reduction will further help in application of the hypothesis H0 and H1 (these hypothesis gives information
                  on the bounds for the lagrange remainder *)

                   cut(D 4 G / INR (fact 4)= (D 4 G)*(/ INR (fact 4))).
                (* Here, we follow the process for reduction of
                D 4 G / INR (fact 4) <= D 4 c / INR (fact 4) to D 4 G <= D 4 c.
                In the following steps,we perform a relatively long process for a basic operation of eliminating 1/4! on boh sides *)
                    { intros.  rewrite H13.
                     cut(D 4 c / INR (fact 4)= (D 4 c)*(/ INR (fact 4))).
                     + intros. rewrite H14. apply Rmult_le_compat_r. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_0_INR. simpl. omega. apply H1.
                     + trivial.
                    }
                    { trivial. }
                    (* Similarly, we carry the same process for reducing  D 4 c / INR (fact 4) <= D 4 F / INR (fact 4) to D 4 c <= D 4 F and proving it*)
                   cut(D 4 c / INR (fact 4) = (D 4 c)*(/ INR(fact 4))).
                   { intros. rewrite H13.
                     cut(D 4 F / INR(fact 4)= (D 4 F)*(/INR (fact 4))).
                     + intros. rewrite H14. apply Rmult_le_compat_r. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_0_INR.  simpl. omega. apply H0.
                     + trivial.
                   }
                   { trivial. }
                  apply Rmax_r.
                 - assert ( (-dx)^4= dx ^4).
                   assert ( -dx = -1 * dx). { nra. }
                   rewrite H12. assert (dx ^4= (-1)^4 * (dx^4)). { nra. } rewrite H13. apply Rpow_mult_distr.
                   rewrite H12.  assert (Rabs (D 4 c / INR (fact 4) * dx ^ 4)= Rabs (D 4 c / INR (fact 4))* Rabs(dx^4)). { apply Rabs_mult. }
                   rewrite H13. apply Rmult_eq_compat_l. apply Rabs_right. nra.
                + nra.
              }
            apply H5.
         }
         { apply (Inst_nat_lower x dx). } (* Here we apply the lemma Inst_nat_lower since the goal statement matches with the lemma statement *)
      - (* Here we apply the lemma on the lower bound for the 4th derivative in the interval [a x], and prove the non-dependent premises*)
        apply (continuity_ab_min (D 4) (x-(x-l)) x). nra. intros. apply (continuity_pt_Dp 4 c 4). omega. nra.
    }
    { (* Here we apply the lemma on the upper bound for the 4th derivative in the interval [a x], and prove the non-dependent premises*)
      apply (continuity_ab_maj (D 4) (x-(x-l)) x). nra. intros. apply (continuity_pt_Dp 4 c 4). omega. nra. }

Qed. (* Lemma on taylor_lagrange for u(x-dx) is proved and defined*)

(*Proof for 2nd order FD scheme, | (u(x+dx) -2* u(x) +u(x-dx))/(dx^2) - (d^2u/dx^2)| <= G*(dx^2)
  The strategy here is to rewrite the scheme into taylor lagrange for u(x+dx) and u(x-dx) and use the already
  proven lemmas to complete the proof *)

(* Theorem statement:
    for x in (a b), there exists gamma>0 in R and G >0 in R, such that forall dx >0 in R and dx<gamma,
   | (u(x+dx) -2* u(x) +u(x-dx))/(dx^2) - (d^2u/dx^2)| <= G*(dx^2), i.e. the scheme is 2nd order accurate *)

Theorem taylor_FD (x:R):
Oab x -> exists gamma:R, gamma >0 /\ exists G:R, G>0/\ forall dx:R, dx>0 -> Oab (x+dx) -> Oab (x-dx)->(dx< gamma -> Rabs( (D 0 (x+dx) - 2* (D 0 x) +D 0 (x-dx)) * / (dx * dx) - D 2 x)<= G*(dx^2)).
Proof.
intros.

(* We would like to instantiate gamma with min (eta, delta) and G with (M+K), but so far,we have no information
on M and K in the environment, thus we introduce the lemmas  on taylor lagrange for u(x+dx) and u(x-dx) and
extract the informations on eta, delta, M and K *)

(* Lemma on taylor lagrange for u(x+dx)*)
cut(Oab x->  exists eta: R, eta>0 /\ exists M :R, M>0 /\forall dx:R, dx>0 ->Oab (x+dx)->(dx<eta -> Rabs(D 0 (x+dx) - Tsum 3 x (x+dx)) <=M*(dx^4))).
- intros. destruct H0 as [eta H1]. (*destruct introduces eta in the environment *)
  apply H. (* proves x in (a b)*)
  destruct H1 as [H2 H3]. (* Breaks the hypothesis H3 into separate hypothesis connected by the "and" operator*)
  (* Lemma on taylor lagrange for u(x-dx)*)
  cut(Oab x ->  exists delta: R, delta>0 /\exists K :R, K>0 /\ forall dx:R, dx>0 ->Oab (x-dx)-> (dx<delta -> Rabs(D 0 (x-dx) - Tsum 3 x (x-dx)) <=K*(dx^4))).
  + intros. destruct H0 as [delta H4]. (* destruct introduces delta in the environment *)
    apply H. destruct H4 as [H5 H6].
    exists (Rmin eta delta).
    split.
    { (* Proof for min(eta, delta) >0 *)
     apply Rmin_pos. (*Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
     Applying this lemma, produces two subgoals, eta>0, delta>0, since we already have these information in the
     environment in form of hypothesis H2 and H5 , we just apply them in the following steps. *)
     apply H2. apply H5. }

     (* we now have to instantiate G , hence we revisit the lemmas on taylor lagrange for u(x+dx) and u(x-dx)
    which are already present in the environment as hypothesis H3 and H4 respectively *)
    { destruct H3 as [M H4]. (* introduces M in the environment *)
      destruct H4 as [H7 H8]. destruct H6 as [K H6]. (* destruct introduces K in the environment*)
      destruct H6 as [H9 H10].
      exists (M+K). (* Since we now have information about M and K , we can instantiate G with (M+K) *)
      split.
      * nra. (* in the environment, we already have M>0, K>0 , hence nra uses these facts to prove (M+K)>0 *)
      * intros. (* introduces information on "dx" in the environment*)
        (* We introduce additional hypothesis dx<eta and dx< delta, these will be used to break the lemmas on
          u(x+dx) and u(x-dx) further . We will prove these hypothesis later *)
       cut(dx<eta).
       + cut(dx< delta).
         - intros. specialize(H8 dx H0 H1 H11). (* Use the information on dx to further break the hypothesis
          and get the desired form of taylor lagrange for (u(x+dx)) after getting rid of the quantifiers *)
          specialize( H10 dx H0 H3 H6).
          (* Use the information on dx to further break the hypothesis
          and get the desired form of taylor lagrange for (u(x-dx)) after getting rid of the quantifiers *)

          (* Next , we will decompose the scheme into the lemmas on taylor lagrange for u(x+dx) and u(x-dx) and apply those lemmas separately
            to complete the proof *)
          apply Rmult_le_reg_r with (dx^2).
          * nra.
          * assert((M + K) * dx ^ 2 * dx ^ 2= (M+K) * (dx ^4)). { nra. }
            rewrite H12.
            cut( Rabs(dx^2)= dx^2).
            { intros. rewrite <- H13.
              assert (Rabs (((D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) * / (dx * dx) - D 2 x) * (dx ^2))=
                         Rabs ((D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) * / (dx * dx) - D 2 x) * Rabs (dx ^ 2)).
              { apply Rabs_mult. }
              rewrite <- H14.
              assert(((D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) * / (dx * dx) - D 2 x) * dx ^ 2=
                      ((D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) - (D 2 x) * (dx^2))).
              { assert ( dx*dx = dx^2). { nra. } rewrite H15.
                assert (((D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) * / dx ^ 2 - D 2 x) * dx ^ 2=
                        ((D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) * / dx ^ 2) * (dx ^2) -D 2 x * dx ^ 2). { nra. }
                rewrite H16.
                assert ((D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) * / dx ^ 2 * dx ^ 2= (D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx))).
                { assert(((D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) * / dx ^ 2 )* dx ^ 2 = (D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx)) * (dx^2) */ (dx^2)). { nra. }
                  rewrite H17. apply Rinv_r_simpl_l. nra.
                }
                rewrite H17. reflexivity.
              }
              rewrite H15.
              assert (( D 2 x) * (dx^2)= ((D 2 x)/(INR (fact 2)))*(dx ^2) +  ((D 2 x)/(INR (fact 2)))*(dx ^2)).
              { assert (INR (fact 2) = 2). { assert ( fact 2= 2%nat). { unfold fact. omega. } rewrite H16. trivial. }
                rewrite H16. nra.
              }
              rewrite H16.
              assert ( (D 0 (x + dx) - 2 * D 0 x + D 0 (x - dx) - (D 2 x / INR (fact 2) * dx ^ 2 + D 2 x / INR (fact 2) * dx ^ 2))=
                        (D 0 (x+dx) - (D 0 x + D 1 x * dx + D 2 x / INR (fact 2) * dx ^ 2 + (D 3 x / INR (fact 3)) * dx ^3)) + ( D 0 (x-dx) - (D 0 x - D 1 x * dx + D 2 x / INR (fact 2) * dx ^ 2- (D 3 x/ INR (fact 3))* (dx ^3)))). { nra. }
              rewrite H17.
              cut( (D 0 x + D 1 x * dx + D 2 x / INR (fact 2) * dx ^ 2 + (D 3 x/ INR (fact 3))* (dx ^3))= Tsum 3 x (x+dx)).
              + intros. rewrite H18.
                cut((D 0 x - D 1 x * dx + D 2 x / INR (fact 2) * dx ^ 2 - D 3 x / INR (fact 3) * dx ^ 3)= Tsum 3 x (x-dx)).
                - intros. rewrite H19.
                  apply Rle_trans with (Rabs(D 0 (x + dx) - sum_f_R0 (fun i : nat => D i x / INR (fact i) * (x + dx - x) ^ i) 3)+
                                        Rabs ((D 0 (x - dx) - sum_f_R0 (fun i : nat => D i x / INR (fact i) * (x - dx - x) ^ i) 3))).
                  * apply Rabs_triang.
                  * assert ((M + K) * dx ^ 4= M * (dx ^4) + K * (dx ^4)). { nra. }
                    rewrite H20. apply Rplus_le_compat.
                    apply H8.
                    apply H10.
                - unfold sum_f_R0. assert (x-dx-x= -dx). { nra. } rewrite H19.
                  assert (fact 0 =1%nat). { simpl. reflexivity. } rewrite H20.
                  assert (fact 1= 1%nat). { simpl. reflexivity. } rewrite H21.
                  assert (INR 1= 1). { reflexivity. } rewrite H22.
                  assert (D 0 x / 1 * (- dx) ^ 0= D 0 x). { nra. } rewrite H23.
                  assert ( D 1 x / 1 * (- dx) ^ 1 = - D 1 x * dx). { nra. } rewrite H24.
                  assert (D 3 x / INR (fact 3) * (- dx) ^ 3= - D 3 x / INR (fact 3) * dx ^ 3).  { nra. } rewrite H25.
                  assert ( (-dx)^2 = dx ^2). { nra. } rewrite H26. nra.
              + unfold sum_f_R0. assert (x+dx -x = dx). { nra. } rewrite H18.
                assert (fact 0 =1%nat). { simpl. reflexivity. } rewrite H19.
                assert (fact 1= 1%nat). { simpl. reflexivity. } rewrite H20.
                assert (D 0 x / INR 1 * dx ^ 0 = D 0 x). { assert (dx^0=1). { nra. } rewrite H21. assert (INR 1=1). { reflexivity. } rewrite H22. nra. }
                rewrite H21.
                assert (D 1 x / INR 1 * dx ^ 1 = D 1 x * dx). { assert (INR 1 =1). { reflexivity. } rewrite H22. nra. }
                rewrite H22. reflexivity.
              }
              { apply Rabs_right. nra. }
           -  (* Proof for dx< delta*)
               apply (Rmin_Rgt eta) in H4. destruct H4 as [H11 H12]. (*We have dx < Rmin eta delta as our hypothesis H4.
                Rmin_Rgt tactic breaks H4 into dx < eta and dx < delta. we will use the later in this proof*)
               apply H12.
        + (*Proof for dx < eta*)
           apply (Rmin_Rgt eta) in H4. (*Lemma Rmin_Rgt : forall r1 r2 r, Rmin r1 r2 > r <-> r1 > r /\ r2 > r.
           We have dx < Rmin eta delta as our hypothesis H4. Rmin_Rgt tactic breaks H4 into dx < eta and dx < delta. we will use the former in this proof*)
           destruct H4 as [H11 H12]. (* breaks the modified hypothesis H4 into two separate hypotheis dx<eta and dx<delta so that these can be ready to
           be applied *)
           apply H11.
      }
   + apply (taylor_ulower x).
- apply (taylor_uupper x).
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear5.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_NChelper :
   forall A B C P Q,
   nCol A B C -> Col A B P -> Col A B Q -> neq P Q ->
   nCol P Q C.
Proof.
intros.
assert (~ eq A B).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (Col B P Q) by (conclude lemma_collinear4).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (Col B A P) by (forward_using lemma_collinearorder).
assert (Col B A Q) by (forward_using lemma_collinearorder).
assert (Col A P Q) by (conclude lemma_collinear4).
assert (Col P Q A) by (forward_using lemma_collinearorder).
assert (Col P Q B) by (forward_using lemma_collinearorder).
assert (~ Col P Q C).
 {
 intro.
 assert (Col A B C) by (conclude lemma_collinear5).
 contradict.
 }
close.
Qed.

End Euclid.


Require Import Ascii String Zdiv.

Open Scope string.

Inductive format :=
| fmt_int : format -> format
| fmt_string : format -> format
| fmt_other : ascii -> format -> format
| fmt_end : format.

Fixpoint format_str s :=
  match s with
  | String "%" (String "d" s') => fmt_int (format_str s')
  | String "%" (String "s" s') => fmt_string (format_str s')
  | String c s' => fmt_other c (format_str s')
  | EmptyString => fmt_end
  end.

Fixpoint gen_format_type f :=
  match f with
  | fmt_int f' => Z -> gen_format_type f'
  | fmt_string f' => string -> gen_format_type f'
  | fmt_other _ f' => gen_format_type f'
  | fmt_end => string
  end.

(* I can't find a nicer way to convert Z -> string :( *)
Definition digit_to_string n : string :=
  match n with
  | 0%Z => "0"
  | 1%Z => "1"
  | 2%Z => "2"
  | 3%Z => "3"
  | 4%Z => "4"
  | 5%Z => "5"
  | 6%Z => "6"
  | 7%Z => "7"
  | 8%Z => "8"
  | 9%Z => "9"
  | _ => ""
  end.

Fixpoint z_to_string' n z acc : string :=
  match n with
  | 0 => acc
  | S n' =>
    let acc' := digit_to_string (Zmod z 10) ++ acc
    in match (Zdiv z 10) with
       | Z0 => acc'
       | z' => z_to_string' n' z' acc'
       end
  end.

Definition z_to_string z :=
  if Z.geb z 0
  then z_to_string' (Z.to_nat z) z ""
  else let z' := Zabs z
       in "-" ++ z_to_string' (Z.to_nat z') z' "".
(* end of laborious Z -> string stuff *)

Fixpoint to_fn f s : gen_format_type f :=
  match f with
  | fmt_int f' => fun i => to_fn f' (s ++ z_to_string i)
  | fmt_string f' => fun i => to_fn f' (s ++ i)
  | fmt_other a f' => to_fn f' (s ++ String a EmptyString)
  | fmt_end => s
  end.

Definition printf s := to_fn (format_str s) "".

Eval compute in printf "%s %s %d" "hi" "there" 123%Z.


Require Import List.
Require Import EqNat.

Definition alist := list (nat * bool).

Fixpoint in_assignment n (a : alist) : Prop :=
  match a with
    | nil => False
    | (h,_)::t => if beq_nat n h
                  then True
                  else in_assignment n t
  end.

Lemma in_empty : forall a, in_assignment a nil -> False.
  intros; compute in H; apply H.
Qed.

Fixpoint find_assignment n (a : alist) : in_assignment n a -> bool :=
  match a with
    | nil => fun pf => match (in_empty n) pf with end
    | (h, tv)::t => if beq_nat h n
                    then fun _ => tv
                    else find_assignment n t
  end.


Require Import XR_Rmin.
Require Import XR_Rmax.
Require Import XR_Rle_dec.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rminmax : forall a b, Rmin a b <= Rmax a b.
Proof.
  intros x y.
  unfold Rmin, Rmax.
  destruct (Rle_dec x y) as [ h | h ].
  { exact h. }
  {
    left.
    apply Rnot_le_lt.
    exact h.
  }
Qed.