Require Export Coq.Relations.Relations.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Program.Program.
Require Export Basic.
Require Import Arith.
Require Import Coq.Arith.PeanoNat.

Class PartialOrder {A} `{Equiv A} (Ale : Le A) : Prop :=
  { po_setoid : Setoid A
  ; po_proper :> Proper ((=) ==> (=) ==> iff) (≤)
  ; po_preorder :> PreOrder (≤)
  ; po_antisym :> AntiSymmetric (≤) }.

Lemma eq_implies_leq {A} `{Po : PartialOrder A} :
  forall x y,
    x = y ->
    x ≤ y /\ y ≤ x.
Proof.
  intros x y C.
  destruct Po.
  rewrite C.
  split; reflexivity.
Qed.

Class TotalOrder {A} `{Ae : Equiv A} (Ale : Le A) : Prop :=
  { total_order_po :> PartialOrder (≤)
  ; total_order_total :> TotalRelation (≤) }.

Section DualOrd.

  Context {A} `{Equiv A} `{Le A}.

  Lemma geq_is_preo `{!PreOrder (≤)} : PreOrder (≥).
  Proof.
    split.
      intros x; reflexivity.
      intros x y z x_le_y y_le_z; transitivity y; assumption.
  Qed.

  Lemma geq_is_po `{!PartialOrder (≤)} : PartialOrder (≥).
  Proof.
    pose proof po_setoid.
    split.
      assumption.
      unfold le, flip.
        reduce.
        rewrite <- H2; rewrite <- H3; tauto.
      apply geq_is_preo.
      intros x y x_le_y y_le_x.
      apply po_antisym.
      apply y_le_x.
      apply x_le_y.
  Qed.

End DualOrd.

Existing Instance geq_is_preo.
Existing Instance geq_is_po.

Section SubOrd.

  Context {A} {P: A->Prop}.

  Definition sub_equiv `{Equiv A} : Equiv {x : A | P x} := sig_equiv P.

  Definition sub_leq (le : Le A) : Le {x : A | P x} := sig_le P.

  Existing Instance sub_equiv.
  Existing Instance sub_leq.

  Instance subord_is_setoid `{Setoid A} : Setoid { x : A | P x }.
  Proof.
  split.
  - unfold Reflexive. intro. unfold equiv. unfold sub_equiv. unfold sig_equiv. reflexivity.
  - unfold Symmetric. intros. unfold equiv. unfold sub_equiv. unfold sig_equiv. destruct H. unfold Symmetric in Equivalence_Symmetric. apply Equivalence_Symmetric.
    unfold equiv in H0. unfold sub_equiv in H0. trivial.
  - unfold Transitive. intros. unfold equiv. unfold sub_equiv. unfold sig_equiv.
    unfold equiv in H0. unfold sub_equiv in H0. unfold equiv in H1. unfold sub_equiv in H1. unfold sig_equiv in H1. rewrite <- H1. trivial.
  Qed.

  Instance subord_is_preorder (leq : Le A) `{!PreOrder leq} : PreOrder (sub_leq leq).
  Proof.
  split.
  - reduce. destruct PreOrder0. unfold Reflexive in PreOrder_Reflexive. apply PreOrder_Reflexive.
  - unfold sub_leq. reduce. destruct PreOrder0. apply transitivity with (y0:=proj1_sig y).
    + apply H.
    + apply H0.
  Qed.

  Global Instance subord_is_partialorder `{Equiv A} (leq : Le A) `{!PartialOrder leq} : PartialOrder (sub_leq leq).
  Proof.
  destruct PartialOrder0. split.
  - apply subord_is_setoid.
  - reduce. unfold le. unfold sub_leq. unfold sig_le. unfold equiv in H0. unfold sub_equiv in H0. unfold sig_equiv in H0.
    unfold equiv in H1. unfold sub_equiv in H1. unfold sig_equiv in H1. rewrite H0. rewrite H1. reflexivity.
  - apply subord_is_preorder. apply po_preorder0.
  - unfold AntiSymmetric. intros. unfold equiv. unfold sub_equiv.
    unfold AntiSymmetric in po_antisym0. apply po_antisym0.
    + reduce in H0. assumption.
    + reduce in H1. assumption.
  Qed.

End SubOrd.

Section ArrowOrd.

  Context {A B: Type}.

  Global Instance arrow_equiv `{Equiv B} : Equiv (A->B) :=
    fun (f g : A->B) => forall x, f x = g x.

  Definition arrow_leq `{Le B} : Le (A->B) :=
    fun (f g : A->B) => forall x, f(x) ≤ g(x).

  Global Instance arrow_leq_inst `{Le B} : Le (A->B) := arrow_leq.

  Lemma arrow_is_preorder {leb : Le B} `{!PreOrder leb} : PreOrder (@arrow_leq leb).
  Proof.
    intros.
    split.
    - reduce. reflexivity.
    - unfold Transitive. intros f h g.
      unfold arrow_leq. intro f_less_than_h.
      firstorder.
      specialize (f_less_than_h x).
      apply transitivity with (y:=h x).
      assumption.
      apply H.
  Qed.

  Global Instance arrow_is_setoid `{Setoid B} : Setoid (A->B).
  Proof.
  split.
  - unfold Reflexive. unfold equiv. unfold arrow_equiv. intros f x.
    destruct H. unfold Reflexive in Equivalence_Reflexive. apply Equivalence_Reflexive.
  - unfold Symmetric. unfold equiv. unfold arrow_equiv. intros f g. firstorder.
  - unfold Transitive. unfold equiv. unfold arrow_equiv. intros f h g. firstorder.
  Qed.

  Instance po_is_setoid `{PartialOrder B} : Setoid B := po_setoid.

  Global Instance arrow_is_partialorder (leb: Le B) `{Equiv B} `{!PartialOrder leb}: PartialOrder (@arrow_leq leb).
  Proof.
  split.
  - apply arrow_is_setoid.
  - reduce. unfold le. unfold arrow_leq. unfold equiv in H0. unfold arrow_equiv in H0.
    unfold equiv in H1. unfold arrow_equiv in H1.
    split.
    + intro. intro w. rewrite <- H1. rewrite <- H0. apply H2.
    + intro. intro w. rewrite -> H1. rewrite -> H0. apply H2.
  - apply arrow_is_preorder.
  - unfold AntiSymmetric. unfold le. unfold arrow_leq. unfold equiv. unfold arrow_equiv.
    intros f g. intros. apply po_antisym.
    + apply H0.
    + apply H1.
  Qed.

End ArrowOrd.

Section order_maps.

  Context {A B : Type}
          {Ae: Equiv A} {Ale: Le A}
          {Be: Equiv B} {Ble: Le B}
          (f : A -> B).

  Class OrderMorphism :=
    { order_po_a : PartialOrder Ale
    ; order_po_b : PartialOrder Ble
    ; ordermor :> SetoidMorphism f }.

  Class OrderPreserving :=
    { order_preserving_mor :> OrderMorphism
    ; order_preserving : forall x y, x ≤ y -> f x ≤ f y }.

  Class OrderReflecting :=
    { order_reflecting_mor :> OrderMorphism
    ; order_reflecting  : forall x y, f x ≤ f y -> x ≤ y }.

  Class OrderEmbedding :=
    { order_embedding_preserving :> OrderPreserving
    ; order_embedding_reflecting :> OrderReflecting }.

  Class OrderIsomorphism `{!Inverse f} :=
    { order_iso_embedding :> OrderEmbedding
    ; order_iso_surjective :> Surjective f }.

  Class OrderReversing :=
    { order_reversing_mor :> OrderMorphism
    ; order_reversing  : forall x y, x ≤ y -> f y ≤ f x }.

End order_maps.

Hint Extern 4 (?f _ ≤ ?f _) => apply (order_preserving f).

Lemma compose_is_order_morphism {A B C}
  `{poA: PartialOrder A} `{poB : PartialOrder B} `{poC: PartialOrder C}:
  forall (f: B->C) (g: A->B),
    OrderMorphism f ->
    OrderMorphism g ->
    OrderMorphism (compose f g).
Proof.
intros f g fop gop.
split. assumption. assumption.
  split. apply po_setoid. apply po_setoid.
  reduce. destruct poA. destruct poB. destruct poC. destruct fop. destruct gop.
  rewrite H2. reflexivity.
Qed.

Lemma compose_preserving_is_preserving {A B C}
  `{poA: PartialOrder A} `{poB : PartialOrder B} `{poC: PartialOrder C}:
  forall (f: B->C) (g: A->B),
    OrderPreserving f ->
    OrderPreserving g ->
    OrderPreserving (compose f g).
Proof.
intros f g f_op g_op. split.
- apply compose_is_order_morphism. apply f_op. apply g_op.
- intros x y x_le_y. unfold compose. apply order_preserving. apply f_op.
  apply order_preserving. apply g_op. apply x_le_y.
Qed.

Lemma compose_reversing_is_preserving {A B C}
  `{poA: PartialOrder A} `{poB : PartialOrder B} `{poC: PartialOrder C}:
  forall (f: B->C) (g: A->B),
    OrderReversing f ->
    OrderReversing g ->
    OrderPreserving (compose f g).
Proof.
intros f g f_or g_or. split.
- apply compose_is_order_morphism. apply f_or. apply g_or.
- intros x y x_le_y. unfold compose. apply order_reversing. apply f_or.
  apply order_reversing. apply g_or. apply x_le_y.
Qed.

Definition fmon (A B : Type) `{PartialOrder A} `{PartialOrder B} :=
    { f : A->B | OrderPreserving f}.

Infix "-m>" := fmon (at level 30, right associativity).

Definition fmon_as_fun {A} {B}
  `{PartialOrder A} `{PartialOrder B} (f : A -m> B) : A -> B := proj1_sig f.

Coercion fmon_as_fun : fmon >-> Funclass.

(* Composition of monotone functions is monotone *)
Definition fmon_comp {O1 O2 O3 : Type}
  `{PartialOrder O1} `{PartialOrder O2} `{PartialOrder O3} :
    (O2 -m> O3) -> (O1 -m> O2) -> O1 -m> O3.
intros f g; exists (compose f g).
apply compose_preserving_is_preserving. apply (proj2_sig f). apply (proj2_sig g).
Defined.

(*
Definition similar {O1 O2} `{PartialOrder O1} `{PartialOrder O2} :=
  exists f : O1 -> O2, OrderIsomorphism f.
*)

Section ProdOrd.

  Context {A B : Type}.

  Global Instance prod_equiv `{Equiv A} `{Equiv B} : Equiv (A*B) := {
     equiv (x y : A*B) := (fst x) = (fst y) /\ (snd x) = (snd y) }.

  Global Instance prod_leq `{Le A} `{Le B} : Le (A*B) := {
    le (x y : A*B) := (fst x) ≤ (fst y) /\ (snd x) ≤ (snd y) }.

  Lemma prod_is_preorder {lea : Le A} `{!PreOrder lea} {leb : Le B} `{!PreOrder leb} : PreOrder prod_leq.
  Proof.
  split.
  - unfold Reflexive. unfold prod_leq. intro x. split. reflexivity. reflexivity.
  - unfold Transitive. intros x y z. unfold prod_leq. intros [HFstxy HSndxy]. intros [HFstyz HSndyz].
    split. transitivity (fst y). assumption. assumption. transitivity (snd y). assumption. assumption.
  Qed.

  Global Instance prod_is_setoid `{Setoid A} `{Setoid B} : Setoid (A*B).
  Proof.
  split.
    - unfold Reflexive. intro. split. reflexivity. reflexivity.
    - unfold Symmetric. intros x y. unfold equiv. unfold prod_equiv.
      intros [HFxy HSxy]. split. symmetry. assumption. symmetry. assumption.
    - unfold Transitive. intros x y z. unfold equiv. unfold prod_equiv. intros [HFxy HSxy] [HFyz HSyz].
      split. transitivity (fst y). assumption. assumption. transitivity (snd y).
      assumption. assumption.
  Qed.

  Global Instance prod_is_partialorder `{Equiv A} (lea : Le A) `{!PartialOrder lea}
             `{Equiv B} (leb : Le B) `{!PartialOrder leb} : PartialOrder (@prod_leq lea leb).
  Proof.
  split.
    - destruct PartialOrder0. destruct PartialOrder1. apply prod_is_setoid.
    - reduce. unfold le. unfold prod_leq. unfold equiv in *. unfold prod_equiv in *.
      destruct H1. destruct H2. destruct PartialOrder0. destruct PartialOrder1.
      rewrite <- H1. rewrite <- H3. rewrite <- H2. rewrite <- H4. split. trivial. trivial.
    - apply prod_is_preorder.
    - unfold AntiSymmetric. unfold le. unfold prod_leq. unfold equiv. unfold prod_equiv.
      intros x y. intros [HFxy HSxy] [HFyx HSyx]. destruct PartialOrder0. destruct PartialOrder1.
      split.
        apply po_antisym0. assumption. assumption.
        apply po_antisym1. assumption. assumption.
  Qed.

End ProdOrd.

Class Pointed {A} (leq : Le A) :=
 { bot : A
 ; Pbot : forall x : A, bot ≤ x }.

Open Scope nat.

Instance : Equiv nat := Nat.eq.
Definition le_nat := fun (x y: nat) => (x <= y)%nat.
Instance : Le nat := le_nat.
Instance : PartialOrder (le_nat).
Admitted.

Close Scope nat.

Class CompletePartialOrder {A} `{Equiv A} (Ale : Le A) := {
    cpo_po :> PartialOrder (≤)
  ; lub : forall (F : nat-m>A), A
  ; cpo_lub_le: forall (F : nat-m>A) (n : nat), F n ≤ lub F
  ; cpo_le_lub: forall (F : nat-m>A) (x : A), (forall n, F n ≤ x) -> lub F ≤ x }.

Lemma lub_le_order_preserving {A} {B}
  `{CompletePartialOrder A}
  `{CompletePartialOrder B} :
  forall (f:A-m>B) (s : nat -m>A),
    lub (fmon_comp f s) ≤ f (lub s).
Proof.
  intros f s.
  apply cpo_le_lub.
  intros.
  unfold fmon_comp. unfold compose. simpl.
  apply order_preserving.
  apply (proj2_sig f).
  apply cpo_lub_le.
Qed.

Section ArrowCPO.

  Context {A:Type} {B} `{Equiv B} {leb : Le B} `{!CompletePartialOrder leb}.

  Instance : Setoid B := po_setoid.

  Definition funseq (s : nat-m>(A->B)) (a : A) : nat-m>B.
  exists (fun (n : nat) => s n a).
  split.
  split.
  apply PartialOrder_instance_0.
  apply CompletePartialOrder0.
  split.
  apply PartialOrder_instance_0.
  apply CompletePartialOrder0.
  reduce.
  rewrite H0.
  apply po_setoid.
  intros x y x_le_y.
  apply (proj2_sig s).
  apply x_le_y.
  Defined.

  Definition lubF := fun (f : nat-m> (A->B)) => fun (a : A) => lub (funseq f a).

  Global Instance : CompletePartialOrder (@arrow_leq A B leb) := {
    lub := lubF
  }.
  Proof.
    intros F n.
    unfold le.
    unfold arrow_leq.
    intro x.
    assert (F n x = funseq F x n).
    { unfold funseq. simpl. reflexivity. }
    rewrite H0.
    apply cpo_lub_le.
    intros F x H1.
    unfold le in *.
    unfold arrow_leq in *.
    intro x0.
    apply cpo_le_lub.
    intro n.
    apply H1.
  Defined.

End ArrowCPO.

Section SubCPO.

  Context {A:Type} {P : A ->Prop} `{Equiv A} `{leq : Le A} `{!CompletePartialOrder leq}.

  Variable PSlub: forall (S : nat-m>A), (forall n, P (S n)) -> P (lub S).

  Definition Embed (t : A) (p : P t) : { x : A | P x }.
  exists t . apply p.
  Defined.

  Definition Extend (S : nat-m>{ x : A | P x }) : nat-m>A.
  destruct S.
  exists (fun n => proj1_sig (x n)).
  split.
  split.
  apply PartialOrder_instance_0.
  apply CompletePartialOrder0.
  split.
  apply PartialOrder_instance_0.
  apply CompletePartialOrder0.
  apply o.
  apply o.
  Defined.

  Lemma ExtendP : forall (S : nat-m>{x : A | P x}) t, P (Extend S t).
  intros S t. destruct S. unfold Extend. simpl. apply (proj2_sig (x t)).
  Defined.

  Global Instance subord_is_cpo : CompletePartialOrder (@sub_leq A P leq) := {
    lub := fun (S: nat-m>{x:A | P x}) => Embed (lub (Extend S)) (PSlub (Extend S) (ExtendP S))
  }.
  intros F n. unfold le. unfold sub_leq. unfold sig_le. unfold Embed. simpl.
  assert (proj1_sig (F n) = Extend F n). {
    destruct F.
    unfold Extend.
    simpl.
    apply po_setoid.
  }
  destruct CompletePartialOrder0. destruct cpo_po0.
  rewrite H0.
  apply cpo_lub_le.
  intros F x H1.
  unfold Embed.
  unfold le.
  unfold sub_leq.
  unfold sig_le.
  simpl.
  apply cpo_le_lub.
  intro n.
  assert (proj1_sig (F n) = Extend F n). {
    destruct F.
    unfold Extend.
    simpl.
    apply po_setoid.
  }
  destruct CompletePartialOrder0. destruct cpo_po0.
  rewrite <- H0.
  apply H1.
  Defined.

End SubCPO.

Section FmonCPO.

  Context {A B} `{Equiv A} `{lea : Le A} `{!CompletePartialOrder lea}
          `{Equiv B} `{leb : Le B} `{!CompletePartialOrder leb}.

Lemma lub_is_op :
  forall (S : nat-m>(A->B)),
    (forall n, OrderPreserving (S n)) ->
    OrderPreserving (lub S).
Proof.
  intros S H1.
  split.
  split.
  apply CompletePartialOrder0.
  apply CompletePartialOrder1.
  split.
  apply CompletePartialOrder0.
  apply CompletePartialOrder1.
  reduce.
  unfold lub.
  unfold CompletePartialOrder_instance_0.
  unfold lubF.
  apply po_antisym.
    apply cpo_le_lub.
    intro.
    unfold funseq at 1.
    simpl.
    specialize H1 with n.
    destruct H1.
    destruct order_preserving_mor0.
    destruct order_po_b0.
    destruct po_setoid0.
    rewrite H2.
    assert (S n y = (funseq S y) n). {
      unfold funseq.
      simpl.
      reflexivity. }
    rewrite H1.
    apply cpo_lub_le.
    apply cpo_le_lub.
    intro.
    unfold funseq at 1.
    simpl.
    specialize H1 with n.
    destruct H1.
    destruct order_preserving_mor0.
    destruct order_po_b0.
    destruct po_setoid0.
    destruct ordermor0.
    assert (S n y = (funseq S x) n). {
      unfold funseq.
      simpl.
      rewrite <- H2.
      reflexivity. }
    rewrite H1.
    apply cpo_lub_le.
  intros x y x_le_y.
  apply cpo_le_lub.
  intro n.
  unfold funseq.
  simpl.
  transitivity (S n y).
  apply H1.
  apply x_le_y.
  unfold lubF.
  assert (S n y = (funseq S y) n).
  { unfold funseq. simpl.
    destruct CompletePartialOrder1.
    destruct cpo_po0.
    reflexivity. }
  destruct CompletePartialOrder1.
  destruct cpo_po0.
  rewrite H2.
  apply cpo_lub_le.
Qed.

Global Instance : CompletePartialOrder (@sub_leq (A->B) OrderPreserving arrow_leq) :=
  subord_is_cpo lub_is_op.

End FmonCPO.

Section LubLemmas.

  Context {A} `{CompletePartialOrder A}.

Lemma lub_le_compat :
  forall (f g : nat-m>A),
    f ≤ g ->
    lub f ≤ lub g.
Proof.
  intros.
  apply cpo_le_lub.
  intros.
  transitivity (g n).
  apply H1.
  apply cpo_lub_le.
Qed.

Definition seq_lift_left :
    forall (f : nat-m>A) (n:nat), nat-m>A.
intros.
exists (fun k => f (n+k)%nat).
split.
- split. apply PartialOrder_instance_0. apply H0.
  split. apply po_setoid. apply po_setoid.
  reduce. destruct f. destruct o. destruct order_preserving_mor0.
  destruct H0. destruct cpo_po0. destruct ordermor0. simpl.
  rewrite H1. reflexivity.
- intros x y x_le_y.
  apply order_preserving.
  apply (proj2_sig f).
  unfold le. unfold Le_instance_0. unfold le_nat.
  auto with arith.
Defined.

Lemma lub_lift_left :
  forall (f : nat-m>A) (n:nat),
    lub f = lub (seq_lift_left f n).
Proof.
intros.
apply po_antisym.
apply lub_le_compat.
unfold seq_lift_left.
unfold le. unfold sub_leq_inst. unfold sub_leq. unfold sig_le.
simpl. unfold le. unfold arrow_leq_inst. unfold arrow_leq.
intro. apply order_preserving. apply (proj2_sig f).
unfold le. unfold Le_instance_0. unfold le_nat. auto with arith.
apply cpo_le_lub. intro. unfold seq_lift_left. unfold fmon_as_fun.
simpl. apply cpo_lub_le.
Qed.

Definition cta (x : A) : nat-m>A.
exists (fun _ => x).
split.
- split.
  apply PartialOrder_instance_0.
  apply cpo_po.
  split.
  apply PartialOrder_instance_0.
  apply cpo_po.
  reduce. destruct H0. destruct cpo_po0. reflexivity.
- intros. reflexivity.
Defined.

End LubLemmas.

Global Instance lub_eq_wd {A} `{CompletePartialOrder A} : Proper (equiv ==> equiv) lub.
Proof.
reduce.
apply po_antisym.
- destruct H0. destruct cpo_po0. apply lub_le_compat.
  unfold le. unfold sub_leq_inst. unfold sub_leq.
  unfold sig_le. unfold le. unfold arrow_leq_inst. unfold arrow_leq.
  intro. unfold equiv in H1. unfold sub_equiv in H1. unfold sig_equiv in H1.
  unfold equiv in H1. unfold arrow_equiv in H1. rewrite H1. reflexivity.
- destruct H0. destruct cpo_po0. apply lub_le_compat.
  unfold le. unfold sub_leq_inst. unfold sub_leq.
  unfold sig_le. unfold le. unfold arrow_leq_inst. unfold arrow_leq.
  intro. unfold equiv in H1. unfold sub_equiv in H1. unfold sig_equiv in H1.
  unfold equiv in H1. unfold arrow_equiv in H1. rewrite H1. reflexivity.
Qed.

Section continuous_maps.

Context {A B} `{CompletePartialOrder A} `{CompletePartialOrder B} (f: A-m>B).

Class LimitPreserving :=
  { limit_preserving: forall (s:nat-m>A), lub (fmon_comp f s) = f (lub s) }.

End continuous_maps.

Lemma limit_compose_preserving_is_preserving {A B C}
  `{CompletePartialOrder A} `{CompletePartialOrder B} `{CompletePartialOrder C}:
  forall (f: B-m>C) (g: A-m>B),
    LimitPreserving f ->
    LimitPreserving g ->
    LimitPreserving (fmon_comp f g).
Proof.
intros f g f_lp g_lp.
split. intro s.
unfold fmon_comp at 3.
unfold compose.
simpl.
destruct H0. destruct H2. destruct H4.
destruct cpo_po0. destruct cpo_po1. destruct cpo_po2.
assert (SetoidMorphism f). { apply (proj2_sig f). }
rewrite <- limit_preserving.
rewrite <- limit_preserving.
assert (fmon_comp (fmon_comp f g) s = fmon_comp f (fmon_comp g s)). {
unfold fmon_comp.
unfold equiv. unfold sub_equiv. unfold sig_equiv. simpl.
unfold compose.  reflexivity.
}
rewrite H2.
reflexivity.
assumption.
assumption.
Qed.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From PLF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import Stlc.
From PLF Require Import Smallstep.

Module STLCProp.
Import STLC.

Lemma canonical_forms_bool : forall t,
  empty |- t \in Bool ->
  value t ->
  (t = <{true}>) \/ (t = <{false}>).
Proof. intros t Ht Hv.
  inversion Hv.
  - subst. inversion Ht.
  - left. reflexivity.
  - right. reflexivity.
Qed.

Lemma canonical_forms_fun : forall t T1 T2,
  empty |- t \in (T1 -> T2) ->
  value t ->
  exists x u, t = <{\x:T1, u}>.
Proof. intros t T1 T2 Ht Hv.
  inversion Hv; subst.
  - exists x0, t1. inversion Ht; subst. reflexivity.
  - inversion Ht.
  - inversion Ht.
Qed.

Theorem progress : forall t T,
  empty |- t \in T ->
  value t \/ exists t', t --> t'.
Proof. intros t T Ht.
  remember empty as e eqn:Ee.
  induction Ht; subst.
  - (*var*) discriminate H.
  - (*abs*) left. constructor.
  - (*app*)
    destruct IHHt1; try reflexivity.
    + (*t1 value*)
      destruct IHHt2; try reflexivity.
      * (*t2 value*)
        right.
        inversion H; subst; try (inversion Ht1; subst).
        exists <{ [x0:=t2]t0 }>.
        apply ST_AppAbs.
        assumption.
      * (*t2 progress*)
        right.
        destruct H0 as [t' Hr].
        exists <{t1 t'}>.
        apply ST_App2.
        apply H.
        apply Hr.
    + (*t1 progress*)
      right.
      destruct H as [t' Hr].
      exists <{t' t2}>.
      apply ST_App1.
      apply Hr.
  - (*true*) left. constructor.
  - (*false*) left. constructor.
  - (*if*)
    right.
    destruct IHHt1; try reflexivity.
    + (*t1 val*)
      inversion H; subst; try (inversion Ht1; subst).
      * eexists. apply ST_IfTrue.
      * eexists. apply ST_IfFalse.
    + (*t1 progr*) destruct H as [t' H]. eexists.
      apply ST_If. apply H.
Qed.

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t --> t'.
Proof.
  intros t.
  induction t; intros T Ht; auto.
  - (*var*) inversion Ht. discriminate H1.
  - (*app*) inversion Ht; subst.
    destruct (IHt1 _ H2).
    + (*t1 val*) destruct (IHt2 _ H4).
      * (*t2 val*) inversion H; subst; try (inversion H2; subst).
        right.
        exists <{ [x0:=t2]t0 }>.
        constructor. assumption.
      * (*t2 progr*) right.
        destruct H0 as [t' Ht'].
        exists <{ t1 t' }>.
        apply ST_App2. assumption.
        apply Ht'.
    + (*t1 progr*)
      destruct H as [t' Ht'].
      right. exists <{ t' t2 }>.
      apply ST_App1. assumption.
  - (*if*)
    right.
    inversion Ht; subst.
    destruct (IHt1 <{Bool}>); try assumption.
    + (*t1 val*)
      inversion H; subst; try (inversion H3; subst).
      * eexists. apply ST_IfTrue.
      * eexists. apply ST_IfFalse.
    + (*t1 progr*) destruct H as [t' H]. eexists.
      apply ST_If. apply H.
Qed.

Lemma weakening : forall Gamma Gamma' t T,
     inclusion Gamma Gamma' ->
     Gamma |- t \in T ->
     Gamma' |- t \in T.
Proof.
  intros Gamma Gamma' t T H Ht.
  generalize dependent Gamma'.
  induction Ht; eauto using inclusion_update.
Qed.

Lemma weakening_empty : forall Gamma t T,
     empty |- t \in T ->
     Gamma |- t \in T.
Proof.
  intros Gamma t T.
  eapply weakening.
  discriminate.
Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
  (x |-> U ; Gamma) |-  t \in T ->
  empty |- v \in U ->
  Gamma |- [x:=v]t \in T.
Proof.
  intros Gamma x U t v T Ht Hv.
  generalize dependent Gamma. generalize dependent T.
  induction t; intros T Gamma H;
  (* in each case, we'll want to get at the derivation of H *)
    inversion H; clear H; subst; simpl; eauto.
  - (* var *)
    rename s into y. destruct (eqb_stringP x y); subst.
    + (* x=y *)
      rewrite update_eq in H2.
      injection H2 as H2; subst.
      apply weakening_empty. assumption.
    + (* x<>y *)
      apply T_Var. rewrite update_neq in H2; auto.
  - (* abs *)
    rename s into y, t into S.
    destruct (eqb_stringP x y); subst; apply T_Abs.
    + (* x=y *)
      rewrite update_shadow in H5. assumption.
    + (* x<>y *)
      apply IHt.
      rewrite update_permute; auto.
Qed.

Lemma substitution_preserves_typing_from_typing_ind : forall Gamma x U t v T,
  (x |-> U ; Gamma) |- t \in T  ->
  empty |- v \in U  ->
  Gamma |- [x:=v]t \in T.
Proof.
  intros Gamma x U t v T Ht Hv.
  remember (x |-> U; Gamma) as Gamma'.
  generalize dependent Gamma.
  induction Ht; intros Gamma' G; simpl; eauto.
  - rename x0 into y. destruct (eqb_stringP x y); subst.
    + rewrite update_eq in H. injection H as H'. subst. apply weakening_empty. assumption.
    + rewrite update_neq in H. constructor. assumption.
      assumption.
  - rename x0 into y. destruct (eqb_stringP x y); subst.
    + apply T_Abs.
      rewrite update_shadow in Ht. assumption.
    + apply T_Abs.
      apply IHHt.
      rewrite update_permute; auto.
Qed.

Theorem preservation : forall t t' T,
  empty |- t \in T ->
  t --> t' ->
  empty |- t' \in T.
Proof with eauto.
  intros t t' T HT. generalize dependent t'.
  remember empty as Gamma.
  induction HT;
       intros t' HE; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and eauto takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T2...
      inversion HT1...
Qed.

Definition stuck (t:tm) : Prop :=  (normal_form step) t /\ ~(value t).
Corollary type_soundness : forall t t' T,
  empty |- t \in T ->
  t -->* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  - apply progress in Hhas_type.
    destruct Hhas_type as [Hval | Hprogr].
    + apply Hnot_val. assumption.
    + apply Hnf. assumption.
  - apply IHHmulti; try assumption.
    apply preservation with x0; try assumption.
Qed.

Theorem unique_types : forall Gamma e T T',
  Gamma |- e \in T  ->
  Gamma |- e \in T' ->
  T = T'.
Proof.
  intros G e.
  generalize dependent G.
  induction e; intros G T T' H H'.
  - (*var*) inversion H; subst. inversion H'; subst.
    rewrite H2 in H3. injection H3 as H3. assumption.
  - (*app*) inversion H; subst. inversion H'; subst.
    assert (Hg: (<{T2 -> T}>) = (<{T0 -> T'}>)). {
      apply (IHe1 G). assumption. assumption.
    }
    injection Hg as Hg1 Hg2.
    assumption.
  - (*abs*) inversion H; subst. inversion H'; subst.
    assert (Hg: T1 = T0). {
      eapply IHe.
      apply H5.
      apply H6.
    }
    rewrite Hg.
    reflexivity.
  - (*true*) inversion H; subst. inversion H'; subst.
    reflexivity.
  - (*false*) inversion H; subst. inversion H'; subst.
    reflexivity.
  - (*if*) inversion H; subst. inversion H'; subst.
    apply (IHe2 G).
    assumption.
    assumption.
Qed.

Inductive appears_free_in (x : string) : tm -> Prop :=
  | afi_var : appears_free_in x <{x}>
  | afi_app1 : forall t1 t2,
      appears_free_in x t1 ->
      appears_free_in x <{t1 t2}>
  | afi_app2 : forall t1 t2,
      appears_free_in x t2 ->
      appears_free_in x <{t1 t2}>
  | afi_abs : forall y T1 t1,
      y <> x ->
      appears_free_in x t1 ->
      appears_free_in x <{\y:T1, t1}>
  | afi_if1 : forall t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x <{if t1 then t2 else t3}>
  | afi_if2 : forall t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x <{if t1 then t2 else t3}>
  | afi_if3 : forall t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x <{if t1 then t2 else t3}>.
Hint Constructors appears_free_in : core.

Definition closed (t:tm) :=   forall x, ~(appears_free_in x t).

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof.
  intros x t T G H.
  generalize dependent G.
  generalize dependent T.
  induction H; intros T G Ht; inversion Ht; subst.
  - exists T.  assumption.
  - apply IHappears_free_in in H3. assumption.
  - apply IHappears_free_in in H5. assumption.
  - apply IHappears_free_in in H6. rewrite update_neq in H6.
    assumption.
    assumption.
  - apply IHappears_free_in in H4. assumption.
  - apply IHappears_free_in in H6. assumption.
  - apply IHappears_free_in in H7. assumption.
Qed.

Corollary typable_empty__closed : forall t T,
    empty |- t \in T ->
    closed t.
Proof.
  intros t T Ht x Hfr.
  inversion Ht; subst.
  - discriminate H.
  - inversion Hfr; subst.
    destruct (free_in_context _ _ _ _ H4 H) as [T' Hgt'].
    rewrite update_neq in Hgt'.
    + discriminate Hgt'.
    + assumption.
  - inversion Hfr; subst.
    + destruct (free_in_context _ _ _ _ H2 H) as [T' Hgt'].
      discriminate Hgt'.
    + destruct (free_in_context _ _ _ _ H2 H0) as [T' Hgt'].
      discriminate Hgt'.
  - inversion Hfr.
  - inversion Hfr.
  - inversion Hfr; subst.
    + destruct (free_in_context _ _ _ _ H3 H) as [T' Hgt'].
      discriminate Hgt'.
    + destruct (free_in_context _ _ _ _ H3 H0) as [T' Hgt'].
      discriminate Hgt'.
    + destruct (free_in_context _ _ _ _ H3 H1) as [T' Hgt'].
      discriminate Hgt'.
Qed.

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.
Proof.
  intros G G' t T Ht.
  generalize dependent G'.
  induction Ht; intros G' F.
  - constructor.
    rewrite <- (F x0).
      assumption.
      constructor.
  - apply T_Abs.
    apply IHHt.
    intros x' Hx'.
    destruct (eqb_stringP x0 x').
    + subst. rewrite update_eq. rewrite update_eq. reflexivity.
    + rewrite update_neq; try apply n.
      rewrite update_neq; try apply n.
      apply (F x').
      constructor.
        apply n.
        assumption.
  - apply T_App with T2.
    + apply IHHt1. intros x' H'. apply F. apply afi_app1. assumption.
    + apply IHHt2. intros x' H'. apply F. apply afi_app2. assumption.
  - constructor.
  - constructor.
  - constructor.
    + apply IHHt1. intros x' H'. apply F. apply afi_if1. assumption.
    + apply IHHt2. intros x' H'. apply F. apply afi_if2. assumption.
    + apply IHHt3. intros x' H'. apply F. apply afi_if3. assumption.
Qed.

(*TODO ex *)

End STLCProp.

Module STLCArith.
Import STLC.

Inductive ty : Type :=
  | Ty_Arrow : ty -> ty -> ty
  | Ty_Nat : ty.

Inductive tm : Type :=
  | tm_var : string -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : string -> ty -> tm -> tm
  | tm_const : nat -> tm
  | tm_succ : tm -> tm
  | tm_pred : tm -> tm
  | tm_mult : tm -> tm -> tm
  | tm_if0 : tm -> tm -> tm -> tm.

Notation "{ x }" := x (in custom stlc at level 1, x constr).
Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99, t custom stlc at level 99, y custom stlc at level 99, left associativity).
Coercion tm_var : string >-> tm.
Notation "'Nat'" := Ty_Nat (in custom stlc at level 0).
Notation "'succ' x" := (tm_succ x) (in custom stlc at level 0,
                                     x custom stlc at level 0).
Notation "'pred' x" := (tm_pred x) (in custom stlc at level 0,
                                     x custom stlc at level 0).
Notation "x * y" := (tm_mult x y) (in custom stlc at level 1,
                                      left associativity).
Notation "'if0' x 'then' y 'else' z" :=
  (tm_if0 x y z) (in custom stlc at level 89, x custom stlc at level 99, y custom stlc at level 99, z custom stlc at level 99, left associativity).
Coercion tm_const : nat >-> tm.

Inductive value : tm -> Prop :=
  | v_abs : forall x T2 t1,
      value <{ \x:T2, t1 }>
  | v_nat : forall (x: nat),
      value <{ x }>.
Hint Constructors value : core.

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | tm_var y =>
      if eqb_string x y then s else t
  | <{t1 t2}> => <{([x:=s] t1) ([x:=s] t2)}>
  | <{\y:T, t1}> =>
      if eqb_string x y then t else <{\y:T, [x:=s] t1}>
  | tm_const n => tm_const n
  | <{succ t}> => <{succ ([x:=s]t)}>
  | <{pred t}> => <{pred ([x:=s]t)}>
  | <{t1 * t2}> => <{([x:=s]t1) * ([x:=s]t2)}>
  | <{if0 t1 then t2 else t3}> =>
      <{if0 ([x:=s] t1) then ([x:=s] t2) else ([x:=s] t3)}>
  end
where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

Reserved Notation "t '-->' t'" (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2,
         value v2 ->
         <{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }>
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 t2}> --> <{t1' t2}>
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 t2}> --> <{v1 t2'}>

  | ST_Pred : forall t t',
        t --> t' ->
         <{pred t}> --> <{pred t'}>
  | ST_Pred_0 :
         <{pred 0}> --> <{0}>
  | ST_Pred_s : forall (t: nat),
         tm_pred (tm_const (S t)) --> <{t}>

  | ST_Succ : forall t t',
        t --> t' ->
         <{succ t}> --> <{succ t'}>
  | ST_Succ_const : forall (n : nat),
         <{succ n}> --> tm_const (S n)

  | ST_MulConst : forall (n m : nat),
         <{ n * m }> --> tm_const (n * m)
  | ST_Mul1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 * t2}> --> <{t1' * t2}>
  | ST_Mul2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 * t2}> --> <{v1 * t2'}>

  | ST_IfTrue : forall t1 t2,
      <{if0 0 then t1 else t2}> --> t1
  | ST_IfFalse : forall n t1 t2,
      n <> 0 ->
      <{if0 n then t1 else t2}> --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      <{if0 t1 then t2 else t3}> --> <{if0 t1' then t2 else t3}>
where "t '-->' t'" := (step t t').
Hint Constructors step : core.

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

Definition context := partial_map ty.
Reserved Notation "Gamma '|-' t '\in' T"
            (at level 101, t custom stlc, T custom stlc at level 0).
Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T1,
      Gamma x = Some T1 ->
      Gamma |- x \in T1
  | T_Abs : forall Gamma x T1 T2 t1,
      (x |-> T2 ; Gamma) |- t1 \in T1 ->
      Gamma |- \x:T2, t1 \in (T2 -> T1)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (T2 -> T1) ->
      Gamma |- t2 \in T2 ->
      Gamma |- t1 t2 \in T1
  | T_Const : forall Gamma (n: nat),
       Gamma |- n \in Nat
  | T_Succ : forall Gamma t,
       Gamma |- t \in Nat ->
       Gamma |- succ t \in Nat
  | T_Pred : forall Gamma t,
       Gamma |- t \in Nat ->
       Gamma |- pred t \in Nat
  | T_Mult : forall t1 t2 Gamma,
       Gamma |- t1 \in Nat ->
       Gamma |- t2 \in Nat ->
       Gamma |- t1 * t2 \in Nat
  | T_If : forall t1 t2 t3 T1 Gamma,
       Gamma |- t1 \in Nat ->
       Gamma |- t2 \in T1 ->
       Gamma |- t3 \in T1 ->
       Gamma |- if0 t1 then t2 else t3 \in T1
where "Gamma '|-' t '\in' T" := (has_type Gamma t T).
Hint Constructors has_type : core.

Inductive appears_free_in (x : string) : tm -> Prop :=
  | afi_var : appears_free_in x <{x}>
  | afi_app1 : forall t1 t2,
      appears_free_in x t1 ->
      appears_free_in x <{t1 t2}>
  | afi_app2 : forall t1 t2,
      appears_free_in x t2 ->
      appears_free_in x <{t1 t2}>
  | afi_abs : forall y T1 t1,
      y <> x ->
      appears_free_in x t1 ->
      appears_free_in x <{\y:T1, t1}>
  | afi_if1 : forall t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x <{if0 t1 then t2 else t3}>
  | afi_if2 : forall t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x <{if0 t1 then t2 else t3}>
  | afi_if3 : forall t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x <{if0 t1 then t2 else t3}>
  | afi_succ : forall t,
      appears_free_in x t ->
      appears_free_in x <{succ t}>
  | afi_pred : forall t,
      appears_free_in x t ->
      appears_free_in x <{pred t}>
  | afi_mult1 : forall t1 t2,
      appears_free_in x t1 ->
      appears_free_in x <{t1 * t2}>
  | afi_mult2 : forall t1 t2,
      appears_free_in x t2 ->
      appears_free_in x <{t1 * t2}>.
Hint Constructors appears_free_in : core.

Definition closed (t:tm) :=   forall x, ~(appears_free_in x t).

Lemma weakening : forall Gamma Gamma' t T,
     inclusion Gamma Gamma' ->
     Gamma |- t \in T ->
     Gamma' |- t \in T.
Proof.
  intros Gamma Gamma' t T H Ht.
  generalize dependent Gamma'.
  induction Ht; eauto using inclusion_update.
Qed.

Lemma weakening_empty : forall Gamma t T,
     empty |- t \in T ->
     Gamma |- t \in T.
Proof.
  intros Gamma t T.
  eapply weakening.
  discriminate.
Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
  (x |-> U ; Gamma) |-  t \in T ->
  empty |- v \in U ->
  Gamma |- [x:=v]t \in T.
Proof.
  intros G x U t.
  generalize dependent G.
  generalize dependent x.
  generalize dependent U.
  induction t; intros U x G v T Ht Hv; simpl.
  - (*| tm_var *)
    destruct (eqb_stringP x s); subst.
    + inversion Ht; subst.
      rewrite update_eq in H1.
      injection H1 as H1; subst.
      apply weakening_empty.
      assumption.
    + inversion Ht; subst.
      rewrite update_neq in H1; try (apply n).
      constructor.
      assumption.
  - (*| tm_app *)
    inversion Ht; subst.
    eapply T_App.
    + apply IHt1 with U; try (apply Hv).
      apply H2.
    + apply IHt2 with U; try (apply Hv).
      apply H4.
  - (*| tm_abs *)
    inversion Ht; subst.
    destruct (eqb_stringP x s); subst.
    + apply T_Abs.
      rewrite update_shadow in H4.
      assumption.
    + apply T_Abs.
      apply IHt with U; try (apply Hv).
      rewrite update_permute.
        assumption.
        intro Hc. symmetry in Hc. apply n. apply Hc.
  - (*| tm_const *)
    inversion Ht; subst.
    constructor.
  - (*| tm_succ *)
    inversion Ht; subst.
    constructor.
    apply IHt with U; try (apply Hv).
    assumption.
  - (*| tm_pred *)
    inversion Ht; subst.
    constructor.
    apply IHt with U; try (apply Hv).
    assumption.
  - (*| tm_mult *)
    inversion Ht; subst.
    eapply T_Mult.
    + apply IHt1 with U; try (apply Hv).
      apply H2.
    + apply IHt2 with U; try (apply Hv).
      apply H4.
  - (*| tm_if0 *)
    inversion Ht; subst.
    eapply T_If.
    + apply IHt1 with U; try (apply Hv).
      apply H3.
    + apply IHt2 with U; try (apply Hv).
      apply H5.
    + apply IHt3 with U; try (apply Hv).
      apply H6.
Qed.

Theorem preservation : forall t t' T,
  empty |- t \in T ->
  t --> t' ->
  empty |- t' \in T.
Proof with eauto.
  intros t t' T HT. generalize dependent t'.
  remember empty as Gamma.
  induction HT;
       intros t' HE; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and eauto takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T2...
      inversion HT1...
Qed.

(*
  | T_Var : forall Gamma x T1,
  | T_Abs : forall Gamma x T1 T2 t1,
  | T_App : forall T1 T2 Gamma t1 t2,
  | T_Const : forall Gamma (n: nat),
  | T_Succ : forall Gamma t,
  | T_Pred : forall Gamma t,
  | T_Mult : forall t1 t2 Gamma,
  | T_If : forall t1 t2 t3 T1 Gamma,
*)
Theorem progress : forall t T,
  empty |- t \in T ->
  value t \/ exists t', t --> t'.
Proof.
  remember empty as e eqn:Eg.
  intros t T Ht.
  induction Ht; subst.
  - (*var*) discriminate H.
  - (*abs*) left. constructor.
  - (*app*) right.
    destruct IHHt1 as [Hv1 | [t1' Ht1']]; try reflexivity.
    + destruct IHHt2 as [Hv2 | [t2' Ht2']]; try reflexivity.
      * inversion Ht1; subst; try (inversion Hv1); subst. eexists. apply ST_AppAbs. assumption.
      * exists <{ t1 t2' }>. constructor. assumption. assumption.
    + exists <{ t1' t2 }>. constructor. assumption.
  - (*const*) left. constructor.
  - (*succ*) destruct IHHt as [Hv | [t' Ht']]; try reflexivity.
    + inversion Hv; subst; (try inversion Ht); subst.
      right. exists (S x0). constructor.
    + right. exists (<{ succ t' }>). constructor. assumption.
  - (*pred*) destruct IHHt as [Hv | [t' Ht']]; try reflexivity.
    + inversion Hv; subst; (try inversion Ht); subst.
      right. destruct x0; eauto.
    + right. exists (<{ pred t' }>). constructor. assumption.
  - (*mul*) right.
    destruct IHHt1 as [Hv1 | [t1' Ht1']]; try reflexivity.
    + destruct IHHt2 as [Hv2 | [t2' Ht2']]; try reflexivity.
      * inversion Ht1; subst; try (inversion Hv1); subst.
        inversion Ht2; subst; try (inversion Hv2); subst.
        exists (tm_const (n * n0)). apply ST_MulConst.
      * exists <{ t1 * t2' }>. constructor. assumption. assumption.
    + exists <{ t1' * t2 }>. constructor. assumption.
  - (*if*) right. destruct IHHt1 as [Hv1 | [t1' Ht1']]; try reflexivity.
    + inversion Ht1; subst; try (inversion Hv1); subst.
      destruct n.
      * exists t2. constructor.
      * exists t3. constructor. auto.
    + exists <{ if0 t1' then t2 else t3 }>.
      constructor.
      assumption.
Qed.

End STLCArith.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.
Require Fin.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils.

Set Implicit Arguments.

(* @DLW: former definition

Inductive pos : nat -> Set :=
  | pos_fst : forall n, pos (S n)
  | pos_nxt : forall n, pos n -> pos (S n).

Arguments pos_fst {n}.
Arguments pos_nxt {n}.

*)

Notation pos := Fin.t.
Notation pos_fst := Fin.F1.
Notation pos_nxt := Fin.FS.

Notation pos0  := (@pos_fst _).
Notation pos1  := (pos_nxt pos0).
Notation pos2  := (pos_nxt pos1).
Notation pos3  := (pos_nxt pos2).
Notation pos4  := (pos_nxt pos3).
Notation pos5  := (pos_nxt pos4).
Notation pos6  := (pos_nxt pos5).
Notation pos7  := (pos_nxt pos6).
Notation pos8  := (pos_nxt pos7).
Notation pos9  := (pos_nxt pos8).
Notation pos10 := (pos_nxt pos9).
Notation pos11 := (pos_nxt pos10).
Notation pos12 := (pos_nxt pos11).
Notation pos13 := (pos_nxt pos12).
Notation pos14 := (pos_nxt pos13).
Notation pos15 := (pos_nxt pos14).
Notation pos16 := (pos_nxt pos15).
Notation pos17 := (pos_nxt pos16).
Notation pos18 := (pos_nxt pos17).
Notation pos19 := (pos_nxt pos18).
Notation pos20 := (pos_nxt pos19).

Definition pos_iso n m : n = m -> pos n -> pos m.
Proof. intros []; auto. Defined.

Section pos_inv.

  Let pos_inv_t n :=
    match n as x return pos x -> Set with
      | 0   => fun _ => False
      | S n => fun i => (( i = pos_fst ) + { p | i = pos_nxt p })%type
    end.

  Let pos_inv : forall n p, @pos_inv_t n p.
  Proof.
    intros _ [ | n p ]; simpl; [ left | right ]; auto; exists p; auto.
  Defined.

  Definition pos_O_inv : pos 0 -> False.
  Proof. apply pos_inv. Defined.

  Definition pos_S_inv n (p : pos (S n)) : ( p = pos_fst ) + { q | p = pos_nxt q }.
  Proof. apply (pos_inv p). Defined.

  Definition pos_nxt_inj n (p q : pos n) (H : pos_nxt p = pos_nxt q) : p = q :=
    match H in _ = a return
       match a as a' in pos m return
           match m with
             | 0 => Prop
             | S n' => pos n' -> Prop
           end with
         | pos_fst   => fun _  => True
         | pos_nxt y => fun x' => x' = y
       end p with
     | eq_refl => eq_refl
   end.

End pos_inv.

Arguments pos_S_inv {n} p /.

Section pos_invert.

  (* Position inversion, "singleton elimination" free version
     One problem remains to fully use it ... it is not
     correctly traversed by type checking algorithm
     of fixpoints (structural recursion)

     pos_S_inv work better in that respect
  *)

  Let pos_invert_t n : (pos n -> Type) -> Type :=
    match n with
        0   => fun P => True
      | S n => fun P => (P (pos_fst) * forall p, P (pos_nxt p))%type
    end.

  Let pos_invert n : forall (P : pos n -> Type), pos_invert_t P -> forall p, P p.
  Proof.
    intros P HP; induction p; simpl in HP; apply HP.
  Defined.

  Theorem pos_O_invert X : pos 0 -> X.
  Proof.
    apply pos_invert; simpl; trivial.
  Defined.

  Theorem pos_S_invert n P : P (@pos_fst n) -> (forall p, P (pos_nxt p)) -> forall p, P p.
  Proof.
    intros; apply pos_invert; split; auto.
  Defined.

End pos_invert.

Arguments pos_S_invert [n] P _ _ p /.

Ltac pos_O_inv p := exfalso; apply (pos_O_inv p).

Ltac pos_S_inv p :=
  let H := fresh in
  let q := fresh
  in  rename p into q; destruct (pos_S_inv q) as [ H | (p & H) ]; subst q.

(*
Ltac pos_O_inv p := apply (@pos_O_invert _ p).
Ltac pos_S_inv x := induction x as [ | x ] using pos_S_invert.
*)

Ltac pos_inv p :=
  match goal with
    | [ H: pos 0     |- _ ] => match H with p => pos_O_inv p end
    | [ H: pos (S _) |- _ ] => match H with p => pos_S_inv p end
  end.

Tactic Notation "invert" "pos" hyp(H) := pos_inv H; simpl.

Ltac analyse_pos p :=
  match type of p with
    | pos 0     => pos_inv p
    | pos (S _) => pos_inv p; [ | try analyse_pos p ]
  end.

Tactic Notation "analyse" "pos" hyp(p) := analyse_pos p.

Definition pos_O_any X : pos 0 -> X.
Proof. intro p; invert pos p. Qed.

Definition pos_eq_dec n (x y : pos n) : { x = y } + { x <> y }.
Proof.
  revert n x y.
  induction x as [ x | n x IH ]; intros y; invert pos y.
  1: left; trivial.
  1,2: right; discriminate.
  destruct (IH y) as [ | C ].
  + left; subst; trivial.
  + right; contradict C; revert C; apply pos_nxt_inj.
Defined.

Fixpoint pos_left n m (p : pos n) : pos (n+m) :=
  match p with
    | pos_fst   => pos_fst
    | pos_nxt p => pos_nxt (pos_left m p)
  end.

Fixpoint pos_right n m : pos m -> pos (n+m) :=
  match n with
    | 0   => fun x => x
    | S n => fun p => pos_nxt (pos_right n p)
  end.

Definition pos_both n m : pos (n+m) -> pos n + pos m.
Proof.
  induction n as [ | n IHn ]; intros p.
  + right; exact p.
  + simpl in p; pos_inv p.
    * left; apply pos_fst.
    * destruct (IHn p) as [ a | b ].
      - left; apply (pos_nxt a).
      - right; apply b.
Defined.

Definition pos_lr n m : pos n + pos m -> pos (n+m).
Proof.
  intros [ p | p ]; revert p.
  + apply pos_left.
  + apply pos_right.
Defined.

Fact pos_both_left n m p : @pos_both n m (@pos_left n m p) = inl p.
Proof.
  induction p as [ | n p IHp ]; simpl; auto.
  rewrite IHp; auto.
Qed.

Fact pos_both_right n m p : @pos_both n m (@pos_right n m p) = inr p.
Proof.
  revert p; induction n as [ | n IHn]; intros p; simpl; auto.
  rewrite IHn; auto.
Qed.

Fact pos_left_right_neq n m p q : @pos_left n m p <> @pos_right n m q.
Proof.
  intros H.
  apply f_equal with (f := @pos_both _ _) in H.
  now rewrite pos_both_left, pos_both_right in H.
Qed.

Fact pos_left_inj n m p q : @pos_left n m p = @pos_left n m q -> p = q.
Proof.
  intros H.
  apply f_equal with (f := @pos_both _ _) in H.
  rewrite !pos_both_left in H.
  now inversion H.
Qed.

Fact pos_right_inj n m p q : @pos_right n m p = @pos_right n m q -> p = q.
Proof.
  intros H.
  apply f_equal with (f := @pos_both _ _) in H.
  rewrite !pos_both_right in H.
  now inversion H.
Qed.

(* A bijection between pos n + pos m <-> pos (n+m) **)

Fact pos_both_lr n m p : @pos_both n m (pos_lr p) = p.
Proof.
  destruct p as [ p | p ].
  + apply pos_both_left.
  + apply pos_both_right.
Qed.

Fact pos_lr_both n m p : pos_lr (@pos_both n m p) = p.
Proof.
  revert p; induction n as [ | n IHn ]; intros p; auto.
  simpl in p; pos_inv p; simpl; auto.
  specialize (IHn p).
  destruct (pos_both n m p); simpl in *; f_equal; auto.
Qed.

Section pos_left_right_rect.

  Variable (n m : nat) (P : pos (n+m) -> Type).

  Hypothesis (HP1 : forall p, P (pos_left _ p))
             (HP2 : forall p, P (pos_right _ p)).

  Theorem pos_left_right_rect : forall p, P p.
  Proof using HP1 HP2.
    intros p.
    rewrite <- pos_lr_both.
    generalize (pos_both n m p); clear p; intros [|]; simpl; auto.
  Qed.

End pos_left_right_rect.

Fixpoint pos_list n : list (pos n) :=
  match n with
    | 0   => nil
    | S n => pos0::map pos_nxt (pos_list n)
  end.

Fact pos_list_prop n p : In p (pos_list n).
Proof.
  induction p as [ | n p Hp ].
  left; auto.
  simpl; right.
  apply in_map_iff.
  exists p; auto.
Qed.

Fact pos_list_length n : length (pos_list n) = n.
Proof.
  induction n; simpl; auto.
  rewrite map_length; f_equal; auto.
Qed.

Fact pos_list_NoDup n : NoDup (pos_list n).
Proof.
  induction n as [|n IH]; simpl; constructor.
  - now intros [? [? ?]]%in_map_iff.
  - apply (FinFun.Injective_map_NoDup (@pos_nxt_inj n) IH).
Qed.

Section pos_map.

  Definition pos_map m n := pos m -> pos n.

  Definition pm_ext_eq m n (r1 r2 : pos_map m n) := forall p, r1 p = r2 p.

  Definition pm_lift m n (r : pos_map m n) : pos_map (S m) (S n).
  Proof.
    intros p.
    invert pos p.
    apply pos_fst.
    apply pos_nxt, (r p).
  Defined.

  Fact pm_lift_fst m n (r : pos_map m n) : pm_lift r pos0 = pos0.
  Proof. auto. Qed.

  Fact pm_lift_nxt m n (r : pos_map m n) p : pm_lift r (pos_nxt p) = pos_nxt (r p).
  Proof. auto. Qed.

  Arguments pm_lift [ m n ] r p.

  Fact pm_lift_ext m n r1 r2 : @pm_ext_eq m n r1 r2 -> pm_ext_eq (pm_lift r1) (pm_lift r2).
  Proof.
    intros H12 p; unfold pm_lift.
    invert pos p; simpl; auto.
    f_equal; apply H12.
  Qed.

  Definition pm_comp l m n : pos_map l m -> pos_map m n -> pos_map l n.
  Proof.
    intros H1 H2 p.
    exact (H2 (H1 p)).
  Defined.

  Fact pm_comp_lift l m n r s : pm_ext_eq (pm_lift (@pm_comp l m n r s)) (pm_comp (pm_lift r) (pm_lift s)).
  Proof.
    intros p.
    unfold pm_comp, pm_lift; simpl.
    invert pos p; simpl; auto.
  Qed.

  Definition pm_id n : pos_map n n := fun p => p.

End pos_map.

Arguments pm_lift { m n } _ _ /.
Arguments pm_comp [ l m n ] _ _ _ /.
Arguments pm_id : clear implicits.

Section pos_nat.

  Fixpoint pos_nat n (p : pos n) : { i | i < n }.
  Proof.
    refine (match p with
              | pos_fst   => exist _ 0 _
              | pos_nxt q => exist _ (S (proj1_sig (pos_nat _ q))) _
            end).
    apply Nat.lt_0_succ.
    apply -> Nat.succ_lt_mono. apply (proj2_sig (pos_nat _ q)).
  Defined.

  Definition pos2nat n p := proj1_sig (@pos_nat n p).

  Fact pos2nat_prop n p : @pos2nat n p < n.
  Proof. apply (proj2_sig (pos_nat p)). Qed.

  Fixpoint nat2pos n : forall x, x < n -> pos n.
  Proof.
     refine (match n as n' return forall x, x < n' -> pos n' with
              | O   => fun x H => _
              | S i => fun x H => _
            end).
    exfalso; revert H; apply Nat.nlt_0_r.
    destruct x as [ | x ].
    apply pos_fst.
    apply pos_nxt.
    apply (nat2pos i x); revert H; apply Nat.succ_lt_mono.
  Defined.

  Definition nat_pos n : { i | i < n } -> pos n.
  Proof. intros (? & H); revert H; apply nat2pos. Defined.

  Arguments pos2nat n !p /.

  Fact pos2nat_inj n (p q : pos n) : pos2nat p = pos2nat q -> p = q.
  Proof.
    revert q.
    induction p as [ n | n p IHp ]; intros q; invert pos q; simpl; auto; try discriminate 1.
    intros H; f_equal; apply IHp; injection H; trivial.
  Qed.

  Fact pos2nat_nat2pos n i (H : i < n) : pos2nat (nat2pos H) = i.
  Proof.
    revert i H;
    induction n as [ | n IHn ]; intros [ | i ] H; simpl; auto; try lia.
    f_equal.
    apply IHn.
  Qed.

  Fact nat2pos_pos2nat n p (H : pos2nat p < n) : nat2pos H = p.
  Proof.
    apply pos2nat_inj; rewrite pos2nat_nat2pos; auto.
  Qed.

  Fact pos2nat_fst n : pos2nat (@pos_fst n) = 0.
  Proof. auto. Qed.

  Fact pos2nat_nxt n p : pos2nat (@pos_nxt n p) = S (pos2nat p).
  Proof. auto. Qed.

  Fact pos2nat_left n m p : pos2nat (@pos_left n m p) = pos2nat p.
  Proof. induction p; simpl; auto. Qed.

  Fact pos2nat_right n m p : pos2nat (@pos_right n m p) = n+pos2nat p.
  Proof.
    revert m p; induction n as [ | n IHn ]; intros m p; auto.
    simpl pos_right; simpl plus; rewrite pos2nat_nxt; f_equal; auto.
  Qed.

  Fixpoint pos_sub n (p : pos n) { struct p } : forall m, n < m -> pos m.
  Proof.
    destruct p as [ | n p ]; intros [ | m ] Hm.
    exfalso; clear pos_sub; abstract lia.
    apply pos_fst.
    exfalso; clear pos_sub; abstract lia.
    apply pos_nxt.
    apply (pos_sub n p), Nat.succ_lt_mono, Hm.
  Defined.

  Fact pos_sub2nat n p m Hm : pos2nat (@pos_sub n p m Hm) = pos2nat p.
  Proof.
    revert m Hm; induction p as [ n | n p IH ]; intros [ | m ] Hm; try lia.
    simpl; auto.
    simpl pos_sub; repeat rewrite pos2nat_nxt; f_equal; auto.
  Qed.

End pos_nat.

Global Opaque pos_nat.

Fact pos_list2nat n : map (@pos2nat n) (pos_list n) = list_an 0 n.
Proof.
  induction n as [ | n IHn ]; simpl; f_equal.
  rewrite <- (map_S_list_an 0), <- IHn.
  do 2 rewrite map_map.
  apply map_ext.
  intros; rewrite pos2nat_nxt; auto.
Qed.

Section pos_prod.

  Variable n : nat.

  Let ll := flat_map (fun p => map (fun q => (p,q)) (pos_list n)) (pos_list n).
  Let ll_prop p q : In (p,q) ll.
  Proof.
    apply in_flat_map; exists p; split.
    apply pos_list_prop.
    apply in_map_iff.
    exists q; split; auto.
    apply pos_list_prop.
  Qed.

  Definition pos_not_diag := filter (fun c => if pos_eq_dec (fst c) (snd c) then false else true) ll.

  Fact pos_not_diag_spec p q : In (p,q) pos_not_diag <-> p <> q.
  Proof.
    unfold pos_not_diag.
    rewrite filter_In; simpl.
    destruct (pos_eq_dec p q).
    split.
    intros (_ & ?); discriminate.
    intros []; auto.
    split; try tauto; split; auto.
  Qed.

End pos_prod.


From Hammer Require Import Hammer.

Require Import Orders Rbase Rbasic_fun ROrderedType GenericMinMax.

Local Open Scope R_scope.

Lemma Rmax_l : forall x y, y<=x -> Rmax x y = x.
Proof. hammer_hook "Rminmax" "Rminmax.Rmax_l".
unfold Rmax. intros.
destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
unfold Rle in *; intuition.
Qed.

Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y.
Proof. hammer_hook "Rminmax" "Rminmax.Rmax_r".
unfold Rmax. intros.
destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
unfold Rle in *; intuition.
Qed.

Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x.
Proof. hammer_hook "Rminmax" "Rminmax.Rmin_l".
unfold Rmin. intros.
destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
unfold Rle in *; intuition.
Qed.

Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y.
Proof. hammer_hook "Rminmax" "Rminmax.Rmin_r".
unfold Rmin. intros.
destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
unfold Rle in *; intuition.
Qed.

Module RHasMinMax <: HasMinMax R_as_OT.
Definition max := Rmax.
Definition min := Rmin.
Definition max_l := Rmax_l.
Definition max_r := Rmax_r.
Definition min_l := Rmin_l.
Definition min_r := Rmin_r.
End RHasMinMax.

Module R.

Include UsualMinMaxProperties R_as_OT RHasMinMax.

Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m.
Proof. hammer_hook "Rminmax" "Rminmax.R.plus_max_distr_l".
intros. apply max_monotone.
intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p.
Proof. hammer_hook "Rminmax" "Rminmax.R.plus_max_distr_r".
intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
apply plus_max_distr_l.
Qed.

Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m.
Proof. hammer_hook "Rminmax" "Rminmax.R.plus_min_distr_l".
intros. apply min_monotone.
intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p.
Proof. hammer_hook "Rminmax" "Rminmax.R.plus_min_distr_r".
intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
apply plus_min_distr_l.
Qed.

Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m).
Proof. hammer_hook "Rminmax" "Rminmax.R.opp_max_distr".
intros. symmetry. apply min_max_antimonotone.
do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m).
Proof. hammer_hook "Rminmax" "Rminmax.R.opp_min_distr".
intros. symmetry. apply max_min_antimonotone.
do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m.
Proof. hammer_hook "Rminmax" "Rminmax.R.minus_max_distr_l".
unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l.
Qed.

Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p.
Proof. hammer_hook "Rminmax" "Rminmax.R.minus_max_distr_r".
unfold Rminus. intros. apply plus_max_distr_r.
Qed.

Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m.
Proof. hammer_hook "Rminmax" "Rminmax.R.minus_min_distr_l".
unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l.
Qed.

Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p.
Proof. hammer_hook "Rminmax" "Rminmax.R.minus_min_distr_r".
unfold Rminus. intros. apply plus_min_distr_r.
Qed.

End R.


Require Import QArith.QArith_base.
Require Import QArith.Qabs.
Require Import QArith.Qpower.
Require Import QArith.Qround.
Require Import ZArith.Znat.
Require Import Psatz.
Require Import Init.Nat.
Require Import ZArith.BinInt.
Require Import ZArith.Zpow_facts.
Require Import PArith.Pnat.
Require Import Omega.

Definition Continuous (f:Q->Q) := forall x0 e,
e>0 -> {d | 0<d /\ forall x, Qabs (x-x0) < d -> Qabs ( (f x) - (f x0) ) < e}.
Definition UniformlyContinuous (f:Q->Q) := forall e,
e>0 -> {d | 0<d /\ forall x x0, Qabs (x - x0) < d -> Qabs ( (f x) - (f x0) ) < e}.

Definition Difference (f:Q->Q) (x:Q) (h:Q) := (f (x+h) - f x)/h.
Definition Differentiable (f:Q->Q) (x : Q) := forall e, e>0 -> {h | h>0 /\ Qabs(f (x+h) - (f x) - h*(Difference f x h) ) < e}.

Theorem uniformly_continuous_is_continuous : forall (f:Q->Q), UniformlyContinuous f -> Continuous f.
Proof.
intros.
unfold UniformlyContinuous in H. unfold Continuous.
intros.
assert(H1 := (H e H0)).
destruct H1.
destruct a.
exists x.
split.
* lra.
* intros. auto with *.
Qed.

Lemma useful_order_property : forall e r:Q, e>0 -> {r>-e} + {r<=e}.
Proof.
intros.
destruct (Qlt_le_dec 0 r).
* assert( -e < r) by lra. auto.
* assert( r<= e ) by lra. auto.
Defined.

Lemma Qpower_reduction : forall a (n:Z), (n>0)%Z -> a>0 -> a^n == a*(a^(n-1)).
Proof.
intros.
assert(R1: a== a^1) by lra.
remember (a^n) as an. remember ( a^(n-1)) as anm1.
rewrite R1; clear R1.
rewrite Heqan. rewrite Heqanm1.
remember ((n-1)%Z) as nm1.
assert(R: (n = 1 + (n-1))%Z) by auto with *.
rewrite R; clear R.
rewrite Heqnm1.
apply Qpower_plus.
lra.
Qed.

Lemma powertwo_bigger_than_exp_pos : forall (n:nat), (2^Z.of_nat (n+1) > Z.of_nat (n+1))%Z.
Proof.
intros.
induction n.
* simpl. unfold Z.pow_pos. simpl. auto with *.
* remember (Z.of_nat (n+1)) as m.
  assert( (Z.of_nat(S n + 1 ) = m+1)%Z ) by nia.
  rewrite H.
  assert( (m > 0)%Z ) by nia.
  assert( (2^m + 2^m > m + 2^m)%Z ) by nia.
  assert( (m + 2^m > m+m)%Z ) by nia.
  assert( (2^m + 2^m > m+m)%Z ) by nia.
  assert( ((2^m + 2^m) = 2^(m+1))%Z ). {
    assert( ((2^m + 2^m) = 2*2^m)%Z ) by nia.
    rewrite H4.
    assert( ( 2^(m+1) = 2*2^m )%Z ). apply Z.pow_succ_r. auto with *.
    rewrite H5.
    auto.
  }
  rewrite H4 in H3.
  assert( (m+m>=m+1)%Z ) by nia.
  nia.
Qed.

Lemma powertwo_bigger_than_exp : forall (n:nat), (2^(Z.of_nat n) > Z.of_nat n)%Z.
Proof.
intros.
destruct n.
* simpl. auto with *.
* assert( ( S n = n+1)%nat) by auto with *. rewrite H.
  apply powertwo_bigger_than_exp_pos.
Qed.

Lemma powertwo_bigger_than_exp_positive : forall (p:positive), (2^(Zpos p) > Zpos p)%Z.
Proof.
intros.
remember (Pos.to_nat p) as m.
assert( (m>0)%nat ). {
  rewrite Heqm.
  apply Pos2Nat.is_pos.
}
assert( Z.pos p = Z.of_nat m ). {
  rewrite Heqm.
  assert( Z.of_nat (Pos.to_nat p) = Z.pos p) by apply positive_nat_Z.
  rewrite H0. auto.
}
rewrite H0.
apply (powertwo_bigger_than_exp).
Qed.

Lemma powertwo_bigger_than_exp_positive2 : forall (p:positive), (2^p > p)%positive.
Proof.
Admitted.

Theorem smaller_rational_works : forall r, r>0 -> (1#2)^(Zpos (Qden r)) < r.
Proof.
Admitted.
(*
intros.
destruct r.
simpl.
assert( Qpower_positive (1#2) Qden = 1^(Zpos Qden) # 2^Qden ). {
  apply Qpower_decomp.
}
rewrite H0.
assert( (1 ^ Z.pos Qden = 1)%Z ) by apply Zpower_pos_1_l.
rewrite H1.
unfold Qlt. simpl.
assert( (Z.pos (2^Qden) = ( 2^ (Z.pos Qden)))%Z ). {
  destruct Qden.
  * simpl.
}

assert( (Z.pos Qden < Z.pos (2^Qden))%Z ). {
  remember ( (Z.to_nat (Z.pos Qden))) as m.
  assert( Z.pos (2^Qden
  assert( ( 2 ^ (Z.of_nat m) > Z.of_nat m)%Z ). {
    apply powertwo_bigger_than_exp.
  }
}
*)

Lemma qnum_powerhalf_is_1 : forall (n:nat), (Qnum ((1#2) ^ (Z.of_nat n)) = 1)%Z.
Proof.
intros.
unfold Qpower.
destruct n.
* simpl. auto.
* simpl.
  remember (Pos.of_succ_nat n) as m.
  assert(
    (Qpower_positive (1 # 2)
     m = (1^(Zpos m)) # (2^m))). {
      apply Qpower_decomp.
     }
  rewrite H. simpl.
  apply Zpower_pos_1_l.
Qed.

Fixpoint bisect_a (f:Q->Q) (a:Q) (b:Q) (e:Q) (He:(e>0)) (m:nat) := match m with
  0%nat => a
|   S p =>
  let mid := (1#2)*(a+b) in
  if (useful_order_property e (f mid) He)
    then (bisect_a f a mid e He p)
    else (bisect_a f mid b e He p)
end.

Fixpoint bisect_b (f:Q->Q) (a:Q) (b:Q) (e:Q) (He:(e>0)) (m:nat) := match m with
  0%nat => b
|   S p =>
  let mid := (1#2)*(a+b) in
  if (useful_order_property e (f mid) He)
    then (bisect_b f a mid e He p)
    else (bisect_b f mid b e He p)
end.

Fixpoint bisect_c (f:Q->Q) (a:Q) (b:Q) (e:Q) (He:(e>0)) (m:nat) := match m with
  0%nat => (1#2)*(a+b)
|   S p =>
  let mid := (1#2)*(a+b) in
  if (useful_order_property e (f mid) He)
    then (bisect_c f a mid e He p)
    else (bisect_c f mid b e He p)
end.

Definition err := 1#100.
Theorem a_pos_err : err>0.
Proof.
unfold err. lra.
Qed.

Definition sqrt_err (x:Q) := x*x-(2#1).

Eval vm_compute in (bisect_c sqrt_err 1 (2#1) err a_pos_err 10).

Lemma exponential_bound : forall (e:Q), e>0 -> {n:Z | (1#2)^n < e}.
Proof.
Admitted.

Lemma bisect_a_works : forall (f:Q->Q) (e:Q) (H:e>0) (n:nat), (f 0) < 0 -> (f 1) > 0 ->
f (bisect_a f 0 1 e H n) < e.
Proof.
Admitted.

Lemma bisect_b_works : forall (f:Q->Q) (e:Q) (H:e>0) (n:nat), (f 0) < 0 -> (f 1) > 0 ->
f (bisect_b f 0 1 e H n) > -e.
Proof.
Admitted.

Lemma bisect_c_works : forall (f:Q->Q) (e:Q) (H:e>0) (n:nat), (f 0) < 0 -> (f 1) > 0 ->
(bisect_c f 0 1 e H n) - (bisect_a f 0 1 e H n) <= (1#2)^(Z.of_nat n) /\
(bisect_b f 0 1 e H n) - (bisect_c f 0 1 e H n) <= (1#2)^(Z.of_nat n).
Proof.
Admitted.

Lemma bisect_c_bounds : forall (f:Q->Q) (e:Q) (H:e>0) (n:nat),
0<bisect_c f 0 1 e H n /\ bisect_c f 0 1 e H n<1.
Proof.
Admitted.

Lemma Qabs_bounds : forall (q:Q) (e:Q), e>0 -> -e<q -> q<e -> Qabs q < e.
Proof.
Admitted.

Theorem intermediate_value_theorem : forall (f:Q->Q) (e:Q), UniformlyContinuous f -> e>0 -> (f 0) < 0 -> (f 1) > 0 ->
{ c | 0<c /\ c<1 /\ Qabs (f c) < e }.
Proof.
intros.

(*First use uniform continuity
  to get a delta to satisfy error*)
unfold UniformlyContinuous in H.
assert( (1#2)*e > 0) by lra.
assert( P0 := (H ((1#2)*e) H3)).
destruct P0.
remember x as delta.
destruct a.
(*Now we have delta, need corresponding
  natural number n to give bisection
  algorithm*)
assert( P1 := exponential_bound delta H4 ).
destruct P1.
remember x0 as n.
(*Use bisection to compute a,b,c such that
  f a<e/2, f b>-e/2, c-a<delta, b-c<delta *)
remember (bisect_a f 0 1 ((1#2)*e) H3 (Z.to_nat n)) as a.
remember (bisect_b f 0 1 ((1#2)*e) H3 (Z.to_nat n)) as b.
remember (bisect_c f 0 1 ((1#2)*e) H3 (Z.to_nat n)) as c.

(* First show f a<e/2 *)
assert( f a < (1#2)*e ). {
  rewrite Heqa.
  apply bisect_a_works.
  lra. lra.
}
(* Secondly: f b > -(1#2)*e *)
assert( f b > -((1#2)*e)). {
  rewrite Heqb.
  apply bisect_b_works.
  lra. lra.
}
(*Lastly show that the computed
  c satisfies the necessary bounds*)
assert( c-a < (1#2)^n ). {
  admit.
}
assert( b-c < (1#2)^n ). {
  admit.
}

(*With last two bounds we may use the fact that
  fb + (1#2)*e > 0 to get
  0<fb < fb - fc + fc + (1#2)*e < fc + e ->
  -e < fc *)
  assert(-e < (f c) ). {
    admit.
  }

(*With first and last bounds we may use the fact that
  fa-(1#2)*e<0 to get
  fc < fc - fa + (1#2)*e < e *)
  assert( (f c) < e ). {
    admit.
  }

(* The last two results may be combined to get the desired result *)

assert( Qabs (f c) < e ). {
  apply Qabs_bounds. lra. lra. lra.
}

exists c.
assert( 0<c /\ c<1). {
  rewrite Heqc.
  apply bisect_c_bounds.
}

destruct H13.
split.
* auto with *.
* auto with *.

Qed.

Lemma Qabs_extensional : forall q1 q2, q1==q2 -> Qabs q1 == Qabs q2.
Proof.
intros.
destruct q1. destruct q2.
unfold Qabs. unfold Z.abs.
destruct Qnum, Qnum0.
* lra.
* auto.
* assert( not (0 # Qden == Z.neg p # Qden0) ).
** unfold Qeq. assert( (Qnum (0 # Qden) = 0)%Z ) by auto with *.
   rewrite H. auto with *.
** contradiction.
* auto.
* auto.
* assert( not (Zpos p # Qden == Z.neg p0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* assert( not (Z.neg p # Qden == 0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* assert( not ( Z.neg p # Qden == ' p0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* unfold Qeq. unfold Qeq in H. simpl. simpl in H.
  assert ( (p*Qden0 = p0*Qden)%positive ).
** nia.
** rewrite H0. auto with *.
Qed.

(*Constant function zero.*)
Definition const (x:Q) := 0.
(*Simple linear function.*)
Definition linear (x:Q) := x.
(*Simple quadratic function.*)
Definition quadratic (x:Q) := x*x.
(*Function with "discontinuity" at zero*)
Definition bad (x:Q) := if (Qlt_le_dec 0 x) then 1 else 0.
Definition worse (x:Q) := if (Qlt_le_dec (2#1) (x*x)) then 1 else 0.

Theorem const_is_continuous : Continuous const.
Proof.
unfold Continuous.
intros.
exists 1.
intros.
unfold const.
split.
* lra.
* intros. simpl. lra.
Qed.

Theorem const_is_differentiable : forall x, Differentiable const x.
Proof.
intros.
unfold Differentiable.
unfold const.
intros.
exists 1.
split.
* lra.
* simpl. lra.

Qed.

Theorem linear_is_continuous : Continuous linear.
Proof.
unfold Continuous.
intros.
exists e.
split.
* lra.
* intros. unfold linear. apply H0.
Qed.

Theorem linear_is_differentiable : forall x, Differentiable linear x.
Proof.
intros.
unfold Differentiable. unfold linear.
intros.
exists e.
split.
* lra.
* unfold Difference.
  assert( Qabs (x + e - x - e * ((x + e - x) / e))  == Qabs 0 ).
  {
    apply Qabs_extensional. field. lra.
  }
  rewrite H0.
  simpl. lra.
Qed.

Theorem quadratic_difference_formula : forall x h, h>0 -> Difference quadratic x h == (1+1)*x + h.
Proof.
intros.
unfold Difference. unfold quadratic.
field. auto with *.
Qed.

Theorem quadratic_is_differentiable : forall x, Differentiable quadratic x.
Proof.
intros.
unfold Differentiable, quadratic.
intros.
exists (e).
split.
* nra.
* rewrite quadratic_difference_formula.
** assert( Qabs( (x + e) * (x + e) - x * x -
   e * ((1 + 1) * x + e)) == Qabs(0) ). {
    apply Qabs_extensional. field.
   }
   rewrite H0. simpl. apply H.
** apply H.
Qed.

(* The function "bad" is not continuous *)
Theorem bad_is_discontinuous : (Continuous bad) -> False.
Proof.
unfold Continuous.
intros.
assert( 0<1#2) by lra.
assert( H1 := H 0 (1#2) H0).
destruct H1.
destruct a.
assert( Hbad := (H2 (x*(1#2)))).
assert( Qabs (x * (1 # 2) - 0) < x ).
{
  assert( Qabs(x * (1#2) - 0) == Qabs (x *(1#2)) ).
  {
    apply Qabs_extensional. lra.
  }
  rewrite H3.
  assert( Qabs( x*(1#2) ) == x*(1#2) ).
  {
    apply Qabs_pos. lra.
  }
  rewrite H4. lra.
}
assert( Hbadbad := Hbad H3 ).
assert(Qabs (bad (x * (1 # 2)) - bad 0) == Qabs 1 ).
{
  unfold bad.
  destruct (Qlt_le_dec 0 (x*(1#2))).
  * destruct (Qlt_le_dec 0 0).
    ** simpl. assert(not (0<0)) by lra. contradiction.
    ** simpl. lra.
  * destruct (Qlt_le_dec 0 0).
    ** simpl. assert(not (0<0)) by lra. contradiction.
    ** simpl. assert(not ((x * (1#2))<=0) ). lra. contradiction.
}

rewrite H4 in Hbadbad.
assert(not (Qabs 1 < 1#2)).
{
  assert( Qabs 1 == 1 ).
  {
    apply Qabs_pos. lra.
  }
  rewrite H5. lra.

}
contradiction.
Qed.

Theorem worse_is_continuous : Continuous worse.
Proof.
unfold Continuous.
intros.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Generalizable All Variables.
Require Import Aw_0_Notations.
Require Import Aw_1_3_Categories.
Require Import Aw_1_4_Functors.
Require Import Aw_1_5_Isomorphisms.

(******************************************************************************)
(* Chapter 1.6.4: Slice Categories                                            *)
(******************************************************************************)
Locate "{ _ : _ & _ }".                     (* "{ x : A  & P }" := sigT (fun x : A => P) *)
(* X が 圏Cの対象であるとき、 *)
(* cod(f) = X である圏Cの射fの集まり *)
Definition MorphismInTo  `{C : Category} (X : C) := {Y : C & Y ~~{C}~~> X}.
(* dom(f) = X である圏Cの射fの集まり *)
Definition MorphismOutOf `{C : Category} (X : C) := {Y : C & X ~~{C}~~> Y}.
Check @MorphismInTo : ∀ (Obj : Type) (Hom : Obj → Obj → Setoid) (C : Category Hom),
    C → Type.
Check MorphismInTo _ : Type.                (* 引数は対象 *)

Check projT1 : ∀ (A : Type) (P : A → Type), sigT P → A.
Check projT2 : ∀ (A : Type) (P : A → Type) (x : sigT P), P (projT1 x).

Section SliceExample.
  Check Sets.                               (* 圏Sets *)
  Variable X : Sets.                        (* 圏Setsの対象 *)
  Variable M : MorphismInTo X.              (* 圏Setsの対象Xをcodとする射、cod(M)=X *)
  Check projT1 M : Sets.                    (* 圏Setsの対象 *)
  Check projT2 M : (λ Y : Sets, Y ~~{ Sets }~~> X) (projT1 M).
  Check projT2 M : (fun (Y : Sets) => (Y ~~{ Sets }~~> X)) (projT1 M).
  Check projT2 M : ((projT1 M) ~~{ Sets }~~> X).
  Check projT2 M : ((projT1 M) ~> X).       (* cod(f)=Xなる射 *)

  Check @iid (projT1 M).
End SliceExample.

Definition TriangleAbove `{C : Category} {X : C} (M1 M2 : MorphismInTo X) :=
   {f : (projT1 M1) ~~{C}~~> (projT1 M2) & (projT2 M2) \\o f === (projT2 M1)}.
Definition TriangleBelow `{C : Category} {X : C} (M1 M2 : MorphismOutOf X) :=
   {f : (projT1 M1) ~~{C}~~> (projT1 M2) & f \\o (projT2 M1) === (projT2 M2)}.
(*
(projT1 M1) ~~{C}~~> (projT1 M2) は Setoid
(projT2 M2) \\o f === (projT2 M1) は Prop
 *)
Check TriangleAbove _ _ : Type.
(*
TriangleAbove M1 M2 は、
(projT1 M1) ~~{C}~~> (projT1 M2) のサブタイプ で、
それを f しとたときに、
(projT2 M2) \\o f === (projT2 M1) を満たすもの。

すなわち、次の可換図を満たす f :

                f
   projT1(M1) -----> projT1(M2)
            \       /
             \     /
       M1     \   /     M2
               V V
                X
*)

Check @eqv.

Program Instance EquivSlice : forall `{C : Category} {X : C} (M1 M2 : MorphismInTo X),
    Equivalence (@eq C).
Print EquivSlice.
(*
Equivalence_Reflexive := eq_Reflexive;
Equivalence_Symmetric := eq_Symmetric;
Equivalence_Transitive := eq_Transitive |}
     : ∀Obj Hom C X _ _, Equivalence eq
 *)

Check eqv_equivalence.
Check EquivSlice.

(* ***** *)
(* ABOVE *)
(* ***** *)

Program Instance SliceTAbove' `{C : Category} {X : C} (M1 M2 : MorphismInTo X) : Setoid :=
  {|
    carrier := TriangleAbove M1 M2;
    eqv := fun f g => (projT1 f = projT1 g)
  |}.
Obligation 1.
Proof.
  split.
  - by case.
  - by case.
  - move=> f g h /= Hfg Hgh.
      by rewrite Hfg Hgh.
Defined.

Program Instance SliceTAbove `{C : Category} {X : C} (M1 M2 : MorphismInTo X) : Setoid :=
  {|
    carrier := TriangleAbove M1 M2;
    eqv := fun f g => (projT1 f === projT1 g)
  |}.
Obligation 1.
Proof.
  split.
  - case=> f Hf.
    reflexivity.
  - move=> f g /= Hfg.
    rewrite Hfg.
    reflexivity.
  - move=> f g h /= Hfg Hgh.
    rewrite Hfg Hgh.
    reflexivity.
Defined.

Check @comp : ∀Obj Hom Category a b c _ _, a ~~{ Category }~~> c.
Check comp _ _ : _ ~~{ _ }~~> _.

Program Instance SliceOver `(C : Category) (X : C) : @Category (MorphismInTo X) SliceTAbove :=
  {|
    iid  := fun y1 => existT _ (@id _ _ (projT1 y1)) _;
    comp := fun _ _ _ f g => existT _ ((projT1 f) \\o (projT1 g)) _
  |}.
Obligation 1.                               (* projT1 y1 ~~{ C }~~> projT1 y1 *)
Proof.
    by apply iid.
Defined.
Obligation 2.                               (* projT2 y1 \\o iid === projT2 y1 *)
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite right_identity.
  reflexivity.
Defined.
Obligation 3.                               (* projT2 c \\o (projT1 f \\o projT1 g) === projT2 a *)
Proof.
  move: H H0 H1 f g => a b c f g.
  case: f => MORbc Hcbc_b.
  case: g => MORab Hbab_a.
  simpl.
  rewrite -associativity.
  rewrite Hcbc_b Hbab_a.
  reflexivity.
Defined.
Obligation 4.
Proof.
  move=> fbc fbc' Hbc fab fab' Hab /=.
  rewrite Hbc Hab.
  reflexivity.
Defined.
Obligation 5.
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite left_identity.
  reflexivity.
Defined.
Obligation 6.
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite right_identity.
  reflexivity.
Defined.
Obligation 7.
Proof.
  rewrite associativity.
  reflexivity.
Defined.

Check @Functor.
Check Functor (fun x => projT1 x).

(* スライスからもとの圏をとりだす関手 *)
Program Instance SliceOverInclusion `{C : Category} (X : C) :
  @Functor _ _ (SliceOver C X) _ _ C (fun x => projT1 x) :=
  {|
    fmor := fun a b f => projT1 f
  |}.
Obligation 2.
Proof.
  rewrite /SliceOver_obligation_1.
  reflexivity.
Defined.
Obligation 3.
Proof.
  reflexivity.
Defined.

(* ***** *)
(* UNDER *)
(* ***** *)

Program Instance SliceTUnder `{C : Category} {X : C} (M1 M2 : MorphismOutOf X) : Setoid :=
  {|
    carrier := TriangleBelow M1 M2;
    eqv := fun f g => (projT1 f === projT1 g)
  |}.
Obligation 1.
Proof.
  split.
  - case=> f Hf.
    reflexivity.
  - move=> f g /= Hfg.
    rewrite Hfg.
    reflexivity.
  - move=> f g h /= Hfg Hgh.
    rewrite Hfg Hgh.
    reflexivity.
Defined.

Check @comp : ∀Obj Hom Category a b c _ _, a ~~{ Category }~~> c.
Check comp _ _ : _ ~~{ _ }~~> _.

Program Instance SliceUnder `(C : Category) (X : C) :
  @Category (MorphismOutOf X) SliceTUnder :=
  {|
    iid  := fun y1 => existT _ (@id _ _ (projT1 y1)) _;
    comp := fun _ _ _ f g => existT _ ((projT1 f) \\o (projT1 g)) _
  |}.
Obligation 1.                               (* projT1 y1 ~~{ C }~~> projT1 y1 *)
Proof.
  by apply iid.
Defined.
Obligation 2.                               (* projT2 y1 \\o iid === projT2 y1 *)
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite left_identity.
  reflexivity.
Defined.
Obligation 3.                               (* projT2 c \\o (projT1 f \\o projT1 g) === projT2 a *)
Proof.
  move: H H0 H1 f g => a b c f g.
  case: f => MORbc Hcbc_b.
  case: g => MORab Hbab_a.
  simpl.
  rewrite associativity.
  rewrite Hbab_a Hcbc_b.
  reflexivity.
Defined.
Obligation 4.
Proof.
  move=> fbc fbc' Hbc fab fab' Hab /=.
  rewrite Hbc Hab.
  reflexivity.
Defined.
Obligation 5.
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite left_identity.
  reflexivity.
Defined.
Obligation 6.
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite right_identity.
  reflexivity.
Defined.
Obligation 7.
Proof.
  rewrite associativity.
  reflexivity.
Defined.

Check @Functor.
Check Functor (fun x => projT1 x).

(* スライスからもとの圏をとりだす関手 *)
Program Instance SliceUnderInclusion `{C : Category} (X : C) :
  @Functor _ _ (SliceUnder C X) _ _ C (fun x => projT1 x) :=
  {|
    fmor := fun a b f => projT1 f
  |}.
Obligation 2.
Proof.
  rewrite /SliceOver_obligation_1.
  reflexivity.
Defined.
Obligation 3.
Proof.
  reflexivity.
Defined.

(* END *)


Set Implicit Arguments.

Require Import set.
Require Import subset.
Require Import equiv.

Proposition equiv_symmetric : forall (a b:set),
  equiv a b <-> equiv b a.
Proof.
  intros a b. unfold equiv. simpl. split.
  intro H. split.
  apply proj2 with (A:= subset a b). exact H.
  apply proj1 with (B:= subset b a). exact H.
  intro H. split.
  apply proj2 with (A:= subset b a). exact H.
  apply proj1 with (B:= subset a b). exact H.
Qed.


(** * CSE505 HW3: ADTs *)

Require Import Frap.

(*
 * In this homework, we will implement a map ADT using association lists,
 * and prove that the implementation satisfies the specification.
 * It may help to look at the DataAbstraction.v file in FRAP to get more familiar
 * with the Coq module system.
 *
 * In order to implement maps, we must have keys with a boolean
 * equality function. We start by defining the type of these keys.
 * This definition comes from the FRAP code in DataAbstraction.v.
 *)
Module Type SET_WITH_EQUALITY.
  Parameter t : Set.
  Parameter equal : t -> t -> bool.

  Axiom equal_ok : forall a b, if equal a b then a = b else a <> b.
End SET_WITH_EQUALITY.

(*
 * One example of a type with a boolean equality function
 * is the natural numbers. This implementation also comes from the
 * FRAP code in DataAbstraction.v.
 *)
Module NatWithEquality <: SET_WITH_EQUALITY with Definition t := nat.
  Definition t := nat.

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

  Theorem equal_ok : forall a b, if equal a b then a = b else a <> b.
  Proof.
    induct a; simplify.

    cases b.
    equality.
    equality.

    cases b.
    equality.
    specialize (IHa b).
    cases (equal a b).
    equality.
    equality.
  Qed.
End NatWithEquality.

(*
 * With these definitions, we can now define our map ADT.
 * This is not too different from the map interface in OCaml:
 * http://caml.inria.fr/pub/docs/manual-ocaml/libref/Map.Make.html
 *)
Module Type MAP (s : SET_WITH_EQUALITY).
  Definition key := s.t. (* The type of keys *)
  Parameter t : Set -> Set. (* A collection type that holds values *)
  Parameter empty : forall {val : Set}, t val. (* The empty map *)

  (* --- Basic operations --- *)

  (*
   * Find the value v that a key maps to, returning Some v if the
   * key is in the map, and None otherwise.
   *)
  Parameter find : forall {val : Set}, key -> t val -> option val.

  (*
   * Add a key and value to the map, and return the updated map.
   *)
  Parameter add : forall {val : Set}, key -> val -> t val -> t val.

  (*
   * Remove the value that the key maps to from the map.
   *)
  Parameter remove : forall {val : Set}, key -> t val -> t val.

  (* --- Specifications for basic operations --- *)

  (*
   * Find of any element in the empty map is None
   *)
  Axiom find_empty :
    forall {val : Set} k,
      @find val k empty = None.

  (*
   * Find always returns the most recent value that maps to a key
   *)
  Axiom find_add :
    forall {val : Set} k v l,
      @find val k (add k v l) = Some v.

  (*
   * Removing a key from the empty map returns the empty map
   *)
  Axiom remove_empty :
    forall {val : Set} k,
      @remove val k empty = empty.

  (*
   * Remove is a kind of inverse of add
   *)
  Axiom remove_add :
    forall {val : Set} k v l,
      @remove val k (add k v l) = l.

  (*
   * If a key is not in the map, then removing it does nothing
   *)
  Axiom remove_not_found :
    forall {val : Set} k l,
      find k l = None ->
      @remove val k l = l.

End MAP.

(*
 * Your task is to implement the map ADT using association lists.
 *
 * You may change any of the Definition statements to Fixpoint, and you may use
 * existing standard library functions.
 *
 * If your proofs do not go through, consider the possibility that the functions
 * you have defined are incorrect. For example, I implemented remove incorrectly
 * the first time around, which made remove_not_found unprovable.
 *)

Module AssociationList (s : SET_WITH_EQUALITY) : MAP s.
  Definition key := s.t. (* The type of keys *)
  Definition t (val : Set) := list (key * val). (* A list of key-value pairs *)
  Definition empty {val : Set} : t val := nil. (* The empty map is an empty list *)

  (* --- Basic operations --- *)

  (*
   * Problem 1 [5 points, ~2 LOC]: Implement the find function.
   *
   * Hint: The boolean equality function s.equal will be helpful here.
   *)
  Definition find {val : Set} (k : key) (l : t val) : option val :=
    None. (* YOUR CODE HERE *)

  (*
   * Problem 2 [5 points, ~2 LOC]: Implement the add function.
   *)
  Definition add {val : Set} (k : key) (v : val) (l : t val) : t val :=
    l. (* YOUR CODE HERE *)

  (*
   * Problem 3 [5 points, ~5 LOC]: Implement the remove function.
   *
   * Hint: The boolean equality function s.equal will be helpful here.
   *)
  Fixpoint remove {val : Set} (k : key) (l : t val) : t val :=
    l. (* YOUR CODE HERE *)

  (* --- Specifications for basic operations --- *)

  (*
   * Problem 4 [5 points, ~2 tactics]: Prove find_empty.
   *)
  Theorem find_empty :
    forall {val : Set} k,
      @find val k empty = None.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (*
   * Problem 5 [10 points, ~10 tactics]: Prove find_add.
   *
   * Hint: See the proof of decideable_equality in ListSet in DataAbstraction.v
   * for a technique to destruct on whether s.equal holds on two values.
   *)
  Theorem find_add :
    forall {val : Set} k v l,
      @find val k (add k v l) = Some v.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (*
   * Problem 6 [5 points, ~2 tactics]: Prove remove_empty.
   *)
  Theorem remove_empty :
    forall {val : Set} k,
      @remove val k empty = empty.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (*
   * Problem 7 [10 points, ~10 tactics]: Prove remove_add.
   *)
  Theorem remove_add :
    forall {val : Set} k v l,
      @remove val k (add k v l) = l.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (*
   * Problem 8 [15 points, ~15 tactics]: Prove remove_not_found.
   *)
  Theorem remove_not_found :
    forall {val : Set} k l,
      find k l = None ->
      @remove val k l = l.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

End AssociationList.

(*
 * We can instantiate this with specific types now, like natural numbers:
 *)

Module NatAssociationList := AssociationList NatWithEquality.

(*
 * We now have an ADT and an implementation of the ADT.
 * To make sure our ADT is actually useful, it helps to have a client as well.
 *
 * Below, we define graphs as association lists using the map ADT.
 * Your task is to prove a few theorems about these graphs.
 *
 * Hint: It will help to use the lemmas from the map ADT.
 *)

Module Graph (s : SET_WITH_EQUALITY) (m : MAP s).
  Definition empty := @m.empty (list s.t). (* The empty graph *)

  (*
   * Get all vertices adjacent to v in g.
   *)
  Definition adjacent (v : s.t) (g : m.t (list s.t)) : list s.t :=
    match m.find v g with
    | Some l => l
    | None => []
    end.

  (*
   * Add edges from v1 to every vertex in v2s to g.
   *)
  Definition add_adjacent (v1 : s.t) (v2s : list s.t) (g : m.t (list s.t)) : m.t (list s.t) :=
    m.add v1 v2s g.

  (*
   * Remove all edges from v in g.
   *)
  Definition remove_adjacent (v : s.t) (g : m.t (list s.t)) : m.t (list s.t) :=
    m.remove v g.

  (*
   * Problem 9 [5 points, ~5 tactics]: Prove adjacent_empty.
   *)
  Theorem adjacent_empty :
    forall v,
      adjacent v empty = [].
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (*
   * Problem 10 [5 points, ~5 tactics]: Prove adjacent_add.
   *)
  Theorem adjacent_add :
    forall v1 v2s g,
      adjacent v1 (add_adjacent v1 v2s g) = v2s.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (*
   * Problem 11 [5 points, ~3 tactics]: Prove remove_empty.
   *)
  Theorem remove_empty :
    forall v,
      remove_adjacent v empty = empty.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (*
   * Problem 12 [5 points, ~2 tactics]: Prove remove_add_adjacent.
   *)
  Theorem remove_add_adjacent :
    forall v1 v2s g,
      remove_adjacent v1 (add_adjacent v1 v2s g) = g.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (* --- BONUS PROBLEM --- *)

  (*
   * We've encoded graph reachability as both an inductive relation (Reachable)
   * and a fixpoint (reachable). Your task is to prove the correspondence between
   * the two.
   *)

  Inductive Reachable (g: m.t (list s.t)) : s.t -> s.t -> Prop :=
  | ReachRefl :
      forall x,
      Reachable g x x
  | ReachTrans :
      forall x y z,
      In y (adjacent x g) ->
      Reachable g y z ->
      Reachable g x z.

  Fixpoint reachable' (fuel : nat) (g : m.t (list s.t)) (wl : list s.t) (b : s.t) : option bool :=
    match fuel with
    | O => None
    | S fuel' =>
        match wl with
        | [] => Some false
        | x :: xs =>
            if s.equal x b
            then Some true
            else reachable' fuel' g (xs ++ adjacent x g) b
        end
     end.

  Definition reachable (g : m.t (list s.t)) (a b : s.t) : option bool :=
    reachable' 1000 g [a] b.

  (*
   * BONUS [15 points, ~25 tactics]: Prove the correspondence between
   * reachable' and Reachable.
   *
   * Hint: The proof for this will mirror the structure of reachable'.
   *)
  Lemma reachable'_Reachable:
    forall n g wl b,
      reachable' n g wl b = Some true ->
      exists a, In a wl /\ Reachable g a b.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

  (*
   * BONUS [5 points, ~10 tactics]: Using reachable'_Reachable,
   * prove the correspondence between reachable and Reachable.
   *)
  Theorem reachable_Reachable:
    forall g a b,
      reachable g a b = Some true ->
      Reachable g a b.
  Proof.
    (* YOUR PROOF HERE *)
  Admitted. (* CHANGE TO QED *)

End Graph.


(* This module contains the arithmetic expression evaluation code
   for KodeLlama2 *)

Module Aexp.

Require Export Exp.

Definition plus_aexplit (a b : AexpLit) :=
  match a, b with
    | mk_aexp_lit q, mk_aexp_lit p => mk_aexp_lit (Qplus q p)
    | _, _ => aexp_error
  end.

Definition minus_aexplit (a b : AexpLit) :=
  match a, b with
    | mk_aexp_lit q, mk_aexp_lit p => mk_aexp_lit (Qminus q p)
    | _, _ => aexp_error
   end.

Definition mult_aexplit (a b : AexpLit) :=
 match a, b with
    | mk_aexp_lit q, mk_aexp_lit p => mk_aexp_lit (Qmult q p)
    | _, _ => aexp_error
  end.

Definition div_aexplit (a b : AexpLit) :=
 match a, b with
    | mk_aexp_lit q, mk_aexp_lit p =>
       if Qeq_bool p (Qmake 0 1) then aexp_error else mk_aexp_lit (Qdiv q p)
    | _, _ => aexp_error
  end.

Definition mod_aexplit ( a b : AexpLit ) :=
  match a,b with
    | mk_aexp_lit q, mk_aexp_lit p =>
       if Qeq_bool p (Qmake 0 1) then aexp_error else mk_aexp_lit (Qmake 0 1)
    | _, _ => aexp_error

  end.

Definition exp_aexplit (a b : AexpLit) := mk_aexp_lit (Qmake 1 1). (* exponentiation...seems hard. We'll get to it later *)

Definition neg_aexplit (a : AexpLit) :=
  match a with
    | mk_aexp_lit q => mk_aexp_lit (Qinv q)
    | aexp_error => aexp_error
  end.

Definition aexplit_zero := mk_aexp_lit (Qmake 0 1).

End Aexp.

Export Aexp.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_extension_1 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable axiom_betweennesssymmetry_2 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable axiom_innertransitivity_3 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A B C)).
Variable defray_4 : (forall A B C : Universe, (exists X : Universe, (out_ A B C -> (betS_ X A C /\ betS_ X A B)))).
Variable defray2_5 : (forall A B C X : Universe, ((betS_ X A C /\ betS_ X A B) -> out_ A B C)).
Variable lemma_3_7b_6 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ B C D) -> betS_ A B D)).

Theorem lemma_ray4_3_7 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.
From mathcomp Require Import all_ssreflect ssralg all_algebra seq matrix.
From mathcomp.analysis Require Import Rstruct.

Set Bullet Behavior "Strict Subproofs".

(*** ||A \otimes v - A v|| <= max_i {e_i}
     |A_i \otimes v - A_i v_2| <= e_i
***)
Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Fixpoint X_m_real_generic {n:nat} (m: nat) x0 b (inv_A1 A2: 'M[R]_n.+1) :
  'cV[R]_n.+1 :=
  match m with
  | O => x0
  | S p => ((-(inv_A1 *m A2)) *m (X_m_real_generic p x0 b inv_A1 A2)) +
           (inv_A1 *m b)
  end.


Inductive ev: nat -> Prop :=
| ev_0: ev 0
| ev_SS: forall n : nat, ev n -> ev (S (S n)).

(** **** Exercise: 1 star (ev_double)  *)
Theorem ev_double: forall n, ev (n + n).
Proof.
  intros n.
  induction n as [|n H].
  - simpl.
    apply ev_0.
  - simpl.
    rewrite <- plus_n_Sm.
    apply ev_SS.
    apply H.
Qed.

(** **** Exercise: 1 star (inversion_practice)  *)
Theorem SSSSev__even: forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros n H.
  inversion H.
  inversion H1.
  apply H3.
Qed.

Theorem even5_nonsense: ev 5 -> 2 + 2 = 9.
Proof.
  intros H.
  inversion H.
  inversion H1.
  inversion H3.
Qed.