Require Export GeoCoq.Elements.OriginalProofs.lemma_inequalitysymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_localextension.
Require Export GeoCoq.Elements.OriginalProofs.lemma_doublereverse.

Section Euclid.
Context `{Ax:euclidean_neutral_ruler_compass}.
Lemma lemma_differenceofparts :
   forall A B C a b c,
   Cong A B a b -> Cong A C a c -> BetS A B C -> BetS a b c ->
   Cong B C b c.
Proof.
intros.
assert (Cong B C b c).
by cases on (eq B A \/ neq B A).
{
 assert (Cong A A a b) by (conclude cn_equalitysub).
 assert (Cong a b A A) by (conclude lemma_congruencesymmetric).
 assert (~ neq a b).
  {
  intro.
  assert (neq A A) by (conclude axiom_nocollapse).
  assert (eq A A) by (conclude cn_equalityreflexive).
  contradict.
  }
 assert (Cong A C A C) by (conclude cn_congruencereflexive).
 assert (Cong B C A C) by (conclude cn_equalitysub).
 assert (Cong B C a c) by (conclude lemma_congruencetransitive).
 assert (Cong b c b c) by (conclude cn_congruencereflexive).
 assert (Cong b c a c) by (conclude cn_equalitysub).
 assert (Cong a c b c) by (conclude lemma_congruencesymmetric).
 assert (Cong B C b c) by (conclude lemma_congruencetransitive).
 close.
 }
{
 assert (~ eq C A).
  {
  intro.
  assert (BetS A B A) by (conclude cn_equalitysub).
  assert (~ BetS A B A) by (conclude axiom_betweennessidentity).
  contradict.
  }
 assert (neq A C) by (conclude lemma_inequalitysymmetric).
 let Tf:=fresh in
 assert (Tf:exists E, (BetS C A E /\ Cong A E A C)) by (conclude lemma_localextension);destruct Tf as [E];spliter.
 assert (neq A C) by (conclude lemma_inequalitysymmetric).
 assert (neq a c) by (conclude axiom_nocollapse).
 assert (neq c a) by (conclude lemma_inequalitysymmetric).
 let Tf:=fresh in
 assert (Tf:exists e, (BetS c a e /\ Cong a e a c)) by (conclude lemma_localextension);destruct Tf as [e];spliter.
 assert (Cong E A A E) by (conclude cn_equalityreverse).
 assert (Cong E A A C) by (conclude lemma_congruencetransitive).
 assert (Cong E A a c) by (conclude lemma_congruencetransitive).
 assert (Cong e a a e) by (conclude cn_equalityreverse).
 assert (Cong e a a c) by (conclude lemma_congruencetransitive).
 assert (Cong a c e a) by (conclude lemma_congruencesymmetric).
 assert (Cong E A a c) by (conclude lemma_congruencetransitive).
 assert (Cong E A e a) by (conclude lemma_congruencetransitive).
 assert (BetS E A C) by (conclude axiom_betweennesssymmetry).
 assert (BetS e a c) by (conclude axiom_betweennesssymmetry).
 assert (Cong E C e c) by (conclude cn_sumofparts).
 assert (BetS E A B) by (conclude axiom_innertransitivity).
 assert (BetS e a b) by (conclude axiom_innertransitivity).
 assert (Cong C B c b) by (conclude axiom_5_line).
 assert (Cong b c B C) by (forward_using lemma_doublereverse).
 assert (Cong B C b c) by (conclude lemma_congruencesymmetric).
 close.
 }
(* cases *)
close.
Qed.

End Euclid.


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

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

Import Rbasic_fun.

(* Why3 comment *)
(* abs is replaced with (Reals.Rbasic_fun.Rabs x) by the coq driver *)

(* Why3 goal *)
Lemma abs_def :
  forall (x:Reals.Rdefinitions.R),
  ((0%R <= x)%R -> ((Reals.Rbasic_fun.Rabs x) = x)) /\
  (~ (0%R <= x)%R -> ((Reals.Rbasic_fun.Rabs x) = (-x)%R)).
split ; intros H.
apply Rabs_right.
now apply Rle_ge.
apply Rabs_left.
now apply Rnot_le_lt.
Qed.

(* Why3 goal *)
Lemma Abs_le :
  forall (x:Reals.Rdefinitions.R) (y:Reals.Rdefinitions.R),
  ((Reals.Rbasic_fun.Rabs x) <= y)%R <-> ((-y)%R <= x)%R /\ (x <= y)%R.
intros x y.
unfold Rabs.
case Rcase_abs ; intros H ; (split ; [intros H0;split | intros (H0,H1)]).
rewrite <- (Ropp_involutive x).
now apply Ropp_le_contravar.
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
apply Rle_trans with (2 := H0).
rewrite <- Ropp_0.
apply Ropp_le_contravar.
now apply Rlt_le.
rewrite <- (Ropp_involutive y).
now apply Ropp_le_contravar.
apply Rge_le in H.
apply Rle_trans with (2 := H).
apply Rle_trans with (Ropp x).
now apply Ropp_le_contravar.
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
exact H0.
exact H1.
Qed.

(* Why3 goal *)
Lemma Abs_pos :
  forall (x:Reals.Rdefinitions.R), (0%R <= (Reals.Rbasic_fun.Rabs x))%R.
exact Rabs_pos.
Qed.

(* Why3 goal *)
Lemma Abs_sum :
  forall (x:Reals.Rdefinitions.R) (y:Reals.Rdefinitions.R),
  ((Reals.Rbasic_fun.Rabs (x + y)%R) <=
   ((Reals.Rbasic_fun.Rabs x) + (Reals.Rbasic_fun.Rabs y))%R)%R.
exact Rabs_triang.
Qed.

(* Why3 goal *)
Lemma Abs_prod :
  forall (x:Reals.Rdefinitions.R) (y:Reals.Rdefinitions.R),
  ((Reals.Rbasic_fun.Rabs (x * y)%R) =
   ((Reals.Rbasic_fun.Rabs x) * (Reals.Rbasic_fun.Rabs y))%R).
exact Rabs_mult.
Qed.

(* Why3 goal *)
Lemma triangular_inequality :
  forall (x:Reals.Rdefinitions.R) (y:Reals.Rdefinitions.R)
    (z:Reals.Rdefinitions.R),
  ((Reals.Rbasic_fun.Rabs (x - z)%R) <=
   ((Reals.Rbasic_fun.Rabs (x - y)%R) + (Reals.Rbasic_fun.Rabs (y - z)%R))%R)%R.
intros x y z.
replace (x - z)%R with ((x - y) + (y - z))%R by ring.
apply Rabs_triang.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import init.

Require Import rat.
Require Import set.

Declare Scope real_scope.
Delimit Scope real_scope with real.

Definition dedekind_cut (a : rat → Prop) :=
    a ≠ all ∧
    a ≠ empty ∧
    (∀ l u, a u → l < u → a l) ∧
    (∀ l, a l → ∃ u, a u ∧ l < u).

Theorem dedekind_le : ∀ a, dedekind_cut a → ∀ l u, a u → l ≤ u → a l.
Proof.
    intros a a_cut l u au lu.
    classic_case (l = u).
    -   subst.
        exact au.
    -   apply (land (rand (rand a_cut)) _ _ au).
        split; assumption.
Qed.

Theorem dedekind_lt : ∀ a, dedekind_cut a → ∀ l u, a l → ¬a u → l < u.
Proof.
    intros a a_cut l u al nau.
    classic_case (l = u) as [eq|neq]; try (subst; contradiction).
    classic_contradiction leq.
    rewrite nlt_le in leq.
    rewrite neq_sym in neq.
    apply nau.
    apply (land (rand (rand a_cut)) u l); try split; assumption.
Qed.

Notation "'real'" := (set_type dedekind_cut).

Definition rat_to_real_base (a b : rat) := b < a.
Lemma rat_to_real_cut : ∀ a, dedekind_cut (rat_to_real_base a).
Proof.
    intros a.
    unfold rat_to_real_base.
    split.
    2: split.
    3: split.
    -   intros eq.
        assert (all a) as contr by exact true.
        rewrite <- eq in contr.
        destruct contr; contradiction.
    -   apply empty_neq.
        exists (a + -(1)).
        rewrite <- (plus_rid a) at 2.
        apply lt_lplus.
        apply pos_neg2.
        exact one_pos.
    -   intros l u ltq1 ltq2.
        exact (trans ltq2 ltq1).
    -   intros l ltq.
        exists ((l + a) * div 2).
        split.
        +   apply lt_mult_rcancel_pos with 2; try exact two_pos.
            rewrite mult_rlinv by apply two_pos.
            rewrite ldist.
            rewrite mult_rid.
            apply lt_rplus.
            exact ltq.
        +   apply lt_mult_rcancel_pos with 2; try exact two_pos.
            rewrite mult_rlinv by apply two_pos.
            rewrite ldist.
            rewrite mult_rid.
            apply lt_lplus.
            exact ltq.
Qed.

Definition rat_to_real a := [_|rat_to_real_cut a].


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

Require Import List Arith Omega.

Require Import wf_utils.

Set Implicit Arguments.

Section lazy_list.

  (* Implementation of lazy lists as the subset of co-lists
     characterized by a finiteness predicate *)

  Variable X : Type.

  CoInductive llist : Type :=
    | lnil : llist
    | lcons : X -> llist -> llist.

  Implicit Types (a: X) (s: llist) (l: list X).

  Unset Elimination Schemes.

  Inductive lfin : llist-> Prop :=
    | lfin_nil :  lfin lnil
    | lfin_cons : forall a ll, lfin ll -> lfin (lcons a ll).

  Arguments lfin_cons : clear implicits.

  Set Elimination Schemes.

  Section small_inversions.

    Let shape_inv s := match s with lnil => False | _         => True   end.
    Let pred_inv s  := match s with lnil => lnil  | lcons x s => s      end.

    Definition lfin_inv x s (H : lfin (lcons x s)) : lfin s :=
      match H in lfin s return shape_inv s -> lfin (pred_inv s) with
        | lfin_nil         => fun E => match E with end
        | lfin_cons _ _ H1 => fun _ => H1
      end I.

    Let output_invert s : lfin s -> Prop :=
      match s as s' return lfin s' -> _ with
        | lnil      => fun H => lfin_nil = H
        | lcons x s => fun H => exists H', lfin_cons x s H' = H
      end.

    Definition lfin_invert s H : @output_invert s H :=
      match H in lfin s return @output_invert s H with
        | lfin_nil         => eq_refl
        | lfin_cons _ _ H' => ex_intro _ H' eq_refl
      end.

  End small_inversions.

  (** We show proof irrelevance for lfin by induction/inversion
      where inversion is obtained by dependent pattern matching

      Interesting case because lfin is not a decidable predicate
      but nevertheless has provable PIRR
    *)

  Fixpoint lfin_pirr s (H1 : lfin s) : forall H2, H1 = H2.
  Proof.
    destruct H1 as [ | x s H1 ]; intros H2.
    + apply (lfin_invert H2).
    + destruct (lfin_invert H2) as (H & E).
      subst; f_equal; apply lfin_pirr.
  Defined.

  Section lfin_rect.

    (** We show dependent recursion principle for lfin implementing
        what a command like

        Scheme lfin_rect := Induction for lfin Sort Type.

        But Scheme is not smart enough to invent PIRR ...
        Remark that we use singleton elimination here ... *)

    Variable P : forall s, lfin s -> Type.

    Hypothesis HP1 : @P _ lfin_nil.
    Hypothesis HP2 : forall x s H, @P s H -> P (@lfin_cons x s H).

    Ltac pirr := match goal with |- @P _ ?a -> @P _ ?b => rewrite (@lfin_pirr _ a b); trivial end.

    Fixpoint lfin_rect s H { struct H } : @P s H.
    Proof.
      revert H.
      refine (match s with
        | lnil      => fun H => _
        | lcons x s => fun H => _
      end).
      + generalize HP1; pirr.
      + generalize (@HP2 x s (lfin_inv H) (@lfin_rect s (lfin_inv H))); pirr.
    Defined.

  End lfin_rect.

  (* Now we define lazy lists *)

  Definition lazy_list := { s | lfin s }.

  Implicit Type ll : lazy_list.

  (* Constructors *)

  Definition lazy_nil : lazy_list := exist _ _ lfin_nil.
  Definition lazy_cons a : lazy_list -> lazy_list.
  Proof.
    intros (ll & H).
    exists (lcons a ll).
    apply lfin_cons, H.
  Defined.

  (* Injectivity of constructors *)

  Fact lazy_cons_inj a b ll1 ll2 : lazy_cons a ll1 = lazy_cons b ll2 -> a = b /\ ll1 = ll2.
  Proof.
    revert ll1 ll2; intros (s1 & H1) (s2 & H2); simpl.
    intros E; apply f_equal with (f := @proj1_sig _ _) in E; simpl in E.
    inversion E; subst; split; auto; f_equal.
    apply lfin_pirr.
  Qed.

  Fact lazy_nil_cons_discr a ll : lazy_nil <> lazy_cons a ll.
  Proof. destruct ll; discriminate. Qed.

  (** And a dependent recursion principle similar to list_rect *)

  Section lazy_list_rect.

    Variable P : lazy_list -> Type.

    Hypothesis (HP0 : P lazy_nil).
    Hypothesis (HP1 : forall a m, P m -> P (lazy_cons a m)).

    Theorem lazy_list_rect : forall ll, P ll.
    Proof.
      intros (? & H).
      induction H as [ | x s H IH ].
      + apply HP0.
      + apply HP1 with (1 := IH).
    Defined.

  End lazy_list_rect.

  (* We have everything to define an isomorphism between list and lazy_list *)

  Section list_lazy_iso.

    Fixpoint list2lazy l :=
      match l with
        | nil  => lazy_nil
        | x::l => lazy_cons x (list2lazy l)
      end.

    Fact list2lazy_inj l m : list2lazy l = list2lazy m -> l = m.
    Proof.
      revert m; induction l as [ | a l IH ]; intros [ | b m ]; simpl; auto.
      + intros H; exfalso; revert H; apply lazy_nil_cons_discr.
      + intros H; exfalso; symmetry in H; revert H; apply lazy_nil_cons_discr.
      + intros H; apply lazy_cons_inj in H; destruct H; f_equal; auto.
    Qed.

    Section lazy2list.

      Let lazy2list_rec ll : { l | ll = list2lazy l }.
      Proof.
        induction ll as [ | a ll (l & Hl) ] using lazy_list_rect.
        + exists nil; auto.
        + exists (a::l); simpl; f_equal; auto.
      Qed.

      Definition lazy2list ll := proj1_sig (lazy2list_rec ll).

      Fact list2lazy2list ll : ll = list2lazy (lazy2list ll).
      Proof. apply (proj2_sig (lazy2list_rec ll)). Qed.

    End lazy2list.

    Fact lazy2list2lazy l : l = lazy2list (list2lazy l).
    Proof. apply list2lazy_inj; rewrite <- list2lazy2list; trivial. Qed.

    (* Fixpoint equations *)

    Fact lazy2list_nil : lazy2list lazy_nil = nil.
    Proof. apply list2lazy_inj; rewrite <- list2lazy2list; auto. Qed.

    Fact lazy2list_cons a ll : lazy2list (lazy_cons a ll) = a :: lazy2list ll.
    Proof.
      apply list2lazy_inj.
      simpl; repeat rewrite <- list2lazy2list; trivial.
    Qed.

  End list_lazy_iso.

  Definition lazy_length ll := length (lazy2list ll).

  Fact lazy_length_nil : lazy_length lazy_nil = 0.
  Proof. unfold lazy_length; rewrite lazy2list_nil; auto. Qed.

  Fact lazy_length_cons x ll : lazy_length (lazy_cons x ll) = S (lazy_length ll).
  Proof. unfold lazy_length; rewrite lazy2list_cons; auto. Qed.

End lazy_list.

Arguments lazy_nil {X}.

Section Rotate.

  (** From "Simple and Efficient Purely Functional Queues and Deques" by Chris Okasaki
      See application in file fifo_3llists.v *)

  Variable (X : Type).

  Implicit Type (l r m a : lazy_list X).

  Let prec l r := lazy_length r = 1 + lazy_length l.
  Let spec l r a m := lazy2list m = lazy2list l ++ rev (lazy2list r) ++ lazy2list a.

  Definition lazy_rotate l r : forall a, prec l r -> sig (spec l r a).
  Proof.
    induction on l r as loop with measure (lazy_length l); intros a.
    induction r as [ | y r' _ ] using lazy_list_rect; intros H.
    + exfalso; red in H; revert H; rewrite lazy_length_nil; intros; omega.
    + revert H.
      induction l as [ | x l' _ ] using lazy_list_rect; intros H.
      * exists (lazy_cons y a); red in H |- *.
        assert (r' = lazy_nil); [ | subst ].
        { revert H.
          induction r' as [ | ? r' ] using lazy_list_rect; auto.
          do 2 rewrite lazy_length_cons.
          rewrite lazy_length_nil; simpl; intros; omega. }
        do 2 rewrite lazy2list_cons, lazy2list_nil; auto.
      * refine (let (m,Hm) := loop l' r' _ (lazy_cons y a) _ in exist _ (lazy_cons x m) _).
        - rewrite lazy_length_cons; omega.
        - red in H |- *; do 2 rewrite lazy_length_cons in H; omega.
        - red in H, Hm |- *.
          repeat rewrite lazy2list_cons.
          rewrite Hm, lazy2list_cons; simpl.
          rewrite app_ass; auto.
  Defined.

End Rotate.

Arguments lazy_rotate {X}.

Extraction Inline lfin_rect lazy_nil lazy_cons lazy_list_rect.


Require Export Omega.
Set Implicit Arguments.

Local Close Scope nat.
Local Open Scope Z.

Lemma Z_mul_neg1_r a:
      a * -1 = - a.
Proof.
 omega.
Qed.

Lemma Z_add_neg_r a b:
      a + -b = a - b.
Proof.
 omega.
Qed.

Ltac Z_simp_all
 := simpl in *;
    repeat rewrite Z.add_0_r in *;
    repeat rewrite Z.mul_1_r in *;
    repeat rewrite Z_mul_neg1_r in *;
    repeat rewrite Z_add_neg_r in *.


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

(*i $Id: Qfield.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Field.
Require Export QArith_base.
Require Import NArithRing.

(** * field and ring tactics for rational numbers *)

Definition Qsrt : ring_theory 0 1 Qplus Qmult Qminus Qopp Qeq.
Proof.
  constructor.
  exact Qplus_0_l.
  exact Qplus_comm.
  exact Qplus_assoc.
  exact Qmult_1_l.
  exact Qmult_comm.
  exact Qmult_assoc.
  exact Qmult_plus_distr_l.
  reflexivity.
  exact Qplus_opp_r.
Qed.

Definition Qsft : field_theory 0 1 Qplus Qmult Qminus Qopp Qdiv Qinv Qeq.
Proof.
  constructor.
  exact Qsrt.
  discriminate.
  reflexivity.
  intros p Hp.
  rewrite Qmult_comm.
  apply Qmult_inv_r.
  exact Hp.
Qed.

Lemma Qpower_theory : power_theory 1 Qmult Qeq Z_of_N Qpower.
Proof.
constructor.
intros r [|n];
reflexivity.
Qed.

Ltac isQcst t :=
  match t with
  | inject_Z ?z => isZcst z
  | Qmake ?n ?d =>
    match isZcst n with
      true => isPcst d
    | _ => false
    end
  | _ => false
  end.

Ltac Qcst t :=
  match isQcst t with
    true => t
    | _ => NotConstant
  end.

Ltac Qpow_tac t :=
  match t with
  | Z0 => N0
  | Zpos ?n => Ncst (Npos n)
  | Z_of_N ?n => Ncst n
  | NtoZ ?n => Ncst n
  | _ => NotConstant
  end.

Add Field Qfield : Qsft
 (decidable Qeq_bool_eq,
  completeness Qeq_eq_bool,
  constants [Qcst],
  power_tac Qpower_theory [Qpow_tac]).

(** Exemple of use: *)

Section Examples.

Let ex1 : forall x y z : Q, (x+y)*z ==  (x*z)+(y*z).
  intros.
  ring.
Qed.

Let ex2 : forall x y : Q, x+y == y+x.
  intros.
  ring.
Qed.

Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z).
  intros.
  ring.
Qed.

Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2).
  ring.
Qed.

Let ex5 : 1+1 == 2#1.
  ring.
Qed.

Let ex6 : (1#1)+(1#1) == 2#1.
  ring.
Qed.

Let ex7 : forall x : Q, x-x== 0.
  intro.
  ring.
Qed.

Let ex8 : forall x : Q, x^1 == x.
  intro.
  ring.
Qed.

Let ex9 : forall x : Q, x^0 == 1.
  intro.
  ring.
Qed.

Let ex10 : forall x y : Q, ~(y==0) -> (x/y)*y == x.
intros.
field.
auto.
Qed.

End Examples.

Lemma Qopp_plus : forall a b,  -(a+b) == -a + -b.
Proof.
  intros; ring.
Qed.

Lemma Qopp_opp : forall q, - -q==q.
Proof.
  intros; ring.
Qed.


(** * Permutation over lists, and finite multisets. *)

Set Implicit Arguments.

From Coq Require Import List Relations Multiset Arith Setoid.
From CoLoR Require Import decidable_set more_list equiv_list.
From CoLoR Require list_permut.

 Definition permut (n : nat) (f : nat -> nat) :=
  (forall i, n <= i -> f i = i) /\
  (forall i, i < n -> f i < n) /\
  (forall i j, i < n -> j < n -> f i = f j -> i = j).

Lemma adequacy :
  forall (A : Type) (R : relation A) (l1 l2 : list A),
  list_permut.permut0 R l1 l2 <->
  (length l1 = length l2 /\
   exists pi, (permut (length l1) pi) /\
   forall i, i < length l1 ->
   match (nth_error l1 i), (nth_error l2 (pi i)) with
   | (Some ai), (Some bi) => R ai bi
   | _, _ => False
   end).
Proof.
intros A R l1; pattern l1; apply list_rec2; clear l1.
intro n; induction n as [ | n]; intros l1 L1 l2; split.
intros P; inversion P; subst.
split; trivial.
exists (fun (i : nat) => i); repeat split; trivial.
intros i L; simpl in L; inversion L.
simpl in L1; inversion L1.
intros [L _]; destruct l1 as [ | a1 l1].
destruct l2 as [ | a2 l2].
apply list_permut.Pnil.
simpl in L; discriminate.
simpl in L1; inversion L1.
intros P; inversion P as [ | a1 b1 l1' l2' l2'' a1_R_b1 Q ]; subst; split; trivial.
exists (fun (i : nat) => i); repeat split; trivial.
intros i L; simpl in L; inversion L.
rewrite (list_permut.permut_length P); trivial.
simpl in L1; generalize (le_S_n _ _ L1); clear L1; intro L1.
rewrite (IHn l1' L1 (l2' ++ l2'')) in Q.
destruct Q as [ L [pi [ Q H]]].
exists (fun (i : nat) =>
             match i with
             | 0 => length l2'
             | S i =>
                 if le_lt_dec (length l2') (pi i)
                 then S (pi i)
                 else pi i
             end); split.
unfold permut in *; repeat split.
intros [ | i] L'; simpl in L'.
inversion L'.
generalize (le_S_n _ _ L'); clear L'; intro L'.
destruct Q as [Q _].
rewrite (Q i L').
destruct (le_lt_dec (length l2') i) as [ll2'_le_i | ll2'_gt_i]; trivial.
rewrite L in L'.
absurd (length l2' < length l2'); auto with arith.
apply le_lt_trans with i; trivial.
apply le_trans with (length (l2' ++ l2'')); trivial.
rewrite length_app; auto with arith.
intros [ | i] L'.
simpl; rewrite L; unfold lt; apply le_n_S; rewrite length_app; auto with arith.
simpl in L'; generalize (le_S_n _ _ L'); clear L'; intro L'.
destruct Q as [_ [Q _]].
destruct (le_lt_dec (length l2') (pi i)) as [ll2'_le_pii | ll2'_gt_pii].
simpl; unfold lt; apply le_n_S; apply Q; trivial.
simpl; apply lt_le_trans with (length l1').
apply Q; trivial.
auto with arith.
destruct Q as [_ [_ Q]].
intros [ | i] [ | j] L' L'' H'; trivial.
destruct  (le_lt_dec (length l2') (pi j)) as [ll2'_cmp_pij | ll2'_cmp_pij];
rewrite H' in ll2'_cmp_pij;
absurd (S (pi j) <= pi j); trivial; auto with arith.
destruct  (le_lt_dec (length l2') (pi i)) as [ll2'_cmp_pii | ll2'_cmp_pii];
rewrite <- H' in ll2'_cmp_pii;
absurd (S (pi i) <= pi i); trivial; auto with arith.
destruct  (le_lt_dec (length l2') (pi i)) as [ll2'_le_pii | ll2'_gt_pii];
destruct  (le_lt_dec (length l2') (pi j)) as [ll2'_le_pij | ll2'_gt_pij].
apply (f_equal (fun n => S n)); apply Q.
simpl in L'; apply lt_S_n; trivial.
simpl in L''; apply lt_S_n; trivial.
injection H'; trivial.
absurd (length l2' < length l2'); auto with arith.
apply le_lt_trans with (pi j); trivial.
rewrite <- H'; auto with arith.
absurd (length l2' < length l2'); auto with arith.
apply le_lt_trans with (pi i); trivial.
rewrite H'; auto with arith.
apply (f_equal (fun n => S n)); apply Q; trivial.
simpl in L'; apply lt_S_n; trivial.
simpl in L''; apply lt_S_n; trivial.
intros [ | i] L'.
simpl; rewrite nth_error_at_pos; trivial.
simpl in L'; generalize (le_S_n _ _ L'); clear L'; intro L'.
simpl; rewrite (nth_error_remove b1 l2' l2'' (pi i)); apply H; trivial.

intros [L [pi [P H]]].
destruct l1 as [ | a1 l1].
destruct l2 as [ | a2 l2].
apply list_permut.Pnil.
simpl in L; discriminate.
assert (L' : 0 < length (a1 :: l1)).
simpl; auto with arith.
generalize (H 0 L'); simpl.
assert (H' := nth_error_ok_in (pi 0) l2).
destruct (nth_error l2 (pi 0)) as [ b1 | ].
intro a1_R_b1; destruct (H' _ (eq_refl _)) as [l2' [l2'' [L'' H'']]]; clear H'.
subst l2; apply list_permut.Pcons; trivial.
rewrite IHn; [split | simpl in L1; apply le_S_n; trivial].
rewrite length_app in L; rewrite plus_comm in L; simpl in L; injection L;
intro L'''; rewrite L'''; rewrite plus_comm; rewrite length_app; trivial.
exists (fun i =>
               if le_lt_dec (length l1) i
               then i
               else
                 if le_lt_dec (pi (S i)) (pi 0)
                 then pi (S i)
                 else (pi (S i)) -1); split.
unfold permut in *; repeat split.

intros i L''';
destruct (le_lt_dec (length l1) i) as [ll1_le_i | ll1_gt_i]; trivial.
absurd (i < i); auto with arith.
apply lt_le_trans with (length l1); trivial.

intros i L''';
destruct (le_lt_dec (length l1) i) as [ll1_le_i | _]; trivial.
assert (L'''' : S i < length (a1 :: l1)).
simpl; auto with arith.
destruct (le_lt_dec (pi (S i)) (pi 0)) as [piSi_le_pi0 | piSi_gt_pi0].
assert (piSi_lt_pi0 : pi (S i) < pi 0).
destruct (le_lt_or_eq _ _ piSi_le_pi0) as [L5 | E]; trivial.
destruct P as [_ [_ P]].
absurd (S i = 0).
discriminate.
apply (P (S i) 0); trivial.
apply lt_le_trans with (pi 0); trivial.
destruct P as [_ [P _]].
generalize (P 0 (lt_O_Sn _)); simpl; auto with arith.
destruct P as [_ [P _]].
generalize (P (S i) L''''); destruct (pi (S i)) as [ | p]; simpl.
intros _; apply le_lt_trans with i; auto with arith.
rewrite <- minus_n_O; auto with arith.

intros i j Li Lj;
destruct (le_lt_dec (length l1) i) as [ll1_le_i | _];
destruct (le_lt_dec (length l1) j) as [ll1_le_j | _];
trivial.
absurd (i < i); auto with arith.
apply lt_le_trans with (length l1); trivial.
absurd (j < j); auto with arith.
apply lt_le_trans with (length l1); trivial.
destruct P as [_ [_ P]];
destruct (le_lt_dec (pi (S i)) (pi 0)) as [piSi_le_pi0 | piSi_gt_pi0];
destruct (le_lt_dec (pi (S j)) (pi 0)) as [piSj_le_pi0 | piSj_gt_pi0].
intro piSi_eq_piSj; assert (Si_eq_Sj : S i = S j).
apply (P (S i) (S j)); simpl; auto with arith.
injection Si_eq_Sj; trivial.
destruct (le_lt_or_eq _ _ piSi_le_pi0) as [L5 | E]; clear piSi_le_pi0.
destruct (pi (S j)) as [ | pj].
absurd (pi 0 < 0); auto with arith.
simpl; rewrite <- minus_n_O.
intro H'; rewrite H' in L5.
absurd (S pj < S pj); auto with arith.
apply le_lt_trans with (pi 0); auto with arith.
absurd (S i = 0).
discriminate.
apply (P (S i) 0); trivial.
simpl; auto with arith.
destruct (le_lt_or_eq _ _ piSj_le_pi0) as [L5 | E]; clear piSj_le_pi0.
destruct (pi (S i)) as [ | qi].
absurd (pi 0 < 0); auto with arith.
simpl; rewrite <- minus_n_O.
intro H'; rewrite <- H' in L5.
absurd (S qi < S qi); auto with arith.
apply le_lt_trans with (pi 0); auto with arith.
absurd (S j = 0).
discriminate.
apply (P (S j) 0); trivial.
simpl; auto with arith.
intro piSi_eq_piSj; assert (Si_eq_Sj : S i = S j).
apply (P (S i) (S j)); simpl; auto with arith.
destruct (pi (S i)) as [ | qi].
absurd (pi 0 < 0); auto with arith.
destruct (pi (S j)) as [ | pj].
absurd (pi 0 < 0); auto with arith.
simpl in piSi_eq_piSj; do 2 rewrite <- minus_n_O in piSi_eq_piSj; subst; trivial.
injection Si_eq_Sj; trivial.

intros i Li;
destruct (le_lt_dec (length l1) i) as [ll1_lt_i | _].
absurd (i < i); auto with arith.
apply lt_le_trans with (length l1); trivial.
generalize (H (S i) (lt_n_S _ _ Li)); simpl.
destruct (nth_error l1 i) as [ai | ]; trivial.
generalize (nth_error_ok_in (pi (S i)) (l2' ++ b1 :: l2''));
destruct (nth_error (l2' ++ b1 :: l2'') (pi (S i))) as [bi | ];
[idtac | contradiction].
intros H' ai_R_bi; destruct (H' _ (eq_refl _)) as [k2 [k2' [Lk2 H'']]]; clear H'.
destruct (in_in_split_set b1 bi l2' l2'' k2 k2' H'') as [[H''' | H'''] | H''']; clear H''.
destruct H''' as [l [H3 H4]]; subst.
rewrite <- ass_app; rewrite <- Lk2; rewrite <- L''; simpl.
destruct (le_lt_dec (length k2) (length (k2 ++ bi :: l))) as [Ok | Ko].
rewrite nth_error_at_pos; trivial.
absurd (length k2 < length k2); auto with arith.
apply le_lt_trans with (length (k2 ++ bi :: l)); trivial.
rewrite length_app; auto with arith.
destruct H''' as [l [H3 H4]]; subst.
rewrite <- Lk2; rewrite <- L''; simpl.
destruct (le_lt_dec (length (l2' ++ b1 :: l)) (length l2')) as [Ko | Ok].
absurd (length l2' < length l2'); auto with arith.
apply lt_le_trans with (length (l2' ++ b1 :: l)); trivial.
rewrite length_app; rewrite plus_comm; simpl; auto with arith.
rewrite (length_app l2' (b1 :: l)).
rewrite plus_comm; simpl; rewrite <- minus_n_O; rewrite plus_comm;
rewrite <- length_app.
rewrite ass_app; rewrite nth_error_at_pos; trivial.
destruct H''' as [_ [H3 H4]]; subst;
absurd (0 = S i).
discriminate.
destruct P as [_ [_ P]].
apply P; simpl; auto with arith.
rewrite <- Lk2; rewrite L''; subst; trivial.
intro; contradiction.
Qed.

Section defs.

  (** * From lists to multisets *)

  Variable A : Type.
  Variable eqA : relation A.
  Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.

  Let emptyBag := EmptyBag A.
  Let singletonBag := SingletonBag _ eqA_dec.

  (** contents of a list *)

  Fixpoint list_contents (l:list A) : multiset A :=
    match l with
      | nil => emptyBag
      | a :: l => munion (singletonBag a) (list_contents l)
    end.

  (** * [permutation]: definition and basic properties *)

  Definition permutation (l m:list A) :=
    meq (list_contents l) (list_contents m).
End defs.

Lemma permut_closure : forall (A : Type) eqA
 (eqA_dec : forall a1 a2, {eqA a1 a2}+{~eqA a1 a2}),
forall a1 a2, @permutation A eqA eqA_dec (a1 :: nil) (a2 :: nil) <->
(forall a, eqA a1 a <-> eqA a2 a).
Proof.
intros A eqA eqA_dec; unfold permutation, meq; simpl.
intros a1 a2; split.
intros H a; assert (Ha := H a); clear H; do 2 rewrite <- plus_n_O in Ha.
destruct (eqA_dec a1 a) as [a1_eq_a | a1_diff_a];
destruct (eqA_dec a2 a) as [a2_eq_a | a2_diff_a].
intuition.
discriminate.
discriminate.
intuition.
intros H a;
destruct (eqA_dec a1 a) as [a1_eq_a | a1_diff_a];
destruct (eqA_dec a2 a) as [a2_eq_a | a2_diff_a]; trivial.
absurd (eqA a2 a); trivial; rewrite <- (H a); trivial.
absurd (eqA a1 a); trivial; rewrite  (H a); trivial.
Qed.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
(**
#
#
** Recap

 Proof language
   - [: name], to prepare the goal for a tactic
   - [=>] [name] [/view] [//] [/=] [{name}] [[]], to post-process the goal
   - [rewrite lem -lem // /= /def]
   - [apply: lem]
 Library
   - naming convention: [addnC], [eqP], [orbN], [orNb], ...
   - notations: [.+1], [if-is-then-else]
   - [Search _ (_ + _) in ssrnat]
   - [Search _ addn "C" in ssrnat]
   - Use the HTML doc!
 Approach
   - boolean predicates
   - [reflect P b] to link bool with Prop

#
#
--------------------------------------------------------
#
#
** Today
   - The [seq] library
   - forward reasoning with [have]
   - spec lemmas
   - [rewrite] patterns

#
#
--------------------------------------------------------
--------------------------------------------------------
#
#
** Sequences
  - an alias for lists (used to be differnt)
  - many notations

*)
Check [::].
Check [:: 3 ; 4].
Check [::] ++ [:: true ; false].
Eval compute in [seq x.+1 | x <- [:: 1; 2; 3]].
Eval compute in [seq x <- [::3; 4; 5] | odd x ].
Eval compute in rcons [:: 4; 5] 3.
Eval compute in all odd [:: 3; 5].

Module polylist.

(**
#
#
--------------------------------------------------------
#
#
** Polymorphic lists
   - This statement makes no assumptions on T
   - recap: [// /= ->]
*)
Lemma size_cat T (s1 s2 : seq T) : size (s1 ++ s2) = size s1 + size s2.
Proof.  by elim: s1 => //= x s1 ->. Qed.

End polylist.

Eval compute in 3 \in [:: 7; 4; 3].

Fail Check forall T : Type, forall x : T, x \in [:: x ].

(**
#
#
--------------------------------------------------------
#
#
** Had-hoc polymorphism
  - T : Type |- l : list T
  - T : eqType |- l : list T
  - eqType means: a type with a decidable equality (_ == _)
*)

Check forall T : eqType, forall x : T, x \in [:: x ].

(**
#
#
--------------------------------------------------------
#
#
** The \in notation
   - overloaded as [(_ == _)]
   - pushing \in with inE
   - computable.
   - rewrite !inE
*)
Lemma test_in l : 3 \in [:: 4; 5] ++ l -> l != [::].
Proof.
by rewrite !inE => /=; apply: contraL => /eqP->.
Qed.

(**
#
#
--------------------------------------------------------
#
#
** Forward reasoning
   - have
   - have :=
   - have + views
   - do I need eqType here?
*)
(**
Definition of all
<<
Fixpoint all a s := if s is x :: s' then a x && all a s' else true.
>> *)
(**
Definition of count
<<
Fixpoint count a s := if s is x :: s' then a x + count s' else 0.
>> *)
(**
A lemma linking the two concepts *)
Lemma all_count (T : eqType) (a : pred T) s :
  all a s = (count a s == size s).
Proof.
elim: s => //= x s.
have EM_a : a x || ~~ a x.
  by exact: orbN.
move: EM_a => /orP EM_a. case: EM_a => [-> | /negbTE-> ] //= _.
(*# have /orP[ ax | n_ax ] : a x || ~~ a x by case: (a x). #*)
Search _ count size in seq.
by rewrite add0n eqn_leq andbC ltnNge count_size.
(*# have := boolP (a x). #*)
Qed.

(**
#
#
--------------------------------------------------------
--------------------------------------------------------
#
#
** Spec lemmas
   - Inductive predicates to drive the proof
*)

Module myreflect1.

Inductive reflect (P : Prop) (b : bool) : Prop :=
  | ReflectT (p : P) (e : b = true)
  | ReflectF (np : ~ P) (e : b = false).

Fixpoint eqn m n :=
  match m, n with
  | 0, 0 => true
  | j.+1,k.+1 => eqn j k
  | _, _ => false
  end.
Arguments eqn !m !n.

Axiom eqP : forall m n, reflect (m = n) (eqn m n).

Lemma test_reflect1 m n : ~~ (eqn m n) || (n <= m <= n).
Proof.
case: (eqn m n) => /=.
(*# case: (eqP m n) => [Enm -> | nE_mn ->] /=. #*)
Admitted.

End myreflect1.

(*#
Module myreflect2.

Inductive reflect (P : Prop) : bool-> Prop :=
  | ReflectT (p : P) : reflect P true
  | ReflectF (np : ~ P) : reflect P false.

Fixpoint eqn m n :=
  match m, n with
  | 0, 0 => true
  | j.+1,k.+1 => eqn j k
  | _, _ => false
  end.
Arguments eqn !m !n.

Axiom eqP : forall m n, reflect (m = n) (eqn m n).
Arguments eqP {m n}.

Lemma test_reflect1 m n : ~~ (eqn m n) || (n <= m <= n).
Proof.
case: (@eqP m n) => [Enm | nE_mn ] /=.
by case: eqP => [->|] //=; rewrite leqnn.
Qed.

End myreflect2.

Check (_ =P _).
Check eqP.

#*)

Inductive leq_xor_gtn m n : bool -> bool -> Prop :=
  | LeqNotGtn of m <= n : leq_xor_gtn m n true false
  | GtnNotLeq of n < m  : leq_xor_gtn m n false true.

Axiom leqP : forall m n : nat, leq_xor_gtn m n (m <= n) (n < m).

(**
#
#
--------------------------------------------------------
#
#
** Let's try out leqP on an ugly goal
   - matching of indexes
   - generalization of unresolved implicits
   - instantiation by matching
*)
Lemma test_leqP m n1 n2 :
  (m <= (if n1 < n2 then n1 else n2)) =
  (m <= n1) && (m <= n2) && ((n1 < n2) || (n2 <= n1)).
Proof.
case: leqP => [leqn21 | /ltnW ltn12 ]; rewrite /= andbT.
  by rewrite andb_idl // => /leq_trans /(_ leqn21).
by rewrite andb_idr // => /leq_trans->.
Qed.

(**
#
#
--------------------------------------------------------
#
#
** Another commodity: [ifP]
   - a spec lemma for if-then-else
   - handy with case, since matching spares you to write
     the expressions involved
*)
Lemma test_ifP n m : if n <= m then 0 <= m - n else m - n == 0.
Proof.
case: ifP => //.
by move=> /negbT; rewrite subn_eq0 leqNgt negbK=> /ltnW.
Qed.

(**
#
#

--------------------------------------------------------
#
#
** Rewrite on steroids
   - keyed matching
   - instantiation
   - localization
*)
Lemma ugly_goal n m :
  n + (m * 2).+1 = n + (m + m.+1).
Proof.
rewrite addnC.
rewrite (addnC m).
rewrite [_ + m]addnC.
rewrite [in n + _]addnC.
rewrite [X in _ = X + n]addnC.
rewrite [in RHS]addnC.
Abort.

Lemma ugly_goal n m :
  n + m = n + m.
Proof.
rewrite addnC.
rewrite [in RHS]addnC.
Abort.

Lemma no_pattern n : n + 0 = n.
Proof.
rewrite -[n in RHS]addn0.
Abort.

(**
#
#
--------------------------------------------------------
#
#
** References for this lesson:
  - SSReflect #manual#
  - documentation of the
       #library#
    - in particular #seq#

#
#
--------------------------------------------------------
#
#
** Demo:
   - you should be now able to read this proof

*)

Lemma dvdn_fact m n : 0 < m <= n -> m %| n`!.
Proof.
case: m => //= m; elim: n => //= n IHn; rewrite ltnS leq_eqVlt.
by move=> /orP[ /eqP-> | /IHn]; [apply: dvdn_mulr | apply: dvdn_mull].
Qed.

Lemma prime_above m : {p | m < p & prime p}.
Proof.
Check pdivP.
have /pdivP[p pr_p p_dv_m1]: 1 < m`! + 1 by rewrite addn1 ltnS fact_gt0.
exists p => //; rewrite ltnNge; apply: contraL p_dv_m1 => p_le_m.
Check dvdn_addr.
by rewrite dvdn_addr ?dvdn_fact ?prime_gt0 // gtnNdvd ?prime_gt1.
Qed.

(** #
# *)


Require Import Setoid.
Require Import Morphisms.
Require Import Coq.Program.Basics.
Require Import ClassicalFacts.

Unset Printing Records.

From Ordinal Require Import Defs.
From Ordinal Require Import Operators.
From Ordinal Require Import Arith.
From Ordinal Require Import Enumerate.

Section fixpoints.
  Variable f : Ord -> Ord.

  Definition iter_f (base:Ord) : nat -> Ord :=
    fix iter_f (n:nat) : Ord :=
      match n with
      | 0 => base
      | S n' => f (iter_f n')
      end.

  Lemma iter_f_monotone :
     (forall x y, x <= y -> f x <= f y) ->
     forall i x y, x <= y -> iter_f x i <= iter_f y i.
  Proof.
    intro H. induction i; simpl; auto.
  Qed.

  Definition fixOrd (base:Ord) : Ord := supOrd (iter_f base).

  Lemma fixOrd_above : forall base, base ≤ fixOrd base.
  Proof.
    intros.
    unfold fixOrd.
    apply (sup_le _ (iter_f base) 0%nat).
  Qed.

  Lemma iter_f_complete n :
    forall base, complete base ->
    (forall x, complete x -> complete (f x)) ->
    complete (iter_f base n).
  Proof.
    induction n as [n IH1] using (well_founded_induction Wf_nat.lt_wf).
    destruct n; simpl; auto.
  Qed.

  Lemma iter_f_index_monotone i j :
    (forall x, complete x -> x <= f x) ->
    (forall x, complete x -> complete (f x)) ->
    (i <= j)%nat ->
    forall base, complete base -> iter_f base i <= iter_f base j.
  Proof.
    intros Hf1 Hf2 H; induction H; intros base Hbase; simpl.
    - reflexivity.
    - rewrite IHle; auto.
      apply Hf1. apply iter_f_complete; auto.
  Qed.

  Lemma directed_iter_f base :
    (forall x, complete x -> x <= f x) ->
    (forall x y, x <= y -> f x <= f y) ->
    (forall x, complete x -> complete (f x)) ->
    complete base ->
    directed nat (iter_f base).
  Proof.
    intros. intros i j. exists (Nat.max i j).
    split; apply iter_f_index_monotone; auto.
    + apply PeanoNat.Nat.le_max_l.
    + apply PeanoNat.Nat.le_max_r.
  Qed.

  Hypothesis Hmonotone : forall x y, x <= y -> f x <= f y.

  Lemma fixOrd_monotone :
     forall x y, x <= y -> fixOrd x <= fixOrd y.
  Proof.
    unfold fixOrd; intros.
    apply sup_least. intro n.
    eapply ord_le_trans with (iter_f y n); [ | apply sup_le ].
    apply iter_f_monotone; auto.
  Qed.

  Hypothesis Hcont : strongly_continuous f.

  Lemma fixOrd_prefixpoint : forall base, f (fixOrd base) ≤ fixOrd base.
  Proof.
    intros.
    apply ord_le_trans with (supOrd (fun i => f (iter_f base i))).
    - apply (Hcont nat (iter_f base) 0%nat).
    - apply sup_least. intro i.
      unfold fixOrd.
      apply (sup_le _ (iter_f base) (S i)).
  Qed.

  Hypothesis Hinflationary : forall x, x ≤ f x.

  Lemma fixOrd_fixpoint : forall base, fixOrd base ≈ f (fixOrd base).
  Proof.
    intros; split.
    - apply Hinflationary.
    - apply fixOrd_prefixpoint; auto.
  Qed.

  Lemma fixOrd_least : forall base z, base ≤ z -> f z ≤ z -> fixOrd base ≤ z.
  Proof.
    intros.
    unfold fixOrd.
    apply sup_least.
    intro i; induction i; simpl; auto.
    apply ord_le_trans with (f z); auto.
  Qed.

  Lemma normal_fix_continuous : strongly_continuous fixOrd.
  Proof.
    intros A g a0. unfold fixOrd.
    apply sup_least; intro i.
    induction i; simpl.
    - apply sup_ord_le_morphism. intro a.
      rewrite <- (sup_le _ _ 0%nat).
      simpl. auto with ord.
    - etransitivity; [ apply Hmonotone; apply IHi |].
      rewrite (Hcont A (fun i => supOrd (iter_f (g i))) a0).
      apply sup_ord_le_morphism. intro a.
      apply fixOrd_prefixpoint.
  Qed.

  Lemma normal_fix_complete base :
    complete base ->
    (forall x, complete x -> x <= f x) ->
    (forall x y, x <= y -> f x <= f y) ->
    (forall x, complete x -> complete (f x)) ->
    complete (fixOrd base).
  Proof.
    intros Hbase Hf1 Hf2 Hf3.
    unfold fixOrd.
    apply sup_complete; auto.
    - intros; apply iter_f_complete; auto.
    - apply directed_iter_f; auto.
    - assert (Hc' : complete (f base)).
      { apply Hf3; auto. }
      destruct (complete_zeroDec base Hbase).
      + destruct (complete_zeroDec (f base) Hc').
        * right. intro i.
          revert H H0. clear -Hf1 Hf2 Hbase. revert base Hbase.
          induction i; simpl; intros; auto.
          transitivity (f base); auto.
          apply Hf2; auto.
          rewrite IHi; auto.
          apply zero_least.
        * left.
          exists 1%nat. simpl.
          auto.
      + left.
        exists 0%nat. simpl. auto.
  Qed.

End fixpoints.

Lemma iter_f_monotone_func f g n :
  (forall x, f x ≤ g x) ->
  (forall x y, x ≤ y -> g x ≤ g y) ->
  forall x, iter_f f x n ≤ iter_f g x n.
Proof.
  intros Hf Hg.
  induction n; intros; simpl.
  - reflexivity.
  - etransitivity; [ apply Hf | apply Hg; auto ].
Qed.

Lemma fixOrd_monotone_func f g :
  (forall x, f x ≤ g x) ->
  (forall x y, x ≤ y -> g x ≤ g y) ->
  forall x, fixOrd f x ≤ fixOrd g x.
Proof.
  intros.
  unfold fixOrd. apply sup_ord_le_morphism.
  intro n. apply iter_f_monotone_func; auto.
Qed.

Definition enum_fixpoints (f:Ord -> Ord) : Ord -> Ord :=
  fix rec (x:Ord) : Ord :=
  match x with
  | ord B g => fixOrd f (ord B (fun b => rec (g b)))
  end.

Lemma enum_fixpoints_monotone f :
  (forall x y, x ≤ y -> f x ≤ f y) ->
  (forall x y, x ≤ y -> enum_fixpoints f x ≤ enum_fixpoints f y).
Proof.
  intros Hf x y; revert x.
  induction y as [C h Hy].
  destruct x as [B g].
  simpl; intros.
  unfold fixOrd.
  apply sup_ord_le_morphism; intro i; simpl.
  apply iter_f_monotone; auto.
  rewrite ord_le_unfold; simpl; intro b.
  rewrite ord_lt_unfold; simpl.
  destruct (ord_le_subord _ _ H b) as [c Hb].
  exists c.
  apply Hy; auto.
Qed.

Lemma enum_fixpoints_increasing f :
  (forall x y, x ≤ y -> f x ≤ f y) ->
  (forall x y, x < y -> enum_fixpoints f x < enum_fixpoints f y).
Proof.
  intros Hf x y H.
  rewrite ord_lt_unfold in H.
  destruct x as [B g].
  destruct y as [C h].
  simpl in *.
  destruct H as [i ?].
  eapply ord_lt_le_trans; [| apply fixOrd_above ].
  rewrite ord_lt_unfold. exists i. simpl.
  apply (enum_fixpoints_monotone f Hf (ord B g) (h i)); auto.
Qed.

Lemma enum_fixpoints_func_mono f g :
  (forall x y, x ≤ y -> f x ≤ f y) ->
  (forall x y, x ≤ y -> g x ≤ g y) ->
  (forall x, f x ≤ g x) ->
  (forall x, enum_fixpoints f x ≤ enum_fixpoints g x).
Proof.
  intros Hf Hg Hfg.
  induction x as [A q Hx]; simpl.
  unfold fixOrd.
  apply sup_ord_le_morphism. intro i.
  transitivity (iter_f f (ord A (fun b : A => enum_fixpoints g (q b))) i).
  - apply iter_f_monotone; auto.
    rewrite ord_le_unfold; simpl; intro a.
    rewrite ord_lt_unfold; simpl; exists a.
    auto.
  - apply iter_f_monotone_func; auto.
Qed.

Lemma enum_are_fixpoints f :
  strongly_continuous f ->
  (forall x, x ≤ f x) ->
  forall x, enum_fixpoints f x ≈ f (enum_fixpoints f x).
Proof.
  intros Hcont Hinflationary.
  destruct x as [X g]; simpl.
  apply fixOrd_fixpoint; auto.
Qed.

Lemma enum_fixpoints_zero f :
  (forall x y, x ≤ y -> f x ≤ f y) ->
  enum_fixpoints f zeroOrd ≈ fixOrd f zeroOrd.
Proof.
  simpl.
  split; apply fixOrd_monotone; auto.
  - rewrite ord_le_unfold; simpl; intuition.
  - rewrite ord_le_unfold; simpl; intuition.
Qed.

Lemma enum_fixpoints_succ f x :
  enum_fixpoints f (succOrd x) ≈ fixOrd f (succOrd (enum_fixpoints f x)).
Proof.
  simpl; intros. reflexivity.
Qed.

Lemma enum_fixpoints_cont f :
  (forall x y, x ≤ y -> f x ≤ f y) ->
  (forall x, x ≤ f x) ->
  strongly_continuous f ->
  strongly_continuous (enum_fixpoints f).
Proof.
  intros Hmono Hinf Hcont A g a0.
  apply fixOrd_least; auto.
  - rewrite ord_le_unfold.
    simpl.
    intros [a i]. simpl.
    rewrite <- (sup_le _ _ a).
    apply enum_fixpoints_increasing; auto with ord.
  - rewrite (Hcont A (fun i => enum_fixpoints f (g i)) a0).
    apply sup_least; intro a.
    rewrite <- enum_are_fixpoints; auto.
    rewrite <- (sup_le _ _ a); auto with ord.
Qed.

Theorem enum_fixpoints_enumerates f:
  (forall x, x ≤ f x) ->
  (forall x y, x ≤ y -> f x ≤ f y) ->
  strongly_continuous f ->
  enumerates (enum_fixpoints f) (fun x => x ≈ f x).
Proof.
  intros Hinf Hmono Hcont.
  hnf; intros.
  constructor; auto.
  - apply enum_are_fixpoints; auto.
  - intros; apply enum_fixpoints_monotone; auto.
  - intros; apply enum_fixpoints_increasing; auto.
  - intros x z Hz1 Hz2.
    destruct x as [A g]. simpl.
    apply fixOrd_least; auto.
    + rewrite ord_le_unfold. simpl; intros.
      apply Hz2. apply (index_lt (ord A g) a).
    + apply Hz1.
Qed.

Lemma enum_fixpoints_enumerates_range f :
  (forall x, x ≤ f x) ->
  (forall x y, x ≤ y -> f x ≤ f y) ->
  strongly_continuous f ->
  enumerates (enum_fixpoints f) (fun x => exists y, x ≈ enum_fixpoints f y).
Proof.
  intros Hinf Hmono Hcont.
  hnf; intros.
  constructor; auto.
  - intro x. exists x. reflexivity.
  - intros; apply enum_fixpoints_monotone; auto.
  - intros; apply enum_fixpoints_increasing; auto.
  - intros x z [y Hy] H.
    destruct x as [A g]; simpl; intros.
    apply fixOrd_least; auto.
    + rewrite ord_le_unfold; simpl; intros.
      apply H. apply (index_lt (ord A g)).
    + transitivity (f (enum_fixpoints f y)).
      apply Hmono. apply Hy.
      rewrite Hy.
      apply enum_are_fixpoints; auto.
Qed.

Lemma enum_fixpoints_complete f :
  (forall x, complete x -> x ≤ f x) ->
  (forall x y, x ≤ y -> f x ≤ f y) ->
  (forall x, complete x -> complete (f x)) ->
  forall x, complete x -> complete (enum_fixpoints f x).
Proof.
  intros Hf1 Hf2 Hf3.
  induction x as [B g Hx]. intro Hc.
  simpl enum_fixpoints.
  apply normal_fix_complete; auto.
  apply lim_complete.
  + intros; apply Hx. apply Hc.
  + intros b1 b2. destruct (complete_directed _ Hc b1 b2) as [b' [Hb1 Hb2]].
    exists b'. split; apply enum_fixpoints_monotone; auto.
  + apply Hc.
Qed.

Definition ε (x:Ord) := enum_fixpoints powOmega x.

Lemma ε_monotone : forall x y, x ≤ y -> ε x ≤ ε y.
Proof.
  unfold ε.
  apply enum_fixpoints_monotone.
  apply powOmega_monotone.
Qed.

Lemma ε_increasing : forall x y, x < y -> ε x < ε y.
Proof.
  unfold ε.
  apply enum_fixpoints_increasing.
  apply powOmega_monotone.
Qed.

Lemma ε_continuous : strongly_continuous ε.
Proof.
  unfold ε.
  apply enum_fixpoints_cont; auto.
  apply powOmega_monotone.
  apply increasing_inflationary.
  apply powOmega_increasing.
  unfold powOmega.
  apply expOrd_continuous.
Qed.

Lemma ε_fixpoint : forall x, ε x ≈ expOrd ω (ε x).
Proof.
  intro x.
  apply enum_are_fixpoints.
  apply expOrd_continuous.
  apply increasing_inflationary.
  apply powOmega_increasing.
Qed.

Theorem ε_enumerates : enumerates ε (fun x => x ≈ expOrd ω x).
Proof.
  unfold ε.
  apply enum_fixpoints_enumerates.
  apply increasing_inflationary.
  apply powOmega_increasing.
  apply powOmega_monotone.
  apply expOrd_continuous.
Qed.

Theorem ε_complete x : complete x -> complete (ε x).
Proof.
  intros. unfold ε.
  apply enum_fixpoints_complete; auto.
  intros; apply increasing_inflationary. apply powOmega_increasing.
  apply powOmega_monotone.
  intros; apply expOrd_complete; auto.
  apply (index_lt ω 0%nat).
  apply omega_complete.
Qed.

Opaque foldOrd.

Theorem ε0_least_expOmega_closed :
  forall X, expOrd ω X ≤ X -> ε 0 ≤ X.
Proof.
  intros.
  unfold ε. simpl. unfold fixOrd.
  apply sup_least; intro i.
  induction i; simpl iter_f.
  { rewrite ord_le_unfold; intros []. }
  rewrite <- H.
  unfold powOmega.
  apply expOrd_monotone.
  apply IHi.
Qed.

Theorem KnuthUp_epsilon : KnuthUp 2 ω ω ≈ ε 0.
Proof.
  rewrite KnuthUp_succ.
  transitivity (foldOrd 1 (expOrd ω) ω); [ reflexivity |].
  rewrite foldOrd_unfold.
  split.
  - apply lub_least.
    + unfold ε; simpl.
      unfold fixOrd.
      rewrite <- (sup_le _ _ 1%nat).
      apply succ_least. apply expOrd_nonzero.
    + apply sup_least; intro n.
      induction n.
      * simpl.
        rewrite foldOrd_unfold.
        transitivity (expOrd ω 1).
        { apply expOrd_monotone. apply lub_least; auto with ord.
          apply sup_least; intros []. }
        unfold fixOrd. rewrite <- (sup_le _ _ 2%nat).
        unfold iter_f. unfold powOmega.
        apply expOrd_monotone.
        apply succ_least. apply expOrd_nonzero.
      * unfold ε. simpl.
        rewrite fixOrd_fixpoint.
        unfold powOmega.
        apply expOrd_monotone.
        rewrite foldOrd_succ.
        apply IHn.
        intros. apply succ_least; apply expOrd_nonzero.
        apply expOrd_continuous.
        apply increasing_inflationary.
        apply powOmega_increasing.
  - unfold ε. simpl enum_fixpoints. unfold fixOrd.
    apply sup_least; intro n.
    rewrite <- lub_le2.
    rewrite <- (sup_le _ _ n).
    simpl.
    induction n; simpl.
    + rewrite ord_le_unfold; intros [].
    + unfold powOmega at 1.
      apply expOrd_monotone.
      rewrite foldOrd_succ.
      apply IHn.
      intros. apply succ_least. apply expOrd_nonzero.
Qed.


(** * TAL-0 Typed Assembly Language *)

(** Based on paper by Greg Morrisett , TAL-0 is the design of a RISC-style typed assembly language which focuses on control-flow safety. This post provides a mechanized metatheory, particularly a machine checked proof of soundness of the TAL-0 type system as proposed by the author in section 4.2.10 of the book Advanced Topics in Types and Programming Languages.  *)

(** The TAL-0 language runs on an abstract machine which is represented by 3 components :

1. A heap H which is a finite, partial map from labels to heap values

2. a register file R which is a total map from registers to values, and

3. a current instruction sequence I.
*)

Require Import Bool Arith Vector.
Require Import LibTactics Maps.

Definition registers := total_map nat.
Definition empty_regs : registers := t_empty 0.

Inductive val : Type :=
 | ANum : nat -> val
 | AReg : nat -> val
 | ALab : nat -> val.

(** We denote addresses of instructions stored in the heap as labels. Unlike a typical machine where labels are resolved to some machine address, which are integers, we maintain a distinction between labels and arbit integers, as this complies with our goal to state and prove the control-flow safety i.e. we can only branch to a valid label, and not to any arbit integer. This will ensure that the machine never gets stuck while trying to do some invalid operation. *)
(*define relations for aeval , ieval*)
Fixpoint aeval (a : val) (R : registers) : nat :=
  match a with
 | ANum n => n
 | AReg d => R (Id d)
 | ALab l => l
  end.

Inductive instr : Type :=
 | IMov : forall d : nat,
    val -> instr
 | IAdd : forall d s : nat,
    instr
 | ISub : forall d v : nat,
    instr
 | IIf : forall d : nat,
    val -> instr.

Inductive instr_seq : Type :=
 | ISeq : instr -> instr_seq -> instr_seq
 | IJmp : val -> instr_seq.

(** Simple Notations are chosen for the sake of clarity while writing programs.*)
Notation "'R(' d ')' ':=' a" :=
  (IMov d (ANum a)) (at level 60).
Notation "'R(' d ')' '+:=' 'R(' s ')'" :=
  (IAdd d s) (at level 60).
Notation "'R(' s ')' '-:=' v" :=
  (ISub s v) (at level 60).
Notation "i1 ;; i2" :=
  (ISeq i1 i2) (at level 80, right associativity).
Notation "'JIF' 'R(' d ')' v" :=
  (IIf d (ANum v)) (at level 70).
Notation "'JMP' v" :=
  (IJmp (ALab v)) (at level 80).
Notation "'JMP' 'R(' r ')'" :=
  (IJmp (AReg r)) (at level 80).

Check JIF R(1) 2.
Check R(1) := 10.
Check R(2) +:= R(1).
Check R(2) -:= 1.
Check R(2) +:= R(1) ;; R(2) -:= 1 ;; JMP 2.
Check JMP 2.
Check JMP R(2).

Definition heaps := partial_map instr_seq.
Definition empty_heap : heaps := empty.

(* Machine State *)
Inductive st : Type :=
 | St : heaps -> registers -> instr_seq -> st.

(** Evaluation of instructions is supposed to change the Machine State and thus some of its components H, R or I. These changes are posed as relations between initial and final state of the machine. *)
Inductive ieval : st -> st -> Prop :=
 | R_IMov : forall H R I d a,
    ieval (St H R (R(d) := a ;; I)) (St H (t_update R (Id d) a) I)
 | R_IAdd : forall H R I d s,
     ieval (St H R (R(d) +:= R(s) ;; I)) (St H (t_update R (Id d) (aeval (AReg d) R + aeval (AReg s) R)) I)
 | R_ISub : forall H R I d v,
     ieval (St H R (R(d) -:= v ;; I)) (St H (t_update R (Id d) (aeval (AReg d) R - aeval (ANum v) R)) I)
 | R_IJmp_Succ : forall H R I' a l,
     l = (aeval a R) -> H (Id l) = Some I' -> ieval (St H R (JMP l)) (St H R I')
 | R_IJmpR_Succ : forall H R I' r,
     H (Id (R (Id r))) = Some I' -> ieval (St H R (JMP R(r))) (St H R I')
 | R_IJmp_Fail : forall H R I a,
     H (Id (aeval a R)) = None -> ieval (St H R I) (St H R I)
 | R_IIf_EQ : forall H R I I2 r v,
     aeval (AReg r) R = 0 -> (H (Id v)) = Some I2 -> ieval (St H R (JIF R(r) v ;; I)) (St H R I2)
 | R_IIf_NEQ : forall H R I r v,
     aeval (AReg r) R <> 0 -> ieval (St H R (JIF R(r) v ;; I)) (St H R I)
 | R_ISeq : forall st st' st'',
     ieval st st' -> ieval st' st'' -> ieval st st''.

(** Example of a program fragment that multiplies 2 numbers stored in registers 1 and 2 and stores their product in register 3, before finally looping in its final state register 4. *)
Definition init_heap := update (update (update empty_heap (Id 1) (R(3) := 0 ;; JMP 2)) (Id 2) (JIF R(1) 3 ;; R(2) +:= R(3) ;; R(1) -:= 1 ;; JMP 2) ) (Id 3) (JMP R(4)).

Definition init_regs : registers :=  (t_update (t_update  (t_update (t_update (t_update empty_regs (Id 5) 1) (Id 6) 2) (Id 7) 3) (Id 1) 1) (Id 2) 2).
Definition final_regs : registers := (t_update (t_update (t_update  (t_update (t_update (t_update empty_regs (Id 5) 1) (Id 6) 2) (Id 4) 1) (Id 1) 0) (Id 2) 2) (Id 3) 2).

Eval compute in init_heap (Id (init_regs (Id 6))).

(* jump to a label proof *)
Example ieval_example1 : ieval (St init_heap init_regs
                          (R(3) := 0 ;; JMP 2))
                               (St init_heap (t_update init_regs (Id 3) 0)
                          (JIF R(1) 3 ;; R(2) +:= R(3) ;; R(1) -:= 1 ;; JMP 2)).
Proof.
  apply R_ISeq with (St init_heap (t_update init_regs (Id 3) 0) (IJmp (ALab 2))).
  apply R_IMov.
  apply R_IJmp_Succ with (a := ALab 2).
  simpl.
  reflexivity.
  unfold init_heap.
  rewrite update_neq.
  rewrite update_eq.
  reflexivity.
  rewrite <- beq_id_false_iff; trivial.
Qed.

(** The types consist of
1. int -> represents arbit integer stored in a register

2. reg -> a type constructor. Takes as input, the type of the register, to which this register is pointing.

3. code -> takes as input a typing context Γ, and gives type (code Γ) which is the type of an instruction sequence that expects type of the Register file to be Γ before it begins execution

4. arrow -> represents type of a single instruction (excluding JMP), which expects register file of type Γ1 before execution, and changes it to Γ2 after it has executed.

5. T -> It is the super type. It is used to represent the type of a register in R, which contains the label of the instruction currently executing. Because in such a case, we have the equation : Γ (r) = code Γ, which in the absence of subtyping or polymorphic types can't be solved. Hence T is assigned the type for such a register as it subsumes all types including itself. When we jump through a register of type T, we forget the type assigned to it, and reassign T to it.
Morrisett's paper uses the polymorphic type for due to some more benefits it affords. However we have used T type for its simplicity.
 *)

Inductive ty : Type :=
 | int : ty
 | reg : ty -> ty
 | code : partial_map ty -> ty
 | arrow : partial_map ty -> partial_map ty -> ty
 | True : ty.

Definition context := partial_map ty.

(* register file types *)
Definition empty_Gamma : context := empty.

(* heap types *)
Definition empty_Psi : context := empty.

(** The Typing Rules *)
(** Ψ is a partial map containing types of instruction sequences. As all instruction sequences end in a JMP statement, all valid values in Ψ are Some (code Γ) where Γ is the initial type state of register expected by that instruction sequence. Now, typing rules may require presence of either both Ψ and Γ, or only Ψ or neither. Hence, we introduce a combined context structure, that handles all the 3 cases. *)
Inductive cmbnd_ctx :=
 | EmptyCtx : cmbnd_ctx
 | PsiCtx : context -> cmbnd_ctx
 | PsiGammaCtx : context -> context -> cmbnd_ctx.

(** Typing rules for arithmetic expressions *)
Inductive ahas_type : cmbnd_ctx -> val -> ty -> Prop :=
 | S_Int : forall Ψ n,
     ahas_type (PsiCtx Ψ) (ANum n) int
 | S_Lab : forall Ψ Γ l v R,
     Ψ (Id l) = Some (code Γ) -> l = aeval (ALab v) R -> ahas_type (PsiCtx Ψ) (ALab v) (code Γ)
 | S_Reg : forall Ψ Γ r,
     Γ (Id r) = Some (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int)
 | S_RegV : forall Ψ Γ r,
     ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg (code Γ))
 | S_RegT : forall Ψ Γ r,
     ahas_type (PsiGammaCtx Ψ Γ) (AReg r) True
 | S_Val : forall Ψ Γ a tau,
     ahas_type (PsiCtx Ψ) a tau -> ahas_type (PsiGammaCtx Ψ Γ) a tau.

Hint Constructors ahas_type.

(** Typing rules for instructions *)
Inductive ihas_type : cmbnd_ctx -> instr -> ty -> Prop :=
 | S_Mov : forall Ψ Γ R d a tau,
    ahas_type (PsiGammaCtx Ψ Γ) a tau -> ahas_type (PsiGammaCtx Ψ Γ) (AReg d) (reg tau) -> (update Γ (Id d) (reg tau)) = Γ -> ihas_type (PsiCtx Ψ) (R(d) := aeval a R) (arrow Γ Γ)
 | S_Add : forall Ψ Γ d s,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg s) (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (AReg d) (reg int) -> update Γ (Id d) (reg int) = Γ -> ihas_type (PsiCtx Ψ) (R(d) +:= R(s)) (arrow Γ Γ)
 | S_Sub : forall Ψ Γ s a v,
      ahas_type (PsiGammaCtx Ψ Γ) a int -> ahas_type (PsiGammaCtx Ψ Γ) (AReg s) (reg int) -> a = ANum v -> ihas_type (PsiCtx Ψ) (R(s) -:= v) (arrow Γ Γ)
 | S_If :  forall Ψ Γ r v,
     ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) -> ihas_type (PsiCtx Ψ) (JIF R(r) v) (arrow Γ Γ).
Hint Constructors ihas_type.

Inductive iseq_has_type : cmbnd_ctx -> instr_seq -> ty -> Prop :=
 | S_Jmp :  forall Ψ Γ v,
     ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) -> iseq_has_type (PsiCtx Ψ) (JMP v) (code Γ)
 | S_JmpT :  forall Ψ Γ v,
     ahas_type (PsiGammaCtx Ψ Γ) (AReg v) True -> iseq_has_type (PsiCtx Ψ) (JMP R(v)) (code Γ)
 | S_Seq :  forall Ψ i1 i2 Γ Γ2,
     ihas_type (PsiCtx Ψ) i1 (arrow Γ Γ2) -> iseq_has_type (PsiCtx Ψ) i2 (code Γ2) -> iseq_has_type (PsiCtx Ψ) (ISeq i1 i2) (code Γ).                                           Hint Constructors iseq_has_type.

Definition init_Gamma : context := update (update (update (update empty_Gamma (Id 1) (reg int)) (Id 2) (reg int)) (Id 3) (reg int)) (Id 4) True.
Check init_Gamma.
Hint Unfold init_Gamma.

Definition init_Psi : context := update (update (update empty_Psi (Id 1) (code init_Gamma))(Id 3) (code init_Gamma)) (Id 2) (code init_Gamma).
Hint Unfold init_Psi.

Ltac match_map := repeat (try rewrite update_neq; try rewrite update_eq; try reflexivity).
Ltac inequality := (rewrite <- beq_id_false_iff; trivial).
Ltac crush_map := match_map ; inequality; try reflexivity.

Ltac rewrite_hyp :=
     match goal with
       | [ H : ?n = _ |- context[?n] ] => rewrite H
     end.

Ltac crush_generic :=
  repeat match goal with
         | [ H : ?T |- ?T    ] => exact T
         | [ |- ?T = ?T ] => reflexivity
         | [ |- True         ] => constructor
         | [ |- _ /\ _       ] => constructor
         | [ |- _ /\ _ -> _  ] => intro
         | [ H : _ /\ _ |- _ ] => destruct H
         | [ |- nat -> _     ] => intro
         | _ => rewrite_hyp || eauto || jauto
         end.

Ltac crush :=
  repeat (crush_generic; match goal with
                         | [ |- update _ _ _ _ = _ ] => crush_map
                         | [ |- init_Gamma _ = _ ] => unfold init_Gamma
                         | [ |- init_Psi _ = _ ] => unfold init_Psi
                         | [ |- ieval _ _ ] => constructor; auto
                         | [ |- ihas_type _ _ _] => constructor; auto
                         | [ |- ?T -> False  ]  => assert T
                         | _ => try subst; trivial
                         end).

Example heap_2_type : forall I (R : registers), (init_heap (Id 2)) = Some I -> iseq_has_type (PsiCtx init_Psi) I (code init_Gamma).
Proof.
  intros.
  unfold init_heap in H.
  rewrite update_neq in H.
  rewrite update_eq in H.
  symmetry in H.
  inversion H.
  apply S_Seq with (Γ2 := init_Gamma).
  crush.
  constructor; auto.
  apply S_Lab with (l := 3) (R := R).
  crush.
  trivial.
  apply S_Seq with (Γ2 := init_Gamma).
  constructor; auto.
  crush.
  apply update_same.
  crush.
  apply S_Seq with (Γ2 := init_Gamma).
  unfold init_Psi.
  apply S_Sub with (a := ANum 1).
  unfold init_Psi.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  apply S_Lab with (l := 2) (R := R).
  crush.
  trivial.
  trivial.
  rewrite <- beq_id_false_iff.
  trivial.
Qed.

(** Typing rule for register file *)
Inductive Rhas_type : cmbnd_ctx -> registers -> context -> Prop :=
| S_Regfile : forall Ψ Γ R r tau a,
    (Γ (Id r)) = Some tau -> aeval a R = R (Id r) -> ahas_type (PsiGammaCtx Ψ Γ) a tau -> Rhas_type (PsiCtx Ψ) R Γ.

Hint Constructors Rhas_type.

(** Typing rule for Heap *)
Inductive Hhas_type : cmbnd_ctx -> heaps -> context -> Prop :=
| S_Heap : forall Ψ H,
    (forall l tau, exists is, Ψ (Id l) = Some tau /\ H (Id l) = Some is /\ iseq_has_type (PsiCtx Ψ) is tau) -> Hhas_type EmptyCtx H Ψ.

Hint Constructors Hhas_type.

(** Typing rule for a valid Machine State *)
Inductive M_ok : cmbnd_ctx -> heaps -> registers -> instr_seq -> Prop :=
| S_Mach : forall H R Is Ψ Γ,
    Hhas_type EmptyCtx H Ψ -> Rhas_type (PsiCtx Ψ) R Γ -> iseq_has_type (PsiCtx Ψ) Is (code Γ) -> M_ok EmptyCtx H R Is.

Hint Constructors M_ok.

(** We will require some Canonical Values Lemmas in our proof of Soundness *)
Lemma Canonical_Values_Int : forall H Ψ Γ v tau,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) v tau -> tau = int -> exists n, v = ANum n.
Proof.
  intros.
  subst.
  inversion H1.
  inversion H6.
  exists n.
  crush.
Qed.

Lemma Canonical_Values_Reg :forall H Ψ Γ r R,
    Hhas_type EmptyCtx H Ψ -> Rhas_type (PsiCtx Ψ) R Γ -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int) -> exists (n : nat), R (Id r) = n.
Proof.
  intros.
  exists (R (Id r)).
  crush.
Qed.

Lemma Canonical_Values_label1 : forall H Ψ Γ v,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) ->  Ψ (Id v) = Some (code Γ) -> exists is, H (Id v) = Some is /\ iseq_has_type (PsiCtx Ψ) is (code Γ).
Proof.
  intros.
  inversion H0.
  inversion H1.
  inversion H7.
  simpl in H5.
  specialize H4 with ( l := v) (tau := code Γ).
  destruct H4 as [i G].
  exists i.
  crush.
Qed.

Lemma Canonical_Values_label2 : forall H Ψ Γ R r,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) True -> exists is, H (Id (R (Id r))) = Some is /\ iseq_has_type (PsiCtx Ψ) is (code Γ).
Proof.
  intros.
  inversion H0.
  inversion H1.
  specialize H3 with ( l := R (Id r)) (tau := (code Γ)).
  destruct H3 as [i G].
  exists i.
  apply G.
  specialize H3 with ( l := R (Id r)) (tau := (code Γ)).
  destruct H3 as [i G].
  exists i.
  crush.
 Qed.

(** Finally the proof of Soundness *)
Theorem Soundness : forall H R Is,
    M_ok EmptyCtx H R Is -> exists H' R' Is', ieval (St H R Is) (St H' R' Is') /\ M_ok EmptyCtx H' R' Is'.
Proof.
  intros.
  inversion H0 ; induction Is; inverts H4.
  induction i; inversion H12;
   try match goal with
    | [H : Γ = Γ2 |- _ ] => symmetry in H
    end;
    try subst.

  (* ISeq IMov I *)
  exists H (t_update R (Id d) (aeval a R1)) Is.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (r := d) (tau := reg tau) (a := AReg d).
  rewrite <- H16.
  rewrite update_eq.
  crush.
  crush.
  crush.
  crush.

  (* ISeq IAdd I *)
  exists H (t_update R (Id d) (aeval (AReg d) R + aeval (AReg s) R)) Is.
  split.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (a := AReg d) (r := d) (tau := reg int).
  rewrite <- H16; apply update_eq.
  crush.
  crush.
  crush.

  (* ISeq ISub I *)
  exists H (t_update R (Id d) (aeval (AReg d) R - aeval (ANum v) R)) Is.
  split.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (a := AReg d) (r := d) (tau := reg int).
  inversion H15.
  crush.
  crush.
  inversion H15.
  crush.
  inversion H7.
  trivial.
  crush.
  crush.

  (* ISeq IIf I *)
  inversion H12.
  inversion H9.
  inversion H18.
  subst.
  simpl in H22.

  remember (R (Id d)) as rd; destruct rd.
  pose proof Canonical_Values_label1 H Ψ Γ v0 H2 H9 H22 as CVL1.
  destruct CVL1 as [Is' G].
  exists H R Is'.
  crush.

  exists H R Is.

  split.
  apply R_IIf_NEQ.
  simpl.
  symmetry in Heqrd; rewrite Heqrd.
  apply beq_nat_false_iff.
  trivial.
  crush.

  (*IJmp*)
  inversion H11; inversion H12.
  simpl in H17.
  subst.
  pose proof Canonical_Values_label1 H Ψ Γ v0 H2 H11 H16 as CVL1.
  destruct CVL1 as [Is G].

  exists H R Is.
  crush.
  apply R_IJmp_Succ with (a := ALab v0).
  crush.
  crush.

  (*IJmpT*)
  pose proof Canonical_Values_label2 H Ψ Γ R v0 H2 H11 as CVL3.
  destruct CVL3 as [Is G].

  exists H R Is.
  crush.
Qed.


(* Steve Awodey's book on category theory *)
(******************************************************************************)
(* Chapter 1.3: Categories                                                    *)
(******************************************************************************)
(* @suharahiromichi *)

(*
(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

(*
(2) Proper関数の定義
A Gentle Introduction to Type Classes and Relations in Coq
*)

(*
(3) Setoid を使うようにし、Setsと(P,<=)のインスタンスをつくる。
http://www.iij-ii.co.jp/lab/techdoc/category/category1.html
 *)

(*
できるだけ Generalizable を使う。
 *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import finset fintype.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Notations.
Require Import Morphisms.
Require Import Coq.Setoids.Setoid.

(*
Reserved Notation "x ~> y" (at level 51, left associativity).
*)
Reserved Notation "x \\o y" (at level 51, left associativity).
Reserved Notation "x === y" (at level 71, left associativity).

Generalizable Variables a b c d e x.
Generalizable Variables Obj.

(* Calss Setoid (carrier : Type) とするのは難しい。なぜ？ *)
Class Setoid : Type :=
  {
    carrier : Type;
    eqv : carrier -> carrier -> Prop;
    eqv_equivalence : Equivalence eqv
  }.
Coercion carrier : Setoid >-> Sortclass.
Notation "x === y" := (eqv x y).

Class Category `(Hom : Obj -> Obj -> Setoid) : Type :=
  {
    hom := Hom where "a ~> b" := (hom a b);
    obj := Obj;
    id   : forall {a : Obj}, (a ~> a);
    comp : forall {a b c : Obj},
             (b ~> c) -> (a ~> b) -> (a ~> c)
                                       where "f \\o g" := (comp f g);
    comp_respects   : forall {a b c : Obj},
                        Proper (eqv ==> eqv ==> eqv) (@comp a b c);
    left_identity   : forall `{f : a ~> b}, id \\o f === f;
    right_identity  : forall `{f : a ~> b}, f \\o id === f;
    associativity   : forall `{f : c ~> d} `{g : b ~> c} `{h : a ~> b},
                        f \\o g \\o h === f \\o (g \\o h)
}.
Coercion obj : Category >-> Sortclass.

Notation "a ~> b"  := (hom a b).
Notation "f \\o g" := (comp f g).
(* Notation "a ~~{ C }~~> b" := (@hom _ _ C a b). *)

(* eqv が、Reflexive と Symmetric と Transitive とを満たす。 *)
Instance category_eqv_Equiv `(C : Category Obj) (a b : Obj) :
  Equivalence (@eqv (a ~> b)).
Proof.
  by apply eqv_equivalence.
Qed.

(* comp は eqv について固有関数である。 *)
Instance category_comp_Proper `(C : Category Obj) (a b c : Obj) :
  Proper (@eqv (b ~> c) ==> @eqv (a ~> b) ==> @eqv (a ~> c)) comp.
Proof.
  by apply comp_respects.
Qed.

(* 可換性についての定理を証明する。 *)
Lemma juggle1 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o g \\o h \\o k === f \\o (g \\o h) \\o k.
Proof.
  intros.
  rewrite <- associativity.
  reflexivity.
Defined.

Lemma juggle2 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o (g \\o (h \\o k)) === f \\o (g \\o h) \\o k.
Proof.
  intros.
  do ! rewrite <- associativity.
  reflexivity.
Defined.

Lemma juggle3 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o g \\o (h \\o k) === f \\o (g \\o h) \\o k.
Proof.
  intros.
  do ! rewrite <- associativity.
  reflexivity.
Defined.

Reserved Notation "x &&& y" (at level 50, left associativity).

(* 直積 *)
Class Product `{C : Category Obj} (Prod : Obj -> Obj -> Obj) : Type :=
  {
    obj' := Obj;
    proj1 : forall {a b : Obj}, (Prod a b) ~> a;
    proj2 : forall {a b : Obj}, (Prod a b) ~> b;

    (* 仲介射 *)
    mediating : forall {a b x : Obj},
                  (x ~> a) -> (x ~> b) -> (x ~> (Prod a b))
                                            where "f &&& g" := (mediating f g);

    med_commute1 : forall `(f : x ~> a) `(g : x ~> b),
                     proj1 \\o (f &&& g) === f;
    med_commute2 : forall `(f : x ~> a) `(g : x ~> b),
                     proj2 \\o (f &&& g) === g;
    med_unique : forall `(f : x ~> a) `(g : x ~> b) `(h : x ~> (Prod a b)),
                   proj1 \\o h === f ->
                   proj2 \\o h === g ->
                   h === (f &&& g)
  }.
Coercion obj': Product >-> Sortclass.
Notation "x &&& y" := (mediating x y).

Check @proj1 : ∀Obj Hom C Prod _ a b, Prod a b ~> a.
Check @proj2 : ∀Obj Hom C Prod _ a b, Prod a b ~> b.

Set Printing All.
Generalizable Variables Prod.
Definition parallel `{C : Category Obj} {Prod : Obj -> Obj -> Obj} {CP : Product Prod}
           `(f : a ~> b) `(g : c ~> d) : (Prod a c) ~> (Prod b d) :=
  let p1 := @proj1 Obj Hom C Prod CP a c in
  let p2 := @proj2 Obj Hom C Prod CP a c in
  (f \\o p1) &&& (g \\o p2).
Notation "f *** g" := (parallel f g).      (* <f,g> *)

(* **** *)
(* Sets *)
(* **** *)
Instance EquivExt : forall (A B : Set), Equivalence (@eqfun A B) := (* notu *)
  {
    Equivalence_Reflexive := @frefl A B;
    Equivalence_Symmetric := @fsym A B;
    Equivalence_Transitive := @ftrans A B
  }.

Instance EqMor : forall (A B : Set), Setoid :=
  {
    carrier := A -> B;
    eqv := @eqfun B A
  }.

Check @Category Set : (Set → Set → Setoid) → Type.
Check @Category Set EqMor : Type.
Check EqMor : Set -> Set -> Setoid.

Program Instance Sets : @Category Set EqMor.
Obligation 3.
Proof.
  rewrite /Sets_obligation_2.
  move=> homab homab' Hhomab hombc hombc' Hhombc.
  move=> x //=.
  rewrite Hhomab.
  rewrite Hhombc.
    by [].
Qed.

Check prod : (Type → Type → Type).
Check @Product Sets EqMor Sets prod.
Check Product prod : Type.

Program Instance SetsProd : @Product Sets EqMor Sets prod :=
  {
    proj1 A B := @fst A B;
    proj2 A B := @snd A B;
    mediating A B X := fun f g x => (f x, g x)
  }.
Obligation 3.
Proof.
  move: H H0.
  rewrite /Sets_obligation_2 => H1 H2 x'.
  rewrite -(H1 x').
  rewrite -(H2 x').
  by apply surjective_pairing.
Qed.

(* **** *)
(* P,<= *)
(* **** *)
Open Scope coq_nat_scope.
Search "_ <= _".
Check 0 <= 0 : Prop.

Definition eq_le m n (p q : m <= n) := True.

Instance EquivGeq : forall (m n : nat), Equivalence (@eq_le m n). (* notu *)
Proof.
    by [].
Qed.

Instance EqLe : forall (m n : nat), Setoid :=
  {
    carrier := m <= n;
    eqv := @eq_le m n
  }.

Check @Category nat : (nat → nat → Setoid) → Type.
Check EqLe : nat → nat → Setoid.
Check @Category nat EqLe.

Program Instance P_LE : @Category nat EqLe.
Obligation 2.
Proof.
    by apply (@Le.le_trans a b c).
Defined.
Obligation 3.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  move=> homab homab' Hhomab hombc hombc' Hhombc.
  by rewrite /eq_le.
Defined.
Obligation 4.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.
Obligation 5.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.
Obligation 6.
Proof.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.

Check P_LE.

Check min : nat -> nat -> nat.
Check @Product P_LE EqLe P_LE min.

Program Instance P_LE_Prod : @Product P_LE EqLe P_LE min.
Obligation 1.
Proof.
  Search (min _ _ <= _).
  by apply Min.le_min_l.
Defined.
Obligation 2.
  by apply Min.le_min_r.
Defined.
Obligation 3.
Proof.
  Search (_ <= min _ _).
  by apply Min.min_glb.
Defined.
Obligation 4.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  rewrite /P_LE_obligation_3.
  by rewrite /eq_le.
Defined.
Obligation 5.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  rewrite /P_LE_obligation_3.
  by rewrite /eq_le.
Defined.

Check P_LE_Prod.

(* an application of parallel (***) *)
Check @parallel.
Lemma parallel_min : forall (m n p q : nat),
      m <= n -> p <= q -> min m p <= min n q.
Proof.
  move=> m n p q Hmn Hpq.
  Check @parallel nat EqLe P_LE min P_LE_Prod m n Hmn p q Hpq.
    by apply: (@parallel nat EqLe P_LE min P_LE_Prod m n Hmn p q Hpq).
    Undo 1.
  Check Hmn *** Hpq.
    by apply: (Hmn *** Hpq).
Qed.
Print parallel_min.

(* END *)


(*|
##########################
Proving a property on sets
##########################

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

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

As a Coq programming experience and following my question in `here
<https://stackoverflow.com/q/52195198/9335627>`__, I'd like to know if
there is another proof, possibly shorter and without using Lemma
``subset_listpair_conserve``, for proving Lemma
``subset_listpair_consFalse``. I proved it but it is long and uses
Lemma ``subset_listpair_consve``.
|*)

Require Import List.
Require Import Bool.

Definition entity := nat.
Definition entityID := nat.
Definition listPair : Set := list (entity * entityID).

(* check if e is in list l *)
Fixpoint in_listpair e (l : listPair) :=
  match l with
  | nil          => false
  | (x, y) :: l' => Nat.eqb e x || in_listpair e l'
  end.

(* check if list l1 is in list l2: i.e., 11 entities are in l2 *)
Fixpoint subset_listpair (l1 l2 : listPair) :=
  match l1 with
  | nil => true
  | (x1, _) :: l1 => in_listpair x1 l2 && subset_listpair l1 l2
  end.

Lemma subset_listpair_consver l1 l2 l3 e :
  in_listpair e l2 = true ->
  in_listpair e l3 = false ->
  subset_listpair l1 l2 = true ->
  subset_listpair l1 l3 = false.
Proof.
Admitted.

Lemma subset_listpair_consFalse l1 l2 l3 :
  subset_listpair l1 l2 = true ->
  subset_listpair l1 l3 = false -> subset_listpair l2 l3 = false.
Proof.
  induction l1.
  - induction l3.
    + destruct l2.
      * simpl. intros. inversion H0.
      * intros. destruct p. simpl in *. reflexivity.
    + simpl in *. intros. intuition. inversion H0.
  - intros. rewrite IHl1.
    + reflexivity.
    + simpl in H0. destruct a. simpl in H.
      rewrite andb_true_iff in H. rewrite andb_false_iff in H0.
      elim H. intros. assumption.
    + simpl in H0. destruct a. simpl in H.
      rewrite andb_true_iff in H. rewrite andb_false_iff in H0.
      elim H. intros.
      * elim H0.
        -- intros. pose proof subset_listpair_consver as H10.
           assert (subset_listpair l1 l3 = false) as H11.
           ++ rewrite H10 with (l2 := l2) (e := e).
              ** reflexivity.
              ** assumption.
              ** assumption.
              ** assumption.
           ++ assumption.
        -- intro. assumption.
Qed.

(*|
Answer
******

Here is one possible solution. I didn't go for a lemma-less proof or
for the shortest proof. Instead, I tried to break down everything into
a bite-sized chunks that are (relatively) easy to manipulate.

First, here is an auxiliary lemma missing from the standard library.
It simply states the law of contraposition in classical logic (we have
decidable propositions here, so those are kind of classical).
|*)

Reset subset_listpair_consFalse. (* .none *)
From Coq Require Import Arith Bool List.

Lemma contra b1 b2 :
  (b2 = false -> b1 = false) <-> (b1 = true -> b2 = true).
Proof. destruct b1, b2; intuition. Qed.

(*| Now, we will need the following easy property: |*)

Lemma in_subset_listpair {p l1 l2} :
  in_listpair p l1 = true ->
  subset_listpair l1 l2 = true ->
  in_listpair p l2 = true.
Proof.
  induction l1 as [| [x1 y1] l1 IH]; simpl; [easy |].
  rewrite orb_true_iff, andb_true_iff. intros [->%Nat.eqb_eq |] []; trivial.
  now apply IH.
Qed.

(*| Next, we prove that ``subset`` is transitive: |*)

Lemma subset_listpair_transitive l2 l1 l3 :
  subset_listpair l1 l2 = true ->
  subset_listpair l2 l3 = true ->
  subset_listpair l1 l3 = true.
Proof.
  induction l1 as [| [x1 y1] l1 IH]; simpl; trivial.
  intros [I1 S1]%andb_prop S2. rewrite (IH S1 S2), andb_true_r.
  now apply (in_subset_listpair I1).
Qed.

(*|
And now, the target lemma, which is basically a contrapositive
statement of the transitivity property:
|*)

Lemma subset_listpair_consFalse l1 l2 l3 :
  subset_listpair l1 l2 = true ->
  subset_listpair l1 l3 = false ->
  subset_listpair l2 l3 = false.
Proof.
  intros S12. rewrite contra.
  now apply subset_listpair_transitive.
Qed.


(* Software Foundations *)
(* Exercice 3 stars, filter_exercise *)

Require Import Coq.Lists.List.
Import ListNotations.

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

Theorem filter_exercise : forall (X : Type)(test : X -> bool)(x : X)(l lf : list X),
filter test l = x :: lf -> test x = true.
Proof.
    intros. generalize dependent l. induction l as [|h t].
    simpl. intros. inversion H.
    intros. simpl in H. destruct (test h) eqn: th.
    inversion H. rewrite H1 in th. apply th.
    apply IHt in H. apply H.
Qed.


From Hammer Require Import Hammer.

From compcert Require Import Raux.
From compcert Require Import Defs.
From compcert Require Import Digits.
From compcert Require Import Generic_fmt.
From compcert Require Import Float_prop.
From compcert Require Import Bracket.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Fcalc_sqrt.

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

Variable fexp : Z -> Z.

Lemma mag_sqrt_F2R :
forall m1 e1,
(0 < m1)%Z ->
mag beta (sqrt (F2R (Float beta m1 e1))) = Z.div2 (Zdigits beta m1 + e1 + 1) :> Z.
Proof. hammer_hook "Sqrt" "Sqrt.mag_sqrt_F2R".
intros m1 e1 Hm1.
rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
apply mag_sqrt.
now apply F2R_gt_0.
Qed.

Definition Fsqrt_core m1 e1 e :=
let d1 := Zdigits beta m1 in
let m1' := (m1 * Zpower beta (e1 - 2 * e))%Z in
let (q, r) := Z.sqrtrem m1' in
let l :=
if Zeq_bool r 0 then loc_Exact
else loc_Inexact (if Zle_bool r q then Lt else Gt) in
(q, l).

Theorem Fsqrt_core_correct :
forall m1 e1 e,
(0 < m1)%Z ->
(2 * e <= e1)%Z ->
let '(m, l) := Fsqrt_core m1 e1 e in
inbetween_float beta m e (sqrt (F2R (Float beta m1 e1))) l.
Proof. hammer_hook "Sqrt" "Sqrt.Fsqrt_core_correct".
intros m1 e1 e Hm1 He.
unfold Fsqrt_core.
set (m' := Zmult _ _).
assert (0 <= m')%Z as Hm'.
{ apply Z.mul_nonneg_nonneg.
now apply Zlt_le_weak.
apply Zpower_ge_0. }
assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf.
{ rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0.
rewrite <- sqrt_mult.
unfold Rsqr, m'.
rewrite mult_IZR, IZR_Zpower by omega.
rewrite Rmult_assoc, <- 2!bpow_plus.
now replace (_ + _)%Z with e1 by ring.
now apply IZR_le.
apply Rle_0_sqr. }
generalize (Z.sqrtrem_spec m' Hm').
destruct Z.sqrtrem as [q r].
intros [Hq Hr].
rewrite Hf.
unfold inbetween_float, F2R. simpl Fnum.
apply inbetween_mult_compat.
apply bpow_gt_0.
rewrite Hq.
case Zeq_bool_spec ; intros Hr'.

rewrite Hr', Zplus_0_r, mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
now constructor.
apply IZR_le.
clear -Hr ; omega.

constructor.
split.

apply Rle_lt_trans with (sqrt (IZR (q * q))).
rewrite mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; omega.
apply sqrt_lt_1.
rewrite mult_IZR.
apply Rle_0_sqr.
rewrite <- Hq.
now apply IZR_le.
apply IZR_lt.
omega.
apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))).
apply sqrt_lt_1.
rewrite <- Hq.
now apply IZR_le.
rewrite mult_IZR.
apply Rle_0_sqr.
apply IZR_lt.
ring_simplify.
omega.
rewrite mult_IZR.
fold (Rsqr (IZR (q + 1))).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; omega.

rewrite Rcompare_half_r.
generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))).
rewrite 2!Rabs_pos_eq.
intros <-.
replace ((2 * sqrt (IZR (q * q + r))) * (2 * sqrt (IZR (q * q + r))))%R
with (4 * Rsqr (sqrt (IZR (q * q + r))))%R by (unfold Rsqr ; ring).
rewrite Rsqr_sqrt.
rewrite <- plus_IZR, <- 2!mult_IZR.
rewrite Rcompare_IZR.
replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
generalize (Zle_cases r q).
case (Zle_bool r q) ; intros Hr''.
change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
omega.
change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
omega.
rewrite <- Hq.
now apply IZR_le.
rewrite <- plus_IZR.
apply IZR_le.
clear -Hr ; omega.
apply Rmult_le_pos.
now apply IZR_le.
apply sqrt_ge_0.
Qed.

Definition Fsqrt (x : float beta) :=
let (m1, e1) := x in
let e' := (Zdigits beta m1 + e1 + 1)%Z in
let e := Z.min (fexp (Z.div2 e')) (Z.div2 e1) in
let '(m, l) := Fsqrt_core m1 e1 e in
(m, e, l).

Theorem Fsqrt_correct :
forall x,
(0 < F2R x)%R ->
let '(m, e, l) := Fsqrt x in
(e <= cexp beta fexp (sqrt (F2R x)))%Z /\
inbetween_float beta m e (sqrt (F2R x)) l.
Proof. hammer_hook "Sqrt" "Sqrt.Fsqrt_correct".
intros [m1 e1] Hm1.
apply gt_0_F2R in Hm1.
unfold Fsqrt.
set (e := Z.min _ _).
assert (2 * e <= e1)%Z as He.
{ assert (e <= Z.div2 e1)%Z by apply Z.le_min_r.
rewrite (Zdiv2_odd_eqn e1).
destruct Z.odd ; omega. }
generalize (Fsqrt_core_correct m1 e1 e Hm1 He).
destruct Fsqrt_core as [m l].
apply conj.
apply Z.le_trans with (1 := Z.le_min_l _ _).
unfold cexp.
rewrite (mag_sqrt_F2R m1 e1 Hm1).
apply Z.le_refl.
Qed.

End Fcalc_sqrt.


Require Import List.
Import ListNotations.

Require Import Logic.Class.Eq.

Require Import Logic.Lam.Syntax.

Fixpoint subst_ (v:Type) (e:Eq v) (f:v -> T v) (xs:list v) (t:T v) : T v :=
    match t with
    | Var x     =>
        match in_dec eqDec x xs with
        | left _    => Var x    (* x is deemed bound    -> Var x                *)
        | right _   => f x      (* x is deemed free     -> f x                  *)
        end
    | App t1 t2 => App (subst_ v e f xs t1) (subst_ v e f xs t2)
    | Lam x t1  => Lam x (subst_ v e f (x :: xs) t1)        (* x now bound      *)
    end.

Arguments subst_ {v} {e}.

Definition subst (v:Type) (e:Eq v) (f:v -> T v) (t:T v) : T v :=
    subst_ f [] t.

Arguments subst {v} {e}.

Lemma substVar : forall (v:Type) (e:Eq v) (f:v -> T v) (t:T v) (x:v),
    t = Var x -> subst f t = f x.
Proof. intros v e f t x H. rewrite H. reflexivity. Qed.

Lemma substApp : forall (v:Type) (e:Eq v) (f:v -> T v) (t1 t2 t:T v),
    t = App t1 t2 -> subst f t = App (subst f t1) (subst f t2).
Proof. intros v e f t1 t2 t H. rewrite H. unfold subst. simpl. reflexivity. Qed.


Inductive equivalent P Q := Equivalent (P_to_Q : P -> Q) (Q_to_P : Q -> P).

Inductive equal T (x : T) : T -> Type := Equal : equal T x x.

(* Arithmetic *)

Inductive natural := Zero | Add_1_to (n : natural).

Fixpoint add (m n : natural) : natural :=
  match m with Zero => n | Add_1_to m_minus_1 => add m_minus_1 (Add_1_to n) end.

Definition double (n : natural) : natural := add n n.

Inductive odd (n : natural) :=
  Odd (half : natural)
    (n_odd : equal natural n (Add_1_to (double half))).

Inductive less_than (m n : natural) :=
  LessThan (diff : natural)
    (m_lt_n : equal natural n (Add_1_to (add m diff))).

(* Finite subsets *)

Definition injective_in T R (D : T -> Type) (f : T -> R) :=
  forall x y, D x -> D y -> equal R (f x) (f y) -> equal T x y.

Inductive in_image T R (D : T -> Type) (f : T -> R) (a : R) :=
  InImage (x : T) (x_in_D : D x) (a_is_fx : equal R a (f x)).

Inductive finite_of_order T (D : T -> Type) (n : natural) :=
  FiniteOfOrder (rank : T -> natural)
    (rank_injective : injective_in T natural D rank)
    (rank_onto :
       forall i, equivalent (less_than i n) (in_image T natural D rank i)).

(* Constraints *)
Universes i j.
Inductive constraint1 : (Type -> Type) -> Type := mk_constraint1 : constraint1 (fun x : Type@{i} => (x : Type@{j})).
Constraint i < j.
Inductive constraint2 : Type@{j} := mkc2 (_ : Type@{i}).
Universes i' j'.
Constraint i' = j'.
Inductive constraint3 : (Type -> Type) -> Type := mk_constraint3 : constraint3 (fun x : Type@{i'} => (x : Type@{j'})).
Inductive constraint4 : (Type -> Type) -> Type
  := mk_constraint4 : let U1 := Type in
                      let U2 := Type in
                      constraint4 (fun x : U1 => (x : U2)).

Module CMP_CON.
  (* Comparison of opaque constants MUST be up to the universe graph.
     See #6798. *)
  Universe big.

  Polymorphic Lemma foo@{u} : Type@{big}.
  Proof. exact Type@{u}. Qed.

  Universes U V.

  Definition yo : foo@{U} = foo@{V} := eq_refl.
End CMP_CON.

Set Universe Polymorphism.

Module POLY_SUBTYP.

  Module Type T.
    Axiom foo : Type.
    Parameter bar@{u v|u = v} : foo@{u}.
  End T.

  Module M.
    Axiom foo : Type.
    Axiom bar@{u v|u = v} : foo@{v}.
  End M.

  Module F (A:T). End F.

  Module X := F M.

End POLY_SUBTYP.

Module POLY_IND.

  Polymorphic Inductive ind@{u v | u < v} : Prop := .

  Polymorphic Definition cst@{u v | v < u} := Prop.

End POLY_IND.


Require Export GeoCoq.Elements.OriginalProofs.lemma_rayimpliescollinear.
Require Export GeoCoq.Elements.OriginalProofs.lemma_ray2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearitypreserved.
Require Export GeoCoq.Elements.OriginalProofs.lemma_raystrict.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equalanglessymmetric :
   forall A B C a b c,
   CongA A B C a b c ->
   CongA a b c A B C.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists U V u v, (Out B A U /\ Out B C V /\ Out b a u /\ Out b c v /\ Cong B U b u /\ Cong B V b v /\ Cong U V u v /\ nCol A B C)) by (conclude_def CongA );destruct Tf as [U[V[u[v]]]];spliter.
assert (Cong b u B U) by (conclude lemma_congruencesymmetric).
assert (Cong b v B V) by (conclude lemma_congruencesymmetric).
assert (Cong v u V U) by (forward_using lemma_doublereverse).
assert (~ Col a b c).
 {
 intro.
 assert (Col b a u) by (conclude lemma_rayimpliescollinear).
 assert (Col b c v) by (conclude lemma_rayimpliescollinear).
 assert (Col B A U) by (conclude lemma_rayimpliescollinear).
 assert (Col B C V) by (conclude lemma_rayimpliescollinear).
 assert (Col a b u) by (forward_using lemma_collinearorder).
 assert (neq b a) by (conclude lemma_ray2).
 assert (neq a b) by (conclude lemma_inequalitysymmetric).
 assert (Col b u c) by (conclude lemma_collinear4).
 assert (Col c b u) by (forward_using lemma_collinearorder).
 assert (Col c b v) by (forward_using lemma_collinearorder).
 assert (neq b c) by (conclude lemma_ray2).
 assert (neq c b) by (conclude lemma_inequalitysymmetric).
 assert (Col b u v) by (conclude lemma_collinear4).
 assert (Cong u v U V) by (conclude lemma_congruencesymmetric).
 assert (Col B U V) by (conclude lemma_collinearitypreserved).
 assert (Col U B V) by (forward_using lemma_collinearorder).
 assert (Col U B A) by (forward_using lemma_collinearorder).
 assert (neq B U) by (conclude lemma_raystrict).
 assert (neq U B) by (conclude lemma_inequalitysymmetric).
 assert (Col B V A) by (conclude lemma_collinear4).
 assert (Col V B A) by (forward_using lemma_collinearorder).
 assert (Col V B C) by (forward_using lemma_collinearorder).
 assert (neq B V) by (conclude lemma_raystrict).
 assert (neq V B) by (conclude lemma_inequalitysymmetric).
 assert (Col B A C) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Cong u v U V) by (conclude lemma_congruencesymmetric).
assert (CongA a b c A B C) by (conclude_def CongA ).
close.
Qed.

End Euclid.