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 t: Type :=
| true
| false
| If (t1 t2 t3: t)
| O
| succ (t1: t)
| pred (t1: t)
| iszero (t1: t).

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

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

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
| 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 --> true
| E_IsZeroSucc : forall nv1,
    NatValue nv1 -> iszero (succ nv1) --> false
| 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 : t -> t -> Prop :=
| B_Value : forall t1,
    value t1 -> t1 ==> t1
| B_IfTrue : forall t1 t2 v2 t3,
    t1 ==> true -> t2 ==> v2 -> value v2 -> If t1 t2 t3 ==> v2
| B_IfFalse : forall t1 t2 t3 v3,
    t1 ==> false -> 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 ==> true
| B_IsZeroSucc : forall t1 nv1,
    t1 ==> (succ nv1) -> iszero t1 ==> false

  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_18 : 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.

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.

Fixpoint 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.


From Hammer Require Import Hammer.

Require Import Bool.

Inductive IfProp (A B:Prop) : bool -> Prop :=
| Iftrue : A -> IfProp A B true
| Iffalse : B -> IfProp A B false.

Hint Resolve Iftrue Iffalse: bool.

Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A.
destruct 1; intros; auto with bool.
case diff_true_false; auto with bool.
Qed.

Lemma Iffalse_inv :
forall (A B:Prop) (b:bool), IfProp A B b -> b = false -> B.
destruct 1; intros; auto with bool.
case diff_true_false; trivial with bool.
Qed.

Lemma IfProp_true : forall A B:Prop, IfProp A B true -> A.
intros.
inversion H.
assumption.
Qed.

Lemma IfProp_false : forall A B:Prop, IfProp A B false -> B.
intros.
inversion H.
assumption.
Qed.

Lemma IfProp_or : forall (A B:Prop) (b:bool), IfProp A B b -> A \/ B.
destruct 1; auto with bool.
Qed.

Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}.
destruct b; intro H.
left; inversion H; auto with bool.
right; inversion H; auto with bool.
Qed.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2016 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

Require Import Equations.Init.

(** Decidable equality.

   We redevelop the derivation of [K] from decidable equality on [A] making
   everything transparent and moving to [Type] so that programs using this
   will actually be computable inside Coq. *)

Set Implicit Arguments.

Definition dec_eq {A} (x y : A) :=
  { x = y } + { x <> y }.

Class EqDec (A : Type) :=
  eq_dec : forall x y : A, { x = y } + { x <> y }.

(** Derivation of principles on sigma types whose domain is decidable. *)

Section EqdepDec.

  Context {A : Type} `{EqDec A}.

  Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
    eq_ind _ (fun a => a = y') eq2 _ eq1.

  Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = refl_equal y.
  Proof.
    intros.
    case u; trivial.
  Defined.

  Variable x : A.

  Let nu (y:A) (u:x = y) : x = y :=
    match eq_dec x y with
      | left eqxy => eqxy
      | right neqxy => False_ind _ (neqxy u)
    end.

  Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
    intros.
    unfold nu in |- *.
    case (eq_dec x y); intros.
    reflexivity.

    case n; trivial.
  Defined.

  Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v.

  Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u.
  Proof.
    intros.
    case u; unfold nu_inv in |- *.
    apply trans_sym_eq.
  Defined.

  Theorem eq_proofs_unicity : forall (y:A) (p1 p2:x = y), p1 = p2.
  Proof.
    intros.
    elim nu_left_inv with (u := p1).
    elim nu_left_inv with (u := p2).
    elim nu_constant with y p1 p2.
    reflexivity.
  Defined.

  Theorem K_dec :
    forall P:x = x -> Type, P (refl_equal x) -> forall p:x = x, P p.
  Proof.
    intros.
    elim eq_proofs_unicity with x (refl_equal x) p.
    trivial.
  Defined.

  Lemma eq_dec_refl : eq_dec x x = left _ (eq_refl x).
  Proof. case eq_dec. intros. f_equal. apply eq_proofs_unicity.
    intro. congruence.
  Defined.

  (** The corollary *)

  Let proj (P:A -> Type) (exP:sigT P) (def:P x) : P x :=
    match exP with
      | existT _ x' prf =>
        match eq_dec x' x with
          | left eqprf => eq_rect x' P prf x eqprf
          | _ => def
        end
    end.

  Theorem inj_right_pair :
    forall (P:A -> Type) (y y':P x),
      existT P x y = existT P x y' -> y = y'.
  Proof.
    intros.
    cut (proj (existT P x y) y = proj (existT P x y') y).
    simpl in |- *.
    case (eq_dec x x).
    intro e.
    elim e using K_dec; trivial.

    intros.
    case n; trivial.

    case H0.
    reflexivity.
  Defined.

  Lemma inj_right_pair_refl (P : A -> Type) (y : P x) :
    inj_right_pair (y:=y) (y':=y) (eq_refl _) = (eq_refl _).
  Proof. unfold inj_right_pair. intros.
    unfold eq_rect. unfold proj. rewrite eq_dec_refl.
    unfold K_dec. simpl.
    unfold eq_proofs_unicity. subst proj.
    simpl. unfold nu_inv, comp, nu. simpl.
    unfold eq_ind, nu_left_inv, trans_sym_eq, eq_rect, nu_constant.
    rewrite eq_dec_refl. reflexivity.
  Defined.

End EqdepDec.

Class EqDecPoint (A : Type) (x : A) :=
  eq_dec_point : forall y : A, { x = y } + { x <> y }.

Instance EqDec_EqDecPoint A `(EqDec A) (x : A) : EqDecPoint x :=
  eq_dec x.

(** Derivation of principles on sigma types whose domain is decidable. *)

Section PointEqdepDec.
  Set Universe Polymorphism.

  Context {A : Type} {x : A} `{EqDecPoint A x}.

  Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
    eq_ind _ (fun a => a = y') eq2 _ eq1.

  Remark point_trans_sym_eq : forall (x y:A) (u:x = y), comp u u = refl_equal y.
  Proof.
    intros.
    case u; trivial.
  Defined.

  Let nu (y:A) (u:x = y) : x = y :=
    match eq_dec_point y with
      | left eqxy => eqxy
      | right neqxy => False_ind _ (neqxy u)
    end.

  Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
    intros.
    unfold nu in |- *.
    case (eq_dec_point y); intros.
    reflexivity.

    case n; trivial.
  Defined.

  Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v.

  Remark nu_left_inv_point : forall (y:A) (u:x = y), nu_inv (nu u) = u.
  Proof.
    intros.
    case u; unfold nu_inv in |- *.
    apply trans_sym_eq.
  Defined.

  Theorem eq_proofs_unicity_point : forall (y:A) (p1 p2:x = y), p1 = p2.
  Proof.
    intros.
    elim nu_left_inv_point with (u := p1).
    elim nu_left_inv_point with (u := p2).
    elim nu_constant with y p1 p2.
    reflexivity.
  Defined.

  Theorem K_dec_point :
    forall P:x = x -> Type, P (refl_equal x) -> forall p:x = x, P p.
  Proof.
    intros.
    elim eq_proofs_unicity_point with x (refl_equal x) p.
    trivial.
  Defined.

  Lemma eq_dec_refl_point : eq_dec_point x = left _ (eq_refl x).
  Proof. case eq_dec_point. intros. f_equal. apply eq_proofs_unicity_point.
    intro. congruence.
  Defined.

  (** The corollary *)

  Let proj (P:A -> Type) (exP:sigma _ P) (def:P x) : P x :=
    match exP with
      | sigmaI _ x' prf =>
        match eq_dec_point x' with
          | left eqprf => eq_rect x' P prf x (eq_sym eqprf)
          | _ => def
        end
    end.

  Theorem inj_right_sigma_point :
    forall (P:A -> Type) (y y':P x),
      sigmaI P x y = sigmaI P x y' -> y = y'.
  Proof.
    intros.
    cut (proj (sigmaI P x y) y = proj (sigmaI P x y') y).
    unfold proj. simpl in |- *.
    case (eq_dec_point x).
    intro e.
    elim e using K_dec_point; trivial.

    intros. unfold proj in H1.
    case n; trivial.

    case H0.
    reflexivity.
  Defined.

  Lemma inj_right_sigma_refl_point (P : A -> Type) (y : P x) :
    inj_right_sigma_point (y:=y) (y':=y) (eq_refl _) = (eq_refl _).
  Proof. unfold inj_right_sigma_point. intros.
    unfold eq_rect. unfold proj. rewrite eq_dec_refl_point.
    unfold K_dec_point. simpl.
    unfold eq_proofs_unicity_point. subst proj.
    simpl. unfold nu_inv, comp, nu. simpl.
    unfold eq_ind, nu_left_inv, trans_sym_eq, eq_rect, nu_constant.
    rewrite eq_dec_refl_point. reflexivity.
  Defined.

End PointEqdepDec.

Section PEqdepDec.
  Set Universe Polymorphism.

  Context {A : Type} `{EqDec A}.

  Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
    eq_ind _ (fun a => a = y') eq2 _ eq1.

  Remark ptrans_sym_eq : forall (x y:A) (u:x = y), comp u u = refl_equal y.
  Proof.
    intros.
    case u; trivial.
  Defined.

  Variable x : A.

  Let nu (y:A) (u:x = y) : x = y :=
    match eq_dec x y with
      | left eqxy => eqxy
      | right neqxy => False_ind _ (neqxy u)
    end.

  Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
    intros.
    unfold nu in |- *.
    case (eq_dec x y); intros.
    reflexivity.

    case n; trivial.
  Defined.

  Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v.

  Remark pnu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u.
  Proof.
    intros.
    case u; unfold nu_inv in |- *.
    apply ptrans_sym_eq.
  Defined.

  Theorem peq_proofs_unicity : forall (y:A) (p1 p2:x = y), p1 = p2.
  Proof.
    intros.
    elim pnu_left_inv with (u := p1).
    elim pnu_left_inv with (u := p2).
    elim nu_constant with y p1 p2.
    reflexivity.
  Defined.

  Theorem pK_dec :
    forall P:x = x -> Prop, P (refl_equal x) -> forall p:x = x, P p.
  Proof.
    intros.
    elim peq_proofs_unicity with x (refl_equal x) p.
    trivial.
  Defined.

  Lemma peq_dec_refl : eq_dec x x = left _ (eq_refl x).
  Proof. case eq_dec. intros. f_equal. apply peq_proofs_unicity.
    intro. congruence.
  Defined.

  (* On [sigma] *)

  Let projs (P:A -> Type) (exP:sigma A P) (def:P x) : P x :=
    match exP with
      | sigmaI _ x' prf =>
        match eq_dec x' x with
          | left eqprf => eq_rect x' P prf x eqprf
          | _ => def
        end
    end.

  Theorem inj_right_sigma :
    forall (P:A -> Type) (y y':P x),
      sigmaI P x y = sigmaI P x y' -> y = y'.
  Proof.
    intros.
    cut (projs (sigmaI P x y) y = projs (sigmaI P x y') y).
    unfold projs.
    case (eq_dec x x).
    intro e.
    elim e using pK_dec. trivial.

    intros.
    case n; trivial.

    case H0.
    reflexivity.
  Defined.

  Lemma inj_right_sigma_refl (P : A -> Type) (y : P x) :
    inj_right_sigma (y:=y) (y':=y) (eq_refl _) = (eq_refl _).
  Proof. unfold inj_right_sigma. intros.
    unfold eq_rect. unfold projs. rewrite peq_dec_refl.
    unfold pK_dec. simpl.
    unfold peq_proofs_unicity. subst projs.
    simpl. unfold nu_inv, comp, nu. simpl.
    unfold eq_ind, nu_left_inv, ptrans_sym_eq, eq_rect, nu_constant.
    rewrite peq_dec_refl. reflexivity.
  Defined.

End PEqdepDec.

Arguments inj_right_sigma {A} {H} {x} P y y' e.

Instance eq_eqdec {A} `{EqDec A} : forall x y : A, EqDec (x = y).
Proof.
  intros. red. intros.
  exact (left (eq_proofs_unicity x0 y0)).
Defined.


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

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

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

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

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

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

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

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

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

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

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

Example example_empty := (_ !-> false).

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

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

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  intros. reflexivity. Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros. unfold t_update. rewrite <- eqb_string_refl. reflexivity.
Qed.

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
 unfold t_update. intros. apply false_eqb_string in H. rewrite H. reflexivity.
Qed.

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros. unfold t_update.  extensionality y. induction (eqb_string x y). reflexivity. reflexivity.
Qed.

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  intros. destruct eqb_string eqn:H.
 - apply eqb_string_true_iff in H. apply ReflectT. apply H.
 - apply eqb_string_false_iff in H. apply ReflectF. apply H.
Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  intros. unfold t_update. extensionality y.
  destruct eqb_string eqn:H.
  -  apply eqb_string_true_iff in H. rewrite H. reflexivity.
  - reflexivity.
Qed.

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  intros. unfold t_update. extensionality y.
   destruct (eqb_string x1 y) eqn:H1.
 - apply eqb_string_true_iff in H1. rewrite H1 in H. apply eqb_string_false_iff in H. rewrite H. reflexivity.
 - reflexivity.
Qed.

(*Partial maps*)
Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

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

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.


(* What follows is a minimal example of how to use the ProofMode. *)

From MatchingLogic Require Import
    Syntax
    ProofSystem
    ProofMode
.

Import MatchingLogic.Syntax.Notations.
Import MatchingLogic.ProofSystem.Notations.

(* Below we prove that in matching logic, ϕ -> ϕ for any pattern ϕ. *)
Example phi_implies_phi
    (* Formulas are formed over a particular signature *)
    {Σ : Signature}
    (Γ : Theory)
    (ϕ : Pattern) :
    (* we have to assume that [ϕ] is well_formed *)
    well_formed ϕ = true ->
    (* The goal *)
    Γ ⊢ ϕ ---> ϕ
.
Proof.
    intros wfϕ.
    (* The tactic [toMLGoal] enters the matching logic proof mode.
       However, it first has to check that the pattern to prove is well-formed.
    *)
    toMLGoal.
    {
        (* the [wf_auto2] tactic is used to discharge well-formedness obligations. *)
        wf_auto2.
    }
    (* the [mlTauto] tactic tries to solve a propositional tautology. *)
    mlTauto.
Qed.

(* Of course, we could prove the same thing using an empty theory.
   However, to be able to denote empty set, we have to import part of the [stdpp] library.
*)

From stdpp Require Import base.

Example phi_implies_phi_from_empty_theory {Σ : Signature} (ϕ : Pattern) :
    well_formed ϕ = true ->
    ∅ ⊢ ϕ ---> ϕ
.
Proof.
    intros wfϕ.
    toMLGoal;[wf_auto2|].
    mlTauto.
Qed.

(* But how would we prove the goal manually? *)
From Coq Require Import String.
Open Scope string_scope.

Example phi_implies_phi_manual {Σ : Signature} (Γ : Theory) (ϕ : Pattern) :
    well_formed ϕ = true ->
    Γ ⊢ ϕ ---> ϕ
.
Proof.
    intros wfϕ.
    toMLGoal;[wf_auto2|].

    (* Ok, lets assume that ϕ holds. We assign this hypothesis a name "H".
       We say that the tactic [mlIntro] moves a left-side of an implication
       into so-called "local context".
    *)
    mlIntro "H".
    (* Now we have to prove ϕ, and we have a hypothesis "H" saying that ϕ holds.
       Then the goal can be proven <i>exact</i>ly from the hypothesis.
     *)
    mlExact "H".

    (* Another way of proving the goal would be to use the [mlAssumption] tactic,
       which searches for a hypothesis that matches the goal.
    *)
    Undo.
    mlAssumption.

    (* Of course, we could also use [mlTauto]. *)
    Undo.
    mlTauto.
Qed.

(* We can also work with conjunction and disjunction. *)
Import MatchingLogic.DerivedOperators_Syntax.Notations.

Example and_or {Σ : Signature} (Γ : Theory) (ϕ₁ ϕ₂ : Pattern) :
    well_formed ϕ₁ = true ->
    well_formed ϕ₂ = true ->
    Γ ⊢ ϕ₁ and ϕ₂ ---> ϕ₁ or ϕ₂
.
Proof.
    intros wfϕ1 wfϕ2.
    toMLGoal;[wf_auto2|].

    mlIntro "H".
    (* we have tactics like:
        * [mlDestructAnd]
        * [mlDestructOr]
        * [mlLeft]
        * [mlRight]
        * [mlSplitAnd]
       which work similarly to their Coq counterparts
     *)

    mlDestructAnd "H" as "H1" "H2".
    mlLeft.
    mlExact "H1".
Qed.

(* Propositional reasoning is easy.
*)

Open Scope ml_scope.

Example use_rewrite {Σ : Signature} (Γ : Theory) (ϕ₁ ϕ₂ ϕ₃ ϕ₄ : Pattern) :
    well_formed ϕ₁ = true ->
    well_formed ϕ₂ = true ->
    well_formed ϕ₃ = true ->
    well_formed ϕ₄ = true ->
    Γ ⊢ ϕ₁ <---> ϕ₂ ->
    (* The [$] operator is an application. *)
    Γ ⊢ (ϕ₃ $ ϕ₁ $ ϕ₄) <---> (ϕ₃ $ ϕ₂ $ ϕ₄)
.
Proof.
    intros wfϕ₁ wfϕ₂ wfϕ₃ wfϕ₄ H. toMLGoal;[wf_auto2|].

    (* Notice that now we have a meta-level assumption [H]. *)

    (* Obviously, mlTauto can't solve this goal. *)
    Fail solve [mlTauto].

    (* However, we can use [H] to rewrite the first occurrence of [ϕ₁] to [ϕ₂]. *)
    mlRewrite H at 1.
    (* Now the goal is provable by propositional reasoning. *)
    (* However, mlTauto cannot solve it. That is a bug. *)
    Fail solve[mlTauto].
    (* Never mind, we prove it manually. *)
    mlSplitAnd; mlIntro "H"; mlExact "H".

    (* We could also rewrite in the other direction *)
    Restart.
    intros wfϕ₁ wfϕ₂ wfϕ₃ wfϕ₄ H. toMLGoal;[wf_auto2|].
    mlRewrite <- H at 1.
    mlSplitAnd; mlIntro "H"; mlExact "H".

    (* Unfortunately, we do not have [mlRewrite _ in _] yet.*)
Qed.

(* We can also use definedness and equality.
   To do so, we have to assume that the signature contains a definedness symbol,
   and the theory a definedness axiom.
   Otherwise, the signature and axiom can be arbitrary.
*)

From MatchingLogic Require Import
    Theories.Definedness_Syntax
    Theories.Definedness_ProofSystem
.
Import Theories.Definedness_Syntax.Notations.
Open Scope ml_scope.
Open Scope string_scope.

(* Obviously, without the definedness symbol, we cannot use equality. *)
Fail Example use_rewriteBy {Σ : Signature} (Γ : Theory) (ϕ₁ ϕ₂ ϕ₃ ϕ₄ : Pattern) :
    well_formed ϕ₁ = true ->
    well_formed ϕ₂ = true ->
    well_formed ϕ₃ = true ->
    well_formed ϕ₄ = true ->
    Γ ⊢ (ϕ₁ $ ϕ₄ =ml ϕ₂ $ ϕ₄ ) ---> (ϕ₁ =ml ϕ₂) ---> ((ϕ₃ $ ϕ₁ $ ϕ₄) <---> (ϕ₃ $ ϕ₂ $ ϕ₄))
.

Example use_rewriteBy {Σ : Signature} {syntax : Definedness_Syntax.Syntax}
    (Γ : Theory) (ϕ₁ ϕ₂ ϕ₃ ϕ₄ : Pattern) :
    well_formed ϕ₁ = true ->
    well_formed ϕ₂ = true ->
    well_formed ϕ₃ = true ->
    well_formed ϕ₄ = true ->
    Γ ⊢ (ϕ₁ $ ϕ₄ =ml ϕ₂ $ ϕ₄ ) ---> (ϕ₁ =ml ϕ₂) ---> ((ϕ₃ $ ϕ₁ $ ϕ₄) <---> (ϕ₃ $ ϕ₂ $ ϕ₄))
.
Proof.
    intros wfϕ₁ wfϕ₂ wfϕ₃ wfϕ₄. toMLGoal;[wf_auto2|].
    mlIntro "H1". mlIntro "H2".

    (* We can rewrite using an equality from the local context. *)
    mlRewriteBy "H1" at 1.
    {
        (* Oops, there is a obligation we do not know how to solve. What does that mean? *)
        unfold theory, named_axioms, NamedAxioms.theory_of_NamedAxioms, axiom. simpl.
        (* Aha, we are missing a Definedness axiom. *)
        admit.
    }
Abort.

Example use_rewriteBy {Σ : Signature} {syntax : Definedness_Syntax.Syntax}
    (Γ : Theory) (ϕ₁ ϕ₂ ϕ₃ ϕ₄ : Pattern) :
    (* This makes the difference. *)
    Definedness_Syntax.theory ⊆ Γ ->
    well_formed ϕ₁ = true ->
    well_formed ϕ₂ = true ->
    well_formed ϕ₃ = true ->
    well_formed ϕ₄ = true ->
    Γ ⊢ (ϕ₁ $ ϕ₄ =ml ϕ₂ $ ϕ₄ ) ---> (ϕ₁ =ml ϕ₂) ---> ((ϕ₃ $ ϕ₁ $ ϕ₄) <---> (ϕ₃ $ ϕ₂ $ ϕ₄))
.
Proof.
    intros HΓ wfϕ₁ wfϕ₂ wfϕ₃ wfϕ₄. toMLGoal;[wf_auto2|].
    mlIntro "H1". mlIntro "H2".

    (* We can rewrite using an equality from the local context. *)
    mlRewriteBy "H1" at 1.
    {
        (* Now we have the appropriate assumption. *)
        assumption.
    }
    {
        (* Another constraint. Under the hood, the rewrite uses the equality elimination lemma,
           which in turn uses deduction theorem.
           Our deduction theorem does not support working with μ patterns yet,
           so we have to check that the context in which we want to rewrite
           is μ-free.
        *)
        simpl.
        (* Oh.. we do not know anything about the [ϕᵢ]s. *)
        admit.
    }
Abort.

(* A solver for boolean tautologies. *)
From Coq Require Import btauto.Btauto.
(* Some helper tactics. *)
From MatchingLogic Require Import
    Utils.extralibrary
    Utils.stdpp_ext
.

Open Scope ml_scope.

Example use_rewriteBy {Σ : Signature} {syntax : Definedness_Syntax.Syntax}
    (Γ : Theory) (ϕ₁ ϕ₂ ϕ₃ ϕ₄ : Pattern) :
    Definedness_Syntax.theory ⊆ Γ ->
    (* This makes the difference. *)
    ((mu_free ϕ₁) && (mu_free ϕ₂) && (mu_free ϕ₃) && (mu_free ϕ₄)) = true ->
    well_formed ϕ₁ = true ->
    well_formed ϕ₂ = true ->
    well_formed ϕ₃ = true ->
    well_formed ϕ₄ = true ->
    Γ ⊢ (ϕ₁ $ ϕ₄ =ml ϕ₂ $ ϕ₄ ) ---> (ϕ₁ =ml ϕ₂) ---> ((ϕ₃ $ ϕ₁ $ ϕ₄) <---> (ϕ₃ $ ϕ₂ $ ϕ₄))
.
Proof.
    intros HΓ Hmf wfϕ₁ wfϕ₂ wfϕ₃ wfϕ₄. toMLGoal;[wf_auto2|].
    mlIntro "H1". mlIntro "H2".

    (* We can rewrite using an equality from the local context. *)
    mlRewriteBy "H1" at 1.
    { assumption. }
    { simpl. destruct_and!. unfold is_true. rewrite H0, H2, H3. reflexivity. }

    (* We could also rewrite by H2 *)
    Restart.

    intros HΓ Hmf wfϕ₁ wfϕ₂ wfϕ₃ wfϕ₄. toMLGoal;[wf_auto2|].
    mlIntro "H1". mlIntro "H2".

    mlRewriteBy "H2" at 1.
    { assumption. }
    { simpl. destruct_and!. unfold is_true. rewrite H0, H2, H3. reflexivity. }

    mlSplitAnd; mlIntro "Hyp"; mlExact "Hyp".
Defined.

Example use_mlApply {Σ : Signature} (Γ : Theory) (a b c : Pattern) :
    well_formed a = true ->
    well_formed b = true ->
    well_formed c = true ->
    Γ ⊢ (a ---> b $ c) ---> (b $ c ---> c) ---> (a ---> c).
Proof.
    intros wfa wfb wfc. toMLGoal;[wf_auto2|].
    mlIntro "H1". mlIntro "H2". mlIntro "H3".
    (* strenghtens the concusion using H2 *)
    mlApply "H2".
    (* Would weaken the hypothesis H3 using H1
       if we had it.
     *)
    (* (mlApply "H1" in "H3"). *)
    mlApply "H1".
    mlExact "H3".
Defined.

Example use_mlApplyMeta {Σ : Signature} (Γ : Theory) (a b c d : Pattern) :
    well_formed a = true ->
    well_formed b = true ->
    well_formed (ex, c) = true ->
    well_formed d = true ->
    Γ ⊢ a ---> ((ex, c) $ d) ---> b ---> (ex, (c $ d)).
Proof.
    intros wfa wfb wfc wfd. toMLGoal;[wf_auto2|].
    mlIntro "H1". mlIntro "H2". mlIntro "H3".

    Check Prop_ex_left.
    mlApplyMeta Prop_ex_left.
    mlExact "H2".
Defined.

Close Scope ml_scope.
Close Scope string_scope.
Close Scope list_scope.


Require Import List.
Require Extraction.

Notation "[]" := nil : myscope.
Infix "::" := cons (at level 60, right associativity) : myscope.

Open Scope myscope.

Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) : myscope.

(* Specyfikacje i typy podzbiorowe *)

(* slaba specyfikacja funkcji : definicja + tw. o poprawnosci *)

Definition tail {A} (l:list A) : list A :=
match l with
| [] => []
| h::t => t
end.

Lemma tail_spec0 :
forall A l, l <> [] -> exists x:A, x::tail l = l.
Proof.
induction l; auto; intros H; [ elim H | idtac ]; eauto.
Qed.

Extraction tail.

(* inaczej: *)

Definition tail1 {A} (l:list A) : l <> [] -> list A :=
match l (* return l <> [] -> list A *) with
| [] => fun p => match (p (refl_equal [])) with end
| h::t => fun _ => t
end.

Eval compute in tail1 [].
Eval compute in tail1 [3;4].
Eval compute in tail1 [3;4] _.
Eval compute in tail1 [] _.

(*Extraction Language Haskell. *)
Extraction tail1.

Hint Extern 1 =>
match goal with
| [ H : ?X <> ?X |- _ ] => elim H; trivial
| [ H : _::_ = [] |- _ ] => discriminate
end.

Lemma nil_not_nil_F :
forall {A} P, @nil A <> @nil A -> P.
Proof. auto. Qed.

Definition tail2 {A} (l:list A) : l <> [] -> list A :=
match l (* return l <> [] -> list A *) with
| [] => fun p => nil_not_nil_F _ p
| h::t => fun _ => t
end.

Extraction tail2.
Extraction nil_not_nil_F.

(*tak nie mozna:
Definition tail3 A (l:list A) (p: l <> []) : list A :=
match l in list _ return list A with
| [] => nil_not_nil_F _ p
| h::t => t
end.
*)

Definition tail3 {A} (l:list A) : l <> [] -> list A.
generalize l; clear l.
refine (fun l =>
match l in list _ return l <> [] -> list A with
| [] => fun p => _
| h::t => fun _ => t
end).
elim p; trivial.
Defined.

Extraction tail3.

(* typ sig do definiowania silnej specyfikacji funkcji *)
Print ex.
Print sig.

Locate "{ _ : _ | _ }".

Definition tail_spec1 {A} (s : { l0 : list A | l0 <> []}) : list A :=
match s with
| exist _ [] p => match p (refl_equal []) with end
| exist _ (h::t) _ => t
end.

(*
Lemma two_not_nil : [2] <> [].
Proof. auto. Qed.
*)

Eval compute in tail_spec1 (exist _ [2] _).

Extraction tail_spec1.

Extraction sig.

Print proj1_sig.
Print proj2_sig.

Definition tail_spec2 {A} (s : { l0 : list A | l0 <> []}) :
{ l' : list A | exists x:A, x :: l' = proj1_sig s} :=

match s (*return { l' : list A | exists x:A, cons x l' = proj1_sig s} *) with
| exist _ [] p => match p (refl_equal []) with end
| exist _ (h::t) p => exist _ t (ex_intro _ h (refl_equal (h :: t)))
end.

Extraction tail_spec2.

Definition tail_spec3 : forall {A} l, l <> [] ->
{ l' : list A | exists x:A, x :: l' = l}.
refine (fun {A} l =>
match l (* return { l' : list A | exists x:A, x :: l' = l} *) with
| [] => fun _ => _
| h::t => fun _ => exist _ t _
end).
elim n; trivial.
split with h; trivial.
Defined.

Print tail_spec3.

Extraction tail_spec3.

Notation " ! " := (False_rect _ _) : spec_scope.
Notation " 'ret' x " := (exist _ x _) (at level 56, no associativity) : spec_scope.

Open Scope spec_scope.

Definition tail_spec4 : forall  {A} (l : list A), l <> [] ->
 { l' : list A | exists x:A, x :: l' = l}.
refine (fun {A} l =>
match l with
| [] => fun _ => !
| h::t => fun _ => ret t
end); eauto.
Defined.

Print tail_spec4.
Eval compute in tail_spec4 [4;5] _.
Extraction tail_spec4.

Require Program.

Obligation Tactic := eauto.

Program Definition tail_spec_program {A} (l : list A) : l <> [] ->
{ l' : list A | exists x:A, x :: l' = l} :=
match l with
| [] => fun _ => !
| h::t => fun _ => ret t
end.

Obligation 2.
intros.
cbn.
exists h.
reflexivity.
(* split with h. *)
(* auto. *)
Qed.

Print tail_spec_program.
Extraction tail_spec_program.

(* czes\u009bciowe typy podzbiorowe *)

Inductive options {A:Type} (P : A -> Prop) : Type :=
| No : options P
| Yes : forall x:A, P x -> options P.

Extraction options.

Notation "{{ x | P }}" := (options (fun x => P)) : option_scope.
Notation "[[ x ]]" := (Yes _ x _) : option_scope.
Notation "!!" := (No _) : option_scope.

Open Scope option_scope.

Definition tail5 : forall {A} (l:list A), {{ l0 | exists x:A, x::l0 = l}}.
refine (fun {A} l =>
match l (*return {{l0 | exists x:A, x::l0 = l}} *) with
| [] => !!
| h::t => [[ t ]]
end).
eauto.
Defined.

Print tail5.

Eval compute in tail5 [2;3;4].
Extraction options.
Extraction tail5.

(* Ale : *)
Definition wrong_tail {A} l : {{l0 | exists x:A, x::l0 = l}} := !!.

Eval compute in wrong_tail [2;3;4].

Close Scope option_scope.

(* hybrydowa suma rozlaczna : zawiera czesc "konstruktywna" i "logiczna" *)
Print sumor.

Extraction sumor.

Notation "[[ x ]]" := (inleft _ (ret x)).
Notation "!!" := (inright _ _).

Check [[ [2;3] ]].

Definition tail_partial {A} (l:list A) :
{l' : list A | exists x, cons x l' = l} + {l = []}.
refine (match l with
| [] => !!
| h::t => [[ t ]]
end); eauto.
Defined.

Eval compute in tail_partial [4;5].
Eval compute in @tail_partial nat [].

Extraction tail_partial.
Extraction sumor.

(**)

Section Remove.

Variable A : Type.
Hypothesis eq_A_dec : forall (x y:A), {x = y} + {x <> y}.

Locate "{ _ } + { _ }".

Notation " x == y " := (eq_A_dec x y) (at level 90) : type_scope.

Fixpoint remove (x:A) (l:list A) : list A :=
match l with
| [] => []
| h::t => if h == x then remove x t else h::remove x t
end.

Definition remove2 (x:A) (l:list A) : list A:=
let f := fix rem x l {struct l} :=
match l with
| [] => []
| h::t => if h == x then rem x t else h::rem x t
end in f x l.

Lemma isnil_dec (l:list A) : {l = []} + {l <> nil}.
Proof.
decide equality.
Defined.

(* a co z taka specyfikacja: *)

Fixpoint remove3 (x:A) (l: list A) : l <> [] -> list A :=
(* match l return l <> [] -> list A with
| [] => fun p => nil_not_nil_F _ p
| h::t => fun p => if h == x then remove3 x t _ else h::remove3 x t _
end. *)
match l with
| [] => fun p => nil_not_nil_F _ p
| h::t => match isnil_dec t with
          | left _ => fun _ => if h == x then [] else [h]
          | right H => fun _ => if h == x then remove3 x t H
                                else h :: remove3 x t H
          end
end.

Definition remove4 : forall (x:A) (l: list A), l <> [] -> list A.
refine (
fix rem x l : l <> [] -> list A :=
match l with
| [] => fun p => !
| h::t =>
  match isnil_dec t with
    | left _ => fun _ => if h == x then [] else [h]
    | right H => fun _ => if h == x then rem x t H else h :: rem x t H
  end
end); eauto.
Defined.

Check List.remove.
Print List.remove.

Definition P : A -> list A -> list A -> Prop :=
fun x l' l => l' = List.remove eq_A_dec x l.

Hint Unfold P.
Print HintDb core.

Notation " # t " := (proj1_sig t) (at level 60) : spec_scope.

Definition remove_spec : forall (x:A) (l:list A),
   { l':list A | P x l' l}.
refine (
fix rem (x:A) (l:list A) : { l':list A | P x l' l} :=
match l with
| [] => ret []
| h::t => if h == x then ret #(rem x t) else ret (h :: #(rem x t))
end); auto;
elim rem; intros; subst; unfold P in *; simpl;
match goal with
| [ |- context [eq_A_dec ?x ?y] ] => elim (eq_A_dec x y); intros; subst; auto
end.
Defined.

End Remove.

Check remove_spec.
Extraction remove_spec.

Require Import Peano_dec.

Eval compute in remove_spec _ eq_nat_dec 3 [1;2;3;4;3].

Print sig.
Print sigT.
Print sig2.
Locate "{ _ : _ & _ }".
Print Scope type_scope.

Notation " [ x , y ] " := (existT _ x (exist _ y _)) : spec_scope.

Definition tail_specT : forall A (l : list A), l <> nil ->
{ l' : list A  & { x : A | cons x l' = l} }.
refine (fun A l =>
match l with
| nil => fun p => !
| h::t => fun _ => [t, h]
end); eauto.
Defined.

Extraction tail_specT.
Extraction sigT.

Close Scope spec_scope.

(* typechecking *)

Inductive exp : Set :=
| num : nat -> exp
| add : exp -> exp -> exp
| bval : bool -> exp
| and : exp -> exp -> exp
| isz : exp -> exp.

Notation " # n " := (num n) (at level 60, no associativity) : exp_scope.
Notation " a1 + a2 " := (add a1 a2) (at level 50, left associativity) : exp_scope.
Notation " b1 & b2 " := (and b1 b2) (at level 40, left associativity) : exp_scope.
Notation " 0 ? a " := (isz a) (at level 37, no associativity) : exp_scope.
Notation "[ x ; .. ; y ]" := (add x .. (add y (num 0)) ..) : exp_scope.

Open Scope exp_scope.

Inductive tp := Nat | Bool.

Reserved Notation " |- e ::: T " (at level 70).

Inductive typing_j : exp -> tp -> Prop :=
| t_num : forall n:nat,
          |- #n ::: Nat
| t_add : forall a1 a2,
          |- a1 ::: Nat-> |- a2 ::: Nat-> |- a1 + a2 ::: Nat
| t_bval : forall b,
           |- bval b ::: Bool
| t_and : forall b1 b2,
          |- b1 ::: Bool-> |- b2 ::: Bool-> |- b1 & b2 ::: Bool
| t_isz : forall a,
          |- a ::: Nat-> |- 0? a ::: Bool
where " |- e ::: T " := (typing_j e T).

Hint Constructors typing_j.

Ltac solve_by_inversion :=
match goal with
| [ H : (|- _ ::: _) |- _ ] => solve [inversion H; subst; auto]
| _ => idtac
end.

Ltac destruct_all :=
repeat match goal with
| [ H : { T : _ | |- ?e ::: T  } |- _ ] => destruct H
| [ H :  _ + { _ } |- _ ] => destruct H
| [ H : tp |- _ ] =>
  match goal with
  | [ H0 : |- ?e ::: H |- _ ] => destruct H
  | _ => idtac
  end
| _ => idtac
end.

Ltac do_inversions n :=
match n with
| O => idtac
| S ?m => match goal with
         | [ H : |- _ ::: _ |- _ ] => inversion H; subst; clear H; do_inversions m
         | _ => idtac
         end
end.

Lemma typing_det :
forall e T1 T2,
|- e ::: T1 -> |- e ::: T2 -> T1 = T2.
Proof.
induction 1; intros; solve_by_inversion.
Qed.

Hint Resolve typing_det.

(* do uzupelnienia - cwiczenie na pozniej *)
Ltac magic_wand := idtac.

Lemma typing_dec :
forall e:exp, { T:tp | |- e ::: T} + {forall T:tp, ~ |- e ::: T}.
Proof.
induction e; intros; destruct_all; magic_wand.
Admitted.

Check typing_dec.
Extraction typing_dec.

(* notacja monadyczna *)
Notation " T <-- e1 ; e2 " := (match e1 with
                                       | inleft (exist _ T _) => e2
                                       | inright _ => _
                                       end) (right associativity, at level 60).

Notation " [[ x ]] " := (inleft _ (exist _ x _)).
Notation " e1 ~> e2 " := (if e1 then e2 else inright _ _) (at level 55).

Lemma eq_tp_dec :
forall T1 T2:tp, {T1 = T2} + {T1 <> T2}.
Proof.
decide equality.
Defined.

Ltac magic_wand' :=
match goal with
| [ |- |-  _ ::: _ ] => solve [subst; constructor; eauto]
| [ |- forall _ , ~ |- _ ::: _ ] => solve [intros; intro; do_inversions 1; eauto]
| [ H : forall _, ~ |- _ ::: _ |- _ + { _ } ] =>
solve [subst; right; intros; intro; do_inversions 1; eelim H; eauto]
| _ => idtac
end.

Definition typing_dec' :
forall e:exp, { T:tp | |- e ::: T} + {forall T:tp, ~ |- e ::: T}.
refine
(fix typ (e:exp) : { T:tp | |- e ::: T} + {forall T:tp, ~ |- e ::: T} :=
match e with
| #n => [[Nat]]
| a1 + a2 =>
T1 <-- typ a1;
T2 <-- typ a2;
eq_tp_dec T1 Nat ~> (eq_tp_dec T2 Nat ~> [[Nat]])
| bval b => [[Bool]]
| b1 & b2 =>
T1 <-- typ b1;
T2 <-- typ b2;
eq_tp_dec T1 Bool ~> (eq_tp_dec T2 Bool~> [[Bool]])
| 0? a =>
T1 <-- typ a;
eq_tp_dec T1 Nat ~> [[Bool]]
end);
magic_wand'.
Defined.

Extraction typing_dec'.

Eval compute in typing_dec' (add (num 3) (num 4)).
Eval compute in typing_dec' (add (num 3) (bval true)).

Definition interpret_tp (t:tp) : Set :=
match t with
| Bool => bool
| Nat => nat
end.

Definition eval (e:exp) {T} (H : |- e ::: T) : interpret_tp T.
(*
induction H.
*)
generalize T H; clear T H.
induction e; intros.
assert (T=Nat) by (inversion H; auto); rewrite H0; simpl.
exact n.
assert (T=Nat) by (inversion H; auto); rewrite H0; simpl.
assert (|- e1 ::: Nat) by (inversion H; auto).
assert (|- e2 ::: Nat) by (inversion H; auto).
exact (Nat.add (IHe1 Nat H1) (IHe2 Nat H2)).
assert (T= Bool) by (inversion H; auto); rewrite H0; simpl.
exact b.
assert (T=Bool) by (inversion H; auto); rewrite H0; simpl.
assert (|- e1 ::: Bool) by (inversion H; auto).
assert (|- e2 ::: Bool) by (inversion H; auto).
exact (andb (IHe1 _ H1) (IHe2 _ H2)).
assert (T=Bool) by (inversion H; auto); rewrite H0; simpl.
assert (|- e ::: Nat) by (inversion H; auto).
exact (if eq_nat_dec (IHe _ H1) 0 then true else false).
Defined.

Print eval.
Extraction Language Haskell.
Extraction eval.
Extraction interpret_tp.

Inductive llist {A:Set} : nat -> Set :=
| lnil : llist 0
| lcons : forall n, A -> llist n -> llist (S n).

(*
Definition nth {A n} (l : @llist A n) m : m < n -> A.
*)

Inductive fin : nat -> Set :=
| fst : forall n, fin (S n)
| next : forall n, fin n -> fin (S n).

Check fst 2.
Check next _ (fst 1).
Check next _ (next _ (fst 0)).

(*
Fixpoint get {A n} (l : @llist A n) {struct l} : fin n -> A :=
match l with
| lcons _ x l' => fun index =>
                  match index in fin (S n) return A with
                  | fst _ => x
                  | next _ index' => get l' index'
                  end
| lnil => fun index =>
          match index in fin n return match n with 0 => A | _ => unit end with
          | fst _ => tt
          | next _ _ => tt
          end
end.
*)

(*
Fixpoint get {A n} (l : @llist A n) {struct l} : fin n -> A :=
match l (*in llist n return fin n -> A*) with
| lcons _ x l' => fun index =>
                  match index in fin (S n) return llist n -> A with
                  | fst _ => fun _ => x
                  | next _ index' => fun l1 => get l1 index'
                  end l'
| lnil => fun index =>
          match index in fin n return match n with 0 => A | _ => unit end with
          | fst _ => tt
          | next _ _ => tt
          end
end.
*)

Fixpoint get {A n} (l : @llist A n) {struct l} : fin n -> A :=
match l (*in llist n return fin n -> A*) with
| lcons _ x l' => fun index =>
                  match index in fin (S n) return (fin n -> A) -> A with
                  | fst _ => fun _ => x
                  | next _ index' => fun f => f index'
                  end (get l')
| lnil => fun index =>
          match index in fin n return match n with 0 => A | _ => unit end with
          | fst _ => tt
          | next _ _ => tt
          end
end.


From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Setoids.Setoid.
From Coq Require Import Logic.FunctionalExtensionality.

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

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

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

Module MapNotations.

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

End MapNotations.

Import MapNotations.

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
  (_ !-> v) x = v.
Proof.
  intros.
  unfold t_empty.
  reflexivity.
Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
  (x !-> v ; m) x = v.
Proof.
  intros.
  unfold t_update.
  rewrite eqb_refl.
  reflexivity.
Qed.

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

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
  (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold t_update.
  induction (x =? x0)%string;
  reflexivity.
Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
  (x !-> m x ; m) = m.
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold t_update.
  destruct (eqb_eq x x0).
  induction (x =? x0)%string.
  rewrite H; reflexivity.
  reflexivity.
Qed.


(********************
 * DM3: Omniscience
 *
 * L'objet de ce DM est d'étudier les types qui sont omniscients dans
 * la théorie des types sous-jacente de Coq. Un type [X] est
 * omniscient quand on peut décider pour tout prédicat [X → bool] s'il
 * est vrai partout ou non.
*)

Set Implicit Arguments.
Require Import Coq.Unicode.Utf8.
Require Import Arith.
Require Import Omega.
Require Import FunctionalExtensionality.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Bool.Bool.

(*****************)
(* Préliminaires *)
(*****************)

Lemma zero_or_succ : forall n : nat, n = 0 \/ exists n' : nat, n = S n'.
Proof.
  induction n.
    left. auto.
    destruct IHn.
      right. exists 0. auto.
      right. exists n. auto.
Qed.

Lemma exmid_bool :
  forall a, a=true \/ a=false.
Proof.
  intro.
  assert ({a=true} + {a <> true}). apply bool_dec.
  destruct H.
    left. apply e.
    right. apply not_true_is_false. apply n.
Qed.

(*****************)

Record equivalence {X : Set} (R : X → X → Prop) : Set :=
  mkEq {
    refl: forall x, R x x;
    symm: forall x y, R x y -> R y x;
    trans: (forall x y z, R x y -> R y z -> R x z)
}.
Record setoid : Type :=
  mkSetoid {
    set : Set;
    R : set → set → Prop;
    R_eq : equivalence R
}.

Definition setoid_of_set (X : Set) : setoid.
  refine (mkSetoid (set:=X) (R := fun x y => x = y) _).
  apply mkEq; [auto | auto | apply eq_trans].
Defined.
Definition bool_setoid := setoid_of_set bool.
Definition nat_setoid := setoid_of_set nat.
Notation "'ℕ'" := (nat_setoid).

(*********************)
(*    Question 1.    *)
(*********************)

Definition extensional {X Y : setoid} (f : set X → set Y) :=
  forall x y, R X x y -> R Y (f x) (f y).
Hint Unfold extensional.
Definition arrow_setoid (X : setoid) (Y : setoid) : setoid.
refine (mkSetoid (set := { f : set X → set Y | extensional f })
                 (R := (fun f g => forall x : set X, R Y (proj1_sig f x) (proj1_sig g x)))
                 _).
apply mkEq.
  intros.
    apply R_eq.
  intros.
    apply symm.
    apply R_eq.
    apply H.
  intros.
    specialize H with (x0 := x0).
    specialize H0 with (x := x0).
    apply trans with (proj1_sig y x0).
    apply R_eq. apply H. apply H0.
Defined.
Notation "X ⇒ Y" := (arrow_setoid X Y) (at level 80).

Definition omniscient (X : setoid) :=
  forall p : set (X ⇒ bool_setoid),
    (exists x, proj1_sig p x = false) \/ (forall x, proj1_sig p x = true).

(*********************)
(*    Question 2.    *)
(*********************)

Definition searchable (X : setoid) :=
  exists eps : set (X ⇒ bool_setoid) → set X,
  forall p : set (X ⇒ bool_setoid),
    (proj1_sig p (eps p) = true <-> forall x, proj1_sig p x = true).

(*********************)
(*    Question 3.    *)
(*********************)

Lemma searchable_implies_omniscient : forall X, searchable X -> omniscient X.
Proof.
  intros. intro.
  unfold searchable in H.
  destruct H.
  specialize H with (p := p).
  assert (proj1_sig p (x p) = true \/ proj1_sig p (x p) = false).
    destruct (proj1_sig p (x p)). auto. auto.
  destruct H0.
    right. apply H. apply H0.
    left. exists (x p). apply H0.
Qed.

(*********************)
(*    Question 4.    *)
(*********************)

Definition finite_setoid (k: nat) : setoid.
refine (mkSetoid (set := { x | x ≤ k}) (R := (fun x y => proj1_sig x = proj1_sig y)) _).
split; [auto | auto | intros; apply eq_trans with (y := proj1_sig y); auto].
Defined.

Definition injection (n : nat) : { x : nat | x ≤ n } → { x : nat | x ≤ S n}.
  intro.
  destruct H.
  exists x. omega.
Defined.

(*****************************************************************)
(*  Preuve de la décidabilité de l'égalité de 2 preuves de n<=m. *)
(*  Source : https://coq.inria.fr/V8.1/faq.html#le-uniqueness    *)
(*****************************************************************)

Require Import Eqdep_dec.
Require Import Peano_dec.

Theorem K_nat :
 forall (x:nat) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
Proof.
  intros; apply K_dec_set with (p := p).
  apply eq_nat_dec.
  assumption.
Qed.

Theorem eq_rect_eq_nat :
 forall (p:nat) (Q:nat->Type) (x:Q p) (h:p=p), x = eq_rect p Q x p h.
Proof.
  intros; apply K_nat with (p := h); reflexivity.
Qed.

Scheme le_ind' := Induction for le Sort Prop.

Theorem le_uniqueness_proof : forall (n m : nat) (p q : n <= m), p = q.
Proof.
  induction p using le_ind'; intro q.
  replace (le_n n) with
    (eq_rect _ (fun n0 => n <= n0) (le_n n) _ (refl_equal n)).
  2:reflexivity.
   generalize (refl_equal n).
     pattern n at 2 4 6 10, q; case q; [intro | intros m l e].
      rewrite <- eq_rect_eq_nat; trivial.
      contradiction (le_Sn_n m); rewrite <- e; assumption.
  replace (le_S n m p) with
   (eq_rect _ (fun n0 => n <= n0) (le_S n m p) _ (refl_equal (S m))).
  2:reflexivity.
   generalize (refl_equal (S m)).
     pattern (S m) at 1 3 4 6, q; case q; [intro Heq | intros m0 l HeqS].
      contradiction (le_Sn_n m); rewrite Heq; assumption.
      injection HeqS; intro Heq; generalize l HeqS.
       rewrite <- Heq; intros; rewrite <- eq_rect_eq_nat.
       rewrite (IHp l0); reflexivity.
Qed.

(** Fin de la preuve **)

Lemma finites_are_omniscient : forall k, omniscient (finite_setoid k).
Proof.

  induction k.

    intro.
    assert {x : nat | x ≤ 0}. exists 0. trivial.
    assert (proj1_sig p H = true \/ proj1_sig p H = false). apply exmid_bool.
    destruct H0.
      right.
        intro.
        destruct x.
        destruct H.
        assert (x0 = x). omega.
        subst x0.
        assert (proj1_sig p (exist (λ x : nat, x ≤ 0) x l0) = proj1_sig p (exist (λ x0 : nat, x0 ≤ 0) x l)).
          apply f_equal. apply f_equal.
          apply le_uniqueness_proof.
        rewrite H in H0.
        apply H0.
      left.
        exists H.
        apply H0.

    admit.
Qed.

(*********************)
(*    Question 5.    *)
(*********************)

Fixpoint min (f : nat → bool) (n:nat) :=
  match n with
    | 0 => f 0
    | S n => andb (min f n) (f (S n))
  end.

(*********************)
(*    Question 6.    *)
(*********************)

Lemma min_trans :
  forall f n, min f (S n) = false -> min f n = false \/ (f (S n) = false).
Proof.
  intros.
  assert (min f (S n) = andb (min f n) (f (S n))). simpl (min f (S n)). trivial.
  rewrite H0 in H.
  apply andb_false_iff in H.
  destruct H.
  left. apply H.
  right. apply H.
Qed.

Lemma min_exact :
  forall f n, f n = false -> min f n = false.
Proof.
  intro.
  induction n.
    intro. simpl. apply H.
    intro. simpl. rewrite H. apply andb_false_r.
Qed.

Lemma min_sup :
  forall f n, min f n = false -> min f (S n) = false.
Proof.
  intro.
  induction n.
    intro. simpl.
    assert (f 0 = false). apply H.
    rewrite H0. apply andb_false_l.
    intro.
      simpl.
      assert (min f n && f (S n) = false). apply H.
      rewrite H0. apply andb_false_l.
Qed.

Lemma min_sup_sup :
  forall f n m, min f n = false -> n <= m -> min f m = false.
Proof.
  intro. intro.
  induction m.
    intros.
      assert (n=0). omega.
      rewrite H1 in H. apply H.
    intros.
      assert (S m = n \/ n < S m). omega.
      destruct H1.
        rewrite H1. apply H.
        assert (min f m = false). apply IHm. apply H. omega.
        apply min_sup. apply H2.
Qed.

Lemma min_true :
  forall f n, min f n = true -> forall k, k <= n -> f k = true.
Proof.
  intros.
  assert ((f k = true) \/ (f k = false)). apply exmid_bool.
  destruct H1.
    apply H1.
    exfalso.
    assert (min f n = false). apply min_sup_sup with (n := k). apply min_exact. apply H1. apply H0.
    apply eq_true_false_abs with (b:= min f n). apply H. apply H2.
Qed.

Lemma compute_minimum :
  forall f n, min f n = false -> exists p, f p = false ∧ (forall k, k < p -> f k = true).
Proof.
  intro.
  induction n.
    intro.
      exists 0. split.
        apply H.
        intros. exfalso. assert (k < 0 -> False). omega. apply H1. apply H0.
    intro.
      assert (min f n = false \/ (f (S n) = false)). apply min_trans. apply H.
      destruct H0.
        apply IHn. apply H0.
        assert (min f n = true \/ min f n = false). apply exmid_bool.
        destruct H1.
          exists (S n).
            split.
            apply H0.
            intros.
            assert (k <= n). omega.
            apply min_true with (n := n).
            apply H1. apply H3.
          apply IHn. apply H1.
Qed.

(*********************)
(*    Question 7.    *)
(*********************)

Definition Decreasing (α : nat -> bool) :=
  forall i k, i ≤ k -> α i = false -> α k = false.
Definition N_infty : setoid.
refine (mkSetoid
          (set := { α : nat -> bool | Decreasing α })
          (R := fun α β => forall n : nat, proj1_sig α n = proj1_sig β n)
          _).
apply mkEq.
  intros. auto.
  intros. auto.
  intros.
    apply eq_trans with (proj1_sig y n).
    auto. auto.
Defined.
Notation "ℕ∞" := N_infty.
Notation "x ≡ y" := (R N_infty x y) (at level 80). (* ≡ représente l'égalité sur ℕ∞ *)

(*********************)
(*    Question 8.    *)
(*********************)

Definition ω : set ℕ∞.
refine (exist _ (fun x => true) _).
  intro. auto.
Defined.

(*********************)
(*    Question 9.    *)
(*********************)

Fixpoint lt_nat (n m : nat) : bool :=
  match n with
    | O => match m with
             | O => false
             | S m' => true
           end
    | S n' => match m with
                | O => false
                | S m' => lt_nat n' m'
              end
  end.

Lemma lt_inf : forall (n m : nat), n < m -> lt_nat n m = true.
Proof.
  induction n.
    induction m.
      intro. omega.
      intro. auto.
    induction m.
      intro. omega.
      intro. simpl. apply IHn. omega.
Qed.

Lemma lt_sup : forall (n m : nat), n ≥ m -> lt_nat n m = false.
Proof.
  induction n.
    induction m.
      intro. auto.
      intro. omega.
    induction m.
      intro. auto.
      intro. simpl. apply IHn. omega.
Qed.

Lemma lt_trans : forall (k n m : nat), lt_nat n k = false -> n ≤ m -> lt_nat m k = false.
Proof.
  induction k.
    intros.
      assert (m = 0 \/ exists m', m = S m'). apply zero_or_succ.
      destruct H1. rewrite H1. simpl. auto.
      destruct H1. rewrite H1. simpl. auto.
    intros.
      assert (m = 0 \/ exists m', m = S m'). apply zero_or_succ.
      destruct H1.
        rewrite H1. assert (0 = n). omega. rewrite H2. auto.
        destruct H1. rewrite H1. simpl.
          assert (n = 0 \/ exists n', n = S n'). apply zero_or_succ.
           destruct H2.
             exfalso.
               assert (lt_nat n (S k) = true).
               rewrite H2. simpl. auto.
               apply eq_true_false_abs with (b := lt_nat n (S k)). auto. auto.
             destruct H2.
             rewrite H2 in H.
             assert (lt_nat x0 k= false). apply H.
             apply IHk with (n := x0). apply H3. omega.
Qed.

Definition of_nat (k : nat) : set ℕ∞.
refine (exist _ (fun x => lt_nat x k) _).
  intro. intros.
  apply lt_trans with (n := i).
    apply H0. apply H.
Defined.

(**********************)
(*    Question 11.    *)
(**********************)

Definition p_set (x : nat → bool) : set (ℕ ⇒ bool_setoid).
  exists x.
  intro. intros.
  destruct H.
  apply R_eq.
Defined.

Fixpoint elt_ninf (f : nat -> bool) (n : nat) : bool :=
  match n with
    | O => f 0
    | S n' => andb (f (S n')) (elt_ninf f n')
  end.

Lemma newZero : forall (p : nat -> bool) (n : nat),
  elt_ninf p n = true -> elt_ninf p (S n) = false -> p (S n) = false.
Proof.
  intros.
  assert (p (S n) && (elt_ninf p n) = false).
    apply H0.
  rewrite H in H1.
  assert (p (S n) && true = p (S n)).
  apply andb_true_r.
  rewrite H2 in H1.
  apply H1.
Qed.

Lemma alwaysZero : forall (p : nat -> bool) (n k: nat),
  elt_ninf p n = false -> k >= n -> elt_ninf p k = false.
Proof.
  intro. intro.
  induction k.
    intros.
      assert (n = 0). omega.
      rewrite H1 in H.
      apply H.
    intros.
      assert (S k = n \/ S k > n). omega.
      destruct H1.
        rewrite H1.
          apply H.
        assert (elt_ninf p k = false).
          apply IHk.
          apply H.
          omega.
          simpl.
          rewrite H2.
          apply andb_false_r.
Qed.

Lemma mkDecreasing : forall p : nat -> bool, Decreasing (elt_ninf p).
Proof.
  intro.
  unfold Decreasing.
  induction i.
    intros.
      apply alwaysZero with (n := 0).
      apply H0.
      omega.
    intros.
      apply alwaysZero with (n := S i).
      apply H0.
      omega.
Qed.

Lemma zero_before : forall (p : nat -> bool) (m : nat),
  elt_ninf p m = false -> exists n, p n = false.
Proof.
  intro.
  induction m.
    intro.
      exists 0.
      destruct H.
      simpl. auto.
    intro.
      assert (p (S m) = false \/ elt_ninf p m = false).
        apply andb_false_iff.
        apply H.
        destruct H0.
          exists (S m).
            apply H0.
          apply IHm.
            apply H0.
Qed.

Lemma true_before : forall (p : nat -> bool) (n : nat),
  elt_ninf p n = true -> p n = true.
Proof.
  intros.
  assert (n = 0 \/ exists n', n = S n'). apply zero_or_succ.
  destruct H0.
    rewrite H0 in H.
      assert (elt_ninf p 0 = p 0). auto.
      rewrite H1 in H.
      rewrite H0.
      apply H.
    destruct H0.
      subst n.
      assert (p (S x) && elt_ninf p x = true).
        apply H.
      assert (p (S x) = true /\ elt_ninf p x = true).
        apply andb_true_iff. apply H0.
      destruct H1.
      apply H1.
Qed.

Lemma almostDecreasing : forall (p : nat -> bool),
  (exists n, p n = false) <-> exists m, elt_ninf p m = false.
Proof.
  intro.
  split.
    intro.
      destruct H.
      exists x.
      assert (x = 0 \/ exists x', x = S x'). apply zero_or_succ.
      destruct H0.
        subst x.
          simpl. apply H.
        destruct H0.
          subst x.
          simpl.
          rewrite H.
          apply andb_false_l.
    intro.
      destruct H.
      apply zero_before with (m := x).
      apply H.
Qed.

Definition of_nat_of_p (p : nat -> bool) : set ℕ∞.
refine (exist _ (fun x => elt_ninf p x) _).
  apply mkDecreasing.
Defined.

Lemma false_after : forall (x : set ℕ∞) n k,
  proj1_sig x n = false -> k >= n -> proj1_sig x k = false.
Proof.
  intro. intro.
  induction k.
    intros.
      assert (n = 0). omega.
      rewrite H1 in H.
      apply H.
    intros.
      assert (S k = n \/ S k > n). omega.
      destruct H1.
        rewrite H1.
          apply H.
        assert (proj1_sig x k = false).
          apply IHk.
          apply H. omega.
          destruct x.
          unfold Decreasing in d.
          apply d with (i := k).
          omega.
          apply H2.
Qed.

Lemma p_eq_of_nat : forall x : set ℕ∞,
  (exists n, x ≡ of_nat n) <-> (exists m, proj1_sig x m = false).
Proof.
  split.
    intro.
      destruct H.
      exists (S x0).
      rewrite H.
      simpl (proj1_sig (of_nat x0)).
      assert (lt_nat (S x0) x0 = false). apply lt_sup. omega.
      apply H0.
    intro.
      destruct H.
      assert (exists p, proj1_sig x p = false ∧ (forall k, k < p -> proj1_sig x k = true)).
        apply compute_minimum with (n := x0).
        apply min_exact.
        apply H.
      destruct H0.
      exists x1.
      simpl.
      intro.
      destruct H0.
      assert (n < x1 \/ n >= x1). omega.
      destruct H2.
        specialize (H1 n).
          assert (lt_nat n x1 = true). apply lt_inf. apply H2.
          rewrite H3.
          apply H1. apply H2.
        assert (lt_nat n x1 = false). apply lt_sup. apply H2.
          rewrite H3.
          apply false_after with (n := x1).
          apply H0. omega.
Qed.

Lemma p_eq_omega : forall x : set ℕ∞,
  (forall n, proj1_sig x n = true) <-> x ≡ ω.
Proof.
  intro.
  split.
    intro.
      intro.
      simpl.
      specialize (H n).
      apply H.
    intro.
      intro.
      rewrite H.
      simpl. auto.
Qed.

Lemma LPO_equiv : omniscient ℕ <-> forall x : set ℕ∞, x ≡ ω \/ exists k, x ≡ of_nat k.
Proof.
  split.

  intro. unfold omniscient in H.
  intro. destruct x. simpl.
  specialize (H (p_set x)). destruct H.
    right.
      destruct H.
      assert (exists p, (proj1_sig (p_set x)) p = false ∧ (forall k, k < p -> (proj1_sig (p_set x)) k = true)).
        apply compute_minimum with (n:= x0). apply min_exact. apply H.
      destruct H0.
      exists x1.
      intro.
      assert (n < x1 \/ n >= x1). omega. destruct H1.
        assert (lt_nat n x1 = true). apply lt_inf. apply H1. rewrite H2.
          destruct H0. apply H3. apply H1.
        assert (lt_nat n x1 = false). apply lt_sup. apply H1. rewrite H2.
          destruct H0.
          unfold Decreasing in d. specialize (d x1 n).
          apply d. omega. apply H0.
    left.
      intro.
      apply H.

  intro. intro.
  simpl.
  destruct p. simpl.
  assert ((exists n, x n = false) <-> exists m, elt_ninf x m = false). apply almostDecreasing.
  destruct H0.
  specialize (H (of_nat_of_p x)).
  destruct H.
    right.
      assert (forall n, proj1_sig (of_nat_of_p x) n = true).
        apply p_eq_omega with (x := (of_nat_of_p x)).
        apply H.
      intro.
      specialize (H2 x0).
      apply true_before.
      apply H2.
    left.
      destruct H.
      exists x0.

      assert (x0 = 0 \/ exists x0', x0 = S x0'). apply zero_or_succ.
      destruct H2.
        specialize (H x0).
          assert (proj1_sig (of_nat x0) x0 = false).
          simpl.
          apply lt_sup. omega.
          rewrite H3 in H.
          subst x0.
          apply H.
        destruct H2.
          assert (elt_ninf x x1 = true).
            specialize (H x1).
            assert (proj1_sig (of_nat x0) x1 = true).
              simpl.
              apply lt_inf. omega.
            rewrite H3 in H.
            apply H.
          assert (elt_ninf x (S x1) = false).
            specialize (H (S x1)).
            assert (proj1_sig (of_nat x0) (S x1) = false).
              assert (S x1 = x0). omega. rewrite H4.
              simpl.
              apply lt_sup. omega.
            rewrite H4 in H.
            apply H.
          assert (x (S x1) = false).
            apply newZero. apply H3. apply H4.
          assert (S x1 = x0). omega. rewrite H6 in H5.
          apply H5.
Qed.

(**********************)
(*    Question 13.    *)
(**********************)

Lemma eq_arrow : forall (p : set (ℕ∞ ⇒ bool_setoid)) x y,
  x ≡ y -> proj1_sig p x = proj1_sig p y.
Proof.
  intros.
  destruct p.
  simpl.
  apply e.
  apply H.
Qed.

Lemma not_of_nat :
  forall p : set (ℕ∞ ⇒ bool_setoid),
    (forall k, proj1_sig p (of_nat k) = true) ->
    forall x, proj1_sig p x = false -> forall k, ~ (x ≡ of_nat k).
Proof.
  intros. intro.
  specialize (H k).
  assert (proj1_sig p x = proj1_sig p (of_nat k)).
    apply eq_arrow.
    apply H1.
  rewrite H2 in H0.
  apply eq_true_false_abs with (b := proj1_sig p (of_nat k)).
  apply H. apply H0.
Qed.

Lemma not_omega :
  forall p : set (ℕ∞ ⇒ bool_setoid),
    proj1_sig p ω = true -> forall x, proj1_sig p x = false -> ~ (x ≡ ω).
Proof.
  intros. intro.
  assert (proj1_sig p x = proj1_sig p ω).
    apply eq_arrow.
    apply H1.
  rewrite H2 in H0.
  apply eq_true_false_abs with (b := proj1_sig p ω).
  apply H. apply H0.
Qed.

Lemma not_of_nat_k :
  forall x : set ℕ∞,
    (forall k, ~ (x ≡ of_nat k)) -> forall k, proj1_sig x k = true.
Proof.
  intros.
  assert (proj1_sig x k = true \/ proj1_sig x k = false).
    apply exmid_bool.
  destruct H0.
    apply H0.
    assert (exists n, x ≡ of_nat n).
      apply p_eq_of_nat. exists k.
      apply H0.
    destruct H1.
    specialize (H x0).
    exfalso.
    apply H. apply H1.
Qed.

Lemma not_of_nat_impl_omega :
  forall x : set ℕ∞,
    (forall k, ~ (x ≡ of_nat k)) -> x ≡ ω.
Proof.
  intros.
  assert (forall k, proj1_sig x k = true).
    apply not_of_nat_k. apply H.
  intro.
  specialize (H0 n).
  simpl.
  rewrite H0.
  auto.
Qed.

Lemma density :
  forall p : set (ℕ∞ ⇒ bool_setoid),
    proj1_sig p ω = true ->
    (forall k, proj1_sig p (of_nat k) = true) ->
    forall x, proj1_sig p x = true.
Proof.
  intros.
  assert (proj1_sig p x = false -> forall k, ~ (x ≡ of_nat k)).
    intro. apply not_of_nat with (p:=p). apply H0. apply H1.
  assert ((forall k, ~ (x ≡ of_nat k)) -> x ≡ ω).
    apply not_of_nat_impl_omega.
  assert (proj1_sig p x = false -> x ≡ ω).
    intro. apply H2. apply H1. apply H3.
  assert (~ (proj1_sig p x = false)).
    intro.
    assert (x ≡ ω). apply H3. apply H4.
    assert (proj1_sig p x = proj1_sig p ω).
      apply eq_arrow.
      apply H5.
    rewrite H6 in H4. rewrite H4 in H.
    assert (false <> true). auto.
    apply H7. apply H.
  destruct (proj1_sig p x).
  auto. auto.
Qed.

(**********************)
(*    Question 14.    *)
(**********************)

Definition ε (p : set (ℕ∞ ⇒ bool_setoid)) : set ℕ∞.
refine (exist _ (fun n => min (fun m => proj1_sig p (of_nat m)) n) _).
  intro. intros.
  apply min_sup_sup with (n:= i).
  assumption. assumption.
Defined.

(**********************)
(*    Question 15.    *)
(**********************)

Lemma ε_correct : forall p, proj1_sig p (ε p) = true <-> forall x, proj1_sig p x = true.
Proof. (* proj1_sig ajouté *)
  admit.
Qed.

(**********************)
(*    Question 16.    *)
(**********************)

Theorem N_infty_omniscient : omniscient ℕ∞.
Proof.
  apply searchable_implies_omniscient.
  exists ε.
  apply ε_correct.
Qed.

(**********************)
(*    Question 17.    *)
(**********************)

Lemma finite_falsification :
  forall p : set (ℕ∞ ⇒ bool_setoid),
    (exists x, (¬ (x ≡ ω) /\ proj1_sig p x = false)) \/ (forall n, proj1_sig p (of_nat n) = true).
Proof.
  admit.
Qed.