(* -----------------Description------------------------------------------

This file contains useful results about reflection techniques in Coq.
Some of the important concepts formalized are:

Definition Prop_bool_eq (P: Prop) (b: bool):= P <-> b=true.
Lemma reflect_intro (P:Prop)(b:bool): Prop_bool_eq P b -> reflect P b.

Lemma impP(p q:bool): reflect (p->q)((negb p) || q).
Lemma switch1(b:bool): b=false -> ~ b.
Lemma switch2(b:bool): ~ b -> b=false.

Some useful Ltac defined terms:

 Ltac switch:=  (apply switch1||apply switch2).
 Ltac switch_in H:= (apply switch1 in H || apply switch2 in H).
 Ltac right_ := apply /orP; right.
 Ltac left_ := apply /orP; left.
 Ltac split_ := apply /andP; split.

--------------------- ------------------- ------------------------------*)

From Coq Require Export ssreflect  ssrbool.

Require Export Omega.

Set Implicit Arguments.

Section GeneralReflections.
Definition Prop_bool_eq (P: Prop) (b: bool):= P <-> b=true.

(* Inductive reflect (P : Prop) : bool -> Set :=
   ReflectT : P -> reflect P true | ReflectF : ~ P -> reflect P false *)
Lemma reflect_elim (P:Prop)(b: bool): reflect P b -> Prop_bool_eq P b.
Proof. { intro H.
       split. case H; [ auto | discriminate || contradiction ].
       case H; [ auto | discriminate || contradiction ]. } Qed.
Lemma reflect_intro (P:Prop)(b:bool): Prop_bool_eq P b -> reflect P b.
Proof. { intros. destruct H as  [H1 H2].
         destruct b. constructor;auto.
         constructor.  intro H. apply H1 in H;inversion H. } Qed.

Lemma reflect_dec P: forall b:bool, reflect P b -> {P} + {~P}.
Proof. intros b H; destruct b; inversion H; auto.  Qed.
Lemma reflect_EM P: forall b:bool, reflect P b -> P \/ ~P.
Proof. intros b H. case H; tauto. Qed.
Lemma dec_EM P: {P}+{~P} -> P \/ ~P.
  Proof. intro H; destruct H as [Hl |Hr];tauto. Qed.
Lemma pbe_EM P: forall b:bool, Prop_bool_eq P b -> P \/ ~P.
Proof. { intros b H; cut( reflect P b).
         apply reflect_EM. apply reflect_intro;auto. } Qed.

(* iffP : forall (P Q : Prop) (b : bool), reflect P b -> (P -> Q) -> (Q -> P) -> reflect Q b *)

(* idP : forall b1 : bool, reflect b1 b1 *)

(* negP
     : reflect (~ ?b1) (~~ ?b1) *)

(* andP
     : reflect (?b1 /\ ?b2) (?b1 && ?b2) *)

(*orP
     : reflect (?b1 \/ ?b2) (?b1 || ?b2) *)
Lemma impP(p q:bool): reflect (p->q)((negb p) || q).
  Proof. { case p eqn:pH; case q eqn:qH; simpl.
       constructor. auto.
       constructor. intro H2. cut (false=true). discriminate. apply H2. auto.
       constructor. auto.
       constructor. discriminate. } Qed.
Lemma impP1(P Q:Prop)(p q:bool)(HP: reflect P p)(HQ: reflect Q q):  reflect (P->Q)((negb p) || q).
Proof. { case p eqn:pH; case q eqn:qH; simpl.
       constructor. move /HP. apply /HQ.
       constructor. intro H2. absurd (Q). move /HQ. discriminate. apply H2; apply /HP;auto.
       constructor. move /HP. discriminate.
       constructor. move /HP. discriminate. } Qed.
Lemma switch1(b:bool): b=false -> ~ b.
Proof. intros H H1.  rewrite H1 in H. discriminate H. Qed.
Lemma switch2(b:bool): ~ b -> b=false.
Proof. intros H. case b eqn:H1. absurd (true);auto. auto. Qed.

Lemma bool_fun_equal (B1 B2: bool): (B1-> B2)-> (B2-> B1)-> B1=B2.
    Proof. intros H1 H2. destruct B1; destruct B2; auto.
           replace false with true. auto. symmetry; auto. Qed.

    Hint Resolve bool_fun_equal: core.

End GeneralReflections.

Hint Immediate reflect_intro reflect_elim  reflect_EM reflect_dec dec_EM: core.
Hint Resolve idP impP impP1: core.
Hint Resolve bool_fun_equal: core.

Ltac solve_dec := eapply reflect_dec; eauto.
Ltac solve_EM  := eapply reflect_EM; eauto.

Ltac switch:=  (apply switch1||apply switch2).
Ltac switch_in H:= (apply switch1 in H || apply switch2 in H).

Ltac right_ := apply /orP; right.
Ltac left_ := apply /orP; left.
Ltac split_ := apply /andP; split.

Section NaturalNumbers.

Lemma ltP (x y:nat): reflect (x < y) (Nat.ltb x y).
Proof. { apply reflect_intro. split.
       { unfold "<".  unfold "<?".
         revert y. induction x. intro y; case y. simpl.
         intro H. inversion H. simpl. auto.
         intro y;case y.
         intro H; inversion H. intros n H.
         replace (S (S x) <=?  S n) with (S x <=? n). apply IHx. omega.
         simpl. auto. }
       { unfold "<"; unfold "<?".
         revert y. induction x. intro y; case y. simpl.
         intro H. inversion H. intros; omega.
         intro y;case y. simpl. intro H; inversion H.
         intro n. replace (S (S x) <=? S n) with (S x <=? n).
         intro H; apply IHx in H. omega. simpl;auto. } } Qed.

Lemma leP (x y: nat): reflect (x <= y) (Nat.leb x y).
Proof. { apply reflect_intro. split.
       { revert y. induction x. intro y; case y; simpl; auto.
         intro y;case y.
         intro H; inversion H. intros n H.
         replace (S  x <=? S n) with ( x <=? n). apply IHx. omega.
         simpl. auto. }
       { revert y. induction x. intro y; case y; intros; omega.
         intro y;case y. simpl. intro H; inversion H.
         intro n. replace (S x <=? S n) with ( x <=? n).
         intro H; apply IHx in H. omega. simpl;auto. } } Qed.

Lemma nat_reflexive: reflexive Nat.leb.
  Proof. unfold reflexive; induction x; simpl; auto. Qed.

Lemma nat_transitive: transitive Nat.leb.
Proof. unfold transitive. intros x y z h1 h2. move /leP in h1. move /leP in h2.
         apply /leP. omega. Qed.

Hint Resolve leP ltP nat_reflexive nat_transitive: core.

End NaturalNumbers.

Hint Resolve leP ltP nat_reflexive nat_transitive: core.


Require Import Nat Arith.

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

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

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

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

Fixpoint plus (plus_arg0 : Nat) (plus_arg1 : Nat) : Nat
           := match plus_arg0, plus_arg1 with
              | zero, n => n
              | succ n, m => succ (plus n m)
              end.

Fixpoint half (half_arg0 : Nat) : Nat
           := match half_arg0 with
              | zero => zero
              | succ zero => zero
              | succ (succ n) => succ (half n)
              end.

Theorem plus_comm: forall (n m: Nat), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : Nat) (y : Nat), eq (half (plus x y)) (half (plus y x)).
Proof.
  intros.
  rewrite plus_comm.
  reflexivity.
Qed.


(*this time w the ensembles library*)
Require Import Reals.
Require Import Lra.
Require Import Ensembles.
Require Image.
Local Open Scope R_scope.
Definition Image (A : Ensemble R) (f : R -> R) : Ensemble R :=
  Image.Im R R A f.

Definition closed_unit_interval : Ensemble R :=
  fun x => 0 <= x <= 1.

Definition three_x : R -> R := fun x => 3*x.
(*continuity*)
Definition neighborhood (eps : R) (point : R) : Ensemble R :=
  fun x =>
    point - eps <= x <= point + eps.

Check In R (neighborhood 1 1).

Definition continuous_c (f : R -> R) (c : R) : Prop :=
  forall (eps : R), exists (delt : R),
      eps > 0 -> delt > 0 ->
      forall x, (neighborhood delt c) x ->
           (neighborhood eps (f c)) (f x).

Definition continuous (f : R -> R) (A : Ensemble R) : Prop :=
  forall (c : R), A c -> continuous_c f c.

Theorem three_x_continuous : continuous three_x closed_unit_interval.
Proof.
  unfold continuous, continuous_c; intros.
  exists (eps / 3). intros. unfold three_x.
  unfold neighborhood in *.
  lra.
Qed.

(*compactness*)
Definition open (A : Ensemble R) : Prop :=
  forall x, exists eps,
      A x -> eps > 0 ->
      Included R (neighborhood eps x) A.

Definition closed (A : Ensemble R) : Prop :=
  open (Complement R A).

Theorem closed_unit_interval_closed : closed closed_unit_interval.
Proof.
  unfold closed, open, Complement, closed_unit_interval; intros.
  assert (G : closed_unit_interval 1). { unfold closed_unit_interval. lra. }
  exists 0.
  unfold not, included, neighborhood, Included, In; intros.
  lra.
Qed.

Definition bounded_above (A : Ensemble R) : Prop :=
  exists (b : R), forall x, A x -> x <= b.

Definition bounded_below (A : Ensemble R) : Prop :=
  exists (b : R), forall x, A x -> b <= x.

Definition bounded (A : Ensemble R) : Prop :=
  bounded_above A /\ bounded_below A.

Ltac show_boundedness bounded_side A x :=
  unfold bounded_side, A; exists x; intros; lra.

Theorem closed_unit_interval_bounded : bounded closed_unit_interval.
Proof.
  unfold bounded; split.
  - show_boundedness bounded_above closed_unit_interval 1.
  - show_boundedness bounded_below closed_unit_interval 0.
Qed.

Definition compact (A : Ensemble R) : Prop :=
  closed A /\ bounded A.

Theorem closed_unit_interval_compact : compact closed_unit_interval.
Proof.
  unfold compact; split.
  - apply closed_unit_interval_closed.
  - apply closed_unit_interval_bounded.
Qed.

(*preservation*)
Definition compact_image (f : R -> R) (A : Ensemble R) : Prop :=
  (*won't be provable if f isn't continuous or A isn't compact*)
  compact (Image A f).

Theorem three_x_preserves_compactness : compact_image three_x closed_unit_interval.
Proof.
  unfold compact_image.
  unfold compact.
  split.
  { unfold closed.
    unfold open, Complement.
    intro x.
    exists 0.
    intros H1 H2.
    lra.
  }
  { unfold bounded.
    split.
    - unfold bounded_above; exists 3; intros x H; unfold closed_unit_interval, three_x in H.
      destruct H. unfold In in H. lra.
    - unfold bounded_below; exists 0; intros x H; unfold closed_unit_interval, three_x in H.
      destruct H. unfold In in H. lra.
  }
Qed.

Definition f_attains_max_and_min (f : R -> R) (A : Ensemble R) : Prop :=
  continuous f A -> compact A ->
  exists (fmin fmax : R), forall (y : R), Image A f y -> fmin <= y <= fmax.

Theorem three_x_attains_max_and_min :
  f_attains_max_and_min three_x closed_unit_interval.
  unfold f_attains_max_and_min.
  intros H1 H2.
  exists 0, 3;
    intros.
    inversion H;
    unfold In, closed_unit_interval in H0;
    unfold three_x in H3;
    lra.
Qed.

Theorem preservation_of_compactness :
  forall (f : R -> R) (A : Ensemble R),
    continuous f A -> compact A ->
    compact_image f A.
Proof.
  intros f A H G.
  unfold compact_image.
  unfold compact.
  split.
  { unfold closed, open, Complement.
    intros x.
    exists 0.
    intros F E.
    lra.
  }
  { assert (J : f_attains_max_and_min f A).
    { unfold f_attains_max_and_min.
      intros _ _.
      unfold compact, bounded in G; destruct G as [G1 [G2 G3]].
      destruct G2 as [b__up G2].
      destruct G3 as [b__low G3].

      eexists. eexists.
      intros y F.
      split.
      - remember (y-1) as fmin.
        assert (J1 : fmin <= y). lra.
        give_up.
      - give_up.
    }
    unfold f_attains_max_and_min in J.
    specialize (J H G).
    destruct J as [fmin [fmax J']].
    unfold compact, bounded in G; destruct G as [G1 [G2 G3]].
    destruct G2 as [b__up G2].
    destruct G3 as [b__low G3].
    split.
    { unfold bounded_above;
        exists fmax;
        intros y F;
        inversion F as [x' F1 y' F2 F3];
        unfold In in F1.
      destruct (J' y) as [J'1 J'2]. apply F.
      apply J'2.
    }
    { unfold bounded_below;
        exists fmin;
        intros y F;
        inversion F as [x' F1 y' F2 F3];
        unfold In in F1.
      destruct (J' y) as [J'1 J'2]. apply F.
      apply J'1.
    }
  }


Add LoadPath "/Users/kfischer/Documents/CS250/cpdtlib".

Require Import Bool Arith String List CpdtTactics.
Require Import FunctionalExtensionality.
Open Scope string_scope.

Definition var := string.

Inductive binop := Plus | Times | Minus.

Inductive aexp : Type :=
| Const : nat -> aexp
| Var : var -> aexp
| Binop : aexp -> binop -> aexp -> aexp.

Inductive bexp : Type :=
| Tt : bexp
| Ff : bexp
| Eq : aexp -> aexp -> bexp
| Lt : aexp -> aexp -> bexp
| And : bexp -> bexp -> bexp
| Or : bexp -> bexp -> bexp
| Not : bexp -> bexp.

Inductive com : Type :=
| Skip : com
| Assign : var -> aexp -> com
| Seq : com -> com -> com
| If : bexp -> com -> com -> com
| While : bexp -> com -> com.

Definition state := var -> nat.

Definition get (x:var) (s:state) : nat := s x.

Definition set (x:var) (n:nat) (s:state) : state :=
  fun y => if string_dec x y then n else get y s.

Definition eval_binop (b:binop) : nat -> nat -> nat :=
  match b with
    | Plus => plus
    | Times => mult
    | Minus => minus
  end.

Fixpoint eval_aexp (e:aexp) (s:state) : nat :=
  match e with
    | Const n => n
    | Var x => get x s
    | Binop e1 b e2 => (eval_binop b) (eval_aexp e1 s) (eval_aexp e2 s)
  end.

Fixpoint eval_bexp (b:bexp) (s:state) : bool :=
  match b with
    | Tt => true
    | Ff => false
    | Eq e1 e2 => NPeano.Nat.eqb (eval_aexp e1 s) (eval_aexp e2 s)
    | Lt e1 e2 => NPeano.ltb (eval_aexp e1 s) (eval_aexp e2 s)
    | And b1 b2 => eval_bexp b1 s && eval_bexp b2 s
    | Or b1 b2 => eval_bexp b1 s || eval_bexp b2 s
    | Not b => negb (eval_bexp b s)
  end.

Inductive eval_com : com -> state -> state -> Prop :=
| Eval_skip : forall s, eval_com Skip s s
| Eval_assign : forall s x e, eval_com (Assign x e) s (set x (eval_aexp e s) s)
| Eval_seq : forall c1 s0 s1 c2 s2,
               eval_com c1 s0 s1 -> eval_com c2 s1 s2 ->
               eval_com (Seq c1 c2) s0 s2
| Eval_if_true : forall b c1 c2 s s',
                   eval_bexp b s = true ->
                   eval_com c1 s s' -> eval_com (If b c1 c2) s s'
| Eval_if_false : forall b c1 c2 s s',
                   eval_bexp b s = false ->
                   eval_com c2 s s' -> eval_com (If b c1 c2) s s'
| Eval_while_false : forall b c s,
                       eval_bexp b s = false ->
                       eval_com (While b c) s s
| Eval_while_true : forall b c s1 s2 s3,
                      eval_bexp b s1 = true ->
                      eval_com c s1 s2 ->
                      eval_com (While b c) s2 s3 ->
                      eval_com (While b c) s1 s3.

Hint Constructors eval_com.

(* Write a function ieval_com : nat -> com -> state -> option state
   which takes "fuel" as an argument and tries to run the command
   for fuel-number of steps.  If the command terminates in that time,
   then you should return the resulting state, and if it doesn't
   terminate in that time, you should return None.
*)

Fixpoint ieval_com (n:nat) (c:com) (s:state) : option state :=
match n with
| O => None
| S m => match c with
    | Skip => Some s
    | Assign x e => Some (set x (eval_aexp e s) s)
    | Seq c1 c2 => match (ieval_com m c1 s) with
      | Some s' => (ieval_com m c2 s')
      | None => None
    end
    | If b c1 c2 => if (eval_bexp b s) then
      (ieval_com m c1 s)
      else (ieval_com m c2 s)
    | While b c1 => if (eval_bexp b s) then
      (ieval_com m (Seq c1 c) s)
      else Some s
    end
end.

(* Prove that :

   eval_com c s1 s2 -> exists n, ieval_com n c s1 = Some s2.

*)

Lemma terminates : forall n c s1 s2, ieval_com n c s1 = Some s2 -> n<>0. crush. Qed.
Lemma neq : forall n, n<>0 <-> exists m, n = S m.
crush. destruct n. crush. exists n. reflexivity. Qed.

Ltac _aterm H id := assert (id := H); apply terminates in id.
Ltac aterm H := let id:=fresh in _aterm H id.
Ltac aterm2 H := let id:=fresh in _aterm H id; apply neq in id; destruct id; rewrite id in *.

Lemma ieval_seq : forall n c1 c2 s1 s2 s3,
       ieval_com n c1 s1 = Some s3 -> ieval_com n c2 s3 = Some s2 -> ieval_com (S n) (Seq c1 c2) s1 = Some s2.
  intros. crush.
Qed.

Lemma ieval_iseq : forall n c1 c2 s1 s2 s3,
       ieval_com (S n) (Seq c1 c2) s1 = Some s3 -> ieval_com n c1 s1 = Some s2 -> ieval_com n c2 s2 = Some s3.
  intros. rewrite <- H. crush.
Qed.

Hint Resolve ieval_seq.

Tactic Notation "unroll_ieval_com" "in" constr(H) :=
  match type of H with
    | ieval_com (S ?X) _ _ = _ => let y:=fresh in let Heqy:=fresh in remember X as y eqn:Heqy; simpl ieval_com in H; rewrite Heqy in *; clear Heqy
  end.

Ltac unroll_ieval_com :=
  match goal with
    | [ |- ieval_com (S ?X) _ _ = _ ] => let y:=fresh in let Heqy:=fresh in remember X as y eqn:Heqy; simpl ieval_com; rewrite Heqy in *; clear Heqy
    | [ H: context[ieval_com (S ?X) _ _] |- _ ] => unroll_ieval_com in H
  end.

Ltac clean :=
  repeat match goal with
    | [ H: ?m = S ?n |- _ ] => rewrite H in *; clear H
    | [ H: S ?m = ?n |- _ ] => rewrite <- H in *; clear H
end.

Ltac cond_simpl c := let cond:=fresh in remember c as cond; destruct cond; simpl.

Lemma seq_term : forall n c1 c2 s1 s2, ieval_com (S n) (Seq c1 c2) s1 = Some s2 ->
         exists s', ieval_com n c1 s1 = Some s'.
  crush. cond_simpl (ieval_com n c1 s1). crush. exists s. crush. crush.
Qed.

Lemma ieval_plus : forall n c s1 s2,
       ieval_com n c s1 = Some s2 ->
         forall m, ieval_com (n + m) c s1 = Some s2.
intros.
Lemma ieval_plus' : forall n c s1 s2,
       ieval_com n c s1 = Some s2 -> ieval_com (n + 1) c s1 = Some s2.
  intro n; induction n.
  (* Base Case *)
    intros. crush.
  (* Induction *)
    intros; rewrite plus_comm in *; rewrite NPeano.Nat.add_succ_r in *;
      simpl plus in *.
    unroll_ieval_com.
    remember (S n) as m.
    destruct c. crush. crush.
    (* Begin SEQ *)
      cond_simpl (ieval_com m c1 s1). clean.
      assert (H2 := H). assert (IHn2 := IHn).
      apply seq_term in H.
      destruct H. assert (H3 := H).
      specialize IHn with (c:=c1) (s1:=s1) (s2:=x).
      apply IHn in H. rewrite <- HeqH1 in H.
      injection H; intros; rewrite <- H1 in *; clear H1; clear H.
      apply ieval_iseq with (c2:=c2) (s3:=s2) (s2:=s) in H2.
      specialize IHn2 with (c:=c2) (s1:=s) (s2:=s2); apply IHn2 in H2;
         assumption.
      assumption.
      clean; apply seq_term in H; destruct H.
      specialize IHn with (c:=c1) (s1:=s1) (s2:=x); apply IHn in H.
      contradict HeqH1. crush.
    (* End SEQ *)
      cond_simpl (eval_bexp b s1); clean; apply IHn with (s2:=s2);
        rewrite <- H; simpl; rewrite <- HeqH1; reflexivity.
    (* End IF *)
      cond_simpl (eval_bexp b s1); clean.
      remember ((Seq c (While b c))) as c2. apply IHn. rewrite <- H.
      simpl. rewrite <- HeqH1. rewrite <- Heqc2. reflexivity.
      rewrite <- H. simpl. rewrite <- HeqH1. reflexivity.
  Qed.
  induction m.
  rewrite plus_comm; simpl; rewrite H; reflexivity.
  assert ( n + S m = ((n + m) + 1) ). crush.
  rewrite H0; apply ieval_plus'; assumption.
Qed.

Ltac destruct_inds IHeval_com1 IHeval_com2 :=
  destruct IHeval_com1 as [x IH1]; destruct IHeval_com2 as [x0 IH2];
  aterm IH1; aterm IH2; assert (x+x0 <> 0) as IS; [ omega | ];
  apply neq in IS; destruct IS as [x1 Hyp].

Tactic Notation "raise" constr(x0) := eapply ieval_plus with (n := _) (m := x0).
Tactic Notation "raise" := raise 1; rewrite plus_comm; simpl plus.
Tactic Notation "raise" constr(x0) "in" constr(H) := eapply ieval_plus with (n := _) (m := x0) in H.
Tactic Notation "raise" "in" constr(H) := raise 1 in H; rewrite plus_comm in H; simpl plus in H.

Lemma EvalCom1 : forall c s1 s2, eval_com c s1 s2 -> exists n, ieval_com n c s1 = Some s2.
    intros.
    induction H; try solve [
    (* Skip, Assign, While false *)
        (exists 1; simpl; try rewrite H; reflexivity) |
    (* Ifs *)
        destruct IHeval_com; exists (S x); simpl;
        rewrite H; rewrite H1; reflexivity ];
    (* Common Setup *)
        destruct_inds IHeval_com1 IHeval_com2;
    (* Seq *)
       [( exists (S (S x1));
          rewrite <- Hyp; unroll_ieval_com )
    (* While True *)
       | (exists (S (S (S x1)));
         unroll_ieval_com; rewrite <- Hyp;
         rewrite H; unroll_ieval_com ) ];
    (* Common cleanup *)
       raise x0 in IH1; raise x in IH2;
       rewrite <- plus_comm in IH2;
       rewrite IH1; rewrite IH2; reflexivity.
Qed.

(* Prove that :

   ieval_com n c s1 = Some s2 -> eval_com c s1 s2

*)

Lemma EvalCom2 : forall n c s1 s2, ieval_com n c s1 = Some s2 -> eval_com c s1 s2.
Lemma EvalCom2' : forall n c s1 s2, ieval_com (S n) c s1 = Some s2 -> eval_com c s1 s2.
  intro n. induction n.
  (* Base Case *)
    intros; destruct c; crush;
    remember (eval_bexp b s1) as x; destruct x; crush.
  (* Induction *)
    intros.
    destruct c. crush. crush.
  (* Seq *)
    unroll_ieval_com in H.
    remember (S n) as x in H; simpl ieval_com in H.
    remember (ieval_com x c1 s1) as y.
    destruct y.
    rewrite Heqx in *.
    assert (IHn2:=IHn).
    specialize IHn with (c:=c2) (s1:=s) (s2:=s2).
    specialize IHn2 with (c:=c1) (s1:=s1) (s2:=s).
    apply IHn in H.
    apply eq_sym in Heqy.
    apply IHn2 in Heqy.
    apply (Eval_seq c1 s1 s c2 s2); assumption.
    contradict H. crush.
  (* If *)
    unroll_ieval_com.
    cond_simpl (eval_bexp b s1); crush.
  (* While *)
    unroll_ieval_com.
    cond_simpl (eval_bexp b s1).
    unroll_ieval_com.
    cond_simpl (ieval_com n c s1).
    apply (Eval_while_true b c s1 s s2).
    apply eq_sym; assumption.
    apply eq_sym in HeqH2; raise in HeqH2;
      eapply IHn in HeqH2; assumption.
    raise in H; eapply IHn; assumption.
    contradict H; crush.
    crush.
Qed.
intros; aterm2 H; apply EvalCom2' in H; assumption.
Qed.

(* Write a function

     optimize_com : com -> com

   which tries to optimize a command and the sub-expressions
   within it.  In particular, your optimizer should at least:

   * replace (a + 0) and (0 + a) with a
   * replace (a - 0) with a
   * replace (a * 1) and (1 * a) with a
   * replace (a * 0) and (0 * a) with 0

   * replace (a == a) with Tt
   * replace (a < a) with Ff
   * replace (Tt && Tt) with Tt
   * replace (Tt || b) and (b || Tt) with Tt
   * replace (Ff && b) and (b && Ff) with Ff

   * replace (skip ; c) and (c ; skip) with c
   * replace (if Tt c1 else c2) with c1
   * replace (if Ff c1 else c2) with c2
*)

Fixpoint optimize_binop (b: binop) (x: aexp) (y: aexp) : aexp :=
  match b with
    | Times => match (x,y) with
      | (a, Const 1) | (Const 1, a) => a
      | (Const 0, _) | (_, Const 0) => Const 0
      | (a,b) => (Binop a Times b)
    end
    | Plus => match (x,y) with
      | (a, Const 0) | (Const 0, a) => a
      | (a,b) => (Binop a Plus b)
    end
    | Minus => match (x,y) with
      | (a, Const 0) => a
      | (a,b) => (Binop a Minus b)
    end
  end.

Ltac Hammer n := try (destruct n; simpl; try omega).

Lemma binop_opt_correct : forall b x y s, eval_aexp (Binop x b y) s = eval_aexp (optimize_binop b x y) s.
  intros.
  destruct b; simpl optimize_binop; destruct x;
  Hammer n; Hammer n0; destruct y;
  Hammer n; Hammer n; Hammer n0; Hammer n0;
  simpl; try omega.
Qed.

Fixpoint optimize_aexp (a: aexp) : aexp :=
  match a with
    | Binop x b y => optimize_binop b (optimize_aexp x) (optimize_aexp y)
    | _ => a
  end.

Lemma aexpopt_correct : forall a s, eval_aexp a s = eval_aexp (optimize_aexp a) s.
  intros.
  induction a; crush.
  apply binop_opt_correct.
Qed.

Definition eq_aexp_dec (a1 a2:aexp) : {a1=a2} + {a1<>a2}.
      decide equality.
      apply (eq_nat_dec n n0).
      apply (string_dec v v0).
      decide equality.
    Defined.

Fixpoint optimize_bexp (b: bexp) : bexp :=
  match b with
   | Eq aa ab => let (aa', bb') := ((optimize_aexp aa),(optimize_aexp ab)) in
     match eq_aexp_dec aa' bb'  with
        | left P => Tt
        | right p => Eq aa' bb'
     end
   | Lt aa ab => let (aa', bb') := ((optimize_aexp aa),(optimize_aexp ab)) in
     match eq_aexp_dec aa' bb' with
      | left P => Ff
      | right p => Lt aa' bb'
     end
   | Not x => match (optimize_bexp x) with
      | Tt => Ff
      | Ff => Tt
      | x => Not x
   end
   | Or x y => match (optimize_bexp x, optimize_bexp y) with
      | (Tt, _) | (_, Tt) => Tt
      | (Ff, a) | (a, Ff) => a
      | (a,b) => Or a b
     end
   | And x y => match (optimize_bexp x, optimize_bexp y) with
      | (Tt, a) | (a, Tt) => a
      | (Ff, _) | (_, Ff) => Ff
      | (a,b) => And a b
     end
    | _ => b
  end.

(* These are probably in the library somewhere but I couldn't find them *)
Lemma eqb_true : forall x, NPeano.Nat.eqb x x = true.
  induction x; crush.
Qed.

Lemma ltb_false : forall x, NPeano.Nat.ltb x x = false.
  induction x; crush.
Qed.

Lemma bexp_opt_correct : forall b s, eval_bexp b s = eval_bexp (optimize_bexp b) s.
intros. induction b; crush;
try (remember (eq_aexp_dec (optimize_aexp a) (optimize_aexp a0)) as cond;
destruct cond; [ simpl;
rewrite aexpopt_correct at 1; rewrite e; rewrite <- aexpopt_correct at 1; try rewrite eqb_true; try rewrite ltb_false; reflexivity |
simpl; repeat rewrite <- aexpopt_correct; reflexivity ]); [ .. | remember (optimize_bexp b) as bb; destruct bb; crush ];
remember (optimize_bexp b1) as bb1; remember (optimize_bexp b2) as bb2;
destruct bb1; solve[ simpl; reflexivity | destruct bb2; simpl;
       solve [ crush | rewrite andb_true_r; reflexivity | rewrite andb_false_r; reflexivity ] ].
Qed.

Fixpoint optimize_com (c:com) : com :=
  match c with
      | Seq c1 c2 => match (optimize_com c1, optimize_com c2) with
        | (Skip, Skip) => Skip
        | (Skip, c2') => c2'
        | (c1', Skip) => c1'
        | (c1', c2') => (Seq c1' c2')
      end
      | Assign v a => Assign v (optimize_aexp a)
      | If bb c1 c2 => match (optimize_bexp bb) with
         | Tt => optimize_com c1
         | Ff => optimize_com c2
         | b => If b (optimize_com c1) (optimize_com c2)
      end
      | While bb c1 => match (optimize_bexp bb) with
         | Ff => Skip
         | b => While b (optimize_com c1)
      end
      | Skip => Skip
  end.

(* Construct a proof that optimizing a program doesn't change its
   input/output behavior.  That is, show that if we start in state
   s1 and evaluate c to get state s2, then if we evaluate
   optimize_com(c) in state s1, we get out a state that is
   extensionally equivalent to s2.
*)

Ltac to_ieval H := apply EvalCom1 in H; destruct H; aterm2 H; simpl in H.
Ltac to_ieval_assign H := simpl ieval_com in H; rewrite <- aexpopt_correct in H.

Lemma eval_assign_correct : forall v a s' s1, eval_com (Assign v (optimize_aexp a)) s1 s' <-> eval_com (Assign v a) s1 s'.
intros.
split; intros; apply EvalCom2 with (n:=1); simpl; apply EvalCom1 in H; destruct H; aterm2 H; simpl in H.
rewrite <- aexpopt_correct in H; assumption.
rewrite aexpopt_correct in H; assumption.
Qed.

Ltac myinj H := let Hx := fresh in injection H as Hx; rewrite Hx in *; clear Hx; clear H.

Ltac magic :=
  repeat match goal with
      | [ H: context[eval_com (optimize_com Skip) _ _] |- _ ] =>  to_ieval H; (try myinj); try assumption
      | [ H: context[eval_com Skip _ _] |- _ ] =>  to_ieval H; (try myinj); try assumption
      | [ H: context[eval_com (Assign _ (optimize_aexp _)) _ _] |- _ ] => apply -> eval_assign_correct in H; try assumption
      | [ |- eval_com (Assign _ (optimize_aexp _)) _ _ ] => apply eval_assign_correct; try assumption
      | [ H: context[eval_com (optimize_com (Assign _ _)) _ _ ] |- _] => simpl optimize_com in H; try assumption
      | [ H: eval_com (optimize_com (Seq ?c2 ?c3)) _ _ |- _ ] => remember (optimize_com (Seq c2 c3))
      | [ H: eval_com (optimize_com (If ?b ?c2 ?c3)) _ _ |- _ ] => remember (optimize_com (If b c2 c3))
      | [ H: eval_com (optimize_com (While ?b ?c2)) _ _ |- _ ] => remember (optimize_com (While b c2))
      | [ H1: eval_com _ ?sx ?s3, H2: eval_com _ ?s3 ?s2 |- eval_com (Seq _ _) ?sx ?s2 ] => apply Eval_seq with (s1:=s3); magic; try assumption
      | [ H: Some ?s1 = Some ?s2 |- _ ] => let Hx := fresh in injection H as Hx; rewrite Hx in *; clear Hx; clear H
      | [ |- eval_com Skip ?s ?s ] => apply Eval_skip; assumption
  end.

Ltac imagic :=
  repeat match goal with
      | [ H: ieval_com ?x ?c ?s1 = ?s2 |- ieval_com (S ?x) ?c ?s1 = ?s2 ] => raise in H; try assumption
      | [ H: ieval_com ?x ?c ?s1 = ?s2, H2: ieval_com (S ?x) ?c ?s1 = ?s3 |- _ ] =>
          let H3:=fresh in assert(H3:=H); raise in H3; rewrite H3 in H2; myinj H2; subst; try assumption; try reflexivity
      | [ H: ?x = ieval_com _ _ _ |- _ ] => apply eq_sym in H
  end.

Lemma seq_correct : forall c1 c2 s1 s' s2, eval_com (optimize_com c1) s1 s' -> eval_com (optimize_com c2) s' s2 -> eval_com (optimize_com (Seq c1 c2)) s1 s2.
intros.
simpl optimize_com.
destruct c1; destruct c2; magic; simpl; magic; destruct c; try destruct c0; magic; simpl; try assumption.
Qed.

Ltac remember_cond name :=
  match goal with
      | [ |- context[ (If ?c _ _ )] ] => remember c as name
      | [ |- context[ (While ?c _ )] ] => remember c as name
  end.

Ltac ifc H Heqcond := contradict H; rewrite bexp_opt_correct; rewrite <- Heqcond; simpl; crush.
Ltac ifb H Heqcond s1 := let cond4:=fresh in  remember_cond cond4; unroll_ieval_com; remember (eval_bexp cond4 s1) as cond5 eqn:Heqcond5; destruct cond5; first [
assumption |
contradict H; rewrite bexp_opt_correct; rewrite <- Heqcond; rewrite <- Heqcond5; crush; try assumption ].

Lemma if_correct : forall b c1 c2 s1 s2,
                     eval_bexp b s1 = false \/ eval_com (optimize_com c1) s1 s2 ->
                     eval_bexp b s1 = true \/ eval_com (optimize_com c2) s1 s2 -> eval_com (optimize_com (If b c1 c2)) s1 s2.
intros.
destruct H; destruct H0;
[ contradict H; crush | .. ];
try (apply EvalCom1 in H0; destruct H0);
try (apply EvalCom1 in H; destruct H);
try (apply EvalCom2 with (n:= x+x0));
try (apply EvalCom2 with (n:= S x)); simpl optimize_com; remember (optimize_bexp b) as cond.
destruct cond; [ ifc H Heqcond | imagic | .. ]; ifb H Heqcond s1.
destruct cond; [ imagic | ifc H0 Heqcond | .. ] ; ifb H0 Heqcond s1.
destruct cond; [
raise x in H; rewrite plus_comm in H; assumption |
raise x0 in H0; assumption | .. ];
(assert (x+x0 <> 0); [ aterm2 H0; crush | ]); apply neq in H1; destruct H1; rewrite H1;
remember_cond cond4; unroll_ieval_com; remember (eval_bexp cond4 s1) as cond5 eqn:Heqcond5; (destruct cond5;
[raise (x-1) in H; assert (x1 = (x0 + (x - 1))) as H3; [ aterm2 H0; crush | ]; rewrite H3; assumption |
raise (x0-1) in H0; assert (x1 = (x + (x0 - 1))) as H3; [ aterm2 H; crush | ]; rewrite H3; assumption ] ).
Qed.

Lemma bexp_true_is_true : forall b, optimize_bexp b = Tt -> (forall s, (eval_bexp b s) = true).
intros. rewrite bexp_opt_correct. rewrite H. simpl. reflexivity.
Qed.

Lemma ieval_minus : forall x c s, ieval_com (S x) c s = None -> ieval_com x c s = None.
intros.
specialize ieval_plus with (n:=x) (m:=1) (c:=c) (s1:=s). intros.
destruct (ieval_com x c s).
assert(Some s0 = Some s0). reflexivity. eapply H0 with (m:=1) in H1.
rewrite plus_comm in H1. simpl plus in H1. congruence. reflexivity.
Qed.

Lemma while_inf : forall x b c s1, (forall s, eval_bexp b s = true) -> ieval_com x (While b c) s1 = None.
induction x; intros; [ crush | ..].
apply ieval_minus. unroll_ieval_com. erewrite H. unroll_ieval_com.
remember (ieval_com x c s1) as cond. destruct cond.
eapply IHx. assumption.
reflexivity.
Qed.

Theorem opt_correct : forall c s1 s2, eval_com c s1 s2 -> eval_com (optimize_com c) s1 s2.
intros.
induction H.
crush.
apply EvalCom2 with (n:=1); simpl. rewrite <- aexpopt_correct. reflexivity.
apply seq_correct with (s':=s1); assumption.
apply if_correct. right. assumption. left. assumption.
apply if_correct. left. assumption. right. assumption.
simpl. apply EvalCom2 with (n:=1). simpl.
remember (optimize_bexp b) as cond.
destruct cond; try reflexivity; rewrite bexp_opt_correct in H; rewrite <- Heqcond in H; rewrite H; reflexivity.
simpl.
remember (optimize_bexp b) as cond.
destruct cond;
apply EvalCom1 in H1; destruct H1; [
apply eq_sym in Heqcond;
pose proof bexp_true_is_true; specialize H2 with (b:=b); apply while_inf with (x:=x) (c:=c) (s1:=s2) in H2;
[rewrite H2 in H1; contradict H1; crush | assumption ] |
contradict H; rewrite -> bexp_opt_correct; rewrite <- Heqcond; simpl; crush | .. ];
apply EvalCom1 in IHeval_com2; destruct IHeval_com2;
apply EvalCom1 in IHeval_com1; destruct IHeval_com1;
apply EvalCom2 with (n:=(S (S (x0+x1))));
remember_cond ccc; unroll_ieval_com;
rewrite Heqcond; rewrite <- bexp_opt_correct; rewrite H;
simpl ieval_com; raise x0 in H3; rewrite plus_comm in H3; rewrite H3;
raise x1 in H2; simpl optimize_com in H2; rewrite <- Heqcond in H2; rewrite Heqccc in H2;
rewrite <- Heqcond; rewrite Heqccc; assumption.
Qed.

(* Hints:

   * You *will* get stuck doing this assignment.  It is hard.
     Don't hesitate to ask questions on Piazza or in class,
     or collaborate with friends to solve this.

   * When proving ieval_com is equivalent to eval_com, you will
     find the following lemma very useful:

     ieval_plus : forall n c s1 s2,
       ieval_com n c s1 = Some s2 ->
         forall m, ieval_com (n + m) c s1 = Some s2

    This says that if it takes n steps to get an answer out,
    then if you run for more than n steps, you still get the
    same answer out.

   * Write a simple optimizer first, and prove that correct.
     Don't try to write a complicated optimizer first.  It's
     easier to "grow" your development incrementally.

  * You will find the following tactic very useful:

       remember(<exp>) as <id>

    Consider a proof state like this:

        H : P (foo + bar + baz)
        -----------------------------------------
        match foo + bar + baz with
          | 0 => blah
          | S n => blahblah
        end

    Executing the tactic

        remember (foo + bar + baz) as x

    will leave you in the state:

        x : nat
        Hxeq : x = foo + bar + baz
        H : P x
        -----------------------------------------
        match x with
          | 0 => blah
          | S n => blahblah
        end

    So "remember" just helps you name a sub-expression in
    a proof, and replace all occurrences of that sub-expression
    with that name.  You can always undo the substitution by
    rewriting by the Hxeq equation.

  * There are many useful arithmetic facts in the libraries
    (e.g., plus_0_r, NPeano.Nat.sub_0_r, mult_comm, etc.)
    Don't forget to use "SearchAbout" to find them.

  * If you [Require Import Omega.] then you can use the "omega"
    tactic to solve some arithmetic questions.

  * You will want to define a comparison operation for arithmetic
    expressions.  The natural thing to write is something like:

       eq_aexp : aexp -> aexp -> bool

    but you will then need to prove that this is actually correct
    i.e., (eq_aexp a1 a2 = true) <-> (a1 = a2).

    An alternative is to define something like:

      eq_aexp_dec : forall (a1 a2:aexp), {a1 = a2} + {a1<>a2}.

    and instead of trying to build it using explicit code, use
    the "decide quality" tactic (two words.)  For instance:

    Definition eq_aexp_dec (a1 a2:aexp) : {a1=a2} + {a1<>a2}.
      decide quality.
      apply (eq_nat_dec n n0).
      apply (string_dec v v0).
      decide equality.
    Defined.

    This tactic will take an inductive definition and try to
    build the decidable equality term for you.  In the example
    above, I had to tell it how to decide quality for some of
    the types used within the definition (nats, strings, and
    binops.)

  * You may also find the tactic:

       replace (<exp1>) with (<exp2>)

    useful.  As suggested, it lets you replace occurrences of
    one expression with another.  It leaves you with two goals:
    The first is the original goal with the substitution performed.
    The second is a requirement to prove <exp1> = <exp2>.

  * My solution for this whole file (not including these comments)
    is about 400 lines of code.  Yours will be much, much bigger
    unless you use a lot of automation.

*)


From Hammer Require Import Hammer.

Require Import Sumbool.
Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Ranalysis1.
Local Open Scope R_scope.

Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
match N with
| O => x
| S n =>
let down := Dichotomy_lb x y P n in
let up := Dichotomy_ub x y P n in
let z := (down + up) / 2 in if P z then down else z
end

with Dichotomy_ub (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
match N with
| O => y
| S n =>
let down := Dichotomy_lb x y P n in
let up := Dichotomy_ub x y P n in
let z := (down + up) / 2 in if P z then z else up
end.

Definition dicho_lb (x y:R) (P:R -> bool) (N:nat) : R := Dichotomy_lb x y P N.
Definition dicho_up (x y:R) (P:R -> bool) (N:nat) : R := Dichotomy_ub x y P N.

Lemma dicho_comp :
forall (x y:R) (P:R -> bool) (n:nat),
x <= y -> dicho_lb x y P n <= dicho_up x y P n.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_comp".
intros.
induction  n as [| n Hrecn].
simpl; assumption.
simpl.
case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
unfold Rdiv; apply Rmult_le_reg_l with 2.
prove_sup0.
pattern 2 at 1; rewrite Rmult_comm.
rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
rewrite Rmult_1_r.
rewrite double.
apply Rplus_le_compat_l.
assumption.
unfold Rdiv; apply Rmult_le_reg_l with 2.
prove_sup0.
rewrite Rmult_comm.
rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
rewrite Rmult_1_r.
rewrite double.
rewrite <- (Rplus_comm (Dichotomy_ub x y P n)).
apply Rplus_le_compat_l.
assumption.
Qed.

Lemma dicho_lb_growing :
forall (x y:R) (P:R -> bool), x <= y -> Un_growing (dicho_lb x y P).
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_lb_growing".
intros.
unfold Un_growing.
intro.
simpl.
case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
right; reflexivity.
unfold Rdiv; apply Rmult_le_reg_l with 2.
prove_sup0.
pattern 2 at 1; rewrite Rmult_comm.
rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
rewrite Rmult_1_r.
rewrite double.
apply Rplus_le_compat_l.
replace (Dichotomy_ub x y P n) with (dicho_up x y P n);
[ apply dicho_comp; assumption | reflexivity ].
Qed.

Lemma dicho_up_decreasing :
forall (x y:R) (P:R -> bool), x <= y -> Un_decreasing (dicho_up x y P).
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_up_decreasing".
intros.
unfold Un_decreasing.
intro.
simpl.
case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
unfold Rdiv; apply Rmult_le_reg_l with 2.
prove_sup0.
rewrite Rmult_comm.
rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
rewrite Rmult_1_r.
rewrite double.
replace (Dichotomy_ub x y P n) with (dicho_up x y P n);
[ idtac | reflexivity ].
replace (Dichotomy_lb x y P n) with (dicho_lb x y P n);
[ idtac | reflexivity ].
rewrite <- (Rplus_comm (dicho_up x y P n)).
apply Rplus_le_compat_l.
apply dicho_comp; assumption.
right; reflexivity.
Qed.

Lemma dicho_lb_maj_y :
forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, dicho_lb x y P n <= y.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_lb_maj_y".
intros.
induction  n as [| n Hrecn].
simpl; assumption.
simpl.
case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
assumption.
unfold Rdiv; apply Rmult_le_reg_l with 2.
prove_sup0.
rewrite Rmult_comm.
rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
rewrite double; apply Rplus_le_compat.
assumption.
pattern y at 2; replace y with (Dichotomy_ub x y P 0);
[ idtac | reflexivity ].
apply decreasing_prop.
assert (H0 := dicho_up_decreasing x y P H).
assumption.
apply le_O_n.
Qed.

Lemma dicho_lb_maj :
forall (x y:R) (P:R -> bool), x <= y -> has_ub (dicho_lb x y P).
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_lb_maj".
intros.
cut (forall n:nat, dicho_lb x y P n <= y).
intro.
unfold has_ub.
unfold bound.
exists y.
unfold is_upper_bound.
intros.
elim H1; intros.
rewrite H2; apply H0.
apply dicho_lb_maj_y; assumption.
Qed.

Lemma dicho_up_min_x :
forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, x <= dicho_up x y P n.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_up_min_x".
intros.
induction  n as [| n Hrecn].
simpl; assumption.
simpl.
case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
unfold Rdiv; apply Rmult_le_reg_l with 2.
prove_sup0.
pattern 2 at 1; rewrite Rmult_comm.
rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
rewrite double; apply Rplus_le_compat.
pattern x at 1; replace x with (Dichotomy_lb x y P 0);
[ idtac | reflexivity ].
apply tech9.
assert (H0 := dicho_lb_growing x y P H).
assumption.
apply le_O_n.
assumption.
assumption.
Qed.

Lemma dicho_up_min :
forall (x y:R) (P:R -> bool), x <= y -> has_lb (dicho_up x y P).
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_up_min".
intros.
cut (forall n:nat, x <= dicho_up x y P n).
intro.
unfold has_lb.
unfold bound.
exists (- x).
unfold is_upper_bound.
intros.
elim H1; intros.
rewrite H2.
unfold opp_seq.
apply Ropp_le_contravar.
apply H0.
apply dicho_up_min_x; assumption.
Qed.

Lemma dicho_lb_cv :
forall (x y:R) (P:R -> bool),
x <= y -> { l:R | Un_cv (dicho_lb x y P) l }.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_lb_cv".
intros.
apply growing_cv.
apply dicho_lb_growing; assumption.
apply dicho_lb_maj; assumption.
Qed.

Lemma dicho_up_cv :
forall (x y:R) (P:R -> bool),
x <= y -> { l:R | Un_cv (dicho_up x y P) l }.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_up_cv".
intros.
apply decreasing_cv.
apply dicho_up_decreasing; assumption.
apply dicho_up_min; assumption.
Qed.

Lemma dicho_lb_dicho_up :
forall (x y:R) (P:R -> bool) (n:nat),
x <= y -> dicho_up x y P n - dicho_lb x y P n = (y - x) / 2 ^ n.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_lb_dicho_up".
intros.
induction  n as [| n Hrecn].
simpl.
unfold Rdiv; rewrite Rinv_1; ring.
simpl.
case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
unfold Rdiv.
replace
((Dichotomy_lb x y P n + Dichotomy_ub x y P n) * / 2 - Dichotomy_lb x y P n)
with ((dicho_up x y P n - dicho_lb x y P n) / 2).
unfold Rdiv; rewrite Hrecn.
unfold Rdiv.
rewrite Rinv_mult_distr.
ring.
discrR.
apply pow_nonzero; discrR.
pattern (Dichotomy_lb x y P n) at 2;
rewrite (double_var (Dichotomy_lb x y P n));
unfold dicho_up, dicho_lb, Rminus, Rdiv; ring.
replace
(Dichotomy_ub x y P n - (Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)
with ((dicho_up x y P n - dicho_lb x y P n) / 2).
unfold Rdiv; rewrite Hrecn.
unfold Rdiv.
rewrite Rinv_mult_distr.
ring.
discrR.
apply pow_nonzero; discrR.
pattern (Dichotomy_ub x y P n) at 1;
rewrite (double_var (Dichotomy_ub x y P n));
unfold dicho_up, dicho_lb, Rminus, Rdiv; ring.
Qed.

Definition pow_2_n (n:nat) := 2 ^ n.

Lemma pow_2_n_neq_R0 : forall n:nat, pow_2_n n <> 0.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.pow_2_n_neq_R0".
intro.
unfold pow_2_n.
apply pow_nonzero.
discrR.
Qed.

Lemma pow_2_n_growing : Un_growing pow_2_n.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.pow_2_n_growing".
unfold Un_growing.
intro.
replace (S n) with (n + 1)%nat;
[ unfold pow_2_n; rewrite pow_add | ring ].
pattern (2 ^ n) at 1; rewrite <- Rmult_1_r.
apply Rmult_le_compat_l.
left; apply pow_lt; prove_sup0.
simpl.
rewrite Rmult_1_r.
pattern 1 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
apply Rlt_0_1.
Qed.

Lemma pow_2_n_infty : cv_infty pow_2_n.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.pow_2_n_infty".
cut (forall N:nat, INR N <= 2 ^ N).
intros.
unfold cv_infty.
intro.
destruct (total_order_T 0 M) as [[Hlt|<-]|Hgt].
set (N := up M).
cut (0 <= N)%Z.
intro.
elim (IZN N H0); intros N0 H1.
exists N0.
intros.
apply Rlt_le_trans with (INR N0).
rewrite INR_IZR_INZ.
rewrite <- H1.
unfold N.
assert (H3 := archimed M).
elim H3; intros; assumption.
apply Rle_trans with (pow_2_n N0).
unfold pow_2_n; apply H.
apply Rge_le.
apply growing_prop.
apply pow_2_n_growing.
assumption.
apply le_IZR.
unfold N.
simpl.
assert (H0 := archimed M); elim H0; intros.
left; apply Rlt_trans with M; assumption.
exists 0%nat; intros.
unfold pow_2_n; apply pow_lt; prove_sup0.
exists 0%nat; intros.
apply Rlt_trans with 0.
assumption.
unfold pow_2_n; apply pow_lt; prove_sup0.
simple induction N.
simpl.
left; apply Rlt_0_1.
intros.
pattern (S n) at 2; replace (S n) with (n + 1)%nat; [ idtac | ring ].
rewrite S_INR; rewrite pow_add.
simpl.
rewrite Rmult_1_r.
apply Rle_trans with (2 ^ n).
rewrite <- (Rplus_comm 1).
rewrite <- (Rmult_1_r (INR n)).
apply (poly n 1).
apply Rlt_0_1.
pattern (2 ^ n) at 1; rewrite <- Rplus_0_r.
rewrite <- (Rmult_comm 2).
rewrite double.
apply Rplus_le_compat_l.
left; apply pow_lt; prove_sup0.
Qed.

Lemma cv_dicho :
forall (x y l1 l2:R) (P:R -> bool),
x <= y ->
Un_cv (dicho_lb x y P) l1 -> Un_cv (dicho_up x y P) l2 -> l1 = l2.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.cv_dicho".
intros.
assert (H2 := CV_minus _ _ _ _ H0 H1).
cut (Un_cv (fun i:nat => dicho_lb x y P i - dicho_up x y P i) 0).
intro.
assert (H4 := UL_sequence _ _ _ H2 H3).
symmetry ; apply Rminus_diag_uniq_sym; assumption.
unfold Un_cv; unfold R_dist.
intros.
assert (H4 := cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
destruct (total_order_T x y) as [[ Hlt | -> ]|Hgt].
unfold Un_cv in H4; unfold R_dist in H4.
cut (0 < y - x).
intro Hyp.
cut (0 < eps / (y - x)).
intro.
elim (H4 (eps / (y - x)) H5); intros N H6.
exists N; intros.
replace (dicho_lb x y P n - dicho_up x y P n - 0) with
(dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ].
rewrite <- Rabs_Ropp.
rewrite Ropp_minus_distr'.
rewrite dicho_lb_dicho_up.
unfold Rdiv; rewrite Rabs_mult.
rewrite (Rabs_right (y - x)).
apply Rmult_lt_reg_l with (/ (y - x)).
apply Rinv_0_lt_compat; assumption.
rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_l.
replace (/ 2 ^ n) with (/ 2 ^ n - 0);
[ unfold pow_2_n, Rdiv in H6; rewrite <- (Rmult_comm eps); apply H6;
assumption
| ring ].
red; intro; rewrite H8 in Hyp; elim (Rlt_irrefl _ Hyp).
apply Rle_ge.
apply Rplus_le_reg_l with x; rewrite Rplus_0_r.
replace (x + (y - x)) with y; [ assumption | ring ].
assumption.
unfold Rdiv; apply Rmult_lt_0_compat;
[ assumption | apply Rinv_0_lt_compat; assumption ].
apply Rplus_lt_reg_l with x; rewrite Rplus_0_r.
replace (x + (y - x)) with y; [ assumption | ring ].
exists 0%nat; intros.
replace (dicho_lb y y P n - dicho_up y y P n - 0) with
(dicho_lb y y P n - dicho_up y y P n); [ idtac | ring ].
rewrite <- Rabs_Ropp.
rewrite Ropp_minus_distr'.
rewrite dicho_lb_dicho_up.
unfold Rminus, Rdiv; rewrite Rplus_opp_r; rewrite Rmult_0_l;
rewrite Rabs_R0; assumption.
assumption.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
Qed.

Definition cond_positivity (x:R) : bool :=
match Rle_dec 0 x with
| left _ => true
| right _ => false
end.

Lemma continuity_seq :
forall (f:R -> R) (Un:nat -> R) (l:R),
continuity_pt f l -> Un_cv Un l -> Un_cv (fun i:nat => f (Un i)) (f l).
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.continuity_seq".
unfold continuity_pt, Un_cv; unfold continue_in.
unfold limit1_in.
unfold limit_in.
unfold dist.
simpl.
unfold R_dist.
intros.
elim (H eps H1); intros alp H2.
elim H2; intros.
elim (H0 alp H3); intros N H5.
exists N; intros.
case (Req_dec (Un n) l); intro.
rewrite H7; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
assumption.
apply H4.
split.
unfold D_x, no_cond.
split.
trivial.
apply (not_eq_sym (A:=R)); assumption.
apply H5; assumption.
Qed.

Lemma dicho_lb_car :
forall (x y:R) (P:R -> bool) (n:nat),
P x = false -> P (dicho_lb x y P n) = false.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_lb_car".
intros.
induction n as [| n Hrecn].
- assumption.
- simpl.
destruct
(sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))) as [Heq|Heq].
+ rewrite Heq.
unfold dicho_lb in Hrecn; assumption.
+ rewrite Heq.
assumption.
Qed.

Lemma dicho_up_car :
forall (x y:R) (P:R -> bool) (n:nat),
P y = true -> P (dicho_up x y P n) = true.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.dicho_up_car".
intros.
induction n as [| n Hrecn].
- assumption.
- simpl.
destruct
(sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))) as [Heq|Heq].
+ rewrite Heq.
unfold dicho_lb in Hrecn; assumption.
+ rewrite  Heq.
assumption.
Qed.

Lemma cv_pow_half : forall a, Un_cv (fun n => a/2^n) 0.
intros a; unfold Rdiv; replace 0 with (a * 0) by ring.
apply CV_mult.
intros eps ep; exists 0%nat; rewrite R_dist_eq; intros n _; assumption.
exact (cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
Qed.

Lemma IVT :
forall (f:R -> R) (x y:R),
continuity f ->
x < y -> f x < 0 -> 0 < f y -> { z:R | x <= z <= y /\ f z = 0 }.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.IVT".
intros.
assert (x <= y) by (left; assumption).
destruct (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3) as (x1,p0).
destruct (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3) as (x0,p).
assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
rewrite H4 in p0.
exists x0.
split.
split.
apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0).
simpl.
right; reflexivity.
apply growing_ineq.
apply dicho_lb_growing; assumption.
assumption.
apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0).
apply decreasing_ineq.
apply dicho_up_decreasing; assumption.
assumption.
right; reflexivity.
set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n).
set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n).
cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0).
cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0).
intros.
cut (forall n:nat, f (Vn n) <= 0).
cut (forall n:nat, 0 <= f (Wn n)).
intros.
assert (H9 := H6 H8).
assert (H10 := H5 H7).
apply Rle_antisym; assumption.
intro.
unfold Wn.
cut (forall z:R, cond_positivity z = true <-> 0 <= z).
intro.
assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n).
elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros.
apply H9.
apply H8.
elim (H7 (f y)); intros.
apply H12.
left; assumption.
intro.
unfold cond_positivity.
case (Rle_dec 0 z) as [Hle|Hnle].
split.
intro; assumption.
intro; reflexivity.
split.
intro feqt;discriminate feqt.
intro.
contradiction.
unfold Vn.
cut (forall z:R, cond_positivity z = false <-> z < 0).
intros.
assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n).
left.
elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros.
apply H9.
apply H8.
elim (H7 (f x)); intros.
apply H12.
assumption.
intro.
unfold cond_positivity.
case (Rle_dec 0 z) as [Hle|Hnle].
split.
intro feqt; discriminate feqt.
intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H7)).
split.
intro; auto with real.
intro; reflexivity.
cut (Un_cv Wn x0).
intros.
assert (H7 := continuity_seq f Wn x0 (H x0) H5).
destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt].
left; assumption.
right; reflexivity.
unfold Un_cv in H7; unfold R_dist in H7.
cut (0 < - f x0).
intro.
elim (H7 (- f x0) H8); intros.
cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ].
assert (H11 := H9 x2 H10).
rewrite Rabs_right in H11.
pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
assert (H12 := Rplus_lt_reg_l _ _ _ H11).
assert (H13 := H6 x2).
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
apply Rle_ge; left; unfold Rminus; apply Rplus_le_lt_0_compat.
apply H6.
exact H8.
apply Ropp_0_gt_lt_contravar; assumption.
unfold Wn; assumption.
cut (Un_cv Vn x0).
intros.
assert (H7 := continuity_seq f Vn x0 (H x0) H5).
destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt].
unfold Un_cv in H7; unfold R_dist in H7.
elim (H7 (f x0) Hlt); intros.
cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ].
assert (H10 := H8 x2 H9).
rewrite Rabs_left in H10.
pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
rewrite Ropp_minus_distr' in H10.
unfold Rminus in H10.
assert (H11 := Rplus_lt_reg_l _ _ _ H10).
assert (H12 := H6 x2).
cut (0 < f (Vn x2)).
intro.
elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
rewrite <- (Ropp_involutive (f (Vn x2))).
apply Ropp_0_gt_lt_contravar; assumption.
apply Rplus_lt_reg_l with (f x0 - f (Vn x2)).
rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
[ unfold Rminus; apply Rplus_lt_le_0_compat | ring ].
assumption.
apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
right; reflexivity.
left; assumption.
unfold Vn; assumption.
Qed.

Lemma IVT_cor :
forall (f:R -> R) (x y:R),
continuity f ->
x <= y -> f x * f y <= 0 -> { z:R | x <= z <= y /\ f z = 0 }.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.IVT_cor".
intros.
destruct (total_order_T 0 (f x)) as [[Hltx|Heqx]|Hgtx].
destruct (total_order_T 0 (f y)) as [[Hlty|Heqy]|Hgty].
cut (0 < f x * f y);
[ intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 H2))
| apply Rmult_lt_0_compat; assumption ].
exists y.
split.
split; [ assumption | right; reflexivity ].
symmetry ; exact Heqy.
cut (x < y).
intro.
assert (H3 := IVT (- f)%F x y (continuity_opp f H) H2).
cut ((- f)%F x < 0).
cut (0 < (- f)%F y).
intros.
destruct (H3 H5 H4) as (x0,[]).
exists x0.
split.
assumption.
unfold opp_fct in H7.
rewrite <- (Ropp_involutive (f x0)).
apply Ropp_eq_0_compat; assumption.
unfold opp_fct; apply Ropp_0_gt_lt_contravar; assumption.
unfold opp_fct.
apply Rplus_lt_reg_l with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r;
assumption.
inversion H0.
assumption.
rewrite H2 in Hltx.
elim (Rlt_irrefl _ (Rlt_trans _ _ _ Hgty Hltx)).
exists x.
split.
split; [ right; reflexivity | assumption ].
symmetry ; assumption.
destruct (total_order_T 0 (f y)) as [[Hlty|Heqy]|Hgty].
cut (x < y).
intro.
apply IVT; assumption.
inversion H0.
assumption.
rewrite H2 in Hgtx.
elim (Rlt_irrefl _ (Rlt_trans _ _ _ Hlty Hgtx)).
exists y.
split.
split; [ assumption | right; reflexivity ].
symmetry ; assumption.
cut (0 < f x * f y).
intro.
elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H2 H1)).
rewrite <- Rmult_opp_opp; apply Rmult_lt_0_compat;
apply Ropp_0_gt_lt_contravar; assumption.
Qed.

Lemma Rsqrt_exists :
forall y:R, 0 <= y -> { z:R | 0 <= z /\ y = Rsqr z }.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.Rsqrt_exists".
intros.
set (f := fun x:R => Rsqr x - y).
cut (f 0 <= 0).
intro.
cut (continuity f).
intro.
destruct (total_order_T y 1) as [[Hlt| -> ]|Hgt].
cut (0 <= f 1).
intro.
cut (f 0 * f 1 <= 0).
intro.
assert (X := IVT_cor f 0 1 H1 (Rlt_le _ _ Rlt_0_1) H3).
elim X; intros t H4.
exists t.
elim H4; intros.
split.
elim H5; intros; assumption.
unfold f in H6.
apply Rminus_diag_uniq_sym; exact H6.
rewrite Rmult_comm; pattern 0 at 2; rewrite <- (Rmult_0_r (f 1)).
apply Rmult_le_compat_l; assumption.
unfold f.
rewrite Rsqr_1.
apply Rplus_le_reg_l with y.
rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus;
rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
left; assumption.
exists 1.
split.
left; apply Rlt_0_1.
symmetry; apply Rsqr_1.
cut (0 <= f y).
intro.
cut (f 0 * f y <= 0).
intro.
assert (X := IVT_cor f 0 y H1 H H3).
elim X; intros t H4.
exists t.
elim H4; intros.
split.
elim H5; intros; assumption.
unfold f in H6.
apply Rminus_diag_uniq_sym; exact H6.
rewrite Rmult_comm; pattern 0 at 2; rewrite <- (Rmult_0_r (f y)).
apply Rmult_le_compat_l; assumption.
unfold f.
apply Rplus_le_reg_l with y.
rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus;
rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
pattern y at 1; rewrite <- Rmult_1_r.
unfold Rsqr; apply Rmult_le_compat_l.
assumption.
left; exact Hgt.
replace f with (Rsqr - fct_cte y)%F.
apply continuity_minus.
apply derivable_continuous; apply derivable_Rsqr.
apply derivable_continuous; apply derivable_const.
reflexivity.
unfold f; rewrite Rsqr_0.
unfold Rminus; rewrite Rplus_0_l.
apply Rge_le.
apply Ropp_0_le_ge_contravar; assumption.
Qed.

Definition Rsqrt (y:nonnegreal) : R :=
let (a,_) := Rsqrt_exists (nonneg y) (cond_nonneg y) in a.

Lemma Rsqrt_positivity : forall x:nonnegreal, 0 <= Rsqrt x.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.Rsqrt_positivity".
intro.
destruct (Rsqrt_exists (nonneg x) (cond_nonneg x)) as (x0 & H1 & H2).
cut (x0 = Rsqrt x).
intros.
rewrite <- H; assumption.
unfold Rsqrt.
case (Rsqrt_exists x (cond_nonneg x)) as (?,[]).
apply Rsqr_inj.
assumption.
assumption.
rewrite <- H0, <- H2; reflexivity.
Qed.

Lemma Rsqrt_Rsqrt : forall x:nonnegreal, Rsqrt x * Rsqrt x = x.
Proof. hammer_hook "Rsqrt_def" "Rsqrt_def.Rsqrt_Rsqrt".
intros.
destruct (Rsqrt_exists (nonneg x) (cond_nonneg x)) as (x0 & H1 & H2).
cut (x0 = Rsqrt x).
intros.
rewrite <- H.
rewrite H2; reflexivity.
unfold Rsqrt.
case (Rsqrt_exists x (cond_nonneg x)) as (x1 & ? & ?).
apply Rsqr_inj.
assumption.
assumption.
rewrite <- H0, <- H2; reflexivity.
Qed.


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

Require Import Arith Lia.

Set Implicit Arguments.

Set Default Proof Using "Type".

Section nat_rev_ind.

  (* A reverse recursion principle *)

  Variables (P : nat -> Prop)
            (HP : forall n, P (S n) -> P n).

  Theorem nat_rev_ind x y : x <= y -> P y -> P x.
  Proof using HP. induction 1; auto. Qed.

End nat_rev_ind.

Section nat_rev_ind'.

  (* A reverse recursion principle *)

  Variables (P : nat -> Prop) (k : nat)
            (HP : forall n, n < k -> P (S n) -> P n).

  Theorem nat_rev_ind' x y : x <= y <= k -> P y -> P x.
  Proof using HP.
    intros H1 H2.
    set (Q n := n <= k /\ P n).
    assert (forall x y, x <= y -> Q y -> Q x) as H.
      apply nat_rev_ind.
      intros n (H3 & H4); split.
      lia.
      revert H4; apply HP, H3.
    apply (H x y).
    lia.
    split; auto; lia.
  Qed.

End nat_rev_ind'.

Section minimizer_pred.

  Variable (P : nat -> Prop)
           (HP : forall p: { n | P n \/ ~ P n }, { P (proj1_sig p) } + { ~ P (proj1_sig p) }).

  Definition minimizer n := P n /\ forall i, i < n -> ~ P i.

  Inductive bar n : Prop :=
    | in_bar_0 : P n -> bar n
    | in_bar_1 : ~ P n -> bar (S n) -> bar n.

  Let bar_ex n : bar n -> P n \/ ~ P n.
  Proof. induction 1; auto. Qed.

  Let loop : forall n, bar n -> { k | P k /\ forall i, n <= i < k -> ~ P i }.
  Proof.
    refine (fix loop n Hn { struct Hn } := match HP (exist _ n (bar_ex Hn)) with
      | left H => exist _ n _
      | right H => match loop (S n) _ with
        | exist _ k Hk => exist _ k _
      end
    end).
    * split; auto; intros; lia.
    * destruct Hn; [ destruct H | ]; assumption.
    * destruct Hk as (H1 & H2).
      split; trivial; intros i Hi.
      destruct (eq_nat_dec i n).
      - subst; trivial.
      - apply H2; lia.
  Qed.

  Hypothesis Hmin : ex minimizer.

  Let bar_0 : bar 0.
  Proof.
    destruct Hmin as (k & H1 & H2).
    apply in_bar_0 in H1.
    clear HP.
    revert H1.
    apply nat_rev_ind' with (k := k).
    intros i H3.
    apply in_bar_1, H2; trivial.
    lia.
  Qed.

  Definition minimizer_pred : sig minimizer.
  Proof using Hmin loop.
    destruct (loop bar_0) as (k & H1 & H2).
    exists k; split; auto.
    intros; apply H2; lia.
  Defined.

End minimizer_pred.

(* Check minimizer_pred. *)
(* Print Assumptions minimizer_pred. *)

(* (* Let P be a computable predicate: *)
(*       - whenever P n has a value (P n or not P n) then that value can be computed *)
(*     Then minimizer P is computable as well: *)
(*       - whenever minimizer P holds for some n, then such an n can be computed *)
(*  *) *)

(* Corollary minimizer_alt (P : nat -> Prop) : *)
(*     (forall n, P n \/ ~ P n -> { P n } + { ~ P n }) -> ex (minimizer P) -> sig (minimizer P). *)
(* Proof. *)
(*   intro H; apply minimizer_pred. *)
(*   intros (n & Hn); apply H, Hn. *)
(* Defined. *)

(* Check minimizer_alt. *)
(* Print Assumptions minimizer_alt. *)

(* Section minimizer. *)

(*   Variable (R : nat -> nat -> Prop) *)
(*            (Rfun : forall n u v, R n u -> R n v -> u = v) *)
(*            (HR : forall n, ex (R n) -> sig (R n)). *)

(*   Definition minimizer' n := R n 0 /\ forall i, i < n -> exists u, R i (S u). *)

(*   Fact minimizer_fun n m : minimizer' n -> minimizer' m -> n = m. *)
(*   Proof. *)
(*     intros (H1 & H2) (H3 & H4). *)
(*     destruct (lt_eq_lt_dec n m) as [ [ H | ] | H ]; auto;  *)
(*       [ apply H4 in H | apply H2 in H ]; destruct H as (u & Hu); *)
(*       [ generalize (Rfun H1 Hu) | generalize (Rfun H3 Hu) ]; discriminate. *)
(*   Qed.  *)

(*   Inductive bar n : Prop := *)
(*     | in_bar_0 : R n 0 -> bar n *)
(*     | in_bar_1 : (exists u, R n (S u)) -> bar (S n) -> bar n. *)

(*   Let bar_ex n : bar n -> ex (R n). *)
(*   Proof. *)
(*     induction 1 as [ n Hn | n (k & Hk) _ _ ]. *)
(*     exists 0; auto. *)
(*     exists (S k); trivial. *)
(*   Qed. *)

(*   Let loop : forall n, bar n -> { k | R k 0 /\ forall i, n <= i < k -> exists u, R i (S u) }. *)
(*   Proof. *)
(*     refine (fix loop n Hn { struct Hn } := match HR (bar_ex Hn) with *)
(*         | exist _ u Hu => match u as m return R _ m -> _ with *)
(*             | 0   => fun H => exist _ n _ *)
(*             | S v => fun H => match loop (S n) _ with *)
(*                 | exist _ k Hk => exist _ k _ *)
(*               end *)
(*           end Hu *)
(*       end). *)
(*     * split; auto; intros; lia. *)
(*     * destruct Hn as [ Hn | ]; trivial; exfalso; generalize (Rfun H Hn); discriminate. *)
(*     * destruct Hk as (H1 & H2); split; trivial; intros i Hi. *)
(*       destruct (eq_nat_dec i n). *)
(*       - subst; exists v; trivial. *)
(*       - apply H2; lia. *)
(*   Qed. *)

(*   Hypothesis Hmin : ex minimizer. *)

(*   Let bar_0 : bar 0. *)
(*   Proof. *)
(*     destruct Hmin as (k & H1 & H2). *)
(*     apply in_bar_0 in H1. *)
(*     clear Hmin HR. *)
(*     revert H1. *)
(*     apply nat_rev_ind' with (k := k). *)
(*     intros i H3. *)
(*     apply in_bar_1, H2; trivial. *)
(*     lia. *)
(*   Qed. *)

(*   Definition minimizer_coq : sig minimizer. *)
(*   Proof. *)
(*     destruct (loop bar_0) as (k & H1 & H2). *)
(*     exists k; split; auto. *)
(*     intros; apply H2; lia. *)
(*   Defined. *)

(* End minimizer. *)

(* Check minimizer_coq. *)
(* Print Assumptions minimizer_coq. *)

(* Extraction "minimizer.ml" minimizer_coq. *)


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

Require Import Arith Lia List Permutation.
Require Vector.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos.

Set Implicit Arguments.
Set Default Goal Selector "!".

Notation vec_nil := (@Vector.nil _).
Notation "x ## v" := (@Vector.cons _ x _ v) (at level 60, right associativity).

Section vector.

  Variable X : Type.

  Notation vec := (@Vector.t X).

(* @DLW: former definition

  Inductive vec : nat -> Type :=
    | vec_nil  : vec 0
    | vec_cons : forall n, X -> vec n -> vec (S n).
*)

  Let vec_decomp_type n :=
    match n with
      | 0   => Prop
      | S n => (X * vec n)%type
    end.

  Definition vec_decomp n (v : vec n) :=
    match v in Vector.t _ k return vec_decomp_type k with
      | vec_nil => False
      | x ## v  => (x,v)
    end.

  Definition vec_head n (v : vec (S n)) := match v with x ## _ => x end.
  Definition vec_tail n (v : vec (S n)) := match v with _ ## w => w end.

  Let vec_head_tail_type n : vec n -> Prop :=
    match n with
      | 0   => fun v => v = vec_nil
      | S n => fun v => v = vec_head v ## vec_tail v
    end.

  Let vec_head_tail_prop n v :  @vec_head_tail_type n v.
  Proof. induction v; simpl; auto. Qed.

  Fact vec_0_nil (v : vec 0) : v = vec_nil.
  Proof. apply (vec_head_tail_prop v). Qed.

  Fact vec_head_tail n (v : vec (S n)) : v = vec_head v ## vec_tail v.
  Proof. apply (vec_head_tail_prop v). Qed.

  Fact vec_cons_inv n x y (v w : vec n) : x ## v = y ## w -> x = y /\ v = w.
  Proof.
    intros H1; generalize H1; intros H2.
    apply f_equal with (f := @vec_head _) in H1.
    apply f_equal with (f := @vec_tail _) in H2.
    auto.
  Qed.

  Fixpoint vec_pos n (v : vec n) : pos n -> X.
  Proof.
    refine (match v with
      | vec_nil => fun p => _
      | x ## v => fun p => _
    end); invert pos p.
    + exact x.
    + exact (vec_pos _ v p).
  Defined.

  Fact vec_pos0 n (v : vec (S n)) : vec_pos v pos0 = vec_head v.
  Proof.
    rewrite (vec_head_tail v).
    reflexivity.
  Qed.

  Fact vec_pos_tail n (v : vec (S n)) p : vec_pos (vec_tail v) p = vec_pos v (pos_nxt p).
  Proof.
    rewrite vec_head_tail at 2; simpl; auto.
  Qed.

  Fact vec_pos1 n (v : vec (S (S n))) : vec_pos v pos1 = vec_head (vec_tail v).
  Proof.
    rewrite <- vec_pos0, vec_pos_tail; auto.
  Qed.

  Fact vec_pos_ext n (v w : vec n) : (forall p, vec_pos v p = vec_pos w p) -> v = w.
  Proof.
    revert v w; induction n as [ | n IHn ]; intros v w H.
    1: rewrite (vec_0_nil v), (vec_0_nil w); auto.
    revert H; rewrite (vec_head_tail v), (vec_head_tail w); f_equal.
    intros H; f_equal.
    + apply (H pos0).
    + apply IHn.
      intros p; apply (H (pos_nxt p)).
  Qed.

  Fixpoint vec_set_pos n : (pos n -> X) -> vec n :=
    match n return (pos n -> X) -> vec n with
      | 0   => fun _ => vec_nil
      | S n => fun g => g pos0 ## vec_set_pos (fun p => g (pos_nxt p))
    end.

  Fact vec_pos_set n (g : pos n -> X) p : vec_pos (vec_set_pos g) p = g p.
  Proof.
    revert g p; induction n as [ | n IHn ]; intros g p; pos_inv p; auto.
    apply IHn.
  Qed.

  Fixpoint vec_change n (v : vec n) : pos n -> X -> vec n.
  Proof.
    refine (match v with
      | vec_nil => fun _ _ => vec_nil
      | y ## v  => fun p x => _
    end).
    pos_inv p.
    + exact (x ## v).
    + exact (y ## vec_change _ v p x).
  Defined.

  Fact vec_change_eq n v p q x : p = q -> vec_pos (@vec_change n v p x) q = x.
  Proof.
    intro; subst q; revert p x.
    induction v; intros p ?; invert pos p; auto.
  Qed.

  Fact vec_change_neq n v p q x : p <> q -> vec_pos (@vec_change n v p x) q = vec_pos v q.
  Proof.
    revert p q x.
    induction v as [ | n y v IH ]; intros p q x H; invert pos p; invert pos q; auto.
    + destruct H; auto.
    + apply IH; contradict H; subst; auto.
  Qed.

  Fact vec_change_idem n v p x y : vec_change (@vec_change n v p x) p y = vec_change v p y.
  Proof.
    apply vec_pos_ext; intros q.
    destruct (pos_eq_dec p q).
    + repeat rewrite vec_change_eq; auto.
    + repeat rewrite vec_change_neq; auto.
  Qed.

  Fact vec_change_same n v p : @vec_change n v p (vec_pos v p) = v.
  Proof.
    apply vec_pos_ext; intros q.
    destruct (pos_eq_dec p q).
    + repeat rewrite vec_change_eq; subst; auto.
    + repeat rewrite vec_change_neq; auto.
  Qed.

  Section vec_eq_dec_pos.

    Fixpoint vec_eq_dec_pos n (u v : vec n) { struct u } :
         (forall p, { vec_pos u p = vec_pos v p } + { vec_pos u p <> vec_pos v p })
      -> { u = v } + { u <> v }.
    Proof.
      destruct u as [ | x n u ].
      + rewrite (vec_0_nil v); left; reflexivity.
      + rewrite (vec_head_tail v); generalize (vec_head v) (vec_tail v); intros y w H.
        destruct (H pos0) as [ G1 | G1 ]; simpl vec_pos in G1; subst.
        2:{ right; contradict G1; apply vec_cons_inv in G1; tauto. }
        destruct (vec_eq_dec_pos _ u w) as [ G2 | G2 ]; subst.
        * intros p; apply (H (pos_nxt p)).
        * left; reflexivity.
        * right; contradict G2; apply vec_cons_inv in G2; tauto.
    Qed.

  End vec_eq_dec_pos.

  Variable eq_X_dec : forall x y : X, { x = y } + { x <> y }.

  Fact vec_eq_dec n (u v : vec n) : { u = v } + { u <> v }.
  Proof using eq_X_dec. apply vec_eq_dec_pos; auto. Qed.

  Fixpoint vec_list n (v : vec n) :=
    match v with
      | vec_nil => nil
      | x ## v  => x::vec_list v
    end.

  Fact vec_list_In n v p : In (vec_pos v p) (@vec_list n v).
  Proof.
    revert p; induction v; intros p; invert pos p; auto.
  Qed.

  Fact vec_list_vec_set_pos n f : vec_list (@vec_set_pos n f) = map f (pos_list n).
  Proof.
    revert f; induction n as [ | n IHn ]; intros f; simpl; f_equal; auto.
    rewrite IHn, map_map; auto.
  Qed.

  Fact map_pos_list_vec n f : map f (pos_list n) = vec_list (@vec_set_pos n f).
  Proof. rewrite vec_list_vec_set_pos; auto. Qed.

  Fact vec_list_length n v : length (@vec_list n v) = n.
  Proof. induction v; simpl; f_equal; auto. Defined.

  Fixpoint list_vec (l : list X) : vec (length l) :=
    match l with
      | nil  => vec_nil
      | x::l => x ## list_vec l
    end.

  Fact list_vec_iso l : vec_list (list_vec l) = l.
  Proof. induction l; simpl; f_equal; auto. Qed.

  (* The other part needs a transport *)

  Fact vec_list_iso n v : list_vec (@vec_list n v) = eq_rect_r _ v (vec_list_length v).
  Proof.
    induction v; simpl; f_equal; auto.
    rewrite IHv; unfold eq_rect_r; simpl.
    generalize (length (vec_list v)) (vec_list_length v).
    intros; subst; cbv; auto.
  Qed.

  Definition list_vec_full l : { v : vec (length l) | vec_list v = l }.
  Proof. exists (list_vec l); apply list_vec_iso. Qed.

  Fact vec_list_inv n v x : In x (@vec_list n v) -> exists p, x = vec_pos v p.
  Proof.
    induction v as [ | n y v IHl ].
    1: intros [].
    intros [ H | H ]; subst.
    + exists pos0; auto.
    + destruct IHl as (p & Hp); auto.
      subst; exists (pos_nxt p); auto.
  Qed.

  Fact vec_list_In_iff n v x : In x (@vec_list n v) <-> exists p, x = vec_pos v p.
  Proof.
    split.
    + apply vec_list_inv.
    + intros (p & ->); apply vec_list_In.
  Qed.

  Variable x : X.

  Fixpoint in_vec n (v : vec n) : Prop :=
    match v with
      | vec_nil => False
      | y ## v  => y = x \/ in_vec v
    end.

  Fact in_vec_list n v : @in_vec n v <-> In x (vec_list v).
  Proof. induction v; simpl; tauto. Qed.

End vector.

Notation vec := Vector.t.
Notation vec_cons := (fun x => @Vector.cons _ x _).

Fact in_vec_pos X n (v : vec X n) p : in_vec (vec_pos v p) v.
Proof. revert p; induction v; intros p; invert pos p; auto. Qed.

Fact in_vec_inv X n (v : vec X n) x : in_vec x v -> exists p, vec_pos v p = x.
Proof.
  induction v as [ | n y v IHv ]; simpl in_vec; try tauto.
  intros [ -> | H ].
  + exists pos0; auto.
  + destruct (IHv H) as (p & <-).
    exists (pos_nxt p); auto.
Qed.

Fact in_vec_dec_inv X n (v : vec X n) :
        (forall x y : X, { x = y } + { x <> y })
     -> forall x, in_vec x v -> { p | vec_pos v p = x }.
Proof.
  intros dec.
  induction v as [ | x n v IHv ].
  + intros _ [].
  + intros y Hy.
    destruct (dec x y) as [ H | H ].
    * exists pos0; auto.
    * destruct (IHv y) as (p & Hp).
      - destruct Hy; tauto.
      - exists (pos_nxt p); auto.
Qed.

(* notations *)

Section vec_app_split.

  Variable (X : Type) (n m : nat).

  Definition vec_app (v : vec X n) (w : vec X m) : vec X (n+m).
  Proof.
    apply vec_set_pos; intros p.
    destruct (pos_both _ _ p) as [ q | q ]; refine (vec_pos _ q); assumption.
  Defined.

  Definition vec_split (v : vec X (n+m)) : vec X n * vec X m.
  Proof.
    split; apply vec_set_pos; intros p; refine (vec_pos v _).
    + apply pos_left, p.
    + apply pos_right, p.
  Defined.

  Fact vec_app_split u : let (v,w) := vec_split u in vec_app v w = u.
  Proof.
    case_eq (vec_split u); intros v w; unfold vec_split, vec_app; intros H.
    injection H; clear H; intros Hw Hv.
    apply vec_pos_ext; unfold vec_app; simpl.
    intros p; rewrite vec_pos_set.
    case_eq (pos_both n m p); intros q Hq.
    + rewrite <- Hv, vec_pos_set; f_equal.
      apply f_equal with (f := @pos_lr _ _) in Hq.
      simpl in Hq; rewrite <- Hq; apply pos_lr_both.
    + rewrite <- Hw, vec_pos_set; f_equal.
      apply f_equal with (f := @pos_lr _ _) in Hq.
      simpl in Hq; rewrite <- Hq; apply pos_lr_both.
  Qed.

  Fact vec_split_app v w : vec_split (vec_app v w) = (v,w).
  Proof.
    unfold vec_split, vec_app; f_equal; apply vec_pos_ext; intros p; repeat rewrite vec_pos_set.
    + rewrite pos_both_left; auto.
    + rewrite pos_both_right; auto.
  Qed.

  Fact vec_pos_app_left v w i : vec_pos (vec_app v w) (pos_left _ i) = vec_pos v i.
  Proof. unfold vec_app; rewrite vec_pos_set, pos_both_left; auto. Qed.

  Fact vec_pos_app_right v w i : vec_pos (vec_app v w) (pos_right _ i) = vec_pos w i.
  Proof. unfold vec_app; rewrite vec_pos_set, pos_both_right; auto. Qed.

End vec_app_split.

Fact vec_app_nil X n v : @vec_app X 0 n vec_nil v = v.
Proof.
  apply vec_pos_ext; unfold vec_app; simpl; intros p.
  rewrite vec_pos_set; auto.
Qed.

Fact vec_app_cons X n m x v w : @vec_app X (S n) m (x##v) w = x##vec_app v w.
Proof.
  apply vec_pos_ext; unfold vec_app; intros p.
  rewrite vec_pos_set; simpl in p.
  analyse pos p.
  + simpl; auto.
  + simpl vec_pos at 3; rewrite vec_pos_set.
    simpl pos_both.
    destruct (pos_both n m p); auto.
Qed.

Fact vec_change_app_left X n m v w i x :
  vec_change (@vec_app X n m v w) (pos_left m i) x = vec_app (vec_change v i x) w.
Proof.
  revert v. induction i as [|?? IH].
  - intros v. rewrite (Vector.eta v), vec_app_cons. simpl. now rewrite vec_app_cons.
  - intros v. rewrite (Vector.eta v), vec_app_cons. simpl. now rewrite vec_app_cons, IH.
Qed.

Fact vec_change_app_right X n m v w i x :
  vec_change (@vec_app X n m v w) (pos_right _ i) x = vec_app v (vec_change w i x).
Proof.
  induction v as [|??? IH].
  - now rewrite !vec_app_nil.
  - now rewrite !vec_app_cons, <- IH.
Qed.

Section vec_map_def.

Variable (X Y : Type).
Variable (f : X -> Y).

Fixpoint vec_map n (v : vec X n) :=
  match v with
    | vec_nil => vec_nil
    | x ## v  => f x ## vec_map v
  end.

End vec_map_def.

Section vec_map.

  Variable (X Y : Type).

  Fixpoint vec_in_map n v : (forall x, @in_vec X x n v -> Y) -> vec Y n.
  Proof.
    refine (match v with
      | vec_nil  => fun _ => vec_nil
      | x##v     => fun f => f x _ ## @vec_in_map _ v _
    end).
    + left; auto.
    + intros y Hy; apply (f y); right; auto.
  Defined.

  Fact vec_in_map_vec_map_eq f n v : @vec_in_map n v (fun x _ => f x) = vec_map f v.
  Proof. induction v; simpl; f_equal; auto. Qed.

  Fact vec_in_map_ext n v f g : (forall x Hx, @f x Hx = @g x Hx)
                             -> @vec_in_map n v f = vec_in_map v g.
  Proof. revert f g; induction v; simpl; intros; f_equal; auto. Qed.

  Fact vec_map_ext f g n v : (forall x, in_vec x v -> f x = g x)
                          -> @vec_map X Y f n v = vec_map g v.
  Proof.
    intros H.
    do 2 rewrite <- vec_in_map_vec_map_eq.
    apply vec_in_map_ext, H.
  Qed.

  Fact vec_list_vec_map (f : X -> Y) n v : vec_list (@vec_map X Y f n v) = map f (vec_list v).
  Proof. induction v; simpl; f_equal; auto. Qed.

End vec_map.

Fact vec_map_map X Y Z (f : X -> Y) (g : Y -> Z) n (v : vec _ n) :
          vec_map g (vec_map f v) = vec_map (fun x => g (f x)) v.
Proof. induction v; simpl; f_equal; auto. Qed.

Section vec_map2.

  (* Definitions taken from stdlib *)

  Definition case0 {A} (P:vec A 0 -> Type) (H:P (@Vector.nil A)) v:P v :=
    match v with
    |vec_nil => H
    |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
    end.

  Definition caseS' {A} {n : nat} (v : vec A (S n)) : forall (P : vec A (S n) -> Type)
                                                      (H : forall h t, P (h ## t)), P v :=
    match v with
    | h ## t => fun P H => H h t
    | _ => fun devil => False_rect (@IDProp) devil
    end.

  Definition rect2 {A B} (P:forall {n}, vec A n -> vec B n -> Type)
             (bas : P vec_nil vec_nil) (recvec : forall {n v1 v2}, P v1 v2 ->
                                                              forall a b, P (a ## v1) (b ## v2)) :=
    fix rect2_fix {n} (v1 : vec A n) : forall v2 : vec B n, P v1 v2 :=
      match v1 with
      | vec_nil  => fun v2 => case0 _ bas v2
      | h1 ## t1 => fun v2 => caseS' v2 (fun v2' => P (h1##t1) v2') (fun h2 t2 => recvec (rect2_fix t1 t2) h1 h2)
      end.

  Definition vec_map2 {A B C} (g:A -> B -> C) :
    forall (n : nat), vec A n -> vec B n -> vec C n :=
    @rect2 _ _ (fun n _ _ => vec C n) vec_nil (fun _ _ _ H a b => (g a b) ## H).

  Global Arguments vec_map2 {A B C} g {n} v1 v2.

End vec_map2.

Fact vec_pos_map X Y (f : X -> Y) n (v : vec X n) p : vec_pos (vec_map f v) p = f (vec_pos v p).
Proof.
  revert p; induction v; intros p; pos_inv p; simpl; auto.
Qed.

Fact vec_map_set_pos X Y f n s : @vec_map X Y f _ (@vec_set_pos _ n s)
                               = vec_set_pos (fun p => f (s p)).
Proof.
  apply vec_pos_ext; intros p.
  rewrite vec_pos_map, vec_pos_set, vec_pos_set; auto.
Qed.

Section vec_plus.

  Variable n : nat.

  Definition vec_plus (v w : vec nat n) := vec_set_pos (fun p => vec_pos v p + vec_pos w p).
  Definition vec_zero : vec nat n := vec_set_pos (fun _ => 0).

  Fact vec_pos_plus v w p : vec_pos (vec_plus v w) p = vec_pos v p + vec_pos w p.
  Proof.
    unfold vec_plus; rewrite vec_pos_set; auto.
  Qed.

  Fact vec_zero_plus v : vec_plus vec_zero v = v.
  Proof.
    apply vec_pos_ext.
    intros p; unfold vec_zero, vec_plus.
    repeat rewrite vec_pos_set; auto.
  Qed.

  Fact vec_zero_spec p : vec_pos vec_zero p = 0.
  Proof. unfold vec_zero; rewrite vec_pos_set; trivial. Qed.

  Fact vec_add_comm v w : vec_plus v w = vec_plus w v.
  Proof.
    apply vec_pos_ext.
    intros p; unfold vec_zero, vec_plus.
    repeat rewrite vec_pos_set; lia.
  Qed.

  Fact vec_add_assoc u v w : vec_plus u (vec_plus v w) = vec_plus (vec_plus u v) w.
  Proof.
    apply vec_pos_ext.
    intros p; unfold vec_zero, vec_plus.
    repeat rewrite vec_pos_set; lia.
  Qed.

  Fact vec_plus_is_zero u v : vec_zero = vec_plus u v -> u = vec_zero /\ v = vec_zero.
  Proof.
   unfold vec_zero, vec_plus; intros H; split; apply vec_pos_ext;
   intros p; apply f_equal with (f := fun v => vec_pos v p) in H;
   repeat rewrite vec_pos_set in * |- *; lia.
  Qed.

  Definition vec_one p : vec _ n := vec_set_pos (fun q => if pos_eq_dec p q then 1 else 0).

  Fact vec_one_spec_eq p q : p = q -> vec_pos (vec_one p) q = 1.
  Proof.
    intros [].
    unfold vec_one; rewrite vec_pos_set.
    destruct (pos_eq_dec p p) as [ | [] ]; auto.
  Qed.

  Fact vec_one_spec_neq p q : p <> q -> vec_pos (vec_one p) q = 0.
  Proof.
    intros H.
    unfold vec_one; rewrite vec_pos_set.
    destruct (pos_eq_dec p q) as [ | ]; auto.
    destruct H; auto.
  Qed.

End vec_plus.

Arguments vec_plus {n}.
Arguments vec_zero {n}.
Arguments vec_one {n}.

Reserved Notation " e '#>' x " (at level 58, format "e #> x").
Reserved Notation " e [ v / x ] " (at level 57, v at level 0, x at level 0,
                                   left associativity, format "e [ v / x ]").

Local Notation " e '#>' x " := (vec_pos e x).
Local Notation " e [ v / x ] " := (vec_change e x v).

Tactic Notation "rew" "vec" :=
  repeat lazymatch goal with
    |              |- context[ _[_/?x]#>?x ] => rewrite vec_change_eq with (p := x) (1 := eq_refl)
    | _ : ?x = ?y  |- context[ _[_/?x]#>?y ] => rewrite vec_change_eq with (p := x) (q := y)
    | _ : ?y = ?x  |- context[ _[_/?x]#>?y ] => rewrite vec_change_eq with (p := x) (q := y)
    | _ : ?x <> ?y |- context[ _[_/?x]#>?y ] => rewrite vec_change_neq with (p := x) (q := y)
    | _ : ?y <> ?x |- context[ _[_/?x]#>?y ] => rewrite vec_change_neq with (p := x) (q := y)
    |              |- context[ vec_pos vec_zero ?x ] => rewrite vec_zero_spec with (p := x)
    |              |- context[ vec_pos (vec_one ?x) ?x ] => rewrite vec_one_spec_eq with (p := x) (1 := eq_refl)
    | _ : ?x = ?y  |- context[ vec_pos (vec_one ?x) ?y ] => rewrite vec_one_spec_eq with (p := x) (q := y)
    | _ : ?y = ?x  |- context[ vec_pos (vec_one ?x) ?y ] => rewrite vec_one_spec_eq with (p := x) (q := y)
    | _ : ?x <> ?y |- context[ vec_pos (vec_one ?x) ?y ] => rewrite vec_one_spec_neq with (p := x) (q := y)
    | _ : ?y <> ?x |- context[ vec_pos (vec_one ?x) ?y ] => rewrite vec_one_spec_neq with (p := x) (q := y)
    | |- context[ _[_/?x][_/?x] ] => rewrite vec_change_idem with (p := x)
    | |- context[ ?v[(?v#>?x)/?x] ] => rewrite vec_change_same with (p := x)
    | |- context[ _[_/?x]#>?y ] => rewrite vec_change_neq with (p := x) (q := y); [ | discriminate ]
    | |- context[ vec_plus vec_zero ?x ] => rewrite vec_zero_plus with (v := x)
    | |- context[ vec_plus ?x vec_zero ] => rewrite (vec_add_comm x vec_zero); rewrite vec_zero_plus with (v := x)
    | |- context[ (vec_set_pos ?f) #> ?p ] => rewrite (vec_pos_set f p)
    | |- context[ (vec_map ?f ?v) #> ?p ] => rewrite (vec_pos_map f v p)
    | |- vec_plus ?x ?y = vec_plus ?y ?x => apply vec_add_comm
  end; auto.

Tactic Notation "vec" "split" hyp(v) "with" ident(n) :=
  rewrite (vec_head_tail v); generalize (vec_head v) (vec_tail v); clear v; intros n v.

Tactic Notation "vec" "nil" hyp(v) := rewrite (vec_0_nil v).

Fact Forall2_vec_list X Y (R : X -> Y -> Prop) n v w : Forall2 R (@vec_list X n v) (vec_list w) <-> forall p, R (vec_pos v p) (vec_pos w p).
Proof.
  revert v w; induction n as [ | n IHn ]; intros v w.
  + vec nil v; vec nil w; split; simpl.
    * intros _ p; invert pos p.
    * constructor.
  + vec split v with x; vec split w with y.
    simpl vec_list; rewrite Forall2_cons_inv, IHn.
    split.
    * intros (H1 & H2) p; invert pos p; auto.
    * intros H; split.
      - apply (H pos0).
      - intro; apply (H (pos_nxt _)).
Qed.

Fact vec_zero_S n : @vec_zero (S n) = 0##vec_zero.
Proof. auto. Qed.

Fact vec_one_fst n : @vec_one (S n) pos0 = 1##vec_zero.
Proof. apply vec_pos_ext; intros p; pos_inv p; rew vec. Qed.

Lemma vec_change_comm {X} n v p q x y : p <> q ->
vec_change (@vec_change X n v p x) q y = vec_change (vec_change v q y) p x.
Proof.
  intros Hpq. apply vec_pos_ext; intros r.
  destruct (pos_eq_dec r p); destruct (pos_eq_dec r q); subst; now rew vec.
Qed.

Fact vec_one_nxt n p : @vec_one (S n) (pos_nxt p) = 0##vec_one p.
Proof.
  apply vec_pos_ext.
  unfold vec_one.
  intros q; rewrite vec_pos_set.
  pos_inv q.
  + simpl; auto.
  + rewrite <- vec_pos_tail.
    simpl vec_tail.
    rewrite vec_pos_set.
    destruct (pos_eq_dec p q) as [ | C ].
    * subst.
      destruct (pos_eq_dec (pos_nxt q) (pos_nxt q)) as [ | [] ]; auto.
    * destruct (pos_eq_dec (pos_nxt p) (pos_nxt q)) as [ | ]; auto.
      destruct C; apply pos_nxt_inj; auto.
Qed.

Fact vec_plus_cons n x v y w : @vec_plus (S n) (x##v) (y##w) = x+y ## vec_plus v w.
Proof.
  apply vec_pos_ext; unfold vec_plus.
  intros p; pos_inv p; repeat (rewrite vec_pos_set; simpl; auto).
Qed.

Fact vec_change_succ n v p : v[(S (v#>p))/p] = @vec_plus n (vec_one p) v.
Proof.
  apply vec_pos_ext.
  intros q.
  destruct (pos_eq_dec p q); rew vec;
  rewrite vec_pos_plus; rew vec; subst; auto.
Qed.

Fact vec_change_pred n v p u : v#>p = S u -> v = @vec_plus n (vec_one p) (v[u/p]).
Proof.
  intros Hu.
  apply vec_pos_ext.
  intros q.
  destruct (pos_eq_dec p q); rew vec;
  rewrite vec_pos_plus; rew vec; subst; auto.
Qed.

Fixpoint vec_sum n (v : vec nat n) :=
  match v with
    | vec_nil => 0
    | x##w    => x + vec_sum w
  end.

Fact vec_sum_plus n v w : @vec_sum n (vec_plus v w) = vec_sum v + vec_sum w.
Proof.
  revert w; induction v; intros w.
  1: rewrite (vec_0_nil (vec_plus _ _)), (vec_0_nil w); auto.
  rewrite (vec_head_tail w), vec_plus_cons; simpl.
  rewrite IHv; lia.
Qed.

Fact vec_sum_zero n : @vec_sum n vec_zero = 0.
Proof. induction n; simpl; auto. Qed.

Fact vec_sum_one n p : @vec_sum n (vec_one p) = 1.
Proof.
  revert p; induction n as [ | n IHn ]; intros p.
  1: invert pos p.
  pos_inv p.
  + rewrite vec_one_fst.
    simpl; f_equal; apply vec_sum_zero.
  + rewrite vec_one_nxt.
    unfold vec_sum; fold vec_sum.
    rewrite IHn; auto.
Qed.

Fact vec_sum_is_zero n v : @vec_sum n v = 0 -> v = vec_zero.
Proof.
  induction v as [ | n x v IHv ]; simpl; auto.
  simpl; rewrite vec_zero_S; intros; f_equal.
  + lia.
  + apply IHv; lia.
Qed.

Fact vec_sum_is_nzero n v : 0 < @vec_sum n v -> { p : _ & { w | v = vec_plus (vec_one p) w } }.
Proof.
  induction v as [ | [ | x] n v IHv ]; intros Hv; simpl in Hv.
  + lia.
  + apply IHv in Hv.
    destruct Hv as (p & w & Hw).
    exists (pos_nxt p), (0##w); rewrite vec_one_nxt.
    rewrite vec_plus_cons; f_equal; auto.
  + exists pos0, (x##v).
    rewrite vec_one_fst, vec_plus_cons; rew vec.
Qed.

Section vec_nat_induction.

  (* Specialized induction on vec nat n, with constant n *)

  Variable (n : nat) (P : vec nat n -> Type).

  Hypothesis HP0 : P vec_zero.
  Hypothesis HP1 : forall p, P (vec_one p).
  Hypothesis HP2 : forall v w, P v -> P w -> P (vec_plus v w).

  Theorem vec_nat_induction v : P v.
  Proof using HP0 HP1 HP2.
    induction v as [ v IHv ] using (measure_rect (@vec_sum n)).
    case_eq (vec_sum v).
    + intros Hv; apply vec_sum_is_zero in Hv; subst; auto.
    + intros x Hx.
      destruct (vec_sum_is_nzero v) as (p & w & Hw).
      * lia.
      * subst.
        apply HP2; auto.
        apply IHv.
       rewrite vec_sum_plus, vec_sum_one; auto.
  Qed.

End vec_nat_induction.

Section vec_map_list.

  Variable X : Type.

  (* morphism between vec nat n and (list X)/~p *)

  Fixpoint vec_map_list X n v : (pos n -> X) -> list X :=
    match v in vec _ m return (pos m -> _) -> _ with
      | vec_nil => fun _ => nil
      | a##v    => fun f => list_repeat (f pos0) a ++ vec_map_list v (fun p => f (pos_nxt p))
    end.

  Fact vec_map_list_zero n f : vec_map_list (@vec_zero n) f = @nil X.
  Proof. revert f; induction n; intros f; simpl; auto. Qed.

  Fact vec_map_list_one n p f : vec_map_list (@vec_one n p) f = f p :: @nil X.
  Proof.
    revert f; induction p; intro.
    + rewrite vec_one_fst; simpl; rewrite vec_map_list_zero; auto.
    + rewrite vec_one_nxt; simpl; rewrite IHp; auto.
  Qed.

  (* The morphism *)

  Fact vec_map_list_plus n v w f : @vec_map_list X n (vec_plus v w) f ~p vec_map_list v f ++ vec_map_list w f.
  Proof.
    revert v w f; induction n as [ | n IHn ]; intros v w f.
    + rewrite (vec_0_nil (vec_plus v w)), (vec_0_nil v), (vec_0_nil w); simpl; auto.
    + rewrite (vec_head_tail v), (vec_head_tail w), vec_plus_cons.
      generalize (vec_head v) (vec_tail v) (vec_head w) (vec_tail w); clear v w; intros x v y w.
      simpl.
      rewrite list_repeat_plus.
      solve list eq; apply Permutation_app; auto.
      apply Permutation_trans with (list_repeat (f pos0) y
                                 ++ vec_map_list v (fun p => f (pos_nxt p))
                                 ++ vec_map_list w (fun p => f (pos_nxt p))).
      * apply Permutation_app; auto.
      * do 2 rewrite <- app_ass.
        apply Permutation_app; auto.
       apply Permutation_app_comm.
  Qed.

End vec_map_list.

Fact map_vec_map_list X Y (f : X -> Y) n v g : map f (@vec_map_list _ n v g) = vec_map_list v (fun p => f (g p)).
Proof.
  revert g; induction v; intro; simpl; auto.
  rewrite map_app; f_equal; auto.
  rewrite map_list_repeat; auto.
Qed.

Section fun2vec.

  Variable X : Type.

  Fixpoint fun2vec i n f : vec X _ :=
    match n with
      | 0   => vec_nil
      | S n => f i##fun2vec (S i) n f
    end.

  Fact fun2vec_id i n f : fun2vec i n f = vec_set_pos (fun p => f (i+pos2nat p)).
  Proof.
    revert i; induction n as [ | n IHn ]; intros i; simpl; f_equal; auto.
    rewrite IHn.
    apply vec_pos_ext; intros; do 2 rewrite vec_pos_set; f_equal.
    rewrite pos2nat_nxt; lia.
  Qed.

  Fact fun2vec_lift i n f : fun2vec i n (fun j => f (S j)) = fun2vec (S i) n f.
  Proof. revert i f; induction n; intros; simpl; f_equal; auto. Qed.

  Fact vec_pos_fun2vec i n f p : vec_pos (fun2vec i n f) p = f (i+pos2nat p).
  Proof. rewrite fun2vec_id, vec_pos_set; auto. Qed.

  Definition vec2fun n (v : vec X n) x i :=
    match le_lt_dec n i with
      | left  _ => x
      | right H => vec_pos v (nat2pos H)
    end.

  Fact fun2vec_vec2fun n v x : fun2vec 0 n (@vec2fun n v x) = v.
  Proof.
    apply vec_pos_ext.
    intros p; rewrite vec_pos_fun2vec; simpl.
    unfold vec2fun.
    generalize (pos2nat_prop p).
    destruct (le_lt_dec n (pos2nat p)); try lia.
    rewrite nat2pos_pos2nat; auto.
  Qed.

  Fact vec2fun_fun2vec n f x i : i < n -> @vec2fun n (fun2vec 0 n f) x i = f i.
  Proof.
    intros H.
    unfold vec2fun.
    destruct (le_lt_dec n i); try lia.
    rewrite vec_pos_fun2vec, pos2nat_nat2pos; auto.
  Qed.

End fun2vec.

Section map_vec_pos_equiv.

  Variable (X : Type) (R : X -> X -> Prop)
           (Y : Type) (T : Y -> Y -> Prop)
           (T_refl : forall y, T y y)
           (T_trans : forall x y z, T x y -> T y z -> T x z).

  Theorem map_vec_pos_equiv n (f : vec X n -> Y) :
           (forall p v x y, R x y -> T (f (v[x/p])) (f (v[y/p])))
        -> forall v w, (forall p, R (v#>p) (w#>p)) -> T (f v) (f w).
  Proof using T_refl T_trans.
    revert f; induction n as [ | n IHn ]; intros f Hf v w H.
    + vec nil v; vec nil w; auto.
    + apply T_trans with (y := f (v[(w#>pos0)/pos0])).
      * rewrite <- (vec_change_same v pos0) at 1; auto.
      * revert H.
        vec split v with a; vec split w with b; intros H; simpl.
        apply IHn with (f := fun v => f(b##v)).
        - intros p q x y Hxy.
          apply (Hf (pos_nxt p) (b##q)); auto.
        - intros p; apply (H (pos_nxt p)).
  Qed.

End map_vec_pos_equiv.


Set Implicit Arguments.

Section PAIRS.
Variable A:Type.
Variable eq_dec : forall (v1 v2:A), {v1 = v2} + {v1 <> v2}.

Definition pair_In (x:A) (p:(A*A)%type) :=
  x = fst p \/ x = snd p.

Lemma pair_in_left:
  forall (x y:A),
  pair_In x (x, y).
Proof.
  intros.
  unfold pair_In.
  auto.
Qed.

Lemma pair_in_right:
  forall (x y:A),
  pair_In y (x, y).
Proof.
  intros.
  unfold pair_In.
  auto.
Qed.

Lemma pair_in_inv:
  forall (v v1 v2:A),
  pair_In v (v1, v2) ->
  v = v1 \/ v = v2.
Proof.
  intros.
  unfold pair_In in *.
  simpl in *.
  assumption.
Qed.

Definition pair_mem (x:A) (p:(A*A)%type) := let (y, z) := p in
  if (eq_dec x y) then true else
  if (eq_dec x z) then true else false.

Lemma pair_mem_prop:
  forall x p,
  pair_mem x p = true -> pair_In x p.
Proof.
  intros.
  unfold pair_mem in *.
  destruct p.
  destruct (eq_dec x a).
  + subst.
    apply pair_in_left.
  + destruct (eq_dec x a0).
    subst.
    apply pair_in_right.
    inversion H.
Qed.

Lemma pair_mem_from_prop:
  forall x p,
  pair_In x p ->
  pair_mem x p = true.
Proof.
  intros.
  destruct p as (v1, v2).
  inversion H.
  - simpl in *.
    subst.
    destruct (eq_dec v1 v1).
    + trivial.
    + contradiction n. (* absurd *)
      trivial.
  - simpl in *; subst.
    destruct (eq_dec v2 v1).
    + trivial.
    + destruct (eq_dec v2 v2).
      * trivial.
      * contradiction n0.
        trivial.
Qed.

Lemma pair_eq_dec:
  forall (v1 v2:(A*A)%type), {v1 = v2} + {v1 <> v2}.
Proof.
  intros.
  destruct v1 as (x1, x2).
  destruct v2 as (y1, y2).
  destruct (eq_dec x1 y1).
  destruct (eq_dec x2 y2).
  subst. left. auto.
  subst. right. intuition. inversion H. apply n in H1. assumption.
  subst. right. intuition. inversion H. apply n in H1. assumption.
Defined.

End PAIRS.

Lemma pair_eq_dec_2
  {A B:Type}
  (a_eq_dec:(forall (a a':A), {a = a'} + {a <> a'}))
  (b_eq_dec:(forall (b b':B), {b = b'} + {b <> b'})):

  forall (p p': A * B),
  {p = p'} + {p <> p'}.
Proof.
  intros.
  destruct p as (a, b).
  destruct p' as (a', b').
  destruct (a_eq_dec a a'), (b_eq_dec b b').
  - subst; left; auto.
  - subst; right; intuition;
    inversion H; subst; contradiction n; trivial.
  - subst; right; intuition;
    inversion H; subst; contradiction n; trivial.
  - subst; right; intuition;
    inversion H; subst; contradiction n; trivial.
Defined.

(*
Implicit Arguments pair_In.
Implicit Arguments pair_mem.
Implicit Arguments pair_eq_dec.
*)

Section Flip.

  (** Reverses a pair. *)

  Definition flip {A:Type} {B:Type} (e:A*B) := (snd e, fst e).

  Lemma flip_rw:
    forall {A:Type} {B:Type} (x:A*B),
    flip (flip x) = x.
  Proof.
    intros.
    destruct x.
    auto.
  Qed.
End Flip.