Require Import HoTT.
From HoTT.Categories Require Import
     Functor NaturalTransformation FunctorCategory.
From GR.bicategories Require Import
     general_category bicategory_laws.

Record LaxFunctor_d
       (C D : BiCategory)
  := Build_LaxFunctor_d
       {
         Fobj_d :> Obj C -> Obj D ;
         Fmor_d : forall (X Y : C), Functor (C⟦X,Y⟧) (D⟦Fobj_d X,Fobj_d Y⟧) ;
         Fcomp₁_d :
           forall {X Y Z : C}
                  (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧),
           Fmor_d Y Z g · Fmor_d X Y f ==> Fmor_d X Z (g · f) ;
         Fid_d : forall (X : C), id₁ (Fobj_d X) ==> Fmor_d _ _ (id₁ X)
       }.

Arguments Build_LaxFunctor_d {C D} Fobj_d Fmor_d Fcomp₁_d Fid_d.
Arguments Fobj_d {C D}.
Arguments Fmor_d {C D} _ X Y.
Local Notation "F '₀d' X" := (Fobj_d F X)%bicategory (at level 60).
Local Notation "F '₁d' f" := (Fmor_d F _ _ f)%bicategory (at level 60).
Local Notation "F '₂d' η" := (morphism_of (Fmor_d F _ _) η)%bicategory (at level 60).
Arguments Fcomp₁_d {C D} _ {X Y Z} g f.
Arguments Fid_d {C D} _ X.

Ltac make_laxfunctor := simple refine (Build_LaxFunctor_d _ _ _ _).

Record is_lax
       {C D : BiCategory}
       (F : LaxFunctor_d C D)
  := Build_is_lax
       {
         Fcomp₂_p :
           forall {X Y Z : C}
                  {g₁ g₂ : C⟦Y,Z⟧} {f₁ f₂ : C⟦X,Y⟧}
                  (η₁ : g₁ ==> g₂)
                  (η₂ : f₁ ==> f₂),
             (Fcomp₁_d F g₂ f₂)
               ∘ ((F ₂d η₁) * (F ₂d η₂))
             =
             (F ₂d (η₁ * η₂))
               ∘ (Fcomp₁_d F g₁ f₁) ;
         F_left_unit_p :
           forall {X Y : C} (f : C⟦X,Y⟧),
             left_unit (F ₁d f)
             =
             (F ₂d (left_unit f))
               ∘ Fcomp₁_d F (id₁ Y) f
               ∘ (Fid_d F Y * id₂ (F ₁d f)) ;
         F_right_unit_p :
           forall {X Y : C} (f : C⟦X,Y⟧),
             right_unit (F ₁d f)
             =
             (F ₂d (right_unit f))
               ∘ Fcomp₁_d F f (id₁ X)
               ∘ (id₂ (F ₁d f) * Fid_d F X) ;
         F_assoc_p :
           forall {W X Y Z : C}
                  (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧),
             (Fcomp₁_d F h (g · f))
               ∘ (id₂ (F ₁d h) * Fcomp₁_d F g f)
               ∘ assoc (F ₁d h) (F ₁d g) (F ₁d f)
             =
             (F ₂d (assoc h g f))
                ∘ Fcomp₁_d F (h · g) f
                ∘ (Fcomp₁_d F h g * id₂ (F ₁d f))
       }.

Arguments Build_is_lax {C D F} _ _ _ _.
Arguments Fcomp₂_p {C D F} _ {X Y Z g₁ g₂ f₁ f₂} η₁ η₂.
Arguments F_left_unit_p {C D F} _ {X Y} f.
Arguments F_right_unit_p {C D F} _ {X Y} f.
Arguments F_assoc_p {C D F} _ {W X Y Z} h g f.

Ltac make_is_lax := simple refine (Build_is_lax _ _ _ _).

Definition LaxFunctor (C D : BiCategory)
  := {F : LaxFunctor_d C D & is_lax F}.

Definition Build_LaxFunctor
           {C D : BiCategory}
           (F : LaxFunctor_d C D)
           (F_lax : is_lax F)
  : LaxFunctor C D
  := (F;F_lax).

Definition Fobj
           {C D : BiCategory}
           (F : LaxFunctor C D)
  : C -> D
  := Fobj_d F.1.

Coercion Fobj : LaxFunctor >-> Funclass.

Definition Fmor
           {C D : BiCategory}
           (F : LaxFunctor C D)
           (X Y : C)
  : Functor (C⟦X,Y⟧) (D⟦F X, F Y⟧)
  := Fmor_d F.1 X Y.

Notation "F '₁' f" := (object_of (Fmor F _ _) f) (at level 40) : bicategory_scope.
Notation "F '₂' η" := (morphism_of (Fmor F _ _) η) (at level 40) : bicategory_scope.

Definition Fmor₂_id₂
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {X Y : C}
           (f : C⟦X,Y⟧)
  : F ₂ (id₂ f) = id₂ (F ₁ f).
Proof.
  apply Fmor.
Defined.

Definition Fmor₂_vcomp
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₁ : f ==> g) (η₂ : g ==> h)
  : F ₂ (η₂ ∘ η₁) = (F ₂ η₂) ∘ (F ₂ η₁).
Proof.
  apply Fmor.
Defined.

Definition Fmor₂_inverse
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {X Y : C}
           {f g : C⟦X,Y⟧}
           (α : f ==> g)
           `{IsIsomorphism _ _ _ α}
  : F ₂ (α^-1) = (F ₂ α)^-1.
Proof.
  apply inverse_of.
Qed.

Definition Fcomp₁
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {X Y Z : C}
           (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧)
  : (F ₁ g) · (F ₁ f) ==> (F ₁ (g · f))
  := Fcomp₁_d F.1 g f.

Definition Fcomp₂
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {X Y Z : C}
           {f₁ f₂ : C⟦X,Y⟧}
           {g₁ g₂ : C⟦Y,Z⟧}
           (η₁ : g₁ ==> g₂)
           (η₂ : f₁ ==> f₂)
  : Fcomp₁ F g₂ f₂ ∘ ((F ₂ η₁) * (F ₂ η₂)) = (F ₂ (η₁ * η₂)) ∘ Fcomp₁ F g₁ f₁
  := Fcomp₂_p F.2 η₁ η₂.

Definition Fcomp
           {C D : BiCategory}
           (F : LaxFunctor C D)
           (X Y Z : C)
  : NaturalTransformation
      ((hcomp (F X) (F Y) (F Z))
         o (Functor.pair (Fmor F Y Z) (Fmor F X Y)))
      ((Fmor F X Z) o hcomp X Y Z).
Proof.
  simple refine (Build_NaturalTransformation _ _ _ _).
  - intros [g f] ; simpl in *.
    apply Fcomp₁.
  - intros [f₁ f₂] [g₁ g₂] [η₁ η₂] ; simpl in *.
    apply Fcomp₂.
Defined.

Definition Fid
           {C D : BiCategory}
           (F : LaxFunctor C D)
           (X : C)
  : id₁ (F X) ==> (F ₁ (id₁ X))
  := Fid_d F.1 X.

Definition F_left_unit
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {X Y : C}
           (f : C⟦X,Y⟧)
  : left_unit (F ₁ f)
    =
    (F ₂ (left_unit f))
      ∘ Fcomp₁ F (id₁ Y) f
      ∘ ((Fid F Y) * (id₂ (F ₁ f)))
  := F_left_unit_p F.2 f.

Definition F_right_unit
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {X Y : C}
           (f : C⟦X,Y⟧)
  : right_unit (F ₁ f)
    =
    (F ₂ (right_unit f))
      ∘ Fcomp₁ F f (id₁ X)
      ∘ ((id₂ (F ₁ f)) * (Fid F X))
  := F_right_unit_p F.2 f.

Definition F_assoc
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {W X Y Z : C}
           (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : (Fcomp₁ F h (g · f))
      ∘ ((id₂ (F ₁ h)) * (Fcomp₁ F g f))
      ∘ assoc (F ₁ h) (F ₁ g) (F ₁ f)
    =
    (F ₂ (assoc h g f))
      ∘ Fcomp₁ F (h · g) f
      ∘ ((Fcomp₁ F h g) * (id₂ (F ₁ f)))
  := F_assoc_p F.2 h g f.

Class is_pseudo
      {C D : BiCategory}
      (F : LaxFunctor C D)
  := { Fcomp_iso : forall {X Y Z : C}
                          (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧),
         IsIsomorphism (Fcomp₁ F g f) ;
       Fid_iso : forall {X : C},
         IsIsomorphism (Fid F X)
     }.

Global Instance is_hprop_is_pseudo
       `{Univalence}
       {C D : BiCategory}
       (F : LaxFunctor C D)
  : IsHProp (is_pseudo F).
Proof.
  apply hprop_allpath.
  intros x y.
  destruct x as [x1 x2], y as [y1 y2].
  assert (x1 = y1) as ->.
  { apply path_ishprop. }
  assert (x2 = y2) as ->.
  { apply path_ishprop. }
  reflexivity.
Qed.

Definition PseudoFunctor
           `{Univalence}
           (C D : BiCategory)
  : Type
  := {F : LaxFunctor C D & is_pseudo F}.

Ltac make_pseudo_functor_lax := simple refine (_;_).

Coercion PseudoFunctor_to_LaxFunctor
         `{Univalence}
         {C D : BiCategory}
         (F : PseudoFunctor C D)
  := F.1.

Global Instance ise_pseudo_pseudo_functor
       `{Univalence}
       {C D : BiCategory}
       (F : PseudoFunctor C D)
  : is_pseudo F
  := F.2.

Global Instance Fcomp₁_is_iso
       {C D : BiCategory}
       (F : LaxFunctor C D)
       `{is_pseudo _ _ F}
       {X Y Z : C}
       (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧)
  : IsIsomorphism (Fcomp₁ F g f).
Proof.
  apply Fcomp_iso.
Defined.

Definition Fcomp₁_inv
           {C D : BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
           {X Y Z : C}
           (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧)
  : (F ₁ (g · f)) ==> (F ₁ g) · (F ₁ f).
Proof.
  exact (Fcomp₁ F g f)^-1.
Defined.

Global Instance Fcomp_is_iso
       `{Funext}
       {C D : BiCategory}
       (F : LaxFunctor C D)
       `{is_pseudo _ _ F}
       {X Y Z : C}
  : @IsIsomorphism (_ -> _) _ _ (Fcomp F X Y Z).
Proof.
  apply isisomorphism_natural_transformation.
  apply _.
Defined.

Definition Fcomp₁_inv_naturality
           `{Funext}
           {C D : BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
           {X Y Z : C}
           {g₁ g₂ : C⟦Y,Z⟧} {f₁ f₂ : C⟦X,Y⟧}
           (ηg : g₁ ==> g₂) (ηf : f₁ ==> f₂)
  : Fcomp₁_inv F g₂ f₂ ∘ (F ₂ (ηg * ηf))
    =
    ((F ₂ ηg) * (F ₂ ηf)) ∘ Fcomp₁_inv F g₁ f₁
  := commutes (@morphism_inverse (_ -> _) _ _ (Fcomp F X Y Z) _) (g₁,f₁) (g₂,f₂) (ηg,ηf).

Global Instance Fid_is_iso
       {C D : BiCategory}
       (F : LaxFunctor C D)
       `{is_pseudo _ _ F}
       {X : C}
  : IsIsomorphism (Fid F X).
Proof.
  apply Fid_iso.
Defined.

Definition Fid_inv
           {C D : BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
           (X : C)
  : (F ₁ (id₁ X)) ==> id₁ (F X).
Proof.
  exact (Fid F X)^-1.
Defined.

Definition F_assoc_inv
           {C D : BiCategory}
           (F : LaxFunctor C D)
           {W X Y Z : C}
           (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : (Fcomp₁ F (h · g) f)
      ∘ ((Fcomp₁ F h g) * (id₂ (F ₁ f)))
      ∘ assoc_inv (F ₁ h) (F ₁ g) (F ₁ f)
    =
    (F ₂ (assoc_inv h g f))
      ∘ Fcomp₁ F h (g · f)
      ∘ ((id₂ (F ₁ h)) * (Fcomp₁ F g f)).
Proof.
  rewrite !vcomp_assoc.
  refine (vcomp_move_L_Mp _ _ _ _) ; simpl.
  rewrite <- !vcomp_assoc.
  refine (vcomp_move_R_pM _ _ _ _) ; simpl.
  exact (F_assoc F h g f)^.
Defined.

Definition F_left_unit_inv
           `{Funext}
           {C D : BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
           {X Y : C}
           (f : C⟦X,Y⟧)
  : left_unit_inv (F ₁ f)
    =
    ((Fid_inv F Y) * (id₂ (F ₁ f)))
      ∘ Fcomp₁_inv F (id₁ Y) f
      ∘ (F ₂ (left_unit_inv f)).
Proof.
  rewrite <- !inverse_of_left_unit.
  unfold Fcomp₁_inv, Fid_inv.
  rewrite <- id₂_inverse.
  rewrite Fmor₂_inverse.
  rewrite <- hcomp_inverse.
  rewrite <- !vcomp_inverse.
  apply path_inverse_2cell.
  rewrite <- !vcomp_assoc.
  apply F_left_unit.
Qed.

Definition F_left_unit_inv_2
           `{Funext}
           {C D : BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
           {X Y : C}
           (f : C⟦X,Y⟧)
  : F ₂ (left_unit_inv f)
    =
    (Fcomp₁ F (id₁ _) f)
      ∘ ((Fid F _) * (id₂ (F ₁ f)))
      ∘ left_unit_inv (F ₁ f).
Proof.
  rewrite (F_left_unit_inv F f).
  rewrite !vcomp_assoc.
  rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
  rewrite <- interchange ; simpl.
  rewrite vcomp_right_inverse, vcomp_right_identity.
  rewrite hcomp_id₂, vcomp_left_identity.
  rewrite <- !vcomp_assoc.
  rewrite vcomp_right_inverse.
  rewrite vcomp_left_identity.
  reflexivity.
Qed.

Definition F_right_unit_inv
           {C D : BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
           {X Y : C}
           (f : C⟦X,Y⟧)
  : right_unit_inv (F ₁ f)
    =
    ((id₂ (F ₁ f)) * (Fid_inv F X))
      ∘ Fcomp₁_inv F f (id₁ X)
      ∘ (F ₂ (right_unit_inv f)).
Proof.
  rewrite <- !inverse_of_right_unit.
  unfold Fcomp₁_inv, Fid_inv.
  rewrite <- id₂_inverse.
  rewrite Fmor₂_inverse.
  rewrite <- hcomp_inverse.
  rewrite <- !vcomp_inverse.
  apply path_inverse_2cell.
  rewrite <- !vcomp_assoc.
  apply F_right_unit.
Qed.

Record PseudoFunctor_d
       (C D : BiCategory)
  := Build_PseudoFunctor_d
       {
         PObj :> C -> D ;
         POne : forall {X Y : C},
             C⟦X,Y⟧ -> D⟦PObj X,PObj Y⟧ ;
         PTwo : forall {X Y : C} {f g : C⟦X,Y⟧},
             f ==> g -> (POne f) ==> (POne g) ;
         Pcomp_d : forall {X Y Z : C}
                           (g : C⟦Y,Z⟧)
                           (f : C⟦X,Y⟧),
             POne g · POne f ==> POne (g · f) ;
         Pid_d : forall (X : C),
             id₁ (PObj X) ==> POne (id₁ X) ;
         Pcomp_inv_d : forall {X Y Z : C}
                               (g : C⟦Y,Z⟧)
                               (f : C⟦X,Y⟧),
             POne (g · f) ==> POne g · POne f ;
         Pid_inv_d : forall (X : C),
             POne (id₁ X) ==> id₁ (PObj X)
       }.

Arguments Build_PseudoFunctor_d {C D} _ _ _ _ _ _ _.
Ltac make_pseudo_functor := simple refine (Build_PseudoFunctor_d _ _ _ _ _ _ _).
Arguments PObj {C D} _ _.
Arguments POne {C D} _ {X Y} _.
Arguments PTwo {C D} _ {X Y f g} _%bicategory.
Arguments Pcomp_d {C D} _ {X Y Z} g f.
Arguments Pid_d {C D} _ X.
Arguments Pcomp_inv_d {C D} _ {X Y Z} g f.
Arguments Pid_inv_d {C D} _ X.
Bind Scope bicategory_scope with PseudoFunctor_d.

Record is_pseudo_functor_p
       {C D : BiCategory}
       (F : PseudoFunctor_d C D)
  := Build_is_pseudo_functor {
         PTwo_id₂ : forall (X Y : C)
                           (f : C⟦X,Y⟧),
           PTwo F (id₂ f) = id₂ (POne F f) ;
         PTwo_comp :
           forall {X Y : C}
                  {f g h : C⟦X,Y⟧}
                  (η : f ==> g)
                  (ε : g ==> h),
             PTwo F (ε ∘ η) = PTwo F ε ∘ PTwo F η ;
         Pcomp_natural :
           forall {X Y Z : C}
                  {f₁ f₂ : C⟦X,Y⟧}
                  {g₁ g₂ : C⟦Y,Z⟧}
                  (η₁ : f₁ ==> f₂)
                  (η₂ : g₁ ==> g₂),
             Pcomp_d F g₂ f₂ ∘ ((PTwo F η₂) * (PTwo F η₁))
             =
             PTwo F (η₂ * η₁) ∘ Pcomp_d F g₁ f₁ ;
         Pright_unit :
           forall {X Y : C}
                  (f : C⟦X,Y⟧),
             right_unit (POne F f)
             =
             (PTwo F (right_unit f))
               ∘ Pcomp_d F f (id₁ X)
               ∘ (id₂ (POne F f) * Pid_d F X) ;
         Pleft_unit :
           forall {X Y : C}
                  (f : C⟦X,Y⟧),
             left_unit (POne F f)
             =
             (PTwo F (left_unit f))
               ∘ Pcomp_d F (id₁ Y) f
               ∘ ((Pid_d F Y) * (id₂ (POne F f))) ;
         Passoc :
           forall {W X Y Z : C}
                  (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧),
             (Pcomp_d F h (g · f))
               ∘ ((id₂ (POne F h)) * (Pcomp_d F g f))
               ∘ assoc (POne F h) (POne F g) (POne F f)
             =
             (PTwo F (assoc h g f))
               ∘ Pcomp_d F (h · g) f
               ∘ ((Pcomp_d F h g) * (id₂ (POne F f))) ;
         Pcomp_left :
           forall {X Y Z : C}
                  (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧),
             Pcomp_inv_d F g f ∘ Pcomp_d F g f = id₂ (POne F g · POne F f) ;
         Pcomp_right :
           forall {X Y Z : C}
                  (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧),
             Pcomp_d F g f ∘ Pcomp_inv_d F g f = id₂ (POne F (g · f)) ;
         Pid_left :
           forall (X : C),
             Pid_d F X ∘ Pid_inv_d F X = id₂ (POne F (id₁ X)) ;
         Pid_right :
           forall (X : C),
             Pid_inv_d F X ∘ Pid_d F X = id₂ (id₁ (F X))
       }.

Ltac make_is_pseudo := simple refine (Build_is_pseudo_functor _ _ _ _ _ _ _ _ _ _ _ _ _).

Definition Build_PseudoFunctor
           `{Univalence}
           {C D : BiCategory}
           (F : PseudoFunctor_d C D)
           (HF : is_pseudo_functor_p F)
    : PseudoFunctor C D.
Proof.
  simple refine (_;_).
  - simple refine (Build_LaxFunctor _ _).
    + make_laxfunctor.
      * exact (PObj F).
      * intros X Y.
        simple refine (Build_Functor _ _ _ _ _ _).
        ** exact (POne F).
        ** exact (@PTwo _ _ F X Y).
        ** apply HF.
        ** apply HF.
      * intros X Y Z g f ; simpl in *.
        exact (Pcomp_d F g f).
      * exact (Pid_d F).
    + make_is_lax ; intros ; simpl in * ; apply HF.
  - split.
    + intros X Y Z g f.
      simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
      * exact (Pcomp_inv_d F g f).
      * apply HF.
      * apply HF.
    + intros X.
      simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
      * exact (Pid_inv_d F X).
      * apply HF.
      * apply HF.
Defined.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import
        Coq.Bool.Bool
        Coq.ZArith.ZArith
        Coq.Lists.List
        Fiat.Common.DecideableEnsembles
        Fiat.Common.EnumType
        Fiat.Common.BoundedLookup
        Fiat.Common
        Fiat.Common.ilist
        Fiat.Common.Tactics.CacheStringConstant
        Fiat.Common.IterateBoundedIndex
        Fiat.Computation
        Bedrock.Word.

(* Decision procedures for propositions that crop up during
synthesis.*)

Lemma decides_True' {A}
  : forall a, decides true ((fun _ : A => True) a).
Proof.
  simpl; intros; exact I.
Qed.

Definition pair_eq_dec {A B}
           (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
           (B_eq_dec : forall a a' : B, {a = a'} + {a <> a'})
  : forall a a' : A * B, {a = a'} + {a <> a'}.
Proof.
  refine (fun a a' => match A_eq_dec (fst a) (fst a'), B_eq_dec (snd a) (snd a') with
                      | left _, left _ => _
                      | _, _ => _
                      end);
    decide equality.
Defined.

Definition decides_pair_eq {A B}
           (t : A -> A -> bool)
           (t' : B -> B -> bool)
           (decides_t : forall a a' : A , decides (t a a') (a = a'))
           (decides_t' : forall b b' : B , decides (t' b b') (b = b'))
  : forall ab ab' : A * B,
    decides (andb (t (fst ab) (fst ab')) (t' (snd ab) (snd ab'))) (ab = ab').
Proof.
  destruct ab; destruct ab'; simpl in *.
  pose proof (decides_t a a0);   pose proof (decides_t' b b0);
    unfold decides, If_Then_Else in *.
  destruct (t a a0);  destruct (t' b b0); simpl in *; congruence.
Qed.

Lemma decides_nat_eq :
  forall (n n' : nat),
    decides (EqNat.beq_nat n n') (n = n').
Proof.
  unfold decides, If_Then_Else; intros.
  destruct (EqNat.beq_nat n n') eqn: ? ;
    try eapply EqNat.beq_nat_true_iff;
    try eapply EqNat.beq_nat_false_iff; eauto.
Qed.

Lemma decides_word_eq {sz}:
  forall (w w' : word sz),
    decides (weqb w w') (w = w').
Proof.
  unfold decides, If_Then_Else; intros.
  destruct (weqb w w') eqn: ? ;
    unfold not; setoid_rewrite <- weqb_true_iff; congruence.
Qed.

Lemma decides_bool_eq :
  forall (b b' : bool),
    decides (eqb b b') (b = b').
Proof.
  unfold decides, If_Then_Else; intros;
    destruct b; destruct b'; simpl; congruence.
Qed.

Lemma decides_unit_eq :
  forall (b b' : unit),
    decides true (b = b').
Proof.
  unfold decides, If_Then_Else; intros;
    destruct b; destruct b'; simpl; congruence.
Qed.

Lemma decides_Fin_eq {n} :
  forall (b b' : Fin.t n),
    decides (fin_eq_dec b b') (b = b').
Proof.
  unfold decides, If_Then_Else; intros;
    destruct (fin_eq_dec b b'); simpl; congruence.
Qed.

Lemma decides_EnumType_eq {A} {n} {tags} :
  forall (b b' : @EnumType n A tags),
    decides (fin_beq b b') (b = b').
Proof.
  unfold decides, If_Then_Else; intros.
  destruct (fin_beq b b') eqn: H' ;
    unfold not; intros;
      try rewrite fin_beq_dec in H';
      try rewrite fin_beq_neq_dec in H'; eauto.
Qed.

Lemma firstn_app {A}
  : forall (l1 l2 : list A),
    firstn (length l1) (l1 ++ l2) = l1.
Proof.
  induction l1; intros; simpl; eauto.
  f_equal; eauto.
Qed.

Lemma decides_firstn_app {A}
  : forall (l1 l2 : list A),
    decides true (firstn (length l1) (l1 ++ l2) = l1).
Proof.
  apply firstn_app.
Qed.

Lemma firstn_self {A}
  : forall (l1 : list A),
    firstn (length l1) l1 = l1.
Proof.
  induction l1; intros; simpl; eauto.
  f_equal; eauto.
Qed.

Lemma decides_firstn_self {A}
  : forall (l1 : list A),
    decides true (firstn (length l1) l1 = l1).
Proof.
  intros; apply firstn_self.
Qed.

Lemma skipn_app {A}
  : forall (l1 l2 : list A),
    skipn (length l1) (l1 ++ l2) = l2.
Proof.
  induction l1; intros; simpl; eauto.
Qed.

Lemma decides_skipn_app {A}
  : forall (l1 l2 : list A),
    decides true (skipn (length l1) (l1 ++ l2) = l2).
Proof.
  apply skipn_app.
Qed.

Lemma firstn_skipn_app {A}
  : forall (l1 l2 l3 : list A),
    firstn (length l3) (skipn (length l1 + length l2) (l1 ++ l2 ++ l3)) = l3.
Proof.
  simpl; intros.
  rewrite <- app_length, List.app_assoc, skipn_app.
  apply firstn_self.
Qed.

Lemma decides_firstn_skipn_app {A}
  : forall (l1 l2 l3 : list A),
    decides true (firstn (length l3) (skipn (length l1 + length l2) (l1 ++ l2 ++ l3)) = l3).
Proof.
  intros; apply firstn_skipn_app.
Qed.

Lemma firstn_skipn_self' {A}
  : forall (n m o : nat) (l : list A),
    length l = n + m + o
    -> (firstn n l ++ firstn m (skipn n l) ++ firstn o (skipn (n + m) l))%list =
       l.
Proof.
  induction n; simpl.
  induction m; simpl; eauto.
  induction o; simpl.
  destruct l; simpl; eauto.
  intros; discriminate.
  destruct l; simpl; eauto.
  intros; f_equal; eauto.
  destruct l; simpl.
  intros; discriminate.
  intros; f_equal; eauto.
  destruct l; simpl.
  intros; discriminate.
  intros; f_equal; eauto.
Qed.

Lemma firstn_skipn_self'' {A}
  : forall (n m o : nat) (l : list A),
    length l = n + m + o
    ->
    decides true ((firstn n l ++ firstn m (skipn n l) ++ firstn o (skipn (n + m) l))%list =
                  l).
Proof.
  intros; eapply firstn_skipn_self'.
  omega.
Qed.

Lemma word_eq_self
  : forall (w : word 1),
    decides true (WS (whd w) WO = w).
Proof.
  simpl; intros; shatter_word w; reflexivity.
Qed.

Lemma firstn_lt_decides {A}:
  forall m n (l : list A),
    (lt m n)%nat
    -> decides true (lt (length (firstn m l)) n)%nat.
Proof.
  simpl; intros; rewrite firstn_length.
  eapply NPeano.Nat.min_lt_iff; eauto.
Qed.

Lemma whd_word_1_refl' :
  forall (b : word 1),
    decides true (WS (whd b) WO = b).
Proof.
  intros; destruct (shatter_word_S b) as [? [? ?] ]; subst.
  rewrite (shatter_word_0 x0); reflexivity.
Qed.

Lemma length_firstn_skipn_app {A}
  : forall (n m o : nat) (l : list A),
    length l = n + m + o
    -> (length (firstn m (skipn n l) )) = m.
Proof.
  induction n; simpl.
  induction m; simpl; eauto.
  induction o; simpl.
  destruct l; simpl; eauto.
  intros; discriminate.
  destruct l; simpl; eauto.
  intros; discriminate.
  intros; f_equal; eauto.
  destruct l; simpl.
  intros; discriminate.
  intros; f_equal; eauto.
Qed.

Lemma decides_length_firstn_skipn_app {A}
  : forall (n m o : nat) (l : list A),
    length l = n + (m + o)
    -> decides true (length (firstn m (skipn n l) ) = m).
Proof.
  intros.
  rewrite length_firstn_skipn_app with (o0 := o);
    simpl; omega.
Qed.

Lemma length_firstn_skipn_app' {A}
  : forall (n m o : nat) (l : list A),
    length l = n + m + o
    -> length (firstn o (skipn (n + m) l)) = o.
Proof.
  induction n; simpl.
  induction m; simpl; eauto.
  induction o; simpl.
  destruct l; simpl; eauto.
  destruct l; simpl; eauto.
  destruct l; simpl; eauto.
  intros; discriminate.
  intros; f_equal; eauto.
  destruct l; simpl.
  intros; discriminate.
  intros; f_equal; eauto.
Qed.

Lemma decides_length_firstn_skipn_app' {A}
  : forall (n m o : nat) (l : list A),
    length l = n + (m + o)
    -> decides true (length (firstn o (skipn (n + m) l) ) = o).
Proof.
  intros; rewrite length_firstn_skipn_app'; simpl; omega.
Qed.

Lemma length_firstn_skipn_app'' {A}
  : forall (n m o : nat) (l : list A),
    length l = n + m + o
    -> length (firstn n l) = n.
Proof.
  induction n; destruct l; simpl; intros;
    try discriminate; eauto.
Qed.

Lemma decides_length_firstn_skipn_app'' {A}
  : forall (n m o : nat) (l : list A),
    length l = n + (m + o)
    -> decides true (length (firstn n l ) = n).
Proof.
  intros; erewrite length_firstn_skipn_app'' with (o0 := o) (m0 := m);
    simpl; omega.
Qed.

Lemma lt_1_pow2_16
  : lt 1 (pow2 16).
Proof.
  intros.
  rewrite <- (wordToNat_natToWord_idempotent 16 1).
  eapply wordToNat_bound.
  simpl; eapply BinNat.N.ltb_lt; reflexivity.
Qed.

Lemma decides_Option_eq_None {B}
  : forall (s_opt : option B) b,
    (Ifopt s_opt as _ Then true Else false) = b
    -> decides (negb b) (s_opt = None).
Proof.
  intros; destruct s_opt; simpl in *; subst;
    simpl in *; congruence.
Qed.

Lemma firstn_skipn_self {A}
  : forall (n m o : nat) (l l1 l2 l3 : list A),
    (l1 ++ l2 ++ l3)%list = l ->
    length l1 = n ->
    length l2 = m ->
    length l3 = o ->
    l1 = firstn n l
    /\ l2 = firstn m (skipn n l)
    /\ l3 = firstn o (skipn (n + m) l).
Proof.
  intros; subst; intuition;
    eauto using firstn_skipn_app, skipn_app, firstn_app.
  rewrite skipn_app; symmetry; apply firstn_app.
Qed.


Require Export Coq.Program.Equality.
Require Export Omega.

(* Hints for invoking omega on arithmetic subgoals. *)

Hint Extern 1 (_ = _ :> nat) => omega.
Hint Extern 1 (_ <> _ :> nat) => omega.
Hint Extern 1 (_ = _ :> Z) => omega.
Hint Extern 1 (_ <> _ :> Z) => omega.
Hint Extern 1 (_ < _) => omega.
Hint Extern 1 (_ > _) => omega.
Hint Extern 1 (_ <= _) => omega.
Hint Extern 1 (_ >= _) => omega.

(* Dealing with if *)

Ltac case_if :=
  let H := fresh in
  match goal with
  | |- context [if ?b then _ else _] =>
    destruct b eqn:H
  | h: context [if ?b then _ else _] |- _ =>
    destruct b eqn:H
  end.

(* Hypothesis handling *)

Ltac applyin H :=
  match goal with h: _ |- _ => apply H in h end.

Ltac spec1 H :=
  lazymatch type of H with
  | ?A -> ?B =>
    let a := fresh in
    assert (a : A); [ eauto | specialize (H a); clear a ]
  | forall x : ?A, _ =>
    let a := fresh in
    evar (a : A);
    specialize (H a); subst a
  end.

Ltac spec H :=
  repeat (spec1 H; []).

(* This tactic unpacks all existentially quantified hypotheses and splits all
   conjunctive hypotheses. *)

Ltac unpack1 :=
  match goal with
  | h: ex _ |- _ => destruct h
  | h: (_ /\ _) |- _ => destruct h
  | h: exists2 _, _ & _ |- _ => destruct h
  end.

Tactic Notation "unpack" :=
  repeat progress unpack1.

Goal
  forall (P Q : nat -> Prop),
  (exists n, P n /\ Q n) ->
  (exists n, Q n /\ P n).
Proof.
  intros. unpack. eauto.
Qed.

(* This variant is analogous, but attacks only one hypothesis, whose name is
   specified. *)

Ltac named_unpack h :=
  generalize h; clear h;
  match goal with
  | |- ex _ -> _ => intros [ ? h ]; named_unpack h
  | |- (_ /\ _) -> _ => intros [ ? h ]; named_unpack h
  | |- _ -> _ => intro h
  end.

Tactic Notation "unpack" hyp(h) := named_unpack h.

Goal
  forall (P Q : nat -> Prop),
  (exists n, P n /\ Q n) ->
  (exists n, Q n /\ P n).
Proof.
  intros ? ? h. unpack h. eauto.
Qed.

(* This variant is analogous, but attacks a term. *)

Ltac term_unpack t :=
  let h := fresh in
  generalize t; intro h; named_unpack h.

Tactic Notation "unpack" constr(t) := term_unpack t.

Goal
  forall (P Q : nat -> Prop) (x : nat),
  x = 0 ->
  (x = 0 -> exists n, P n /\ Q n) ->
  (exists n, Q n /\ P n).
Proof.
  intros ? ? ? z h. unpack (h z). unpack h. eauto.
Qed.

(* Turn some tactics into hints. *)

Hint Extern 1 => f_equal : f_equal.

Hint Extern 1 => congruence : congruence.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable ltA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defanglelessthan_1 : (forall A B C D E F : Universe, (exists U X V : Universe, (ltA_ A B C D E F -> (betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X)))))).
Variable defanglelessthan2_2 : (forall A B C D E F U X V : Universe, ((betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X))) -> ltA_ A B C D E F)).
Variable lemma_equalanglesNC_3 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable defsupplement_4 : (forall A B C D F : Universe, (supp_ A B C D F -> (out_ B C D /\ betS_ A B F))).
Variable defsupplement2_5 : (forall A B C D F : Universe, ((out_ B C D /\ betS_ A B F) -> supp_ A B C D F)).
Variable axiom_betweennesssymmetry_6 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_ray1_7 : (forall A B P : Universe, (out_ A B P -> (betS_ A P B \/ (B = P \/ betS_ A B P)))).
Variable axiom_innertransitivity_8 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A B C)).
Variable lemma_3_7b_9 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ B C D) -> betS_ A B D)).
Variable lemma_rayimpliescollinear_10 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable defcollinear_11 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_12 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_13 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_14 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_15 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_16 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_17 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_betweennotequal_18 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_collinearorder_19 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_collinear4_20 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_inequalitysymmetric_21 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_raystrict_22 : (forall A B C : Universe, (out_ A B C -> A <> C)).
Variable postulate_Pasch_inner_23 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B Q C /\ ~(col_ A C B))) -> (betS_ A X Q /\ betS_ B X P)))).
Variable lemma_ray4_1_24 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_25 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_26 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_equalanglessymmetric_27 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_supplements_28 : (forall A B C D F Xa Xb Xc Xd Xf : Universe, ((congA_ A B C Xa Xb Xc /\ (supp_ A B C D F /\ supp_ Xa Xb Xc Xd Xf)) -> congA_ D B F Xd Xb Xf)).
Variable lemma_equalanglesreflexive_29 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_ray5_30 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_equalangleshelper_31 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable lemma_equalanglesflip_32 : (forall A B C D E F : Universe, (congA_ A B C D E F -> congA_ C B A F E D)).
Variable lemma_angleorderrespectscongruence_33 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ congA_ P Q R D E F) -> ltA_ A B C P Q R)).
Variable lemma_ray3_34 : (forall B C D V : Universe, ((out_ B C D /\ out_ B C V) -> out_ B D V)).
Variable lemma_ABCequalsCBA_35 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_36 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_angleorderrespectscongruence2_37 : (forall A B C D E F Xa Xb Xc : Universe, ((ltA_ A B C D E F /\ congA_ Xa Xb Xc A B C) -> ltA_ Xa Xb Xc D E F)).

Theorem lemma_supplementinequality_38 : (forall A B C D F Xa Xb Xc Xd Xf : Universe, ((supp_ A B C D F /\ (supp_ Xa Xb Xc Xd Xf /\ ltA_ Xa Xb Xc A B C)) -> ltA_ D B F Xd Xb Xf)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Program.Equality.
Require Export Memory.

Definition is_preorder {Conf} (pre : Conf -> Conf -> Prop) : Prop
  := (forall c, pre c c) /\ (forall c1 c2 c3, pre c1 c2 -> pre c2 c3 -> pre c1 c3).

Definition monotonicity {Conf}
           (pre : Conf -> Conf -> Prop) (vm : Conf -> Conf -> Prop) :
     Prop := forall (C1 C1' C2 : Conf),
  pre C1 C1' ->
  vm C1 C2 ->
  exists C2', vm C1' C2' /\ pre C2 C2'.

Ltac prove_preorder :=
  split;[
    intros c; destruct c;
    repeat
      (match goal with
       | [H : _ * _ |- _] => destruct H
       end);
      eauto with memory
  | intros c1 c2 c3 L1 L2; destruct c1, c2, c3;
    inversion L1; inversion L2; subst;
    repeat
      (match goal with
       | [H : (_, _) = (_, _) |- _] => inversion H; clear H
       end); subst;
    eauto with memory].

Ltac prove_monotonicity1 :=
  do 3 intro; intros Hle Step;
  dependent destruction Step; inversion Hle.

Ltac prove_monotonicity2 := subst;
  eexists; (split; [try solve [econstructor; eauto with memory]| eauto with memory]).

Ltac prove_monotonicity := prove_monotonicity1; prove_monotonicity2.

Module Type Machine.
Parameter Conf : Type.
Parameter Pre : Conf -> Conf -> Prop.
Parameter Rel : Conf -> Conf -> Prop.
Parameter preorder : is_preorder Pre.
Parameter monotone : monotonicity Pre Rel.
End Machine.

Require Import List.
Require Import Relations.

Module MetaTheory (machine : Machine).
Export machine.
Import ListNotations.

Declare Scope machine_scope.
Infix "==>" := Rel(at level 80, no associativity) : machine_scope.

Definition trc := clos_refl_trans Conf Rel.

Infix "=>>" := trc (at level 80, no associativity) : machine_scope.

Open Scope machine_scope.

Lemma trc_refl c : c =>> c.
Proof. apply rt_refl. Qed.

Lemma trc_step c1 c2 : c1 ==> c2 -> c1 =>> c2.
Proof. apply rt_step. Qed.

Lemma trc_step_trans c1 c2 c3 : c1 =>> c2 -> c2 ==> c3 -> c1 =>> c3.
Proof. intros. eapply rt_trans; eauto using rt_step. Qed.

Lemma trc_step_trans' c1 c2 c3 : c1 ==> c2 -> c2 =>> c3 -> c1 =>> c3.
Proof. intros. eapply rt_trans; eauto using rt_step. Qed.

Lemma trc_trans c1 c2 c3 : c1 =>> c2 -> c2 =>> c3 -> c1 =>> c3.
Proof. apply rt_trans. Qed.

Hint Resolve trc_step trc_step_trans : core.
Hint Immediate trc_refl : core.

Lemma trc_ind' :
forall P : Conf -> Conf -> Prop,
(forall c : Conf, P c c) ->
(forall c1 c2 c3 : Conf, c1 ==> c2 -> c2 =>> c3 -> P c2 c3 -> P c1 c3) ->
forall c c0 : Conf, c =>> c0 -> P c c0.
Proof.
  intros X Y Z c1 c2 S. unfold trc in S. rewrite -> clos_rt_rt1n_iff in S.
  induction S; eauto. rewrite <- clos_rt_rt1n_iff in S. eauto.
Qed.

Infix "⊑" := Pre  (at level 70) : machine_scope.
Notation "x ⊒ y" := (Pre y x) (at level 70) : machine_scope.

Lemma cle_trans (C1 C2 C3 : Conf) : C1 ⊑ C2 -> C2 ⊑ C3 -> C1 ⊑ C3.
Proof.
  intros. pose preorder as P. unfold is_preorder in *. destruct P. eauto.
Qed.
Lemma cle_refl (C : Conf) : C ⊑ C.
Proof.
  intros. pose preorder as P. unfold is_preorder in *. destruct P. eauto.
Qed.

Hint Resolve cle_refl : core.

Lemma monotone_step (C1 C1' C2 : Conf) :
  C1 ⊑ C1' ->
  C1 ==> C2 ->
  exists C2', C1' ==> C2' /\ C2 ⊑ C2' .
Proof.
  intros. pose monotone as M. unfold monotonicity in M. eauto.
Qed.

Lemma monotone_machine (C1 C1' C2 : Conf) :
  C1 ⊑ C1' ->
  C1 =>> C2 ->
  exists C2', C1' =>> C2' /\ C2 ⊑ C2' .
Proof.
  intros I M. generalize dependent C1'. dependent induction M using trc_ind';intros.
  - exists C1'. split; eauto.
  - eapply monotone_step in I; eauto. destruct I as [m2' HS]. destruct HS as [S Ic'].
    apply IHM in Ic'. destruct Ic'. destruct H0. eexists. split. eapply trc_step_trans'; eassumption. assumption.
Qed.

Definition Reach (C1 C2 : Conf) : Prop := exists C, C1 =>> C /\ C ⊒ C2.

Infix "=|>" := Reach (at level 80, no associativity).

Lemma Reach_refl C : C =|> C.
Proof.
  exists C. split; auto.
Qed.

Hint Resolve Reach_refl : core.

Lemma Reach_eq C1 C2 : C1 = C2 -> C1 =|> C2.
Proof.
  intros. subst. auto.
Qed.

Lemma Reach_trans C1 C2 C3 : C1 =|> C2 -> C2 =|> C3 -> C1 =|> C3.
Proof.
  intros L1 L2.
  destruct L1 as [C1' L1]. destruct L1 as [S1 M1].
  destruct L2 as [C2' L2]. destruct L2 as [S2 M2].
  eapply monotone_machine in S2;[|eassumption]. destruct S2 as [C3' G]. destruct G as [S2' M2'].
  eexists. split.
  - eapply trc_trans. apply S1. apply S2'.
  - eapply cle_trans;eassumption.
Qed.

Lemma Reach_cle C1 C2 : C1 ⊒ C2 -> C1 =|> C2.
Proof.
  intros L. eexists. split. apply trc_refl. assumption.
Qed.

Lemma Reach_trc C1 C2 : C1 =>> C2 -> C1 =|> C2.
Proof.
  intros L. eexists. split. eassumption. apply cle_refl.
Qed.

Lemma Reach_vm C1 C2 : C1 ==> C2 -> C1 =|> C2.
Proof.
  intros L. apply Reach_trc. apply trc_step. assumption.
Qed.

Definition determ {A} (R : A -> A -> Prop) : Prop := forall C C1 C2, R C C1 -> R C C2 -> C1 = C2.

Definition trc' C C' :=  C =>> C' /\ ~ exists C'', C' ==> C''.

Notation "x =>>! y" := (trc' x y) (at level 80, no associativity).

Lemma determ_factor C1 C2 C3 : determ Rel -> C1 ==> C2 -> C1 =>>! C3 -> C2 =>> C3.
Proof.
  unfold determ. intros. destruct H1.
  destruct H1 using trc_ind'.
  - exfalso. apply H2. eexists. eassumption.
  - assert (c2 = C2). eapply H. apply H1. apply H0. subst. auto.
Qed.

Lemma determ_trc : determ Rel -> determ trc'.
Proof.
  intros. unfold determ. intros. destruct H0. induction H0 using trc_ind'.
  - destruct H1. destruct H0 using trc_ind'. reflexivity. exfalso. apply H2. eexists. eassumption.
  - apply IHtrc. apply H2. split. eapply determ_factor; eassumption. destruct H1. assumption.
Qed.
End MetaTheory.


Require Export Coq.Logic.FunctionalExtensionality.
Require Export Coq.Logic.PropExtensionality.
Require Coq.Logic.Description.
Require Coq.Logic.Classical_Prop.

Require Import Tactics.
Require Import Sigma.

Ltac fextensionality :=
  fun n =>
    (match n with
     | 0 => idtac
     | S ?n' =>
         let x := fresh "x"
         in
           apply FunctionalExtensionality.functional_extensionality_dep;
           intro x;
           fextensionality n';
           revert x
     end).

Ltac pextensionality := apply propositional_extensionality; split.

Lemma UIP :
  forall (A : Type) (x y : A) (p1 p2 : x = y),
    p1 = p2.
Proof.
intros A x y p1 p2.
apply proof_irrelevance.
Qed.

Hint Resolve UIP : uip.

Lemma description :
  forall (A : Type) (P : A -> Prop),
    (exists! x, P x)
    -> exT A P.
Proof.
intros A P H.
pose proof (Coq.Logic.Description.constructive_definite_description P H) as (x & Hx).
exists x.
auto.
Qed.

Lemma choice :
  forall (A B : Type) (P : A -> B -> Prop),
    (forall x, exists! y, P x y)
    -> existsT (f : A -> B), forall x, P x (f x).
Proof.
intros A B P Hex.
exists (fun x => pi1 (description _ (P x) (Hex x))).
intro x.
exact (pi2 (description _ (P x) (Hex x))).
Qed.

Lemma description_beta :
  forall A (P : A -> Prop) (x : A) (H : unique P x),
    pi1 (description A P (ex_intro _ x H)) = x.
Proof.
intros A P x Huniq.
symmetry.
pose proof Huniq as (_ & Honly).
apply Honly.
exact (pi2 (description A P (ex_intro (unique P) x Huniq))).
Qed.

(* used in SemanticsGuard and Lattice *)
Definition excluded_middle := Coq.Logic.Classical_Prop.classic.
Definition proof_by_contradiction := Coq.Logic.Classical_Prop.NNPP.


Require Export Undecidability.Shared.Prelim.

(** * TM to SRH *)

(* ** More preliminaries, with definition of finite types *)

Definition dec (X: Prop) : Type := {X} + {~ X}.
Coercion dec2bool P (d: dec P) := if d then true else false.
Existing Class dec.
Definition Dec (X: Prop) (d: dec X) : dec X := d.
Arguments Dec X {d}.

Hint Extern 4 =>  (* Improves type class inference *)
match goal with
  | [  |- dec ((fun _ => _) _) ] => cbn
end : typeclass_instances.

Tactic Notation "decide" constr(p) :=
  destruct (Dec p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (Dec p) as i.
Tactic Notation "decide" "_" :=
  destruct (Dec _).

Notation "'eq_dec' X" := (forall x y : X, dec (x=y)) (at level 70).

Structure eqType := EqType {
  eqType_X :> Type;
  eqType_dec : eq_dec eqType_X }.

Arguments EqType X {_} : rename.
Canonical Structure eqType_CS X (A: eq_dec X) := EqType X.
Existing Instance eqType_dec.

Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  unfold dec. decide equality.
Defined.

(** The definitions of finite types are adopted from the Bachelor Thesis of Jan Menz. (https://www.ps.uni-saarland.de/~menz/bachelor.php) *)

Fixpoint count (X: Type) `{eq_dec X}  (A: list  X) (x:  X) {struct A} : nat :=
  match A with
  | nil => O
  | cons y A' =>  if Dec (x=y) then S(count A' x) else count A' x end.

Class finTypeC  (type:eqType) : Type := FinTypeC {
                                            enum: list type;
                                            enum_ok: forall x: type, count enum x = 1
                                          }.

Structure finType : Type := FinType {
                                type:> eqType;
                                class: finTypeC type }.

Arguments FinType type {class}.
Existing Instance class | 0.

Canonical Structure finType_CS (X : Type) {p : eq_dec X} {class : finTypeC (EqType X)} : finType := FinType (EqType X).

Definition elem (F: finType) := @enum (type F) (class F).
Hint Unfold elem.
Hint Unfold class.

Ltac dec := repeat (destruct Dec).

Lemma countIn (X:eqType) (x:X) A:
  count A x > 0 -> x el A.
Proof.
  induction A.
  - cbn. omega.
  - cbn. dec.
    + intros. left. symmetry. exact e.
    + intros. right. apply IHA. exact H.
Qed.

Lemma elem_spec (X: finType) (x:X) : x el (elem X).
Proof.
  apply countIn.  pose proof (enum_ok x) as H. unfold elem. omega.
Qed.

Hint Resolve elem_spec.
Hint Resolve enum_ok.

Lemma countSplit (X: eqType) (A B: list X) (x: X)  : count A x + count B x = count (A ++ B) x.
Proof.
  induction A.
  - reflexivity.
  - cbn. decide (x=a).
    +cbn. f_equal; exact IHA.
    + exact IHA.
Qed.

Fixpoint pos (X : eqType) (x : X) (A : list X) :=
  match A with
  | [] => None
  | a :: A => if Dec (x = a) then Some 0 else match pos x A with Some n => Some (S n) | None => None end
  end.

Definition pos_el' (X : eqType) (x : X) (A : list X) (H : x el A) : {n | pos x A = Some n}.
Proof.
  induction A.
  - inv H.
  - decide (x = a).
    + subst. exists 0. cbn. decide (a = a); congruence.
    + destruct IHA; try firstorder congruence.
      exists (S x0). cbn. decide (x = a); rewrite ?e; congruence.
Defined.

Lemma pos_length (X : eqType) (x : X) A n :
  pos x A = Some n -> n < |A|.
Proof.
  revert n; induction A; cbn; intros.
  - inv H.
  - decide (x = a).
    + inv H. omega.
    + destruct (pos x A) eqn:E; inv H. specialize (IHA n1 eq_refl). omega.
Qed.

Lemma pos_nth (X : eqType) (x : X) A n :
  pos x A = Some n -> nth_error A n = Some x.
Proof.
  revert n; induction A; cbn; intros.
  - inv H.
  - decide (x = a).
    + now inv H.
    + destruct (pos x A) eqn:E; inv H. cbn. eauto.
Qed.

Definition pos_el (X : eqType) (x : X) (A : list X) (H : x el A) := proj1_sig (pos_el' H).

Definition index (X : finType) (x : X) := pos_el (elem_spec x).

Lemma map_app_inv X Y (f : X -> Y) x y z :
  map f x = y ++ z -> exists x' x'', x = x' ++ x'' /\ map f x' = y /\ map f x'' = z.
Proof.
  revert x; induction y; cbn; intros.
  - exists [], x. firstorder.
  - destruct x; inv H.
    destruct (IHy _ H2) as (x' & x'' & -> & <- & <-).
    exists (x :: x'), (x''). firstorder.
Qed.

Lemma pos_inj (X : eqType) (x y : X) (A : list X) n :
  pos x A = Some n -> pos y A = Some n -> x = y.
Proof.
  revert n; induction A; cbn; intros.
  - inv H.
  - decide (x = a); decide (y = a); subst; try congruence.
    + inv H. destruct (pos y A); inv H0.
    + inv H0. destruct (pos x A); inv H.
    + destruct (pos x A), (pos y A); inv H; inv H0. eauto.
Qed.

Lemma inj_index (X : finType) : Injective (@index X).
Proof.
  intros ? ? ?. unfold index, pos_el in *.
  do 2 destruct pos_el'. cbn in H. subst. eapply pos_inj; eauto.
Qed.

(** ** Definition of single-tape Turing Machines  *)
(** Adopted definitions from the formalization of Multitape Turing Machines taken from Asperti, Riciotti "Formalizing Turing Machines" and accompanying Matita foramlisation *)

Section Fix_Sigma.

  Variable sig : finType.

  Global Instance eq_dec_sig: eq_dec sig.
  Proof. exact _. Defined.

  (* *** Definition of the tape *)

  (** A tape is essentially a triple âŒ©left,current,rightâŒª where however the current
symbol could be missing. This may happen for three different reasons: both tapes
are empty; we are on the left extremity of a non-empty tape (left overflow), or
we are on the right extremity of a non-empty tape (right overflow). *)

  Inductive tape : Type :=
  | niltape : tape
  | leftof : sig -> list sig -> tape
  | rightof : sig -> list sig -> tape
  | midtape : list sig -> sig -> list sig -> tape.

  Global Instance eq_dec_tape: eq_dec tape.
  Proof. unfold dec. decide equality; decide (e=e0); decide (l=l0); auto;
           decide (l= l1); decide (l0=l2); auto.
  Defined.

  Definition tapeToList (t : tape) : list sig :=
    match t with
    | niltape => []
    | leftof s r => s :: r
    | rightof s l => List.rev (s :: l)
    | midtape l c r => (List.rev l) ++ [c] ++ r
    end.

  Definition sizeOfTape t := |tapeToList t|.

  (* symbol under head *)
  Definition current :=
    fun (t : tape) =>
      match t with
      | midtape _ c _ => Some c
      | _ => None
      end.

  (* symbol-list left of head *)
  Definition left :=
    fun (t : tape) =>
      match t with
      | niltape => []
      | leftof _ _ => []
      | rightof s l => s :: l
      | midtape l _ _ => l
      end.

  (* symbol-list right of head *)
  Definition right :=
    fun (t : tape) =>
      match t with
      | niltape => []
      | leftof s r => s :: r
      | rightof _ _ => []
      | midtape _ _ r => r
      end.

  (* makes a tape from left, current, right *)
   Definition mk_tape ls c rs :=
    match c with
    | Some c => midtape ls c rs
    | None => match ls with
             | List.nil => match rs with
                     | List.nil => niltape
                     | r :: rs => leftof r rs
                     end
             | l :: ls => rightof l ls
             end
    end.

  (* *** Definition of moves *)

  Inductive move : Type := L : move | R : move | N : move.

  Global Instance move_eq_dec : eq_dec move.
  Proof.
    intros. hnf. decide equality.
  Defined.

  Global Instance move_finC : finTypeC (EqType move).
  Proof.
    apply (FinTypeC (enum := [L; R; N])).
    intros []; now cbv.
  Qed.

  (* *** Definition of a Sigletape Turing Machine *)

  Record sTM : Type :=
    {
      states : finType; (* states of the TM *)
      trans : states * (option sig) -> states * ((option sig) * move); (* the transition function *)
      start: states; (* the start state *)
      halt : states -> bool (* decidable subset of halting states *)
    }.

  (* Definition of tape movements *)

  Definition tape_move_right :=
    fun (t : tape) =>
      match t with
        niltape => niltape
      | rightof _ _ =>t
      | leftof a rs => midtape  [ ] a rs
      | midtape ls a rs =>
        match rs with
          []  => rightof  a ls
        | a0 :: rs0 => midtape (a::ls) a0 rs0
        end
      end.

  Definition tape_move_left :=
    fun (t : tape) =>
      match t with
        niltape => niltape
      | leftof _ _ => t
      | rightof a ls => midtape ls a [ ]
      | midtape ls a rs =>
        match ls with
          [] => leftof a rs
        | a0 :: ls0 => midtape ls0 a0 (a::rs)
        end
      end.

  Definition tape_move := fun (t : tape) (m : move) =>
                            match m with  R => tape_move_right t | L => tape_move_left t | N => t end.

  (* Writing on the tape *)

  Definition tape_write := fun (t : tape) (s : option sig) =>
                             match s with
                               None => t
                             | Some s0 => midtape (left t) s0 (right t)
                             end.

  (** A single step of the machine *)

  Definition tape_move_mono := fun (t : tape) (mv : option sig * move) =>
                                 tape_move (tape_write t (fst mv)) (snd mv).

  (* *** Configurations of TM *)

  Record mconfig (states:finType) : Type :=
    mk_mconfig
      {
        cstate : states;
        ctape : tape
      }.

  Instance eq_dec_conf (s: finType): eq_dec (mconfig s).
  Proof. intros x y. destruct x,y.
         decide (cstate0 = cstate1); decide (ctape0 = ctape1);
           try (right; intros H; now inversion H). left. now subst.
  Qed.

  (* *** Machine execution *)

  Definition step :=
    fun (M:sTM) (c:mconfig (states M)) =>
      let (news,action) := trans (cstate c, current (ctape c))
      in mk_mconfig news (tape_move_mono (ctape c) action).

  (* Initial configuration *)
  Definition initc := fun (M : sTM) tape =>
                        mk_mconfig (@start M) tape.

  (* Run the machine i steps until it halts *)
  (* Returns None iff the maschine does not halt within i steps *)
  Definition loop (A:Type) := fix l n (f:A -> A) (p : A -> bool) a {struct n}:=
                              if p a then Some a  else
                                match n with
                                  O => None
                                | S m => l m f p (f a)
                                end.

  Definition loopM := fun (M :sTM) (i : nat) cin =>
                        loop i (@step M) (fun c => halt (cstate c)) cin.

  (* *** Definition of Reachability *)

  Definition TMterminates (M: sTM) (start: mconfig (states M)) :=
    exists i outc, loopM i start = Some outc.

  Lemma loop_step_not A f p (a : A) i out:
    loop i f p (f a) = out -> (p a = false) -> (loop (S i) f p a = out).
  Proof.
  destruct i; intros H HF; cbn in *; rewrite HF; destruct (p (f a)); assumption.
  Qed.

  Inductive reach (M: sTM) : mconfig (states M) ->  mconfig (states M) -> Prop :=
  |reachI c : reach c c
  |reachS c d: reach (step c) d -> (halt (cstate c) = false) -> reach c d.
  Hint Constructors reach.

  Definition Halt' (M: sTM) (start: mconfig (states M)) :=
    exists (f: mconfig (states M)), halt (cstate f)=true /\ reach start f.

  Lemma TM_terminates_Halt (M:sTM) (start: mconfig (states M)) :
    TMterminates start <-> Halt' start.
  Proof.
    split.
    - intros [i [fin H]]. revert H. revert start. induction i; intros start H; cbn in *.
      + exists start. destruct (halt (cstate start)) eqn: HS. split; auto. inv H.
      + destruct (halt (cstate start)) eqn: HS.
        * inv H. exists fin. now split.
        * destruct (IHi (step start)) as [q [HF RF]]. unfold loopM. assumption.
          exists q. split. assumption. now apply reachS.
    - intros [f [HF RF]]. revert HF. induction RF; intros HR.
      + exists 0, c. cbn. now rewrite HR.
      + destruct (IHRF HR) as [i [out LH]]. exists (S i), out. now apply loop_step_not.
  Qed.

End Fix_Sigma.

Definition Halt (S: {sig:finType & sTM sig & tape sig}) :=
  Halt' (initc (projT2 (sigT_of_sigT2 S)) (projT3 S)).

Definition Reach (S: (sigT (fun (sig:finType) =>
                              (sigT (fun (M:sTM sig) => prod (mconfig sig (states M))
                                                          (mconfig sig (states M))))))) :=
  let (c1,c2) := (projT2 (projT2 S)) in
  reach c1 c2.


Require Import Core.

Set Implicit Arguments.
Set Warnings "-extraction-opaque-accessed".

Module Notations.
  Notation "[ ]" := nil (format "[ ]") : list_scope.
  Notation "[ x ]" := (cons x nil) : list_scope.
  Notation "[ x ; y ; .. ; z ]" :=
    (cons x (cons y .. (cons z nil) ..)) : list_scope.
  Open Scope list.
End Notations.

Import Notations.
Import Equal.Notations.

(** * Append and Reverse *)
(*  -------------------- *)

Section app_rev.
  Variable A: Type.

  (** The standard library of Coq defines the function [app] in the form [[
      Fixpoint app a b :=
        match a with
        | [] => b
        | x::xs => x :: (app xs b)
        end.]]
   and introduces the notation [a ++ b]  for [app a b].*)

  (** This recursive definition is not tail recursive but its time complexity
  is linear with the size of the first list. In this section we derive some
  properties about list appending.  *)

  Theorem app_associative:
    forall a b c: list A,
      (a ++ b) ++ c = a ++ b ++ c.  (* '++' is right associative *)
  Proof
    fix f a b c :=
    match a with
    | [] => eq_refl
    | x :: a => Equal.inject (f a b c) (fun l => x :: l)
    end.

  Theorem app_nil_right_neutral:
    forall a: list A,
      a ++ [] = a.
  Proof
    fix f a :=
    match a with
    | [] => eq_refl
    | x :: a => Equal.inject (f a) (fun l => x :: l)
    end.

  (** For list reversal we define a straightforward recursive function which
  is neither tail recursive nor linear. *)

  Fixpoint rev (a:list A): list A :=
    match a with
    | [] => []
    | x :: a => rev a ++ [x]
    end.

  Theorem rev_distributes_app:
    forall a b: list A,
      rev (a ++ b) = rev b ++ rev a.
  Proof
    fix f a b :=
    match a with
    | [] => Equal.use_bwd
              (app_nil_right_neutral (rev b))
              (fun l => _ = l)
              eq_refl
    | x :: a =>
      (equality_chain:
         (eq_refl: rev ((x::a)++b) = rev (x::(a++b))),
         (eq_refl: _ = rev (a++b) ++ [x]),
         (Equal.inject (f a b) (fun l => l ++ _): _ = (rev b ++ rev a) ++ [x]),
         (app_associative (rev b) (rev a) [x]:  _ = rev b ++ rev a ++ [x]),
         (eq_refl: _ = rev b ++ rev (x::a)))
    end.

  Theorem rev_involutive:
    forall a: list A,
      rev (rev a) = a.
  Proof
    fix f a :=
    match a with
    | [] => eq_refl
    | x :: a =>
      (equality_chain:
         (eq_refl : rev (rev (x :: a)) = rev (rev a ++ [x])),
         (rev_distributes_app _ _ : _ = rev [x] ++  rev (rev a)),
         (Equal.use_bwd (f a) (fun l => rev [x] ++ l = x :: a) eq_refl
           :  _ = x :: a))
    end.

End app_rev.

(** * Fast Append and Reverse *)
(*  ------------------------- *)
Section fast_app_rev.
  Variable A: Type.

  (** This section defines functions for efficient list reversal and list
  append. The functions are tail recursive and perform in linear time. *)

  Definition reverse_append (xs ys:list A): {b:list A | b = rev xs ++ ys}.
  Proof.
    exact(
      (fix f a b: rev a ++ b = rev xs ++ ys ->
                  {b | b = rev xs ++ ys} :=
         match a with
         | [] =>
           fun inv =>
             exist
               _ b
               inv
         | x :: tl =>
           fun inv =>
             f tl (x::b)
               (equality_chain:
                  (Equal.flip (app_associative (rev tl) [x] b)
                   : rev tl ++ x :: b  =  (rev tl ++ [x]) ++ b),
                  (eq_refl: _ = rev (x :: tl) ++ b),
                  (inv: _ = rev xs ++ ys))
         end
      ) xs ys eq_refl
    ).
  Defined.

  Definition reverse (a:list A):  {b:list A | b = rev a}.
  Proof.
    exact(
        match reverse_append a [] with
        | exist _ b eq =>
          exist _ b
                (Equal.join eq (app_nil_right_neutral _))
        end).
  Defined.

  Definition append (a b:list A): {c:list A | c = a ++ b}.
  Proof.
    exact(
        match (reverse a) with
        | exist _ ra pa =>
          match reverse_append ra b with
          | exist _ c pc =>
            exist
              _ c
              ((equality_chain:
                  (pc: c = rev ra ++ b),
                  (Equal.use
                     pa
                     (fun x => _ = rev x ++ b)
                     eq_refl
                   : _ = rev (rev a) ++ b),
                  (
                    Equal.use_bwd
                      (rev_involutive a)
                      (fun x => x ++ b = a ++ b)
                      eq_refl
                    : _ = a ++ b)
               )
               : c = a ++ b)
          end
        end).
  Defined.
End fast_app_rev.


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

Require Import Bool ZArith OrdersFacts Nnat ZAxioms ZSig.

(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] *)

Module ZTypeIsZAxioms (Import ZZ : ZType').

Hint Rewrite
 spec_0 spec_1 spec_2 spec_add spec_sub spec_pred spec_succ
 spec_mul spec_opp spec_of_Z spec_div spec_modulo spec_square spec_sqrt
 spec_compare spec_eqb spec_ltb spec_leb spec_max spec_min
 spec_abs spec_sgn spec_pow spec_log2 spec_even spec_odd spec_gcd
 spec_quot spec_rem spec_testbit spec_shiftl spec_shiftr
 spec_land spec_lor spec_ldiff spec_lxor spec_div2
 : zsimpl.

Ltac zsimpl := autorewrite with zsimpl.
Ltac zcongruence := repeat red; intros; zsimpl; congruence.
Ltac zify := unfold eq, lt, le in *; zsimpl.

Instance eq_equiv : Equivalence eq.
Proof. unfold eq. firstorder. Qed.

Local Obligation Tactic := zcongruence.

Program Instance succ_wd : Proper (eq ==> eq) succ.
Program Instance pred_wd : Proper (eq ==> eq) pred.
Program Instance add_wd : Proper (eq ==> eq ==> eq) add.
Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul.

Theorem pred_succ : forall n, pred (succ n) == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem one_succ : 1 == succ 0.
Proof.
now zify.
Qed.

Theorem two_succ : 2 == succ 1.
Proof.
now zify.
Qed.

Section Induction.

Variable A : ZZ.t -> Prop.
Hypothesis A_wd : Proper (eq==>iff) A.
Hypothesis A0 : A 0.
Hypothesis AS : forall n, A n <-> A (succ n).

Let B (z : Z) := A (of_Z z).

Lemma B0 : B 0.
Proof.
unfold B; simpl.
rewrite <- (A_wd 0); auto.
zify. auto.
Qed.

Lemma BS : forall z : Z, B z -> B (z + 1).
Proof.
intros z H.
unfold B in *. apply -> AS in H.
setoid_replace (of_Z (z + 1)) with (succ (of_Z z)); auto.
zify. auto.
Qed.

Lemma BP : forall z : Z, B z -> B (z - 1).
Proof.
intros z H.
unfold B in *. rewrite AS.
setoid_replace (succ (of_Z (z - 1))) with (of_Z z); auto.
zify. auto with zarith.
Qed.

Lemma B_holds : forall z : Z, B z.
Proof.
intros; destruct (Z_lt_le_dec 0 z).
apply natlike_ind; auto with zarith.
apply B0.
intros; apply BS; auto.
replace z with (-(-z))%Z in * by (auto with zarith).
remember (-z)%Z as z'.
pattern z'; apply natlike_ind.
apply B0.
intros; rewrite Z.opp_succ; unfold Z.pred; apply BP; auto.
subst z'; auto with zarith.
Qed.

Theorem bi_induction : forall n, A n.
Proof.
intro n. setoid_replace n with (of_Z (to_Z n)).
apply B_holds.
zify. auto.
Qed.

End Induction.

Theorem add_0_l : forall n, 0 + n == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m).
Proof.
intros. zify. auto with zarith.
Qed.

Theorem sub_0_r : forall n, n - 0 == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m).
Proof.
intros. zify. auto with zarith.
Qed.

Theorem mul_0_l : forall n, 0 * n == 0.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m.
Proof.
intros. zify. ring.
Qed.

(** Order *)

Lemma eqb_eq x y : eqb x y = true <-> x == y.
Proof.
 zify. apply Z.eqb_eq.
Qed.

Lemma leb_le x y : leb x y = true <-> x <= y.
Proof.
 zify. apply Z.leb_le.
Qed.

Lemma ltb_lt x y : ltb x y = true <-> x < y.
Proof.
 zify. apply Z.ltb_lt.
Qed.

Lemma compare_eq_iff n m : compare n m = Eq <-> n == m.
Proof.
 intros. zify. apply Z.compare_eq_iff.
Qed.

Lemma compare_lt_iff n m : compare n m = Lt <-> n < m.
Proof.
 intros. zify. reflexivity.
Qed.

Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m.
Proof.
 intros. zify. reflexivity.
Qed.

Lemma compare_antisym n m : compare m n = CompOpp (compare n m).
Proof.
 intros. zify. apply Z.compare_antisym.
Qed.

Include BoolOrderFacts ZZ ZZ ZZ [no inline].

Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
Proof.
intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
Qed.

Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m.
Proof.
intros. zify. omega.
Qed.

Theorem min_l : forall n m, n <= m -> min n m == n.
Proof.
intros n m. zify. omega with *.
Qed.

Theorem min_r : forall n m, m <= n -> min n m == m.
Proof.
intros n m. zify. omega with *.
Qed.

Theorem max_l : forall n m, m <= n -> max n m == n.
Proof.
intros n m. zify. omega with *.
Qed.

Theorem max_r : forall n m, n <= m -> max n m == m.
Proof.
intros n m. zify. omega with *.
Qed.

(** Part specific to integers, not natural numbers *)

Theorem succ_pred : forall n, succ (pred n) == n.
Proof.
intros. zify. auto with zarith.
Qed.

(** Opp *)

Program Instance opp_wd : Proper (eq ==> eq) opp.

Theorem opp_0 : - 0 == 0.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem opp_succ : forall n, - (succ n) == pred (- n).
Proof.
intros. zify. auto with zarith.
Qed.

(** Abs / Sgn *)

Theorem abs_eq : forall n, 0 <= n -> abs n == n.
Proof.
intros n. zify. omega with *.
Qed.

Theorem abs_neq : forall n, n <= 0 -> abs n == -n.
Proof.
intros n. zify. omega with *.
Qed.

Theorem sgn_null : forall n, n==0 -> sgn n == 0.
Proof.
intros n. zify. omega with *.
Qed.

Theorem sgn_pos : forall n, 0<n -> sgn n == 1.
Proof.
intros n. zify. omega with *.
Qed.

Theorem sgn_neg : forall n, n<0 -> sgn n == opp 1.
Proof.
intros n. zify. omega with *.
Qed.

(** Power *)

Program Instance pow_wd : Proper (eq==>eq==>eq) pow.

Lemma pow_0_r : forall a, a^0 == 1.
Proof.
 intros. now zify.
Qed.

Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b.
Proof.
 intros a b. zify. intros. now rewrite Z.add_1_r, Z.pow_succ_r.
Qed.

Lemma pow_neg_r : forall a b, b<0 -> a^b == 0.
Proof.
 intros a b. zify. intros Hb.
 destruct [b]; reflexivity || discriminate.
Qed.

Lemma pow_pow_N : forall a b, 0<=b -> a^b == pow_N a (Z.to_N (to_Z b)).
Proof.
 intros a b. zify. intros Hb. now rewrite spec_pow_N, Z2N.id.
Qed.

Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p).
Proof.
 intros a b. red. now rewrite spec_pow_N, spec_pow_pos.
Qed.

(** Square *)

Lemma square_spec n : square n == n * n.
Proof.
 now zify.
Qed.

(** Sqrt *)

Lemma sqrt_spec : forall n, 0<=n ->
 (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)).
Proof.
 intros n. zify. apply Z.sqrt_spec.
Qed.

Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0.
Proof.
 intros n. zify. apply Z.sqrt_neg.
Qed.

(** Log2 *)

Lemma log2_spec : forall n, 0<n ->
 2^(log2 n) <= n /\ n < 2^(succ (log2 n)).
Proof.
 intros n. zify. apply Z.log2_spec.
Qed.

Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0.
Proof.
 intros n. zify. apply Z.log2_nonpos.
Qed.

(** Even / Odd *)

Definition Even n := exists m, n == 2*m.
Definition Odd n := exists m, n == 2*m+1.

Lemma even_spec n : even n = true <-> Even n.
Proof.
 unfold Even. zify. rewrite Z.even_spec.
 split; intros (m,Hm).
 - exists (of_Z m). now zify.
 - exists [m]. revert Hm. now zify.
Qed.

Lemma odd_spec n : odd n = true <-> Odd n.
Proof.
 unfold Odd. zify. rewrite Z.odd_spec.
 split; intros (m,Hm).
 - exists (of_Z m). now zify.
 - exists [m]. revert Hm. now zify.
Qed.

(** Div / Mod *)

Program Instance div_wd : Proper (eq==>eq==>eq) div.
Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.

Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b).
Proof.
intros a b. zify. intros. apply Z.div_mod; auto.
Qed.

Theorem mod_pos_bound :
 forall a b, 0 < b -> 0 <= modulo a b /\ modulo a b < b.
Proof.
intros a b. zify. intros. apply Z_mod_lt; auto with zarith.
Qed.

Theorem mod_neg_bound :
 forall a b, b < 0 -> b < modulo a b /\ modulo a b <= 0.
Proof.
intros a b. zify. intros. apply Z_mod_neg; auto with zarith.
Qed.

Definition mod_bound_pos :
 forall a b, 0<=a -> 0<b -> 0 <= modulo a b /\ modulo a b < b :=
 fun a b _ H => mod_pos_bound a b H.

(** Quot / Rem *)

Program Instance quot_wd : Proper (eq==>eq==>eq) quot.
Program Instance rem_wd : Proper (eq==>eq==>eq) rem.

Theorem quot_rem : forall a b, ~b==0 -> a == b*(quot a b) + rem a b.
Proof.
intros a b. zify. apply Z.quot_rem.
Qed.

Theorem rem_bound_pos :
 forall a b, 0<=a -> 0<b -> 0 <= rem a b /\ rem a b < b.
Proof.
intros a b. zify. apply Z.rem_bound_pos.
Qed.

Theorem rem_opp_l : forall a b, ~b==0 -> rem (-a) b == -(rem a b).
Proof.
intros a b. zify. apply Z.rem_opp_l.
Qed.

Theorem rem_opp_r : forall a b, ~b==0 -> rem a (-b) == rem a b.
Proof.
intros a b. zify. apply Z.rem_opp_r.
Qed.

(** Gcd *)

Definition divide n m := exists p, m == p*n.
Local Notation "( x | y )" := (divide x y) (at level 0).

Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m].
Proof.
 intros n m. split.
 - intros (p,H). exists [p]. revert H; now zify.
 - intros (z,H). exists (of_Z z). now zify.
Qed.

Lemma gcd_divide_l : forall n m, (gcd n m | n).
Proof.
 intros n m. apply spec_divide. zify. apply Z.gcd_divide_l.
Qed.

Lemma gcd_divide_r : forall n m, (gcd n m | m).
Proof.
 intros n m. apply spec_divide. zify. apply Z.gcd_divide_r.
Qed.

Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m).
Proof.
 intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest.
Qed.

Lemma gcd_nonneg : forall n m, 0 <= gcd n m.
Proof.
 intros. zify. apply Z.gcd_nonneg.
Qed.

(** Bitwise operations *)

Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit.

Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true.
Proof.
 intros. zify. apply Z.testbit_odd_0.
Qed.

Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false.
Proof.
 intros. zify. apply Z.testbit_even_0.
Qed.

Lemma testbit_odd_succ : forall a n, 0<=n ->
 testbit (2*a+1) (succ n) = testbit a n.
Proof.
 intros a n. zify. apply Z.testbit_odd_succ.
Qed.

Lemma testbit_even_succ : forall a n, 0<=n ->
 testbit (2*a) (succ n) = testbit a n.
Proof.
 intros a n. zify. apply Z.testbit_even_succ.
Qed.

Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false.
Proof.
 intros a n. zify. apply Z.testbit_neg_r.
Qed.

Lemma shiftr_spec : forall a n m, 0<=m ->
 testbit (shiftr a n) m = testbit a (m+n).
Proof.
 intros a n m. zify. apply Z.shiftr_spec.
Qed.

Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m ->
 testbit (shiftl a n) m = testbit a (m-n).
Proof.
 intros a n m. zify. intros Hn H.
 now apply Z.shiftl_spec_high.
Qed.

Lemma shiftl_spec_low : forall a n m, m<n ->
 testbit (shiftl a n) m = false.
Proof.
 intros a n m. zify. intros H. now apply Z.shiftl_spec_low.
Qed.

Lemma land_spec : forall a b n,
 testbit (land a b) n = testbit a n && testbit b n.
Proof.
 intros a n m. zify. now apply Z.land_spec.
Qed.

Lemma lor_spec : forall a b n,
 testbit (lor a b) n = testbit a n || testbit b n.
Proof.
 intros a n m. zify. now apply Z.lor_spec.
Qed.

Lemma ldiff_spec : forall a b n,
 testbit (ldiff a b) n = testbit a n && negb (testbit b n).
Proof.
 intros a n m. zify. now apply Z.ldiff_spec.
Qed.

Lemma lxor_spec : forall a b n,
 testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
Proof.
 intros a n m. zify. now apply Z.lxor_spec.
Qed.

Lemma div2_spec : forall a, div2 a == shiftr a 1.
Proof.
 intros a. zify. now apply Z.div2_spec.
Qed.

End ZTypeIsZAxioms.

Module ZType_ZAxioms (ZZ : ZType)
 <: ZAxiomsSig <: OrderFunctions ZZ <: HasMinMax ZZ
 := ZZ <+ ZTypeIsZAxioms.


Require Import ssreflect ssrfun ssrbool eqtype seq Setoid Morphisms.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* First some basic propositional equalities Basically, we need to repeat *)
(* most of ssrbool.v here but we'll do it as we go. *)

Lemma andTp p : True /\ p <-> p.      Proof. by intuition. Qed.
Lemma andpT p : p /\ True <-> p.      Proof. by intuition. Qed.
Lemma andFp p : False /\ p <-> False. Proof. by intuition. Qed.
Lemma andpF p : p /\ False <-> False. Proof. by intuition. Qed.
Lemma orTp p : True \/ p <-> True.    Proof. by intuition. Qed.
Lemma orpT p : p \/ True <-> True.    Proof. by intuition. Qed.
Lemma orFp p : False \/ p <-> p.      Proof. by intuition. Qed.
Lemma orpF p : p \/ False <-> p.      Proof. by intuition. Qed.

Delimit Scope rel_scope with rel.
Open Scope rel_scope.

(**************************************************************************)
(* We follow ssrbool, and provide four different types of predicates.     *)
(*                                                                        *)
(* (1) Pred is the type of propositional functions                        *)
(* (2) Simpl_Pred is the type of predicates that automatically simplify   *)
(*     when used in an applicative position.                              *)
(* (3) Mem_Pred is for predicates that support infix notation x \In P     *)
(* (4) PredType is the structure for interpreting various types, such as  *)
(* lists, tuples, etc. as predicates.                                     *)
(*                                                                        *)
(* Important point is that custom lemmas over predicates can be stated in *)
(* terms of Pred, while Simpl_Pred, Mem_Pred and PredType are for         *)
(* technical developments used in this file only. More on this point      *)
(* can be found in ssrbool.                                               *)
(**************************************************************************)

Definition Pred T := T -> Prop.
Identity Coercion fun_of_Pred : Pred >-> Funclass.

Notation xPred0 := (fun _ => False).
Notation xPred1 := (fun x y => x = y).
Notation xPredT := (fun _ => True).
Notation xPredI := (fun (p1 p2 : Pred _) x => p1 x /\ p2 x).
Notation xPredU := (fun (p1 p2 : Pred _) x => p1 x \/ p2 x).
Notation xPredC := (fun (p : Pred _) x => ~ p x).
Notation xPredD := (fun (p1 p2 : Pred _) x => ~ p2 x /\ p1 x).
Notation xPreim := (fun f (p : Pred _) x => p (f x)).

Section Predicates.
Variable T : Type.

(* simple predicates *)

Definition Simpl_Pred := simpl_fun T Prop.
Definition SimplPred (p : Pred T) : Simpl_Pred := SimplFun p.
Coercion Pred_of_Simpl (p : Simpl_Pred) : Pred T := p : T -> Prop.

(* it's useful to declare the operations as simple predicates, so that *)
(* complex expressions automatically reduce when used in applicative   *)
(* positions *)

Definition Pred0 := SimplPred xPred0.
Definition Pred1 x := SimplPred (xPred1 x).
Definition PredT := SimplPred xPredT.
Definition PredI p1 p2 := SimplPred (xPredI p1 p2).
Definition PredU p1 p2 := SimplPred (xPredU p1 p2).
Definition PredC p := SimplPred (xPredC p).
Definition PredD p1 p2 := SimplPred (xPredD p1 p2).
Definition Preim rT f (d : Pred rT) := SimplPred (xPreim f d).

(* membership predicates *)

CoInductive Mem_Pred : Type := MemProp of Pred T.
Definition isMem pT toPred mem := mem = (fun p : pT => MemProp [eta toPred p]).

(* the general structure for predicates *)

Structure PredType : Type := PropPredType {
  Pred_Sort :> Type;
  toPred : Pred_Sort -> Pred T;
  _ : {mem | isMem toPred mem}}.

Definition mkPredType pT toP := PropPredType (exist (@isMem pT toP) _ (erefl _)).

(* Pred, SimplPred, Mem_Pred, pred and simpl_pred are PredType's *)
Canonical Structure PredPredType := Eval hnf in @mkPredType (Pred T) id.
Canonical Structure SimplPredPredType := Eval hnf in mkPredType Pred_of_Simpl.
Coercion Pred_of_Mem mp : Pred_Sort PredPredType :=
  let: MemProp p := mp in [eta p].
Canonical Structure MemPredType := Eval hnf in mkPredType Pred_of_Mem.
Canonical Structure predPredType := Eval hnf in @mkPredType (pred T) id.
Canonical Structure simplpredPredType :=
  Eval hnf in @mkPredType (simpl_pred T) (fun p x => p x).

End Predicates.

Implicit Arguments Pred0 [T].
Implicit Arguments PredT [T].
Prenex Implicits Pred0 PredT PredI PredU PredC PredD Preim.

Notation "r1 +p r2" := (PredU r1 r2 : Pred _)
  (at level 55, right associativity) : rel_scope.
Notation "r1 *p r2" := (xPredI r1 r2 : Pred _)
  (at level 45, right associativity) : rel_scope.

Notation "[ 'Pred' : T | E ]" := (SimplPred (fun _ : T => E))
  (at level 0, format "[ 'Pred' :  T  |  E ]") : fun_scope.
Notation "[ 'Pred' x | E ]" := (SimplPred (fun x => E))
  (at level 0, x ident, format "[ 'Pred'  x  |  E ]") : fun_scope.
Notation "[ 'Pred' x : T | E ]" := (SimplPred (fun x : T => E))
  (at level 0, x ident, only parsing) : fun_scope.
Notation "[ 'Pred' x y | E ]" := (SimplPred (fun t => let: (x, y) := t in E))
  (at level 0, x ident, y ident, format "[ 'Pred'  x  y  |  E ]") : fun_scope.
Notation "[ 'Pred' x y : T | E ]" :=
  (SimplPred (fun t : (T*T) => let: (x, y) := t in E))
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Definition repack_Pred T pT :=
  let: PropPredType _ a mP := pT return {type of @PropPredType T for pT} -> _ in
   fun k => k a mP.

Notation "[ 'PredType' 'of' T ]" := (repack_Pred (fun a => @PropPredType _ T a))
  (at level 0, format "[ 'PredType'  'of'  T ]") : form_scope.

Notation Pred_Class := (Pred_Sort (PredPredType _)).
Coercion Sort_of_Simpl_Pred T (p : Simpl_Pred T) : Pred_Class := p : Pred T.

Definition PredArgType := Type.
Coercion Pred_of_argType (T : PredArgType) : Simpl_Pred T := PredT.

Notation "{ :: T }" := (T%type : PredArgType)
  (at level 0, format "{ ::  T }") : type_scope.

(* These must be defined outside a Section because "cooking" kills the *)
(* nosimpl tag. *)
Definition Mem T (pT : PredType T) : pT -> Mem_Pred T :=
  nosimpl (let: PropPredType _ _ (exist mem _) := pT return pT -> _ in mem).
Definition InMem T x mp := nosimpl Pred_of_Mem T mp x.

Prenex Implicits Mem.

(* Membership Predicates can be used as simple ones *)
Coercion Pred_of_Mem_Pred T mp := [Pred x : T | InMem x mp].

(* equality and subset *)

Definition EqPredType T (pT : PredType T) (p1 p2 : pT) :=
  forall x : T, toPred p1 x <-> toPred p2 x.

Definition SubPredType T (pT : PredType T) (p1 p2 : pT) :=
  forall x : T, toPred p1 x -> toPred p2 x.

(* Definition EqPred T (p1 p2 : Pred T) := EqPredType p1 p2. *)
(* Definition SubPred T (p1 p2 : Pred T) := SubPredType p1 p2.  *)
Definition EqSimplPred T (p1 p2 : Simpl_Pred T) := EqPredType p1 p2.
Definition SubSimplPred T (p1 p2 : Simpl_Pred T) := SubPredType p1 p2.
(*
Definition EqMem T (p1 p2 : Mem_Pred T) := EqPredType p1 p2.
Definition SubMem T (p1 p2 : Mem_Pred T) := SubPredType p1 p2.
*)

Definition EqPredFun T1 T2 (pT2 : PredType T2) p1 p2 :=
  forall x : T1, @EqPredType T2 pT2 (p1 x) (p2 x).
Definition SubPredFun T1 T2 (pT2 : PredType T2) p1 p2 :=
  forall x : T1, @SubPredType T2 pT2 (p1 x) (p2 x).

Definition EqMem T p1 p2 := forall x : T, InMem x p1 <-> InMem x p2.
Definition SubMem T p1 p2 := forall x : T, InMem x p1 -> InMem x p2.

Notation "A <~> B" := (@EqPredType _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A ~> B" := (@SubPredType _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A <~1> B" := (@EqPredFun _ _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A ~1> B" := (@SubPredFun _ _ _ A B)
  (at level 70, no associativity) : rel_scope.

Notation "x \In A" := (InMem x (Mem A))
  (at level 70, no associativity) : rel_scope.
Notation "x \Notin A" := (~ (x \In A))
  (at level 70, no associativity) : rel_scope.
Notation "A =p B" := (EqMem (Mem A) (Mem B))
  (at level 70, no associativity) : type_scope.
Notation "A <=p B" := (SubMem (Mem A) (Mem B))
  (at level 70, no associativity) : type_scope.

(* Some notation for turning PredTypes into Pred or Simple Pred *)
Notation "[ 'Mem' A ]" := (Pred_of_Simpl (Pred_of_Mem_Pred (Mem A)))
  (at level 0, only parsing) : fun_scope.
Notation "[ 'PredI' A & B ]" := (PredI [Mem A] [Mem B])
  (at level 0, format "[ 'PredI'  A  &  B ]") : fun_scope.
Notation "[ 'PredU' A & B ]" := (PredU [Mem A] [Mem B])
  (at level 0, format "[ 'PredU'  A  &  B ]") : fun_scope.
Notation "[ 'PredD' A & B ]" := (PredD [Mem A] [Mem B])
  (at level 0, format "[ 'PredD'  A  &  B ]") : fun_scope.
Notation "[ 'PredC' A ]" := (PredC [Mem A])
  (at level 0, format "[ 'PredC'  A ]") : fun_scope.
Notation "[ 'Preim' f 'of' A ]" := (Preim f [Mem A])
  (at level 0, format "[ 'Preim'  f  'of'  A ]") : fun_scope.

Notation "[ 'Pred' x \In A ]" := [Pred x | x \In A]
  (at level 0, x ident, format "[ 'Pred'  x  \In  A ]") : fun_scope.
Notation "[ 'Pred' x \In A | E ]" := [Pred x | (x \In A) /\ E]
  (at level 0, x ident, format "[ 'Pred'  x  \In  A  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A & B | E ]" :=
  [Pred x y | (x \In A) /\ (y \In B) /\ E]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  &  B  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A & B ]" := [Pred x y | (x \In A) /\ (y \In B)]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  &  B ]") : fun_scope.
Notation "[ 'Pred' x y \In A | E ]" := [Pred x y \In A & A | E]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A ]" := [Pred x y \In A & A]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A ]") : fun_scope.

Section Simplifications.
Variables (T : Type) (pT : PredType T).

Lemma Mem_toPred : forall (p : pT), Mem (toPred p) = Mem p.
Proof. by rewrite /Mem; case: pT => T1 app1 [mem1  /= ->]. Qed.

Lemma toPredE : forall x (p : pT), toPred p x = (x \In p).
Proof. by move=> *; rewrite -Mem_toPred. Qed.

Lemma In_Simpl : forall x (p : Simpl_Pred T), (x \In p) = p x.
Proof. by []. Qed.

Lemma Simpl_PredE : forall (p : Pred T), p <~> [Pred x | p x].
Proof. by []. Qed.

(* Definition InE := (In_Simpl, Simpl_PredE). (* to be extended *) *)

Lemma Mem_Simpl : forall (p : Simpl_Pred T), Mem p = p :> Pred T.
Proof. by []. Qed.

Definition MemE := Mem_Simpl. (* could be extended *)

Lemma Mem_Mem : forall p : pT, (Mem (Mem p) = Mem p) * (Mem [Mem p] = Mem p).
Proof. by move=> p; rewrite -Mem_toPred. Qed.

End Simplifications.

(**************************************)
(* Definitions and lemmas for setoids *)
(**************************************)

Section RelProperties.
Variables (T : Type) (pT : PredType T).

Lemma EqPredType_refl (r : pT) : EqPredType r r. Proof. by []. Qed.
Lemma SubPredType_refl (r : pT) : SubPredType r r. Proof. by []. Qed.

Lemma EqPredType_sym (r1 r2 : pT) : EqPredType r1 r2 -> EqPredType r2 r1.
Proof. by move=>H1 x; split; move/H1. Qed.

Lemma EqPredType_trans' (r1 r2 r3 : pT) :
  EqPredType r1 r2 -> EqPredType r2 r3 -> EqPredType r1 r3.
Proof. by move=>H1 H2 x; split; [move/H1; move/H2 | move/H2; move/H1]. Qed.

Lemma SubPredType_trans' (r1 r2 r3 : pT) :
  SubPredType r1 r2 -> SubPredType r2 r3 -> SubPredType r1 r3.
Proof. by move=>H1 H2 x; move/H1; move/H2. Qed.

Definition EqPredType_trans r2 r1 r3 := @EqPredType_trans' r1 r2 r3.
Definition SubPredType_trans r2 r1 r3 := @SubPredType_trans' r1 r2 r3.
End RelProperties.

Hint Resolve EqPredType_refl SubPredType_refl.

(* Declaration of relations *)

(* Unfortunately, Coq setoids don't seem to understand implicit coercions *)
(* and canonical structures so we have to repeat relation declarations    *)
(* for all instances. This is really annoying, but at least I don't have  *)
(* to reprove the lemmas on refl, sym and trans                           *)
(*                                                                        *)
Add Parametric Relation T (pT : PredType T) : pT (@EqPredType _ pT)
   reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqPredType_rel.

(*                                                                        *)
(* Add Parametric Relation T (pT : PredType T) : pT (@SubPredType _ pT)   *)
(*  reflexivity proved by (@SubPredType_refl _ _)                         *)
(*  transitivity proved by (@SubPredType_trans' _ _) as SubPredType_rel.  *)

(* Add Parametric Relation T : (Pred T) (@EqPred _)
  reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqPred_rel.

Add Parametric Relation T : (Pred T) (@SubPred _)
  reflexivity proved by (@SubPredType_refl _ _)
  transitivity proved by (@SubPredType_trans' _ _) as SubPred_rel.
*)

Add Parametric Relation T : (Simpl_Pred T) (@EqSimplPred _)
  reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqSimplPred_rel.

Add Parametric Relation T : (Simpl_Pred T) (@SubSimplPred _)
  reflexivity proved by (@SubPredType_refl _ _)
  transitivity proved by (@SubPredType_trans' _ _) as SubSimplPred_rel.

Add Parametric Relation T : (Mem_Pred T) (@EqMem T)
  reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqMem_rel.

Add Parametric Relation T : (Mem_Pred T) (@SubMem _)
  reflexivity proved by (@SubPredType_refl _ _)
  transitivity proved by (@SubPredType_trans' _ _) as SubMem_rel.

(* Declaring morphisms. *)
(* Annoyingly, even the coercions must be declared *)

Add Parametric Morphism T : (@Pred_of_Simpl T) with signature
      @EqSimplPred _ ==> @EqPredType T (PredPredType T) as Pred_of_Simpl_morph.
Proof. by []. Qed.

(* Do we need other coercions? We'll discover as we go *)

(* Now the other morphisms. Again, not clear which ones are needed.   *)
(* However, for all this to work, it seems that morphisms must be     *)
(* declared with most specific signatures, or else the system         *)
(* complains. For example, we use EqPred _ instead of EqPredType _ _, *)
(* even though the former is an instance of the later.                *)

(*
Add Parametric Morphism T : (@EqPred T) with signature
    @EqPred _ ==> @EqPred _ ==> iff as EqPred_morph.
Proof. by move=>r1 s1 H1 r2 s2 H2; rewrite H1 H2. Qed.
*)

Add Parametric Morphism T (pT : PredType T) : (@EqPredType T pT) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> iff as EqPredType_morph.
Proof. by move=>r1 s1 H1 r2 s2 H2; rewrite H1 H2. Qed.

Add Parametric Morphism T (pT : PredType T) : (@SubPredType T pT) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> iff as SubPred_morph.
Proof. by move=>r1 s1 H1 r2 s2 H2; split=>H x; move/H1; move/H; move/H2. Qed.

Add Parametric Morphism T : (@InMem T) with signature
    @eq _ ==> @EqMem _ ==> iff as InMem_morph.
Proof. by move=>x r s H; split; move/H. Qed.

Add Parametric Morphism T (pT : PredType T) : (@Mem T pT) with signature
  @EqPredType _ _ ==> @EqMem _ as Mem_morhp.
Proof. by move=>x y H p; rewrite /EqPredType -!toPredE in H *; rewrite H. Qed.

Add Parametric Morphism T : (@PredU T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> @EqSimplPred _ as predU_morph.
Proof.
move=>r1 s1 H1 r2 h2 H2 x; split;
by case; [move/H1 | move/H2]=>/=; auto.
Qed.

Add Parametric Morphism T : (@PredI T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> @EqPredType _ _ as predI_morph.
Proof.
move=>r1 s1 H1 r2 s2 H2 x; split;
by case; move/H1=>T1; move/H2=>T2.
Qed.

Add Parametric Morphism T : (@PredC T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ as predC_morph.
Proof. by move=>r s H x; split=>H1; apply/H. Qed.

Section RelLaws.
Variable (T : Type).

Lemma orrI (r : Pred nat) : r +p r <~> r.
Proof.  by move=>x; split; [case | left]. Qed.

Lemma orrC (r1 r2 : Pred T) : r1 +p r2 <~> r2 +p r1.
Proof. move=>x; split=>/=; tauto. Qed.

Lemma orr0 (r : Pred T) : r +p Pred0 <~> r.
Proof. by move=>x; split; [case | left]. Qed.

Lemma or0r (r : Pred T) : Pred0 +p r <~> r.
Proof. by rewrite orrC orr0. Qed.

Lemma orrCA (r1 r2 r3 : Pred T) : r1 +p r2 +p r3 <~> r2 +p r1 +p r3.
Proof. by move=>x; split=>/=; intuition. Qed.

Lemma orrAC (r1 r2 r3 : Pred T) : (r1 +p r2) +p r3 <~> (r1 +p r3) +p r2.
Proof. by move=>?; split=>/=; intuition. Qed.

Lemma orrA (r1 r2 r3 : Pred T) : (r1 +p r2) +p r3 <~> r1 +p r2 +p r3.
Proof. by rewrite (orrC r2) orrCA orrC. Qed.

(* absorption *)
Lemma orrAb (r1 a : Pred T) : r1 <~> r1 +p a <-> a ~> r1.
Proof.
split; first by move=>-> x /=; auto.
move=>H x /=; split; first by auto.
by case=>//; move/H.
Qed.

Lemma sub_orl (r1 r2 : Pred T) : r1 ~> r1 +p r2. Proof. by left. Qed.
Lemma sub_orr (r1 r2 : Pred T) : r2 ~> r1 +p r2. Proof. by right. Qed.

End RelLaws.

Section SubMemLaws.
Variable T : Type.

Lemma subp_refl (p : Pred T) : p <=p p.
Proof. by []. Qed.

Lemma subp_asym (p1 p2 : Pred T) : p1 <=p p2 -> p2 <=p p1 -> p1 =p p2.
Proof. by move=>H1 H2 x; split; [move/H1 | move/H2]. Qed.

Lemma subp_trans (p2 p1 p3 : Pred T) : p1 <=p p2 -> p2 <=p p3 -> p1 <=p p3.
Proof. by move=>H1 H2 x; move/H1; move/H2. Qed.

Lemma subp_or (p1 p2 q : Pred T) : p1 <=p q /\ p2 <=p q <-> p1 +p p2 <=p q.
Proof.
split=>[[H1] H2 x|H1]; first by case; [move/H1 | move/H2].
by split=>x H2; apply: H1; [left | right].
Qed.

Lemma subp_and (p1 p2 q : Pred T) : q <=p p1 /\ q <=p p2 <-> q <=p p1 *p p2.
Proof.
split=>[[H1] H2 x|] H; last by split=>x; case/H.
by split; [apply: H1 | apply: H2].
Qed.

Lemma subp_orl (p1 p2 q : Pred T) : p1 <=p p2 -> p1 +p q <=p p2 +p q.
Proof. by move=>H x; case; [move/H; left|right]. Qed.

Lemma subp_orr (p1 p2 q : Pred T) : p1 <=p p2 -> q +p p1 <=p q +p p2.
Proof. by move=>H x; case; [left | move/H; right]. Qed.

Lemma subp_andl (p1 p2 q : Pred T) : p1 <=p p2 -> p1 *p q <=p p2 *p q.
Proof. by by move=>H x [H1 H2]; split; [apply: H|]. Qed.

Lemma subp_andr (p1 p2 q : Pred T) : p1 <=p p2 -> q *p p1 <=p q *p p2.
Proof. by move=>H x [H1 H2]; split; [|apply: H]. Qed.

End SubMemLaws.

Hint Resolve subp_refl.

Section ListMembership.
Variable T : Type.

Fixpoint Mem_Seq (s : seq T) :=
  if s is y::s' then (fun x => x = y \/ Mem_Seq s' x) else xPred0.

Definition EqSeq_Class := seq T.
Identity Coercion seq_of_EqSeq : EqSeq_Class >-> seq.

Coercion Pred_of_Eq_Seq (s : EqSeq_Class) : Pred_Class := [eta Mem_Seq s].

Canonical Structure seq_PredType := @mkPredType T (seq T) Pred_of_Eq_Seq.
(* The line below makes Mem_Seq a canonical instance of topred. *)
Canonical Structure Mem_Seq_PredType := mkPredType Mem_Seq.

Lemma In_cons : forall y s x, (x \In y :: s) <-> (x = y) \/ (x \In s).
Proof. by []. Qed.

Lemma In_nil : forall x, (x \In [::]) <-> False.
Proof. by []. Qed.

Lemma Mem_Seq1 : forall x y, (x \In [:: y]) <-> (x = y).
Proof. by move=> x y; rewrite In_cons orpF. Qed.

Definition InE := (Mem_Seq1, In_cons, In_Simpl).
(* I also wanted to add Simpl_PredE, but setoid rewrite returns an error *)
(* and instead of trying the other rules in the tuple, it just stops *)
(* This is ridiculuous *)

Lemma Mem_cat : forall x s1 s2, (x \In s1 ++ s2) <-> x \In s1 \/ x \In s2.
Proof.
move=>x; elim=>[|y s1 IH] s2 /=; first by split; [right | case].
rewrite !InE /=.
split.
- case=>[->|/IH]; first by left; left.
  by case; [left; right | right].
case; first by case; [left | move=>H; right; apply/IH; left].
by move=>H; right; apply/IH; right.
Qed.

End ListMembership.

Lemma Mem_map T T' (f : T -> T') x (s : seq T) :
         x \In s -> f x \In (map f s).
Proof.
elim: s=>[|y s IH] //; rewrite InE /=.
by case=>[<-|/IH]; [left | right].
Qed.

Lemma Mem_map_inv T T' (f : T -> T') x (s : seq T) :
        x \In (map f s) -> exists y, x = f y /\ y \In s.
Proof.
elim: s=>[|y s IH] //=; rewrite InE /=.
case; first by move=>->; exists y; split=>//; left.
by case/IH=>z [->]; exists z; split=>//; right.
Qed.

Prenex Implicits Mem_map_inv.

(* Setoids for extensional equality of functions *)

Lemma eqfun_refl A B (f : A -> B) : f =1 f. Proof. by []. Qed.
Lemma eqfun_sym A B (f1 f2 : A -> B) : f1 =1 f2 -> f2 =1 f1.
Proof. by move=>H x; rewrite H. Qed.
Lemma eqfun_trans A B (f1 f2 f3 : A -> B) : f1 =1 f2 -> f2 =1 f3 -> f1 =1 f3.
Proof. by move=>H1 H2 x; rewrite H1 H2. Qed.

Add Parametric Relation A B : (A -> B) (@eqfun _ _)
  reflexivity proved by (@eqfun_refl A B)
  symmetry proved by (@eqfun_sym A B)
  transitivity proved by (@eqfun_trans A B) as eqfun_morph.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. lfind. Admitted.


(** printing ~ $\neg$ #¬# *)
(** printing -> $\ra$ #→# *)
(** printing => $\Ra$ #⇒# *)
(** printing ==> $\Ra$ #⇒# *)
(** printing <-> $\lra$ #↔# *)
(** printing /\ $\wedge$ #∧# *)
(** printing \/ $\vee$ #∨# *)
(** printing forall $\forall$ #∀# *)
(** printing exist $\exists$ #&exists;# *)

(** * Misc.v: Preliminaries *)

Set Implicit Arguments.
(* Require Export Setoid. *)
Require Export Arith.
Require Import Coq.Classes.SetoidTactics.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Classes.Morphisms.

Open Local Scope signature_scope.

(* Should be in standard library Arith.EqNat.beq_nat. *)
Lemma beq_nat_neq: forall x y : nat, x <> y -> false = beq_nat x y.
Proof.
  induction x;induction y;simpl;auto.
Qed.

Lemma if_beq_nat_nat_eq_dec : forall A (x y:nat) (a b:A),
  (if beq_nat x y then a else b) = if eq_nat_dec x y then a else b.
Proof.
  intros A x y a b.
  destruct (eq_nat_dec x y);intros;subst.
  rewrite <- beq_nat_refl;trivial.
  rewrite <- beq_nat_neq;auto.
Qed.

Definition ifte A (test:bool) (thn els:A) := if test then thn else els.

Add Parametric Morphism (A:Type) : (@ifte A)
  with signature (eq ==>eq ==> eq ==> eq) as ifte_morphism1.
Proof.
  trivial.
Qed.

Add Parametric Morphism (A:Type) x : (@ifte A x)
  with signature (eq ==> eq ==> eq) as ifte_morphism2.
Proof.
  trivial.
Qed.

Add Parametric Morphism (A:Type) x y : (@ifte A x y)
  with signature (eq ==> eq) as ifte_morphism3.
Proof.
  trivial.
Qed.

(** ** Definition of iterator [compn]
   [compn f u n x] is defined as (f (u (n-1)).. (f (u 0) x)) *)

Fixpoint compn (A:Type)(f:A -> A -> A) (x:A) (u:nat -> A) (n:nat) {struct n}: A :=
   match n with O => x | (S p) => f (u p) (compn f x u p) end.

Lemma comp0 : forall (A:Type) (f:A -> A -> A) (x:A) (u:nat -> A), compn f x u 0 = x.
trivial.
Save.

Lemma compS : forall (A:Type) (f:A -> A -> A) (x:A) (u:nat -> A) (n:nat),
              compn f x u (S n) = f (u n) (compn f x u n).
trivial.
Save.

(** ** Reducing if constructs *)

Lemma if_then : forall (P:Prop) (b:{ P }+{ ~ P })(A:Type)(p q:A),
      P -> (if b then p else q) = p.
destruct b; simpl; intuition.
Save.

Lemma if_else : forall (P :Prop) (b:{ P }+{ ~ P })(A:Type)(p q:A),
      ~P -> (if b then p else q) = q.
destruct b; simpl; intuition.
Save.

Lemma if_then_not : forall (P Q:Prop) (b:{ P }+{ Q })(A:Type)(p q:A),
      ~ Q -> (if b then p else q) = p.
destruct b; simpl; intuition.
Save.

Lemma if_else_not : forall (P Q:Prop) (b:{ P }+{ Q })(A:Type)(p q:A),
      ~P -> (if b then p else q) = q.
destruct b; simpl; intuition.
Save.

(** ** Classical reasoning *)

Definition class (A:Prop) := ~ ~ A -> A.

Lemma class_neg : forall A:Prop, class ( ~ A).
unfold class; intuition.
Save.

Lemma class_false : class False.
unfold class; intuition.
Save.
Hint Resolve class_neg class_false.

Definition orc (A B:Prop) := forall C:Prop, class C -> (A -> C) -> (B -> C) -> C.

Lemma orc_left : forall A B:Prop, A -> orc A B.
red;intuition.
Save.

Lemma orc_right : forall A B:Prop, B -> orc A B.
red;intuition.
Save.

Hint Resolve orc_left orc_right.

Lemma class_orc : forall A B, class (orc A B).
repeat red; intros.
apply H0; red; intro.
apply H; red; intro.
apply H3; apply H4; auto.
Save.

Implicit Arguments class_orc [].

Lemma orc_intro : forall A B, ( ~ A -> ~ B -> False) -> orc A B.
intros; apply class_orc; red; intros.
apply H; red; auto.
Save.

Lemma class_and : forall A B, class A -> class B -> class (A /\ B).
unfold class; intuition.
Save.

Lemma excluded_middle : forall A, orc A ( ~ A).
red; intros.
apply H; red; intro.
intuition.
Save.

Definition exc (A :Type)(P:A -> Prop) :=
   forall C:Prop, class C -> (forall x:A, P x -> C) -> C.

Lemma exc_intro : forall (A :Type)(P:A -> Prop) (x:A), P x -> exc P.
red;firstorder.
Save.

Lemma class_exc : forall (A :Type)(P:A -> Prop), class (exc P).
repeat red; intros.
apply H0; clear H0; red; intro.
apply H; clear H; red; intro H2.
apply H2; intros; auto.
apply H0; apply (H1 x); auto.
Save.

Lemma exc_intro_class : forall (A:Type) (P:A -> Prop), ((forall x, ~ P x) -> False) -> exc P.
intros; apply class_exc; red; intros.
apply H; red; intros; auto.
apply H0; apply exc_intro with (x:=x);auto.
Save.

Lemma not_and_elim_left : forall A B, ~ (A /\ B) -> A -> ~B.
intuition.
Save.

Lemma not_and_elim_right : forall A B, ~ (A /\ B) -> B -> ~A.
intuition.
Save.

Hint Resolve class_orc class_and class_exc excluded_middle.

Lemma class_double_neg : forall P Q: Prop, class Q -> (P -> Q) -> ~ ~ P -> Q.
intros.
apply (excluded_middle (A:=P)); auto.
Save.

(** ** Extensional equality *)

Definition feq A B (f g : A -> B) := forall x, f x = g x.

Lemma feq_refl : forall A B (f:A->B), feq f f.
red; trivial.
Save.

Lemma feq_sym : forall A B (f g : A -> B), feq f g -> feq g f.
unfold feq; auto.
Save.

Lemma feq_trans : forall A B (f g h: A -> B), feq f g -> feq g h -> feq f h.
unfold feq; intros.
transitivity (g x); auto.
Save.

Hint Resolve feq_refl.
Hint Immediate feq_sym.
Hint Unfold feq.

Add Parametric Relation (A B : Type) : (A -> B) (feq (A:=A) (B:=B))
  reflexivity proved by (feq_refl (A:=A) (B:=B))
  symmetry proved by (feq_sym (A:=A) (B:=B))
  transitivity proved by (feq_trans (A:=A) (B:=B))
as feq_rel.

(** Computational version of elimination on CompSpec *)

Lemma CompSpec_rect : forall (A : Type) (eq lt : A -> A -> Prop) (x y : A)
       (P : comparison -> Type),
       (eq x y -> P Eq) ->
       (lt x y -> P Lt) ->
       (lt y x -> P Gt)
    -> forall c : comparison, CompSpec eq lt x y c -> P c.
intros A eq lt x y P Peq Plt1 Plt2; destruct c; intro.
apply Peq; inversion H; auto.
apply Plt1; inversion H; auto.
apply Plt2; inversion H; auto.
Defined.

(** Decidability *)
Require Omega.

Lemma dec_sig_lt : forall P : nat -> Prop, (forall x, {P x}+{ ~ P x})
  -> forall n, {i | i < n /\ P i}+{forall i, i < n -> ~ P i}.
intros P Pdec.
induction n.
right; intros; exfalso; omega.
destruct IHn as [(i,(He1,He2))|Hn]; auto.
left; exists i; auto.
destruct (Pdec n) as [HP|HnP].
left; exists n; auto.
right; intros; assert (i < n \/ i = n) as [H1|H2]; subst; auto; try omega.
Defined.

Lemma dec_exists_lt : forall P : nat -> Prop, (forall x, {P x}+{ ~ P x})
  -> forall n, {exists i, i < n /\ P i}+{~ exists i, i < n /\ P i}.
intros P decP n; destruct (dec_sig_lt P decP n) as [(i,(H1,H2))|H].
left; exists i; auto.
right; intros (i,(H1,H2)); apply (H i H1 H2).
Save.

Definition eq_nat2_dec : forall p q : nat*nat, { p=q }+{~ p=q }.
intros (p1,p2) (q1,q2).
destruct (eq_nat_dec p1 q1) as [H1|H1]; subst.
destruct (eq_nat_dec p2 q2) as [H2|H2]; subst; auto with zarith.
right; intro Heq; apply H2.
injection Heq; trivial.
right; intro Heq; apply H1.
injection Heq; trivial.
Defined.

Lemma nat_compare_specT
   : forall x y : nat, CompareSpecT (x = y) (x < y)%nat (y < x)%nat (nat_compare x y).
intros; apply CompareSpec2Type.
apply nat_compare_spec.
Save.

(** * Preliminary lemmas relating the ordre on nat and N *)

Require Export NArith.

Lemma N2Nat_lt_mono : forall n m, (n < m)%N <-> (N.to_nat n < N.to_nat m)%nat.
unfold N.lt; intros n m; rewrite N2Nat.inj_compare.
rewrite <- nat_compare_lt; split; auto.
Save.

Lemma N2Nat_le_mono : forall n m, (n <= m)%N <-> (N.to_nat n <= N.to_nat m)%nat.
unfold N.le; intros n m; rewrite N2Nat.inj_compare.
rewrite <- nat_compare_le; split; trivial.
Save.

Lemma N2Nat_inj_lt : forall n m, (n < m)%N -> (N.to_nat n < N.to_nat m)%nat.
intros; rewrite <- N2Nat_lt_mono; trivial.
Save.

Lemma N2Nat_inj_le : forall n m, (n <= m)%N -> (N.to_nat n <= N.to_nat m)%nat.
intros; rewrite <- N2Nat_le_mono; trivial.
Save.

Lemma N2Nat_inj_pos : forall n, (0 < n)%N -> (0 < N.to_nat n)%nat.
unfold N.lt; intros n; rewrite N2Nat.inj_compare.
rewrite <- nat_compare_lt; trivial.
Save.
Hint Resolve N2Nat_inj_lt N2Nat_inj_pos N2Nat_inj_le.

Lemma Nsucc_pred_pos: forall n : N, (0 < n)%N -> N.succ (N.pred n) = n.
intros; apply N.lt_succ_pred with (0%N); trivial.
Save.
Hint Resolve Nsucc_pred_pos.

Lemma Npos : forall n, (0 <= n)%N.
destruct n; discriminate.
Save.
Hint Resolve Npos.

Lemma Neq_lt_0 : forall n, (n=0)%N \/ (0<n)%N.
intros; destruct (N.lt_eq_cases 0 n) as (Heq,_); intros.
destruct Heq; auto.
Save.
Hint Resolve Neq_lt_0.

Lemma Nlt0_le1 : forall n, (0<n)%N -> (1<=n)%N.
intros; change (N.succ 0 <= n)%N; rewrite N.le_succ_l; auto.
Save.
Hint Immediate Nlt0_le1.

(* Tactic to deal with closed inequalities on N *)
Ltac Nineq :=
     match goal with
      |- (N.le ?n ?m) => compute; discriminate
    | |- (N.lt ?n ?m) => compute; reflexivity
    | |- ~ (eq (A:=N) ?n ?m) => rewrite <- N.compare_eq_iff; compute; discriminate
    end.


Add LoadPath "." as OPAT.
Require Import OPAT.doit3 OPAT.aula5 OPAT.aula6 OPAT.aula7.

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons n l' *)
    reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil    => nil
  | h :: t => rev t ++ [h]
  end.

Example test_rev1:            rev [1;2;3] = [3;2;1].
Proof. reflexivity.  Qed.
Example test_rev2:            rev nil = nil.
Proof. reflexivity.  Qed.

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = [] *)
    reflexivity.
  - (* l = n :: l' *)
    (* This is the tricky case.  Let's begin as usual
       by simplifying. *)
    simpl.
    (* Now we seem to be stuck: the goal is an equality
       involving [++], but we don't have any useful equations
       in either the immediate context or in the global
       environment!  We can make a little progress by using
       the IH to rewrite the goal... *)
    rewrite <- IHl'.
    (* ... but now we can't go any further. *)
Abort.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  (* WORKED IN CLASS *)
  intros l1 l2. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons *)
    simpl. rewrite -> IHl1'. reflexivity.  Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons *)
    simpl. rewrite -> app_length, plus_comm.
    simpl. rewrite -> IHl'. reflexivity.
Qed.

Search rev.