Definition f : (nat->bool)->(nat->bool)->nat->bool.
    intros f1 f2.
    assumption.
Defined.

(*By Defined instead of Qed, the Proof is transparent, which may give compute some automic choice by coq system*)

(*Difference between opague and transparent*)
Print f.
Eval compute in (f (fun n=>true) (fun n => false) 45).
Opaque f.
Eval compute in (f (fun n=>true) (fun n => false) 45).

Require Import Arith.

Parameters (prime_divisor : nat->nat)
           (prime : nat->Prop)
           (divides : nat->nat->Prop).
Open Scope nat_scope.
Check (prime (prime_divisor 220)).
Check (divides (prime_divisor 220) 220).
Check (divides 3).

Parameters binary_word : nat->Set.
Definition short : Set := binary_word 32.
Definition long : Set := binary_word 64.
Check (not (divides 3 81)).
Check (let d := prime_divisor 220 in prime d /\ divides d 220).

Theorem le_i_SSi : forall i:nat, i <= S (S i).
Proof
   (fun i:nat => le_S _ _ (le_S _ _ (le_n i))).

(*Below is Implicit Arguments*)
Fail Check le_S (m:45).
Set Implicit Arguments.
Fail Check le_S (m:45).
Unset Implicit Arguments.
(*Directly Set Implicit Arguments instead of using <Set Implicit Arguments> can help specify which implicit argument to be made explicit*)
Arguments le_S [n m].
Check le_S (m:=45).

Print le_S.
Definition compose (A B C:Set) (f:A->B) (g:B->C) (a:A) := g (f a).


(* En este archivo se demuestran teoremas que forman parte
* de la librería de Coq en versiones posteriores
* a la utilizada en el presente trabajo *)
Require Import Coq.Lists.List.
Require Import Classical.
Set Reversible Pattern Implicit.

Section MyConcat.

    Context `{A:Type, B:Type}.
Fixpoint concat (l : list (list A)) : list A :=
  match l with
  | nil => nil
  | cons x l => x ++ concat l
  end.

    Theorem concat_nil : concat nil = nil.
    Proof.
        auto.
    Qed.

    Theorem concat_cons : forall x l, concat (cons x l) = x ++ concat l.
    Proof.
        intros.
        auto.
    Qed.

    Theorem concat_app : forall l1 l2, concat (l1 ++ l2) = concat l1 ++ concat l2.
    Proof.
        intros.
        induction l1.
        auto.
        simpl.
        rewrite IHl1.
        apply app_assoc.
    Qed.

 Definition flat_map (f:A -> list B) :=
    fix flat_map (l:list A) : list B :=
    match l with
      | nil => nil
      | cons x t => (f x)++(flat_map t)
    end.

    Theorem in_flat_map : forall (f:A->list B)(l:list A)(y:B), In y (flat_map f l) <-> exists x, In x l /\ In y (f x).
    Proof.
        intros.
        split;intros.
        induction l; simpl in H.
        destruct H.
        rewrite in_app_iff in H.
        destruct H.
        exists a.
        split;auto.
        apply in_eq.
        specialize (IHl H).
        destruct IHl.
        exists x.
        destruct H0.
        split;auto.
        apply in_cons;auto.
        destruct H.
        destruct H.
        induction l.
        inversion H.
        simpl.
        rewrite in_app_iff.
        inversion H.
        left.
        rewrite H1;auto.
        right.
        apply IHl;auto.
    Qed.
End MyConcat.

Section RemoveAll.
Context `{A:Type}.
Fixpoint removeAll (eq_dec : forall x y : A, {x = y}+{x <> y}) (toBeRemoved: list A) (fromList: list A) : list A :=
    match toBeRemoved with
    | nil => fromList
    | cons x toBeRemoved' => remove eq_dec x (removeAll eq_dec toBeRemoved' fromList)
    end.

End RemoveAll.

Theorem flat_map_concat_map : forall A B (f : A -> list B) l, flat_map f l = concat (map f l).
Proof.
    intros.
    induction l.
    auto.
    simpl.
    rewrite IHl;auto.
Qed.

Theorem In_nth_error :forall (A:Set) (x:A) (l:list A), In x l -> exists n, nth_error l n = Some x.
Proof.
    intros.
    induction l.
    inversion H.
    elim (classic (a=x));intros.
    rewrite H0 in *.
    exists 0.
    auto.
    inversion H.
    contradiction.
    specialize (IHl H1).
    destruct IHl.
    exists (S x0).
    auto.
Qed.

Theorem gen_nth_err_in : forall (A:Set) (x:A) (l:list A), (exists n:nat,nth_error l n = Some x) -> In x l.
Proof.
    intros.
    induction l.
    destruct H.
    destruct x0;simpl in H;discriminate H.
    destruct H.
    destruct x0;simpl in H.
    inversion H.
    apply in_eq.
    apply in_cons.
    apply IHl.
    exists x0;auto.
Qed.

Theorem nth_error_In :forall (A:Set) (x:A) (l:list A) (n:nat), nth_error l n = Some x -> In x l.
Proof.
    intros.
    apply gen_nth_err_in.
    exists n;auto.
Qed.

Theorem map_cons :forall (A B:Set) (f:A->B) (x:A)(l:list A), map f (x::l) = (f x) :: (map f l).
Proof.
    intros.
    auto.
Qed.


Require NPeano.
Import NPeano.Nat.
Require Import ExtLib.Tactics.Consider.
Require Import Coq.Bool.Bool.
Require Import ExtLib.Data.Nat.

Require Import Coq.omega.Omega.

Set Implicit Arguments.
Set Strict Implicit.

(**  Some tests *)
Section test.
  Goal forall x y z,  (ltb x y && ltb y z) = true ->
                 ltb x z = true.
  intros x y z.
  consider (ltb x y && ltb y z).
  consider (ltb x z); auto. intros. exfalso. omega.
  Qed.

  Goal forall x y z,
    ltb x y = true ->
    ltb y z = true ->
    ltb x z = true.
  Proof.
    intros. consider (ltb x y); consider (ltb y z); consider (ltb x z); intros; auto.
    exfalso; omega.
  Qed.

End test.


(* constructions for inductive proofs about derivations,
  adapted from ~jeremy/isabelle/2005/seqms/gentree.{thy,ML} *)

Set Implicit Arguments.
Require Import Coq.Program.Equality. (* for dependent induction/destruction *)
Require Import PeanoNat. (* for Nat *)

Require Import gen.
Require Import genT.
Require Import ddT.
Require Import dd_fc.
Require Import rtcT.

Require Import gstep.

(** conditions for inductive proofs for a tree **)

Definition gen_step_tr W rules fty P (A : fty) sub
  (dt : @derrec_fc W rules emptyT) :=
  (forall A' : fty, sub A' A -> forall d, P A' d) ->
  (forall dtn, in_nextup_fc dtn dt -> P A dtn) -> P A dt.

(* here is the same thing based the conclusion of the tree *)
Definition gen_step_c W rules fty (P : fty -> W -> Type) A sub c
  (dt : derrec rules emptyT c) :=
  (forall A' : fty, sub A' A ->
    forall c (d : derrec rules emptyT c), P A' c) ->
  (forall cn (dtn : derrec rules emptyT cn),
    in_nextup dtn dt -> P A cn) -> P A c.

Definition gf2_step_tr W fty (P : fty -> W -> Type) A sub dtsr dts :=
    ((forall A', sub A' A -> (forall dts, AccT dtsr dts -> P A' dts)) ->
    (forall dts', dtsr dts' dts -> P A dts') -> P A dts).

(** results linking the conditions for inductive proofs for a tree **)

Lemma gs_gsc W fty rules P A sub (c : W) (dt : derrec rules emptyT c):
  iffT (@gen_step W fty P A sub (derrec rules emptyT)
    (map (@derrec_fc_concl _ _ _) (nextup (fcI dt))) c)
  (@gen_step_c W rules fty P A sub c dt).
Proof. unfold gen_step.  unfold gen_step_c. apply pair ; intros.
- specialize (X X0). clear X0.
apply X. clear X.
apply ForallTI_forall.
intros x inmn.  apply InT_mapE in inmn. cD. subst.  split.
+  apply der_der_fc.
+ destruct inmn.  apply nextup_in_nu in inmn1.
simpl. rewrite der_concl_eq.  eapply X1 in inmn1. exact inmn1.
+ exact dt.
- specialize (X X0). clear X0.
apply X. clear X.
intros * inn.
eapply ForallTD_forall in X1. cD. exact X0.
apply in_nextup_nu in inn.  apply InT_mapI.
exists (fcI dtn). split. simpl. rewrite der_concl_eq. reflexivity.
exact inn. Qed.

Lemma gstr_gf2 W rules fty P A sub (dt : @derrec_fc W rules emptyT) :
  iffT (@gen_step_tr W rules fty P A sub dt)
    (@gf2_step_tr _ fty P A sub (@in_nextup_fc _ _ _) dt).
Proof. unfold gen_step_tr. unfold gf2_step_tr. apply pair ; intros.
- pose (fun A' saa dts => X0 A' saa dts (AccT_in_nextup_fc dts)) as X0'.
exact (X X0' X1).
- revert X1. apply X.  intros. apply (X0 A' X1). Qed.

Lemma gsc_gstr W rules fty P A sub c dt:
  iffT (@gen_step_c W rules fty P A sub c dt)
    (@gen_step_tr W rules fty (fun A' d => P A' (derrec_fc_concl d))
      (A : fty) sub (fcI dt)).
Proof. unfold gen_step_tr. unfold gen_step_c. simpl.
apply pair ; intros.
- rewrite (der_concl_eq dt). apply X.
+ intros.  specialize (X0 A' X2 (fcI d)). simpl in X0.
rewrite (der_concl_eq d) in X0. exact X0.
+ intros * inn.
specialize (X1 (fcI dtn)). simpl in X1.
rewrite (der_concl_eq dtn) in X1. apply X1.
exact (in_nextup_fcI inn).
- rewrite (der_concl_eq dt) in X. apply X.
+ intros. apply (X0 A' X2).
destruct d. simpl. rewrite (der_concl_eq d). exact d.
+ intros dtn inn. destruct dtn.
simpl. rewrite (der_concl_eq d).
apply (X1 concl d).  dependent destruction inn. exact i. Qed.

(* so we have these results linking these various conditions *)
Check gs_gsc. Check gsc_gstr. Check gstr_gf2.

(** lemmas enabling inductive proofs for a tree **)

Lemma gen_step_c_lem W rules fty (P : fty -> W -> Type) A sub : AccT sub A ->
  (forall A c dt, @gen_step_c W rules fty P A sub c dt) ->
  forall c (dt : derrec rules emptyT c), P A c.
Proof. intros acc gs. induction acc.
eapply derrec_all_rect.
intros. destruct H.
unfold gen_step_c in gs.
intros ps concl rpc drs fps.
pose (derI _ rpc drs).
specialize (gs x concl d X).
apply gs. clear gs a X.
intros.  eapply ForallTD_forall in fps. apply fps.
exact (in_nextup_concl_in X). Qed.

(* this also gives an induction principle for derrec_fc *)
Lemma gen_step_tr_lem W rules fty P A sub : AccT sub A ->
  (forall A dt, @gen_step_tr W rules fty P A sub dt) -> forall dt, P A dt.
Proof. intros acc gs. induction acc.
unfold gen_step_tr in gs.
pose (fun dt => gs x dt X) as p.
intro. destruct dt. revert d. revert concl.
(* note derrec_all_rect is forall conclusions, we want forall trees *)
eapply derrec_rect_mut_all.
- intros. destruct p0.
- intros * apd.  apply p. unfold nextup.
intros dtn ind.  destruct dtn.
exact (allP_all_in_d apd (in_trees_drs d (in_nextup_fc_nu ind))). Qed.

Lemma gf2_step_tr_lem W fty (P : fty -> W -> Type) A sub dtsr :
  (forall A dts, gf2_step_tr P A sub dtsr dts) ->
     AccT sub A -> (forall dts, AccT dtsr dts -> P A dts).
Proof. intros gs acc. induction acc.
intros dts add. induction add.
unfold gf2_step_tr in gs. exact (gs _ _ X X0). Qed.

(* so have these lemmas for proving results inductively *)
Check gstep.gen_step_lemT.
Check gen_step_c_lem.  Check gen_step_tr_lem. Check gf2_step_tr_lem.

(** conditions for inductive proofs for two trees **)

Definition dt2fun fty U W rlsa rlsb (P : fty -> U -> W -> Type) (A : fty)
  (da : @derrec_fc U rlsa emptyT) (db : @derrec_fc W rlsb emptyT) :=
  P A (derrec_fc_concl da) (derrec_fc_concl db).

Definition gen_step2_tr U W rulesa rulesb fty P (A : fty) sub
  (dta : @derrec_fc U rulesa emptyT) (dtb : @derrec_fc W rulesb emptyT) :=
  (forall A' : fty, sub A' A -> forall da db, P A' da db) ->
  (forall dtna, in_nextup_fc dtna dta -> P A dtna dtb) ->
  (forall dtnb, in_nextup_fc dtnb dtb -> P A dta dtnb) -> P A dta dtb.

Definition gen_step2_c U W rulesa rulesb fty
  (P : fty -> U -> W -> Type) (A : fty) sub ca cb
  (dta : derrec rulesa emptyT ca)
  (dtb : derrec rulesb emptyT cb) :=
  (forall A' : fty, sub A' A ->
    forall ca (dta : derrec rulesa emptyT ca)
      cb (dtb : derrec rulesb emptyT cb), P A' ca cb) ->
  (forall cp (dtp : derrec rulesa emptyT cp),
    in_nextup dtp dta -> P A cp cb) ->
  (forall cq (dtq : derrec rulesb emptyT cq),
    in_nextup dtq dtb -> P A ca cq) -> P A ca cb.

Definition gf_step2_tr U W fty (P : fty -> U -> W -> Type)
    A sub gfl gfr dta dtb :=
  (forall A', sub A' A ->
    forall a b, AccT gfl a -> AccT gfr b -> P A' a b) ->
  (forall dtp, gfl dtp dta -> P A dtp dtb) ->
  (forall dtq, gfr dtq dtb -> P A dta dtq) -> P A dta dtb.

Definition sum_step2_tr U W fty (P : fty -> U -> W -> Type)
    A sub gsl gsr dta dtb :=
  (forall A', sub A' A -> forall a b, P A' a b) ->
  (forall dta' dtb', gsl dta' + gsr dtb' < gsl dta + gsr dtb ->
    P A dta' dtb') -> P A dta dtb.

(** results linking the conditions for intudtive proofs for two trees **)
Lemma gs2_gs2c U W rulesa rulesb fty P (A : fty) sub ca cb dta dtb:
  iffT (@gen_step2 U W fty P A sub
    (derrec rulesa emptyT) (derrec rulesb emptyT)
    (der_botr_ps dta) ca (der_botr_ps dtb) cb)
  (@gen_step2_c U W rulesa rulesb fty P A sub ca cb dta dtb).
Proof. unfold gen_step2.  unfold gen_step2_c.
  rewrite <- !der_botr_ps_eq. apply pair ; intros.
- specialize (X X0). clear X0.
apply (fun fa fb => X fa fb dta dtb) ; clear X ; apply ForallTI_forall ;
intros x inmn ; apply InT_mapE in inmn ; cD ; subst ;  split ;
try apply der_der_fc.
+ destruct inmn.  apply nextup_in_nu in inmn1.
simpl. rewrite der_concl_eq.  eapply X1 in inmn1. exact inmn1.
+ destruct inmn.  apply nextup_in_nu in inmn1.
simpl. rewrite der_concl_eq.  eapply X2 in inmn1. exact inmn1.
- specialize (X X0). clear X0.
apply X ; clear X ; intros * inn.
+ eapply ForallTD_forall in X1. cD. exact X0.
apply in_nextup_nu in inn.  apply InT_mapI.
exists (fcI dtp). split. simpl. rewrite der_concl_eq. reflexivity.  exact inn.
+ eapply ForallTD_forall in X2. cD. exact X0.
apply in_nextup_nu in inn.  apply InT_mapI.
exists (fcI dtq). split. simpl. rewrite der_concl_eq. reflexivity.  exact inn.
Qed.

(*
(** results linking the conditions for intudtive proofs for two trees **)
Lemma gs2_gs2c U W rulesa rulesb fty P (A : fty) sub ca cb dta dtb:
  iffT (@gen_step2 U W fty P A sub
    (derrec rulesa emptyT) (derrec rulesb emptyT)
    (map (@derrec_fc_concl _ _ _) (nextup (fcI dta))) ca
    (map (@derrec_fc_concl _ _ _) (nextup (fcI dtb))) cb)
  (@gen_step2_c U W rulesa rulesb fty P A sub ca cb dta dtb).
Proof. unfold gen_step2.  unfold gen_step2_c. apply pair ; intros.
- specialize (X X0). clear X0.
apply (fun fa fb => X fa fb dta dtb) ; clear X ; apply ForallTI_forall ;
intros x inmn ; apply InT_mapE in inmn ; cD ; subst ;  split ;
try apply der_der_fc.
+ destruct inmn.  apply nextup_in_nu in inmn1.
simpl. rewrite der_concl_eq.  eapply X1 in inmn1. exact inmn1.
+ destruct inmn.  apply nextup_in_nu in inmn1.
simpl. rewrite der_concl_eq.  eapply X2 in inmn1. exact inmn1.
- specialize (X X0). clear X0.
apply X ; clear X ; intros * inn.
+ eapply ForallTD_forall in X1. cD. exact X0.
apply in_nextup_nu in inn.  apply InT_mapI.
exists (fcI dtp). split. simpl. rewrite der_concl_eq. reflexivity.  exact inn.
+ eapply ForallTD_forall in X2. cD. exact X0.
apply in_nextup_nu in inn.  apply InT_mapI.
exists (fcI dtq). split. simpl. rewrite der_concl_eq. reflexivity.  exact inn.
Qed.
*)

Lemma gs2tr_gf2 U W rulesa rulesb fty P A sub dta dtb :
  iffT (@gen_step2_tr U W rulesa rulesb fty P A sub dta dtb)
    (@gf_step2_tr _ _ fty P A sub
      (@in_nextup_fc _ _ _) (@in_nextup_fc _ _ _) dta dtb).
Proof. unfold gen_step2_tr. unfold gf_step2_tr. apply pair ; intros.
- pose (fun A' saa a b =>
  X0 A' saa a b (AccT_in_nextup_fc a) (AccT_in_nextup_fc b)) as X0'.
exact (X X0' X1 X2).
- revert X2. revert X1. apply X.  intros. apply (X0 A' X1). Qed.

Lemma gs2c_gs2tr U W rulesa rulesb fty P A sub ca cb dta dtb:
  iffT (@gen_step2_c U W rulesa rulesb fty P A sub ca cb dta dtb)
  (@gen_step2_tr U W rulesa rulesb fty (dt2fun P) A sub (fcI dta) (fcI dtb)).
Proof. unfold gen_step2_tr. unfold gen_step2_c. unfold dt2fun. simpl.
apply pair ; intros.
- rewrite (der_concl_eq dta). rewrite (der_concl_eq dtb). apply X.
+ intros A' saa ca0 da cb0 db.
specialize (X0 A' saa (fcI da) (fcI db)). simpl in X0.
rewrite (der_concl_eq da) in X0.  rewrite (der_concl_eq db) in X0. exact X0.
+ intros * inn.  specialize (X1 (fcI dtp)). simpl in X1.
rewrite (der_concl_eq dtp) in X1.  rewrite (der_concl_eq dtb) in X1. apply X1.
exact (in_nextup_fcI inn).
+ intros * inn.  specialize (X2 (fcI dtq)). simpl in X2.
rewrite (der_concl_eq dtq) in X2. rewrite (der_concl_eq dta) in X2. apply X2.
exact (in_nextup_fcI inn).
- rewrite (der_concl_eq dta) in X. rewrite (der_concl_eq dtb) in X. apply X.
+ intros A' saa *. apply (X0 A' saa).
destruct da. simpl. rewrite (der_concl_eq d). exact d.
destruct db. simpl. rewrite (der_concl_eq d). exact d.
+ intros * inn. destruct dtna.
simpl. rewrite (der_concl_eq d).  apply (X1 concl d).
dependent destruction inn. exact i.
+ intros * inn. destruct dtnb.
simpl. rewrite (der_concl_eq d).  apply (X2 concl d).
dependent destruction inn. exact i.  Qed.

(* so we have these results linking these various conditions *)
Check gs2_gs2c. Check gs2c_gs2tr. Check gs2tr_gf2.

(** lemmas enabling inductive proofs for two trees **)

Lemma gen_step2_c_lem U W rulesa rulesb fty P A sub : AccT sub A ->
  (forall A ca cb dta dtb,
    @gen_step2_c U W rulesa rulesb fty P A sub ca cb dta dtb) ->
  forall ca (dta : derrec rulesa emptyT ca) cb (dtb : derrec rulesb emptyT cb),
    P A ca cb.
Proof. intros acc gs. induction acc.
eapply derrec_all_rect2.
intros. destruct H.  intros. destruct H.
unfold gen_step2_c in gs.
intros *. intros rx ry drx dry fpx fpy.
pose (derI _ rx drx) as dx.  pose (derI _ ry dry) as dy.
specialize (gs x cx cy dx dy X).
apply gs ; clear gs a X ; intros.
+ eapply ForallTD_forall in fpx. apply fpx. exact (in_nextup_concl_in X).
+ eapply ForallTD_forall in fpy. apply fpy. exact (in_nextup_concl_in X).
Qed.

Lemma gen_step2_tr_lem U W rulesa rulesb fty P A sub : AccT sub A ->
  (forall A dta dtb, @gen_step2_tr U W rulesa rulesb fty P A sub dta dtb) ->
  forall dta dtb, P A dta dtb.
Proof. intros acc gs. induction acc.
unfold gen_step2_tr in gs.  pose (fun dta dtb => gs x dta dtb X) as p.
intro. destruct dta. revert d. revert concl.
eapply (@derrec_rect_mut_all U rulesa emptyT
  (fun ca (d : derrec rulesa emptyT ca) => forall dtb, P x (fcI d) dtb)).
- intros. destruct p0.
- intros * apd dtb. destruct dtb. revert d0. revert concl0.
eapply (derrec_rect_mut_all).
+ intros. destruct p0.
+ intros * apdb. apply p. unfold nextup.
intros dtna inda. destruct dtna.
exact (allP_all_in_d apd (in_trees_drs d (in_nextup_fc_nu inda)) _).
intros dtnb indb. destruct dtnb.
exact (allP_all_in_d apdb (in_trees_drs _ (in_nextup_fc_nu indb))). Qed.

Lemma gf_step2_tr_lem U W fty (P : fty -> U -> W -> Type) A sub gra grb :
  (forall A dta dtb, gf_step2_tr P A sub gra grb dta dtb) -> AccT sub A ->
    (forall dta, AccT gra dta -> forall dtb, AccT grb dtb -> P A dta dtb).
Proof. intros gs acc. induction acc.
unfold gf_step2_tr in gs.
pose (fun y s dta dtb adg => X y s dta adg dtb) as X'.
pose (fun dta dtb => gs x dta dtb X').
intros dta aga.  induction aga.
intros dtb agb.  pose agb.  induction a1.
apply p.
intros dtp gad.  apply X0 ; assumption.
intros dtq gbd.  apply (X1 dtq gbd (a1 dtq gbd)).
Qed.

Check gen_step2_c_lem.  Check gen_step2_tr_lem.  Check gf_step2_tr_lem.

Definition measure {U} f (dtn dt : U) := f dtn < f dt.

Lemma AccT_measure' U f n : forall dt : U, f dt < n -> AccT (measure f) dt.
Proof.  induction n.
- intros.  apply Nat.nlt_0_r in H.  contradiction H.
- intros.  apply AccT_intro.  intros.  unfold measure in H0.  apply IHn.
apply Lt.lt_n_Sm_le in H.  eapply Lt.lt_le_trans ; eassumption.  Qed.

Definition AccT_measure U f dt :=
  @AccT_measure' U f _ dt (Nat.lt_succ_diag_r _).

Definition size_step2_tr U W fty rulesa rulesb P (A : fty) sub :=
    gf_step2_tr P A sub (measure (@derrec_fc_size U rulesa emptyT))
      (measure (@derrec_fc_size W rulesb emptyT)).

Definition height_step2_tr U W fty rulesa rulesb P (A : fty) sub :=
    gf_step2_tr P A sub (measure (@derrec_fc_height U rulesa emptyT))
      (measure (@derrec_fc_height W rulesb emptyT)).

Lemma size_step2_tr_lem U W fty (rulesa : rlsT U) (rulesb : rlsT W)
  (P : fty -> derrec_fc rulesa emptyT -> derrec_fc rulesb emptyT -> Type)
  A sub dta dtb: AccT sub A ->
  (forall A dta dtb, size_step2_tr P A sub dta dtb) -> P A dta dtb.
Proof. unfold size_step2_tr. intros acc fgf.
apply (gf_step2_tr_lem fgf acc) ; apply AccT_measure. Qed.

Lemma height_step2_tr_lem U W fty (rulesa : rlsT U) (rulesb : rlsT W)
  (P : fty -> derrec_fc rulesa emptyT -> derrec_fc rulesb emptyT -> Type)
  A sub dta dtb: AccT sub A ->
  (forall A dta dtb, height_step2_tr P A sub dta dtb) -> P A dta dtb.
Proof. unfold height_step2_tr. intros acc fgf.
apply (gf_step2_tr_lem fgf acc) ; apply AccT_measure. Qed.

Lemma nextup_size W rules prems (d dn : @derrec_fc W rules prems):
  InT dn (nextup d) -> derrec_fc_size dn < derrec_fc_size d.
Proof. destruct d. destruct dn.
unfold derrec_fc_size. unfold nextup.
destruct d. intro. inversion X.
intro idt. apply in_trees_drs in idt.
simpl. clear r. (* otherwise complicates induction *)
induction idt ; simpl.
+ apply Lt.le_lt_n_Sm. apply Nat.le_add_r.
+ eapply Lt.lt_le_trans. apply IHidt. apply le_n_S. apply Plus.le_plus_r. Qed.

Lemma nextup_height W rules prems (d dn : @derrec_fc W rules prems):
  InT dn (nextup d) -> derrec_fc_height dn < derrec_fc_height d.
Proof. destruct d. destruct dn.
unfold derrec_fc_height. unfold nextup.
destruct d. intro. inversion X.
intro idt. apply in_trees_drs in idt.
simpl. clear r. (* otherwise complicates induction *)
induction idt ; simpl.
+ apply Lt.le_lt_n_Sm. apply Nat.le_max_l.
+ eapply Lt.lt_le_trans. apply IHidt. apply le_n_S. apply Nat.le_max_r. Qed.

Definition in_nextup_size W rules prems d dn inn :=
  @nextup_size W rules prems d dn (in_nextup_fc_nu inn).
Definition in_nextup_height W rules prems d dn inn :=
  @nextup_height W rules prems d dn (in_nextup_fc_nu inn).

Lemma gs2_tr_size U W fty (rulesa : rlsT U) (rulesb : rlsT W)
  (P : fty -> derrec_fc rulesa emptyT -> derrec_fc rulesb emptyT -> Type)
  A sub dta dtb:
  gen_step2_tr P A sub dta dtb -> size_step2_tr P A sub dta dtb.
Proof. unfold size_step2_tr. unfold gf_step2_tr.  unfold gen_step2_tr.
intros gs2 saa.
specialize (gs2 (fun A' s a b =>
  saa A' s a b (AccT_measure _ _) (AccT_measure _ _))).
clear saa. intros pb aq. apply gs2.
intros. apply (pb dtna). unfold measure.  apply (in_nextup_size X).
intros. apply (aq dtnb). unfold measure.  apply (in_nextup_size X). Qed.

Lemma gs2_tr_height U W fty (rulesa : rlsT U) (rulesb : rlsT W)
  (P : fty -> derrec_fc rulesa emptyT -> derrec_fc rulesb emptyT -> Type)
  A sub dta dtb:
  gen_step2_tr P A sub dta dtb -> height_step2_tr P A sub dta dtb.
Proof. unfold height_step2_tr. unfold gf_step2_tr.  unfold gen_step2_tr.
intros gs2 saa.
specialize (gs2 (fun A' s a b =>
  saa A' s a b (AccT_measure _ _) (AccT_measure _ _))).
clear saa. intros pb aq. apply gs2.
intros. apply (pb dtna). unfold measure.  apply (in_nextup_height X).
intros. apply (aq dtnb). unfold measure.  apply (in_nextup_height X). Qed.

Lemma gs2_hs2 (U W fty : Type) rlsl rlsr (P : fty -> U -> W -> Type)
  A sub cl cr (dl : derrec rlsl emptyT cl) (dr : derrec rlsr emptyT cr)
  psl psr (brl : botRule_fc (fcI dl) psl cl) (brr : botRule_fc (fcI dr) psr cr):
  gen_step2 P A sub (derrec rlsl emptyT) (derrec rlsr emptyT) psl cl psr cr ->
  height_step2_tr (dt2fun P) A sub (fcI dl) (fcI dr).
Proof. intro gs2. apply gs2_tr_height.  apply gs2c_gs2tr. apply gs2_gs2c.
rewrite (snd (botRule_fc_prems brl)).  rewrite (snd (botRule_fc_prems brr)).
exact gs2. Qed.

Print Implicit gs2_tr_height.  Print Implicit gs2_hs2.
Check (gs2_hs2 (get_botrule _) (get_botrule _)).

Definition sumh_step2_tr U W fty (rulesa : rlsT U) (rulesb : rlsT W)
  (P : fty -> derrec_fc rulesa emptyT -> derrec_fc rulesb emptyT -> Type)
    A sub :=
      sum_step2_tr P A sub (@derrec_fc_height _ _ _) (@derrec_fc_height _ _ _).

Lemma sum_step2_tr_gf2 U W fty (P : fty -> U -> W -> Type)
    A sub gsa gsb dta dtb :
  iffT (sum_step2_tr P A sub gsa gsb dta dtb)
    (gf2_step_tr (fun fml ab => P fml (fst ab) (snd ab)) A sub
      (measure (fun ab => Nat.add (gsa (fst ab)) (gsb (snd ab)))) (dta, dtb)).
Proof. unfold sum_step2_tr. unfold gf2_step_tr.
unfold iffT. split.
- intros fsglp sp glpp.
simpl. apply fsglp.
+ intros A' saa a b.
apply (sp A' saa (a, b)). apply AccT_measure.
+ intros *. specialize (glpp (dta', dtb')).
unfold measure in glpp. simpl in glpp. exact glpp.
- intros sglpp sp glp.
simpl in sglpp. apply sglpp.
intros. destruct dts.  simpl. apply sp. apply X.
intros. destruct dts'. simpl. apply glp.
unfold measure in H. simpl in H. exact H.
Qed.

Definition sum_step2_tr_D_gf2 U W fty P A sub gsa gsb dta dtb :=
  iffT_D1 (@sum_step2_tr_gf2 U W fty P A sub gsa gsb dta dtb).

Lemma sum_step2_tr_lem U W fty (P : fty -> U -> W -> Type)
    A sub gsa gsb dta dtb : AccT sub A ->
  (forall A dta dtb, sum_step2_tr P A sub gsa gsb dta dtb) -> P A dta dtb.
Proof. intros *. intros acc ss.
pose (fun fty UW => P fty (fst UW) (snd UW)) as Q.
assert (Q A (dta, dtb)).
eapply gf2_step_tr_lem.
intros.  apply sum_step2_tr_D_gf2.
all: cycle 1. exact acc. apply AccT_measure.
subst Q. simpl in X. exact X.
destruct dts. apply ss. Qed.

Check sum_step2_tr_lem.

Lemma gf2_sum U W fty (P : fty -> U -> W -> Type) A sub gsa gsb dta dtb:
  gf_step2_tr P A sub (measure gsa) (measure gsb) dta dtb ->
    sum_step2_tr P A sub gsa gsb dta dtb.
Proof. unfold sum_step2_tr. unfold gf_step2_tr.
intros gf2 saa lgss.
require gf2. intros. exact (saa A' X a b).
apply gf2 ; intros ; apply lgss ; unfold measure in H.
apply Plus.plus_lt_compat_r. exact H.
apply Plus.plus_lt_compat_l. exact H. Qed.

Lemma sumh_step2_tr_lem U W fty (rulesa : rlsT U) (rulesb : rlsT W)
  (P : fty -> derrec_fc rulesa emptyT -> derrec_fc rulesb emptyT -> Type)
  (A : fty) sub dta dtb : AccT sub A ->
  (forall A dta dtb, sumh_step2_tr P A sub dta dtb) -> P A dta dtb.
Proof. unfold sumh_step2_tr.  apply sum_step2_tr_lem. Qed.

Lemma hs2_sumh U W fty rulesa rulesb P A sub dta dtb:
  @height_step2_tr U W fty rulesa rulesb P A sub dta dtb ->
  @sumh_step2_tr U W fty rulesa rulesb P A sub dta dtb.
Proof. unfold height_step2_tr. unfold sumh_step2_tr. apply gf2_sum. Qed.

(* TODO

if possible, need to look at gen_step2sr
gs2_tr_sr
gs2_sr_tr

val _ = qed_goal_spec_mp "gs2_sr_tr" gentree.thy
  "valid rls dta --> valid rls dtb --> \
    \ gen_step2sr P A sub rls (botRule dta, botRule dtb) --> \
    \ gen_step2_tr (%A (dtl, dtr). P A (conclDT dtl, conclDT dtr)) \
        \ A sub (dta, dtb)"

first, link gen_step and gen_step_c
for gen_step, derivs needs to be derrec rules emptyT
gen_step has ps concl arg, gen_step_c has tree

*)
(* summary of some results for two trees *)
(*
Print gen_step2.
Print gen_step2_c.
Print gen_step2_tr.
Print gf_step2_tr.
Print height_step2_tr.
Check gen_step2_lemT.
Check gen_step2_tr_lem.
Check gf_step2_tr_lem.
Check height_step2_tr_lem.
Check gs2_gs2c.
Check gs2c_gs2tr.
Check gs2tr_gf2.
Check gs2_tr_height.
*)


Require Import List.
Require Import Arith.

CoInductive Stream (a:Type) : Type :=
| Cons : a -> Stream a -> Stream a
.

Arguments Cons {a} _ _.

Definition head (a:Type) (s:Stream a) : a :=
    match s with
    | Cons x _  => x
    end.

Arguments head {a} _.

Definition tail (a:Type) (s:Stream a) : Stream a :=
    match s with
    | Cons _ t  => t
    end.

Arguments tail {a} _.

Fixpoint take (a:Type) (n:nat) (s:Stream a) : list a :=
    match n with
    | 0     => nil
    | S p   =>
        match s with
        | Cons h t      => h :: take a p t
        end
    end.

Arguments take {a} _ _.

(* our experience of induction suggests this may not be the best *)
CoFixpoint map' (a b:Type) (f:a -> b) (s:Stream a) : Stream b :=
    match s with
    | Cons h t  => Cons (f h) (map' a b f t)
    end.

Arguments map' {a} {b} _ _.

(* our experience of induction suggests this could be better *)
Definition map (a b:Type) (f:a -> b) : Stream a -> Stream b :=
    cofix g (s:Stream a) : Stream b :=
        match s with
        | Cons h t  => Cons(f h) (g t)
        end.

Arguments map {a} {b} _ _.

CoFixpoint zeroes : Stream nat := Cons 0 zeroes.

CoFixpoint from (n:nat) : Stream nat := Cons n (from (S n)).

Definition nats : Stream nat := from 0.

CoFixpoint ones : Stream nat := Cons 1 ones.
Definition ones': Stream nat := map S zeroes.

Example take_test1 : take 5 zeroes = 0::0::0::0::0::nil.
Proof. reflexivity. Qed.

Example take_test2 : take 6 nats = 0::1::2::3::4::5::nil.
Proof. reflexivity. Qed.

CoFixpoint interleave (a:Type) (s1 s2:Stream a) : Stream a :=
    match s1, s2 with
    | Cons h1 t1, Cons h2 t2    => Cons h1 (Cons h2 (interleave a t1 t2))
    end.

Arguments interleave {a} _ _.

(* unguarded recursive call *)
Fail CoFixpoint bizarre (a b:Type) (f:a -> b) (s:Stream a) : Stream b :=
    match s with
    | Cons h t => interleave (Cons (f h) (bizarre a b f t)) (Cons (f h) (bizarre a b f t))
    end.

(* unguarded recursive call  *)
Fail CoFixpoint bad : Stream nat := tail (Cons 0 bad).

(* not quite the same as 'id': this function appears to be
   very useful when writing some coinductive proofs         *)
Definition frob (a:Type) (s:Stream a) : Stream a :=
    match s with
    | Cons h t  => Cons h t
    end.

Arguments frob {a} _.

(* seems pointless and yet very useful *)
Lemma frob_same : forall (a:Type) (s:Stream a), s = frob s.
Proof. intros a [h t]. reflexivity. Qed.

Arguments frob_same {a} _.

CoInductive stream_eq (a:Type) : Stream a -> Stream a -> Prop :=
| Stream_eq : forall (x:a) (t1 t2:Stream a),
    stream_eq a t1 t2 -> stream_eq a (Cons x t1) (Cons x t2).

Arguments stream_eq  {a} _ _.

Lemma stream_destruct : forall (a:Type) (x y:a) (t1 t2:Stream a),
    stream_eq (Cons x t1) (Cons y t2) -> x = y /\ stream_eq t1 t2.
Proof.
    intros a x y t1 t2 H. inversion H. split.
    - reflexivity.
    - assumption.
Qed.

(* true but seemingly not useful, leading to non-guarded proofs *)
Lemma stream_eq_basic : forall (a:Type) (s1 s2:Stream a),
    head s1 = head s2               ->
    stream_eq (tail s1) (tail s2)   ->
    stream_eq s1 s2.
Proof.
    intros a [h1 t1] [h2 t2]. simpl. intros Head Tail.
    rewrite Head. constructor. assumption.
Qed.

(* coinductive principle for stream_eq *)
Lemma stream_eq_coind : forall (a:Type) (R:Stream a -> Stream a -> Prop),
    (forall (s1 s2:Stream a), R s1 s2 -> head s1 = head s2)     ->
    (forall (s1 s2:Stream a), R s1 s2 -> R (tail s1) (tail s2)) ->
    (forall (s1 s2:Stream a), R s1 s2 -> stream_eq s1 s2).
Proof.
    intros a R Hhead Htail. cofix coIH.
    intros [h1 t1] [h2 t2] H.
    generalize H. intro H'.
    apply Hhead in H'. simpl in H'.
    rewrite H'. constructor.
    apply coIH.
    apply Htail in H. simpl in H.
    assumption.
Qed.

Arguments stream_eq_coind {a} _ _ _.

(* direct proof, using cofix tactic *)
Lemma stream_eq_refl : forall (a:Type) (s:Stream a), stream_eq s s.
Proof.
    intros a. cofix coIH. intros [h t].
    constructor. apply coIH.
Qed.

(* proof using coinduction principle, not using cofix tactic *)
Lemma stream_eq_refl' : forall (a:Type) (s:Stream a), stream_eq s s.
Proof.
    intros a s. apply (stream_eq_coind (fun x y => x = y)).
    - clear s. intros s1 s2 H. rewrite H. reflexivity.
    - clear s. intros s1 s2 H. rewrite H. reflexivity.
    - reflexivity.
Qed.

(* direct proof, so using cofix tactic *)
Lemma stream_eq_sym : forall (a:Type) (s1 s2:Stream a),
    stream_eq s1 s2 -> stream_eq s2 s1.
Proof.
    intros a. cofix coIH. intros s1 s2 H. destruct H.
    constructor. apply coIH.
    assumption.
Qed.

(* proof using coinduction principle, not using cofix tactic*)
Lemma stream_eq_sym' : forall (a:Type) (s1 s2:Stream a),
    stream_eq s1 s2 -> stream_eq s2 s1.
Proof.
    intros a s1 s2 H. apply (stream_eq_coind (fun x y => stream_eq y x)).
    - clear s1 s2 H. intros s1 s2 H. destruct H. reflexivity.
    - clear s1 s2 H. intros s1 s2 H. destruct H. assumption.
    - assumption.
Qed.

(* direct proof, so using cofix tactic *)
Lemma stream_eq_trans : forall (a:Type) (s1 s2 s3:Stream a),
    stream_eq s1 s2 -> stream_eq s2 s3 -> stream_eq s1 s3.
Proof.
    intros a. cofix coIH. intros s1 s2 s3 H12. revert s3.
    destruct H12. intros s3 H23.
    remember (Cons x t2) as s2 eqn:E in H23. revert E.
    destruct H23. intros H. inversion H. subst.
    constructor.
    apply coIH with t2; assumption.
Qed.

(* proof using coinduction principle, not using cofix tactic *)
Lemma stream_eq_trans' : forall (a:Type) (s1 s2 s3:Stream a),
    stream_eq s1 s2 -> stream_eq s2 s3 -> stream_eq s1 s3.
Proof.
   intros a s1 s2 s3 H12 H23.
   apply (stream_eq_coind
    (fun x z => exists y, stream_eq x y /\ stream_eq y z)).
    - clear s1 s2 s3 H12 H23. intros s1 s3 [s2 [H12 H23]].
      revert s3 H23. destruct H12. intros s3 H23.
      remember (Cons x t2) as s2 eqn:E in H23. revert E.
      destruct H23. intros H. inversion H. subst.
      reflexivity.
    - clear s1 s2 s3 H12 H23. intros s1 s3 [s2 [H12 H23]].
      exists (tail s2). split.
      + destruct H12. assumption.
      + destruct H23. assumption.
    - exists s2. split; assumption.
Qed.

(* predicate needed for using coinduction principle of stream_eq *)
CoInductive is_ones : Stream nat ->  Prop :=
| IsOnes : forall (s:Stream nat), is_ones s -> is_ones (Cons 1 s)
.

Lemma ones_are_ones : is_ones ones.
Proof.
    cofix coIH. rewrite frob_same. simpl. constructor. assumption.
Qed.

Lemma ones_are_ones' : is_ones ones'.
Proof.
    cofix coIH. rewrite frob_same. simpl. constructor. assumption.
Qed.

(* direct proof, so using cofix tactic *)
Lemma ones_same : stream_eq ones ones'.
Proof.
    cofix coIH.
    rewrite (frob_same ones).
    rewrite (frob_same ones').
    simpl. constructor. assumption.
Qed.

(* proof using coinduction principle, so not using cofix tactic *)
Lemma ones_same' : stream_eq ones ones'.
Proof.
    apply (stream_eq_coind (fun x y => is_ones x /\ is_ones y)).
    - intros s1 s2 [H1 H2]. destruct H1, H2. reflexivity.
    - intros s1 s2 [H1 H2]. destruct H1, H2. split; assumption.
    - split.
        + apply ones_are_ones.
        + apply ones_are_ones'.
Qed.

(* actually we can do even simpler: syntactic equality between streams useful *)
Lemma ones_same'' : stream_eq ones ones'.
Proof.
    apply (stream_eq_coind (fun x y => x = ones /\ y = ones')).
    - intros s1 s2 [H1 H2]. rewrite H1, H2. reflexivity.
    - intros s1 s2 [H1 H2]. rewrite H1, H2. split; reflexivity.
    - split; reflexivity.
Qed.

(* direct proof, so using cofix tactic *)
Lemma map_same : forall (a b:Type) (f:a -> b) (s:Stream a),
    stream_eq (map f s) (map' f s).
Proof.
    intros a b f. cofix coIH. intros [h t].
    rewrite (frob_same (map  f (Cons h t))).
    rewrite (frob_same (map' f (Cons h t))).
    simpl. constructor. apply coIH.
Qed.

(* proof using coinduction principle: syntactic equality between streams useful *)
Lemma map_same' : forall (a b:Type) (f:a -> b) (s:Stream a),
    stream_eq (map f s) (map' f s).
Proof.
    intros a b f s.
    apply (stream_eq_coind (fun x y => exists s, x = map f s /\ y = map' f s)).
    - clear s. intros s1 s2 [s [H1 H2]]. rewrite H1, H2. destruct s. reflexivity.
    - clear s. intros s1 s2 [s [H1 H2]]. rewrite H1, H2. destruct s.
      exists s. split; reflexivity.
    - exists s. split; reflexivity.
Qed.

(* direct proof, so using cofix tactic *)
Theorem stream_eq_loop : forall (a:Type) (s1 s2:Stream a),
    head s1 = head s2 -> tail s1 = s1 -> tail s2 = s2 -> stream_eq s1 s2.
Proof.
    intros a. cofix coIH. intros [h1 t1] [h2 t2] H T1 T2.
    simpl in H. rewrite <- H. constructor.
    simpl in T1, T2. apply coIH.
    + rewrite T1, T2. assumption.
    + rewrite T1. assumption.
    + rewrite T2. assumption.
Qed.

(* proof using coinduction principle,so not using confix tactic *)
Theorem stream_eq_loop' : forall (a:Type) (s1 s2:Stream a),
    head s1 = head s2 -> tail s1 = s1 -> tail s2 = s2 -> stream_eq s1 s2.
Proof.
    intros a s1 s2 H T1 T2. apply (stream_eq_coind (fun x y => x = s1 /\ y = s2)).
    - intros x y [Hx Hy]. subst. assumption.
    - intros x y [Hx Hy]. subst. split; assumption.
    - split; reflexivity.
Qed.

CoFixpoint fact_slow' (n:nat) : Stream nat := Cons (fact n) (fact_slow' (S n)).
Definition fact_slow := fact_slow' 1.

CoFixpoint fact_iter' (cur acc:nat) : Stream nat := Cons acc (fact_iter' (S cur) (acc * cur)).
Definition fact_iter := fact_iter' 2 1.

(*
Eval simpl in (take 5 fact_slow).
Eval simpl in (take 5 fact_iter).
*)

Lemma fact_basic: forall (n:nat), fact (S n) = (S n) * fact n.
Proof.
    induction n as [|n IH].
    - reflexivity.
    - unfold fact at 1. fold (fact (S n)). reflexivity.
Qed.

Lemma fact_def : forall (x n:nat), fact_iter' x (fact n * S n) = fact_iter' x (fact (S n)).
Proof.
    intros x n. rewrite mult_comm. rewrite <- fact_basic. reflexivity.
Qed.

Lemma fact_eq' : forall (n:nat), stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
Proof.
    intros n. apply (stream_eq_coind (fun x y => exists n,
        x = fact_iter' (S n) (fact n) /\ y = fact_slow' n)).
    - clear n. intros x y [n [H1 H2]]. rewrite H1, H2. reflexivity.
    - clear n. intros x y [n [H1 H2]]. exists (S n). split.
        + rewrite H1. simpl.
          assert (fact n * S n = fact n + n * fact n) as E. { ring. }
          rewrite E. reflexivity.
        + rewrite H2. reflexivity.
    - exists n. split; reflexivity.
Qed.

Theorem fact_eq : stream_eq fact_iter fact_slow.
Proof. apply fact_eq'. Qed.

Theorem stream_eq_onequant : forall (a b:Type) (f g: a -> Stream b),
    (forall (x:a), head (f x) = head (g x)) ->
    (forall (x:a), exists (y:a), tail (f x) = f y /\ tail (g x) = g y) ->
    (forall (x:a), stream_eq (f x) (g x)).
Proof.
    intros a b f g H T x. apply (stream_eq_coind (fun s1 s2 =>
        exists y, s1 = f y /\ s2 = g y)).
    - clear x. intros s1 s2 [x [H1 H2]]. subst. apply H.
    - clear x. intros s1 s2 [x [H1 H2]]. subst. apply T.
    - exists x. split; reflexivity.
Qed.

Lemma fact_eq'' : forall (n:nat), stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
Proof.
    apply stream_eq_onequant.
    - intros x. reflexivity.
    - intros x. exists (S x). split.
        + simpl. assert (fact x * S x = fact x + x * fact x) as E. { ring. }
          rewrite E. reflexivity.
        + reflexivity.
Qed.


Add LoadPath ".".

Require Import "MyNat".

Lemma ySx:forall x y:MyNat,
(y<x\/y=x)<->y<S x.
intros.
split.
intros.
elim H.
intro.
elim H0.
intro.
exists (S x0).
simpl.
simpl in H1.
rewrite H1.
auto.
intro.
exists O.
rewrite H0.
auto.

intros.
elim H.
intro.
elim x0.
intro.
right.
simpl in H0.
apply Ax2.
auto.
intros.
left.
exists m.
simpl. simpl in H1.
apply Ax2.
auto.
Qed.

Lemma L3:forall P:MyNat->Prop,
forall x:MyNat,
((forall y:MyNat,y<x->P y)/\P x)
->(forall y:MyNat,y<S x->P y).
intros P x H0 y.
elim (ySx x y) .
intros.
apply H1 in H2.
elim H2.
apply H0.
intro.
rewrite->H3.
apply H0.
Qed.
Lemma L4:forall P:MyNat->Prop,
(forall x:MyNat,(forall y:MyNat,y< x->P y)
->P x)
->forall x y:MyNat,y<x->P y.
intros P H0 x.
elim x.
intros.
apply False_ind.
apply (MagRel1 y O).
elim y.
auto.
intros.
right. exists m. apply Comm.
apply H.
intros m H1.
apply L3.
split.
apply H1.
apply H0.
apply H1.
Qed.
Theorem SAI :
forall P:MyNat->Prop,
(forall x:MyNat,
(forall y:MyNat,y<x->P y)->P x)
->(forall x:MyNat,P x).
intros.
apply L4 with (x:=S x).
apply H.
exists O.
auto.
Qed.


Require Import Arith.
Require Import List.

(*
Require Import Peano.
Require Import Peano_dec.
*)

Inductive Ty : Set :=
| Imp : Ty -> Ty -> Ty
| TV : nat -> Ty
| Nu : Ty -> Ty
| One : Ty
| And : Ty -> Ty -> Ty
| Or : Ty -> Ty -> Ty.

Inductive Term : Set :=
| V : nat -> Term
| Unit : Term
| Pair : Term -> Term -> Term
| Inl : Ty -> Term -> Term
| Inr : Ty -> Term -> Term
| Cas : Term -> Term -> Term -> Term
| Spl : Term -> Term -> Term
| Rec : nat -> Term -> Term
| App : Term -> Term -> Term
| Abs : Ty -> Term -> Term
| I : Ty -> Term -> Term
| O : Ty -> Term -> Term.

Lemma ty_eq_dec : forall (ty1 ty2 : Ty), {ty1 = ty2} + {ty1 <> ty2}.
Proof.
  decide equality. decide equality.
Defined.

Inductive Ctx : Set :=
| G : nat -> list Ty -> Ctx.

Inductive Holds : Set :=
| H : Ctx -> Term -> Ty -> Holds.

Notation "n ; l |= t @ ty" := (H (G n l) t ty) (at level 60).
Open Scope list_scope.

Fixpoint tyshift (ty : Ty) (d : nat) {struct ty} : Ty :=
  match ty with
    | One => One
    | Imp ty0 ty1 => Imp (tyshift ty0 d) (tyshift ty1 d)
    | TV m => if le_lt_dec d m then TV (S m) else TV m
    | Nu ty0 => Nu (tyshift ty0 (S d))
    | And ty0 ty1 => And (tyshift ty0 d) (tyshift ty1 d)
    | Or ty0 ty1 => Or (tyshift ty0 d) (tyshift ty1 d)
  end.

Require Import Omega.
Definition tysub : forall (ty : Ty) (n : nat) (s : Ty), Ty.
Proof.
  refine
    (fix tysub (ty : Ty) (n : nat) (s : Ty) {struct ty} : Ty :=
      match ty with
        | TV m => match le_lt_dec n m with
                    | left p => match eq_nat_dec n m with
                                  | left _ => s
                                  | right p' =>
                                    (match m as m' return (m = m' -> Ty) with
                                      | 0 => (fun p'' => False_rec _ _)
                                      | S m' => (fun _ => TV m')
                                     end) (refl_equal m)
                                end
                    | right _ => TV m
                  end
        | Imp ty1 ty2 => Imp (tysub ty1 n s) (tysub ty2 n s)
        | One => One
        | And ty0 ty1 => And (tysub ty0 n s) (tysub ty1 n s)
        | Or ty0 ty1 => Or (tysub ty0 n s) (tysub ty1 n s)
        | Nu t => Nu (tysub t (S n) (tyshift s n))
      end).
  destruct m. apply le_n_O_eq in p. apply p'. auto. inversion p''.
Defined.

Fixpoint valid (ty : Ty) (n : nat) {struct ty} : Prop :=
  match ty with
    | TV m =>
      if le_lt_dec n m
        then False
        else True
    | Imp s t => valid s n /\ valid t n
    | One => True
    | And s t => valid s n /\ valid t n
    | Or s t => valid s n /\ valid t n
    | Nu t => valid t (S n)
  end.

Definition valid_dec : forall (ty : Ty) (n : nat), {valid ty n}+{~ valid ty n}.
Proof.
  induction ty ; intros ; simpl ; auto ; firstorder.

  (* TV *) intros.
  case_eq (le_lt_dec n0 n). intros. right. simpl. auto.
  intros. left. simpl. auto.
Defined.

Lemma tyshift_level : forall ty1 n,
  valid ty1 n -> valid (tyshift ty1 n) (S n).
Proof.
  induction ty1 ; intros ; simpl ; firstorder.
  (* TV *)
  case_eq (le_lt_dec n0 n). simpl. intros. rewrite H1.
  simpl in H0. rewrite H1 in H0. inversion H0.
  intros. simpl. destruct n. auto.
  case_eq (le_lt_dec n0 n). intros. simpl. omega. simpl. intros. auto.
Defined.

Lemma tysub_level : forall ty1 ty2 n,
  valid ty1 (S n) -> valid ty2 n -> valid (tysub ty1 n ty2) n.
Proof.
   induction ty1 ; intros ; simpl ; firstorder.
   (* TV *)
   simpl.
   case_eq (le_lt_dec n0 n); case_eq (eq_nat_dec n0 n) ; intros ; auto.
   destruct n. absurd (n0 <> 0). omega. omega.
   simpl in H0. case_eq (le_lt_dec n0 n). intros. rewrite H4 in H0. simpl in H0. inversion H0.
   intros. clear H0.  absurd (n0 <> S n). intros. omega. omega.
   absurd (n0 = n). omega. omega. simpl. rewrite H3. auto.
   (* Nu *)
   intros. simpl in H0. simpl.
   apply IHty1. auto.
   (* need tyshift lemma *)
   apply tyshift_level. auto.
 Defined.

Inductive Derivation : Holds -> Set :=
| ImpIntro : forall n l t ty xty,
  valid xty n ->
  Derivation (n ; l |= t @ ty) ->
  Derivation (n ; xty::l |= (Abs xty t) @ (Imp xty ty))
| ImpElim : forall n l t f ty xty,
  Derivation (n ; l |= t @ xty) ->
  Derivation (n ; l |= f @ (Imp xty ty)) ->
  Derivation (n ; l |= (App f t) @ ty)
| OneIntro : forall n l,
  Derivation (n ; l |= Unit @ One)
| PairIntro : forall n l r s rty sty,
  Derivation (n ; l |= r @ rty) ->
  Derivation (n ; l |= s @ sty) ->
  Derivation (n ; l |= Pair r s @ And rty sty)
| PairElim : forall n l r s aty bty cty,
  Derivation (n ; l |= r @ And aty bty) ->
  Derivation (n ; aty::bty::l |= s @ cty) ->
  Derivation (n ; l |= Spl r s @ cty)
| OrIntroL : forall n l t lty rty,
  valid rty n ->
  Derivation (n ; l |= t @ lty) ->
  Derivation (n ; l |= Inl (Or lty rty) t @ Or lty rty)
| OrIntroR : forall n l t lty rty,
  valid lty n ->
  Derivation (n ; l |= t @ rty) ->
  Derivation (n ; l |= Inr (Or lty rty) t @ Or lty rty)
| OrElim : forall n l r s t lty rty cty,
  Derivation (n ; l |= r @ Or lty rty) ->
  Derivation (n ; lty::l |= s @ cty) ->
  Derivation (n ; rty::l |= t @ cty) ->
  Derivation (n ; l |= Cas r s t @ cty)
| NuIntro : forall n l r ty,
  Derivation (S n ; l |= r @ tysub ty 0 (Nu ty)) ->
  Derivation (n ; l |= I (Nu ty) r @ Nu ty)
| NuElim : forall n l r ty,
  Derivation (n ; l |= r @ Nu ty) ->
  Derivation (S n ; l |= O (Nu ty) r @ tysub ty 0 (Nu ty))
| VarIntro : forall n l ty i,
  i < length l -> nth i l One = ty ->
  Derivation (n ; l |= V i @ ty).

Fixpoint typeof (n : nat) (l : list Ty) (t : Term) {struct t} : option Ty :=
  match t with
    | Unit => Some One
    | V n' =>
      if le_lt_dec (length l) n'
        then None
        else Some (nth n' l One)
    | Pair r s =>
      (fun mrty msty =>
        match mrty,msty with
          | Some aty,Some bty => Some (And aty bty)
          | _,_ => None
        end) (typeof n l r) (typeof n l s)
    | Inl ty s =>
      match ty with
        | Or lty rty =>
          (fun mlty =>
            match mlty with
              | Some lty' =>
                if ty_eq_dec lty' lty
                  then if valid_dec rty n
                    then Some (Or lty rty)
                    else None
                  else None
              | _ => None
            end) (typeof n l s)
        | _ => None
      end
    | Inr ty s =>
      match ty with
        | Or lty rty =>
          (fun mrty =>
            match mrty with
              | Some rty' =>
                if ty_eq_dec rty' rty
                  then if valid_dec lty n
                    then Some (Or lty rty)
                    else None
                  else None
              | _ => None
            end) (typeof n l s)
        | _ => None
      end
    | Cas r s t =>
      (fun mrty =>
        match mrty with
          | Some (Or lty rty) =>
            (fun msty mtty =>
              match msty,mtty with
                | Some cty, Some cty' =>
                  if ty_eq_dec cty cty'
                    then Some cty
                    else None
                | _,_ => None
              end) (typeof n (lty::l) s) (typeof n (rty::l) t)
          | _ => None
        end) (typeof n l r)
    | Spl r s =>
      (fun mrty =>
        match mrty with
          | Some (And lty rty) => typeof n (lty::rty::l) s
          | _ => None
        end) (typeof n l r)
    | App r s =>
      (fun mrty msty =>
        match mrty,msty with
          | Some (Imp xty yty),Some xty' =>
            if ty_eq_dec xty' xty
              then Some yty
              else None
          | _,_ => None
        end) (typeof n l r) (typeof n l s)
    | Abs ty r =>
      (fun mrty =>
        match mrty with
          | Some ty' => Some (Imp ty ty')
          | _ => None
        end) (typeof n (ty::l) r)
    | I ty r =>
      (fun mrty =>
        match mrty with
          | Some ty' => Some (Nu ty')
          | _ => None
        end) (typeof (S n) l r)
    | O ty r =>
      (fun mrty =>
        match mrty with
          | Some ty' => Some (Nu ty')
          | _ => None
        end) (typeof (S n) l r)
    | Rec n t =>
      (fun mrty =>
        match mrty with
          | Some ty => Some ty
          | _ => None
        end) (typeof n l t)
  end.

Eval compute in typeof 0 nil (Abs One Unit).

Definition check : forall n l t ty, option (Derivation (n ; l |= t @ ty)).
Proof.
  refine
    (fix check (n : nat) (l : list Ty) (t : Term) (ty : Ty) {struct t} : option (Derivation (n ; l |= t @ ty)) :=
      (match t as t' return t = t' -> option (Derivation (n ; l |= t @ ty)) with
         | V n' => match le_lt_dec (length l) n' with
                     | left p => (fun _ => None (A:=Derivation (n; l |= t @ ty)))
                     | right p =>
                       match ty_eq_dec (nth n' l Zero) ty with
                         | left p' => _
                         | right p' => (fun _ => None (A:=Derivation (n; l |= t @ ty)))
                       end
                   end
         | App r s => (fun r' s' => _) (check n l r (Imp tyx ty)) (check n l s tyx)
         | Abs ty' s => _
         | TApp r ty' => _
         | Lam s => _
       end) (refl_equal t)).
  (* V -- using firstorder as a stand-in for failure *)
  intros. apply Some. apply (VarIntro n l ty) in p.  rewrite <- H0 in p. auto. auto. intros.
  (* App *)
  apply (check n l r

Defined.
Print check.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intros s. unfold eqb_string.
  destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
  - reflexivity.
  - destruct Hs_not_eq. reflexivity.
Qed.

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold eqb_string.
   destruct (string_dec x y) as [Hs_eq | Hs_not_eq].
   - rewrite Hs_eq. split. reflexivity. reflexivity.
   - split.
     + intros contra. discriminate contra.
     + intros H. rewrite H in Hs_not_eq. destruct Hs_not_eq. reflexivity.
Qed.

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <->  x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H. Qed.

Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _ !-> false
  ).

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  intros X v x1 x2 m H.
  unfold t_update.
  rewrite <- eqb_string_false_iff in H.
  rewrite H. reflexivity.
Qed.

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  intros A m v1 v2 x.
  apply functional_extensionality.
  intros y. unfold t_update.
  destruct (eqb_string x y); reflexivity.
Qed.

Definition conj_disj : forall P Q R, P /\ (Q \/ R) -> (P /\ Q) \/ (P /\ R) :=
fun (P Q R : Prop) (H : P /\ (Q \/ R))=>
  match H with
  | conj HP HQR =>
    match HQR with
    | or_introl HQ => or_introl (conj HP HQ)
    | or_intror HR => or_intror (conj HP HR)
    end
  end.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Module Playground1.
Interactive Module Playground1 started

Coq < Require Import Arith Classical.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked

Coq < Fixpoint evenb (n:nat) : bool := match n with | O => true | S O => false | S (S n') => evenb n' end.
evenb is defined
evenb is recursively defined (decreasing on 1st argument)

Coq < Definition oddb (n:nat) : bool := negb (evenb n).
oddb is defined

Coq < Example testoddb1: oddb 1 = true.
1 subgoal

  ============================
  oddb 1 = true

testoddb1 < Proof.
1 subgoal

  ============================
  oddb 1 = true

testoddb1 < simpl.
1 subgoal

  ============================
  oddb 1 = true

testoddb1 < reflexivity.
No more subgoals.

testoddb1 < Qed.
Proof.
simpl.
reflexivity.

Qed.
testoddb1 is defined


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Inductive type : Type :=
| arr : type -> type -> type
| B : type.

Inductive term : Type :=
| lambda : string -> type -> term -> term
| var : string -> term
| app : term -> term -> term
| const : bool -> term
.

Definition idB : term := lambda "x" B (var "x").

Fixpoint subst (n : string) (nt : term) (exp: term) : term :=
  match exp with
  | lambda s t tm =>
      if eqb n s
      then lambda s t tm
      else lambda s t (subst n nt tm)
  | var s =>
      if eqb n s
      then nt
      else var s
  | app t1 t2 =>
      app (subst n nt t1) (subst n nt t2)
  | const b =>
      const b
  end.

Theorem simple_const : subst "x" (const true) (var "x") = const true.
Proof.
  simpl.
  reflexivity.
Qed.

Definition is_value (exp : term) : bool :=
  match exp with
  | app _ _ => false
  | var _   => false
  | _       => true
  end.

Fixpoint step (exp : term) : option term :=
  match exp with
  | app t1 t2 =>
      if is_value t1
      then match t1 with
      | lambda s _ tm =>
          Some (subst s t2 tm)
      | _ => None
      end
      else option_map (fun t1' => app t1' t2) (step t1)
  | _ => None
  end.

Compute step (app idB (const true)).

Theorem step_id : forall e, (step (app idB e) = Some e).
Proof.
  intros.
  simpl.
  apply eq_refl.
Qed.

(*
----------------  [intro_bool]
L |- const b : B

 (v, t) in L
----------------  [intro_var]
 L |- v : t

 L |- e1 : t1 -> t2
 L |- e2 : t1
----------------  [intro_app]
 L |- e1 e2 : t2

 (v,t),L |- e : t2
-----------------------  [intro_lam]
 L |- lambda v : t. e : t -> t2

*)

Inductive firstIn (s : string) (t : type) : list (string * type) -> Prop :=
| fFirst : forall l, firstIn s t (cons (s,t) l)
| fDeeper : forall s' t2 l,
    s' <> s
    -> firstIn s t l
    -> firstIn s t (cons (s',t2) l)
.

Inductive typesto : list (string * type) -> term -> type -> Prop :=
| intro_bool : forall L b,
    typesto L (const b) B
| intro_var : forall L v t,
    firstIn v t L
    -> typesto L (var v) t
| intro_app : forall L e1 e2 t1 t2,
    typesto L e1 (arr t1 t2)
    -> typesto L e2 t2
    -> typesto L (app e1 e2) t2
| intro_lam : forall L v e t t2,
    typesto (cons (v,t) L) e t2
    -> typesto L (lambda v t e) (arr t t2)
.

Lemma only_lambda_is_value : forall e L t1 t2 ,
  is_value e = true
  -> typesto L e (arr t1 t2)
  -> exists s' t' e', e = lambda s' t' e'.
Proof.
  intros.
  inversion H0.
  - rewrite <- H3 in H.
    inversion H.
  - rewrite <- H4 in H. inversion H.
  - exists v, t1, e0. easy.
Qed.

Theorem progress : forall L e t,
  typesto L e t
  -> L = nil
  -> is_value e = true \/ exists e', step e = Some e'.
Proof.
  intros.
  induction H.
  - left; reflexivity.
  - right.
    rewrite H0 in H.
    inversion H.
  - right.
    apply IHtypesto1 in H0.
    inversion H0.
    inversion IHtypesto1.

  refine (ex_intro _ (const b) _).
    reflexivity.
  - now exists (var v).
  -
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Lists accessed with integers (not nat) and using LibBag typeclasses     *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibOperation LibReflect
  LibProd LibNat LibInt LibOption LibWf.
Require Export LibList LibNat.
Require Import LibInt.
Require Export LibBag.

Open Local Scope comp_scope.

(* ********************************************************************** *)
(** * List operations using indices in Z *)

Section Zindices.
Variables A : Type.
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types i : int.
Ltac auto_tilde ::= eauto with maths.

(* ---------------------------------------------------------------------- *)
(** * Definitions *)

(** Functions *)

Definition length (l:list A) :=
  (length l) : int.

Definition nth `{Inhab A} (i:int) (l:list A) :=
  If i < 0 then arbitrary else nth (abs i) l.

Definition update (i:int) (v:A) (l:list A) :=
  If i < 0 then l else LibList.update (abs i) v l.

Definition make (n:int) (v:A) :=
  If n < 0 then arbitrary else make (abs n) v.

End Zindices.

(* ---------------------------------------------------------------------- *)
(** ** Typeclasses read & update operations, binds and index predicates *)

(** Note: we also define [card] as [length], but we use [length] everywhere
    in the specifications. *)

Definition card_impl A (l:list A) : nat :=
  LibList.length l.
  (* todo: should it return a nat or an int? might change... *)

Definition read_impl `{Inhab A} (l:list A) (i:int) : A :=
  nth i l.

Definition update_impl A (l:list A) (i:int) (v:A) : list A :=
  update i v l.

Definition index_impl A (l:list A) (i:int) : Prop :=
  index (LibList.length l : int) i.

Instance card_inst : forall A, BagCard (list A).
 constructor. rapply (@card_impl A). Defined.
Instance read_inst : forall `{Inhab A}, BagRead int A (list A).
 constructor. rapply (@read_impl A H). Defined.
Instance update_inst : forall A, BagUpdate int A (list A).
  constructor. rapply (@update_impl A). Defined.
Instance index_inst : forall A, BagIndex int (list A).
  constructor. rapply (@index_impl A). Defined.

Global Opaque card_inst read_inst update_inst index_inst.

(* LATER
Definition binds_impl A (l:list A) (i:int) (v:A) : Prop :=
  index_impl l i /\ nth i l = v.
  (* deprecated:  ZNth i l v. *)
Instance binds_inst : forall A, BagBinds int A (list A).
  constructor. rapply (@binds_impl A). Defined.
Global Opaque binds_inst
*)

(* ---------------------------------------------------------------------- *)
(** * Properties of length *)

Section LengthProperties.
Variable A : Type.
Implicit Types l : list A.
Ltac auto_tilde ::= eauto with maths.

Lemma length_nonneg : forall A (L: list A), 0 <= length L.
Proof using. intros. unfold length. math. Qed.
Lemma length_nil :
  length (@nil A) = 0.
Proof using. auto. Qed.
Lemma length_cons : forall x l,
  length (x::l) = 1 + length l.
Proof using. intros. unfold length. rew_length~. Qed.
Lemma length_app : forall l1 l2,
  length (l1 ++ l2) = length l1 + length l2.
Proof using. intros. unfold length. rew_length~. Qed.
Lemma length_last : forall x l,
  length (l & x) = 1 + length l.
Proof using. intros. unfold length. rew_length~. Qed.
Lemma length_zero_inv : forall l,
  length l = 0 -> l = nil.
Proof using. intros. unfolds length. applys~ LibList.length_zero_inv. Qed.

End LengthProperties.

Hint Rewrite length_nil length_cons length_app
 length_last length_rev : rew_length.
Hint Rewrite length_nil length_cons length_app
 length_last length_rev : rew_list.

(* ---------------------------------------------------------------------- *)
(** * Properties of zmake *)

Section MakeProperties.
Transparent read_inst.

Lemma read_make : forall `{Inhab A} (i n:int) (v:A),
  index n i -> (make n v)[i] = v.
Proof using.
  introv N. rewrite int_index_def in N. unfold make, read_inst, read_impl, nth.
  case_if. math. simpl. case_if. math.
  applys nth_make. forwards: Zabs_nat_lt i n; try math.
Qed.

Lemma length_make : forall A (n:int) (v:A),
  n >= 0 ->
  length (make n v) = n :> int.
Proof using.
  introv N. unfold make. case_if. math.
  unfold length. rewrite LibList.length_make.
  rewrite~ abs_pos.
Qed.

End MakeProperties.

(* ---------------------------------------------------------------------- *)
(** * Properties of update *)

Section UpdateProperties.
Transparent index_inst read_inst update_inst.

Lemma length_update : forall A (l:list A) (i:int) (v:A),
  length (l[i:=v]) = length l.
Proof using.
  intros. unfold update_inst, update_impl, length, update. simpl.
  case_if. math. rewrite~ length_update.
Qed.

Lemma read_update_case : forall `{Inhab A} (l:list A) (i j:int) (v:A),
  index l j -> l[i:=v][j] = (If i = j then v else l[j]).
Proof using.
  introv. unfold index_inst, index_impl, update_inst, update_impl, update,
    read_inst, read_impl, nth. simpl. introv N. rewrite int_index_def in N.
  case_if. math.
  case_if. case_if. auto. case_if.
    rewrite~ nth_update_eq. apply nat_int_lt. rewrite abs_pos; try math.
    rewrite~ nth_update_neq. apply nat_int_lt. rewrite abs_pos; try math.
      apply nat_int_neq. rewrite abs_pos; try math. rewrite abs_pos; try math.
Qed.

Lemma read_update_eq : forall `{Inhab A} (l:list A) (i:int) (v:A),
  index l i -> (l[i:=v])[i] = v.
Proof using. introv N. rewrite~ read_update_case. case_if~. Qed.

Lemma read_update_neq : forall `{Inhab A} (l:list A) (i j:int) (v:A),
  index l j -> (i <> j) -> (l[i:=v])[j] = l[j].
Proof using. introv N. rewrite~ read_update_case. case_if; auto_false~. Qed.

End UpdateProperties.

(* ---------------------------------------------------------------------- *)
(** * Normalization tactics *)

(** [rew_arr] is a light normalization tactic for array *)

(* TODO: rename to [rew_array_nocase] *)
Hint Rewrite @read_make @length_make @length_update @read_update_eq
  : rew_arr.

Tactic Notation "rew_arr" :=
  autorewrite with rew_arr.
Tactic Notation "rew_arr" "in" hyp(H) :=
  autorewrite with rew_arr in H.
Tactic Notation "rew_arr" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_arr).
  (* autorewrite with rew_arr in *. *)

Tactic Notation "rew_arr" "~" :=
  rew_arr; auto_tilde.
Tactic Notation "rew_arr" "*" :=
  rew_arr; auto_star.
Tactic Notation "rew_arr" "~" "in" hyp(H) :=
  rew_arr in H; auto_tilde.
Tactic Notation "rew_arr" "*" "in" hyp(H) :=
  rew_arr in H; auto_star.
Tactic Notation "rew_arr" "~" "in" "*" :=
  rew_arr in *; auto_tilde.
Tactic Notation "rew_arr" "*" "in" "*" :=
  rew_arr in *; auto_star.

(** [rew_array] is a normalization tactic for array *)

Hint Rewrite @read_make @length_make @length_update @read_update_eq
  @read_update_case : rew_array.

Tactic Notation "rew_array" :=
  autorewrite with rew_array.
Tactic Notation "rew_array" "in" hyp(H) :=
  autorewrite with rew_array in H.
Tactic Notation "rew_array" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_array).
  (* autorewrite with rew_array in *. *)

Tactic Notation "rew_array" "~" :=
  rew_array; auto_tilde.
Tactic Notation "rew_array" "*" :=
  rew_array; auto_star.
Tactic Notation "rew_array" "~" "in" hyp(H) :=
  rew_array in H; auto_tilde.
Tactic Notation "rew_array" "*" "in" hyp(H) :=
  rew_array in H; auto_star.
Tactic Notation "rew_array" "~" "in" "*" :=
  rew_array in *; auto_tilde.
Tactic Notation "rew_array" "*" "in" "*" :=
  rew_array in *; auto_star.

(* ---------------------------------------------------------------------- *)
(** * Valid index predicate *)

Section IndexProperties.
Transparent index_inst.

Lemma index_def : forall A (l:list A) i,
  index l i = index (length l : int) i.
Proof using. auto. Qed.

Lemma index_length_unfold : forall A (l:list A) i,
  index (length l : int) i -> index l i.
Proof using. introv H. rewrite* index_def. Qed.

Lemma index_length_eq : forall A (l:list A) (n:int) i,
  index n i -> n = length l -> index l i.
Proof using. intros. subst. rewrite~ index_def. Qed.

Lemma index_bounds : forall A (l:list A) i,
  index l i = (0 <= i < length l).
Proof using. auto. Qed.

Lemma index_bounds_impl : forall A (l:list A) i,
  0 <= i < length l -> index l i.
Proof using. intros. rewrite~ index_bounds. Qed.

Lemma index_update : forall A (l:list A) i j (v:A),
  index l i -> index (l[j:=v]) i.
Proof using. intros. rewrite index_def in *. rewrite~ length_update. Qed.

Lemma index_zmake : forall A n i (v:A),
  index n i -> index (make n v) i.
Proof using.
  introv H. rewrite index_def. rewrite int_index_def in H.
  rewrite~ length_make. math.
Qed.

End IndexProperties.

(* ---------------------------------------------------------------------- *)
(** * count *)

(* TODO: complete definitions and proofs, which are used by CFML/Dijstra *)

Require Import LibWf.

(* TODO: implement a non-decidable version of count *)

Parameter count : forall A (P:A->Prop) (l:list A), int.

(* currently not used
Parameter count_make : forall A (f:A->Prop) n v,
  count f (make n v) = (If f v then n else 0).
*)

Parameter count_update : forall `{Inhab A} (P:A->Prop) (l:list A) (i:int) v,
  index l i ->
  count P (l[i:=v]) = count P l
    - (If P (l[i]) then 1 else 0)
    + (If P v then 1 else 0).

Parameter count_bounds : forall `{Inhab A} (l:list A) (P:A->Prop),
  0 <= count P l <= length l.

(** The following lemma is used to argue that the update to a sequence,
    when writing a value that satisfies [P] in place of one that did not
    satisfy [P], decreases the total number of values that satisfying
    [P] in the sequence. *)

Lemma count_upto : forall `{Inhab A} (P:A->Prop) (l:list A) (n i:int) (v:A),
  ~ P (l[i]) -> P v -> index l i -> (length l <= n)%Z ->
  upto n (count P (l[i:=v])) (count P l).
Proof using.
  introv Ni Pv Hi Le. forwards K: (count_bounds (l[i:=v]) P). split.
  rewrite length_update in K. math.
  lets M: (@count_update A _). rewrite~ M. clear M.
  do 2 (case_if; tryfalse). math.
Qed.

(* ---------------------------------------------------------------------- *)
(* LATER:

Lemma isTrue_eq_list : forall A {IA:Inhab A} (L1 L2:list A),
  len L1 = len L2 ->
  ((forall i, index (len L1) i -> L1[i] = L2[i]) ->
  (L1 = L2)).

*)

(* ********************************************************************** *)
(** * DEPRECATED -- List predicates using indices in Z *)

Section ZindicesOld.
Variables A : Type.
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types i : int.
Ltac auto_tilde ::= eauto with maths.

(* ---------------------------------------------------------------------- *)
(** * DEPRECATED *)

(** Predicates *)

Definition ZInbound i l :=
  0 <= i /\ i < length l.

Definition ZNth i l x :=
  Nth (abs i) l x /\ 0 <= i.

Definition ZUpdate i x l l' :=
  Update (abs i) x l l' /\ 0 <= i.

(* ---------------------------------------------------------------------- *)
(** * DEPRECATED -- Znth *)

Lemma ZNth_here : forall i x l,
  i = 0 -> ZNth i (x::l) x.
Proof using. intros. subst. split~. constructor. Qed.

Lemma ZNth_zero : forall x l,
  ZNth 0 (x::l) x.
Proof using. intros. apply~ ZNth_here. Qed.

Lemma ZNth_next : forall i j x y l,
  ZNth j l x -> i = j+1 -> ZNth i (y::l) x.
Proof using.
  introv [H P] M. subst. split~.
  applys_eq* Nth_next 3. rew_abs_pos~.
Qed.

Lemma ZNth_app_l : forall i x l1 l2,
  ZNth i l1 x -> ZNth i (l1 ++ l2) x.
Proof using. introv [H P]. split~. apply~ Nth_app_l. Qed.

Lemma ZNth_app_r : forall i j x l1 l2,
  ZNth j l2 x -> i = j + length l1 -> ZNth i (l1 ++ l2) x.
Proof using.
  introv [H P]. unfold length. split~. subst.
  apply* Nth_app_r. rew_abs_pos~.
Qed.

Lemma ZNth_nil_inv : forall i x,
  ZNth i nil x -> False.
Proof using. introv [H P]. apply* Nth_nil_inv. Qed.

Lemma ZNth_cons_inv : forall i x l,
  ZNth i l x ->
     (exists q, l = x::q /\ i = 0)
  \/ (exists y q j, l = y::q /\ ZNth j q x /\ i = j+1).
Proof using.
  introv [H P]. forwards~: (@abs_pos i).
  destruct (Nth_cons_inv H); unpack.
  left. exists___. split~.
  right. exists___. splits~.
   split. rewrite* abs_pos_nat. math.
   math.
Qed.

Lemma ZNth_inbound : forall i l,
   ZInbound i l -> exists x, ZNth i l x.
Proof using.
  introv [P U]. unfolds length. gen_eq n: (abs i).
  gen i l. induction n; intros;
    forwards~: (@abs_pos i); destruct l; rew_length in U; try math.
  math_rewrite (i = 0). exists __. split~. constructor.
  forwards~ [x [M P']]: (>> IHn (i-1) l).
    forwards~: (@abs_spos i).
    exists x. split~. rewrite~ (@abs_spos i). constructor~.
Qed.

(* ---------------------------------------------------------------------- *)
(** * DEPRECATED -- ZInbound *)

Lemma ZInbound_zero : forall x l,
  ZInbound 0 (x::l).
Proof using. split; unfold length; rew_list~. Qed.

Lemma ZInbound_zero_not_nil : forall x l,
  l <> nil -> ZInbound 0 l.
Proof using.
  intros. split~. unfold length.
  destruct l; tryfalse. rew_list~.
Qed.

Lemma ZInbound_cons : forall i j x l,
  ZInbound j l -> j = i-1 -> ZInbound i (x::l).
Proof using. introv [P U] H. split; rew_list~. Qed.

Lemma ZInbound_nil_inv : forall i,
  ZInbound i nil -> False.
Proof using. introv [P U]. rew_list in U. math. Qed.

Lemma ZInbound_cons_inv : forall i x l,
  ZInbound i (x::l) -> i = 0 \/ (i <> 0 /\ ZInbound (i-1) l).
Proof using.
  introv [P U]. rew_length in U. tests: (i = 0).
    left~.
    right~. split. math. split~.
Qed.

Lemma ZInbound_cons_pos_inv : forall i x l,
  ZInbound i (x::l) -> i <> 0 -> ZInbound (i-1) l.
Proof using.
  introv H P. destruct* (ZInbound_cons_inv H).
Qed.

Lemma ZInbound_one_pos_inv : forall i x,
  ZInbound i (x::nil) -> i <> 0 -> False.
Proof using.
  intros. eapply ZInbound_nil_inv. apply* ZInbound_cons_pos_inv.
Qed.

Lemma ZInbound_app_l_inv : forall i l1 l2,
  ZInbound i (l1++l2) -> i < length l1 -> ZInbound i l1.
Proof using. introv [P U] H. split~. Qed.

Lemma ZInbound_app_r_inv : forall i j l1 l2,
  ZInbound j (l1++l2) -> j = length l1 + i -> i >= 0 -> ZInbound i l2.
Proof using. introv [P U] R H. rew_length in U. split~. Qed.

(* ---------------------------------------------------------------------- *)
(** * DEPRECATED -- ZUpdate *)

Lemma ZUpdate_here : forall x y l,
  ZUpdate 0 x (y::l) (x::l).
Proof using. split~. apply Update_here. Qed.

Lemma ZUpdate_cons : forall i j x y l l',
  ZUpdate j x l l' -> i = j+1 -> ZUpdate i x (y::l) (y::l').
Proof using.
  introv [U P] H. split~. applys_eq~ Update_cons 4.
  subst. rew_abs_pos~.
Qed.

Lemma ZUpdate_app_l : forall i x l1 l1' l2,
  ZUpdate i x l1 l1' -> ZUpdate i x (l1++l2) (l1'++l2).
Proof using. introv [U P]. split~. apply~ Update_app_l. Qed.

Lemma ZUpdate_app_r : forall i j x l1 l2 l2',
  ZUpdate j x l2 l2' -> i = j + length l1 -> ZUpdate i x (l1++l2) (l1++l2').
Proof using.
  introv [U P] H. unfolds length. split~. apply~ Update_app_r.
  subst. rew_abs_pos~.
Qed.

Lemma ZUpdate_not_nil : forall i x l1 l2,
  ZUpdate i x l1 l2 -> l2 <> nil.
Proof using. introv [U P]. apply~ Update_not_nil. Qed.

Lemma ZUpdate_length : forall i x l l',
  ZUpdate i x l l' -> length l = length l'.
Proof using.
  introv [U P]. unfolds length.
  forwards~: Update_length.
Qed.

End ZindicesOld.


From Hammer Require Import Hammer.

Require Import Setoid Morphisms Basics Equalities Orders.
Set Implicit Arguments.

Inductive ord : Set := OEQ | OLT | OLE.
Definition trans_ord o o' :=
match o, o' with
| OEQ, _ => o'
| _, OEQ => o
| OLE, OLE => OLE
| _, _ => OLT
end.
Local Infix "+" := trans_ord.

Module Type IsTotalOrder (O:EqLtLe) :=
IsEq O <+ IsStrOrder O <+ LeIsLtEq O <+ LtIsTotal O.

Module OrderFacts (Import O:EqLtLe)(P:IsTotalOrder O).
Include EqLtLeNotation O.

Lemma eq_refl : forall x, x==x.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.eq_refl".   reflexivity. Qed.

Lemma le_refl : forall x, x<=x.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.le_refl".   intros; rewrite P.le_lteq; right; reflexivity. Qed.

Lemma lt_irrefl : forall x, ~ x<x.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.lt_irrefl".   intros. apply StrictOrder_Irreflexive. Qed.

Lemma eq_sym : forall x y, x==y -> y==x.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.eq_sym".   auto with *. Qed.

Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.le_antisym".
intros x y; rewrite 2 P.le_lteq. intuition.
elim (StrictOrder_Irreflexive x); transitivity y; auto.
Qed.

Lemma neq_sym : forall x y, ~x==y -> ~y==x.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.neq_sym".   auto using eq_sym. Qed.

Ltac subst_eqns :=
match goal with
| H : _==_ |- _ => (rewrite H || rewrite <- H); clear H; subst_eqns
| _ => idtac
end.

Definition interp_ord o :=
match o with OEQ => O.eq | OLT => O.lt | OLE => O.le end.
Local Notation "#" := interp_ord.

Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.trans".
destruct o, o'; simpl; intros x y z;
rewrite ?P.le_lteq; intuition auto;
subst_eqns; eauto using (StrictOrder_Transitive x y z) with *.
Qed.

Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z.
Definition le_trans x y z : x<=y -> y<=z -> x<=z := @trans OLE OLE x y z.
Definition lt_trans x y z : x<y -> y<z -> x<z := @trans OLT OLT x y z.
Definition le_lt_trans x y z : x<=y -> y<z -> x<z := @trans OLE OLT x y z.
Definition lt_le_trans x y z : x<y -> y<=z -> x<z := @trans OLT OLE x y z.
Definition eq_lt x y z : x==y -> y<z -> x<z := @trans OEQ OLT x y z.
Definition lt_eq x y z : x<y -> y==z -> x<z := @trans OLT OEQ x y z.
Definition eq_le x y z : x==y -> y<=z -> x<=z := @trans OEQ OLE x y z.
Definition le_eq x y z : x<=y -> y==z -> x<=z := @trans OLE OEQ x y z.

Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.eq_neq".   eauto using eq_trans, eq_sym. Qed.

Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.neq_eq".   eauto using eq_trans, eq_sym. Qed.

Lemma not_neq_eq : forall x y, ~~x==y -> x==y.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.not_neq_eq".
intros x y H. destruct (P.lt_total x y) as [H'|[H'|H']]; auto;
destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto.
Qed.

Lemma not_ge_lt : forall x y, ~y<=x -> x<y.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.not_ge_lt".
intros x y H. destruct (P.lt_total x y); auto.
destruct H. rewrite P.le_lteq. intuition.
Qed.

Lemma not_gt_le : forall x y, ~y<x -> x<=y.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.not_gt_le".
intros x y H. rewrite P.le_lteq. generalize (P.lt_total x y); intuition.
Qed.

Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x<y.
Proof. hammer_hook "OrdersTac" "OrdersTac.OrderFacts.le_neq_lt".   auto using not_ge_lt, le_antisym. Qed.

End OrderFacts.

Module MakeOrderTac (Import O:EqLtLe)(P:IsTotalOrder O).
Include OrderFacts O P.
Include EqLtLeNotation O.

Ltac order_rewr x eqn :=

let rewr H t := generalize t; clear H; intro H
in
match goal with
| H : x == _ |- _ => rewr H (eq_trans (eq_sym eqn) H); order_rewr x eqn
| H : _ == x |- _ => rewr H (eq_trans H eqn); order_rewr x eqn
| H : ~x == _ |- _ => rewr H (eq_neq (eq_sym eqn) H); order_rewr x eqn
| H : ~_ == x |- _ => rewr H (neq_eq H eqn); order_rewr x eqn
| H : x < _ |- _ => rewr H (eq_lt (eq_sym eqn) H); order_rewr x eqn
| H : _ < x |- _ => rewr H (lt_eq H eqn); order_rewr x eqn
| H : x <= _ |- _ => rewr H (eq_le (eq_sym eqn) H); order_rewr x eqn
| H : _ <= x |- _ => rewr H (le_eq H eqn); order_rewr x eqn
| _ => clear eqn
end.

Ltac order_eq x y eqn :=
match x with
| y => clear eqn
| _ => change (interp_ord OEQ x y) in eqn; order_rewr x eqn
end.

Ltac order_prepare :=
match goal with
| H : ?A -> False |- _ => change (~A) in H; order_prepare
| H : ~(?R ?x ?y) |- _ =>
match R with
| eq => fail 1
| _ => (change (~x==y) in H ||
apply not_gt_le in H ||
apply not_ge_lt in H ||
clear H || fail 1); order_prepare
end
| H : ?R ?x ?y |- _ =>
match R with
| eq => fail 1
| lt => fail 1
| le => fail 1
| _ => (change (x==y) in H ||
change (x<y) in H ||
change (x<=y) in H ||
clear H || fail 1); order_prepare
end
| |- ~ _ => intro; order_prepare
| |- _ ?x ?x =>
exact (eq_refl x) || exact (le_refl x) || exfalso
| _ =>
(apply not_neq_eq; intro) ||
(apply not_ge_lt; intro) ||
(apply not_gt_le; intro) || exfalso
end.

Ltac order_loop :=
match goal with

| H : ?x < ?x |- _ => exact (lt_irrefl H)
| H : ~ ?x == ?x |- _ => exact (H (eq_refl x))

| H : ?x <= ?x |- _ => clear H; order_loop

| H : ?x == ?y |- _ => order_eq x y H; order_loop

| H1 : ?x <= ?y, H2 : ?y <= ?x |- _ =>
generalize (le_antisym H1 H2); clear H1 H2; intro; order_loop

| H1: ?x <= ?y, H2: ~ ?x == ?y |- _ =>
generalize (le_neq_lt H1 H2); clear H1 H2; intro; order_loop
| H1: ?x <= ?y, H2: ~ ?y == ?x |- _ =>
generalize (le_neq_lt H1 (neq_sym H2)); clear H1 H2; intro; order_loop

| H1 : ?x < ?y, H2 : ?y < ?z |- _ =>
match goal with
| H : x < z |- _ => fail 1
| _ => generalize (lt_trans H1 H2); intro; order_loop
end
| H1 : ?x <= ?y, H2 : ?y < ?z |- _ =>
match goal with
| H : x < z |- _ => fail 1
| _ => generalize (le_lt_trans H1 H2); intro; order_loop
end
| H1 : ?x < ?y, H2 : ?y <= ?z |- _ =>
match goal with
| H : x < z |- _ => fail 1
| _ => generalize (lt_le_trans H1 H2); intro; order_loop
end
| H1 : ?x <= ?y, H2 : ?y <= ?z |- _ =>
match goal with
| H : x <= z |- _ => fail 1
| _ => generalize (le_trans H1 H2); intro; order_loop
end
| _ => idtac
end.

Ltac order :=
intros; order_prepare; order_loop; fail "Order tactic unsuccessful".

End MakeOrderTac.

Module OTF_to_OrderTac (OTF:OrderedTypeFull).
Module TO := OTF_to_TotalOrder OTF.
Include !MakeOrderTac OTF TO.
End OTF_to_OrderTac.

Module OT_to_OrderTac (OT:OrderedType).
Module OTF := OT_to_Full OT.
Include !OTF_to_OrderTac OTF.
End OT_to_OrderTac.


Variables phi psi: Prop.

Section mt.
  Hypothesis H1: phi -> psi.
  Hypothesis H2: ~psi.
  Lemma mt: ~phi.
  Proof.
    intro.
    apply H2.
    apply H1.
    assumption.
  Qed.


(** Pierre Castéran, Univ. Bordeaux and LaBRI *)

From hydras Require Export DecPreOrder.
From Coq Require Import Arith ZArith List  Sets.Finite_sets  Sets.Ensembles.

#[ global ] Instance Nat_le_dec : RelDecision le := le_dec.

#[ global ] Instance Nat_le_TO : TotalPreOrder le.
Proof.
 split.
 - apply Nat.le_preorder.
 - intros a b; apply Nat.le_ge_cases.
Qed.

#[ global ] Instance Z_le_dec : RelDecision Z.le := Z_le_dec.

#[ global ] Instance Z_le_TO : TotalPreOrder Z.le.
split.
- apply Z.le_preorder.
- intros a b; destruct (Z_le_gt_dec a b).
    *  left;auto.
    *  right; auto with zarith.
Qed.

Import DecPreOrder.

(** Pre-order associated with an inverse function *)

#[ global ] Instance Inverse_fun {A B:Type}{f : A -> B}
         {leB: relation B}{PB: PreOrder leB}:
                     PreOrder (fun x y => leB (f x) (f y)).
Proof.
  split.
  -  intros x; reflexivity.
  - intros x y z Hxy Hyz; now transitivity (f y).
Defined.

#[ global ] Instance Total_Inverse_fun {A B:Type}{f : A -> B}
         {leB: relation B}{TB: TotalPreOrder leB} :
                     TotalPreOrder (fun x y => leB (f x) (f y)).
Proof.
split.
- apply Inverse_fun.
- intros a b.
  destruct TB.
  destruct (total_pre_order_total (f a) (f b)).
  + now left.
  + now right.
Defined.

#[ global ] Instance RelDecision_Inverse_fun {A B:Type}{f : A -> B}
 {leB: relation B} {RDB : RelDecision leB} :
  RelDecision (fun x y => leB (f x) (f y)) :=
  fun x y => decide_rel leB (f x) (f y).

(** Pre-order associated with inclusion *)

#[ global ] Instance PrO_Included {U:Type}: PreOrder (Included U).
Proof.
split;unfold Included;auto.
Defined.

Arguments Included {U} _ _.

Definition Included_s {U}  (A B : Ensemble U) :=
  Included  A B /\ ~ Included  B A.

Infix "<:" := Included (at level 30).
Infix "'<s'" := Included_s (at level 30).

(** Example
  Lists (pre-ordered by their length) *)

#[ global ] Instance  List_length {A:Type}:
   TotalPreOrder (fun l l' : list A => List.length l <= List.length l')%nat.
apply Total_Inverse_fun.
Defined.

(** Non dependent lexicographic product *)

Section lexprod.
 Variables (A B : Type)
           (leA : relation A)
           (leB : relation B).
 Context (TA : TotalPreOrder leA)
         (TB : TotalPreOrder leB)
         (DA : RelDecision leA)
         (DB : RelDecision leB).

 Definition PA := @total_pre_order_pre A leA TA.
 Definition PB := @total_pre_order_pre B leB TB.

Notation "x '<=A' y" := (leA x y) (at level 70, no associativity).
Notation "x '<A' y" := (@lt A leA PA x y) (at level 70, no associativity).
Notation "x '<=B' y" := (leB x y) (at level 70, no associativity).
Notation "x '<B' y" := (@lt B leB PB x y ) (at level 70, no associativity).
Notation "x =A= y" := (@preorder_equiv A leA PA x y) (at level 70, no associativity).
Notation "x =B= y" := (@preorder_equiv B leB PB x y) (at level 70, no associativity).

Inductive lex_prod (p p':A*B): Prop :=
| lex1 : (fst p) <A (fst p') -> lex_prod p p'
| lex2 :  (fst p) =A= (fst p') ->  (snd p) <=B (snd p') -> lex_prod p p'.

Notation "x '<=lex' y" := (lex_prod x y) (at level 70, no associativity).
Notation "x '<lex' y" := (@lt (A*B)  lex_prod _ x y) (at level 70, no associativity).

 #[global] Instance PO_lex_prod : PreOrder lex_prod.
 Proof.
 split.
 -   intro x; right;  reflexivity.
 -    intros x y z Hxy Hyz; destruct x,y,z.
      destruct Hxy.
      +  left; simpl in * |- *.
         destruct Hyz; simpl in *.
         now transitivity a0.
         apply DecPreOrder.lt_le_trans with a0;auto.
         now destruct H0.
      + destruct Hyz;  simpl in * |- *.
        left;auto.
        simpl; apply DecPreOrder.le_lt_trans with a0; auto.
        destruct H;auto.
       right.  simpl.   now transitivity a0.
       simpl;   now transitivity b0.
Defined.

Lemma lex_of_equiv (a a':A)(b b':B) :
     a =A= a' ->  b =B= b' -> preorder_equiv (a,b) (a',b').
Proof.
 intros H1 H2; destruct H1, H2;split;
  right;auto;   split;auto.
Qed.

Lemma lex_inv_left (a a':A)(b b':B) :
  ((a,b) <=lex (a',b')) -> a <=A a'.
Proof.
  destruct 1 as [H | H];
  destruct H; auto.
Qed.

Lemma lex_inv_right (a a':A)(b b':B) :
  ((a,b) <=lex (a',b')) ->  a =A=  a' -> b <=B b'.
Proof.
 intros [H|H].
  - destruct 1.
     absurd (a'  <A a').
     + apply lt_irreflexive.
     + apply DecPreOrder.le_lt_trans with a;auto.
 - auto.
Qed.

Lemma lex_strict_intro_right  (a a':A)(b b':B) :
  a =A= a' -> b <B b' -> (a,b) <lex (a',b').
Proof.
  intros H H1.
  split.
  right;auto.
  now destruct H1.
  intro H2.
  absurd (b <B b).
  apply lt_irreflexive;auto.
  apply DecPreOrder.lt_le_trans with b';auto.
  apply (lex_inv_right _ _ _ _ H2).
  now symmetry.
Qed.

Lemma lex_strict_intro_left  (a a':A)(b b':B) :
  a <A a'  -> (a,b) <lex (a',b').
Proof.
  split. now  constructor.
  intro H0.
  apply (@lt_irreflexive _ _ PA a).
  apply DecPreOrder.lt_le_trans with a'; auto.
  apply (lex_inv_left _ _ _ _ H0).
Qed.

#[global] Instance To_lex_prod : TotalPreOrder lex_prod.
Proof.
  split.
  - apply PO_lex_prod.
  - destruct TA as [Apre Atot].
    destruct TB as [Bpre Btot].
    intros x y; destruct x, y.
    destruct (Atot a a0) as [HAle|HAle].
    * destruct (le_lt_equiv_dec a a0 HAle) as [Ha|Ha].
      + left;left;auto.
      + destruct (Btot b b0).
        { left;right;auto. }
        { right; right; simpl. now symmetry. assumption. }
    * destruct (le_lt_equiv_dec a0 a HAle).
      + right;left. assumption.
      + destruct (Btot b0 b).
        { right; right; simpl; assumption. }
        { left;  right;[ now symmetry | assumption]. }
Qed.

#[global] Instance lex_prod_dec : RelDecision lex_prod.
Proof.
intros x y; destruct x, y.
destruct (decide (leA a a0)) as [HAle|Hale].
- destruct (le_lt_equiv_dec a a0 HAle) as [Ha|Ha].
  * left;left;auto.
  * destruct (decide (leB b b0)) as [HBle|HBle].
    + left;right;auto.
    + right; intro Hle.
      contradict HBle.
      destruct Hle as [Hle|Hle].
      { simpl in Hle.
        destruct Ha.
        destruct Hle.
        contradiction. }
      { simpl in Hle.
        simpl in H.
        assumption. }
- right. intro Hle.
  destruct Hle as [Hle|Hle].
  * simpl in Hle.
    destruct Hle.
    contradiction.
  * simpl in Hle.
    contradict Hale.
    destruct Hle.
    assumption.
Defined.

End lexprod.