(** **********************************************************

Benedikt Ahrens, Anders Mörtberg (adapted from yoneda.v)

2016

************************************************************)

(** **********************************************************

Contents : Definition of the covariant Yoneda functor
           [covyoneda(C) : [C^op, [C, HSET]]]

************************************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Export UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Export UniMath.CategoryTheory.FunctorCategory.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.whiskering.

Ltac unf := unfold identity,
                   compose,
                   precategory_morphisms;
                   simpl.

(** The following lemma is already in precategories.v . It should be transparent? *)

(* Lemma iso_comp_left_isweq {C:precategory} {a b:ob C} (h:iso a b) (c:C) : *)
(*   isweq (λ f : hom _ c a, f · h). *)
(* Proof. intros. apply (@iso_comp_right_isweq C^op b a (opp_iso h)). Qed. *)

(** * Covariant Yoneda functor *)

(** ** On objects *)

Definition covyoneda_objects_ob (C : category) (c : C^op)
          (d : C) := C⟦c,d⟧.

(* Definition covyoneda_objects_mor (C : precategory) (c : C^op) *)
(*     (d d' : C) (f : C⟦d,d'⟧) : *)
(*    covyoneda_objects_ob C c d -> covyoneda_objects_ob C c d' := *)
(*     λ g, g · f. *)

Definition covyoneda_ob_functor_data (C : category) (c : C^op) :
    functor_data C HSET.
Proof.
exists (λ c', make_hSet (covyoneda_objects_ob C c c') (homset_property C c c')) .
intros a b f g. unfold covyoneda_objects_ob in *. simpl in *.
exact (g · f).
Defined.

Lemma is_functor_covyoneda_functor_data (C : category) (c : C^op) :
  is_functor (covyoneda_ob_functor_data C c).
Proof.
split.
- intros c'; apply funextfun; intro x; apply id_right.
- intros a b d f g; apply funextfun; intro h; apply assoc.
Qed.

Definition covyoneda_objects (C : category) (c : C^op) :
             functor C HSET :=
    tpair _ _ (is_functor_covyoneda_functor_data C c).

(** ** On morphisms *)

Definition covyoneda_morphisms_data (C : category) (c c' : C^op)
    (f : C^op⟦c,c'⟧) : ∏ a : C,
         HSET⟦covyoneda_objects C  c a,covyoneda_objects C  c' a⟧.
Proof.
simpl in f; intros a g.
apply (f · g).
Defined.

Lemma is_nat_trans_covyoneda_morphisms_data (C : category)
     (c c' : C^op) (f : C^op⟦c,c'⟧) :
  is_nat_trans (covyoneda_objects C c) (covyoneda_objects C c')
               (covyoneda_morphisms_data C c c' f).
Proof.
intros d d' g; apply funextsec; intro h; apply assoc.
Qed.

Definition covyoneda_morphisms (C : category) (c c' : C^op)
   (f : C^op⟦c,c'⟧) : nat_trans (covyoneda_objects C c) (covyoneda_objects C c') :=
   tpair _ _ (is_nat_trans_covyoneda_morphisms_data C c c' f).

Definition covyoneda_functor_data (C : category) :
   functor_data C^op [C,HSET,has_homsets_HSET] :=
   tpair _ (covyoneda_objects C) (covyoneda_morphisms C).

(** ** Functorial properties of the yoneda assignments *)

Lemma is_functor_covyoneda (C : category) :
  is_functor (covyoneda_functor_data C).
Proof.
split.
- intro a.
  apply (@nat_trans_eq C _ has_homsets_HSET).
  intro c; apply funextsec; intro f; simpl in *.
  apply id_left.
- intros a b c f g.
  apply (@nat_trans_eq C _ has_homsets_HSET).
  simpl; intro d; apply funextsec; intro h; apply pathsinv0, assoc.
Qed.

Definition covyoneda (C : category) :
  functor C^op [C, HSET, has_homsets_HSET] :=
   tpair _ _ (is_functor_covyoneda C).

(** TODO: adapt the rest? *)

(* (* Notation "'ob' F" := (precategory_ob_mor_fun_objects F)(at level 4). *) *)

(* (** ** Yoneda lemma: natural transformations from [yoneda C c] to [F] *)
(*          are isomorphic to [F c] *) *)

(* Definition yoneda_map_1 (C : precategory) (hs: has_homsets C) (c : C) *)
(*    (F : functor C^op HSET) : *)
(*        hom _ (yoneda C hs c) F -> pr1 (F c) := *)
(*    λ h,  pr1 h c (identity c). *)

(* Lemma yoneda_map_2_ax (C : precategory) (hs: has_homsets C) (c : C) *)
(*        (F : functor C^op HSET) (x : pr1 (F c)) : *)
(*   is_nat_trans (pr1 (yoneda C hs c)) F *)
(*          (fun (d : C) (f : hom (C ^op) c d) => #F f x). *)
(* Proof. *)
(*   intros a b f; simpl in *. *)
(*   apply funextsec. *)
(*   unfold yoneda_objects_ob; intro g. *)
(*   set (H:= functor_comp F  _ _  b g). *)
(*   unfold functor_comp in H; *)
(*   unfold opp_precat_data in H; *)
(*   simpl in *. *)
(*   apply (toforallpaths _ _ _ (H f) x). *)
(* Qed. *)

(* Definition yoneda_map_2 (C : precategory) (hs: has_homsets C) (c : C) *)
(*    (F : functor C^op HSET) : *)
(*        pr1 (F c) -> hom _ (yoneda C hs c) F. *)
(* Proof. *)
(*   intro x. *)
(*   exists (λ d : ob C, λ f, #F f x). *)
(*   apply yoneda_map_2_ax. *)
(* Defined. *)

(* Lemma yoneda_map_1_2 (C : precategory) (hs: has_homsets C) (c : C) *)
(*   (F : functor C^op HSET) *)
(*   (alpha : hom _ (yoneda C hs c) F) : *)
(*       yoneda_map_2 _ _ _ _ (yoneda_map_1 _ _ _ _ alpha) = alpha. *)
(* Proof. *)
(*   simpl in *. *)
(*   set (T:=nat_trans_eq (C:=C^op) (has_homsets_HSET)). *)
(*   apply T. *)
(*   intro a'; simpl. *)
(*   apply funextsec; intro f. *)
(*   unfold yoneda_map_1. *)
(*   pathvia ((alpha c · #F f) (identity c)). *)
(*     apply idpath. *)
(*   rewrite <- nat_trans_ax. *)
(*   unf; apply maponpaths. *)
(*   apply (id_right C a' c f ). *)
(* Qed. *)

(* Lemma yoneda_map_2_1 (C : precategory) (hs: has_homsets C) (c : C) *)
(*    (F : functor C^op HSET) (x : pr1 (F c)) : *)
(*    yoneda_map_1 _ _ _ _ (yoneda_map_2 _ hs  _ _ x) = x. *)
(* Proof. *)
(*   simpl. *)
(*   rewrite (functor_id F). *)
(*   apply idpath. *)
(* Qed. *)

(* Lemma isaset_nat_trans_yoneda (C: precategory) (hs: has_homsets C) (c : C) *)
(*   (F : functor C^op HSET) : *)
(*  isaset (nat_trans (yoneda_ob_functor_data C hs c) F). *)
(* Proof. *)
(*   apply isaset_nat_trans. *)
(*   apply (has_homsets_HSET). *)
(* Qed. *)

(* Lemma yoneda_iso_sets (C : precategory) (hs: has_homsets C) (c : C) *)
(*    (F : functor C^op HSET) : *)
(*    is_iso (C:=HSET) *)
(*      (a := make_hSet (hom _ ((yoneda C) hs c) F) (isaset_nat_trans_yoneda C hs c F)) *)
(*      (b := F c) *)
(*      (yoneda_map_1 C hs c F). *)
(* Proof. *)
(*   set (T:=yoneda_map_2 C hs c F). simpl in T. *)
(*   set (T':= T : hom HSET (F c) (make_hSet (hom _ ((yoneda C) hs c) F) *)
(*                                          (isaset_nat_trans_yoneda C hs c F))). *)
(*   apply (is_iso_qinv (C:=HSET) _ T' ). *)
(*   repeat split; simpl. *)
(*   - apply funextsec; intro alpha. *)
(*     unf; simpl. *)
(*     apply (yoneda_map_1_2 C hs c F). *)
(*   - apply funextsec; intro x. *)
(*     unf; rewrite (functor_id F). *)
(*     apply idpath. *)
(* Defined. *)

(* Definition yoneda_iso_target (C : precategory) (hs : has_homsets C) *)
(*            (F : [C^op, HSET, has_homsets_HSET]) *)
(*   : functor C^op HSET. *)
(* Proof. *)
(*   simple refine (@functor_composite _ [C^op, HSET, has_homsets_HSET]^op _ _ _  ). *)
(*   - apply functor_opp. *)
(*     apply yoneda. apply hs. *)
(*   - apply (yoneda _ (functor_category_has_homsets _ _ _ ) F). *)
(* Defined. *)

(* Lemma is_natural_yoneda_iso (C : precategory) (hs : has_homsets C) (F : functor C^op HSET): *)
(*   is_nat_trans (yoneda_iso_target C hs F) F *)
(*   (λ c, yoneda_map_1 C hs c F). *)
(* Proof. *)
(*   unfold is_nat_trans. *)
(*   intros c c' f. cbn in *. *)
(*   apply funextsec. *)
(*   unfold yoneda_ob_functor_data. cbn. *)
(*   unfold yoneda_morphisms_data. *)
(*   unfold yoneda_map_1. *)
(*   intro X. *)
(*   assert (XH := nat_trans_ax X). *)
(*   cbn in XH. unfold yoneda_objects_ob in XH. *)
(*   assert (XH' := XH c' c' (identity _ )). *)
(*   assert (XH2 := toforallpaths _ _ _ XH'). *)
(*   rewrite XH2. *)
(*   rewrite (functor_id F). *)
(*   cbn. *)
(*   clear XH2 XH'. *)
(*   assert (XH' := XH _ _ f). *)
(*   assert (XH2 := toforallpaths _ _ _ XH'). *)
(*   eapply pathscomp0. Focus 2. apply XH2. *)
(*   rewrite id_right. *)
(*   apply idpath. *)
(* Qed. *)

(* Definition natural_trans_yoneda_iso (C : precategory) (hs : has_homsets C) *)
(*   (F : functor C^op HSET) *)
(*   : nat_trans (yoneda_iso_target C hs F) F *)
(*   := tpair _ _ (is_natural_yoneda_iso C hs F). *)

(* Lemma is_natural_yoneda_iso_inv (C : precategory) (hs : has_homsets C) (F : functor C^op HSET): *)
(*   is_nat_trans F (yoneda_iso_target C hs F) *)
(*   (λ c, yoneda_map_2 C hs c F). *)
(* Proof. *)
(*   unfold is_nat_trans. *)
(*   intros c c' f. cbn in *. *)
(*   apply funextsec. *)
(*   unfold yoneda_ob_functor_data. cbn. *)
(*   unfold yoneda_map_2. *)
(*   intro A. *)
(*   apply nat_trans_eq. { apply (has_homsets_HSET). } *)
(*   cbn. intro d. *)
(*   apply funextfun. *)
(*   unfold yoneda_objects_ob. intro g. *)
(*   unfold yoneda_morphisms_data. *)
(*   apply (! toforallpaths _ _ _ (functor_comp F _ _ _ _ _ ) A). *)
(* Qed. *)

(* Definition natural_trans_yoneda_iso_inv (C : precategory) (hs : has_homsets C) *)
(*   (F : functor C^op HSET) *)
(*   : nat_trans (yoneda_iso_target C hs F) F *)
(*   := tpair _ _ (is_natural_yoneda_iso C hs F). *)

(* Lemma isweq_yoneda_map_1 (C : precategory) (hs: has_homsets C) (c : C) *)
(*    (F : functor C^op HSET) : *)
(*   isweq *)
(*      (*a := make_hSet (hom _ ((yoneda C) hs c) F) (isaset_nat_trans_yoneda C hs c F)*) *)
(*      (*b := F c*) *)
(*      (yoneda_map_1 C hs c F). *)
(* Proof. *)
(*   set (T:=yoneda_map_2 C hs c F). simpl in T. *)
(*   simple refine (isweq_iso _ _ _ _ ). *)
(*   - apply T. *)
(*   - apply yoneda_map_1_2. *)
(*   - apply yoneda_map_2_1. *)
(* Defined. *)

(* Definition yoneda_weq (C : precategory) (hs: has_homsets C) (c : C) *)
(*    (F : functor C^op HSET) *)
(*   :  hom [C^op, HSET, has_homsets_HSET] ((yoneda C hs) c) F ≃ pr1hSet (F c) *)
(*   := make_weq _ (isweq_yoneda_map_1 C hs c F). *)

(* (** ** The Yoneda embedding is fully faithful *) *)

(* Lemma yoneda_fully_faithful (C : precategory) (hs: has_homsets C) : fully_faithful (yoneda C hs). *)
(* Proof. *)
(*   intros a b; simpl. *)
(*   apply (isweq_iso _ *)
(*       (yoneda_map_1 C hs a (pr1 (yoneda C hs) b))). *)
(*   - intro; simpl in *. *)
(*     apply id_left. *)
(*   - intro gamma. *)
(*     simpl in *. *)
(*     apply nat_trans_eq. apply (has_homsets_HSET). *)
(*     intro x. simpl in *. *)
(*     apply funextsec; intro f. *)
(*     unfold yoneda_map_1. *)
(*     unfold yoneda_morphisms_data. *)
(*     assert (T:= toforallpaths _ _ _ (nat_trans_ax gamma a x f) (identity _ )). *)
(*     cbn in T. *)
(*     eapply pathscomp0; [apply (!T) |]. *)
(*     apply maponpaths. *)
(*     apply id_right. *)
(* Defined. *)

(* Section yoneda_functor_precomp. *)

(* Variables C D : precategory. *)
(* Variables (hsC : has_homsets C) (hsD : has_homsets D). *)
(* Variable F : functor C D. *)

(* Section fix_object. *)

(* Variable c : C. *)

(* Definition yoneda_functor_precomp' : nat_trans (yoneda_objects C hsC c) *)
(*       (functor_composite (functor_opp F) (yoneda_objects D hsD (F c))). *)
(* Proof. *)
(*   simple refine (tpair _ _ _ ). *)
(*   - intros d f ; simpl. *)
(*     apply (#F f). *)
(*   - abstract (intros d d' f ; *)
(*               apply funextsec; intro t; simpl; *)
(*               apply functor_comp). *)
(* Defined. *)

(* Definition yoneda_functor_precomp :  _ ⟦ yoneda C hsC c, functor_composite (functor_opp F) (yoneda_objects D hsD (F c))⟧. *)
(* Proof. *)
(*   exact yoneda_functor_precomp'. *)
(* Defined. *)

(* Variable Fff : fully_faithful F. *)

(* Lemma is_iso_yoneda_functor_precomp : is_iso yoneda_functor_precomp. *)
(* Proof. *)
(*   apply functor_iso_if_pointwise_iso. *)
(*   intro. simpl. *)
(*   set (T:= make_weq _ (Fff a c)). *)
(*   set (TA := make_hSet (hom C a c) (hsC _ _ )). *)
(*   set (TB := make_hSet (hom D (F a) (F c)) (hsD _ _ )). *)
(*   apply (hset_equiv_is_iso TA TB T). *)
(* Defined. *)

(* End fix_object. *)

(* Let A := functor_composite F (yoneda D hsD). *)
(* Let B := pre_composition_functor _ _ HSET (has_homsets_opp hsD) (has_homsets_HSET)  (functor_opp F). *)

(* Definition yoneda_functor_precomp_nat_trans : *)
(*     @nat_trans *)
(*       C *)
(*       [C^op, HSET, (has_homsets_HSET)] *)
(*       (yoneda C hsC) *)
(*       (functor_composite A B). *)
(* Proof. *)
(*   simple refine (tpair _ _ _ ). *)
(*   - intro c; simpl. *)
(*     apply yoneda_functor_precomp. *)
(*   - abstract ( *)
(*         intros c c' f; *)
(*         apply nat_trans_eq; try apply (has_homsets_HSET); *)
(*         intro d; apply funextsec; intro t; *)
(*         cbn; *)
(*         apply functor_comp). *)
(* Defined. *)

(* End yoneda_functor_precomp. *)


Require Import List.
Import ListNotations.

Class Bifunctor (F : Type -> Type -> Type) := {
    bimap {A B C D} : (A -> C) -> (B -> D) -> F A B -> F C D;
    first {A B C} : (A -> C) -> F A B -> F C B;
    second {A B D} : (B -> D) -> F A B -> F A D;

    bimap_first_second {A B C D} (g : A -> C) (h : B -> D) :
    forall x, bimap g h x = first g (second h x);
    first_bimap {A B C} (g : A -> C) :
    forall x, first g x = bimap g (fun (x : B) => x) x;
    second_bimap {A B D} (h : B -> D) :
    forall x, second h x = bimap (fun (x : A) => x) h x
  }.

#[export]
Instance Prod_BF : Bifunctor prod.
Proof.
  refine ( {|
             bimap _ _ _ _ := fun g h '(x,y) => (g x, h y);
             first _ _ _ := fun g '(x,y) => (g x, y);
             second _ _ _ := fun h '(x,y) => (x, h y);
             bimap_first_second :=  _;
             first_bimap := _;
             second_bimap := _
           |} ).
  - intros A B C D g h [a b]. reflexivity.
  - intros A B C g [a b]. reflexivity.
  - intros A B D h [a b]. reflexivity.
Defined.

Definition list_sum (A B : Type) : Type :=
  list (A + B).

Definition list_sum_bimap {A B C D} :
  (A -> C) -> (B -> D) -> list_sum A B -> list_sum C D :=
  fun g h xs =>
    List.map (fun (s : A + B) =>
                     match s with
                     | inl a => inl (g a)
                     | inr b => inr (h b)
                     end) xs.

Definition list_sum_first {A B C} : (A -> C) -> (list_sum A B) -> list_sum C B :=
  fun g xs =>
    List.map (fun (s : A + B) =>
                match s with
                | inl a => inl (g a)
                | inr b => inr b
                end) xs.

Definition list_sum_second {A B D} : (B -> D) -> list_sum A B -> list_sum A D :=
  fun h xs =>
    List.map (fun (s : A + B) =>
                match s with
                | inl a => inl a
                | inr b => inr (h b)
                end) xs.

#[export]
Instance ls_BF : Bifunctor list_sum.
Proof.
  refine ( {|
             bimap _ _ _ _ := list_sum_bimap;
             first _ _ _ := list_sum_first;
             second _ _ _ := list_sum_second;
             bimap_first_second :=  _;
             first_bimap := _;
             second_bimap := _
           |} ).
  - intros.
    induction x.
    + trivial.
    + simpl.
      destruct a;
      now rewrite IHx.
  - intros.
    admit.
  - admit.
Admitted.


Require Import Cat.Category.
Require Import Mon.Monoid.
Require Import Mon.MonCat.
Require Import Grp.Group.
Require Import Functor.
Require Import Cat.FullSubcat.
Require Import Cat.SetCategory.
Require Import Cat.FinCategory.
Require Import Coq.Sets.Finite_sets.
Require Import Pro.Preorder.
Require Import Pro.LinearOrder.

Definition MonCoqFun : Functor MonCat CoqCat.
   Hint Unfold mon_hom_fn id_of comp_of id_mon comp_mon CoqCat MonCat.
   refine(cons_functor MonCat CoqCat undertype_mon (@mon_hom_fn) _ _);
   intros;
   [
       | destruct f as [f [a b]]; destruct g as [g [c d]]
   ];
   reflexivity.
Defined.

Definition GrpMonFun : Functor GrpCat MonCat.
    refine (cons_functor GrpCat MonCat monoid_of (@mon_hom_of) _ _);
        reflexivity.
Defined.

Definition FullSubcatFun (cat : Cat) (filter : ob cat -> Prop) : Functor (full_subcat cat filter) cat.
    refine (cons_functor (full_subcat cat filter) cat extract_ob (fun c d f => f) _ _);
        reflexivity.
Qed.

Definition FinSetFun (U : Type) : Functor (FinCat U) (SetCat U) :=
    FullSubcatFun (SetCat U) (Finite U).

Definition LinProFun (U : Type) : Functor LinCat PrOCat :=
    FullSubcatFun PrOCat Is_Linear.


Require Export Monads.
Require Import Program.Basics.
Require Import Program.Syntax.

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

Section functionals.
Variables A B C : Type.

Definition FuncType : Type
  := forall (T : monadType), (A -> T B) -> T C.

Definition FuncStateType : Type
  := forall S, (A -> State S B) -> State S C.
End functionals.

Section strategy.
Variables A B C : Type.

Inductive Tree :=
  Ans : C -> Tree
| Que : A -> (B -> Tree) -> Tree.

Fixpoint tree2funT (T : monadType) (t : Tree) :=
  match t with
    | Ans c => fun k => tval T c
    | Que a f =>
        fun k => k a >>= (fun b => @tree2funT T (f b) k)
  end.

Definition tree2fun (t : Tree) : FuncType A B C.
intro T. refine (tree2funT t).
Defined.

Lemma tree2fun_simpl (t : Tree) (T : monadType) :
  @tree2fun t T = tree2funT t.
Proof. now unfold tree2fun. Qed.

Definition evaltree (t : Tree) (f : A -> B)
  := @tree2fun t Id f.

Lemma evaltree_Que x k f :
  evaltree (Que x k) f = evaltree (k (f x)) f.
Proof. easy. Qed.

(* TODO: what is that for here? *)
Definition evaltree_unit (t : Tree) (f : A -> B)
  := fst ((@tree2fun t (State unit) (compose (@tval _ _) f)) ()).

Lemma evaltree_unit_Que x k f :
  evaltree_unit (Que x k) f = evaltree_unit (k (f x)) f.
Proof. easy. Qed.

Lemma evaltree_same (t : Tree) (f : A -> B) :
  evaltree t f = evaltree_unit t f.
Proof. induction t; now firstorder. Qed.

(* Relational interpreter of trees for (State S) *)
Inductive wrap_rel_State {S}
  : Tree -> (A -> S -> B * S -> Prop) -> S -> C * S -> Prop :=
  | wrapAns :
      forall (f : A -> S -> B * S -> Prop) c s,
        wrap_rel_State (Ans c) f s (c,s)
  | wrapQue :
      forall (f : A -> S -> B * S -> Prop) a k s d0 s0 ds1,
        f a s (d0, s0) ->
        wrap_rel_State (k d0) f s0 ds1 ->
        wrap_rel_State (Que a k) f s ds1.

Lemma wrap_rel_State_Ans_inv S c f s d1 s1 :
  @wrap_rel_State S (Ans c) f s (d1, s1) ->
  d1 = c /\ s1 = s.
Proof. intros H; now inversion H; subst. Qed.

Lemma wrap_rel_State_Que_inv S a k f s ds1 :
  @wrap_rel_State S (Que a k) f s ds1 ->
  exists d0 s0,
    f a s (d0, s0) /\ wrap_rel_State (k d0) f s0 ds1.
Proof. intros H; now inversion H; subst; eauto. Qed.

Lemma wrap_rel_State_fun S t
  (f : A -> S -> (B * S) -> Prop)
  (f' : A -> S -> (B * S) -> Prop)
  (Hfun : forall a s r r', f a s r -> f' a s r' -> r = r') :
  forall s ds1 ds1',
    @wrap_rel_State S t f s ds1 ->
    @wrap_rel_State S t f' s ds1' ->
    ds1 = ds1'.
Proof.
induction t as [c | a k IH].
- intros s [d1 s1] [d1' s1'] H H'.
  destruct (wrap_rel_State_Ans_inv H); subst.
  destruct (wrap_rel_State_Ans_inv H'); subst.
  easy.
- intros s [d1 s1] [d1' s1'] H H'.
  destruct (wrap_rel_State_Que_inv H) as [d0 [s0 [Hf H0]]].
  destruct (wrap_rel_State_Que_inv H') as [d0' [s0' [Hf' H0']]].
  assert (H1 := Hfun _ _ _ _ Hf Hf').
  inversion H1; subst; clear H1.
  now firstorder.
Qed.

(* Relational interpreter of trees for (ErrorT (State S)) *)
Inductive wrap_rel_ErrorT_State {S}
  : Tree -> (A -> S -> (Exc B) * S -> Prop) -> S -> (Exc C) * S -> Prop :=
  | wrapESAns :
      forall (f : A -> S -> (Exc B) * S -> Prop) c s,
        wrap_rel_ErrorT_State (Ans c) f s (value c,s)
  | wrapESQueValue :
      forall (f : A -> S -> (Exc B) * S -> Prop) a k s d0 s0 ds1,
        f a s (value d0, s0) ->
        wrap_rel_ErrorT_State (k d0) f s0 ds1 ->
        wrap_rel_ErrorT_State (Que a k) f s ds1
  | wrapESQueError :
      forall (f : A -> S -> (Exc B) * S -> Prop) a k s s0,
        f a s (error, s0) ->
        wrap_rel_ErrorT_State (Que a k) f s (error,s0).

Lemma wrap_rel_ErrorT_State_Ans_inv S c f s d1 s1 :
  @wrap_rel_ErrorT_State S (Ans c) f s (d1, s1) ->
  d1 = value c /\ s1 = s.
Proof. intros H; now inversion H; subst. Qed.

Lemma wrap_rel_ErrorT_State_Que_value_inv S a k f s d s1 :
  @wrap_rel_ErrorT_State S (Que a k) f s (value d,s1) ->
  exists d0 s0,
    f a s (value d0, s0) /\
    wrap_rel_ErrorT_State (k d0) f s0 (value d,s1).
Proof. intros H; now inversion H; subst; eauto. Qed.

Lemma wrap_rel_ErrorT_State_Que_error_inv S a k f s s1 :
  @wrap_rel_ErrorT_State S (Que a k) f s (error,s1) ->
  f a s (error,s1) \/
  exists d0 s0,
    f a s (value d0, s0) /\
    wrap_rel_ErrorT_State (k d0) f s0 (error,s1).
Proof. intros H; now inversion H; subst; eauto. Qed.

Lemma wrap_rel_ErrorT_State_fun S t
  (f : A -> S -> (Exc B) * S -> Prop)
  (f' : A -> S -> (Exc B) * S -> Prop)
  (Hfun : forall a s r r', f a s r -> f' a s r' -> r = r') :
  forall s ds1 ds1',
    @wrap_rel_ErrorT_State S t f s ds1 ->
    @wrap_rel_ErrorT_State S t f' s ds1' ->
    ds1 = ds1'.
Proof.
induction t as [c | a k IH].
- intros s [d1 s1] [d1' s1'] H H'.
  destruct (wrap_rel_ErrorT_State_Ans_inv H); subst.
  destruct (wrap_rel_ErrorT_State_Ans_inv H'); subst.
  easy.
- intros s [d1 s1] [d1' s1'] H H'.
  destruct d1 as [d1 |]; destruct d1' as [d1' |].
  + destruct (wrap_rel_ErrorT_State_Que_value_inv H)
             as [d0 [s0 [Hf H0]]].
    destruct (wrap_rel_ErrorT_State_Que_value_inv H')
             as [d0' [s0' [Hf' H0']]].
    assert (H1 := Hfun _ _ _ _ Hf Hf').
    inversion H1; subst; clear H1.
    now firstorder.
  + destruct (wrap_rel_ErrorT_State_Que_value_inv H)
             as [d0 [s0 [Hf H0]]].
    destruct (wrap_rel_ErrorT_State_Que_error_inv H')
             as [Hf' | [d0' [s0' [Hf' H0']]]].
    * now assert (H1 := Hfun _ _ _ _ Hf Hf').
    * assert (H1 := Hfun _ _ _ _ Hf Hf').
      inversion H1; subst; clear H1.
      now firstorder.
  + destruct (wrap_rel_ErrorT_State_Que_value_inv H')
             as [d0' [s0' [Hf' H0']]].
    destruct (wrap_rel_ErrorT_State_Que_error_inv H)
             as [Hf | [d0 [s0 [Hf H0]]]].
    * now assert (H1 := Hfun _ _ _ _ Hf Hf').
    * assert (H1 := Hfun _ _ _ _ Hf Hf').
      inversion H1; subst; clear H1.
      now firstorder.
  + destruct (wrap_rel_ErrorT_State_Que_error_inv H)
             as [Hf | [d0 [s0 [Hf H0]]]];
    destruct (wrap_rel_ErrorT_State_Que_error_inv H')
             as [Hf' | [d0' [s0' [Hf' H0']]]].
    * assert (H1 := Hfun _ _ _ _ Hf Hf').
      now inversion H1; subst; clear H1.
    * now assert (H1 := Hfun _ _ _ _ Hf Hf').
    * now assert (H1 := Hfun _ _ _ _ Hf Hf').
    * assert (H1 := Hfun _ _ _ _ Hf Hf').
      inversion H1; subst; clear H1.
      now firstorder.
Qed.

End strategy.

Implicit Arguments Ans [A B C].
Implicit Arguments Que [A B C].

Notation "[[ t ]]" := (@tree2fun _ _ _ (t : Tree _ _ _)) (at level 60).
Notation "[[ t ]]*" := (@evaltree _ _ _ (t : Tree _ _ _)) (at level 60).
Notation "[[ t ]]#" := (@wrap_rel_State _ _ _ _ (t : Tree _ _ _)) (at level 60).
Notation "[[ t ]]##" := (@wrap_rel_ErrorT_State _ _ _ _ (t : Tree _ _ _)) (at level 60).

(*Definition isPure A B C (F : FuncType A B C)
  := exists t, forall (T : monadType), F T = [[t]] T.*)

Definition is_pure A B C (F : FuncType A B C)
  := {t | F = [[t]] }.


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

Require Import NZAxioms NZBase Decidable OrdersTac.

Module Type NZOrderProp
 (Import NZ : NZOrdSig')(Import NZBase : NZBaseProp NZ).

Instance le_wd : Proper (eq==>eq==>iff) le.
Proof.
intros n n' Hn m m' Hm. now rewrite <- !lt_succ_r, Hn, Hm.
Qed.

Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H].

Theorem lt_le_incl : forall n m, n < m -> n <= m.
Proof.
intros. apply lt_eq_cases. now left.
Qed.

Theorem le_refl : forall n, n <= n.
Proof.
intro. apply lt_eq_cases. now right.
Qed.

Theorem lt_succ_diag_r : forall n, n < S n.
Proof.
intro n. rewrite lt_succ_r. apply le_refl.
Qed.

Theorem le_succ_diag_r : forall n, n <= S n.
Proof.
intro; apply lt_le_incl; apply lt_succ_diag_r.
Qed.

Theorem neq_succ_diag_l : forall n, S n ~= n.
Proof.
intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r.
Qed.

Theorem neq_succ_diag_r : forall n, n ~= S n.
Proof.
intro n; apply neq_sym, neq_succ_diag_l.
Qed.

Theorem nlt_succ_diag_l : forall n, ~ S n < n.
Proof.
intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl.
Qed.

Theorem nle_succ_diag_l : forall n, ~ S n <= n.
Proof.
intros n H; le_elim H.
false_hyp H nlt_succ_diag_l. false_hyp H neq_succ_diag_l.
Qed.

Theorem le_succ_l : forall n m, S n <= m <-> n < m.
Proof.
intro n; nzinduct m n.
split; intro H. false_hyp H nle_succ_diag_l. false_hyp H lt_irrefl.
intro m.
rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd.
rewrite or_cancel_r.
reflexivity.
intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l.
intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl.
Qed.

(** Trichotomy *)

Theorem le_gt_cases : forall n m, n <= m \/ n > m.
Proof.
intros n m; nzinduct n m.
left; apply le_refl.
intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition.
Qed.

Theorem lt_trichotomy : forall n m,  n < m \/ n == m \/ m < n.
Proof.
intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto.
Qed.

Notation lt_eq_gt_cases := lt_trichotomy (only parsing).

(** Asymmetry and transitivity. *)

Theorem lt_asymm : forall n m, n < m -> ~ m < n.
Proof.
intros n m; nzinduct n m.
intros H; false_hyp H lt_irrefl.
intro n; split; intros H H1 H2.
apply lt_succ_r in H2. le_elim H2.
apply H; auto. apply le_succ_l. now apply lt_le_incl.
rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l.
apply le_succ_l in H1. le_elim H1.
apply H; auto. rewrite lt_succ_r. now apply lt_le_incl.
rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l.
Qed.

Notation lt_ngt := lt_asymm (only parsing).

Theorem lt_trans : forall n m p, n < m -> m < p -> n < p.
Proof.
intros n m p; nzinduct p m.
intros _ H; false_hyp H lt_irrefl.
intro p. rewrite 2 lt_succ_r.
split; intros H H1 H2.
apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1].
assert (n <= p) as H3 by (auto using lt_le_incl).
le_elim H3. assumption. rewrite <- H3 in H2.
elim (lt_asymm n m); auto.
Qed.

Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p.
Proof.
intros n m p. rewrite 3 lt_eq_cases.
intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ';
 generalize (lt_trans n m p); auto with relations.
Qed.

(** Some type classes about order *)

Instance lt_strorder : StrictOrder lt.
Proof. split. exact lt_irrefl. exact lt_trans. Qed.

Instance le_preorder : PreOrder le.
Proof. split. exact le_refl. exact le_trans. Qed.

Instance le_partialorder : PartialOrder _ le.
Proof.
intros x y. compute. split.
intro EQ; now rewrite EQ.
rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y.
Qed.

(** We know enough now to benefit from the generic [order] tactic. *)

Definition lt_compat := lt_wd.
Definition lt_total := lt_trichotomy.
Definition le_lteq := lt_eq_cases.

Module OrderElts <: TotalOrder.
 Definition t := t.
 Definition eq := eq.
 Definition lt := lt.
 Definition le := le.
 Definition eq_equiv := eq_equiv.
 Definition lt_strorder := lt_strorder.
 Definition lt_compat := lt_compat.
 Definition lt_total := lt_total.
 Definition le_lteq := le_lteq.
End OrderElts.
Module OrderTac := !MakeOrderTac OrderElts.
Ltac order := OrderTac.order.

(** Some direct consequences of [order]. *)

Theorem lt_neq : forall n m, n < m -> n ~= m.
Proof. order. Qed.

Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m.
Proof. intuition order. Qed.

Theorem eq_le_incl : forall n m, n == m -> n <= m.
Proof. order. Qed.

Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y.
Proof. order. Qed.

Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z.
Proof. order. Qed.

Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y.
Proof. order. Qed.

Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z.
Proof. order. Qed.

Declare Left  Step lt_stepl.
Declare Right Step lt_stepr.
Declare Left  Step le_stepl.
Declare Right Step le_stepr.

Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p.
Proof. order. Qed.

Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p.
Proof. order. Qed.

Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m.
Proof. order. Qed.

(** More properties of [<] and [<=] with respect to [S] and [0]. *)

Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m.
Proof.
intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r.
Qed.

Theorem lt_succ_l : forall n m, S n < m -> n < m.
Proof.
intros n m H; apply le_succ_l; order.
Qed.

Theorem le_le_succ_r : forall n m, n <= m -> n <= S m.
Proof.
intros n m LE. apply lt_succ_r in LE. order.
Qed.

Theorem lt_lt_succ_r : forall n m, n < m -> n < S m.
Proof.
intros. rewrite lt_succ_r. order.
Qed.

Theorem succ_lt_mono : forall n m, n < m <-> S n < S m.
Proof.
intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r.
Qed.

Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m.
Proof.
intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd.
Qed.

Theorem lt_0_1 : 0 < 1.
Proof.
rewrite one_succ. apply lt_succ_diag_r.
Qed.

Theorem le_0_1 : 0 <= 1.
Proof.
apply lt_le_incl, lt_0_1.
Qed.

Theorem lt_1_2 : 1 < 2.
Proof.
rewrite two_succ. apply lt_succ_diag_r.
Qed.

Theorem lt_0_2 : 0 < 2.
Proof.
transitivity 1. apply lt_0_1. apply lt_1_2.
Qed.

Theorem le_0_2 : 0 <= 2.
Proof.
apply lt_le_incl, lt_0_2.
Qed.

(** The order tactic enriched with some knowledge of 0,1,2 *)

Ltac order' := generalize lt_0_1 lt_1_2; order.

Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m.
Proof.
intros n m H1 H2. rewrite <- le_succ_l, <- one_succ in H1. order.
Qed.

(** More Trichotomy, decidability and double negation elimination. *)

(** The following theorem is cleary redundant, but helps not to
remember whether one has to say le_gt_cases or lt_ge_cases *)

Theorem lt_ge_cases : forall n m, n < m \/ n >= m.
Proof.
intros n m; destruct (le_gt_cases m n); intuition order.
Qed.

Theorem le_ge_cases : forall n m, n <= m \/ n >= m.
Proof.
intros n m; destruct (le_gt_cases n m); intuition order.
Qed.

Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m.
Proof.
intros n m; destruct (lt_trichotomy n m); intuition order.
Qed.

(** Decidability of equality, even though true in each finite ring, does not
have a uniform proof. Otherwise, the proof for two fixed numbers would
reduce to a normal form that will say if the numbers are equal or not,
which cannot be true in all finite rings. Therefore, we prove decidability
in the presence of order. *)

Theorem eq_decidable : forall n m, decidable (n == m).
Proof.
intros n m; destruct (lt_trichotomy n m) as [ | [ | ]];
 (right; order) || (left; order).
Qed.

(** DNE stands for double-negation elimination *)

Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m.
Proof.
intros n m; split; intro H.
destruct (eq_decidable n m) as [H1 | H1].
assumption. false_hyp H1 H.
intro H1; now apply H1.
Qed.

Theorem le_ngt : forall n m, n <= m <-> ~ n > m.
Proof. intuition order. Qed.

(** Redundant but useful *)

Theorem nlt_ge : forall n m, ~ n < m <-> n >= m.
Proof. intuition order. Qed.

Theorem lt_decidable : forall n m, decidable (n < m).
Proof.
intros n m; destruct (le_gt_cases m n); [right|left]; order.
Qed.

Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m.
Proof.
intros n m; split; intro H.
destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H].
intro H1; false_hyp H H1.
Qed.

Theorem nle_gt : forall n m, ~ n <= m <-> n > m.
Proof. intuition order. Qed.

(** Redundant but useful *)

Theorem lt_nge : forall n m, n < m <-> ~ n >= m.
Proof. intuition order. Qed.

Theorem le_decidable : forall n m, decidable (n <= m).
Proof.
intros n m; destruct (le_gt_cases n m); [left|right]; order.
Qed.

Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m.
Proof.
intros n m; split; intro H.
destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H].
intro H1; false_hyp H H1.
Qed.

Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m.
Proof.
intros n m; rewrite lt_succ_r. intuition order.
Qed.

(** The difference between integers and natural numbers is that for
every integer there is a predecessor, which is not true for natural
numbers. However, for both classes, every number that is bigger than
some other number has a predecessor. The proof of this fact by regular
induction does not go through, so we need to use strong
(course-of-value) induction. *)

Lemma lt_exists_pred_strong :
  forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k.
Proof.
intro z; nzinduct n z.
order.
intro n; split; intros IH m H1 H2.
apply le_succ_r in H2. destruct H2 as [H2 | H2].
now apply IH. exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2].
apply IH. assumption. now apply le_le_succ_r.
Qed.

Theorem lt_exists_pred :
  forall z n, z < n -> exists k, n == S k /\ z <= k.
Proof.
intros z n H; apply lt_exists_pred_strong with (z := z) (n := n).
assumption. apply le_refl.
Qed.

Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n.
Proof.
 intros z n H.
 destruct (lt_exists_pred _ _ H) as (n' & EQ & LE).
 rewrite EQ. now rewrite pred_succ.
Qed.

(** Stronger variant of induction with assumptions n >= 0 (n < 0)
in the induction step *)

Section Induction.

Variable A : t -> Prop.
Hypothesis A_wd : Proper (eq==>iff) A.

Section Center.

Variable z : t. (* A z is the basis of induction *)

Section RightInduction.

Let A' (n : t) := forall m, z <= m -> m < n -> A m.
Let right_step :=   forall n, z <= n -> A n -> A (S n).
Let right_step' :=  forall n, z <= n -> A' n -> A n.
Let right_step'' := forall n, A' n <-> A' (S n).

Lemma rs_rs' :  A z -> right_step -> right_step'.
Proof.
intros Az RS n H1 H2.
le_elim H1. apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]].
rewrite H3. apply RS; trivial. apply H2; trivial.
rewrite H3; apply lt_succ_diag_r.
rewrite <- H1; apply Az.
Qed.

Lemma rs'_rs'' : right_step' -> right_step''.
Proof.
intros RS' n; split; intros H1 m H2 H3.
apply lt_succ_r in H3; le_elim H3;
[now apply H1 | rewrite H3 in *; now apply RS'].
apply H1; [assumption | now apply lt_lt_succ_r].
Qed.

Lemma rbase : A' z.
Proof.
intros m H1 H2. apply le_ngt in H1. false_hyp H2 H1.
Qed.

Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n.
Proof.
intros H1 n H2. apply H1 with (n := S n); [assumption | apply lt_succ_diag_r].
Qed.

Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n.
Proof.
intro RS'; apply A'A_right; unfold A'; nzinduct n z;
[apply rbase | apply rs'_rs''; apply RS'].
Qed.

Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n.
Proof.
intros Az RS; apply strong_right_induction; now apply rs_rs'.
Qed.

Theorem right_induction' :
  (forall n, n <= z -> A n) -> right_step -> forall n, A n.
Proof.
intros L R n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply L; now apply lt_le_incl.
apply L; now apply eq_le_incl.
apply right_induction. apply L; now apply eq_le_incl. assumption.
now apply lt_le_incl.
Qed.

Theorem strong_right_induction' :
  (forall n, n <= z -> A n) -> right_step' -> forall n, A n.
Proof.
intros L R n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply L; now apply lt_le_incl.
apply L; now apply eq_le_incl.
apply strong_right_induction. assumption. now apply lt_le_incl.
Qed.

End RightInduction.

Section LeftInduction.

Let A' (n : t) := forall m, m <= z -> n <= m -> A m.
Let left_step :=   forall n, n < z -> A (S n) -> A n.
Let left_step' :=  forall n, n <= z -> A' (S n) -> A n.
Let left_step'' := forall n, A' n <-> A' (S n).

Lemma ls_ls' :  A z -> left_step -> left_step'.
Proof.
intros Az LS n H1 H2. le_elim H1.
apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl].
rewrite H1; apply Az.
Qed.

Lemma ls'_ls'' : left_step' -> left_step''.
Proof.
intros LS' n; split; intros H1 m H2 H3.
apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1.
le_elim H3.
apply le_succ_l in H3. now apply H1.
rewrite <- H3 in *; now apply LS'.
Qed.

Lemma lbase : A' (S z).
Proof.
intros m H1 H2. apply le_succ_l in H2.
apply le_ngt in H1. false_hyp H2 H1.
Qed.

Lemma A'A_left : (forall n, A' n) -> forall n, n <= z -> A n.
Proof.
intros H1 n H2. apply (H1 n); [assumption | now apply eq_le_incl].
Qed.

Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n.
Proof.
intro LS'; apply A'A_left; unfold A'; nzinduct n (S z);
[apply lbase | apply ls'_ls''; apply LS'].
Qed.

Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n.
Proof.
intros Az LS; apply strong_left_induction; now apply ls_ls'.
Qed.

Theorem left_induction' :
  (forall n, z <= n -> A n) -> left_step -> forall n, A n.
Proof.
intros R L n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply left_induction. apply R. now apply eq_le_incl. assumption.
now apply lt_le_incl.
rewrite H; apply R; now apply eq_le_incl.
apply R; now apply lt_le_incl.
Qed.

Theorem strong_left_induction' :
  (forall n, z <= n -> A n) -> left_step' -> forall n, A n.
Proof.
intros R L n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply strong_left_induction; auto. now apply lt_le_incl.
rewrite H; apply R; now apply eq_le_incl.
apply R; now apply lt_le_incl.
Qed.

End LeftInduction.

Theorem order_induction :
  A z ->
  (forall n, z <= n -> A n -> A (S n)) ->
  (forall n, n < z  -> A (S n) -> A n) ->
    forall n, A n.
Proof.
intros Az RS LS n.
destruct (lt_trichotomy n z) as [H | [H | H]].
now apply left_induction; [| | apply lt_le_incl].
now rewrite H.
now apply right_induction; [| | apply lt_le_incl].
Qed.

Theorem order_induction' :
  A z ->
  (forall n, z <= n -> A n -> A (S n)) ->
  (forall n, n <= z -> A n -> A (P n)) ->
    forall n, A n.
Proof.
intros Az AS AP n; apply order_induction; try assumption.
intros m H1 H2. apply AP in H2; [|now apply le_succ_l].
now rewrite pred_succ in H2.
Qed.

End Center.

Theorem order_induction_0 :
  A 0 ->
  (forall n, 0 <= n -> A n -> A (S n)) ->
  (forall n, n < 0  -> A (S n) -> A n) ->
    forall n, A n.
Proof (order_induction 0).

Theorem order_induction'_0 :
  A 0 ->
  (forall n, 0 <= n -> A n -> A (S n)) ->
  (forall n, n <= 0 -> A n -> A (P n)) ->
    forall n, A n.
Proof (order_induction' 0).

(** Elimintation principle for < *)

Theorem lt_ind : forall (n : t),
  A (S n) ->
  (forall m, n < m -> A m -> A (S m)) ->
   forall m, n < m -> A m.
Proof.
intros n H1 H2 m H3.
apply right_induction with (S n); [assumption | | now apply le_succ_l].
intros; apply H2; try assumption. now apply le_succ_l.
Qed.

(** Elimination principle for <= *)

Theorem le_ind : forall (n : t),
  A n ->
  (forall m, n <= m -> A m -> A (S m)) ->
   forall m, n <= m -> A m.
Proof.
intros n H1 H2 m H3.
now apply right_induction with n.
Qed.

End Induction.

Tactic Notation "nzord_induct" ident(n) :=
  induction_maker n ltac:(apply order_induction_0).

Tactic Notation "nzord_induct" ident(n) constr(z) :=
  induction_maker n ltac:(apply order_induction with z).

Section WF.

Variable z : t.

Let Rlt (n m : t) := z <= n < m.
Let Rgt (n m : t) := m < n <= z.

Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt.
Proof.
intros x1 x2 H1 x3 x4 H2; unfold Rlt. rewrite H1; now rewrite H2.
Qed.

Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt.
Proof.
intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2.
Qed.

Theorem lt_wf : well_founded Rlt.
Proof.
unfold well_founded.
apply strong_right_induction' with (z := z).
auto with typeclass_instances.
intros n H; constructor; intros y [H1 H2].
apply nle_gt in H2. elim H2. now apply le_trans with z.
intros n H1 H2; constructor; intros m [H3 H4]. now apply H2.
Qed.

Theorem gt_wf : well_founded Rgt.
Proof.
unfold well_founded.
apply strong_left_induction' with (z := z).
auto with typeclass_instances.
intros n H; constructor; intros y [H1 H2].
apply nle_gt in H2. elim H2. now apply le_lt_trans with n.
intros n H1 H2; constructor; intros m [H3 H4].
apply H2. assumption. now apply le_succ_l.
Qed.

End WF.

End NZOrderProp.

(** If we have moreover a [compare] function, we can build
    an [OrderedType] structure. *)

Module NZOrderedType (NZ : NZDecOrdSig')
 <: DecidableTypeFull <: OrderedTypeFull
 := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec.


(**************************************************************************
* 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.

(** Automation for [math], to unfold [length] *)

Lemma LibListZ_length_def : forall A (l:list A),
  length l = LibList.length l.
Proof using. auto. Qed.

Hint Rewrite LibListZ_length_def : rew_maths.

(* DEMO: *)

Goal forall A (l : list A), 0 <= length l.
Proof. intros. math. Qed.

Goal forall (l : list Z) (s n : int),
     s <= n -> s = length l -> n >= 0.
Proof. intros. math. Qed.

(* ---------------------------------------------------------------------- *)
(** ** 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 (l: list A), 0 <= length l.
Proof using. intros. 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_singleton: forall (x : A), length (x :: nil) = 1.
Proof using. reflexivity. 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.
Lemma length_tail : forall l,
  l <> nil -> length (tail l) = length l - 1.
Proof using. induction l; intros; simpl; unfold length; rew_length. congruence. math. Qed.
Lemma length_tail_le : forall l,
  length (tail l) <= length l.
Proof using. destruct l; simpl; unfold length; rew_length; math. Qed.
Lemma length_le_1_implies_nil_tail : forall l,
  length l <= 1 -> tail l = nil.
Proof using.
  intros. destruct l; eauto.
  simpl. unfold length in *. rew_length in *.
  eapply length_zero_inv. math.
Qed.
Lemma abs_length:
  forall i l,
  i = length l ->
  abs i = LibList.length l.
Proof.
  unfold length. intros. subst.
  generalize (LibList.length l). clear A l. (* for clarity *)
  rew_maths. eapply Zabs2Nat.id.
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.

Lemma cons_make: forall n A (x : A), 0 < n -> x :: make (n - 1) x = make n x.
Proof.
  intros.
  unfold make. do 2 (case_if; [ math | ]).
  (* This is really painful. *)
  rewrite abs_minus by math.
  change (abs 1) with 1%nat.
  assert (0 < abs n)%nat.
  { change 0%nat with (abs 0%Z).
    eapply Zabs.Zabs_nat_lt.
    math. }
  eapply LibList.cons_make.
  math.
Qed.

End MakeProperties.

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

(* Properties of [read]. *)

Section ReadProperties.
Transparent read_inst.

Context (A : Type) `{Inhab A}.

Lemma read_zero:
  forall x (xs : list A),
  (x :: xs)[0] = x.
Proof.
  intros. unfold read, read_inst, read_impl, nth.
  case_if; [ math | ]. reflexivity.
Qed.

Lemma read_succ:
  forall x (xs : list A) i,
  0 <= i < length xs ->
  (x :: xs)[i + 1] = xs[i].
Proof.
  intros. unfold read, read_inst, read_impl, nth, LibList.nth.
  do 2 (case_if; [ math | ]).
  change (i + 1) with (Z.succ i).
  rewrite Zabs2Nat.inj_succ by math.
  reflexivity.
Qed.

End ReadProperties.

(* ---------------------------------------------------------------------- *)
(* Extensional equality between two lists. *)

Lemma ext_eq:
  forall A `{Inhab A} (xs ys : list A),
  length xs = length ys ->
  (forall i, 0 <= i < length xs -> xs[i] = ys[i]) ->
  xs = ys.
Proof.
  induction xs; destruct ys; simpl; introv Heq Hread;
  try solve [ eauto | false ]. f_equal.
  (* The head. *)
  { specializes Hread 0.
    repeat rewrite read_zero in Hread.
    repeat rewrite length_cons in Hread.
    eapply Hread.
    forwards: length_nonneg xs. math. }
  (* The tail. *)
  { repeat rewrite length_cons in *.
    eapply IHxs. math. intros i Hi.
    specializes Hread (i + 1).
    do 2 rewrite read_succ in Hread by math.
    eapply Hread. math. }
Qed.

Lemma ext_eq_index:
  forall A `{Inhab A} (xs ys : list A),
  length xs = length ys ->
  (forall i, index xs i -> xs[i] = ys[i]) ->
  xs = ys.
Proof.
  eauto using ext_eq.
Qed.

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

Section UpdateProperties.
Transparent index_inst read_inst update_inst.

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

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 index_update_eq : forall A (l:list A) i j (v:A),
  index (l[j:=v]) i = index l i.
Proof using. intros. rewrite index_def in *. rewrite~ length_update. 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_update_eq. 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.

Lemma update_update_eq : forall `{Inhab A} (l:list A) (i:int) (v w:A),
  index l i -> l[i:=v][i:=w] = l[i:=w].
Proof using.
  intros. eapply ext_eq_index; repeat rewrite length_update.
  { reflexivity. }
  intros j.
  repeat rewrite index_update_eq.
  intros Hj.
  repeat rewrite read_update_case by eauto using index_update.
  case_if; reflexivity.
Qed.

Lemma update_update_neq : forall `{Inhab A} (l:list A) (i j:int) (v w:A),
  index l i -> index l j -> i <> j -> l[i:=v][j:=w] = l[j:=w][i:=v].
Proof using.
  intros. eapply ext_eq_index; repeat rewrite length_update.
  { reflexivity. }
  intros k.
  repeat rewrite index_update_eq.
  intros Hk.
  repeat rewrite read_update_case by eauto using index_update.
  repeat case_if; reflexivity.
Qed.

Lemma update_app_right:
  forall A ys j xs i ij (v : A),
  i = length xs ->
  0 <= j ->
  ij = i + j ->
  (xs ++ ys)[ij:=v] = xs ++ ys[j:=v].
Proof.
  intros. subst ij.
  unfold LibBag.update, update_inst, update_impl.
  unfold update. do 2 (case_if; [ math | ]).
  eapply LibList.update_app_right with (i := abs i).
  { eauto using abs_length. }
  { eapply Zabs2Nat.inj_add; math. }
Qed.

Lemma update_app_right_here:
  forall A i (xs ys : list A) x y,
  i = length xs ->
  (xs ++ y :: ys)[i := x] = xs & x ++ ys.
Proof.
  intros.
  unfold LibBag.update, update_inst, update_impl.
  unfold update. case_if; [ math | ].
  eapply LibList.update_app_right_here.
  eauto using abs_length.
Qed.

Lemma read_cons_case : forall `{IA:Inhab A} (l:list A) (i:int) (v:A),
  (v::l)[i] = (If i = 0 then v else l[i-1]).
Proof using.
  introv. simpl. unfold read_impl, nth.
  case_if.
  - case_if. math. case_if~. math.
  - case_if~. case_if. math. rewrite~ abs_spos. math.
Qed.

Lemma read_last_case : forall `{IA:Inhab A} (l:list A) (i:int) (v:A),
  (l & v)[i] = (If i = LibList.length l then v else l[i]).
Proof using.
  introv. simpl. unfold read_impl, nth.
  case_if.
  - case_if~; math.
  - admit. (* lemmas missing about "&" and LibList.nth *)
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 @read_cons_case @read_last_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.

(* [index_def] : proven above *)

(* [index_update] : proven above *)

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_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 *)

(* UNDER CONSTRUCTION *)

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

Require Import LibWf.

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

Axiom count : (* UNDER CONSTRUCTION *)
  forall A (P:A->Prop) (l:list A), int.

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

Axiom count_update : (* UNDER CONSTRUCTION *)
  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).

Axiom count_bounds : (* UNDER CONSTRUCTION *)
  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.

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

(* The [prefix] ordering on lists has been defined in [LibList]. Here, we
   provide an alternate definition, as well as more properties. *)

(* TEMPORARY characterize [prefix] as pointwise equality *)

Section Prefix.

Variable A : Type.
Implicit Types xs ys : list A.

Lemma le_implies_ge: forall x y, x <= y -> y >= x.
Proof. math. Qed.

Local Hint Resolve le_implies_ge length_nonneg.

(* [prefix], [snoc], and read access. *)

Lemma prefix_read:
  forall `{Inhab A} ys xs y,
  prefix (ys & y) xs ->
  y = xs[length ys].
Proof using.
  intros.
  change (xs[length ys]) with (nth (length ys) xs).
  unfold nth. case_if as Hop; [ | clear Hop ].
  { false. forwards: length_nonneg ys. math. }
  unfold LibList.nth.
  generalize dependent xs.
  generalize dependent ys. unfold prefix.
  induction ys; intros xs [ zs ? ]; rew_list in *.
  (* Base case. *)
  { change (abs 0) with (0%nat).
    subst xs. reflexivity. }
  (* Inductive case. *)
  { rewrite abs_plus by first [ math | eauto ].
    change (abs 1) with (1%nat).
    destruct xs as [ | x xs ]; [ congruence | ].
    simpl. eapply IHys. exists zs. rew_list. congruence. }
Qed.

(* [prefix] and [length]. *)

Lemma prefix_length:
  forall ys xs,
  prefix ys xs ->
  length ys <= length xs.
Proof using.
  intros ys xs [ zs ? ]. subst xs. rew_list.
  assert (length zs >= 0). { eauto. }
  math.
Qed.

Lemma prefix_snoc_length:
  forall ys y xs,
  prefix (ys & y) xs ->
  length ys < length xs.
Proof using.
  intros ys y xs [ zs ? ]. subst xs. rew_list.
  assert (length zs >= 0). { eauto. }
  math.
Qed.

End Prefix.


Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Coq.Arith.Compare_dec.

Set Implicit Arguments.
Set Strict Implicit.

(* Some tactics for automation of later proofs *)
Ltac caseDestruct t := destruct t; try solve [ simpl in *; discriminate ].

Ltac dintuition := repeat (intuition;
  match goal with
    | [ H : exists _, _ |- _ ] => destruct H
  end).

Ltac unlet := repeat match goal with
                       | [ x := ?y |- _ ] => subst x
                     end.

Ltac hypRewriter := repeat match goal with
                              | [ H : ?x = _ |- context [ ?x ] ] => rewrite H
                              | [ H1 : ?x = _, H2 : context [ ?x ] |- _ ] => rewrite H1 in H2
                            end.

Ltac loop := repeat (repeat (hypRewriter; autorewrite with provers in *); simpl in *; subst; dintuition).

Ltac provers := intuition; loop; unlet; loop; try congruence; firstorder.

(* null hint to initialize db *)
Hint Rewrite app_nil_l : provers.

Section UpdateAt.
  Variable A : Type.

  Variable new default : A.

  Fixpoint updateAt (ls : list A) (n : nat) : list A :=
    match n with
      | 0 => new :: tail ls
      | S n => match head ls with
                 | None => default
                 | Some v => v
               end :: updateAt (tail ls) n
    end.

  Definition defaulted (ls : list A) (n : nat) (n' : nat) : option A :=
    match Compare_dec.lt_eq_lt_dec n n' with
      | inleft (left _) => nth_error ls n'
      | inleft (right _) => Some new
      | inright _ => match nth_error ls n' with
                       | None => Some default
                       | Some v => Some v
                     end
    end.

  Lemma nth_error_updateAt : forall n l,
    nth_error (updateAt l n) n = value new.
    induction n; destruct l; simpl; (reflexivity || apply IHn).
  Defined.

  Lemma nth_error_updateAt_not : forall old n' ls n,
    n <> n' ->
    nth_error ls n = Some old ->
    nth_error (updateAt ls n') n = Some old.
  Proof.
    induction n'; destruct ls; destruct n; simpl; intros; try solve [ discriminate | exfalso; auto | auto ].
  Qed.

  Lemma nth_error_updateAt_gt : forall n n' ls,
    n < n' ->
    nth_error (updateAt ls n) n' = nth_error ls n'.
  Proof.
    induction n; simpl; intros.
      destruct n'; destruct ls; simpl; intros; try solve [ auto | exfalso; omega | destruct n'; reflexivity ].

      destruct n'. exfalso; omega.
        destruct ls; simpl. rewrite IHn. destruct n'; auto. omega.
        apply IHn. omega.
  Defined.

  Lemma nth_error_updateAt_lt : forall n' n ls,
    n' < n ->
    nth_error (updateAt ls n) n' =
      match nth_error ls n' with
        | None => Some default
        | Some v => Some v
      end.
  Proof.
    induction n'; simpl; intros.
      destruct n; [ exfalso; omega | ]. destruct ls; auto.
      destruct n; [ exfalso; omega | ]. destruct ls; simpl; rewrite IHn' by omega. destruct n'; auto.
      auto.
  Defined.

  Theorem nth_error_updateAt_eq : forall n ls n',
    nth_error (updateAt ls n) n' = defaulted ls n n'.
  Proof.
    unfold defaulted; intros.
      destruct (lt_eq_lt_dec n n'). destruct s.
      eapply nth_error_updateAt_gt; auto.
      subst; eapply nth_error_updateAt; auto.
      eapply nth_error_updateAt_lt; auto.
  Defined.

  (** **)
  Fixpoint cast (P : option A -> Type) ls idx
    : P (nth_error (updateAt ls idx) idx) -> P (Some new) :=
    match idx with
      | O => match ls
             return P (nth_error (updateAt ls O) O) -> _ with
               | nil => fun x => x
               | _ => fun x => x
             end
      | S idx =>
        match ls return P (nth_error (updateAt ls (S idx)) (S idx)) -> _ with
          | nil => cast P nil idx
          | _ => cast P _ idx
        end
    end.

  Theorem cast_inj : forall P idx ls x y, cast P ls idx x = cast P ls idx y -> x = y.
  Proof.
    induction idx; destruct ls; simpl; intros; auto.
  Qed.

End UpdateAt.

Section UpdatePosition2.
  Variable A : Type.

  Hint Rewrite nth_error_updateAt : provers.
  Lemma nth_error_updateAt_2 : forall A (ls : list A) d d' a b m n,
    m <> n ->
    nth_error (updateAt a d (updateAt b d' ls n) m) n = value b.
    induction ls; induction m; induction n; provers.
  Qed.
End UpdatePosition2.

(*
Section MapRepr.
  Variable T : Type.
  Record Repr : Type :=
  { footprint : list (nat * T)
  ; default : T
  }.

  Definition nil_Repr (d : T) : Repr :=
  {| footprint := nil
   ; default := d
   |}.

  Definition listToRepr (ls : list T) (d : T) : Repr :=
    {| footprint :=
      ((fix listToRepr ls cur : list (nat * T) :=
        match ls with
          | nil => nil
          | l :: ls => (cur, l) :: listToRepr ls (S cur)
        end) ls 0)
     ; default := d
     |}.

  Definition listOptToRepr (ls : list (option T)) (d : T) : Repr :=
    {| footprint :=
      ((fix listToRepr ls cur : list (nat * T) :=
        match ls with
          | nil => nil
          | Some l :: ls => (cur, l) :: listToRepr ls (S cur)
          | None :: ls => listToRepr ls (S cur)
        end) ls 0)
     ; default := d
     |}.

  Fixpoint repr' (d : T) (ls : list (nat * T)) : list T -> list T :=
    match ls with
      | nil => fun x => x
      | (n, v) :: ls =>
        fun x => updateAt v d (repr' d ls x) n
    end.

  Section get.
    Variable n : nat.

    Fixpoint get (ls : list (nat * T)) : option T :=
      match ls with
        | nil => None
        | (n',v) :: ls =>
          if Peano_dec.eq_nat_dec n n' then Some v else get ls
      end.
  End get.

  Definition repr (l : Repr) : list T -> list T :=
    match l with
      | {| footprint := f ; default := d |} =>
        repr' d f
    end.

  Fixpoint nat_eq_bool (a b : nat) : bool :=
    match a , b with
      | 0 , 0 => true
      | S a , S b => nat_eq_bool a b
      | _ , _ => false
    end.

  Fixpoint nat_in (l : list nat) (n : nat) : bool :=
    match l with
      | nil => false
      | a :: b => if nat_eq_bool a n then true else nat_in b n
    end.

  Fixpoint repr_optimize (l : list (nat * T)) (ignore : list nat) : list (nat * T) :=
    match l with
      | nil => nil
      | (n,t) :: b =>
        if nat_in ignore n then
          repr_optimize b ignore
        else
          (n,t) :: repr_optimize b (n :: ignore)
    end.

  Definition repr_combine (l r : Repr) : Repr :=
    match l , r with
      | {| footprint := lf ; default := ld |} ,
        {| footprint := rf ; default := rd |} =>
        {| footprint := repr_optimize (lf ++ rf) nil ; default := ld |}
    end.
  (** NOTE: that we don't have any lemmas for combination because we are
   ** relying on Ltac's dynamic types to do combinations
   **)

  Definition repr_get (l : Repr) (n : nat) : option T :=
    get n (footprint l).

End MapRepr.
*)

(** This is an alternative representation
 ** 1) it avoids nats (including comparison)
 ** 2) it is canonical
 ** 3) it optimizes the common case of prefixes
 **)
Section Repr2.
  Section parametric.
    Variable T : Type.
    Record Repr : Type :=
    { footprint : list (option T)
    ; default : T
    }.

    Definition nil_Repr (d : T) : Repr :=
      {| footprint := nil
       ; default := d
      |}.

    Definition listToRepr (ls : list T) (d : T) : Repr :=
      {| footprint := map (@Some _) ls
       ; default := d
      |}.

    Definition listOptToRepr (ls : list (option T)) (d : T) : Repr :=
      {| footprint := ls
       ; default := d
      |}.

    Fixpoint repr' (d : T) (ls : list (option T)) : list T -> list T :=
      match ls with
        | nil => fun x => x
        | None :: ls => fun x =>
          match x with
            | nil => d
            | a :: _ => a
          end :: repr' d ls (tl x)
        | Some v :: ls => fun x =>
          v :: repr' d ls (tl x)
      end.

    Definition repr (l : Repr) : list T -> list T :=
      Eval cbv delta [ repr' ] in
        match l with
          | {| footprint := f ; default := d |} =>
            repr' d f
        end.

    Fixpoint join (ls rs : list (option T)) : list (option T) :=
      match ls , rs with
        | nil , rs => rs
        | ls , nil => ls
        | l :: ls , r :: rs =>
          match l with
            | Some _ => l
            | None => r
          end :: join ls rs
      end.

    Definition repr_combine (l r : Repr) : Repr :=
      Eval cbv delta [ join ] in
        match l , r with
          | {| footprint := lf ; default := ld |} ,
            {| footprint := rf ; default := rd |} =>
            {| footprint := join lf rf ; default := ld |}
        end.

    Lemma repr_idempotent : forall a b,
      repr a (repr a b) = repr a b.
    Proof.
      clear. destruct a.
      simpl. induction footprint0; simpl; intros; auto.
      destruct a; simpl; auto. f_equal. rewrite IHfootprint0. auto.
      destruct b; auto. rewrite IHfootprint0; auto. simpl.
      rewrite IHfootprint0. auto.
    Qed.

  End parametric.
End Repr2.

Ltac reduce_repr_list ls :=
  eval cbv beta zeta delta [
    repr_combine repr listOptToRepr listToRepr nil_Repr
    map
  ] in ls.


Module Type Seed.
  (* === Eq =============== *)
  Parameter T : Set.
  Parameter eq_bool  : T -> T -> bool.

  Axiom eq_bool_correct : forall x y, eq_bool x y = true <-> x = y.

  (* === Eq =============== *)

End Seed.

Module Make(S : Seed).
  Export S.

  Definition eq_dec : forall (x y: T), {x = y} + {x <> y}.
    intros x y. case_eq (eq_bool x y).
    - intros eq. apply eq_bool_correct in eq. now left.
    - intros neq. right. intro. apply eq_bool_correct in H. now rewrite neq in H.
  Defined.

End Make.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_bnd_low_reduce :
  forall T1 x1 L1, T1 = (t_sel_bnd x1 L1) ->
                  forall T2 L2 T2', T2 = (t_low L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.