Definition relation (X : Type) := X -> X -> Prop.

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Module ArithC.

Inductive t : Type :=
| true
| false
| If (t1 t2 t3: t)
| O (*オーです*)
| succ (t1: t)
| pred (t1: t)
| iszero (t1: t).

Fixpoint Const_num (T: t) : nat :=
  match T with
  | true => 1
  | false => 1
  | O => 1
  | succ t1 => Const_num t1
  | pred t1 => Const_num t1
  | iszero t1 => Const_num t1
  | If t1 t2 t3 => (Const_num t1) + (Const_num t2) + (Const_num t3)
  end.

Fixpoint size (T: t) : nat :=
  match T with
  | true => 1
  | false => 1
  | O => 1
  | succ t1 => 1 + (size t1)
  | pred t1 => 1 + (size t1)
  | iszero t1 => 1 + (size t1)
  | If t1 t2 t3 => 1 +  (size t1) + (size t2) + (size t3)
  end.

Lemma l3_3: forall T,
    Const_num T <= size T.
Proof.
  induction T; auto.
  - (*If*)
    simpl. induction IHT1. induction IHT2. induction IHT3; auto.
    rewrite plus_n_Sm in IHIHT3; apply le_S; assumption.
    apply le_S. rewrite <- plus_n_Sm. rewrite plus_Sn_m. assumption.
    apply le_S; assumption.
  - (*succ*)
    simpl. inversion IHT; auto.
  - (*pred*)
    simpl. inversion IHT; auto.
  - (*iszero*)
    simpl. inversion IHT; auto.
Qed.

Fixpoint depth (T: t): nat :=
  match T with
  | true => 1
  | false => 1
  | O => 1
  | succ t1 => 1 + depth t1
  | pred t1 => 1 + depth t1
  | iszero t1 => 1 + depth t1
  | If t1 t2 t3 => (Nat.max (depth t1) (Nat.max (depth t2) (depth t3) ))
  end.

End ArithC.

Module ArithBool.

Inductive t : Type :=
| true
| false
| If (t1 t2 t3: t).

Inductive value : t -> Prop :=
| v_true : value true
| v_false: value false.

Reserved Notation " t '-->' t' " (at level 40).

Inductive step : t -> t -> Prop :=
| E_IfTrue : forall t2 t3,
    If true t2 t3 --> t2
| E_IfFalse : forall t2 t3,
    If false t2 t3 --> t3
| E_If : forall t1 t1' t2 t3,
    t1 --> t1' ->
    If t1 t2 t3 --> If t1' t2 t3

  where " t '-->' t' " := (step t t').

Theorem T3_5_4 : forall t t' t'', (*決定性*)
    t --> t' -> t --> t'' -> t' = t''.
Proof.
  intros. generalize dependent t''.
  induction H; intros.
  - (*E_Iftrue*)
    inversion H0; subst; auto. inversion H4.
  - (*E_IfFalse*)
    inversion H0; subst; auto. inversion H4.
  - (*E_If*)
    inversion H0; subst. inversion H. inversion H.
    apply IHstep in H5; subst; auto.
Qed.

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Lemma L_origin : forall t t' t'',
    t -->* t' -> t' -->* t'' -> t -->* t''.
Proof.
  intros. generalize dependent t''. induction H; intros; try assumption.
  eapply multi_step. apply H. apply IHmulti in H1. assumption.
Qed.

Theorem T3_5_11 : forall t u u',
    t -->* u -> t -->* u' -> value u -> value u' -> u = u'.
Proof.
  intros. generalize dependent u'. induction H; intros.
  induction H0; auto. destruct H1; inversion H.

  destruct H2. destruct H3; inversion H.
  eapply T3_5_4 with (t'' := y0) in H; auto.
  subst.
  apply IHmulti; auto.
Qed.

Theorem T3_5_12 : forall t1,
    exists t', value t' /\ t1 -->* t'.
Proof.
  induction t1.
  exists true; split. apply v_true. apply multi_refl.
  exists false; split. apply v_false. apply multi_refl.
  inversion IHt1_1; inversion IHt1_2; inversion IHt1_3;
  clear IHt1_3; clear IHt1_2; clear IHt1_1.
  inversion H. inversion H0. inversion H1.
  induction H3.
  destruct H2.
  exists x0. split; auto. eapply multi_step. apply E_IfTrue. assumption.
  exists x1. split; auto. eapply multi_step. apply E_IfFalse. assumption.

  destruct IHmulti; auto.
  exists x2. inversion H9; split; auto.
  eapply multi_step. apply E_If. apply H3. assumption.
Qed.

End ArithBool.

Module ArithNat.

Inductive term: Type :=
| Tru
| Fls
| If (t1 t2 t3: term)
| O
| succ (t1: term)
| pred (t1: term)
| iszero (t1: term).

Inductive NatValue: term -> Prop :=
| nv_O : NatValue O
| nv_S : forall nv1, NatValue nv1 -> NatValue (succ nv1).

Inductive value: term -> Prop :=
| v_tru : value Tru
| v_fls : value Fls
| v_nat : forall t1, NatValue t1 -> value t1.

Reserved Notation " t '-->' t' " (at level 40).
Inductive step: term -> term -> Prop :=
| E_IfTrue : forall t2 t3,
    If Tru t2 t3 --> t2
| E_IfFalse : forall t2 t3,
    If Fls t2 t3 --> t3
| E_If : forall t1 t1' t2 t3,
    t1 --> t1' ->
    If t1 t2 t3 --> If t1' t2 t3
| E_Succ : forall t1 t1',
    t1 --> t1' -> succ t1 --> succ t1'
| E_PredZero :
    pred O --> O
| E_PredSucc : forall nv1,
    NatValue nv1 -> pred (succ nv1) --> nv1
| E_Pred : forall t1 t1',
    t1 --> t1' -> pred t1 --> pred t1'
| E_IsZeroZero :
    iszero O --> Tru
| E_IsZeroSucc : forall nv1,
    NatValue nv1 -> iszero (succ nv1) --> Fls
| E_IsZero : forall t1 t1',
    t1 --> t1' -> iszero t1 --> iszero t1'

  where " t '-->' t' " := (step t t').

Lemma nv_notstep : forall nv1,
    NatValue nv1 -> not (exists t1, nv1 --> t1).
Proof.
  intros. induction H; intro H1.
  inversion H1. inversion H.
  inversion H1. inversion H0; subst.
  induction IHNatValue.
  exists t1'; assumption.
Qed.

Theorem T3_5_14 : forall t1 t1' t1'',
    t1 --> t1' -> t1 --> t1'' -> t1' = t1''.
Proof.
  intros. generalize dependent t1''.
  induction H; intros.
  - (*E_IfTtur*)
    inversion  H0; subst; auto. inversion H4.
  - (*E_IfFalse*)

    inversion H0; subst; auto. inversion H4.
  - (*E_If*)
    inversion H0; subst. inversion H. inversion H.
    apply IHstep in H5; subst; auto.
  - (*E_Succ*)
    inversion H0. apply IHstep in H2; subst; auto.
  - (*E_PredZero*)
    inversion H0; subst; auto. inversion H1.
  - (*E_PredSucc*)
    inversion H0; auto.
    apply nv_notstep in H. inversion H2. induction H. exists t1'0. assumption.
  - (*E_Pred*)
    inversion H0; subst. inversion H.
    inversion H. apply nv_notstep in H2. induction H2. exists t1'0; auto.
    apply IHstep in H2. subst; auto.
  - (*E_IsZeroZero*)
    inversion H0; subst; auto. inversion H1.
  - (*E_IsZeroSucc*)
    inversion H0; subst; auto.
    inversion H2; subst. apply nv_notstep in H. induction H. exists t1'0; auto.
  - (*E_Iszero*)
    inversion H0; subst.
    inversion H.
    apply nv_notstep in H2. induction H2. inversion H. exists t1'0; auto.
    apply IHstep in H2. subst; auto.
Qed.

Reserved Notation " t '==>' t' " (at level 40).

Inductive bigstep : term -> term -> Prop :=
| B_Value : forall t1,
    value t1 -> t1 ==> t1
| B_IfTrue : forall t1 t2 v2 t3,
    t1 ==> Tru -> t2 ==> v2 -> value v2 -> If t1 t2 t3 ==> v2
| B_IfFalse : forall t1 t2 t3 v3,
    t1 ==> Fls -> t3 ==> v3 -> value v3 -> If t1 t2 t3 ==> v3
| B_Succ : forall t1 nv1,
    t1 ==> nv1 -> NatValue nv1 -> succ t1 ==> succ nv1
| B_PredZero : forall t1,
    t1 ==> O -> pred t1 ==> O
| B_PredSucc : forall t1 nv1,
    t1 ==> (succ nv1) -> NatValue nv1 -> pred t1 ==> nv1
| B_IsZeroZero : forall t1,
    t1 ==> O -> iszero t1 ==> Tru
| B_IsZeroSucc : forall t1 nv1,
    t1 ==> (succ nv1) -> iszero t1 ==> Fls

  where " t '==>' t' " := (bigstep t t').

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Lemma bigstepvalue: forall t1 v,
    t1 ==> v -> value v.
Proof.
  intros. induction H; auto.
  apply v_nat. apply nv_S; auto.
  inversion IHbigstep. inversion H1. apply v_nat; auto.
  apply v_tru. apply v_fls.
Qed.

Lemma bigsteptrans: forall t1 t1' t2,
    t1 --> t1' -> t1' ==> t2 -> t1 ==> t2.
Proof.
  intros. generalize dependent t2; induction H; intros.
  - (*E_IfTrue*)
    apply B_IfTrue; auto. apply B_Value; apply v_tru.
    eapply bigstepvalue; auto. apply H0.
  - (*E_IfFalse*)
    apply B_IfFalse; auto. apply B_Value; apply v_fls.
    eapply bigstepvalue; eauto.
  - (*E_If*)
    inversion H0; subst. inversion H1. inversion H2.
    apply B_IfTrue; auto.
    apply B_IfFalse; auto.
  - (*E_Succ*)
    inversion H0; subst. inversion H1. inversion H2. apply B_Succ; auto.
    apply IHstep. apply B_Value; auto. apply v_nat; auto.
    apply B_Succ; auto.
  - (*E_PredZero*)
    inversion H0; subst. apply B_PredZero; auto.
  - (*E_PredSucc*)
    inversion H; subst.
    inversion H0. apply B_PredSucc; auto. apply B_Value. apply v_nat; apply nv_S; apply nv_O.
    inversion H0; subst. apply B_PredSucc. apply B_Value. apply v_nat; apply nv_S. apply H. auto.
    apply B_PredSucc. apply B_Succ; auto. apply nv_S; auto. apply nv_S; auto.
  - (*E_Pred*)
    inversion H0; subst. inversion H1. inversion H2.
    apply B_PredZero. apply IHstep; auto.
    apply B_PredSucc; auto.
  - (*E_IsZeroZero*)
    inversion H0. apply B_IsZeroZero. apply B_Value. apply v_nat. apply nv_O.
  - (*E_IsZeroSucc*)
    inversion H0. apply B_IsZeroSucc with (nv1:= nv1). apply B_Value. apply v_nat; apply nv_S; auto.
  - (*E_IsZero*)
    inversion H0; subst. inversion H1. inversion H2.
    apply B_IsZeroZero; auto.
    apply B_IsZeroSucc with (nv1:= nv1); auto.
Qed.

Theorem T3_5_17 : forall t1 v,
    (t1 -->* v) -> value v -> t1 ==> v.
Proof.
  intros. induction H.
  apply B_Value; auto.
  pose proof (IHmulti H0).
  eapply bigsteptrans. apply H. apply H2.
Qed.

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

End ArithNat.

Module ArithNatBad.

Inductive t: Type :=
| tru
| fls
| If (t1 t2 t3: t)
| O
| succ (t1: t)
| pred (t1: t)
| iszero (t1: t)
| wrong.

Inductive NatValue: t -> Prop :=
| nv_O : NatValue O
| nv_S : forall nv1, NatValue nv1 -> NatValue (succ nv1).

Inductive value: t -> Prop :=
| v_tru : value tru
| v_fls : value fls
| v_nat : forall t1, NatValue t1 -> value t1.

Inductive BadNat : t -> Prop :=
| bn_tru : BadNat tru
| bn_fls : BadNat fls
| bn_wrong : BadNat wrong.

Inductive BadBool : t -> Prop :=
| bb_nat : forall t1, NatValue t1 -> BadBool t1
| bb_wrong : BadBool wrong.

Reserved Notation " t '-->' t' " (at level 40).
Inductive estep: t -> t -> Prop :=
| Ee_IfTrue : forall t2 t3,
    If tru t2 t3 --> t2
| Ee_IfFalse : forall t2 t3,
    If fls t2 t3 --> t3
| Ee_If : forall t1 t1' t2 t3,
    t1 --> t1' ->
    If t1 t2 t3 --> If t1' t2 t3
| Ee_Succ : forall t1 t1',
    t1 --> t1' -> succ t1 --> succ t1'
| Ee_PredZero :
    pred O --> O
| Ee_PredSucc : forall nv1,
    NatValue nv1 -> pred (succ nv1) --> nv1
| Ee_Pred : forall t1 t1',
    t1 --> t1' -> pred t1 --> pred t1'
| Ee_IsZeroZero :
    iszero O --> tru
| Ee_IsZeroSucc : forall nv1,
    NatValue nv1 -> iszero (succ nv1) --> fls
| Ee_IsZero : forall t1 t1',
    t1 --> t1' -> iszero t1 --> iszero t1'

(*行き詰まり処理*)
| Ee_IfWrong : forall t1 t2 t3,
    BadBool t1 -> If t1 t2 t3 --> wrong
| E_SuccWrong : forall t1,
    BadNat t1 -> succ t1 --> wrong
| Ee_PredWrong : forall t1,
    BadNat t1 -> pred t1 --> wrong
| Ee_IsZeroWrong : forall t1,
    BadNat t1 -> iszero t1 --> wrong

  where " t '-->' t' " := (estep t t').

Reserved Notation " t '-->o' t' " (at level 40).
Inductive step: t -> t -> Prop :=
| E_IfTrue : forall t2 t3,
    If tru t2 t3 -->o t2
| E_IfFalse : forall t2 t3,
    If fls t2 t3 -->o t3
| E_If : forall t1 t1' t2 t3,
    t1 -->o t1' ->
    If t1 t2 t3 -->o If t1' t2 t3
| E_Succ : forall t1 t1',
    t1 -->o t1' -> succ t1 -->o succ t1'
| E_PredZero :
    pred O -->o O
| E_PredSucc : forall nv1,
    NatValue nv1 -> pred (succ nv1) -->o nv1
| E_Pred : forall t1 t1',
    t1 -->o t1' -> pred t1 -->o pred t1'
| E_IsZeroZero :
    iszero O -->o tru
| E_IsZeroSucc : forall nv1,
    NatValue nv1 -> iszero (succ nv1) -->o fls
| E_IsZero : forall t1 t1',
    t1 -->o t1' -> iszero t1 -->o iszero t1'

  where " t '-->o' t' " := (step t t').

Definition stop (t1: t) :=
  not (value t1) /\ not (exists t1', t1 -->o t1').

Lemma existstop:
  exists t1, stop t1.
Proof.
  exists (iszero tru).
  split.
  intro H; inversion H. inversion H0.
  intro H. inversion H. inversion H0. inversion H2.
Qed.

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

Ltac solve_by_invert :=
  solve_by_inverts 1.

Fixpoint Good (t1: t) : bool :=
  match t1 with
  | wrong => false
  | If t1' t2 t3 => andb (Good t1') (andb (Good t2) (Good t3))
  | succ t1' => Good t1'
  | pred t1' => Good t1'
  | iszero t1' => Good t1'
  | _ => true
  end.

Lemma nv_notstep : forall nv1,
    NatValue nv1 -> not (exists t1, nv1 --> t1).
Proof.
  intros. induction H; intro H1.
  inversion H1. inversion H.
  inversion H1. inversion H0; subst.
  induction IHNatValue.
  exists t1'; assumption.
  inversion H3; subst; solve_by_invert.
Qed.

Lemma NatValuesucc: forall nv,
    NatValue nv -> not (exists t1', succ nv --> t1').
Proof.
  intros. induction H.
  intro H. inversion H. inversion H0; try solve_by_invert.
  intro HH. inversion HH. inversion H0; subst.
  induction IHNatValue. exists t1'; auto.
  inversion H2.
Qed.

Lemma A3: forall t1 t1' t1'',
     t1 --> t1' -> t1 --> t1'' -> t1' = t1''.
Proof.
  intros. generalize dependent t1''; induction H; intros.
  -
    inversion H0; subst; auto; try solve_by_invert. inversion H4. inversion H.
  -
    inversion H0; subst; auto; try solve_by_inverts 2.
  -
    inversion H0; subst; try solve_by_invert.
    apply IHestep in H5; subst; auto.
    inversion H5; subst. induction (nv_notstep t1); auto. exists t1'; auto.
    inversion H.
  -
    inversion H0; subst. rewrite IHestep with (t1'':=t1'0); auto.
    inversion H2; subst; try solve_by_invert.
  -
    inversion H0; auto; try solve_by_invert.
  -
    inversion H0; subst; auto.
    induction (NatValuesucc nv1); auto. exists t1'; auto.
    inversion H2.
  -
    inversion H0;subst. inversion H.
    induction (NatValuesucc t1''); auto. exists t1'; auto.
    apply IHestep in H2; subst; auto.
    inversion H2; subst; try solve_by_invert.
  -
    inversion H0; auto; try solve_by_invert.
  -
    inversion H0; subst; auto.
    induction (NatValuesucc nv1); auto. exists t1'; auto.
    inversion H2.
  -
    inversion H0; subst; auto; try solve_by_invert.
    induction (NatValuesucc nv1); auto. exists t1'; auto.
    apply IHestep in H2; subst; auto.
    inversion H2; subst; try solve_by_invert.
  -
    inversion H0; subst; try solve_by_inverts 2; auto.
    inversion H; subst; try solve_by_invert.
    induction (nv_notstep t1); auto. exists t1'; auto.
  -
    inversion H; subst.
    inversion H0; subst; try solve_by_invert; auto.
    inversion H0; subst; try solve_by_invert; auto.
    inversion H0; subst; auto. inversion H2.
  -
    inversion H0; subst; try solve_by_invert; auto.
    inversion H; subst; try solve_by_invert.
  -
    inversion H0; subst; try solve_by_invert; auto.
    inversion H; subst; try solve_by_invert.
Qed.

Lemma IfStopWrong: forall t1 t2 t3,
    stop (If t1 t2 t3) -> not (exists t1', t1 -->o t1').
Proof.
  intros.
  induction t1.
  - (*tur*)
    inversion H. induction H1. exists t2; apply E_IfTrue.
  - (*fls*)
    inversion H. induction H1; exists t3; apply E_IfFalse.
  - (*If*)
    intros HH.
    inversion HH.
    inversion H.
    inversion H0; subst;
    induction H2; eexists; eapply E_If; apply H0.
  -
    intro HH; inversion HH. inversion H0.
  -
    intro HH; inversion HH. inversion H0.
    inversion H. induction H5.
    eexists. eapply E_If. eapply E_Succ. apply H2.
  -
    intros HH; inversion HH. inversion H. inversion H0; subst;
    induction H2; subst; eexists; eapply E_If; eassumption.
  -
    intros HH; inversion HH; inversion H. inversion H0; subst;
    induction H2; eexists; eapply E_If; eassumption.
  -
    intros HH; inversion HH; inversion H. inversion H0; subst;
    induction H2; eexists; eapply E_If; eassumption.
Qed.

Notation multiestep := (multi estep).
Notation "t1 '-->*' t2" := (multiestep t1 t2) (at level 40).

Notation multistep := (multi step).
Notation "t1 '-->o*' t2" := (multistep t1 t2) (at level 40).

Lemma Iftrans : forall t1 t2 t3 t1',
    t1 -->* t1' -> If t1 t2 t3 -->* If t1' t2 t3.
Proof.
  intros. induction H.
  apply multi_refl. eapply multi_step. apply Ee_If. eassumption.
  assumption.
Qed.

Lemma multitrans: forall t1 t2 t3,
    t1 -->* t2 -> t2 -->* t3 -> t1 -->* t3.
Proof.
  intros. generalize dependent t3. induction H; intros.
  assumption.
  eapply multi_step. apply H. apply IHmulti. assumption.
Qed.

Fixpoint NVBool (t1: t) : bool :=
  match t1 with
  | O => true
  | succ t1' => NVBool t1'
  | _ => false
  end.

Lemma NVB_nv : forall t1,
    NVBool t1 = true <-> NatValue t1.
Proof.
  split; intros.
  -
    induction t1; try solve_by_invert.
    apply nv_O. apply nv_S. apply IHt1. inversion H; auto.
  -
    induction H; subst; auto.
Qed.

Lemma stepe : forall t1 t1',
    t1 -->o t1' -> t1 --> t1'.
Proof.
  intros. induction H.
  -
    apply Ee_IfTrue.
  -
    apply Ee_IfFalse.
  -
    apply Ee_If; auto.
  -
    apply Ee_Succ; auto.
  -
    apply Ee_PredZero.
  -
    apply Ee_PredSucc; auto.
  -
    apply Ee_Pred; auto.
  -
    apply Ee_IsZeroZero.
  -
    apply Ee_IsZeroSucc; auto.
  -
    apply Ee_IsZero; auto.
Qed.

Lemma succtrans : forall t1 t1',
    t1 -->* t1' -> succ t1 -->* succ t1'.
Proof.
  intros. induction H.
  apply multi_refl.
  eapply multi_step. apply Ee_Succ. apply H. apply IHmulti.
Qed.

Lemma predtrans : forall t1 t1',
    t1 -->* t1' -> pred t1 -->* pred t1'.
Proof.
  intros. induction H.
  apply multi_refl.
  eapply multi_step. apply Ee_Pred; eassumption. auto.
Qed.

Lemma iszerotrans : forall t1 t1',
    t1 -->* t1' -> iszero t1 -->* iszero t1'.
Proof.
  intros. induction H.
  apply multi_refl.
  eapply multi_step. apply Ee_IsZero. apply H. auto.
Qed.

Lemma estepor: forall t1 t1',
    t1 --> t1' -> t1 -->o t1' \/ t1 -->* wrong.
Proof.
  induction t1; intros; try solve_by_invert.
  -
    inversion H; subst.
    left. apply E_IfTrue.
    left. apply E_IfFalse.
    apply IHt1_1 in H4; inversion H4.
    left. apply E_If; auto.
    apply Iftrans with (t2:= t1_2) (t3:=t1_3) in H0.
    right. eapply multitrans. apply H0. eapply multi_step. apply Ee_IfWrong. apply bb_wrong. apply multi_refl.
    right. eapply multi_step. apply H. apply multi_refl.
  -
    inversion H; subst. apply IHt1 in H1. inversion H1.
    left. apply E_Succ; auto.
    apply succtrans in H0. right. eapply multitrans. apply H0. eapply multi_step. apply E_SuccWrong. apply bn_wrong. apply multi_refl.
    right. eapply multi_step. apply H. apply multi_refl.
  -
    inversion H; subst.
    left. apply E_PredZero. left. apply E_PredSucc; auto.
    apply IHt1 in H1. inversion H1. left. apply E_Pred; auto.
    right. apply predtrans in H0. eapply multitrans. apply H0. eapply multi_step. apply Ee_PredWrong. apply bn_wrong. apply multi_refl.
    right. eapply multi_step. apply Ee_PredWrong; auto. apply multi_refl.
  -
    inversion H; subst.
    left. apply E_IsZeroZero. left. apply E_IsZeroSucc; auto.
    apply IHt1 in H1. inversion H1.
    left. apply E_IsZero; auto.
    right. apply iszerotrans in H0. eapply multitrans. apply H0. eapply multi_step. apply Ee_IsZeroWrong. apply bn_wrong. apply multi_refl.
    right. eapply multi_step. apply Ee_IsZeroWrong; auto. apply multi_refl.
Qed.

Fixpoint isnumericval (t1: t): bool :=
  match t1 with
  | O => true
  | succ t1 => isnumericval t1
  | _ => false
  end.

Definition isval (t1: t) : bool :=
  match t1 with
  | tru => true
  | fls => true
  | _ => isnumericval t1
  end.

Definition isbool (t1: t) : bool :=
  match t1 with
  | tru => true
  | fls => true
  | _ => false
  end.

Definition isBNat (t1: t) : bool :=
  match t1 with
  | wrong => true
  | _ => isbool t1
  end.

Definition isBbool (t1: t) : bool :=
  match t1 with
  | wrong => true
  | _ => isnumericval t1
  end.

Inductive optiont : Type :=
| Some (T: t)
| None.

Fixpoint eval1 (t': t) : optiont :=
  match t' with
  | If t1 t2 t3 =>
    if (isbool t1) then
      match t1 with
      | tru => Some t2
      | fls => Some t3
      | _ => None
      end else if (isBbool t1) then Some wrong else
      match (eval1 t1) with
      | Some t1' => Some (If t1' t2 t3)
      | _ => None
      end
  | succ t1 =>
    if isnumericval t1 then
      None else if (isBNat t1) then Some wrong else
      match (eval1 t1) with
      | Some t1' => Some (succ t1')
      | _ => None
      end
  | pred t1 =>
    if (isnumericval t1) then
      match t1 with
      | O => Some O
      | succ nv1 => Some nv1
      | _ => None
      end else if (isBNat t1) then Some wrong else
      match (eval1 t1) with
      | Some t1' => Some (pred t1')
      | _ => None
      end
  | iszero t1 =>
    if (isnumericval t1) then
      match t1 with
      | O => Some tru
      | succ _ => Some fls
      | _ => None
      end else if (isBNat t1) then Some wrong else
      match (eval1 t1) with
      | Some t1' => Some (iszero t1')
      | _ => None
      end
  | _ => None
  end.

Lemma isnumericvalCC : forall t1,
    isnumericval t1 = true <-> NatValue t1.
Proof.
  split; intros.
  induction t1; try solve_by_invert.
  apply nv_O. inversion H. apply nv_S. apply IHt1; auto.
  induction H. reflexivity. inversion IHNatValue; auto.
Qed.

Lemma NVstep: forall nv,
    NatValue nv -> not (exists t1', succ nv -->o t1').
Proof.
  intros. induction H.
  intro H. inversion H. inversion H0; try solve_by_invert.
  intro HH. inversion HH. inversion H0; subst.
  induction IHNatValue. exists t1'; auto.
Qed.

Lemma BBCC : forall t1,
    isBbool t1 = true <-> BadBool t1.
Proof.
  split; intros.
  induction t1; try solve_by_inverts 2. apply bb_nat. apply nv_O. apply bb_nat. apply nv_S.
  inversion H. apply isnumericvalCC in H1. auto. apply bb_wrong.
  induction H; auto. induction H; auto. simpl. apply isnumericvalCC. auto.
Qed.

Lemma BNCC : forall t1,
    isBNat t1 = true <-> BadNat t1.
Proof.
  split; intros.
  induction t1; try solve_by_invert. apply bn_tru. apply bn_fls. apply bn_wrong.
  inversion H; auto.
Qed.

Lemma eval1OK : forall t1 t1',
    t1 --> t1' <-> eval1 t1 = Some t1'.
Proof with eauto.
  split; intros.
  -
    induction H; try reflexivity; simpl.
    +
      destruct (isbool t1) eqn:IHb.
      destruct t1; try solve_by_invert.
      destruct (isBbool t1) eqn:IHBb.
      unfold isbool in IHb. unfold isBbool in IHBb.
      destruct t1; try solve_by_invert.
      apply isnumericvalCC in IHBb.
      inversion IHBb; subst.
      inversion H. subst. induction (nv_notstep t1); auto. exists t1'0. auto.
      subst. destruct t1; try solve_by_invert.
      rewrite IHestep. reflexivity.
    +
      destruct (isnumericval t1) eqn:IHn.
      destruct t1; try solve_by_invert. apply isnumericvalCC in IHn.
      inversion IHn; subst. induction (nv_notstep t1); auto. inversion H; subst. exists t1'0; auto.
      destruct t1; try solve_by_invert.
      destruct (isBNat t1) eqn:IHBn. destruct t1; try solve_by_invert.
      rewrite IHestep; auto.
    +
      apply isnumericvalCC in H. rewrite H. auto.
    +
      rewrite IHestep. destruct (isnumericval t1) eqn:IHnum. apply isnumericvalCC in IHnum.
      induction (nv_notstep t1); auto. exists t1'; auto.
      destruct (isBNat t1) eqn:IHBN. destruct t1; try solve_by_invert.
      auto.
    +
      apply isnumericvalCC in H. rewrite H. auto.
    +
      rewrite IHestep. destruct (isnumericval t1) eqn:IHn. destruct t1; try solve_by_invert.
      inversion H; subst. apply isnumericvalCC in IHn. inversion IHn; subst. induction (nv_notstep t1); auto.
      exists t1'0; auto.
      destruct t1; try solve_by_invert.
      destruct (isBNat t1) eqn:IHB; auto. destruct t1; try solve_by_invert.
    +
      destruct (isbool t1) eqn:IHb. destruct t1; try solve_by_inverts 2.
      apply BBCC in H. rewrite H; auto.
    +
      destruct (isnumericval t1) eqn:IHnum. destruct t1; try solve_by_invert.
      apply BNCC in H. rewrite H. auto.
    +
      destruct t1; try solve_by_invert; auto.
    +
      destruct t1; try solve_by_invert; auto.
  -
    generalize dependent t1'.
    induction t1; intros; try solve_by_invert.
    +
      inversion H. destruct (isbool t1_1) eqn:IHB. destruct t1_1; try solve_by_invert; inversion H1; constructor.
      induction (isBbool t1_1) eqn:IHBB. inversion H1. apply Ee_IfWrong. apply BBCC in IHBB. auto.
      induction (eval1 t1_1); inversion H1. apply Ee_If. apply IHt1_1. reflexivity.
    +
      inversion H. destruct (isnumericval t1) eqn:IHnum; try solve_by_invert.
      destruct (isBNat t1) eqn:IHBN. inversion H1. apply E_SuccWrong. apply BNCC; auto.
      destruct (eval1 t1); inversion H1. apply Ee_Succ. apply IHt1...
    +
      inversion H. destruct (isnumericval t1) eqn:IHnum. destruct t1; try solve_by_invert; inversion H1.
      apply Ee_PredZero. apply Ee_PredSucc. inversion IHnum. subst. apply isnumericvalCC...
      destruct (isBNat t1) eqn:IHBN. inversion H1. apply Ee_PredWrong. apply BNCC...
      destruct (eval1 t1); inversion H1. apply Ee_Pred; apply IHt1...
    +
      inversion H. destruct (isnumericval t1) eqn:IHn. destruct t1; inversion H1.
      apply Ee_IsZeroZero. apply Ee_IsZeroSucc. apply isnumericvalCC...
      destruct (isBNat t1) eqn:IHB; inversion H1. apply Ee_IsZeroWrong. apply BNCC...
      destruct (eval1 t1); inversion H1. apply Ee_IsZero. apply IHt1...
Qed.

Inductive multieval :t -> t -> Prop :=
  | refl : forall t1, multieval t1 t1
  | st : forall t1 t1' t1'', eval1 t1 = Some t1' -> multieval t1' t1'' -> multieval t1 t1''.

Lemma multievalstep : forall t1 t1',
    multieval t1 t1' <-> t1 -->* t1'.
Proof.
  split; intros.
  -
    induction H. apply multi_refl.
    apply eval1OK in H. eapply multi_step. apply H; auto. apply IHmultieval.
  -
    induction H. apply refl. apply eval1OK in H. eapply st. apply H. apply IHmulti.
Qed.

Lemma A4: forall t1,
    stop t1 -> multieval t1 wrong.
Proof with eauto.
  induction t1; intros.
  -
    inversion H. induction H0. constructor.
  -
    inversion H. induction H0. constructor.
  -
    destruct (isbool t1_1) eqn:IHB. destruct t1_1; inversion IHB.
    inversion H. induction H1. exists t1_2. apply E_IfTrue.
    inversion H. induction H1. exists t1_3. constructor.
    destruct (isBbool t1_1) eqn:IHBb...
    apply st with (t1':= wrong). simpl. rewrite IHB. rewrite IHBb... apply refl.

    assert (stop t1_1).
    split; intro HH. inversion H. destruct t1_1; try solve_by_inverts 2.
    inversion HH. apply isnumericvalCC in H2.
    inversion IHBb. inversion H2. rewrite H5 in H6. inversion H6.
    inversion HH. inversion H. induction H2. exists (If x t1_2 t1_3). constructor; auto.

    apply IHt1_1 in H0. apply multievalstep in H0. apply multievalstep. apply Iftrans with (t2:= t1_2) (t3:=t1_3) in H0. eapply multitrans. apply H0. eapply multi_step. apply Ee_IfWrong. apply bb_wrong. apply multi_refl.
  -
    inversion H. induction H0; constructor. constructor.
  -
    destruct (isnumericval t1) eqn:IHnum. inversion H. induction H0. apply v_nat.
    apply nv_S; apply isnumericvalCC...
    destruct (isBNat t1) eqn: IHBn...
    eapply st with (t1':=wrong). simpl. rewrite IHBn. rewrite IHnum... constructor.

    assert (stop t1).
    split; intros HH. destruct t1; try solve_by_inverts 2. inversion HH. apply isnumericvalCC in H0. rewrite H0 in IHnum. inversion IHnum.
    inversion HH. inversion H. induction H2. exists (succ x). constructor. auto.

    apply IHt1 in H0. apply multievalstep in H0. apply multievalstep.
    apply succtrans in H0. eapply multitrans.
    apply H0.
    eapply multi_step. apply E_SuccWrong. apply bn_wrong. constructor.
  -
    simpl. destruct (isnumericval t1) eqn:IHnum. destruct t1; try solve_by_invert...
    inversion H. induction H1. exists O. constructor. inversion H. induction H1. exists t1. constructor. apply isnumericvalCC...
    destruct (isBNat t1) eqn:IHBn...
    eapply st with (t1':=wrong). simpl. rewrite IHBn. rewrite IHnum... constructor.

    assert (stop t1).
    split; intro HH. destruct t1; try solve_by_inverts 2. inversion HH. apply isnumericvalCC in H0. rewrite IHnum in H0. inversion H0.
    inversion HH. inversion H. induction H2. exists (pred x); constructor...
    apply IHt1 in H0. apply multievalstep. apply multievalstep in H0. apply predtrans in H0.
    eapply multitrans. apply H0. eapply multi_step. apply Ee_PredWrong. constructor. constructor.
  -
    simpl. destruct (isnumericval t1) eqn:IHnum. destruct t1; try solve_by_invert.
    inversion H. induction H1. exists tru; constructor. inversion H. induction H1. exists fls. constructor. apply isnumericvalCC...
    destruct (isBNat t1) eqn:BN...
    apply st with (t1':= wrong). simpl. rewrite IHnum. rewrite BN... constructor.

    assert (stop t1).
    split; intro HH. destruct t1; try solve_by_inverts 2. inversion HH. apply isnumericvalCC in H0. rewrite H0 in IHnum. inversion IHnum.
    inversion HH. inversion H. induction H2. exists (iszero x). constructor...
    apply IHt1 in H0.
    apply multievalstep in H0. apply multievalstep.
    apply iszerotrans in H0. eapply multitrans. apply H0.
    econstructor. apply Ee_IsZeroWrong. apply bn_wrong. constructor.
  -
    apply refl.
Qed.

Lemma A5: forall t1 t2,
    Good t1 = true -> Good t2 = false ->
    t1 --> t2 -> stop t1.
Proof.
  intros. induction H1; try solve_by_invert.
  -
    inversion H. apply andb_prop in H2. inversion H2. rewrite H1 in H0. discriminate H0.
  -
    inversion H. apply andb_prop in H2. inversion H2. rewrite H3 in H0; discriminate.
  -
    split; intros HH. inversion HH. inversion H2.
    inversion H0. inversion H. apply andb_prop in H4. inversion H4. rewrite H5 in H3.
    destruct (Good t1') eqn:IHH. discriminate.
    inversion HH. inversion H6; subst; try solve_by_invert.
    destruct IHestep; auto. induction H8. exists t1'0; auto.
  -
    split; intro HH. inversion HH; subst. inversion H2; induction (nv_notstep t1); auto. exists t1'; auto.
    inversion HH. inversion H2; subst. destruct IHestep; auto. induction H5. exists t1'0; auto.
  -
    inversion H. rewrite H3 in H0. inversion H0.
  -
    inversion H. destruct IHestep; auto.
    split; intro HH. inversion HH. inversion H5.
    inversion HH. inversion H5; subst; try solve_by_invert.
    induction H2. apply v_nat; apply nv_S; auto.
    induction H4. exists t1'0; auto.
  -
    inversion H; inversion H0. destruct IHestep; auto.
    split; intro HH. inversion HH. inversion H6.
    inversion HH. inversion H6; subst; try solve_by_invert.
    induction H2. apply v_nat; apply nv_S; auto.
    induction H5. exists t1'0; auto.
  -
    inversion H1; subst; try solve_by_inverts 2.
    split; intro HH; inversion HH. inversion H3.
    inversion H3; subst; try solve_by_invert.
    induction (NVstep t1); auto. exists (succ t1'). apply E_Succ; auto.
  -
    inversion H1; subst; try solve_by_invert;
    split; intro HH;
      inversion HH; inversion H2; subst; try solve_by_invert.
  -
    inversion H1; subst; try solve_by_invert;
      split; intro HH; inversion HH;  try solve_by_inverts 2.
  -
    inversion H1; subst; try solve_by_invert;
      split; intro HH; inversion HH;  try solve_by_inverts 2.
Qed.

Theorem A2right : forall t1 t1',
    Good t1 = true -> Good t1' = true ->
    t1 -->o t1' -> stop t1' -> t1 -->* wrong.
Proof.
  intros.
  eapply multi_step. apply stepe in H1. apply H1. apply multievalstep. apply A4. assumption.
Qed.

Theorem A2left : forall t1 t1',
    Good t1 = true -> Good t1' = true ->
    t1 -->o t1' -> t1' --> wrong -> stop t1'.
Proof.
  intros. split; intro HH.
  inversion HH; subst; try solve_by_inverts 2.
  induction (nv_notstep t1'); auto. exists wrong; auto.
  inversion HH. inversion H2; subst; try solve_by_invert.
  -
    inversion H0. apply andb_prop in H5. inversion H5. inversion H6.
  -
    inversion H4; subst. inversion H5; subst. inversion H3. inversion H10.
    inversion H3; subst. inversion H11; subst. induction (nv_notstep nv1); auto. eexists. apply stepe in H8. apply H8.
    inversion H3; subst. inversion H9.
  -
    inversion H4; subst; try solve_by_inverts 2.
  -
    inversion H4; subst; try solve_by_inverts 2.
  -
    inversion H4; subst; try solve_by_inverts 2.
Qed.

End ArithNatBad.


(* ==================================================================== *)
(* Some examples showing that Coq's implementation of strict positivity *)
(* is a conservative approximation: it does not allow for some          *)
(* strictly positive definitions.                                       *)
(* ==================================================================== *)

Require Import EnvExt Sorting Vector Nat ZArith.
Require Import Basics.

(* ---------------------------- *)
(* A simple AST for expressions *)
(* ---------------------------- *)

Inductive OpName :=
| Neg : OpName
| Add : OpName.

(* This works *)
Inductive Exp :=
  | natNum : nat -> Exp
  | op : OpName -> list Exp -> Exp.

(* Type of lists-with-length implemented as a subset type *)
Definition VecST (A : Type) (n : nat) : Type := {xs : list A | length xs = n}.

Inductive Ops : nat -> Type:=
| NegZ : Ops 1
| AddZ : Ops 2.
(* But if we need list in the argument of the constructor to be of certain length
   (let's say we want to keep track of arity of the operations) : *)

(* Inductive ExpVecST := *)
(*   | natNumA : nat -> ExpVecST *)
(*   | opA : forall n, Ops n -> VecST ExpVecST n -> ExpVecST. *)

(* We get an error:  *)
(* Error: Non strictly positive occurrence of "ExpVecST" in *)
(*  "forall n : nat, VecST ExpVecST n -> ExpVecST". *)

Notation Vec := Vector.t.

(* But if we replace VectST works for vectors! *)
Inductive ExpVec :=
  | ZNumV : Z -> ExpVec
  | opV :  forall n, Ops n -> Vec ExpVec n -> ExpVec.

(* Now, we can define a total evaluation function *)
Program Definition eval_op {n} (f : Ops n) : Vec Z n -> Z :=
  match f with
  | NegZ => fun args => match n with
                        | O => _ (* impossible case *)
                        | 1 => (- hd (args))%Z
                        | S _ => _ (* impossible case *)
                        end
  | AddZ => fun args => match n with
                        | O => _ (* impossible case *)
                        | 1 => _ (* impossible case *)
                        | 2 => (hd args + hd (tl args))%Z
                        | S _ => _ (* impossible case *)
                        end
  end.

Fixpoint eval_ExpVec (e : ExpVec) : Z :=
  match e with
  | ZNumV n => n
  | opV n op_ args => eval_op op_ (map eval_ExpVec args)
  end.

(* -------------------------------------------- *)
(* Environments as lists of pair with a certain *)
(* "well-formedness" condition                  *)
(* -------------------------------------------- *)

(* We want the list in the argument of the constructor to be sorted: *)

Notation Key := nat.

Module M := EnvExt.OrdEnv Basics.ID.

(* Ordering for keys *)
Definition lt_key {A} (e e' : Key * A)  :=
  match e, e' with
    (k,v),(k',v') => k < k'
  end.

(* Sigma type representing list with a property being sorted according to lt_key  *)
Definition sort_list A := {xs : list (Key * A) | sort (@lt_key A) xs}.

(* The definition, which uses additional property
   on an list argument, violates Coq's strict positivity constraint *)

(* Inductive ExpBad1 := *)
(*   ctrBad :  sort_list ExpBad1 -> ExpBad1. *)

(* Basically, all definitions, where we quantify over the list to
   to say something about the list, even without doing anything with
   the list elements, don't work.*)

(* Inductive ExpBad2 := *)
(* | c : (forall x : list (Key * ExpBad2), length x = 1) -> ExpBad2. *)

(* Now, the idea is to separate properties on keys (because we sort only by first component
   of the list) from the values *)

Definition skeys n := {keys | sort ID.lt keys & length keys = n}.

(* This definition is clearly isomorphic to the representation above,
   and it passes strict Coq's strict positivity check *)
Inductive Exp1 :=
| ctr1 : forall n, skeys n -> Vector.t Exp1 n -> Exp1.

(* We used this idea, though we replaced the list of keys with the vector *)
(* See OrdEnv.v *)
Inductive Exp2 :=
  ctr2 :  M.VecEnv.VecEnv Exp2 -> Exp2.


(** This file collects definitions and theorems on abstract rewriting systems.
These are particularly useful as we define the operational semantics as a
small step semantics. *)
From stdpp Require Export sets well_founded.
From stdpp Require Import options.

(** * Definitions *)
Section definitions.
  Context `(R : relation A).

  (** An element is reducible if a step is possible. *)
  Definition red (x : A) := ∃ y, R x y.

  (** An element is in normal form if no further steps are possible. *)
  Definition nf (x : A) := ¬red x.

  (** The symmetric closure. *)
  Definition sc : relation A := λ x y, R x y ∨ R y x.

  (** The reflexive transitive closure. *)
  Inductive rtc : relation A :=
    | rtc_refl x : rtc x x
    | rtc_l x y z : R x y → rtc y z → rtc x z.

  (** The reflexive transitive closure for setoids. *)
  Inductive rtcS `{Equiv A} : relation A :=
    | rtcS_refl x y : x ≡ y → rtcS x y
    | rtcS_l x y z : R x y → rtcS y z → rtcS x z.

  (** Reductions of exactly [n] steps. *)
  Inductive nsteps : nat → relation A :=
    | nsteps_O x : nsteps 0 x x
    | nsteps_l n x y z : R x y → nsteps n y z → nsteps (S n) x z.

  (** Reductions of at most [n] steps. *)
  Inductive bsteps : nat → relation A :=
    | bsteps_refl n x : bsteps n x x
    | bsteps_l n x y z : R x y → bsteps n y z → bsteps (S n) x z.

  (** The transitive closure. *)
  Inductive tc : relation A :=
    | tc_once x y : R x y → tc x y
    | tc_l x y z : R x y → tc y z → tc x z.

  (** An element [x] is universally looping if all paths starting at [x]
  are infinite. *)
  CoInductive all_loop : A → Prop :=
    | all_loop_do_step x : red x → (∀ y, R x y → all_loop y) → all_loop x.

  (** An element [x] is existentally looping if some path starting at [x]
  is infinite. *)
  CoInductive ex_loop : A → Prop :=
    | ex_loop_do_step x y : R x y → ex_loop y → ex_loop x.
End definitions.

(** The reflexive transitive symmetric closure. *)
Definition rtsc {A} (R : relation A) := rtc (sc R).

(** Weakly and strongly normalizing elements. *)
Definition wn {A} (R : relation A) (x : A) := ∃ y, rtc R x y ∧ nf R y.

Notation sn R := (Acc (flip R)).

(** The various kinds of "confluence" properties. Any relation that has the
diamond property is confluent, and any confluent relation is locally confluent.
The naming convention are taken from "Term Rewriting and All That" by Baader and
Nipkow. *)
Definition diamond {A} (R : relation A) :=
  ∀ x y1 y2, R x y1 → R x y2 → ∃ z, R y1 z ∧ R y2 z.

Definition confluent {A} (R : relation A) :=
  diamond (rtc R).

Definition locally_confluent {A} (R : relation A) :=
  ∀ x y1 y2, R x y1 → R x y2 → ∃ z, rtc R y1 z ∧ rtc R y2 z.

Global Hint Unfold nf red : core.

(** * General theorems *)
Section general.
  Context `{R : relation A}.

  Local Hint Constructors rtc nsteps bsteps tc : core.

  (** ** Results about the reflexive-transitive closure [rtc] *)
  Lemma rtc_transitive x y z : rtc R x y → rtc R y z → rtc R x z.
  Proof. induction 1; eauto. Qed.

  (* We give this instance a lower-than-usual priority because [setoid_rewrite]
     queries for [@Reflexive Prop ?r] in the hope of [iff_reflexive] getting
     picked as the instance.  [rtc_reflexive] overlaps with that, leading to
     backtracking.  We cannot set [Hint Mode] because that query must not fail,
     but we can at least avoid picking [rtc_reflexive].

     See Coq bug https://github.com/coq/coq/issues/7916 and the test
     [tests.typeclasses.test_setoid_rewrite]. *)
  Global Instance rtc_po : PreOrder (rtc R) | 10.
  Proof. split; [exact (@rtc_refl A R) | exact rtc_transitive]. Qed.

  (* Not an instance, related to the issue described above, this sometimes makes
  [setoid_rewrite] queries loop. *)
  Lemma rtc_equivalence : Symmetric R → Equivalence (rtc R).
  Proof.
    split; try apply _.
    intros x y. induction 1 as [|x1 x2 x3]; [done|trans x2; eauto].
  Qed.

  Lemma rtc_once x y : R x y → rtc R x y.
  Proof. eauto. Qed.
  Lemma rtc_r x y z : rtc R x y → R y z → rtc R x z.
  Proof. intros. etrans; eauto. Qed.
  Lemma rtc_inv x z : rtc R x z → x = z ∨ ∃ y, R x y ∧ rtc R y z.
  Proof. inversion_clear 1; eauto. Qed.
  Lemma rtc_ind_l (P : A → Prop) (z : A)
    (Prefl : P z) (Pstep : ∀ x y, R x y → rtc R y z → P y → P x) :
    ∀ x, rtc R x z → P x.
  Proof. induction 1; eauto. Qed.
  Lemma rtc_ind_r_weak (P : A → A → Prop)
    (Prefl : ∀ x, P x x) (Pstep : ∀ x y z, rtc R x y → R y z → P x y → P x z) :
    ∀ x z, rtc R x z → P x z.
  Proof.
    cut (∀ y z, rtc R y z → ∀ x, rtc R x y → P x y → P x z).
    { eauto using rtc_refl. }
    induction 1; eauto using rtc_r.
  Qed.
  Lemma rtc_ind_r (P : A → Prop) (x : A)
    (Prefl : P x) (Pstep : ∀ y z, rtc R x y → R y z → P y → P z) :
    ∀ z, rtc R x z → P z.
  Proof.
    intros z p. revert x z p Prefl Pstep. refine (rtc_ind_r_weak _ _ _); eauto.
  Qed.
  Lemma rtc_inv_r x z : rtc R x z → x = z ∨ ∃ y, rtc R x y ∧ R y z.
  Proof. revert z. apply rtc_ind_r; eauto. Qed.

  Lemma rtc_nf x y : rtc R x y → nf R x → x = y.
  Proof. destruct 1 as [x|x y1 y2]; [done|]. intros []; eauto. Qed.

  Lemma rtc_congruence {B} (f : A → B) (R' : relation B) x y :
    (∀ x y, R x y → R' (f x) (f y)) → rtc R x y → rtc R' (f x) (f y).
  Proof. induction 2; econstructor; eauto. Qed.

  (** ** Results about [nsteps] *)
  Lemma nsteps_once x y : R x y → nsteps R 1 x y.
  Proof. eauto. Qed.
  Lemma nsteps_once_inv x y : nsteps R 1 x y → R x y.
  Proof. inversion 1 as [|???? Hhead Htail]; inversion Htail; by subst. Qed.
  Lemma nsteps_trans n m x y z :
    nsteps R n x y → nsteps R m y z → nsteps R (n + m) x z.
  Proof. induction 1; simpl; eauto. Qed.
  Lemma nsteps_r n x y z : nsteps R n x y → R y z → nsteps R (S n) x z.
  Proof. induction 1; eauto. Qed.

  Lemma nsteps_add_inv n m x z :
    nsteps R (n + m) x z → ∃ y, nsteps R n x y ∧ nsteps R m y z.
  Proof.
    revert x.
    induction n as [|n IH]; intros x Hx; simpl; [by eauto|].
    inversion Hx; naive_solver.
  Qed.

  Lemma nsteps_inv_r n x z : nsteps R (S n) x z → ∃ y, nsteps R n x y ∧ R y z.
  Proof.
    rewrite <- PeanoNat.Nat.add_1_r.
    intros (?&?&?%nsteps_once_inv)%nsteps_add_inv; eauto.
  Qed.

  Lemma nsteps_congruence {B} (f : A → B) (R' : relation B) n x y :
    (∀ x y, R x y → R' (f x) (f y)) → nsteps R n x y → nsteps R' n (f x) (f y).
  Proof. induction 2; econstructor; eauto. Qed.

  (** ** Results about [bsteps] *)
  Lemma bsteps_once n x y : R x y → bsteps R (S n) x y.
  Proof. eauto. Qed.
  Lemma bsteps_add_r n m x y :
    bsteps R n x y → bsteps R (n + m) x y.
  Proof. induction 1; simpl; eauto. Qed.
  Lemma bsteps_weaken n m x y :
    n ≤ m → bsteps R n x y → bsteps R m x y.
  Proof.
    intros. rewrite (Nat.le_add_sub n m); auto using bsteps_add_r.
  Qed.
  Lemma bsteps_add_l n m x y :
    bsteps R n x y → bsteps R (m + n) x y.
  Proof. apply bsteps_weaken. auto with arith. Qed.
  Lemma bsteps_S n x y :  bsteps R n x y → bsteps R (S n) x y.
  Proof. apply bsteps_weaken. lia. Qed.
  Lemma bsteps_trans n m x y z :
    bsteps R n x y → bsteps R m y z → bsteps R (n + m) x z.
  Proof. induction 1; simpl; eauto using bsteps_add_l. Qed.
  Lemma bsteps_r n x y z : bsteps R n x y → R y z → bsteps R (S n) x z.
  Proof. induction 1; eauto. Qed.
  Lemma bsteps_ind_r (P : nat → A → Prop) (x : A)
    (Prefl : ∀ n, P n x)
    (Pstep : ∀ n y z, bsteps R n x y → R y z → P n y → P (S n) z) :
    ∀ n z, bsteps R n x z → P n z.
  Proof.
    cut (∀ m y z, bsteps R m y z → ∀ n,
      bsteps R n x y → (∀ m', n ≤ m' ∧ m' ≤ n + m → P m' y) → P (n + m) z).
    { intros help n. change n with (0 + n). eauto. }
    induction 1 as [|m x' y z p2 p3 IH]; [by eauto with arith|].
    intros n p1 H. rewrite <-plus_n_Sm.
    apply (IH (S n)); [by eauto using bsteps_r |].
    intros [|m'] [??]; [lia |]. apply Pstep with x'.
    - apply bsteps_weaken with n; intuition lia.
    - done.
    - apply H; intuition lia.
  Qed.

  Lemma bsteps_congruence {B} (f : A → B) (R' : relation B) n x y :
    (∀ x y, R x y → R' (f x) (f y)) → bsteps R n x y → bsteps R' n (f x) (f y).
  Proof. induction 2; econstructor; eauto. Qed.

  (** ** Results about the transitive closure [tc] *)
  Lemma tc_transitive x y z : tc R x y → tc R y z → tc R x z.
  Proof. induction 1; eauto. Qed.
  Global Instance tc_transitive' : Transitive (tc R).
  Proof. exact tc_transitive. Qed.
  Lemma tc_r x y z : tc R x y → R y z → tc R x z.
  Proof. intros. etrans; eauto. Qed.
  Lemma tc_rtc_l x y z : rtc R x y → tc R y z → tc R x z.
  Proof. induction 1; eauto. Qed.
  Lemma tc_rtc_r x y z : tc R x y → rtc R y z → tc R x z.
  Proof. intros Hxy Hyz. revert x Hxy. induction Hyz; eauto using tc_r. Qed.
  Lemma tc_rtc x y : tc R x y → rtc R x y.
  Proof. induction 1; eauto. Qed.

  Lemma red_tc x : red (tc R) x ↔ red R x.
  Proof.
    split.
    - intros [y []]; eexists; eauto.
    - intros [y HR]. exists y. by apply tc_once.
  Qed.

  Lemma tc_congruence {B} (f : A → B) (R' : relation B) x y :
    (∀ x y, R x y → R' (f x) (f y)) → tc R x y → tc R' (f x) (f y).
  Proof. induction 2; econstructor; by eauto. Qed.

  (** ** Results about the symmetric closure [sc] *)
  Global Instance sc_symmetric : Symmetric (sc R).
  Proof. unfold Symmetric, sc. naive_solver. Qed.

  Lemma sc_lr x y : R x y → sc R x y.
  Proof. by left. Qed.
  Lemma sc_rl x y : R y x → sc R x y.
  Proof. by right. Qed.

  Lemma sc_congruence {B} (f : A → B) (R' : relation B) x y :
    (∀ x y, R x y → R' (f x) (f y)) → sc R x y → sc R' (f x) (f y).
  Proof. induction 2; econstructor; by eauto. Qed.

  (** ** Equivalences between closure operators *)
  Lemma bsteps_nsteps n x y : bsteps R n x y ↔ ∃ n', n' ≤ n ∧ nsteps R n' x y.
  Proof.
    split.
    - induction 1 as [|n x1 x2 y ?? (n'&?&?)].
      + exists 0; naive_solver eauto with lia.
      + exists (S n'); naive_solver eauto with lia.
    - intros (n'&Hn'&Hsteps). apply bsteps_weaken with n'; [done|].
      clear Hn'. induction Hsteps; eauto.
  Qed.

  Lemma tc_nsteps x y : tc R x y ↔ ∃ n, 0 < n ∧ nsteps R n x y.
  Proof.
    split.
    - induction 1 as [|x1 x2 y ?? (n&?&?)].
      { exists 1. eauto using nsteps_once with lia. }
      exists (S n); eauto using nsteps_l.
    - intros (n & ? & Hstep). induction Hstep as [|n x1 x2 y ? Hstep]; [lia|].
      destruct Hstep; eauto with lia.
  Qed.

  Lemma rtc_tc x y : rtc R x y ↔ x = y ∨ tc R x y.
  Proof.
    split; [|naive_solver eauto using tc_rtc].
    induction 1; naive_solver.
  Qed.

  Lemma rtc_nsteps x y : rtc R x y ↔ ∃ n, nsteps R n x y.
  Proof.
    split.
    - induction 1; naive_solver.
    - intros [n Hsteps]. induction Hsteps; naive_solver.
  Qed.
  Lemma rtc_nsteps_1 x y : rtc R x y → ∃ n, nsteps R n x y.
  Proof. rewrite rtc_nsteps. naive_solver. Qed.
  Lemma rtc_nsteps_2 n x y : nsteps R n x y → rtc R x y.
  Proof. rewrite rtc_nsteps. naive_solver. Qed.

  Lemma rtc_bsteps x y : rtc R x y ↔ ∃ n, bsteps R n x y.
  Proof. rewrite rtc_nsteps. setoid_rewrite bsteps_nsteps. naive_solver. Qed.
  Lemma rtc_bsteps_1 x y : rtc R x y → ∃ n, bsteps R n x y.
  Proof. rewrite rtc_bsteps. naive_solver. Qed.
  Lemma rtc_bsteps_2 n x y : bsteps R n x y → rtc R x y.
  Proof. rewrite rtc_bsteps. naive_solver. Qed.

  Lemma nsteps_list n x y :
    nsteps R n x y ↔ ∃ l,
      length l = S n ∧
      head l = Some x ∧
      last l = Some y ∧
      ∀ i a b, l !! i = Some a → l !! S i = Some b → R a b.
  Proof.
    setoid_rewrite head_lookup. split.
    - induction 1 as [x|n' x x' y ?? IH].
      { exists [x]; naive_solver. }
      destruct IH as (l & Hlen & Hfirst & Hlast & Hcons).
      exists (x :: l). simpl. rewrite Hlen, last_cons, Hlast.
      split_and!; [done..|]. intros [|i]; naive_solver.
    - intros ([|x' l]&?&Hfirst&Hlast&Hcons); simplify_eq/=.
      revert x Hlast Hcons.
      induction l as [|x1 l IH]; intros x2 Hlast Hcons; simplify_eq/=; [constructor|].
      econstructor; [by apply (Hcons 0)|].
      apply IH; [done|]. intros i. apply (Hcons (S i)).
  Qed.

  Lemma bsteps_list n x y :
    bsteps R n x y ↔ ∃ l,
      length l ≤ S n ∧
      head l = Some x ∧
      last l = Some y ∧
      ∀ i a b, l !! i = Some a → l !! S i = Some b → R a b.
  Proof.
    rewrite bsteps_nsteps. split.
    - intros (n'&?&(l&?&?&?&?)%nsteps_list). exists l; eauto with lia.
    - intros (l&?&?&?&?). exists (pred (length l)). split; [lia|].
      apply nsteps_list. exists l. split; [|by eauto]. by destruct l.
  Qed.

  Lemma rtc_list x y :
    rtc R x y ↔ ∃ l,
      head l = Some x ∧
      last l = Some y ∧
      ∀ i a b, l !! i = Some a → l !! S i = Some b → R a b.
  Proof.
    rewrite rtc_bsteps. split.
    - intros (n'&(l&?&?&?&?)%bsteps_list). exists l; eauto with lia.
    - intros (l&?&?&?). exists (pred (length l)).
      apply bsteps_list. exists l. eauto with lia.
  Qed.

  Lemma tc_list x y :
    tc R x y ↔ ∃ l,
      1 < length l ∧
      head l = Some x ∧
      last l = Some y ∧
      ∀ i a b, l !! i = Some a → l !! S i = Some b → R a b.
  Proof.
    rewrite tc_nsteps. split.
    - intros (n'&?&(l&?&?&?&?)%nsteps_list). exists l; eauto with lia.
    - intros (l&?&?&?&?). exists (pred (length l)).
      split; [lia|]. apply nsteps_list. exists l. eauto with lia.
  Qed.

  Lemma ex_loop_inv x :
    ex_loop R x →
    ∃ x', R x x' ∧ ex_loop R x'.
  Proof. inversion 1; eauto. Qed.

End general.

Section more_general.
  Context `{R : relation A}.

  (** ** Results about the reflexive-transitive-symmetric closure [rtsc] *)
  Global Instance rtsc_equivalence : Equivalence (rtsc R) | 10.
  Proof. apply rtc_equivalence, _. Qed.

  Lemma rtsc_lr x y : R x y → rtsc R x y.
  Proof. unfold rtsc. eauto using sc_lr, rtc_once. Qed.
  Lemma rtsc_rl x y : R y x → rtsc R x y.
  Proof. unfold rtsc. eauto using sc_rl, rtc_once. Qed.
  Lemma rtc_rtsc_rl x y : rtc R x y → rtsc R x y.
  Proof. induction 1; econstructor; eauto using sc_lr. Qed.
  Lemma rtc_rtsc_lr x y : rtc R y x → rtsc R x y.
  Proof. intros. symmetry. eauto using rtc_rtsc_rl. Qed.

  Lemma rtsc_congruence {B} (f : A → B) (R' : relation B) x y :
    (∀ x y, R x y → R' (f x) (f y)) → rtsc R x y → rtsc R' (f x) (f y).
  Proof. unfold rtsc; eauto using rtc_congruence, sc_congruence. Qed.

  Lemma ex_loop_tc x :
    ex_loop (tc R) x ↔ ex_loop R x.
  Proof.
    split.
    - revert x; cofix IH.
      intros x (y & Hstep & Hloop')%ex_loop_inv.
      destruct Hstep as [x y Hstep|x y z Hstep Hsteps].
      + econstructor; eauto.
      + econstructor; [by eauto|].
        eapply IH. econstructor; eauto.
    - revert x; cofix IH.
      intros x (y & Hstep & Hloop')%ex_loop_inv.
      econstructor; eauto using tc_once.
  Qed.

End more_general.

Section properties.
  Context `{R : relation A}.

  Local Hint Constructors rtc nsteps bsteps tc : core.

  Lemma nf_wn x : nf R x → wn R x.
  Proof. intros. exists x; eauto. Qed.
  Lemma wn_step x y : wn R y → R x y → wn R x.
  Proof. intros (z & ? & ?) ?. exists z; eauto. Qed.
  Lemma wn_step_rtc x y : wn R y → rtc R x y → wn R x.
  Proof. induction 2; eauto using wn_step. Qed.

  Lemma nf_sn x : nf R x → sn R x.
  Proof. intros Hnf. constructor; intros y Hxy. destruct Hnf; eauto. Qed.
  Lemma sn_step x y : sn R x → R x y → sn R y.
  Proof. induction 1; eauto. Qed.
  Lemma sn_step_rtc x y : sn R x → rtc R x y → sn R y.
  Proof. induction 2; eauto using sn_step. Qed.

  (** An acyclic relation that can only take finitely many steps (sometimes
  called "globally finite") is strongly normalizing *)
  Lemma tc_finite_sn x : Irreflexive (tc R) → pred_finite (tc R x) → sn R x.
  Proof.
    intros Hirr [xs Hfin]. remember (length xs) as n eqn:Hn.
    revert x xs Hn Hfin.
    induction (lt_wf n) as [n _ IH]; intros x xs -> Hfin.
    constructor; simpl; intros x' Hxx'.
    assert (x' ∈ xs) as (xs1&xs2&->)%elem_of_list_split by eauto using tc_once.
    refine (IH (length xs1 + length xs2) _ _ (xs1 ++ xs2) _ _);
      [rewrite app_length; simpl; lia..|].
    intros x'' Hx'x''. feed pose proof (Hfin x'') as Hx''; [by econstructor|].
    cut (x' ≠ x''); [set_solver|].
    intros ->. by apply (Hirr x'').
  Qed.

  (** The following theorem requires that [red R] is decidable. The intuition
  for this requirement is that [wn R] is a very "positive" statement as it
  points out a particular trace. In contrast, [sn R] just says "this also holds
  for all successors", there is no "data"/"trace" there. *)
  Lemma sn_wn `{!∀ y, Decision (red R y)} x : sn R x → wn R x.
  Proof.
    induction 1 as [x _ IH]. destruct (decide (red R x)) as [[x' ?]|?].
    - destruct (IH x') as (y&?&?); eauto using wn_step.
    - by apply nf_wn.
  Qed.

  Lemma all_loop_red x : all_loop R x → red R x.
  Proof. destruct 1; auto. Qed.
  Lemma all_loop_step x y : all_loop R x → R x y → all_loop R y.
  Proof. destruct 1; auto. Qed.
  Lemma all_loop_rtc x y : all_loop R x → rtc R x y → all_loop R y.
  Proof. induction 2; eauto using all_loop_step. Qed.
  Lemma all_loop_alt x :
    all_loop R x ↔ ∀ y, rtc R x y → red R y.
  Proof.
    split; [eauto using all_loop_red, all_loop_rtc|].
    intros H. cut (∀ z, rtc R x z → all_loop R z); [eauto|].
    cofix FIX. constructor; eauto using rtc_r.
  Qed.

  Lemma wn_not_all_loop x : wn R x → ¬all_loop R x.
  Proof. intros (z&?&?). rewrite all_loop_alt. eauto. Qed.
  Lemma sn_not_ex_loop x : sn R x → ¬ex_loop R x.
  Proof. unfold not. induction 1; destruct 1; eauto. Qed.

  (** An alternative definition of confluence; also known as the Church-Rosser
  property. *)
  Lemma confluent_alt :
    confluent R ↔ (∀ x y, rtsc R x y → ∃ z, rtc R x z ∧ rtc R y z).
  Proof.
    split.
    - intros Hcr. induction 1 as [x|x y1 y1' [Hy1|Hy1] Hy1' (z&IH1&IH2)]; eauto.
      destruct (Hcr y1 x z) as (z'&?&?); eauto using rtc_transitive.
    - intros Hcr x y1 y2 Hy1 Hy2.
      apply Hcr; trans x; eauto using rtc_rtsc_rl, rtc_rtsc_lr.
  Qed.

  Lemma confluent_nf_r x y :
    confluent R → rtsc R x y → nf R y → rtc R x y.
  Proof.
    rewrite confluent_alt. intros Hcr ??. destruct (Hcr x y) as (z&Hx&Hy); auto.
    by apply rtc_nf in Hy as ->.
  Qed.
  Lemma confluent_nf_l x y :
    confluent R → rtsc R x y → nf R x → rtc R y x.
  Proof. intros. by apply (confluent_nf_r y x). Qed.

  Lemma diamond_confluent :
    diamond R → confluent R.
  Proof.
    intros Hdiam. assert (∀ x y1 y2,
      rtc R x y1 → R x y2 → ∃ z, rtc R y1 z ∧ rtc R y2 z) as Hstrip.
    { intros x y1 y2 Hy1; revert y2.
      induction Hy1 as [x|x y1 y1' Hy1 Hy1' IH]; [by eauto|]; intros y2 Hy2.
      destruct (Hdiam x y1 y2) as (z&Hy1z&Hy2z); auto.
      destruct (IH z) as (z'&?&?); eauto. }
    intros x y1 y2 Hy1; revert y2.
    induction Hy1 as [x|x y1 y1' Hy1 Hy1' IH]; [by eauto|]; intros y2 Hy2.
    destruct (Hstrip x y2 y1) as (z&?&?); eauto.
    destruct (IH z) as (z'&?&?); eauto using rtc_transitive.
  Qed.

  Lemma confluent_locally_confluent :
    confluent R → locally_confluent R.
  Proof. unfold confluent, locally_confluent; eauto. Qed.

  (** The following is also known as Newman's lemma *)
  Lemma locally_confluent_confluent :
    (∀ x, sn R x) → locally_confluent R → confluent R.
  Proof.
    intros Hsn Hcr x. induction (Hsn x) as [x _ IH].
    intros y1 y2 Hy1 Hy2. destruct Hy1 as [x|x y1 y1' Hy1 Hy1']; [by eauto|].
    destruct Hy2 as [x|x y2 y2' Hy2 Hy2']; [by eauto|].
    destruct (Hcr x y1 y2) as (z&Hy1z&Hy2z); auto.
    destruct (IH _ Hy1 y1' z) as (z1&?&?); auto.
    destruct (IH _ Hy2 y2' z1) as (z2&?&?); eauto using rtc_transitive.
  Qed.
End properties.

(** * Theorems on sub relations *)
Section subrel.
  Context {A} (R1 R2 : relation A).
  Notation subrel := (∀ x y, R1 x y → R2 x y).
  Lemma red_subrel x : subrel → red R1 x → red R2 x.
  Proof. intros ? [y ?]; eauto. Qed.
  Lemma nf_subrel x : subrel → nf R2 x → nf R1 x.
  Proof. intros ? H1 H2; destruct H1; by apply red_subrel. Qed.
  Lemma rtc_subrel x y : subrel → rtc R1 x y → rtc R2 x y.
  Proof. induction 2; [by apply rtc_refl|]. eapply rtc_l; eauto. Qed.
End subrel.


Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts MoreEnumerabilityFacts.

Require Import List.
Import ListNotations.
Require Import Dec.

Set Implicit Arguments.

Set Default Proof Using "Type".

(* ** Pre-order properties *)

Section Properties.

  Variables (X : Type) (P : X -> Prop)
            (Y : Type) (Q : Y -> Prop)
            (Z : Type) (R : Z -> Prop).

  Fact reduces_reflexive : P ⪯ P.
  Proof. exists (fun x => x); red; tauto. Qed.

  Fact reduces_transitive : P ⪯ Q -> Q ⪯ R -> P ⪯ R.
  Proof.
    unfold reduces, reduction.
    intros (f & Hf) (g & Hg).
    exists (fun x => g (f x)).
    intro; rewrite Hf, Hg; tauto.
  Qed.

  (* ** An equivalent dependent definition *)

  Fact reduces_dependent :
    P ⪯ Q <-> inhabited (forall x, { y | P x <-> Q y }).
  Proof.
    constructor.
    - intros [f Hf]. constructor. intros x. now exists (f x).
    - intros [f]. exists (fun x => proj1_sig (f x)).
      intros x. exact (proj2_sig (f x)).
  Qed.

  Fact reduces_complement : P ⪯ Q -> complement P ⪯ complement Q.
  Proof.
    intros [f Hf].
    exists f. intros x. specialize (Hf x). split.
    all: intros H Hc; apply H, Hf, Hc.
  Qed.

End Properties.

Module ReductionChainNotations.

(* DLW: Thx to M. Wuttke for the tip, see coq-club ML *)

Ltac redchain2Prop_rec xs :=
  lazymatch xs with
  | pair ?x (pair ?y ?xs) =>
    let z := redchain2Prop_rec (pair y xs) in
    constr:(x ⪯ y /\ z)
  | pair ?x ?y => constr:(x ⪯ y)
  end.

Ltac redchain2Prop xs :=
  let z := redchain2Prop_rec xs
  in  exact z.

Declare Scope reduction_chain.
Delimit Scope reduction_chain with redchain_scope.
Notation "x '⪯ₘ' y" := (pair x y) (at level 80, right associativity, only parsing) : reduction_chain.
Notation "'⎩' xs '⎭'" := (ltac:(redchain2Prop (xs % redchain_scope))) (only parsing).

(*
Definition Undec_Problem := { X : Type & X -> Prop }.

Definition undec_problem X (P : X -> Prop) : Undec_Problem := existT _ X P.

Notation "⎩ p ⎭" := (@undec_problem _ p) (format "⎩ p ⎭").

Infix "⪯ₚ" := (fun p q : Undec_Problem => projT2 p ⪯ projT2 q : Prop) (at level 70).

Reserved Notation "p '⪯ₗ' q 'by' l" (at level 70).

Section reduction_chain.

  Inductive reduction_chain : Undec_Problem -> Undec_Problem -> list Undec_Problem -> Prop :=
    | reduction_chain_nil  : forall p, p ⪯ₗ p by nil
    | reduction_chain_cons : forall p q r l, p ⪯ₚ q -> q ⪯ₗ r by l -> p ⪯ₗ r by q::l
  where "p '⪯ₗ' q 'by' l" := (reduction_chain p q l).

  Fact reduction_chain_reduces p q l : p ⪯ₗ q by l -> p ⪯ₚ q.
  Proof.
    induction 1 as [ p | p q r l H1 _ ? ].
    + apply reduces_reflexive.
    + apply reduces_transitive with (1 := H1); trivial.
  Qed.

  Fact reduction_chain_app p q r l m : p ⪯ₗ q by l -> q ⪯ₗ r by m -> p ⪯ₗ r by l++m.
  Proof.
    induction 1; intros; auto.
    constructor 2; auto.
  Qed.

End reduction_chain.

Notation "p '⪯ₗ' q 'by' l" := (reduction_chain p q l).

Tactic Notation "red" "chain" "stop" := constructor 1.
Tactic Notation "red" "chain" "step" constr(H) := constructor 2; [ apply H | ].
Tactic Notation "red" "chain" "app" constr(H) := apply reduction_chain_app with (1 := H).
*)

End ReductionChainNotations.

Lemma dec_red X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> decidable q -> decidable p.
Proof.
  unfold decidable, decider, reduces, reduction, reflects.
  intros [f] [d]. exists (fun x => d (f x)). intros x. rewrite H. eapply H0.
Qed.

Lemma red_comp X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> (fun x => ~ p x) ⪯ (fun y => ~ q y).
Proof.
  intros [f]. exists f. intros x. red in H. now rewrite H.
Qed.

Section enum_red.

  Variables (X Y : Type) (p : X -> Prop) (q : Y -> Prop).
  Variables (f : X -> Y) (Hf : forall x, p x <-> q (f x)).

  Variables (Lq : _) (qe : list_enumerator Lq q).

  Variables (x0 : X).

  Variables (d : eq_dec Y).

  Local Fixpoint L L' n :=
    match n with
    | 0 => []
    | S n => L L' n ++ (filter (fun x => Dec (In (f x) (cumul Lq n))) (cumul L' n))
    end.

  Local Lemma enum_red L' :
    list_enumerator__T L' X ->
    list_enumerator (L L') p.
  Proof using qe Hf.
    intros HL'.
    split.
    + intros H.
      eapply Hf in H. eapply (cumul_spec qe) in H as [m1]. destruct (cumul_spec__T HL' x) as [m2 ?].
      exists (1 + m1 + m2). cbn. apply in_app_iff. right.
      apply filter_In. split.
      * eapply cum_ge'; eauto; lia.
      * eapply Dec_auto. eapply cum_ge'; eauto; lia.
    + intros [m H]. induction m.
      * inversion H.
      * cbn in H. apply in_app_or in H. destruct H; [now auto|].
        apply filter_In in H. destruct H as [_ H].
        destruct (Dec _) in H; [|easy].
        eapply Hf. eauto.
  Qed.

End enum_red.

Lemma enumerable_red X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> discrete Y -> enumerable q -> enumerable p.
Proof.
  intros [f] [] % enum_enumT [] % discrete_iff [L] % enumerable_enum.
  eapply list_enumerable_enumerable.
  eexists. eapply enum_red; eauto.
Qed.

Theorem not_decidable X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> ~ enumerable (complement p) ->
  ~ decidable q /\ ~ decidable (complement q).
Proof.
  intros. split; intros ?.
  - eapply H1. eapply dec_red in H2; eauto.
    eapply dec_compl in H2. eapply dec_count_enum; eauto.
  - eapply H1. eapply dec_red in H2; eauto.
    eapply dec_count_enum; eauto. now eapply red_comp.
Qed.

Theorem not_coenumerable X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> ~ enumerable (complement p) -> discrete Y ->
  ~ enumerable (complement q).
Proof.
  intros. intros ?. eapply H1. eapply enumerable_red in H3; eauto.
  now eapply red_comp.
Qed.


From Coq Require Import ssreflect.
From stdpp Require Import namespaces countable list.

(** List difference. *)

Definition list_minus {A:Type} `{EqDecision A} (l1 l2 : list A) :=
  (max_prefix l1 l2).1.1.

Lemma list_minus_nil_r {A:Type} `{EqDecision A} (l : list A) :
  list_minus l [] = l.
Proof. by destruct l. Qed.

Lemma list_minus_nil_l {A:Type} `{EqDecision A} (l : list A) :
  list_minus [] l = [].
Proof. by destruct l. Qed.

Lemma list_minus_prefix_app {A : Type} `{EqDecision A}
      (l1 l2 l3 : list A) :
  l1 `prefix_of` l2 →
  list_minus (l2 ++ l3) l1 = (list_minus l2 l1) ++ l3.
Proof.
  revert l1.
  induction l2 as [|x l2 IHl2]; intros l1 Hprefix.
  - apply prefix_nil_inv in Hprefix. rewrite Hprefix.
    by rewrite list_minus_nil_r.
  - destruct l1 as [|y l1]; [by rewrite list_minus_nil_r|].
    rewrite /list_minus. simpl.
    case_decide; [|by apply prefix_cons_inv_1 in Hprefix].
    subst. apply IHl2.
    by eapply prefix_cons_inv_2.
Qed.

Lemma list_minus_prefix_length {A : Type} `{EqDecision A}
      (l1 l2 : list A) :
  l1 `prefix_of` l2 → length (list_minus l2 l1) = length l2 - length l1.
Proof.
  generalize dependent l1.
  induction l2 as [|x l2 IHl2]; [done|]; intros l1 Hprefix.
  destruct l1; [done|].
  rewrite /list_minus. simpl.
  case_decide; [|by apply prefix_cons_inv_1 in Hprefix].
  subst. apply IHl2.
  by eapply prefix_cons_inv_2.
Qed.

Lemma list_minus_id_nil {A : Type} `{EqDecision A} (l : list A) :
  list_minus l l = [].
Proof. induction l; [done|]. rewrite /list_minus /=. by case_decide. Qed.

Lemma list_minus_cons {A : Type} `{EqDecision A} x (l1 l2 : list A) :
  list_minus l2 l1 = list_minus (x::l2) (x::l1).
Proof. rewrite /list_minus. destruct l1 as [|y l1]; simpl; by case_decide. Qed.

Lemma list_minus_alt {A : Type} `{EqDecision A} (l1 l2 : list A) :
  l1 `prefix_of` l2 →
  list_minus l2 l1 = drop (length l1) l2.
Proof.
  revert l2.
  induction l1 as [|x l1 IHl1]; intros l2 Hprefix.
  { rewrite list_minus_nil_r. done. }
  destruct l2 as [|y l2]; [done|].
  assert (x = y) as -> by by eapply prefix_cons_inv_1.
  rewrite -list_minus_cons. apply IHl1. by eapply prefix_cons_inv_2.
Qed.


Require Import Basics.
Require Import Equalities.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import Relation_Definitions.
Require Import SetoidClass.
Open Scope program_scope.

Lemma id_left_unit : forall {A B : Type} (f : A -> B), id ∘ f = f.
Proof. intros A B f; unfold compose; extensionality x; reflexivity. Qed.
Lemma id_right_unit : forall {A B : Type} (f : A -> B), f ∘ id = f.
Proof. intros A B f; unfold compose; extensionality x; reflexivity. Qed.

Class Category :=
  { Obj : Type
  ; Hom : Obj -> Obj -> Type
  ; HomSetoid :> forall X Y : Obj, Setoid (Hom X Y)
  ; comp : forall {A B C : Obj}, Hom B C -> Hom A B -> Hom A C
  ; comp_assoc : forall {A B C D : Obj} (f : Hom C D) (g : Hom B C) (h : Hom A B),
                   comp (comp f g) h == comp f (comp g h)
  ; comp_resp_equiv : forall {A B C : Obj},
                        Proper (equiv ==> equiv ==> equiv) (@comp A B C)
  ; ident : forall {A : Obj}, Hom A A
  ; ident_left_unit : forall {A B : Obj} (f : Hom A B), comp ident f == f
  ; ident_right_unit : forall {A B : Obj} (f : Hom A B), comp f ident == f }.
Notation "f ⊚ g" := (comp f g) (at level 40, left associativity).
Notation "A ~> B" := (Hom A B) (at level 60, right associativity).
Definition dom {C : Category} {A B : Obj} (f : A ~> B) := A.
Definition cod {C : Category} {A B : Obj} (f : A ~> B) := B.

Hint Extern 0 (Reflexive equiv) =>
  apply (@Equivalence_Reflexive _ _ (HomSetoid _ _)) : typeclass_instances.
Hint Extern 0 (Symmetric equiv) =>
  apply (@Equivalence_Symmetric _ _ (HomSetoid _ _)) : typeclass_instances.
Hint Extern 0 (Transitive equiv) =>
  apply (@Equivalence_Transitive _ _ (HomSetoid _ _)) : typeclass_instances.

Definition Inverse {C : Category} {A B : Obj} (f : A ~> B) (g : B ~> A) : Prop :=
  (f ⊚ g == ident) /\ (g ⊚ f == ident).
Definition Iso {C : Category} (A B : Obj) : Prop :=
  exists (f : A ~> B) (g : B ~> A), Inverse f g.
Notation "A ≅ B" := (Iso A B) (at level 50, no associativity).

Lemma comp_cong : forall {Cat : Category} {A B : Obj} {g h : A ~> B},
                    g == h -> forall {C} (f : Hom B C), f ⊚ g == f ⊚ h.
Proof. intros Cat A B g h gEh C f; apply comp_resp_equiv; [reflexivity | assumption]. Qed.

Lemma equiv_left_inv : forall {Cat : Category} {A B C : Obj} {g h : A ~> B} {f : B ~> C},
                         f ⊚ g == f ⊚ h -> forall {fi}, fi ⊚ f == ident -> g == h.
Proof.
  intros Cat A B C g h f fgEfh fi inv.
  transitivity (fi ⊚ f ⊚ g).
    transitivity (ident ⊚ g).
      symmetry; apply ident_left_unit.
    apply comp_resp_equiv; [symmetry; assumption | reflexivity].
  transitivity (fi ⊚ f ⊚ h).
    repeat rewrite comp_assoc.
  apply comp_resp_equiv; [reflexivity | assumption].
  transitivity (ident ⊚ h).
    apply comp_resp_equiv; [assumption | reflexivity].
  apply ident_left_unit.
Qed.

Lemma ident_inverse : forall {C : Category} {A : Obj}, Inverse ident (ident (A:=A)).
Proof. intros C A; split; apply ident_left_unit. Qed.

Lemma inverse_uniqueness :
  forall {C : Category} {A B : Obj} (f : A ~> B) (g1 g2 : B ~> A),
    Inverse f g1 -> Inverse f g2 -> g1 == g2.
Proof.
  intros C A B f g1 g2 invG1 invG2.
  destruct invG1, invG2.
  rewrite <- H1 in H.
  apply (equiv_left_inv H H2).
Qed.

Lemma comp_inverse
  : forall {Cat : Category} {A B C : Obj} {f : B ~> C} {fi} {g : A ~> B} {gi},
      Inverse f fi -> Inverse g gi -> Inverse (f ⊚ g) (gi ⊚ fi).
Proof.
  intros Cat A B C f fi g gi finv ginv; split.
  transitivity (f ⊚ ident ⊚ fi).
  rewrite comp_assoc.
  apply comp_resp_equiv.
    symmetry; apply ident_right_unit.
  rewrite <- comp_assoc.
  destruct ginv.
  transitivity (ident ⊚ fi).
    apply comp_resp_equiv; [assumption | reflexivity].
  apply ident_left_unit.
  transitivity (f ⊚ fi).
    rewrite comp_assoc; apply comp_cong; apply ident_left_unit.
  destruct finv.
  assumption.

  transitivity (gi ⊚ ident ⊚ g).
  rewrite comp_assoc.
  apply comp_resp_equiv.
    symmetry; apply ident_right_unit.
  rewrite <- comp_assoc.
  destruct finv.
  transitivity (ident ⊚ g).
    apply comp_resp_equiv; [assumption | reflexivity].
  apply ident_left_unit.
  transitivity (gi ⊚ g).
    rewrite comp_assoc; apply comp_cong; apply ident_left_unit.
  destruct ginv.
  assumption.
Qed.

Lemma inverse_sym : forall {C : Category} {A B : Obj} {f : A ~> B} {fi : B ~> A},
                      Inverse f fi -> Inverse fi f.
Proof. intros C A B f fi finv; destruct finv; split; assumption. Qed.

Class Functor (C D : Category) :=
  { omap : @Obj C -> @Obj D
  ; fmap : forall {c1 c2 : @Obj C}, c1 ~> c2 -> omap c1 ~> omap c2
  ; fmap_id : forall c : @Obj C, fmap ident == @ident D (omap c)
  ; fmap_dist : forall {c1 c2 c3 : @Obj C} (f : c2 ~> c3) (g : c1 ~> c2),
                  fmap (f ⊚ g) == fmap f ⊚ fmap g }.

(*
Section Rel.
  Instance Rel_Category : Category :=
    {| Obj := Set
     ; Hom := fun (A B : Set) => A -> B -> Prop
     ; FEq := fun P Q => eq
     ; Equiv := fun P Q => eq_equivalence
     ; comp := fun A B C P Q => fun a c => exists b, P b c /\ Q a b
     ; ident := fun A => fun a b => a = b |}.
  Proof.
    intros A B C D P Q R; extensionality a; extensionality c.
    intros A B P; extensionality a; extensionality b.
    intros A B P. extensionality a; extensionality b.
End Rel.
*)

Section Preorder.
  Class Preorder (P : Set) :=
    { Lt : P -> P -> Prop
    ; preorder_refl : forall a, Lt a a
    ; preorder_trans : forall {a b c}, Lt a b -> Lt b c -> Lt a c }.
  Instance Preoder_Category {P : Set} `{Preorder P} : Category :=
    {| Obj := P
     ; Hom := Lt
     ; HomSetoid := fun A B => {| equiv := eq |}
     ; comp := fun A B C bLc aLb => preorder_trans aLb bLc
     ; comp_assoc := fun A B C D f g h => proof_irrelevance _ _ _
     ; comp_resp_equiv := fun a b c bLc bLc' _ aLb aLb' _ => proof_irrelevance _ _ _
     ; ident := preorder_refl
     ; ident_left_unit := fun A B f => proof_irrelevance _ _ _
     ; ident_right_unit := fun A B f => proof_irrelevance _ _ _ |}.
End Preorder.

Section Poset.
  Class Poset (A : Set) :=
    { Lte : A -> A -> Prop
    ; poset_refl : forall a, Lte a a
    ; poset_trans : forall {a b c}, Lte a b -> Lte b c -> Lte a c
    ; poset_antisym : forall {a b}, Lte a b -> Lte b a -> a = b }.
  Definition monotone {A B : Set} `{PA : Poset A}`{PB : Poset B} (m : A -> B) : Prop :=
    forall a a', Lte a a' -> Lte (m a) (m a').
  Definition monotone_comp {A B C : Set} `{PA : Poset A}`{PB : Poset B}`{PC : Poset C}
    {n : B -> C} {m : A -> B} : monotone n -> monotone m -> monotone (n ∘ m) :=
    fun mn mm a a' aLa' => mn _ _ (mm _ _ aLa').
  Instance Posets_Category : Category :=
    {| Obj := {A : Set & Poset A}
     ; HomSetoid := fun A B => {| equiv := eq |}
     ; Hom := fun (A B : sigT Poset) =>
               {f : projT1 A -> projT1 B | monotone (PA:=projT2 A)(PB:=projT2 B) f }
     ; comp := fun A B C f g => exist monotone (projT1 f ∘ projT1 g)
                                      (monotone_comp (projT2 f) (projT2 g))
     ; ident := fun A => exist monotone id (fun a a' aLa' => aLa') |}.
  Proof.
    intros A B C D f g h; simpl; reflexivity.
    intros A B f; destruct f; unfold monotone_comp, id, compose; simpl; f_equal.
    intros A B f; destruct f; unfold monotone_comp, id, compose; simpl; f_equal.
  Defined.

  Instance Poset_Category (P : Set) `{Poset P} : Category :=
    {| Obj := P
     ; Hom := Lte
     ; HomSetoid := fun p1 p2 => {| equiv := eq |}
     ; comp := fun p1 p2 p3 p2Lp3 p1Lp2 => poset_trans p1Lp2 p2Lp3
     ; comp_assoc := fun p1 p2 p3 p4 p3Lp4 p2Lp3 p1Lp2 => proof_irrelevance _ _ _
     ; comp_resp_equiv := fun _ _ _ _ _ _ _ _ _ => proof_irrelevance _ _ _
     ; ident := poset_refl
     ; ident_left_unit := fun p1 p2 p1Lp2 => proof_irrelevance _ _ _
     ; ident_right_unit := fun p1 p2 p1Lp2 => proof_irrelevance _ _ _ |}.
End Poset.

Module Type T0.
  Variable X : Set.
  Definition Subset (X : Set) := X -> Prop.
  Variable Tau : Subset X -> Prop.
  Definition Open (U : Subset X) := Tau U.

  Definition Empty : Subset X := fun x => False.
  Parameter Empty_open : Open Empty.

  Definition All (X : Set) : Subset X := fun x => True.
  Parameter X_open : Open (All X).

  Parameter Union_open : forall U V, Open U -> Open V -> Open (fun x => U x \/ V x).
  Parameter Intersection_open : forall U V, Open U -> Open V -> Open (fun x => U x /\ V x).

  Definition In (p : X) (S : Subset X) := S p.
  Definition Contains (S R : Subset X) := forall p, S p -> R p.
  Notation "S <= R" := (Contains S R) (at level 70, no associativity).

  Definition N (p : X) (V : Subset X) :=
    exists (U : Subset X), Open U /\ In p U /\ U <= V.
  Parameter Kolmogorov
    : forall p1 p2, p1 <> p2 -> (exists V, Open V /\ N p1 V /\ ~In p2 V ) \/
                                (exists V, Open V /\ N p2 V /\ ~In p1 V).
End T0.

Module Topology (Import t0 : T0).
  Hypothesis LEM : forall p1 p2 : X, p1 = p2 \/ p1 <> p2.

  Instance Specialization_Poset : Poset X :=
    {| Lte := fun x y => forall U, Open U -> In x U -> In y U |}.
  Proof.
    intros a U OU Ua; assumption.
    intros a b c aLb bLc U OU Ua; refine (bLc U OU _); apply (aLb U OU Ua).
    intros a b aLb bLa.
    assert (H : a = b \/ a <> b) by apply LEM; destruct H.
      assumption.
      assert ((exists V, Open V /\ N a V /\ ~In b V) \/
              (exists V, Open V /\ N b V /\ ~In a V)) by apply (Kolmogorov _ _ H).
      destruct H0; destruct H0 as [V H0]; destruct H0; destruct H1; destruct H1 as [W H1];
      destruct H1; destruct H3.
        assert (In b W) by apply (aLb W H1 H3).
        assert (In b V) by (apply H4; assumption).
        exfalso; apply H2; assumption.

        assert (In a W) by apply (bLa W H1 H3).
        assert (In a V) by (apply H4; assumption).
        exfalso; apply H2; assumption.
  Defined.
End Topology.

Instance Dis_Category (X : Set) : Category :=
  {| Obj := X
   ; Hom := fun x1 x2 => x1 = x2
   ; HomSetoid := fun x1 x2 => {| equiv := eq |}
   ; comp := fun x1 x2 x3 x2Ex3 x1Ex2 => eq_trans x1Ex2 x2Ex3
   ; comp_assoc := fun x1 x2 x3 x4 x1Ex2 x2Ex3 x3Ex4 => proof_irrelevance _ _ _
   ; comp_resp_equiv := fun _ _ _ _ _ _ _ _ _ => proof_irrelevance _ _ _
   ; ident := fun x => eq_refl
   ; ident_left_unit := fun x1 x2 x1Ex2 => proof_irrelevance _ _ _
   ; ident_right_unit := fun x1 x2 x1Ex2 => proof_irrelevance _ _ _ |}.

Section Monoid.
  Class Monoid (M : Type) `{Setoid M} :=
    { mul : M -> M -> M
    ; mul_assoc : forall m1 m2 m3, mul m1 (mul m2 m3) == mul (mul m1 m2) m3
    ; one : M
    ; one_left_unit : forall m, mul one m == m
    ; one_right_unit : forall m, mul m one == m }.

  Definition MonHom {M N : Type} `{MM : Monoid M} `{MN : Monoid N} (f : M -> N) :=
    Proper (equiv ==> equiv) f /\
    f one == one /\
    forall m1 m2, f (mul m1 m2) == mul (f m1) (f m2).

  Lemma comp_MonHom
    : forall {M N P : Type} `{Monoid M}`{Monoid N}`{Monoid P} {f : N -> P}{g : M -> N},
        MonHom f -> MonHom g -> MonHom (f ∘ g).
  Proof.
    intros M N P SM MM SN MN SP MP f g hf hg.
    destruct hf, hg.
    destruct H0, H2.
    split.
      intros x y xEy; unfold compose; repeat f_equiv; assumption.
      split.
        unfold compose; rewrite H2; assumption.
        intros m1 m2; unfold compose; rewrite H4; apply H3.
  Defined.

  Lemma id_MonHom : forall {M : Type} `{Monoid M}, MonHom id.
  Proof.
    intros M SM MM.
    split.
      intros x y xEy; assumption.
      split; [| intros]; reflexivity.
  Qed.

  Instance Monoids_Category : Category :=
    {| Obj := {Mon : Set & {SMon : Setoid Mon & Monoid Mon (H:=SMon)}}
     ; Hom := fun M N => sig (MonHom (H:=projT1 (projT2 M))(MM:=projT2 (projT2 M))
                                     (H0:=projT1 (projT2 N))(MN:=projT2 (projT2 N)))
     ; HomSetoid := fun M N => {| equiv := eq |}
     ; comp := fun M N P f g => existT _ (projT1 f ∘ projT1 g)
                                       (comp_MonHom (projT2 f) (projT2 g))
     ; ident := fun M => existT _ id id_MonHom |}.
  Proof.
    intros A B C D f g h; simpl; f_equal; apply proof_irrelevance.
    intros A B f; destruct f; destruct m; simpl; f_equal; apply proof_irrelevance.
    intros A B f; destruct f; simpl; f_equal; apply proof_irrelevance.
  Defined.

  Instance Comp_Monoid (X : Type) : forall S : Setoid (X -> X), Monoid (X -> X) :=
    {| mul := compose
     ; mul_assoc := fun m1 m2 m3 => reflexivity _
     ; one := id
     ; one_left_unit := fun m => reflexivity _
     ; one_right_unit := fun m => reflexivity _ |}.

  Class Group (G : Type) `{Monoid G} :=
    { inv : G -> G
    ; inv_inverse : forall g, mul (inv g) g == one }.
  Definition Aut {C : Category} (X : Obj) := {f : X ~> X & {g : X ~> X | Inverse f g}}.

  Instance Aut_Setoid {C : Category} (X : Obj) : Setoid (Aut X) :=
    {| equiv := fun f f' =>
         projT1 f == projT1 f' /\ projT1 (projT2 f) == projT1 (projT2 f')|}.
  Proof.
    split.
      intro; split; reflexivity.
      intros ? ? H; destruct H; split; symmetry; assumption.
      intros ? y ? H H0; destruct H, H0; split;
        [transitivity (projT1 y) | transitivity (projT1 (projT2 y))]; assumption.
  Defined.

  Definition aut_comp {C : Category} {X : Obj} (f g : Aut X) : Aut X :=
    existT _ (projT1 f ⊚ projT1 g)
          (exist _ (projT1 (projT2 g) ⊚ projT1 (projT2 f))
                 (comp_inverse (projT2 (projT2 f)) (projT2 (projT2 g)))).

  Instance Aut_Monoid {C : Category} (X : Obj) : Monoid (Aut X) :=
    {| mul := aut_comp
     ; one := existT _ ident (exist _ ident ident_inverse) |}.
  Proof.
    intros f g h; destruct f, g, h; simpl; split; [symmetry |]; apply comp_assoc.
    intro f; simpl; split; [apply ident_left_unit | apply ident_right_unit].
    intro f; simpl; split; [apply ident_right_unit | apply ident_left_unit].
  Defined.

  Definition aut_inv {C : Category} {X : Obj} (f : Aut X) : Aut X :=
    existT _ (projT1 (projT2 f))
           (exist _ (projT1 f) (inverse_sym (projT2 (projT2 f)))).
  Instance Aut_Group {C : Category} (X : Obj) : Group (Aut X) :=
    {| inv := aut_inv |}.
  Proof.
    intros g; destruct g; destruct s; destruct i; simpl; split; assumption.
  Defined.

  Instance Perm_Setoid {C : Category} (X : Obj) (P : Aut X -> Prop)
    : Setoid {g : Aut X | P g} :=
    {| equiv := fun f f' => proj1_sig f == proj1_sig f' |}.
  Proof.
    split.
      intro x; reflexivity.
      intros x y xEy; symmetry; assumption.
      intros x y z xEy yEz; transitivity (proj1_sig y); assumption.
  Defined.

  Instance Perm_Monoid {C : Category} (X : Obj) (P : Aut X -> Prop)
    (Pone : P one) (Pcomp : forall f g, P f -> P g -> P (aut_comp f g))
    : Monoid {g : Aut X | P g} :=
    {| mul := fun f g => exist _ (aut_comp (proj1_sig f) (proj1_sig g))
                               (Pcomp _ _ (proj2_sig f) (proj2_sig g))
     ; one := exist _ (existT _ ident (exist _ ident ident_inverse)) Pone |}.
  Proof.
    intros m1 m2 m3; destruct m1, m2, m3; simpl; split; [symmetry |]; apply comp_assoc.
    intro m; simpl; split; [apply ident_left_unit | apply ident_right_unit].
    intro m; simpl; split; [apply ident_right_unit | apply ident_left_unit].
  Defined.

  Instance Perm_Group {C : Category} (X : Obj) (P : Aut X -> Prop)
    (Pone : P one)
    (Pcomp : forall f g, P f -> P g -> P (aut_comp f g))
    (Pinv : forall f, P f -> P (aut_inv f))
    : Group (H0:=Perm_Monoid X P Pone Pcomp) {g : Aut X | P g} :=
    {| inv := fun f => exist _ (aut_inv (proj1_sig f)) (Pinv _ (proj2_sig f)) |}.
  Proof.
    intros f; destruct f; destruct x; destruct s; destruct i; simpl; split; assumption.
  Defined.

  Definition GroupHom {G H : Set} `{GG : Group G} `{GH : Group H} (h : G -> H) : Prop :=
    MonHom h /\ forall g : G, h (inv g) == inv (h g).
  Definition GroupIso {G H : Set} `{GG : Group G} `{GH : Group H} (h : G -> H) : Prop :=
    GroupHom h /\ exists hi : H -> G, GroupHom hi /\
                                      (forall x, h (hi x) == x) /\
                                      forall x, hi (h x) == x.

  Theorem Cayley : forall (G : Set) `(Group G), exists H `(Group H) h, GroupIso h.
  Proof.
    intros G H MG GG.
  Qed.
End Monoid.


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

Require Import Rbase Equalities Orders OrdersTac.

Local Open Scope R_scope.

(** * DecidableType structure for real numbers *)

Lemma Req_dec : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
Proof.
  intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
    intuition eauto 3.
Qed.

Definition Reqb r1 r2 := if Req_dec r1 r2 then true else false.
Lemma Reqb_eq : forall r1 r2, Reqb r1 r2 = true <-> r1=r2.
Proof.
 intros; unfold Reqb; destruct Req_dec as [EQ|NEQ]; auto with *.
 split; try discriminate. intro EQ; elim NEQ; auto.
Qed.

Module R_as_UBE <: UsualBoolEq.
 Definition t := R.
 Definition eq := @eq R.
 Definition eqb := Reqb.
 Definition eqb_eq := Reqb_eq.
End R_as_UBE.

Module R_as_DT <: UsualDecidableTypeFull := Make_UDTF R_as_UBE.

(** Note that the last module fulfills by subtyping many other
    interfaces, such as [DecidableType] or [EqualityType]. *)

(** Note that [R_as_DT] can also be seen as a [DecidableType]
    and a [DecidableTypeOrig]. *)

(** * OrderedType structure for binary integers *)

Definition Rcompare x y :=
 match total_order_T x y with
  | inleft (left _) => Lt
  | inleft (right _) => Eq
  | inright _ => Gt
 end.

Lemma Rcompare_spec : forall x y, CompareSpec (x=y) (x<y) (y<x) (Rcompare x y).
Proof.
 intros. unfold Rcompare.
 destruct total_order_T as [[H|H]|H]; auto.
Qed.

Module R_as_OT <: OrderedTypeFull.
 Include R_as_DT.
 Definition lt := Rlt.
 Definition le := Rle.
 Definition compare := Rcompare.

 Instance lt_strorder : StrictOrder Rlt.
 Proof. split; [ exact Rlt_irrefl | exact Rlt_trans ]. Qed.

 Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Rlt.
 Proof. repeat red; intros; subst; auto. Qed.

 Lemma le_lteq : forall x y, x <= y <-> x < y \/ x = y.
 Proof. unfold Rle; auto with *. Qed.

 Definition compare_spec := Rcompare_spec.

End R_as_OT.

(** Note that [R_as_OT] can also be seen as a [UsualOrderedType]
   and a [OrderedType] (and also as a [DecidableType]). *)

(** * An [order] tactic for real numbers *)

Module ROrder := OTF_to_OrderTac R_as_OT.
Ltac r_order := ROrder.order.

(** Note that [r_order] is domain-agnostic: it will not prove
    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)


Require Import List.
Require Import Omega.

Lemma in_split : forall (X:Type) (x:X) (l:list X),
  In x l ->
  exists l1 l2, l = l1 ++ x :: l2.
Proof.
  induction l; intros.
  - inversion H.
  - inversion H.
    + subst x. exists nil, l. reflexivity.
    + specialize (IHl H0). destruct IHl as [l1 [l2 A]].
      exists (a::l1), l2. subst l. reflexivity.
Qed.

Inductive repeats {X:Type} : list X -> Prop :=
| repeats_this:
    forall x l, In x l -> repeats (x :: l)
| repeats_other:
    forall x l, repeats l -> repeats (x :: l).

Lemma nth_error_hd:
  forall (X: Type) (l l': list X) (x: X),
    nth_error (l ++ x :: l') (length l) = Some x.
Proof.
  induction l; intros.
  - simpl. reflexivity.
  - simpl. eapply IHl; auto.
Qed.

Lemma to_list_nat:
  forall (X: Type) (l1 l2: list X),
    (forall x, In x l1 -> In x l2) ->
    exists l, map (nth_error l2) l = map (fun x => Some x) l1.
Proof.
  induction l1; intros.
  - exists nil; reflexivity.
  - generalize (IHl1 l2 (fun x Hin => H x (in_cons _ _ _ Hin))). intros [l A].
    generalize (H a (in_eq _ _)). intros B. generalize (in_split _ _ _ B). intros [hd [tl Heq]].
    exists (length hd :: l). simpl. rewrite A. f_equal.
    rewrite Heq. eapply nth_error_hd.
Qed.

Lemma repeats_in_nat_implies_repeats:
  forall (X: Type) (l: list nat),
    repeats l ->
    forall (l1 l2: list X), map (nth_error l2) l = map (fun x => Some x) l1 ->
                       repeats l1.
Proof.
  induction 1; intros.
  - simpl in H0. destruct l1; inversion H0. clear H0.
    constructor 1. generalize (in_map (nth_error l2) _ _ H). intros Hin.
    rewrite H3 in Hin. rewrite H2 in Hin. eapply in_map_iff in Hin.
    destruct Hin as [x1 [A N]]. inversion A; subst; auto.
  - simpl in H0. destruct l1; inversion H0. clear H0.
    constructor 2. eapply IHrepeats; eauto.
Qed.

Lemma not_in_app:
  forall (X: Type) (l1 l2: list X) (x: X),
    ~ In x (l1 ++ l2) ->
    ~ In x l1 /\ ~ In x l2.
Proof.
  intros; split; red; intros.
  - eapply H. eapply in_or_app. left; auto.
  - eapply H. eapply in_or_app. right; auto.
Qed.

Lemma not_in_cons:
  forall (X: Type) (l: list X) (x y: X),
    ~ In x (y::l) ->
    x <> y /\ ~ In x l.
Proof.
  unfold not; split; intros.
  - subst x; apply H; apply in_eq.
  - apply H; apply in_cons; auto.
Qed.

Lemma repeats_app:
  forall (X: Type) (l1 l2: list X) (x: X),
    In x l1 ->
    In x l2 ->
    repeats (l1 ++ l2).
Proof.
  induction l1; intros.
  - inversion H.
  - destruct H; try subst a.
    + simpl. constructor. eapply in_or_app. right; auto.
    + simpl. constructor 2. eapply IHl1; eauto.
Qed.

Lemma repeats_app_right:
  forall (X: Type) (l1 l2: list X),
    repeats l2 ->
    repeats (l1 ++ l2).
Proof.
  induction l1; intros; auto.
  simpl; constructor 2. apply IHl1; eauto.
Qed.

Lemma repeats_remove:
  forall (X: Type) (l1 l2: list X) (x: X),
    repeats (l1 ++ l2) ->
    repeats (l1 ++ x :: l2).
Proof.
  induction l1; intros.
  - simpl in H; simpl. constructor 2; auto.
  - simpl in H; inversion H; subst.
    + simpl. eapply in_app_or in H1; destruct H1.
      * constructor. eapply in_or_app. left; auto.
      * constructor. eapply in_or_app. right. right; auto.
    + eapply IHl1 in H1. simpl. constructor 2. eapply H1.
Qed.

Lemma repeats_permut_hd:
  forall (X: Type) (l: list X) (a b: X),
    repeats (a :: b :: l) ->
    repeats (b :: a :: l).
Proof.
  induction l; intros.
  - inversion H; subst.
    + destruct H1. subst.
      * constructor; eapply in_eq.
      * inversion H0.
    + inversion H1; subst.
      * inversion H2.
      * inversion H2.
  - inversion H; subst.
    + destruct H1.
      * subst. constructor; apply in_eq.
      * destruct H0.
        { subst a0. constructor 2. constructor; apply in_eq. }
        { constructor 2. constructor. right; auto. }
    + change (b :: a0 :: a :: l) with ((b :: nil) ++ a0 :: (a :: l)).
      apply repeats_remove. simpl. auto.
Qed.

Lemma repeats_permut:
  forall (X: Type) (l1 l2: list X) (a b: X),
    repeats (a :: l1 ++ b :: l2) ->
    repeats (b :: l1 ++ a :: l2).
Proof.
  induction l1; intros.
  - simpl in H. simpl.
    inversion H; subst.
    + destruct H1.
      * subst b. constructor. left; auto.
      * constructor 2. constructor; auto.
    + inversion H1; subst.
      * constructor. right; auto.
      * constructor 2. constructor 2; auto.
  - simpl in H. simpl. apply repeats_permut_hd in H. apply repeats_permut_hd.
    inversion H; subst.
    + destruct H1; subst.
      * constructor. right. apply in_or_app. right. left; auto.
      * apply in_app_or in H0. destruct H0.
        { constructor. right. apply in_or_app. left; auto. }
        { destruct H0; subst.
          - constructor; left; auto.
          - constructor. right. eapply in_or_app. right; right; auto. }
    + eapply IHl1 in H1. constructor 2. auto.
Qed.

Lemma nth_error_Some X (l: list X) n : nth_error l n <> None <-> n < length l.
Proof.
  revert n. induction l; destruct n; simpl.
  - split; [now destruct 1 | inversion 1].
  - split; [now destruct 1 | inversion 1].
  - split; now auto with arith.
  - rewrite IHl; split; auto with arith.
Qed.

Lemma pigeonhole_nat':
  forall (m: nat) (l: list nat),
    2 <= length l < m ->
    (forall n, In n l -> n < length l - 1) ->
    repeats l.
Proof.
  induction m; intros.
  - destruct l; simpl in H; omega.
  - destruct l; simpl in H; try omega.
    destruct l; simpl in H; try omega.
    destruct l; simpl in H.
    + generalize (H0 n (in_eq _ _)). generalize (H0 n0 (in_cons _ _ _ (in_eq _ _))). simpl; intros.
      assert (n0 = 0) by omega. assert (n = 0) by omega; subst.
      constructor. eapply in_eq.
    + destruct (In_dec eq_nat_dec n (n0 :: n1 :: l)).
      * constructor; auto.
      * destruct (In_dec eq_nat_dec (S (length l)) (n0 :: n1 :: l)).
        { generalize (in_split _ _ _ i). intros [l1 [l2 A]].
          generalize (H0 n (or_introl eq_refl)). intros B.
          assert (n < S (length l)).
          - rewrite A in n2. apply not_in_app in n2. destruct n2.
            apply not_in_cons in H2. simpl in B; destruct H2; try omega.
          - destruct (In_dec eq_nat_dec (S (length l)) l1).
            + rewrite A. rewrite app_comm_cons. eapply repeats_app; auto.
              * right. apply i0.
              * apply in_eq.
            + destruct (In_dec eq_nat_dec (S (length l)) l2).
              { rewrite A. constructor 2. apply repeats_app_right; auto.
                constructor. auto. }
              { clear B. assert (HA: length (l1 ++ n :: l2) =length (l1 ++ S (length l) :: l2)).
                { rewrite ! app_length; simpl; auto. }
                assert (HB: 2 <= length (l1 ++ n :: l2) < m).
                { rewrite HA. rewrite <- A. simpl; try omega. }
                - generalize (IHm (l1 ++ n :: l2) HB). rewrite HA. rewrite ! A. intros HC.
                  assert (repeats (l1 ++ n :: l2)).
                  { apply HC. intros. eapply in_app_or in H2. destruct H2.
                    - rewrite <- A. simpl.
                      assert (n5 < S (S (length l))).
                      + apply H0. rewrite A. right. eapply in_or_app. left; auto.
                      + destruct (eq_nat_dec n5 (S (length l))); try congruence. omega.
                    - destruct H2.
                      + rewrite <- A; simpl; omega.
                      + assert (n5 < S (S (length l))).
                        * apply H0. rewrite A. right. eapply in_or_app. right. right; auto.
                        * destruct (eq_nat_dec n5 (S (length l))); try congruence. rewrite <- A; simpl. omega. }
                  eapply repeats_permut. constructor 2; auto. } }
        constructor 2. eapply IHm.
        { simpl; omega. }
        { intros. destruct H1; subst.
          - simpl. assert (n4 < S (S (length l))).
            { apply H0. right; left; auto. }
            apply not_in_cons in n3. destruct n3. omega.
          - destruct H1; subst.
            + simpl. assert (n4 < S (S (length l))).
              { apply H0. right; right; left; auto. }
              apply not_in_cons in n3. destruct n3. apply not_in_cons in H3; destruct H3. omega.
            + simpl. assert (n4 < S (S (length l))).
              { apply H0. right; right; right; auto. }
              apply not_in_cons in n3. destruct n3.
              apply not_in_cons in H4; destruct H4.
              destruct (eq_nat_dec n4 (S (length l))); try congruence; omega. }
Qed.

Lemma pigeonhole_nat:
  forall (l: list nat),
    2 <= length l ->
    (forall n, In n l -> n < length l - 1) ->
    repeats l.
Proof.
  intros; eapply pigeonhole_nat'; eauto.
Qed.

Theorem pigeonhole_principle:
  forall (X:Type) (l1 l2: list X),
   (forall x, In x l1 -> In x l2) ->
   length l2 < length l1 ->
   repeats l1.
Proof.
  intros. generalize (to_list_nat _ _ _ H). intros [l A].
  eapply repeats_in_nat_implies_repeats; eauto.
  assert (length l = length l1).
  { erewrite <- (map_length (nth_error l2) l). rewrite A.
    apply map_length. }
  eapply pigeonhole_nat.
  - rewrite H1. destruct l1; simpl in H0; try omega.
    destruct l1; destruct l2; simpl in H0; try omega.
    + generalize (H x (in_eq _ _)). intro HA; inversion HA.
    + generalize (H x (in_eq _ _)). intro HA; inversion HA.
    + simpl; omega.
  - intros. rewrite H1.
    assert (n < length l2).
    { generalize (in_map (nth_error l2) _ _ H2). rewrite A. intros B.
      generalize (proj1 (in_map_iff _ _ _) B). intros [x [C D]].
      eapply nth_error_Some. rewrite <- C. congruence. }
    omega.
Qed.