From CoreErlang.FrameStack Require Export Termination.
Import ListNotations.

(** Because of this, reasoning about preorder relations is enough *)
Goal forall T : Type, forall R : relation T, Reflexive R -> Transitive R ->
  let R' := fun x y => R x y /\ R y x in Reflexive R' /\ Symmetric R' /\ Transitive R'.
Proof.
  intros. split. 2: split.
  * intro. unfold R'. split; apply H.
  * intro. intros. unfold R' in *. destruct H1.
    split; auto.
  * intro. intros. unfold R' in *. destruct H1, H2. split.
    - eapply H0; eauto.
    - eapply H0; eauto.
Qed.

Definition exc_rel (n : nat)
                    (Vrel : forall m, m <= n -> Val -> Val -> Prop)
                    (e1 e2 : Exception) : Prop :=
match e1, e2 with
  | (class1, reason1, details1), (class2, reason2, details2)  =>
    class1 = class2 /\
    (forall m (Hmn : m <= n),
    Vrel m Hmn reason1 reason2 /\
    Vrel m Hmn details1 details2)
end.

(* Normal forms are exceptions and value sequences! This is why there
   is two clauses. *)
Definition frame_rel (n : nat)
                     (Vrel : forall m, m <= n -> Val -> Val -> Prop)
                     (F1 F2 : FrameStack) : Prop :=
  FSCLOSED F1 /\ FSCLOSED F2 /\
  (forall m (Hmn : m <= n) (vl1 vl2 : ValSeq),
    list_biforall (Vrel m Hmn) vl1 vl2 ->
    | F1, RValSeq vl1 | m ↓ -> | F2, RValSeq vl2 | ↓)
  /\
  (forall m (Hmn : m <= n) (e1 e2 : Exception),
    exc_rel m (fun m' H => Vrel m' (Nat.le_trans _ _ _ H Hmn)) e1 e2 ->
    | F1, RExc e1 | m ↓ -> | F2, RExc e2 | ↓)
  /\
  (forall m (Hmn : m <= n), | F1, RBox | m ↓ -> | F2, RBox | ↓).

Definition exp_rel (n : nat)
                   (Vrel : forall m, m <= n -> Val -> Val -> Prop)
                   (p1 p2 : Exp)
                 : Prop :=
  EXPCLOSED p1 /\ EXPCLOSED p2 /\
  forall m (Hmn : m <= n) F1 F2,
     frame_rel m (fun m' H => Vrel m' (Nat.le_trans _ _ _ H Hmn)) F1 F2 ->
     | F1, RExp p1 | m ↓ -> | F2, RExp p2 | ↓
.

Fixpoint Vrel_rec (n : nat)
                  (Vrel : forall m, m < n -> Val -> Val -> Prop)
                  (v1 v2 : Val) : Prop :=
  VALCLOSED v1 /\ VALCLOSED v2 /\
  match v1, v2 with
  | VNil, VNil => True
  | VLit l, VLit l' => if Lit_beq l l' then True else False
  | VCons hd tl, VCons hd' tl' => Vrel_rec n Vrel hd hd' /\ Vrel_rec n Vrel tl tl'
  | VTuple l, VTuple l' =>
    (fix go l l' :=
      match l, l' with
        | [], []        => True
        | x::xs, y::ys  => Vrel_rec n Vrel x y /\ go xs ys
        | _,  _         => False
      end) l l'
  | VMap l, VMap l' =>
    (fix go l l' :=
      match l, l' with
        | [], []        => True
        | (x1,x2)::xs, (y1,y2)::ys  => Vrel_rec n Vrel x1 y1 /\
                                       Vrel_rec n Vrel x2 y2 /\
                                       go xs ys
        | _,  _         => False
      end) l l'
  | VClos ext id vc e, VClos ext' id' vc' e' =>
    vc = vc' /\
    id = id' /\
    (forall m (Hmn : m < n),
     forall (vl1 vl2 : list Val),
     length vl1 = vc -> (* list_biforall restricts the length of vl2, thus
                           this is sufficient*)
     list_biforall (Vrel m Hmn) vl1 vl2 ->
     exp_rel m (fun m' H => Vrel m' (Nat.le_lt_trans _ _ _ H Hmn))
                (e.[list_subst ((convert_to_closlist ext)++vl1) idsubst])
                (e'.[list_subst ((convert_to_closlist ext')++vl2) idsubst])
   )
  | _, _ => False
  end
.

Definition Vrel : nat -> Val -> Val -> Prop :=
  Fix Wf_nat.lt_wf _ Vrel_rec.

Definition Erel (n : nat) (e1 e2 : Exp) : Prop :=
  exp_rel n (fun m _ => Vrel m) e1 e2.

Definition Frel (n : nat) (K1 K2 : FrameStack) : Prop :=
  frame_rel n (fun m _ => Vrel m) K1 K2.

Definition Excrel (n: nat) (ex1 ex2 : Exception) : Prop :=
  exc_rel n (fun m _ => Vrel m) ex1 ex2.

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

(** ξ and η assigns closed expressions to vars in Γ
  Basically this says, ξ and η are equivalent pointwise for Γ
*)
Lemma Vrel_rec_pointwise {n : nat} :
  forall (f g : forall m : nat, (m < n)%nat -> Val -> Val -> Prop),
    (forall (m : nat) (p : (m < n)%nat), f m p = g m p) ->
    Vrel_rec n f = Vrel_rec n g.
Proof.
  intros.
  extensionality v1.
  extensionality v2. generalize dependent v2.
  induction v1 using Val_ind_weakened with
    (Q := Forall (
      fun v1 => forall v2 : Val, Vrel_rec n f v1 v2 = Vrel_rec n g v1 v2
    ))
    (R := Forall (
      fun '(v11, v12) =>
        (forall v2 : Val, Vrel_rec n f v11 v2 = Vrel_rec n g v11 v2)
      /\
        (forall v2 : Val, Vrel_rec n f v12 v2 = Vrel_rec n g v12 v2)
    )); try destruct v2; unfold Vrel_rec; intros; try reflexivity.
  * f_equal. f_equal. rewrite IHv1_1, IHv1_2; reflexivity.
  * do 2 f_equal.
    generalize dependent l0. induction l; destruct l0; try reflexivity; cbn.
    destruct_foralls; unfold Vrel_rec in *; f_equal.
    - now rewrite H2.
    - clear H2. now apply IHl with (l0 := l0) in H3.
  * do 2 f_equal.
    generalize dependent l0. induction l; destruct l0; try reflexivity; cbn.
    destruct a, p.
    destruct_foralls; simpl. f_equal. 2: f_equal.
    - fold Vrel_rec in *. now rewrite (proj1 H2).
    - fold Vrel_rec in *. now rewrite (proj2 H2).
    - clear H2. now apply IHl with (l0 := l0) in H3.
  * repeat f_equal.
    extensionality m.
    extensionality Hmn.
    extensionality v1'.
    extensionality v2'.
    rewrite H.
    extensionality l1.
    extensionality bif.
    f_equal.
    extensionality m'.
    extensionality H0.
    trivial.
  * auto.
  * auto.
  * auto.
  * auto.
Qed.

Lemma Vrel_Fix_eq : forall {n : nat} {v1 v2 : Val},
  Vrel n v1 v2
  =
  Vrel_rec n (fun (m : nat) (_ : m < n) => Vrel m) v1 v2.
Proof.
  intros.
  unfold Vrel.
  rewrite Fix_eq by (auto using Vrel_rec_pointwise).
  trivial.
Qed.

Definition inf :=
  ELetRec
    [(0, °EApp (`VFunId (0, 0)) [])]
    (EApp (`VFunId (0, 0)) []).

Theorem inf_diverges :
  forall n Fs, ~|Fs, inf| n↓.
Proof.
  intros. intro. induction n using Wf_nat.lt_wf_ind.
  inv H. 2: inv H1.
  * simpl in *. inv H6. inv H4. inv H2. inv H5. 2: inv H.
    cbn in H7.
    unfold inf in H0. specialize (H0 (1 + k) ltac:(lia)).
    apply H0. econstructor. reflexivity. cbn. assumption.
Qed.

Scheme le_dep_ind := Induction for le Sort Prop.

Ltac forall_to_Forall :=
  match goal with
  | [H : forall i : nat, i < length _ -> ?P (nth i _ _) |- _] =>
    apply indexed_to_forall in H
  end.
Ltac foralls_to_Foralls :=
  repeat forall_to_Forall.

Ltac fdestruct_scopes :=
  destruct_scopes;
  foralls_to_Foralls;
  destruct_foralls.

Lemma Vrel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {v1 v2 : Val},
    Vrel n v1 v2 ->
    Vrel m v1 v2.
Proof.
  induction 1 using le_dep_ind;
    intros;
    eauto.
  generalize dependent v2.
  induction v1 using Val_ind_weakened with
  (Q := Forall (
    fun v1 => forall v2 : Val, Vrel (S m0) v1 v2 -> Vrel m v1 v2
  ))
  (R := Forall (
    fun '(v11, v12) =>
      (forall v2 : Val, Vrel (S m0) v11 v2 -> Vrel m v11 v2)
    /\
      (forall v2 : Val, Vrel (S m0) v12 v2 -> Vrel m v12 v2)
  )); try destruct v2; intros; intuition; try break_match_hyp; intros.
  * rewrite Vrel_Fix_eq.
    rewrite Vrel_Fix_eq in H. destruct H as [cl1 [cl2 H]].
    split. 2: split. 1-2: auto.
    simpl. simpl in H. intros.
    specialize (IHv1_1 v2_1). specialize (IHv1_2 v2_2).
    do 2 rewrite Vrel_Fix_eq in IHv1_1. do 2 rewrite Vrel_Fix_eq in IHv1_2.
    split. apply IHv1_1, H. apply IHv1_2, H.
  * rewrite Vrel_Fix_eq.
    rewrite Vrel_Fix_eq in H. simpl in *.
    intuition.
    generalize dependent l0. induction l; intros; auto.
    - destruct_foralls; destruct l0; intuition; simpl in *.
      + specialize (H4 v). do 2 rewrite Vrel_Fix_eq in H4. now apply H4.
      + apply H2; auto.
        fdestruct_scopes. constructor; now apply indexed_to_forall.
        fdestruct_scopes. constructor; now apply indexed_to_forall.
  * rewrite Vrel_Fix_eq.
    rewrite Vrel_Fix_eq in H. simpl in *.
    intuition.
    generalize dependent l0. induction l; intros; auto.
    - destruct_foralls; destruct l0; intuition; simpl in *.
      destruct a, p. intuition.
      + specialize (H2 v1). do 2 rewrite Vrel_Fix_eq in H2. now apply H2.
      + specialize (H7 v2). do 2 rewrite Vrel_Fix_eq in H7. now apply H7.
      + apply H1; auto;
        destruct_scopes.
        constructor; intros; [apply (H6 (S i) ltac:(slia))|apply (H12 (S i) ltac:(slia))].
        constructor; intros; [apply (H9 (S i) ltac:(slia))|apply (H11 (S i) ltac:(slia))].
  * rewrite Vrel_Fix_eq. rewrite Vrel_Fix_eq in H.
    unfold Vrel_rec at 1.
    unfold Vrel_rec at 1 in H. intuition.
    apply H4; auto. lia.
Qed.

Lemma Erel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {e1 e2 : Exp},
    Erel n e1 e2 ->
    Erel m e1 e2.
Proof.
  intros.
  unfold Erel, exp_rel.
  unfold Erel, exp_rel in H.
  destruct H, H0. split; auto. split; auto.
  intros. eapply (H1 m0); eauto. lia.
Qed.

Lemma Excrel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {e1 e2 : Exception},
    Excrel n e1 e2 ->
    Excrel m e1 e2.
Proof.
  intros.
  unfold Excrel, exc_rel in *. destruct e1, e2, p, p0.
  split. apply H.
  intros. split; eapply Vrel_downclosed; apply H; eassumption.
  Unshelve. 1-2: lia.
Qed.

Lemma Vrel_closed : forall {n : nat} {v1 v2 : Val},
    Vrel n v1 v2 ->
    VALCLOSED v1 /\ VALCLOSED v2.
Proof.
  intros. rewrite Vrel_Fix_eq in H.
  destruct v1, v2; destruct H as [Cl1 [Cl2 H]];
  split; try contradiction.
  all: auto.
Qed.

Lemma Vrel_closed_l : forall {n : nat} {v1 v2 : Val},
    Vrel n v1 v2 ->
    VALCLOSED v1.
Proof.
  intros.
  apply Vrel_closed in H.
  intuition.
Qed.

Global Hint Resolve Vrel_closed_l : core.

Lemma Vrel_closed_r : forall {n : nat} {v1 v2 : Val},
    Vrel n v1 v2 ->
    VALCLOSED v2.
Proof.
  intros.
  apply Vrel_closed in H.
  intuition.
Qed.

Global Hint Resolve Vrel_closed_r : core.

Lemma Erel_closed : forall {n : nat} {e1 e2 : Exp},
    Erel n e1 e2 ->
    EXPCLOSED e1 /\ EXPCLOSED e2.
Proof.
  intros.
  unfold Erel, exp_rel in H.
  intuition.
Qed.

Lemma Erel_closed_l : forall {n : nat} {e1 e2 : Exp},
    Erel n e1 e2 ->
    EXPCLOSED e1.
Proof.
  intros.
  apply Erel_closed in H.
  intuition.
Qed.

Global Hint Resolve Erel_closed_l : core.

Lemma Erel_closed_r : forall {n : nat} {e1 e2 : Exp},
    Erel n e1 e2 ->
    EXPCLOSED e2.
Proof.
  intros.
  apply Erel_closed in H.
  intuition.
Qed.

Global Hint Resolve Erel_closed_r : core.

(** closing substitutions *)
Definition Grel (n : nat) (Γ : nat) (ξ₁ ξ₂ : Substitution) : Prop :=
  SUBSCOPE Γ ⊢ ξ₁ ∷ 0 /\ SUBSCOPE Γ ⊢ ξ₂ ∷ 0 /\
  forall x, x < Γ ->
    match (ξ₁ x), (ξ₂ x) with
    | inl e1, inl e2 => Vrel n e1 e2
    | _, _ => False
    end.

Lemma Grel_downclosed_helper : forall vals1 vals2 m n,
  m <= n -> length vals1 = length vals2 ->
  list_biforall (Vrel n) vals1 vals2 ->
  list_biforall (Vrel m) vals1 vals2.
Proof.
  intro. induction vals1 using list_length_ind; intros.
  destruct vals1, vals2.
  * constructor.
  * inversion H1.
  * inversion H1.
  * inversion H2. subst. constructor.
    - eapply Vrel_downclosed. eauto.
    - eapply H; eauto.
Unshelve. auto.
Qed.

Lemma Grel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {Γ : nat} {ξ₁ ξ₂ : Substitution},
    Grel n Γ ξ₁ ξ₂ ->
    Grel m Γ ξ₁ ξ₂ .
Proof.
  unfold Grel; intros.
  unfold Grel; intros. intuition.
  repeat break_match_goal; specialize (H2 x H1); try rewrite Heqs in H2; try rewrite Heqs0 in H2; [ intuition (eauto using Vrel_downclosed) | contradiction | contradiction ].
Qed.

Definition Vrel_open (Γ : nat) (v1 v2 : Val) :=
  forall n ξ₁ ξ₂,
  Grel n Γ ξ₁ ξ₂
->
  Vrel n (substVal ξ₁ v1) (substVal ξ₂ v2).

Definition Excrel_open (Γ : nat) (e1 e2 : Exception) :=
  forall n ξ₁ ξ₂,
  Grel n Γ ξ₁ ξ₂
->
  Excrel n e1.[ξ₁]ₑₓ e2.[ξ₂]ₑₓ.

Definition Erel_open (Γ : nat) (e1 e2 : Exp) :=
  forall n ξ₁ ξ₂,
  Grel n Γ ξ₁ ξ₂
->
  Erel n (subst ξ₁ e1) (subst ξ₂ e2).

Lemma Erel_open_closed : forall {Γ e1 e2},
    Erel_open Γ e1 e2 ->
    forall ξ, SUBSCOPE Γ ⊢ ξ ∷ 0 ->
              EXPCLOSED (e1.[ξ]) /\ EXPCLOSED (e2.[ξ]).
Proof.
  intros.
  apply @Erel_closed with (n:=0).
  apply H; auto.
  unfold Grel.
  intuition idtac. break_match_goal.
  (* rewrite Vrel_Fix_eq. unfold Vrel_rec at 1. *)
  specialize (H0 x H1) as P'. rewrite Heqs in P'. clear dependent ξ.
  * clear H H1 x e1 e2 Γ. rewrite Vrel_Fix_eq. revert P'. revert v.
    einduction v using Val_ind_weakened with
      (Q := Forall (
        fun v => VALCLOSED v -> Vrel_rec 0 (fun (m : nat) (_ : m < 0) => Vrel m) v v
      ))
      (R := Forall (
        fun '(v1, v2) =>
         (VALCLOSED v1 -> Vrel_rec 0 (fun (m : nat) (_ : m < 0) => Vrel m) v1 v1) /\
         (VALCLOSED v2 -> Vrel_rec 0 (fun (m : nat) (_ : m < 0) => Vrel m) v2 v2)
      )); intros; auto.
    all: split;[auto|split;auto].
    - now rewrite Lit_eqb_refl.
    - destruct_scopes. split. now eapply IHv0_1. now eapply IHv0_2.
    - induction l; auto.
      fdestruct_scopes. split.
      + now apply H1.
      + apply IHl; auto. constructor. now apply indexed_to_forall.
    - induction l; auto.
      fdestruct_scopes. destruct a. split. 2: split.
      + apply H3. apply (H0 0). slia.
      + apply H3. apply (H2 0). slia.
      + apply IHl; auto. constructor.
        intros. apply (H0 (S i)). slia.
        intros. apply (H2 (S i)). slia.
    - inv P'. lia.
    - inv P'. lia.
    - split; auto. intros. split; auto. lia.
  * specialize (H0 x H1). rewrite Heqs in H0. lia.
Qed.

Lemma Erel_open_scope : forall {Γ e1 e2},
    Erel_open Γ e1 e2 ->
    EXP Γ ⊢ e1 /\ EXP Γ ⊢ e2.
Proof.
  intros.
  pose proof (Erel_open_closed H).
  split;
  eapply (subst_implies_scope_exp); intros; apply H0; auto.
Qed.

Lemma Erel_open_scope_l : forall {Γ e1 e2},
    Erel_open Γ e1 e2 ->
    EXP Γ ⊢ e1.
Proof.
  intros. eapply Erel_open_scope in H. destruct H. auto.
Qed.

Global Hint Resolve Erel_open_scope_l : core.

Lemma Erel_open_scope_r : forall {Γ e1 e2},
    Erel_open Γ e1 e2 ->
    EXP Γ ⊢ e2.
Proof.
  intros. eapply Erel_open_scope in H. destruct H. auto.
Qed.

Global Hint Resolve Erel_open_scope_r : core.

Theorem Vrel_fundamental_0 v :
  VALCLOSED v -> Vrel 0 v v.
Proof.
  rewrite Vrel_Fix_eq. induction v using Val_ind_weakened with
    (Q := Forall (
      fun v => VALCLOSED v -> Vrel 0 v v
    ))
    (R := Forall (
      fun '(v1, v2) =>
        (VALCLOSED v1 -> Vrel 0 v1 v1)
        /\
        (VALCLOSED v2 -> Vrel 0 v2 v2)
    )); intros; simpl; intuition.
  * now rewrite Lit_eqb_refl.
  * destruct_scopes. now apply IHv1.
  * destruct_scopes. now apply IHv2.
  * fdestruct_scopes. induction l; auto.
    destruct_foralls. split.
    rewrite <- Vrel_Fix_eq. now apply H2. intuition.
  * destruct_scopes. induction l; auto. destruct_foralls.
    destruct a. split. 2: split.
    1-2: rewrite <- Vrel_Fix_eq; apply H2.
    1: now apply (H1 0 ltac:(slia)).
    1: now apply (H3 0 ltac:(slia)).
    apply IHl; auto; intros.
    1: now apply (H1 (S i) ltac:(slia)).
    1: now apply (H3 (S i) ltac:(slia)).
  * inv H. lia.
  * inv H. lia.
  * lia.
  * constructor; auto. intro. rewrite Vrel_Fix_eq. now apply IHv.
  * constructor; auto. split; intro; rewrite Vrel_Fix_eq.
    now apply IHv1.
    now apply IHv2.
Qed.

Lemma Vrel_open_closed : forall {Γ v1 v2},
    Vrel_open Γ v1 v2 ->
    forall ξ, SUBSCOPE Γ ⊢ ξ ∷ 0 ->
              VALCLOSED (v1.[ξ]ᵥ) /\ VALCLOSED (v2.[ξ]ᵥ).
Proof.
  intros.
  apply @Vrel_closed with (n:=0).
  apply H; auto.
  unfold Grel.
  intuition idtac. break_match_goal. 2: {
    epose proof (H0 x H1). rewrite Heqs in H2. lia.
  }
  specialize (H0 x H1) as P'. rewrite Heqs in P'.
  now apply Vrel_fundamental_0.
Qed.

Lemma Vrel_open_scope : forall {Γ e1 e2},
    Vrel_open Γ e1 e2 ->
    VAL Γ ⊢ e1 /\ VAL Γ ⊢ e2.
Proof.
  intros.
  pose proof (Vrel_open_closed H).
  split;
  eapply (subst_implies_scope_val); intros; apply H0; auto.
Qed.

Lemma Vrel_open_scope_l : forall {Γ e1 e2},
    Vrel_open Γ e1 e2 ->
    VAL Γ ⊢ e1.
Proof.
  intros. eapply Vrel_open_scope in H. destruct H. auto.
Qed.

Global Hint Resolve Vrel_open_scope_l : core.

Lemma Vrel_open_scope_r : forall {Γ e1 e2},
    Vrel_open Γ e1 e2 ->
    VAL Γ ⊢ e2.
Proof.
  intros. eapply Vrel_open_scope in H. destruct H. auto.
Qed.

Global Hint Resolve Vrel_open_scope_r : core.

Lemma Frel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {F1 F2 : FrameStack},
    Frel n F1 F2 ->
    Frel m F1 F2.
Proof.
  unfold Frel, frame_rel.
  intuition. eapply H1 in H5. exact H5. lia. assumption.
  eapply H2. 3: exact H5. lia. assumption.
  eapply H4. 2: eassumption. lia.
Qed.

Global Hint Resolve Frel_downclosed : core.

Lemma Frel_closed : forall {n : nat} {F1 F2 : FrameStack},
    Frel n F1 F2 ->
    FSCLOSED F1 /\ FSCLOSED F2.
Proof.
  intros.
  unfold Frel, frame_rel in H.
  intuition.
Qed.

Lemma Frel_closed_l : forall {n : nat} {F1 F2 : FrameStack},
    Frel n F1 F2 ->
    FSCLOSED F1.
Proof.
  intros.
  apply Frel_closed in H.
  intuition.
Qed.

Global Hint Resolve Frel_closed_l : core.

Lemma Frel_closed_r : forall {n : nat} {F1 F2 : FrameStack},
    Frel n F1 F2 ->
    FSCLOSED F2.
Proof.
  intros.
  apply Frel_closed in H.
  intuition.
Qed.

Global Hint Resolve Frel_closed_r : core.

Lemma biforall_vrel_scoped : forall vals1 vals2 Γ,
  list_biforall (Vrel_open Γ) vals1 vals2 ->
  Forall (fun e => VAL Γ ⊢ e) vals1 /\ Forall (fun e => VAL Γ ⊢ e) vals2.
Proof.
  induction vals1; intros; inversion H; subst; repeat constructor.
  * eapply Vrel_open_scope_l; eauto.
  * specialize (IHvals1 _ _ H4); apply IHvals1.
  * eapply Vrel_open_scope_r; eauto.
  * eapply IHvals1; eauto.
Qed.

Lemma biforall_erel_scoped : forall vals1 vals2 Γ,
  list_biforall (Erel_open Γ) vals1 vals2 ->
  Forall (fun e => EXP Γ ⊢ e) vals1 /\ Forall (fun e => EXP Γ ⊢ e) vals2.
Proof.
  induction vals1; intros; inversion H; subst; split; constructor.
  * eapply Erel_open_scope_l; eauto.
  * specialize (IHvals1 _ _ H4); apply IHvals1.
  * eapply Erel_open_scope_r; eauto.
  * eapply IHvals1; eauto.
Qed.

Lemma biforall_vrel_closed : forall vals1 vals2 m,
  list_biforall (Vrel m) vals1 vals2 ->
  Forall (fun e => VALCLOSED e) vals1 /\ Forall (fun e => VALCLOSED e) vals2.
Proof.
  induction vals1; intros; inversion H; subst; repeat constructor.
  * eapply Vrel_closed_l; eauto.
  * specialize (IHvals1 _ _ H4); apply IHvals1.
  * eapply Vrel_closed_r; eauto.
  * eapply IHvals1; eauto.
Qed.

Lemma biforall_erel_closed : forall vals1 vals2 m,
  list_biforall (Erel m) vals1 vals2 ->
  Forall (fun e => EXPCLOSED e) vals1 /\ Forall (fun e => EXPCLOSED e) vals2.
Proof.
  induction vals1; intros; inversion H; subst; split; constructor.
  * eapply Erel_closed_l; eauto.
  * specialize (IHvals1 _ _ H4); apply IHvals1.
  * eapply Erel_closed_r; eauto.
  * eapply IHvals1; eauto.
Qed.

Lemma Grel_scons : forall n v1 v2 ξ₁ ξ₂ Γ,
  Grel n Γ ξ₁ ξ₂ -> Vrel n v1 v2 -> Grel n (S Γ) (v1.:ξ₁) (v2.:ξ₂).
Proof.
  intros. split. 2: split.
  1-2: apply cons_scope; auto.
  2, 4: apply H. 1-2: now apply Vrel_closed in H0.
  intros. destruct x; simpl; auto.
  apply H. lia.
Qed.

Corollary Grel_list : forall n vl1 vl2 ξ₁ ξ₂ Γ,
  Grel n Γ ξ₁ ξ₂ -> list_biforall (Vrel n) vl1 vl2 ->
  Grel n (length vl1 + Γ) (list_subst vl1 ξ₁) (list_subst vl2 ξ₂).
Proof.
  induction vl1; intros; inversion H0; subst; simpl; auto.
  apply Grel_scons; auto.
Qed.

(* To avoid unnecessary case separations: *)
Lemma Vrel_possibilities : forall {n v1 v2},
  Vrel n v1 v2 ->
  (v1 = VNil /\ v2 = VNil) \/
  (exists n, v1 = VLit n /\ v2 = VLit n) \/
  (* (exists p, v1 = EPid p /\ v2 = EPid p) \/ *)
  (exists v11 v12 v21 v22, v1 = VCons v11 v12 /\ v2 = VCons v21 v22) \/
  (exists l l', v1 = VTuple l /\ v2 = VTuple l') \/
  (exists l l', v1 = VMap l /\ v2 = VMap l') \/
  (exists ext1 ext2 id1 id2 vl1 vl2 b1 b2,
    v1 = VClos ext1 id1 vl1 b1 /\ v2 = VClos ext2 id2 vl2 b2).
Proof.
  intros; destruct v1, v2; destruct H as [? [? ?] ]; subst; try contradiction.
  * left. auto.
  * break_match_hyp. 2: inv H1. apply Lit_eqb_eq in Heqb. subst.
    right. left. eexists; split; reflexivity.
  * right. right. left. repeat eexists.
  * right. right. right. left. repeat eexists.
  * right. right. right. right. left. repeat eexists.
  * right. right. right. right. right. repeat eexists.
Qed.

Lemma Grel_list_subst m vl' Γ ξ₁ ξ₂:
  forall vl1 vl2,
  list_biforall (Vrel m) vl1 vl2 ->
  Grel m Γ ξ₁ ξ₂ ->
  length vl1 = vl' ->
  Grel m (vl' + Γ) (upn vl' ξ₁ >> list_subst vl1 idsubst)
  (upn vl' ξ₂ >> list_subst vl2 idsubst).
Proof.
  split. 2: split.
  1-2: eapply substcomp_scoped.
  1,3: apply upn_scope; now apply H0.
  1-2: apply scoped_list_subscoped_eq; auto.
  all: apply biforall_length in H as HB.
  2: lia.
  {
    rewrite indexed_to_forall; intros.
    eapply biforall_forall with (i := i) in H. 2: lia.
    apply Vrel_closed_l in H. eassumption.
  }
  {
    rewrite indexed_to_forall; intros.
    eapply biforall_forall with (i := i) in H.
    2: lia.
    apply Vrel_closed_r in H. eassumption.
  }
  intros.
  assert (x < vl' \/ x >= vl') as [LT | LT] by lia.
  {
    rewrite substcomp_list_eq, substcomp_list_eq. 2-3: lia.
    do 2 rewrite substcomp_id_r.
    rewrite list_subst_lt, list_subst_lt. 2-3: lia.
    eapply biforall_forall with (i := x) in H. eassumption.
    lia.
  }
  {
    rewrite substcomp_list_eq, substcomp_list_eq. 2-3: lia.
    do 2 rewrite substcomp_id_r.
    rewrite list_subst_ge, list_subst_ge. 2-3: lia.
    destruct H0 as [_ [_ H0]].
    rewrite HB. apply H0. lia.
  }
  Unshelve. all: exact VNil.
Qed.

Definition Rrel (n : nat) (r1 r2 : Redex) :=
  REDCLOSED r1 /\ REDCLOSED r2 /\
  forall m (Hmn : m <= n) F1 F2, Frel m F1 F2 ->
    | F1, r1 | m ↓ -> | F2, r2 | ↓.

Definition Rrel_open (Γ : nat) (r1 r2 : Redex) :=
  forall (n : nat) (ξ₁ ξ₂ : Substitution),
  Grel n Γ ξ₁ ξ₂ -> Rrel n r1.[ξ₁]ᵣ r2.[ξ₂]ᵣ.

Theorem Rrel_downclosed :
  forall n r1 r2, Rrel n r1 r2 -> forall m, m <= n -> Rrel m r1 r2.
Proof.
  intros. destruct H as [Hcl1 [Hcl2 H]]. split. 2: split.
  1-2: auto.
  intros. eapply H. 3: exact H2. lia. eapply Frel_downclosed. eassumption.
  Unshelve. lia.
Qed.


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Export ListsOp.ZofList.
From Tweetnacl Require Export ListsOp.Forall_ZofList.
From Tweetnacl Require Import ListsOp.Zipp.

Definition Zlist_and a b := Zipp (Z.land) a b.
Definition Zlist_or a b := Zipp (Z.lor) a b.

Open Scope Z.

Lemma Zlist_and_ZofList : forall n a b,
  0 < n ->
  Forall (fun x => 0 <= x < 2^n) a ->
  Forall (fun x => 0 <= x < 2^n) b ->
  Z.land (ZofList n a) (ZofList n b) = ZofList n (Zlist_and a b).
Proof.
  intros n a b Hn; gen a b.
  induction a as [| a la IHa];
  intros [|b lb] => Ha Hb.
  reflexivity.
  simpl.
  replace (ZofList n (map (Z.land 0) lb)) with 0.
  omega.
  clear b Ha Hb.
  induction lb as [| b lb IHlb].
  reflexivity.
  simpl.
  rewrite -IHlb.
  omega.
  simpl.
  rewrite ?Z.land_0_r.
  replace (ZofList n (map (λ x : ℤ, Z.land x 0) la)) with 0.
  omega.
  clear a IHa Ha Hb.
  induction la as [| a la IHla].
  reflexivity.
  simpl.
  rewrite Z.land_0_r -IHla.
  omega.
  simpl.
  apply Forall_cons in Ha.
  apply Forall_cons in Hb.
  destruct Ha as [Ha Hla].
  destruct Hb as [Hb Hlb].
  orewrite Zxor_add.
  rewrite -IHa ; try assumption.
  orewrite Zxor_add.
  orewrite Zxor_add.
  2: apply Z_land_bound; omega.
  rewrite Z_land_dist.
  rewrite (Z.land_comm a).
  rewrite Z_land_dist.
  rewrite -(Z.land_comm a).
  rewrite (Z.land_comm (2 ^ n * ZofList n la)).
  rewrite Z_land_dist.
  replace (Z.land b (2 ^ n * ZofList n la)) with 0.
  replace (Z.land (2 ^ n * ZofList n lb) a) with 0.
  rewrite Z.lxor_0_l.
  rewrite Z.lxor_0_r.
  rewrite Z.mul_comm.
  rewrite -Z.shiftl_mul_pow2 ; try omega.
  rewrite Z.mul_comm.
  rewrite -Z.shiftl_mul_pow2 ; try omega.
  rewrite -Z.shiftl_land.
  rewrite Z.mul_comm.
  rewrite -Z.shiftl_mul_pow2 ; try omega.
  f_equal.
  rewrite Z.land_comm.
  reflexivity.
  rewrite Z.land_comm.
  rewrite Z_land_null ; omega.
  rewrite Z_land_null ; omega.
Qed.

Lemma Forall_Zlist_and: forall n a b,
  0 < n ->
  Forall (fun x => 0 <= x < 2^n) a ->
  Forall (fun x => 0 <= x < 2^n) b ->
  Forall (fun x => 0 <= x < 2^n) (Zlist_and a b).
Proof.
  intros n a b Hn ; gen a b.
  induction a as [| a la IHa] ; induction b as [|b lb IHb] => Ha Hb.
  unfold Zlist_and; simpl ; by apply Forall_nil.
  replace (Zlist_and [] (b :: lb)) with (0 :: Zlist_and [] (lb)).
  2: rewrite /Zlist_and; simpl ; flatten ; reflexivity.
  apply Forall_cons_2.
  split; try omega.
  apply Z.gt_lt.
  apply pown0.
  omega.
  apply Forall_cons in Hb; destruct Hb.
  apply IHb; try assumption.
  replace (Zlist_and (a :: la) []) with (0 :: Zlist_and la []).
  2: rewrite /Zlist_and ; simpl ; rewrite Z.land_0_r ; destruct la ; reflexivity.
  apply Forall_cons_2.
  split; try omega.
  apply Z.gt_lt.
  apply pown0.
  omega.
  apply Forall_cons in Ha; destruct Ha.
  apply IHa; try assumption.
  apply Forall_cons in Ha; destruct Ha.
  apply Forall_cons in Hb; destruct Hb.
  replace (Zlist_and (a :: la) (b :: lb)) with ((Z.land a b) :: Zlist_and la lb).
  2: rewrite /Zlist_and ; simpl ; reflexivity.
  apply Forall_cons_2.
  apply Z_land_bound ; omega.
  apply IHa; try assumption.
Qed.

Lemma Zlist_or_ZofList : forall n a b,
  0 < n ->
  Forall (fun x => 0 <= x < 2^n) a ->
  Forall (fun x => 0 <= x < 2^n) b ->
  Z.lor (ZofList n a) (ZofList n b) = ZofList n (Zlist_or a b).
Proof.
  intros n a b Hn; gen a b.
  induction a as [| a la IHa];
  intros [|b lb] => Ha Hb.
  reflexivity.
  simpl.
  replace (map (Z.lor 0) lb) with lb.
  omega.
  clear b Ha Hb.
  induction lb as [| b lb IHlb].
  reflexivity.
  simpl.
  rewrite -IHlb.
  reflexivity.
  simpl.
  rewrite ?Z.lor_0_r.
  replace (map (λ x : ℤ, Z.lor x 0) la) with la.
  omega.
  clear a IHa Ha Hb.
  induction la as [| a la IHla].
  reflexivity.
  simpl.
  rewrite Z.lor_0_r -IHla.
  reflexivity.
  simpl.
  apply Forall_cons in Ha.
  apply Forall_cons in Hb.
  destruct Ha as [Ha Hla].
  destruct Hb as [Hb Hlb].
  orewrite Zor_add.
  rewrite -IHa ; try assumption.
  orewrite Zor_add.
  orewrite Zor_add.
  2: apply Z_lor_bound; omega.
  rewrite -Z.lor_assoc.
  rewrite -Z.lor_assoc.
  f_equal.
  rewrite Z.lor_comm.
  rewrite -Z.lor_assoc.
  f_equal.
  rewrite Z.mul_comm.
  rewrite -Z.shiftl_mul_pow2 ; try omega.
  rewrite Z.mul_comm.
  rewrite -Z.shiftl_mul_pow2 ; try omega.
  rewrite Z.mul_comm.
  rewrite -Z.shiftl_mul_pow2 ; try omega.
  rewrite -Z.shiftl_lor.
  f_equal.
  rewrite Z.lor_comm.
  reflexivity.
Qed.

Close Scope Z.


(** * Combi.Erdos_Szekeres.Erdos_Szekeres : The Erdös-Szekeres theorem *)
(******************************************************************************)
(*      Copyright (C) 2014-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * The Erdös-Szekeres theorem on monotonic subsequences.

A proof of the Erdös Szekeres theorem about longest increasing and
decreasing subsequences. The theorem is [Erdos_Szekeres] and
says that any sequence [s] of length at least [n*m+1] over a totally ordered
type contains
- either a nondecreasing subsequence of length [n+1];
- or a strictly decreasing subsequence of length [m+1].
We prove it as a corollary of Greene's theorem on the Robinson-Schensted
correspondance. Note that there are other proof which require less theory.
 *****)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq fintype.
From mathcomp Require Import tuple finfun finset bigop path order.

Require Import partition tableau Schensted ordtype Greene Greene_inv.

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

Import Order.TTheory.
Open Scope N.

Section OrderedType.

Variables (disp : unit) (T : inhOrderType disp).

Lemma Greene_rel_one (s : seq T) (R : rel T) :
  exists t : seq T, subseq t s /\ sorted R t /\ size t = (Greene_rel R s) 1.
Proof using .
rewrite /Greene_rel /= /Greene_rel_t.
set P := (X in \max_(_ | X _) _).
have : #|P| > 0.
  apply/card_gt0P; exists set0.
  rewrite /P /ksupp !unfold_in /= cards0 /=.
  apply/andP; split.
  + by apply/trivIsetP => s1 s2; rewrite inE.
  + by apply/forallP => x; rewrite inE.
rewrite /P {P} => /(eq_bigmax_cond (fun x => #|cover x|)).
case=> x Hx Hmax; rewrite Hmax.
move: Hx; rewrite /ksupp unfold_in => /and3P [] Hcard _ /forallP Hall.
case Hc: #|x| => [/= | c ].
  move: Hc => /eqP; rewrite cards_eq0 => /eqP ->.
  exists [::]; repeat split; first exact: sub0seq.
  by rewrite /cover big_set0 cards0.
have {Hcard Hc} : #|x| == 1.
  move: Hcard; rewrite Hc.
  by rewrite ltnS leqn0 => /eqP ->.
move/cards1P => [] x0 Hx0; subst x.
move/(_ x0) : Hall; rewrite inE eq_refl /=.
set sol := extractpred _ _ => Hsol.
exists sol; repeat split.
+ exact: extsubsm.
+ exact: Hsol.
+ rewrite /sol size_extract.
  by rewrite /= /cover big_set1.
Qed.

Theorem Erdos_Szekeres (m n : nat) (s : seq T) :
  size s > m * n ->
  (exists t, subseq t s /\ sorted <=%O t /\ size t > m) \/
  (exists t, subseq t s /\ sorted >%O t /\ size t > n).
Proof using .
move=> Hsize; pose tab := RS s.
have {Hsize} : (n < size (shape tab)) \/ (m < head 0 (shape tab)).
  have Hpart := is_part_sht (is_tableau_RS s).
  apply/orP; move: Hsize; rewrite -(size_RS s) /size_tab.
  apply contraLR; rewrite negb_or -!leqNgt => /andP [] Hn Hm.
  by apply (leq_trans (part_sumn_rectangle Hpart)); apply: leq_mul.
move=> [] Hltn.
- right => {m}.
  have := Greene_col_RS 1 s.
  rewrite -sum_conj.
  rewrite (_ : \sum_(l <- shape (RS s)) minn l 1 = size (shape (RS s))); first last.
    have := is_part_sht (is_tableau_RS s).
    move: (shape _) => sh.
    elim: sh => [//= | s0 sh IHsh]; first by rewrite big_nil.
    move=> Hpart; have /= Hs0 := part_head_non0 Hpart.
    move: Hpart => /= /andP [] Hhead Hpart.
    rewrite big_cons (IHsh Hpart).
    rewrite (_ : minn s0 1 = 1) ?add1n //.
    by rewrite /minn; move: Hs0; case s0.
  move=> Hgr; move: Hltn; rewrite -Hgr {tab Hgr}.
  case: (Greene_rel_one s >%O) => x [] Hsubs [] Hsort <- Hn.
  by exists x.
- left => {n}.
  have := Greene_row_RS 1 s.
  rewrite (_ : sumn (take 1 (shape (RS s))) = head 0 (shape (RS s))); first last.
    by case: (shape (RS s)) => [| s0 l] //=; rewrite take0 addn0.
  rewrite /Greene_row => Hgr; move: Hltn; rewrite -Hgr {tab Hgr}.
  case: (Greene_rel_one s <=%O) => x [] Hsubs [] Hsort <- Hn.
  by exists x.
Qed.

End OrderedType.


Require Import Coq.Lists.List Bedrock.EqdepClass.
Require Export Coq.Classes.EquivDec.
Require Import Bedrock.Decidables.

Set Implicit Arguments.
Set Strict Implicit.

Section fin.
  Variable A : Type.

  Inductive fin : list A -> Type :=
  | FO : forall x ls, fin (x :: ls)
  | FS : forall x ls, fin ls -> fin (x :: ls).

  Fixpoint lift (ls : list A) e : fin ls -> fin (e ++ ls) :=
    match e as e return fin ls -> fin (e ++ ls) with
      | nil => fun x => x
      | a :: b => fun x => FS a (@lift ls b x)
    end.

  Definition finOut ls (f : fin ls) : match ls return fin ls -> Type with
                                        | nil => fun _ => Empty_set
                                        | _ => fun f => {f' : _ & f = FS _ f'} + {f = FO _ _}
                                      end f :=
  match f with
    | FO _ _ => inright _ (refl_equal _)
    | FS _ _ f' => inleft _ (existT _ f' (refl_equal _))
  end.

  Definition finIfz t (ls : list A) (d : fin (t :: ls))
    : forall (R : fin (t :: ls) -> Type) (h : R (@FO _ _)) (n : forall c, R (@FS _ _ c)),
    R d :=
    match d as d' in fin ls' return match ls' return fin ls' -> Type with
                                | nil => fun _ => Empty_set
                                | a :: b => fun d =>
                                  forall (R : fin (a :: b) -> Type) (h : R (@FO _ _)) (n : forall c, R (@FS _ _ c)), R d
                              end d'
      with
      | FO _ _ => fun _ h _ => h
      | FS _ _ x => fun _ _ f => f x
    end.

  Definition finArg ls (f : fin ls) : option (fin (tl ls)) :=
    match f with
      | FO _ _ => None
      | FS _ _ f' => Some f'
    end.

  Lemma fin_inj : forall z ls (x y : fin ls),
    x <> y
    -> FS z x <> FS z y.
    red; intros.
    assert (finArg (FS z x) = finArg (FS z y)) by congruence.
    simpl in *; congruence.
  Qed.

  Hint Immediate fin_inj.

  Definition finEq : forall ls (x y : fin ls), {x = y} + {x <> y}.
    refine (fix finEq ls : forall x y : fin ls, {x = y} + {x <> y} :=
      match ls return forall x y : fin ls, {x = y} + {x <> y} with
        | nil => fun x _ => match finOut x with end
        | _ :: _ => fun x y => match finOut x, finOut y with
                                 | inleft (existT x' _), inleft (existT y' _) => if finEq _ x' y' then left _ _ else right _ _
                                 | inright _, inright _ => left _ _
                                 | _, _ => right _ _
                               end
      end); clear finEq; (cbv beta in *; subst; auto; try congruence;
        match goal with
          | [ H : sigT _ |- _ ] => destruct H
        end; subst; discriminate).
  Defined.

  Global Instance EquivDec_fin ls : EqDec (fin ls) (@eq _) :=
  { equiv_dec := @finEq ls }.

  Definition dcomp_option T (a b : T) (d : dcomp a b) : option (a = b) :=
    match d with
      | Eq pf => Some pf
      | _ => None
    end.

  Global Instance Comparable_fin ls : Comparable (fin ls).
  constructor.
  refine ((fix finCmp ls (x : fin ls) : forall y : fin ls, dcomp x y :=
    match x in fin ls return forall y : fin ls, dcomp x y with
      | FO a b => fun y : fin (a :: b) =>
        @finIfz _ _ y (dcomp (FO a b)) (Eq (refl_equal _)) (fun _ => Lt _ _)
      | FS a ls r => fun y : fin (a :: ls) =>
        @finIfz _ _ y (dcomp (FS a r)) (Gt _ _)
          (fun r' => match finCmp _ r r' with
                       | Eq pf => Eq (match pf in _ = t return FS a r = FS a t with
                                        | refl_equal => refl_equal _
                                      end)

                       | Gt => Gt _ _
                       | Lt => Lt _ _
                     end)
    end) ls).
  Defined.

  Fixpoint get (ls : list A) : fin ls -> A :=
    match ls return fin ls -> A with
      | nil => fun f => match f in fin N return match N with
                                                  | nil => A
                                                  | _ => unit
                                                end with
                          | FO _ _ => tt
                          | FS _ _ _ => tt
                        end
      | x :: ls' => fun f => match f in fin N return match N with
                                                       | nil => Empty_set
                                                       | _ :: ls' => (fin ls' -> A) -> A
                                                     end with
                               | FO _ _ => fun _ => x
                               | FS _ _ f' => fun get_ls' => get_ls' f'
                             end (@get ls')
    end.

  Fixpoint liftD (ls : list A) e : forall i : fin ls, { x : fin (e ++ ls) & get x = get i } :=
    match e as e return forall i : fin ls, { x : fin (e ++ ls) & get x = get i } with
      | nil => fun x => existT _ x (refl_equal _)
      | a :: b => fun x =>
        match @liftD ls b x with
          | existT x pf =>
            existT _ (FS a x) (match pf in _ = t
                                 return get (FS a x) = t with
                                 | refl_equal => refl_equal _
                               end)
        end
    end.

  Fixpoint pf_list_simpl A b c (a : list A) : (a ++ b :: nil) ++ c = a ++ b :: c :=
    match a as a return (a ++ b :: nil) ++ c = a ++ b :: c with
      | nil => refl_equal (nil ++ b :: nil ++ c)
      | a' :: b' => match eq_sym (@pf_list_simpl A b c b') in _ = t return a' :: t = a' :: b' ++ b :: c
                      with
                      | refl_equal => refl_equal _
                    end
    end.

  Fixpoint fin_remove (U : Type) ls t ls' : forall (f : fin (ls ++ t :: ls')),
    (t = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U :=
    match ls as ls
      return forall f : fin (ls ++ t :: ls'), (t = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U
      with
      | nil => fun (f : fin (t :: ls')) =>
        match f in fin z
          return match z with
                   | nil => unit
                   | a :: b => (a = get f -> U) -> (forall f' : fin b, get f' = get f -> U) -> U
                 end
          with
          | FO _ _ => fun D _ => D refl_equal
          | FS _ _ f => fun _ F => F _ refl_equal
        end
      | a :: b => fun (f : fin (a :: b ++ t :: ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove _ _ _ _ (projT1 s)
              (match eq_sym (projT2 s) in _ = t' return (t = get t' -> U) -> (t = get (projT1 s)) -> U with
                 | refl_equal => fun x => x
               end D)
              (fun x' pf => F (FS _ x')
                match eq_sym (projT2 s) in _ = t return get (FS a x') = get t with
                  | refl_equal => pf
                end)
          | inright l => F (FO _ _) match eq_sym l in _ = t return get (FO _ _) = get t with
                                      | refl_equal => refl_equal
                                    end
        end
    end.

  Fixpoint fin_remove_range' (U : Type) ls'' ls' : forall (f : fin (ls'' ++ ls')),
    (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls'), get f' = get f -> U) -> U :=
    match ls'' as ls''
      return forall f : fin (ls'' ++ ls'), (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin ls', get f' = get f -> U) -> U
      with
      | nil => fun (f : fin ls') => fun _ z => z f refl_equal
      | a :: b => fun (f : fin (a :: b ++  ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove_range' _ b ls' (projT1 s)
              (fun x' pf => D (FS _ x') match eq_sym (projT2 s) in _ = t return get (FS a x') = get t with
                                          | refl_equal => pf
                                        end)
              (fun x' pf => F x' match eq_sym (projT2 s) in _ = t return get x' = get t with
                                   | refl_equal => pf
                                 end)
          | inright l => D (FO _ _) match eq_sym l in _ = t return get (FO a b) = get t with
                                      | refl_equal => refl_equal
                                    end
        end
    end.

  Fixpoint fin_remove_range (U : Type) ls ls'' ls' : forall (f : fin (ls ++ ls'' ++ ls')),
    (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U :=
    match ls as ls
      return forall f : fin (ls ++ ls'' ++ ls'), (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U
      with
      | nil => fun (f : fin (ls'' ++ ls')) => @fin_remove_range' U ls'' ls' f
      | a :: b => fun (f : fin (a :: b ++ ls'' ++  ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove_range _ _ _ _ (projT1 s)
              (fun x' pf => D x' match eq_sym (projT2 s) in _ = t return get x' = get t with
                                   | refl_equal => pf
                                 end)
              (fun x' pf => F (FS _ x') match eq_sym (projT2 s) in _ = t return get (FS _ x') = get t with
                                          | refl_equal => pf
                                        end)
          | inright l => F (FO _ _)
              match eq_sym l in _ = t return get (FO _ _) = get t with
                | refl_equal => refl_equal
              end
        end
    end.

  Fixpoint liftDmid (ls ls' : list A) e : forall (i : fin (ls' ++ ls)),
    { x : fin (ls' ++ e ++ ls) & get x = get i }.
  refine (
    match ls' as ls' return forall (i : fin (ls' ++ ls)),
      { x : fin (ls' ++ e ++ ls) & get x = get i } with
      | nil => fun i => liftD e i
      | a :: b => fun i : fin (a :: b ++ ls) =>
        match finOut i with
          | inleft (existT r pf) =>
            match liftDmid ls b e r with
              | existT rr pf' =>
                @existT _ _ (FS a rr) _
            end
          | inright pf => @existT _ _ (FO _ _) _
        end
    end).
  rewrite pf; simpl; assumption.
  rewrite pf; reflexivity.
  Defined.

  Fixpoint liftDend (ls : list A) e (i : fin ls) :
    { x : fin (ls ++ e) & get x = get i } :=
    match i as i in fin ls return { x : fin (ls ++ e) & get x = get i } with
      | FO _ _ => existT _ (FO _ _) refl_equal
      | FS _ _ f =>
        match liftDend e f with
         | existT _ e => existT _ (FS _ _) e
        end
    end.

  Section liftD_Proofs.
    Variable EQ : EqDec A (@eq A).

    Lemma liftD_liftD_app : forall (a z y : list A) x0,
      projT1 (liftD y (projT1 (liftD a x0))) =
      match app_assoc_reverse y a z in (_ = t) return (fin t) with
        | eq_refl => projT1 (liftD (y ++ a) x0)
      end.
    Proof.
      induction y; simpl in *; uip_all.
        simpl in *. uip_all. reflexivity.
        simpl in *. case_eq (liftD y (projT1 (liftD a x0))).
        simpl. intros. assert (projT1 (liftD y (projT1 (liftD a x0))) = x).
        rewrite H; auto.
        rewrite IHy in H0. subst.
        destruct (liftD (y ++ a) x0). simpl. uip_all.
        generalize e e2. rewrite <- e2. uip_all. reflexivity.
    Qed.

    Lemma liftDmid_lift_nil : forall (a b : list A) x0,
      projT1 (liftDmid a b nil x0) = x0.
    Proof.
      induction b; simpl; intros; auto.
      destruct (finOut x0). destruct s. subst.
      specialize (IHb x). destruct (liftDmid a b nil x). simpl in *. subst; auto.

      subst. simpl. reflexivity.
    Qed.

    Lemma liftDmid_liftDmid_app : forall x y z a x0,
      projT1 (liftDmid (a ++ z) x y (projT1 (liftDmid z x a x0)))
      = match app_ass _ _ _ in _ = t return fin (_ ++ t) with
          | refl_equal => projT1 (liftDmid z x (y ++ a) x0)
        end.
    Proof.
      induction x.
        simpl; intros; apply liftD_liftD_app.
        intros. simpl in x0. destruct (finOut x0).

        destruct s. specialize (IHx y z a0 x1). subst. simpl in *.
        destruct (liftDmid z x a0 x1); simpl in *. destruct (liftDmid (a0 ++ z) x y x0); simpl in *.
        subst. destruct (liftDmid z x (y ++ a0) x1). simpl. uip_all. generalize e2 x2. rewrite e2.
        intros. rewrite (UIP_refl e3). reflexivity.

        subst; simpl. uip_all. generalize e. rewrite e. uip_all. reflexivity.
    Qed.
  End liftD_Proofs.

  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall x ls, B x -> hlist ls -> hlist (x :: ls).

  Definition hlist_hd (T : A) (ls : list A) (v : hlist (T :: ls)) : B T :=
    match v in hlist ls return match ls with
                                 | nil => unit
                                 | a :: _ => B a
                               end with
      | HNil => tt
      | HCons _ _ x _ => x
    end.

  Definition hlist_tl (T : A) (ls : list A) (v : hlist (T :: ls)) : hlist ls :=
    match v in hlist ls return match ls with
                                 | nil => unit
                                 | _ :: ls => hlist ls
                               end with
      | HNil => tt
      | HCons _ _ _ x => x
    end.

  Fixpoint hlist_app ll lr : hlist ll -> hlist lr -> hlist (ll ++ lr) :=
    match ll with
      | nil => fun _ x => x
      | _ :: _ => fun l r => HCons (hlist_hd l) (hlist_app (hlist_tl l) r)
    end.

  Fixpoint hlist_All ls (P : forall t, B t -> Prop) (h : hlist ls) {struct h} : Prop :=
    match h with
      | HNil => True
      | HCons _ _ a b => P _ a /\ hlist_All P b
    end.

  Variable dec : forall x (y z : B x), option (y = z).

  Definition hlistEq : forall x (y z : hlist x), option (y = z).
    refine (fix hlistEq x (y : hlist x) : forall z : hlist x, option (y = z) :=
      match y in hlist x return forall z : hlist x, option (y = z) with
        | HNil => fun z => match z in hlist x return match x return hlist x -> Type with
                                                       | nil => fun z => option (HNil = z)
                                                       | _ => fun _ => unit
                                                     end z with
                             | HNil => Some _
                             | _ => tt
                           end
        | HCons _ _ v1 y' => fun z => match z in hlist x return match x return hlist x -> Type with
                                                                  | nil => fun _ => unit
                                                                  | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                                                    (forall v2, option (v1 = v2))
                                                                    -> (forall z', option (y' = z'))
                                                                    -> option (HCons v1 y' = z)
                                                                end z with
                                        | HNil => tt
                                        | HCons _ _ v2 z' => fun v1 _ dec' self => if dec' v2 then if self z' then Some _ else None else None
                                      end v1 y' (dec v1) (hlistEq _ y')
      end); clear hlistEq; abstract congruence.
  Defined.

  Variable cmp : forall x (y z : B x), dcomp y z.
  Definition hlistCmp : forall x (y z : hlist x), dcomp y z.
    refine (fix hlistCmp x (y : hlist x) : forall z : hlist x, dcomp y z :=
      match y in hlist x return forall z : hlist x, dcomp y z with
        | HNil => fun z => match z in hlist x return match x return hlist x -> Type with
                                                       | nil => fun z => dcomp HNil z
                                                       | _ => fun _ => unit
                                                     end z with
                             | HNil => Eq _
                             | _ => tt
                           end
        | HCons _ _ v1 y' => fun z => match z in hlist x return match x return hlist x -> Type with
                                                                  | nil => fun _ => unit
                                                                  | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                                                    (forall v2, dcomp v1 v2)
                                                                    -> (forall z', dcomp y' z')
                                                                    -> dcomp (HCons v1 y') z
                                                                end z with
                                        | HNil => tt
                                        | HCons _ _ v2 z' => fun v1 _ cmp' self =>
                                          match cmp' v2 with
                                            | Eq _ =>
                                              match self z' with
                                                | Gt => Gt _ _
                                                | Lt => Lt _ _
                                                | Eq _ => Eq _
                                              end
                                            | Gt => Gt _ _
                                            | Lt => Lt _ _
                                          end
                                      end v1 y' (cmp v1) (hlistCmp _ y')
      end); clear hlistCmp; abstract congruence.
  Defined.

  Variable ocmp : forall x (y z : B x), option (dcomp y z).
  Fixpoint hlistOCmp x (y : hlist x) : forall (z : hlist x), option (dcomp y z).
    refine (
      match y as y in hlist x return forall z : hlist x, option (dcomp y z) with
        | HNil => fun z =>
          match z in hlist x return match x return hlist x -> Type with
                                      | nil => fun z => option (dcomp HNil z)
                                      | _ => fun _ => unit
                                    end z with
            | HNil => Some (Eq _)
            | _ => tt
          end
        | HCons _ _ v1 y' => fun z =>
          match z in hlist x return match x return hlist x -> Type with
                                      | nil => fun _ => unit
                                      | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                        (forall v2, option (dcomp v1 v2))
                                        -> (forall z', option (dcomp y' z'))
                                        -> option (dcomp (HCons v1 y') z)
                                    end z with
            | HNil => tt
            | HCons _ _ v2 z' => fun v1 _ cmp' self =>
              match cmp' v2 with
                | None =>
                  match self z' with
                    | None => None
                    | Some Gt => Some (Gt _ _)
                    | Some Lt => Some (Lt _ _)
                    | Some (Eq _) => None
                  end
                | Some (Eq _) =>
                  match self z' with
                    | None => None
                    | Some Gt => Some (Gt _ _)
                    | Some Lt => Some (Lt _ _)
                    | Some (Eq _) => Some (Eq _)
                  end
                | Some Gt => Some (Gt _ _)
                | Some Lt => Some (Lt _ _)
              end
          end v1 y' (ocmp v1) (hlistOCmp _ y')
      end); clear hlistOCmp; abstract congruence.
  Defined.

  Fixpoint hlist_get (ls : list A) (i : fin ls) : hlist ls -> B (get i) :=
    match i in fin ls return hlist ls -> B (get i) with
      | FO _ _ => fun hl => hlist_hd hl
      | FS _ _ f' => fun hl => hlist_get f' (hlist_tl hl)
    end.

  Section hlist_Proofs.
    Variable EQ : EqDec A (@eq A).
    Lemma hlist_nil_only : forall (h : hlist nil),
      h = HNil.
    Proof.
      intros.
      change h with (match refl_equal in _ = t return hlist t with
                       | refl_equal => h
                     end).
      generalize (refl_equal (@nil A)). generalize h.
      assert (forall k (h : hlist k) (e : k = nil),
        match e in (_ = t) return (hlist t) with
          | eq_refl => h
        end = HNil).
      destruct h0.
      uip_all. reflexivity.
      congruence.
      eauto.
    Qed.

    Lemma hlist_eta : forall a b (h : hlist (a :: b)),
      h = HCons (hlist_hd h) (hlist_tl h).
    Proof.
      intros.
      assert (forall k (h : hlist k) (e : k = a :: b),
        match e in (_ = t) return (hlist t) with
          | eq_refl => h
        end = HCons (hlist_hd match e in _ = t return hlist t with
                                | eq_refl => h
                              end)
        (hlist_tl match e in _ = t return  hlist t with
                    | eq_refl => h
                  end)).
      destruct h0. congruence.
      intros. inversion e. subst.
      generalize e. uip_all. reflexivity.

      specialize (H _ h (refl_equal _)). assumption.
    Qed.

    Theorem hlist_get_lift : forall ls ls' ls'' (f : fin (ls ++ ls'')) G G' G'',
      hlist_get f (hlist_app G G'') =
      match liftDmid ls'' ls ls' f with
        | existT f' pf =>
          match pf in _ = t return B t with
            | refl_equal =>
              hlist_get f' (hlist_app G (hlist_app G' G''))
          end
      end.
    Proof.
      induction ls. simpl. intros. unfold liftDmid; simpl.
        Focus.
        generalize dependent ls'. induction ls'; simpl; auto.
          intros. specialize (IHls' (hlist_tl G')). rewrite IHls'. destruct (liftD ls' f).
          simpl. generalize (hlist_get x (hlist_app (hlist_tl G') G'')). generalize e. rewrite e.
          intros. rewrite (UIP_refl e0). reflexivity.

        intros. simpl in f. destruct (finOut f). destruct s; subst. simpl.
        specialize (@IHls ls' _ x (hlist_tl G) G' G''). rewrite IHls. clear IHls.
        destruct (liftDmid ls'' ls ls' x). reflexivity.
        subst. reflexivity.
    Qed.

    Theorem hlist_get_lift_end : forall ls' G' ls (f : fin ls) G,
      hlist_get f G =
      match liftDend ls' f with
        | existT f' pf =>
          match pf in _ = t return B t with
            | refl_equal =>
              hlist_get f' (hlist_app G G')
          end
      end.
    Proof.
      clear dec cmp ocmp.
      induction f; simpl; auto.
      destruct f; simpl in *. auto.
      intros. rewrite IHf. clear IHf. destruct (liftDend ls' f).
      generalize e. rewrite <- e. uip_all. auto.
    Qed.

    Lemma hlist_get_remove_range' : forall U a b (A : hlist a) (B' : hlist b) x P
      (D : forall x' : fin a, get x' = get x -> U) F,
      (forall x' (pf : get x' = get x),
        hlist_get x (hlist_app A B') =
          match pf in _ = z return B z with
            | refl_equal => hlist_get x' A
          end ->
        P (D x' pf)) ->
      (forall x' pf,
        hlist_get x (hlist_app A B') =
          match pf in _ = t return B t with
            | refl_equal => hlist_get x' B'
          end ->
        P (F x' pf)) ->
      P (@fin_remove_range' U a b x D F).
    Proof.
      clear dec cmp ocmp.
      induction a; simpl; intros; eauto.
      destruct (finOut x) as [ [ ? ? ] | ? ]; subst; simpl; eauto.
      eapply IHa; eauto.
    Qed.

    Theorem hlist_get_remove_range : forall U a b c (A : hlist a) (B' : hlist b) (C : hlist c) x P (D : forall x' : fin b, get x' = get x -> U) F,
      (forall x' (pf : get x' = get x),
        hlist_get x (hlist_app A (hlist_app B' C)) =
          match pf in _ = z return B z with
            | refl_equal => hlist_get x' B'
          end ->
        P (D x' pf)) ->
      (forall x' pf,
        hlist_get x (hlist_app A (hlist_app B' C)) =
          match pf in _ = t return B t with
            | refl_equal => hlist_get x' (hlist_app A C)
          end ->
        P (F x' pf)) ->
      P (@fin_remove_range U a b c x D F).
    Proof.
      clear dec cmp ocmp.
      induction a; simpl; intros.
      eapply hlist_get_remove_range'; eauto.
      destruct (finOut x); subst; simpl.
        destruct s; subst; simpl. eapply IHa; eauto.
        eapply X0. auto.
    Qed.

  End hlist_Proofs.

  Fixpoint absAll (ls : list A) :
    (hlist ls -> Type) -> Type :=
    match ls return (hlist ls -> Type) -> Type with
      | nil => fun R => R (HNil)
      | a :: b => fun R =>
        forall x : B a, absAll (fun y => R (HCons x y))
    end.

  Fixpoint hlistDestruct (ls : list A) (args : hlist ls) {struct args}
    : forall K : hlist ls -> Type, absAll K -> K args :=
      match
        args as args0 in hlist ls0
          return (forall K : hlist ls0 -> Type, absAll K -> K args0)
        with
        | HNil =>
          fun (K : hlist nil -> Type) (cc : absAll K) => cc
        | HCons x0 ls0 x args =>
          fun (K : hlist (x0 :: ls0) -> Type) (cc : absAll K) =>
            hlistDestruct args
            (fun y : hlist ls0 => K (HCons x y))
            (cc x)
      end.

  Variable a : A.
  Variable b : B a.
  Fixpoint hlistIn (ls : list A) : hlist ls -> Prop :=
    match ls as ls return hlist ls -> Prop with
      | nil => fun _ => False
      | hd :: tl => fun hl =>
        (exists pf : a = hd, hlist_hd hl = match pf in _ = t return B t with
                                             | refl_equal => b
                                           end)
        \/ hlistIn (hlist_tl hl)
    end.

End fin.

Implicit Arguments FO [A x ls].
Implicit Arguments FS [A x ls].
Implicit Arguments finIfz [A t ls].

Implicit Arguments get [A].
Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].

Section hlist_map.
  Variable A : Type.
  Variable F : A -> Type.
  Variable G : A -> Type.
  Variable ff : forall x, F x -> G x.

  Fixpoint hlist_map (ls : list A) (hl : hlist F ls) {struct hl} : hlist G ls :=
    match hl in @hlist _ _ ls return hlist G ls with
      | HNil => HNil
      | HCons _ _ hd tl =>
        HCons (ff hd) (hlist_map tl)
    end.
End hlist_map.

Section hlist_fold2.
  Variables T U V : Type.
  Variables F G : T -> Type.
  Variable f : U -> forall t : T, F t -> G t -> U.

  Fixpoint hlist_fold2 ls (l : hlist F ls) {struct l} : hlist G ls -> U -> U :=
    match l in hlist _ ls
      return hlist G ls -> U -> U
      with
      | HNil => fun _ acc => acc
      | HCons _ _ fr hr => fun r acc =>
        hlist_fold2 hr (hlist_tl r) (f acc fr (hlist_hd r))
    end.
End hlist_fold2.

Export Decidables.


Welcome to Coq 8.4pl4 (November 2015)

Coq < Definition negb (b:bool) : bool := match b with | true => false | false => true end.
negb is defined

Coq < Theorem negb_involutive : forall b : bool, negb (negb b) = b.
1 subgoal

  ============================
   forall b : bool, negb (negb b) = b

negb_involutive < Proof.
1 subgoal

  ============================
   forall b : bool, negb (negb b) = b

negb_involutive < info_auto.
(* info auto : *)
idtac.
1 subgoal

  ============================
   forall b : bool, negb (negb b) = b

negb_involutive < intros b.
1 subgoal

  b : bool
  ============================
   negb (negb b) = b

negb_involutive < destruct b.
2 subgoals

  ============================
   negb (negb true) = true

subgoal 2 is:
 negb (negb false) = false

negb_involutive < reflexivity.
1 subgoal

  ============================
   negb (negb false) = false

negb_involutive < reflexivity.
No more subgoals.

negb_involutive < Qed.
info_auto.
intros b.
destruct b.
 reflexivity.

 reflexivity.

negb_involutive is defined

Coq < ^C
User interrupt.

Coq < ^C
User interrupt.

Coq <


Require Export Coq.Bool.Bool Coq.Classes.EquivDec.

Ltac inv H := inversion H; subst; clear H.

Ltac eqdec a b :=
  destruct (equiv_dec a b) as [? | ?];
  unfold equiv, complement in *; subst;
  try contradiction; simpl.

Ltac dispatch_eqdec :=
  match goal with
  | |- context [equiv_dec ?a ?b]
    => eqdec a b
  | H: context [equiv_dec ?a ?b] |- _
    => eqdec a b; simpl in *
  end.

Lemma contrapositive : forall P Q : Prop,
    (P -> Q) -> ~ Q -> ~ P.
Proof.
  intuition.
Qed.

Lemma nexists_forall_not : forall {A : Type} (P : A -> Prop),
    ~ (exists x, P x) -> forall x, ~ P x.
Proof.
  eauto.
Qed.

Section Curry.
  Context {A B C : Type}.

  Definition curry (f : A * B -> C) (a : A) (b : B) : C := f (a,b).

  Definition uncurry (f : A -> B -> C) '((a,b) : A * B) : C := f a b.

  Local Hint Unfold curry : core.
  Local Hint Unfold uncurry : core.

  Lemma curry_uncurry : forall f ab,
      uncurry (curry f) ab = f ab.
  Proof.
      intros f [a b]; reflexivity.
  Qed.

  Lemma uncurry_curry : forall f a b,
      curry (uncurry f) a b = f a b.
  Proof.
    reflexivity.
  Qed.
End Curry.

Definition reflects
           {A B : Type} (R : A -> B -> Prop) (f: A -> B -> bool) :=
  forall a b, reflect (R a b) (f a b).

Lemma Acc_inj : forall {A B : Type} (f : A -> B) (R : B -> B -> Prop) (a : A),
    Acc R (f a) -> Acc (fun a a' => R (f a) (f a')) a.
Proof.
  intros A B f R a HR.
  remember (f a) as fa eqn:Heqfa.
  generalize dependent a.
  induction HR; intros a ?; subst.
  constructor. firstorder.
Qed.

Lemma well_founded_inj : forall {A B : Type} (f : A -> B) (R : B -> B -> Prop),
    well_founded R ->
    well_founded (fun a a' => R (f a) (f a')).
Proof.
  unfold well_founded. intros A B f R.
  intros HR a. eauto using Acc_inj.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export NumPrelude NZAxioms.
Require Import NZBase NZOrder NZAddOrder Plus Minus.

(** In this file, we investigate the shape of domains satisfying
    the [NZDomainSig] interface. In particular, we define a
    translation from Peano numbers [nat] into NZ.
*)

Local Notation "f ^ n" := (fun x => nat_rect _ x (fun _ => f) n).

Instance nat_rect_wd n {A} (R:relation A) :
 Proper (R==>(R==>R)==>R) (fun x f => nat_rect (fun _ => _) x (fun _ => f) n).
Proof.
intros x y eq_xy f g eq_fg; induction n; [assumption | now apply eq_fg].
Qed.

Module NZDomainProp (Import NZ:NZDomainSig').
Include NZBaseProp NZ.

(** * Relationship between points thanks to [succ] and [pred]. *)

(** For any two points, one is an iterated successor of the other. *)

Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n.
Proof.
revert n.
apply central_induction with (z:=m).
 { intros x y eq_xy; apply ex_iff_morphism.
  intros n; apply or_iff_morphism.
 + split; intros; etransitivity; try eassumption; now symmetry.
 + split; intros; (etransitivity; [eassumption|]); [|symmetry];
    (eapply nat_rect_wd; [eassumption|apply succ_wd]).
 }
exists 0%nat. now left.
intros n. split; intros [k [L|R]].
exists (Datatypes.S k). left. now apply succ_wd.
destruct k as [|k].
simpl in R. exists 1%nat. left. now apply succ_wd.
rewrite nat_rect_succ_r in R. exists k. now right.
destruct k as [|k]; simpl in L.
exists 1%nat. now right.
apply succ_inj in L. exists k. now left.
exists (Datatypes.S k). right. now rewrite nat_rect_succ_r.
Qed.

(** Generalized version of [pred_succ] when iterating *)

Lemma succ_swap_pred : forall k n m, n == (S^k) m -> m == (P^k) n.
Proof.
induction k.
simpl; auto with *.
simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto.
rewrite <- nat_rect_succ_r in H; auto.
Qed.

(** From a given point, all others are iterated successors
    or iterated predecessors. *)

Lemma itersucc_or_iterpred : forall n m, exists k, n == (S^k) m \/ n == (P^k) m.
Proof.
intros n m. destruct (itersucc_or_itersucc n m) as (k,[H|H]).
exists k; left; auto.
exists k; right. apply succ_swap_pred; auto.
Qed.

(** In particular, all points are either iterated successors of [0]
    or iterated predecessors of [0] (or both). *)

Lemma itersucc0_or_iterpred0 :
 forall n, exists p:nat, n == (S^p) 0 \/ n == (P^p) 0.
Proof.
 intros n. exact (itersucc_or_iterpred n 0).
Qed.

(** * Study of initial point w.r.t. [succ] (if any). *)

Definition initial n := forall m, n ~= S m.

Lemma initial_alt : forall n, initial n <-> S (P n) ~= n.
Proof.
split. intros Bn EQ. symmetry in EQ. destruct (Bn _ EQ).
intros NEQ m EQ. apply NEQ. rewrite EQ, pred_succ; auto with *.
Qed.

Lemma initial_alt2 : forall n, initial n <-> ~exists m, n == S m.
Proof. firstorder. Qed.

(** First case: let's assume such an initial point exists
    (i.e. [S] isn't surjective)... *)

Section InitialExists.
Hypothesis init : t.
Hypothesis Initial : initial init.

(** ... then we have unicity of this initial point. *)

Lemma initial_unique : forall m, initial m -> m == init.
Proof.
intros m Im. destruct (itersucc_or_itersucc init m) as (p,[H|H]).
destruct p. now simpl in *. destruct (Initial _ H).
destruct p. now simpl in *. destruct (Im _ H).
Qed.

(** ... then all other points are descendant of it. *)

Lemma initial_ancestor : forall m, exists p, m == (S^p) init.
Proof.
intros m. destruct (itersucc_or_itersucc init m) as (p,[H|H]).
destruct p; simpl in *; auto. exists O; auto with *. destruct (Initial _ H).
exists p; auto.
Qed.

(** NB : We would like to have [pred n == n] for the initial element,
    but nothing forces that. For instance we can have -3 as initial point,
    and P(-3) = 2. A bit odd indeed, but legal according to [NZDomainSig].
    We can hence have [n == (P^k) m] without [exists k', m == (S^k') n].
*)

(** We need decidability of [eq] (or classical reasoning) for this: *)

Section SuccPred.
Hypothesis eq_decidable : forall n m, n==m \/ n~=m.
Lemma succ_pred_approx : forall n, ~initial n -> S (P n) == n.
Proof.
intros n NB. rewrite initial_alt in NB.
destruct (eq_decidable (S (P n)) n); auto.
elim NB; auto.
Qed.
End SuccPred.
End InitialExists.

(** Second case : let's suppose now [S] surjective, i.e. no initial point. *)

Section InitialDontExists.

Hypothesis succ_onto : forall n, exists m, n == S m.

Lemma succ_onto_gives_succ_pred : forall n, S (P n) == n.
Proof.
intros n. destruct (succ_onto n) as (m,H). rewrite H, pred_succ; auto with *.
Qed.

Lemma succ_onto_pred_injective : forall n m, P n == P m -> n == m.
Proof.
intros n m. intros H; apply succ_wd in H.
rewrite !succ_onto_gives_succ_pred in H; auto.
Qed.

End InitialDontExists.

(** To summarize:

  S is always injective, P is always surjective  (thanks to [pred_succ]).

  I) If S is not surjective, we have an initial point, which is unique.
     This bottom is below zero: we have N shifted (or not) to the left.
     P cannot be injective: P init = P (S (P init)).
     (P init) can be arbitrary.

  II) If S is surjective, we have [forall n, S (P n) = n], S and P are
     bijective and reciprocal.

     IIa) if [exists k<>O, 0 == S^k 0], then we have a cyclic structure Z/nZ
     IIb) otherwise, we have Z
*)

(** * An alternative induction principle using [S] and [P]. *)

(** It is weaker than [bi_induction]. For instance it cannot prove that
    we can go from one point by many [S] _or_ many [P], but only by many
    [S] mixed with many [P]. Think of a model with two copies of N:

    0,  1=S 0,   2=S 1, ...
    0', 1'=S 0', 2'=S 1', ...

    and P 0 = 0' and P 0' = 0.
*)

Lemma bi_induction_pred :
  forall A : t -> Prop, Proper (eq==>iff) A ->
    A 0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) ->
    forall n, A n.
Proof.
intros. apply bi_induction; auto.
clear n. intros n; split; auto.
intros G; apply H2 in G. rewrite pred_succ in G; auto.
Qed.

Lemma central_induction_pred :
  forall A : t -> Prop, Proper (eq==>iff) A -> forall n0,
    A n0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) ->
    forall n, A n.
Proof.
intros.
assert (A 0).
destruct (itersucc_or_iterpred 0 n0) as (k,[Hk|Hk]); rewrite Hk; clear Hk.
 clear H2. induction k; simpl in *; auto.
 clear H1. induction k; simpl in *; auto.
apply bi_induction_pred; auto.
Qed.

End NZDomainProp.

(** We now focus on the translation from [nat] into [NZ].
    First, relationship with [0], [succ], [pred].
*)

Module NZOfNat (Import NZ:NZDomainSig').

Definition ofnat (n : nat) : t := (S^n) 0.
Notation "[ n ]" := (ofnat n) (at level 7) : ofnat.
Local Open Scope ofnat.

Lemma ofnat_zero : [O] == 0.
Proof.
reflexivity.
Qed.

Lemma ofnat_succ : forall n, [Datatypes.S n] == succ [n].
Proof.
 now unfold ofnat.
Qed.

Lemma ofnat_pred : forall n, n<>O -> [Peano.pred n] == P [n].
Proof.
 unfold ofnat. destruct n. destruct 1; auto.
 intros _. simpl. symmetry. apply pred_succ.
Qed.

(** Since [P 0] can be anything in NZ (either [-1], [0], or even other
    numbers, we cannot state previous lemma for [n=O]. *)

End NZOfNat.

(** If we require in addition a strict order on NZ, we can prove that
    [ofnat] is injective, and hence that NZ is infinite
    (i.e. we ban Z/nZ models) *)

Module NZOfNatOrd (Import NZ:NZOrdSig').
Include NZOfNat NZ.
Include NZBaseProp NZ <+ NZOrderProp NZ.
Local Open Scope ofnat.

Theorem ofnat_S_gt_0 :
  forall n : nat, 0 < [Datatypes.S n].
Proof.
unfold ofnat.
intros n; induction n as [| n IH]; simpl in *.
apply lt_succ_diag_r.
apply lt_trans with (S 0). apply lt_succ_diag_r. now rewrite <- succ_lt_mono.
Qed.

Theorem ofnat_S_neq_0 :
  forall n : nat, 0 ~= [Datatypes.S n].
Proof.
intros. apply lt_neq, ofnat_S_gt_0.
Qed.

Lemma ofnat_injective : forall n m, [n]==[m] -> n = m.
Proof.
induction n as [|n IH]; destruct m; auto.
intros H; elim (ofnat_S_neq_0 _ H).
intros H; symmetry in H; elim (ofnat_S_neq_0 _ H).
intros. f_equal. apply IH. now rewrite <- succ_inj_wd.
Qed.

Lemma ofnat_eq : forall n m, [n]==[m] <-> n = m.
Proof.
split. apply ofnat_injective. intros; now subst.
Qed.

(* In addition, we can prove that [ofnat] preserves order. *)

Lemma ofnat_lt : forall n m : nat, [n]<[m] <-> (n<m)%nat.
Proof.
induction n as [|n IH]; destruct m; repeat rewrite ofnat_zero; split.
intro H; elim (lt_irrefl _ H).
inversion 1.
auto with arith.
intros; apply ofnat_S_gt_0.
intro H; elim (lt_asymm _ _ H); apply ofnat_S_gt_0.
inversion 1.
rewrite !ofnat_succ, <- succ_lt_mono, IH; auto with arith.
rewrite !ofnat_succ, <- succ_lt_mono, IH; auto with arith.
Qed.

Lemma ofnat_le : forall n m : nat, [n]<=[m] <-> (n<=m)%nat.
Proof.
intros. rewrite lt_eq_cases, ofnat_lt, ofnat_eq.
split.
destruct 1; subst; auto with arith.
apply Lt.le_lt_or_eq.
Qed.

End NZOfNatOrd.

(** For basic operations, we can prove correspondance with
    their counterpart in [nat]. *)

Module NZOfNatOps (Import NZ:NZAxiomsSig').
Include NZOfNat NZ.
Local Open Scope ofnat.

Lemma ofnat_add_l : forall n m, [n]+m == (S^n) m.
Proof.
 induction n; intros.
 apply add_0_l.
 rewrite ofnat_succ, add_succ_l. simpl. now f_equiv.
Qed.

Lemma ofnat_add : forall n m, [n+m] == [n]+[m].
Proof.
 intros. rewrite ofnat_add_l.
 induction n; simpl. reflexivity.
 now f_equiv.
Qed.

Lemma ofnat_mul : forall n m, [n*m] == [n]*[m].
Proof.
 induction n; simpl; intros.
 symmetry. apply mul_0_l.
 rewrite plus_comm.
 rewrite ofnat_add, mul_succ_l.
 now f_equiv.
Qed.

Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n.
Proof.
 induction m; simpl; intros.
 apply sub_0_r.
 rewrite sub_succ_r. now f_equiv.
Qed.

Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m].
Proof.
 intros n m H. rewrite ofnat_sub_r.
 revert n H. induction m. intros.
 rewrite <- minus_n_O. now simpl.
 intros.
 destruct n.
 inversion H.
 rewrite nat_rect_succ_r.
 simpl.
 etransitivity. apply IHm. auto with arith.
    eapply nat_rect_wd; [symmetry;apply pred_succ|apply pred_wd].
Qed.

End NZOfNatOps.