Require Export theories.Integers.

(* THE CHOICE AXIOM *)

Module Choice.

(* 139 Definition  c is a choice function if and only if c is a function and
   c(x) ∈ x for each member x of domain c. *)

Definition ChoiceFunction c : Prop :=
  Function c /\ (forall x, x ∈ dom(c) -> c[x] ∈ x).

Hint Unfold ChoiceFunction : set.

(* IX Axiom of Choice  There is a choice function c whose domain is μ ~ [Φ]. *)

Axiom Axiom_Choice : exists c, ChoiceFunction c /\ dom(c) = μ ~ [Φ].

Hint Resolve Axiom_Choice : set.

(* 140 Theorem  If x is a set there is a 1_1 function whose range is x and
   whose domain is an ordinal number. *)

Lemma Ex_bel_dom_set_res : forall x c,
  Ensemble x -> ChoiceFunction c ->
  (exists g, forall h, Ensemble h -> g[h] = c[x ~ ran(h)]).
Proof.
  intros.
  unfold ChoiceFunction in H0; destruct H0.
  exists (\{\ λ u v, v = c [x ~ ran(u)] \}\); intros.
  apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme; split; Ens; intros.
    apply Axiom_Scheme in H3; destruct H3.
    apply H5; clear H5; apply Axiom_Scheme; split; Ens.
    apply Axiom_SchemeP; split; try apply ord_set; Ens.
    apply Axiom_Scheme in H4; destruct H4.
    rewrite fun_set_eq in H5; auto.
    apply Axiom_SchemeP in H5; apply H5.
  - apply Axiom_Scheme; split; Ens; intros.
    apply Axiom_Scheme in H4; destruct H4.
    apply Axiom_SchemeP in H5; destruct H5.
    rewrite H6; auto.
Qed.

Lemma Property_F11 : forall f,
  dom(f⁻¹) = ran(f) /\ ran(f⁻¹) = dom(f).
Proof.
  intros; rewrite <- dom_ran_inv, <- dom_ran_inv'; auto.
Qed.

Lemma bel_dom_set_res : forall f g y,
  y ∈ dom(f) -> f [y] = g [f | (y)] -> Ensemble (f | (y)).
Proof.
  intros.
  generalize (classic ((f|(y)) ∈ dom(g))); intros; destruct H1; Ens.
  apply dom_value in H1; rewrite H1 in H0; clear H1.
  apply dom_value in H; rewrite H0 in *.
  generalize (notin_fix μ); intros; contradiction.
Qed.

Theorem exist_fun1_ordnum : forall x,
  Ensemble x -> exists f, Function1_1 f /\ ran(f) = x /\ Ordinal_Number dom(f).
Proof.
  intros.
  generalize Axiom_Choice; intros; destruct H0 as [c H0], H0.
  double H0; apply (Ex_bel_dom_set_res x _) in H2; auto; destruct H2 as [g H2].
  generalize (fun_ord_dom_value_res_eq g); intros; destruct H3 as [f H3], H3, H4.
  unfold ChoiceFunction in H0; destruct H0; exists f.
  assert (Function1_1 f).
  { unfold Function1_1; split; auto.
    unfold Function; split; intros.
    - unfold Relation; intros; PP H7 a b; Ens.
    - unfold Inverse in H7; destruct H7.
      apply Axiom_SchemeP in H7; apply Axiom_SchemeP in H8; destruct H7, H8.
      clear H7 H8; double H9; apply Property_dom in H8.
      double H10; apply Property_dom in H10.
      generalize (classic (y = z)); intros; destruct H11; auto.
      assert (Ordinal y /\ Ordinal z).
      { split; apply (ord_bel_ord dom(f) _); auto. }
      elim H12; intros; apply ord_bel_eq in H12.
      assert (Ordinal_Number y /\ Ordinal_Number z).
      { unfold Ordinal_Number, R; split; apply Axiom_Scheme; Ens. }
      clear H13 H14; destruct H15; apply H5 in H13; apply H5 in H14.
      rewrite H2 in H13, H14; try apply (bel_dom_set_res _ g _); auto.
      clear H2 H5; apply Property_Value in H8; auto.
      apply Property_Value in H10; auto.
      unfold Function in H3; destruct H3.
      add ([y,f[y]] ∈ f) H7; add ([z,f[z]] ∈ f) H9.
      apply H3 in H7; apply H3 in H9; rewrite H9 in H7; clear H9.
      double H8; double H10; apply Property_ran in H8.
      apply Property_ran in H10; destruct H12.
      + assert (f[z] ∈ ran(f|(z))).
        { rewrite H7; unfold Range; apply Axiom_Scheme; split; Ens.
          exists y; unfold Restriction; apply bel_inter; split; auto.
          unfold Cartesian; apply Axiom_SchemeP; split; Ens.
          split; auto; apply bel_universe_set; Ens. }
        assert ((x ~ ran(f|(z))) ∈ dom(c)).
        { generalize (classic ((x ~ ran(f|(z))) ∈ dom(c))); intros.
          destruct H16; auto; apply dom_value in H16; auto.
          rewrite H16 in H14; rewrite H14 in H10; AssE μ.
          generalize universe_notset; intros; contradiction. }
        apply H6 in H16; unfold Difference at 2 in H16.
        rewrite <- H14 in H16; apply bel_inter in H16; destruct H16.
        unfold Complement in H17; apply Axiom_Scheme in H17; destruct H17.
        unfold NotIn in H18; contradiction.
      + destruct H12; try contradiction.
        assert (f[y] ∈ ran(f|(y))).
        { rewrite <- H7; unfold Range; apply Axiom_Scheme; split; Ens.
          exists z; unfold Restriction; apply bel_inter; split; auto.
          unfold Cartesian; apply Axiom_SchemeP; split; Ens.
          split; auto; apply bel_universe_set; Ens. }
        assert ((x ~ ran(f|(y))) ∈ dom(c)).
        { generalize (classic ((x ~ ran(f|(y))) ∈ dom(c))); intros.
          destruct H16; auto; apply dom_value in H16; auto.
          rewrite H16 in H13; rewrite H13 in H8; AssE μ.
          generalize universe_notset; intros; contradiction. }
        apply H6 in H16; unfold Difference at 2 in H16.
        rewrite <- H13 in H16; apply bel_inter in H16; destruct H16.
        unfold Complement in H17; apply Axiom_Scheme in H17; destruct H17.
        unfold NotIn in H18; contradiction. }
  split; auto; assert (ran(f) ⊂ x).
  { unfold Subclass; intros; unfold Range in H8; apply Axiom_Scheme in H8.
    destruct H8, H9; double H9; apply Property_dom in H10.
    assert (Ordinal_Number x0).
    { unfold Ordinal_Number, R; apply Axiom_Scheme; split; Ens.
      apply (ord_bel_ord dom(f) _); split; auto. }
    apply H5 in H11; rewrite H2 in H11; try apply (bel_dom_set_res _ g _); auto.
    apply Property_Value in H10; auto; destruct H3.
    add ([x0,f[x0]]∈f) H9; apply H12 in H9; rewrite <- H9 in H11.
    assert ((x ~ ran(f|(x0))) ∈ dom(c)).
    { generalize (classic ((x ~ ran(f|(x0))) ∈ dom(c))); intros.
      destruct H13; auto; apply dom_value in H13; auto.
      rewrite H13 in H11; rewrite H11 in H9; rewrite <- H9 in H10.
      clear H9 H11 H13; apply Property_ran in H10; AssE μ.
      generalize universe_notset; intros; contradiction. }
    apply H6 in H13; rewrite <- H11 in H13.
    unfold Difference in H13; apply bel_inter in H13; apply H13. }
  assert (Ensemble dom(f)).
  { unfold Function1_1 in H7; destruct H7 as [H9 H7]; clear H9.
    generalize (Property_F11 f); intros; destruct H9; rewrite <- H9 in H8.
    rewrite <- H10; apply Axiom_Substitution; apply sub_set in H8; auto. }
  assert (Ordinal_Number dom(f)).
  { unfold Ordinal_Number; apply Axiom_Scheme; split; auto. }
  split; auto; apply H5 in H10.
  assert (f|(dom(f)) = f).
  { unfold Restriction; apply Axiom_Extent; split; intros.
    - apply Axiom_Scheme in H11; apply H11.
    - apply Axiom_Scheme; repeat split; Ens; unfold Function, Relation in H3.
      double H11; apply H3 in H12; destruct H12 as [a [b H12]].
      rewrite H12 in *; clear H12; apply Axiom_SchemeP; repeat split; Ens.
      + apply Property_dom in H11; auto.
      + apply Property_ran in H11; apply bel_universe_set; Ens. }
  rewrite H11 in *; clear H11.
  rewrite H2 in H10; try apply fun_dom_set; auto.
  generalize (notin_fix dom(f)); intros.
  apply dom_value in H11; auto; rewrite H10 in H11.
  generalize (classic ((x ~ ran(f)) ∈ dom(c))); intros; destruct H12.
  - apply dom_value in H12; auto; rewrite H11 in H12.
    generalize (notin_fix μ); intros; contradiction.
  - rewrite H1 in H12; unfold Difference at 2 in H12.
    assert ((x ~ ran(f)) ∈ (μ ∩ ¬[Φ]) <-> (x ~ ran(f)) ∈ μ /\
            (x ~ ran(f)) ∈ ¬[Φ]).
    { split; intros; try apply bel_inter; auto. }
    apply definition_not in H13; auto; clear H12.
    assert (Ensemble (x ~ ran(f))).
    { apply (sub_set x _); auto; unfold Subclass.
      intros; apply Axiom_Scheme in H12; apply H12. }
    apply not_and_or in H13; destruct H13.
    + elim H13; apply bel_universe_set; auto.
    + assert ((x ~ ran(f)) ∈ ¬[Φ] <-> Ensemble (x ~ ran(f)) /\
              (x ~ ran(f)) ∉ [Φ]).
      { split; intros; try apply Axiom_Scheme; auto.
        apply Axiom_Scheme in H14; apply H14. }
      apply definition_not in H14; auto; clear H13.
      apply not_and_or in H14; destruct H14; try contradiction.
      unfold NotIn in H13; apply NNPP in H13.
      unfold Singleton in H13; apply Axiom_Scheme in H13; destruct H13.
      generalize Axiom_Infinity; intros; destruct H15, H15, H16.
      AssE Φ; clear H15 H16 H17; apply bel_universe_set in H18.
      apply H14 in H18; symmetry; apply -> Property_Φ in H18; auto.
Qed.

Hint Resolve exist_fun1_ordnum : set.

(* 141 Definition  n is a nest if and only if, whenever x an y are members of
   n, then  x ⊂ y or y ⊂ x. *)

Definition Nest n : Prop :=
  forall x y, x ∈ n /\ y ∈ n -> x ⊂ y \/ y ⊂ x.

Hint Unfold Nest : set.

(* 142 Theorem  If n is a nest and each member of n is a nest, then ∪n is a
   nest. *)

Theorem nest_eleU : forall n,
  Nest n /\ (forall m, m ∈ n -> Nest m) -> Nest (∪ n).
Proof.
  intros; destruct H.
  unfold Nest; intros; destruct H1.
  unfold Element_U in H1, H2; apply Axiom_Scheme in H1.
  apply Axiom_Scheme in H2; destruct H1, H2, H3, H4, H3, H4.
  unfold Nest in H; assert (x0∈n /\ x1∈n). { Ens. }
  apply H0 in H5; apply H0 in H6; apply H in H7; destruct H7.
  - unfold Subclass in H7; apply H7 in H3; clear H7.
    unfold Nest in H6; apply H6; auto.
  - unfold Subclass in H7; apply H7 in H4; clear H7.
    unfold Nest in H5; apply H5; auto.
Qed.

Hint Resolve nest_eleU : set.

(* 143 Theorem (Hausdorff maximal principle)  If x is a set there is a nest n
   such that n ⊂ x and if m is nest, m ⊂ x, and n ⊂ m, then m = n. *)

Definition En_c x h : Class :=
  \{ λ m, Nest m /\ m ⊂ x /\ (forall p, p ∈ ran(h) -> p ⊂ m /\ p <> m) \}.

Lemma Ex_Enc : forall x c,
  Ensemble x -> ChoiceFunction c ->
  (exists g, forall h, Ensemble h -> g[h] = c[En_c x h]).
Proof.
  intros.
  unfold ChoiceFunction in H0; destruct H0.
  exists (\{\ λ u v, v = c[En_c x u] \}\); intros.
  apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme; split; Ens; intros.
    apply Axiom_Scheme in H3; destruct H3.
    apply H5; clear H5; apply Axiom_Scheme; split; Ens.
    apply Axiom_SchemeP; split; try apply ord_set; Ens.
    apply Axiom_Scheme in H4; destruct H4.
    rewrite fun_set_eq in H5; auto.
    apply Axiom_SchemeP in H5; apply H5.
  - apply Axiom_Scheme; split; Ens; intros.
    apply Axiom_Scheme in H4; destruct H4.
    apply Axiom_SchemeP in H5; destruct H5.
    rewrite H6; auto.
Qed.

Lemma lem_Hausdorff_maximal_principle : forall f z,
  Function f -> z ∈ (∪ ran(f)) -> exists x, z ∈ f [x] /\ x ∈ dom(f).
Proof.
  intros.
  unfold Element_U in H0; apply Axiom_Scheme in H0.
  destruct H0, H1 as [y H1], H1; unfold Range in H2.
  apply Axiom_Scheme in H2; destruct H2, H3 as [x H3].
  double H3; rewrite fun_set_eq in H4; auto.
  apply Axiom_SchemeP in H4; destruct H4; rewrite H5 in *.
  apply Property_dom in H3; Ens.
Qed.

Theorem Hausdorff_maximal_principle : forall x,
  Ensemble x -> exists n, (Nest n /\ n ⊂ x) /\
  (forall m, Nest m -> m ⊂ x /\ n ⊂ m -> m = n).
Proof.
  intros.
  generalize Axiom_Choice; intros; destruct H0 as [c H0], H0.
  double H0; apply (Ex_Enc x _) in H2; auto; destruct H2 as [g H2].
  generalize (fun_ord_dom_value_res_eq g); intros; destruct H3 as [f H3], H3, H4.
  unfold ChoiceFunction in H0; destruct H0.
  (* If u ∈ dom(f), then f[u] is a nest of x. *)
  assert (forall u, u ∈ dom(f) -> Nest f[u] /\ f[u] ⊂ x /\
         (forall p, p ∈ ran(f|(u)) -> p ⊊ f[u])).
  { intros; assert (Ordinal_Number u).
    { unfold Ordinal_Number, R; apply Axiom_Scheme.
      split; try apply (ord_bel_ord dom(f) _); Ens. }
    apply H5 in H8; rewrite H2 in H8; try apply (bel_dom_set_res _ g _); auto.
    assert (En_c x (f|(u)) ∈ dom(c)).
    { generalize (classic (En_c x (f|(u)) ∈ dom(c))); intros.
      destruct H9; auto; apply dom_value in H9; auto.
      rewrite H9 in H8; clear H9; apply Property_Value in H7; auto.
      apply Property_ran in H7; rewrite H8 in H7; AssE μ.
      generalize universe_notset; intros; contradiction. }
    apply H6 in H9; rewrite <- H8 in H9; clear H8.
    apply Axiom_Scheme in H9; apply H9. }
  (* If u and v are members of dom(f) and u<v, then f[u] ⊊ f[v]. *)
  assert (forall u v, u ∈ dom(f) -> v ∈ dom(f) -> u ∈ v -> f[u] ⊊ f[v]).
  { intros; apply H7 in H9; clear H7; destruct H9, H9.
    apply H11; unfold Range; apply Axiom_Scheme.
    apply Property_Value in H8; auto; double H8.
    apply Property_ran in H12; split; Ens; exists u.
    unfold Restriction; apply bel_inter; split; auto.
    unfold Cartesian; apply Axiom_SchemeP; split; Ens.
    split; try apply bel_universe_set; Ens. }
  exists (∪ ran(f)); intros; split; intros; try split.
  - unfold Nest; intros z0 z1 H9; destruct H9.
    apply lem_Hausdorff_maximal_principle in H9; apply lem_Hausdorff_maximal_principle in H10; auto.
    destruct H9, H10, H9, H10.
    assert (Ordinal x0 /\ Ordinal x1).
    { split; apply (ord_bel_ord dom(f) _); auto. }
    apply ord_bel_eq in H13; destruct H13 as [H13|[H13|H13]].
    + apply H8 in H13; auto; unfold ProperSubclass in H13.
      destruct H13; apply H13 in H9; clear H13 H14.
      apply H7 in H12; destruct H12; clear H13.
      unfold Nest in H12; apply H12; auto.
    + apply H8 in H13; auto; unfold ProperSubclass in H13.
      destruct H13; apply H13 in H10; clear H13 H14.
      apply H7 in H11; destruct H11; clear H13.
      unfold Nest in H11; apply H11; auto.
    + rewrite H13 in H9; apply H7 in H12; destruct H12.
      unfold Nest in H12; apply H12; auto.
  - unfold Subclass; intros; apply lem_Hausdorff_maximal_principle in H9; auto.
    destruct H9, H9; apply H7 in H10; destruct H10, H11.
    unfold Subclass in H11; apply H11; auto.
  - destruct H10; generalize (notin_fix dom(f)); intros.
    apply dom_value in H12.
    assert (Function f⁻¹).
    { unfold Function; split; intros.
      - unfold Relation; intros; PP H13 a b; Ens.
      - destruct H13; unfold Inverse in H13, H14.
        apply Axiom_SchemeP in H13; apply Axiom_SchemeP in H14.
        destruct H13, H14; double H15; double H16.
        rewrite fun_set_eq in H17, H18; auto.
        apply Axiom_SchemeP in H17; apply Axiom_SchemeP in H18.
        destruct H17, H18; rewrite H19 in H20.
        clear H17 H18 H19; apply Property_dom in H15.
        apply Property_dom in H16.
        assert (Ordinal y /\ Ordinal z).
        { split; apply (ord_bel_ord dom(f) _); auto. }
        apply ord_bel_eq in H17; destruct H17.
        + apply H8 in H17; auto; unfold ProperSubclass in H17.
          destruct H17; contradiction.
        + destruct H17; auto; apply H8 in H17; auto.
          destruct H17; symmetry in H20; contradiction. }
    assert (Ensemble dom(f)).
    { generalize (Property_F11 f); intros; destruct H14.
      rewrite <- H15; apply Axiom_Substitution; auto; rewrite H14.
      apply (sub_set pow(x) _); try (apply pow_set in H; auto).
      unfold Subclass; intros; unfold Range in H16; apply Axiom_Scheme in H16.
      destruct H16, H17; double H17; rewrite fun_set_eq in H18; auto.
      apply Axiom_SchemeP in H18; destruct H18; rewrite H19 in *; clear H18 H19.
      apply Property_dom in H17; apply H7 in H17; destruct H17, H18.
      unfold PowerClass; apply Axiom_Scheme; split; auto. }
    assert (Ordinal_Number dom(f)).
    { unfold Ordinal_Number, R; apply Axiom_Scheme; split; auto. }
    apply H5 in H15; assert (f|(dom(f)) = f).
    { unfold Restriction; apply Axiom_Extent; split; intros.
      - apply Axiom_Scheme in H16; apply H16.
      - apply Axiom_Scheme; repeat split; Ens; unfold Function, Relation in H3.
        double H16; apply H3 in H17; destruct H17 as [a [b H17]].
        rewrite H17 in *; clear H17; apply Axiom_SchemeP; repeat split; Ens.
        + apply Property_dom in H16; auto.
        + apply Property_ran in H16; apply bel_universe_set; Ens. }
    rewrite H16 in *; rewrite H15 in H12; clear H15 H16.
    rewrite H2 in H12; try apply fun_dom_set; auto.
    generalize (classic (En_c x f ∈ dom(c))); intros; destruct H15.
    + apply dom_value in H15; auto; rewrite H12 in H15.
      generalize (notin_fix μ); intros; contradiction.
    + rewrite H1 in H15; unfold Difference in H15.
      assert (En_c x f ∈ (μ ∩ ¬[Φ]) <-> En_c x f ∈ μ /\ En_c x f ∈ ¬[Φ]).
      { split; intros; try apply bel_inter; auto. }
      apply definition_not in H16; auto; clear H15.
      assert (Ensemble (En_c x f)).
      { apply (sub_set pow(x) _); try (apply pow_set in H; auto).
        unfold Subclass; intros; unfold En_c in H15.
        apply Axiom_Scheme in H15; destruct H15, H17, H18.
        unfold PowerClass; apply Axiom_Scheme; split; auto. }
      apply not_and_or in H16; destruct H16.
      * elim H16; apply bel_universe_set; auto.
      * assert (En_c x f ∈ ¬[Φ] <-> Ensemble (En_c x f) /\ En_c x f ∉ [Φ]).
        { split; intros; try apply Axiom_Scheme; auto.
          apply Axiom_Scheme in H17; apply H17. }
        apply definition_not in H17; auto; clear H16.
        apply not_and_or in H17; destruct H17; try contradiction.
        unfold NotIn in H16; apply NNPP in H16.
        unfold Singleton in H16; apply Axiom_Scheme in H16; destruct H16.
        generalize Axiom_Infinity; intros; destruct H18, H18, H19.
        AssE Φ; clear H18 H19 H20; apply bel_universe_set in H21.
        apply H17 in H21; clear H17.
        generalize (classic (m = ∪ ran( f))); intros; destruct H17; auto.
        assert (m ∈ (En_c x f)).
        { unfold En_c; apply Axiom_Scheme; repeat split; auto.
          - apply (sub_set x _); auto.
          - unfold Subclass; intros; apply H11.
            unfold Element_U; apply Axiom_Scheme; split; Ens.
          - intro; rewrite H19 in H18; clear H19.
            elim H17; apply sub_eq; split; auto.
            unfold Subclass; intros; apply Axiom_Scheme; Ens. }
        rewrite H21 in H18; generalize (not_bel_zero m); contradiction.
Qed.

Hint Resolve Hausdorff_maximal_principle : set.

End Choice.

Export Choice.


Require Import List.
Import ListNotations.

Require Import BinInt ZArith_dec.
Require Export Id State Expr Stmt.

From hahn Require Import HahnBase.

Module SmallStep.

  Reserved Notation "c1 '--' s '-->' c2" (at level 0).

  Inductive ss_int_step : stmt -> conf -> option stmt * conf -> Prop :=
  | ss_Skip        : forall (c : conf), c -- SKIP --> (None, c)
  | ss_Assign      : forall (s : state Z) (i o : list Z) (x : id) (e : expr) (z : Z)
                            (SVAL : [| e |] s => z),
      (s, i, o) -- x ::= e --> (None, (s [x <- z], i, o))
  | ss_Read        : forall (s : state Z) (i o : list Z) (x : id) (z : Z),
      (s, z::i, o) -- READ x --> (None, (s [x <- z], i, o))
  | ss_Write       : forall (s : state Z) (i o : list Z) (e : expr) (z : Z)
                            (SVAL : [| e |] s => z),
      (s, i, o) -- WRITE e --> (None, (s, i, z::o))
  | ss_Seq_Compl   : forall (c c' : conf) (s1 s2 : stmt)
                            (SSTEP : c -- s1 --> (None, c')),
      c -- s1 ;; s2 --> (Some s2, c')
  | ss_Seq_InCompl : forall (c c' : conf) (s1 s2 s1' : stmt)
                            (SSTEP : c -- s1 --> (Some s1', c')),
      c -- s1 ;; s2 --> (Some (s1' ;; s2), c')
  | ss_If_True     : forall (s : state Z) (i o : list Z) (s1 s2 : stmt) (e : expr)
                            (SCVAL : [| e |] s => Z.one),
      (s, i, o) -- COND e THEN s1 ELSE s2 END --> (Some s1, (s, i, o))
  | ss_If_False    : forall (s : state Z) (i o : list Z) (s1 s2 : stmt) (e : expr)
                            (SCVAL : [| e |] s => Z.zero),
      (s, i, o) -- COND e THEN s1 ELSE s2 END --> (Some s2, (s, i, o))
  | ss_While       : forall (c : conf) (s : stmt) (e : expr),
      c -- WHILE e DO s END --> (Some (COND e THEN s ;; WHILE e DO s END ELSE SKIP END), c)
  where "c1 -- s --> c2" := (ss_int_step s c1 c2).

  Reserved Notation "c1 '--' s '-->>' c2" (at level 0).

  Inductive ss_int : stmt -> conf -> conf -> Prop :=
    ss_int_Base : forall (s : stmt) (c c' : conf)
                         (STEP : c -- s --> (None, c')),
      c -- s -->> c'
  | ss_int_Step : forall (s s' : stmt) (c c' c'' : conf)
                    (STEP  : c -- s --> (Some s', c'))
                    (STEPS : c' -- s' -->> c''),
      c -- s -->> c''
  where "c1 -- s -->> c2" := (ss_int s c1 c2).

  Lemma ss_int_step_deterministic (s : stmt)
        (c : conf) (c' c'' : option stmt * conf)
        (EXEC1 : c -- s --> c')
        (EXEC2 : c -- s --> c'') :
    c' = c''.
  Proof. admit. Admitted.

  Lemma ss_int_deterministic (c c' c'' : conf) (s : stmt)
        (STEP1 : c -- s -->> c') (STEP2 : c -- s -->> c'') :
    c' = c''.
  Proof. admit. Admitted.

  Lemma ss_bs_base (s : stmt) (c c' : conf) (STEP : c -- s --> (None, c')) :
    c == s ==> c'.
  Proof. admit. Admitted.

  Lemma ss_ss_composition (c c' c'' : conf) (s1 s2 : stmt)
        (STEP1 : c -- s1 -->> c'') (STEP2 : c'' -- s2 -->> c') :
    c -- s1 ;; s2 -->> c'.
  Proof. admit. Admitted.

  Lemma ss_bs_step (c c' c'' : conf) (s s' : stmt)
        (STEP : c -- s --> (Some s', c'))
        (EXEC : c' == s' ==> c'') :
    c == s ==> c''.
  Proof. admit. Admitted.

  Theorem bs_ss_eq (s : stmt) (c c' : conf) :
    c == s ==> c' <-> c -- s -->> c'.
  Proof. admit. Admitted.
End SmallStep.


(** * Relation

    関係についての定義や定理を記述する。 *)

Require Import Basis .

(** 戦術を使う。 *)
Declare ML Module "ltac_plugin" .
Set Default Proof Mode "Classic" .

(** 記法を使う。 *)
Import Basis.Notation .

(** [A] と [B] の上の関係。 *)
Definition rel (A B : Type) : Type := A -> B -> Type .

(** 逆関係。 *)
Definition rel_inv {A B : Type} (R : rel A B) : rel B A
  := fun x y => R y x .

(** 関係の結び。 *)
Inductive rel_sum {A B : Type} (R S : rel A B) : rel A B
  :=
  | mk_rel_sum : forall x y, sum (R x y) (S x y) -> rel_sum R S x y
  .

(** 関係の交わり。 *)
Inductive rel_prod {A B : Type} (R S : rel A B) : rel A B
  :=
  | mk_rel_prod : forall x y, prod (R x y) (S x y) -> rel_prod R S x y
  .

(** 関係の合成。 *)
Inductive rel_comp {A B C : Type} (R : rel B C) (S : rel A B) : rel A C
  :=
  | mk_rel_comp : forall x y z, R y z -> S x y -> rel_comp R S x z
  .

(** 関数を関係に変換する。 *)
Definition rel_fun {A B : Type} (f : A -> B) : rel A B
  := fun x y => f x = y .

(** [R] は [S] の部分関係である。 *)
Definition rel_sub {A B : Type} (R S : rel A B) : Type
  := forall x y, R x y -> S x y .

(** ** Well-foundness *)

Section Acc .

  Variable A : Type .
  Variable R : A -> A -> Type .

  (** [A] の関係 [R] は [x : A] において整礎である。 *)
  Inductive acc (x : A) : Type
    :=
    | mk_acc : (forall xp, R xp x -> acc xp) -> acc x
    .

  Definition acc_case_nodep
    (x : A) (P : Type)
    (case_mk_acc : (forall xp, R xp x -> acc xp) -> P)
    (H : acc x) : P
    := match H with mk_acc _ Hp => case_mk_acc Hp end .

  Definition acc_case
    (x : A) (P : acc x -> Type)
    (case_mk_acc : forall Hps, P (mk_acc x Hps))
    (H : acc x) : P H
    := match H with mk_acc _ Hps => case_mk_acc Hps end .

  Definition acc_rec
    (P : A -> Type)
    (case_mk_acc : forall x, (forall xp, R xp x -> P xp) -> P x)
    (x : A) (xH : acc x) : P x .
  Proof.
   revert x xH .
   refine (fix go (x : A) (xH : acc x) {struct xH} : P x := _) .
   refine (acc_case_nodep x (P x) _ xH) .
   refine (fun xHps => _) .
   refine (case_mk_acc x _) .
   refine (fun xp xpR => _) .
   exact (go xp (xHps xp xpR)) .
  Defined.

  Definition acc_rect
    (P : forall x, acc x -> Type)
    (case_mk_acc
       : forall x xHps,
                        (forall xp xpR, P xp (xHps xp xpR)) ->
                         P x (mk_acc x xHps))
    (x : A) (xH : acc x) : P x xH .
  Proof.
   revert x xH .
   refine (fix go (x : A) (xH : acc x) {struct xH} : P x xH := _) .
   refine (acc_case x (P x) _ xH) .
   refine (fun xHps => _) .
   refine (case_mk_acc x xHps _) .
   refine (fun xp xpR => _) .
   exact (go xp (xHps xp xpR)) .
  Defined.

End Acc.

Arguments acc {_} _ _ .
Arguments mk_acc {_ _ _} _ .
Arguments acc_case_nodep {_ _ _ _} _ _ .
Arguments acc_case {_ _ _ _} _ _ .
Arguments acc_rec {_ _ _} _ {_} _ .
Arguments acc_rect {_ _ _} _ {_} _ .

(** [mk_acc] の反対。 *)
Definition inv_acc
  {A : Type} {R : A -> A -> Type} {x : A} (H : acc R x)
  {y : A} (yR : R y x) : acc R y .
Proof.
 revert H y yR .
 refine (acc_case_nodep _) .
 exact idmap .
Defined.

(** [R] は整礎である。 *)
Definition well_founded {A : Type} (R : A -> A -> Type) : Type
  := forall x : A, acc R x .

(** *** Well-founded induction

    「超限再帰的な定義」からの類推で、関数を整礎帰納法的に定義するともいえる。 *)

(** 非依存の整礎帰納法。 *)
Definition wf_ind_nodep
  {A : Type} {R : A -> A -> Type} {P : Type}
  (c : forall x, (forall xp, R xp x -> P) -> P)
  (wf_R : well_founded R) (x : A) : P
  := acc_rec c (wf_R x) .

(** 整礎帰納法。 *)
Definition wf_ind
  {A : Type} {R : A -> A -> Type} {P : A -> Type}
  (c : forall x : A, (forall xp : A, R xp x -> P xp) -> P x)
  (wf_R : well_founded R) (x : A) : P x
  := acc_rec c (wf_R x) .

Definition infinite_descent_0
  {A : Type} {R : A -> A -> Type} {P : A -> Type}
  (c : forall x : A, (forall xp : A, R xp x -> P xp -> empty) -> P x -> empty)
  (wf_R : well_founded R) (x : A) : P x -> empty
  := (wf_ind c wf_R x) .

Definition infinite_descent_1
  {A : Type} {R : A -> A -> Type} {P : A -> Type}
  (c : forall x  : (sigma xv, P xv),
                   (forall xp : (sigma xv, P xv),
                                 R (dfst xp) (dfst x) ->
                                 empty) ->
                    empty)
  (wf_R : well_founded R) (x : sigma xv, P xv) : empty .
Proof.
 revert x .
 refine (dsum_elim_nodep _) .
 refine (infinite_descent_0 _ wf_R) .
 refine (fun x I xH => _) .
 refine (c (dpair x xH) _) .
 refine (dsum_elim _) .
 refine (fun xp xpH xpR => _) .
 refine (I xp _ xpH) .
 change (R xp x) in xpR .
 exact xpR .
Defined.

Definition infinite_descent_2
  {A : Type} {R : A -> A -> Type} {P : A -> Type}
  (c : forall x : (sigma xv, P xv),
                   sigma xp : (sigma xvp, P xvp), R (dfst xp) (dfst x))
  (wf_R : well_founded R) (x : sigma xv, P xv) : empty .
Proof.
 revert x .
 refine (infinite_descent_1 _ wf_R) .
 refine (fun x I => _) .
 generalize (c x) .
 refine (dsum_elim_nodep _) .
 refine (fun xp xpR => _) .
 refine (I xp _) .
 exact xpR .
Defined.

Definition infinite_descent_3
  {A : Type} {R : A -> A -> Type} {P : A -> Type}
  (c : forall xv, P xv -> sigma xpv, prod (P xpv) (R xpv xv))
  (wf_R : well_founded R) (xv : A) (xh : P xv) : empty .
Proof.
 refine (infinite_descent_2 _ wf_R (dpair xv xh)) ; clear xv xh .
 refine (dsum_elim _) .
 refine (fun xv xh => _) .
 generalize (c xv xh) .
 refine (dsum_elim_nodep _) .
 refine (fun xpv => _) .
 refine (prod_elim_nodep _) .
 refine (fun xph xpr => _) .
 refine (dpair (dpair xpv xph) _) .
 change (R xpv xv) .
 exact xpr .
Defined.

(** 無限降下法。

    [infinite_descent_0 <-> infinite_descent_1 -> infinite_descent_2 <-> infinite_descent_3] 。

    *)
Notation infinite_descent := infinite_descent_3 .

(** *** Existence of infinite descending sequence *)

Section Chain .

  Variable A : Type .
  Variable R : A -> A -> Type .

  (** [A] の関係 [R] は [x : A] において反整礎である。 *)
  CoInductive chain (x : A) : Type
    :=
    | chain_build : (sigma xp, prod (R xp x) (chain xp)) -> chain x
    .

  Definition ds_chain
    (x : A) (P : Type)
    (H : chain x) : sigma xp, prod (R xp x) (chain xp)
    := match H with chain_build _ Hp => Hp end .

  Definition chain_corec
    (P : A -> Type)
    (case_ds_chain : forall (x : A) (xH : P x), sigma xp, prod (R xp x) (P xp))
    (x : A) (xH : P x) : chain x .
  Proof.
   revert x xH .
   refine (cofix go (x : A) (xH : P x) : chain x := _) .
   refine (chain_build x _) .
   generalize (case_ds_chain x xH) .
   refine (dsum_elim _) .
   refine (fun xp => _) .
   refine (prod_elim _) .
   refine (fun Hr Hp => _) .
   refine (dpair xp _) .
   refine (pair Hr _) .
   exact (go xp Hp) .
  Defined.

End Chain.

(** 参考文献:

    * https://ja.wikipedia.org/w/index.php?oldid=70335496
    * https://en.wikipedia.org/w/index.php?oldid=886562428
    * https://github.com/coq/coq/blob/f4cf212efd98d01a6470ea7bfd1034d52e928906/theories/Init/Wf.v

    *)


Require Import coqutil.Macros.subst coqutil.Macros.unique coqutil.Map.Interface.
Require Coq.Lists.List.
Require Coq.Logic.Eqdep_dec.

(* TODO: move me? *)
Definition minimize_eq_proof{A: Type}(eq_dec: forall (x y: A), {x = y} + {x <> y}){x y: A}    (pf: x = y): x = y :=
  match eq_dec x y with
  | left p => p
  | right n => match n pf: False with end
  end.

Module Import parameters.
  Class parameters := {
    key : Type;
    value : Type;
    ltb : key -> key -> bool
  }.

  Class strict_order {T} {ltb : T -> T -> bool}: Prop := {
    ltb_antirefl : forall k, ltb k k = false;
    ltb_trans : forall k1 k2 k3, ltb k1 k2 = true -> ltb k2 k3 = true -> ltb k1 k3 = true;
    ltb_total : forall k1 k2, ltb k1 k2 = false -> ltb k2 k1 = false -> k1 = k2;
  }.
  Global Arguments strict_order {_} _.
End parameters. Notation parameters := parameters.parameters.

Section SortedList. Local Set Default Proof Using "All".
  Context {p : unique! parameters} {ok : strict_order ltb}.

  Local Definition eqb k1 k2 := andb (negb (ltb k1 k2)) (negb (ltb k2 k1)).

  Fixpoint put m (k:key) (v:value) : list (key * value) :=
    match m with
    | nil => cons (k, v) nil
    | cons (k', v') m' =>
      match ltb k k', ltb k' k with
      | (* < *) true, _ => cons (k, v) m
      | (* = *) false, false => cons (k, v) m'
      | (* > *) false, true => cons (k', v') (put m' k v)
      end
    end.

  Fixpoint remove m (k:key) : list (key * value) :=
    match m with
    | nil => nil
    | cons (k', v') m' =>
      match ltb k k', ltb k' k with
      | (* < *) true, _ => m
      | (* = *) false, false => m'
      | (* > *) false, true => cons (k', v') (remove m' k)
      end
    end.

  Fixpoint sorted (m : list (key * value)) :=
    match m with
    | cons (k1, _) ((cons (k2, _) m'') as m') => andb (ltb k1 k2) (sorted m')
    | _ => true
    end.

  Record rep := { value : list (key * value) ; _value_ok : sorted value = true }.

  Lemma ltb_antisym k1 k2 (H:eqb k1 k2 = false) : ltb k1 k2 = negb (ltb k2 k1).
  Proof.
    apply Bool.andb_false_iff in H.
    destruct (ltb k1 k2) eqn:H1; destruct (ltb k2 k1) eqn:H2; cbn in *; trivial.
    { pose proof ltb_trans _ _ _ H1 H2; pose proof ltb_antirefl k1; congruence. }
    { destruct H; discriminate. }
  Qed.

  Lemma sorted_put m k v : sorted m = true -> sorted (put m k v) = true.
  Proof.
    revert v; revert k; induction m as [|[k0 v0] m]; trivial; []; intros k v H.
    cbn [put]; destruct (ltb k k0) eqn:?.
    { eapply Bool.andb_true_iff; split; assumption. }
    destruct (ltb k0 k) eqn:?; cycle 1.
    { rewrite (ltb_total k k0); assumption. }
    cbn [sorted]; destruct m as [|[k1 v1] mm] eqn:?Hmm.
    { cbn. rewrite Bool.andb_true_r; trivial. }
    rewrite (IHm k v) by (eapply Bool.andb_true_iff in H; destruct H; eassumption).
    cbn [put]; destruct (ltb k k1) eqn:?; rewrite ?Bool.andb_true_r; trivial; [].
    destruct (ltb k1 k) eqn:?; rewrite ?Bool.andb_true_r; trivial; [].
    eapply Bool.andb_true_iff in H; destruct H; eassumption.
  Qed.

  Lemma sorted_remove m k : sorted m = true -> sorted (remove m k) = true.
  Proof.
    revert k; induction m as [|[k0 v0] m]; [trivial|]; []; intros k H.
    cbn [remove].
    destruct (ltb k k0) eqn:?; trivial; [].
    destruct (ltb k0 k) eqn:?; trivial; cycle 1.
    { destruct m as [|[] ?]; [trivial|]; eapply Bool.andb_true_iff in H; destruct H; eassumption. }
    cbn [sorted]; destruct m as [|[k1 v1] mm] eqn:?Hmm; trivial.
    rewrite IHm by (eapply Bool.andb_true_iff in H; destruct H; eassumption).
    cbn [remove]; destruct (ltb k k1) eqn:?; rewrite ?Bool.andb_true_r; eauto 2 using ltb_trans; [].
    destruct (ltb k1 k) eqn:?; rewrite ?Bool.andb_true_r.
    { eapply Bool.andb_true_iff in H; destruct H; eassumption. }
    destruct mm as [|[kk vv] ?]; rewrite ?Bool.andb_true_r; trivial.
    repeat (eapply Bool.andb_true_iff in H; destruct H as [?GG H]); eauto 2 using ltb_trans.
  Qed.

  Definition lookup(l: list (key * parameters.value))(k: key): option parameters.value :=
    match List.find (fun p => eqb k (fst p)) l with
    | Some (_, v) => Some v
    | None => None
    end.

  Lemma eqb_refl: forall x: key, eqb x x = true.
  Proof.
    intros. unfold eqb. rewrite (@ltb_antirefl _ _ ok). reflexivity.
  Qed.

  Lemma eqb_true: forall k1 k2, eqb k1 k2 = true <-> k1 = k2.
  Proof.
    unfold eqb. intros.
    split; intros.
    - eapply Bool.andb_true_iff in H. destruct H as [L1 L2].
      destruct (ltb k1 k2) eqn: E12. 1: discriminate L1.
      destruct (ltb k2 k1) eqn: E21. 1: discriminate L2.
      eauto using ltb_total.
    - subst.
      apply Bool.andb_true_iff.
      rewrite ltb_antirefl.
      intuition.
  Qed.

  Lemma eqb_false: forall k1 k2, eqb k1 k2 = false <-> k1 <> k2.
  Proof.
    intros.
    rewrite <-Bool.not_true_iff_false.
    unfold not.
    rewrite eqb_true.
    intuition.
  Qed.

  Lemma eqb_sym: forall k1 k2, eqb k1 k2 = eqb k2 k1.
  Proof using.
    unfold eqb. intros.
    destruct (ltb k1 k2) eqn: E12;
    destruct (ltb k2 k1) eqn: E21;
    eauto using ltb_total.
  Qed.

  Lemma lookup_cons: forall k1 k2 v l,
      lookup ((k1, v) :: l) k2 = if eqb k2 k1 then Some v else lookup l k2.
  Proof using.
    unfold lookup. intros. simpl. rewrite eqb_sym. destruct (eqb k1 k2); reflexivity.
  Qed.

  Lemma sorted_cons: forall l k v,
      sorted ((k, v) :: l) = true ->
      sorted l = true /\ lookup l k = None /\ forall k0, ltb k0 k = true -> lookup l k0 = None.
  Proof.
    induction l; intros.
    - simpl. auto.
    - simpl in *. destruct a as [k' v'].
      apply Bool.andb_true_iff in H. destruct H.
      split; [assumption|]. simpl.
      setoid_rewrite lookup_cons.
      destruct (eqb k k') eqn: E. {
        unfold eqb in E. rewrite H in E. simpl in E. discriminate E.
      }
      specialize IHl with (1 := v) (2 := H0).
      destruct IHl as [IH1 [IH2 IH3]].
      split; [solve [eauto]|].
      intros k0 L0.
      unfold eqb in E. rewrite H in E. simpl in E.
      destruct (eqb k0 k') eqn: E2.
      + unfold eqb in E2. rewrite  (ltb_trans _ _ _ L0 H) in E2. simpl in E2. discriminate.
      + destruct l as [|[k'' v''] l]; try reflexivity.
        apply Bool.andb_true_iff in H0. destruct H0. eauto using ltb_trans.
  Qed.

  Definition map : map.map key parameters.value :=
    let wrapped_put m k v := Build_rep (put (value m) k v) (minimize_eq_proof Bool.bool_dec (sorted_put _ _ _ (_value_ok m))) in
    let wrapped_remove m k := Build_rep (remove (value m) k) (minimize_eq_proof Bool.bool_dec (sorted_remove _ _ (_value_ok m))) in
    {|
    map.rep := rep;
    map.empty := Build_rep nil eq_refl;
    map.get m k := lookup (value m) k;
    map.put := wrapped_put;
    map.remove := wrapped_remove;
    map.fold R f r0 m := List.fold_right (fun '(k, v) r => f r k v) r0 (value m);
  |}.

  Lemma eq_value {x y : rep} : value x = value y -> x = y.
  Proof using.
    cbv [value]; destruct x as [x px], y as [y py].
    intro; subst y.
    apply f_equal, Eqdep_dec.UIP_dec; decide equality.
  Qed.

  Global Instance map_ok : map.ok map.
  Proof.
    split.
    { intros [l1 ST1] [l2 ST2] F.
      apply eq_value; unfold map.get, map in *; cbn [value] in *.
      revert ST1 l2 ST2 F.
      induction l1; intros.
      - destruct l2 as [|[k v] t2]. 1: reflexivity.
        specialize (F k). rewrite lookup_cons in F. rewrite eqb_refl in F. discriminate F.
      - destruct a as [k1 v1].
        destruct l2 as [|[k2 v2] l2].
        + specialize (F k1). cbv [lookup] in F. simpl in F. rewrite eqb_refl in F. discriminate.
        + setoid_rewrite lookup_cons in F.
          apply sorted_cons in ST1. destruct ST1 as [ST1 [N1 M1]].
          apply sorted_cons in ST2. destruct ST2 as [ST2 [N2 M2]].
          specialize (IHl1 ST1 _ ST2).
          destruct (eqb k1 k2) eqn: E12.
          * rewrite eqb_true in E12. subst.
            specialize (F k2) as F2. rewrite eqb_refl in F2.
            apply Option.eq_of_eq_Some in F2. subst.
            f_equal.
            eapply IHl1.
            simpl. intros.
            specialize (F k).
            destruct (eqb k k2) eqn: E2; try rewrite eqb_true in E2; congruence.
          * exfalso.
            unfold eqb in F.
            apply Bool.andb_false_iff in E12. destruct E12 as [E12 | E12]; apply Bool.negb_false_iff in E12.
            -- specialize (F k1). rewrite E12, (@ltb_antirefl _ _ ok) in F.
               simpl in F.
               specialize M2 with (1 := E12). congruence.
            -- specialize (F k2). rewrite E12, (@ltb_antirefl _ _ ok) in F.
               simpl in F.
               specialize M1 with (1 := E12). congruence. }
    { intros; exact eq_refl. }
    {
      intros [l ST] k v.
      revert ST.
      simpl.
      induction l; intros; simpl.
      - rewrite lookup_cons. rewrite eqb_refl. reflexivity.
      - destruct a as [k1 v1].
        apply sorted_cons in ST. destruct ST as [ST [N M]].
        destruct (ltb k k1) eqn:Hlt1.
        { rewrite lookup_cons. rewrite eqb_refl. reflexivity. }
        destruct (ltb k1 k) eqn:Hlt2.
        2: { rewrite lookup_cons. rewrite eqb_refl. reflexivity. }
        rewrite lookup_cons. unfold eqb. rewrite Hlt1. rewrite Hlt2. simpl. apply IHl. assumption.
    }
    {
      intros [l ST] k v' k'.
      rewrite <-eqb_false.
      simpl.
      revert ST v' k'.
      induction l; intros; simpl.
      - rewrite lookup_cons. rewrite H. reflexivity.
      - destruct a as [k1 v1].
        apply sorted_cons in ST. destruct ST as [ST [N M]].
        specialize (IHl ST).
        destruct (ltb k' k1) eqn:Hlt1.
        { rewrite lookup_cons. rewrite H. reflexivity. }
        destruct (ltb k1 k') eqn:Hlt2.
        { rewrite lookup_cons.
          destruct (eqb k k1) eqn:Heq.
          {
            rewrite lookup_cons.
            rewrite Heq.
            reflexivity.
          }
          rewrite IHl by assumption.
          rewrite lookup_cons.
          rewrite Heq.
          reflexivity.
        }
        assert (k1 = k') by (apply ltb_total; assumption).
        subst.
        do 2 rewrite lookup_cons.
        rewrite H.
        reflexivity.
    }
    {
      intros [l ST] k.
      simpl.
      revert ST.
      induction l; intros; simpl.
      - reflexivity.
      - destruct a as [k1 v1].
        apply sorted_cons in ST. destruct ST as [ST [N M]].
        destruct (ltb k k1) eqn:Hlt1.
        { specialize M with (1 := Hlt1). rewrite lookup_cons.
          replace (eqb k k1) with false by (unfold eqb; rewrite Hlt1; reflexivity).
          assumption.
        }
        destruct (ltb k1 k) eqn:Hlt2.
        {
          rewrite lookup_cons.
          replace (eqb k k1) with false.
          2: {
            unfold eqb.
            rewrite Hlt2.
            cbn.
            rewrite Bool.andb_false_r.
            reflexivity.
          }
          apply IHl.
          assumption.
        }
        assert (k = k1) by (apply ltb_total; assumption).
        subst.
        assumption.
    }
    {
      intros [l ST] k k'.
      rewrite <-eqb_false.
      simpl.
      revert ST k'.
      induction l; intros; simpl.
      - reflexivity.
      - destruct a as [k1 v1].
        apply sorted_cons in ST. destruct ST as [ST [N M]].
        specialize IHl with (1 := ST).
        destruct (ltb k' k1) eqn:Hlt1.
        { reflexivity. }
        destruct (ltb k1 k') eqn:Hlt2.
        { do 2 rewrite lookup_cons.
          destruct (eqb k k1).
          + reflexivity.
          + apply IHl. assumption.
        }
        rewrite lookup_cons.
        assert (k1 = k') by (apply ltb_total; assumption).
        subst.
        rewrite H.
        reflexivity.
    }
    { intros.
      simpl. remember (value m) as l. generalize dependent m.
      induction l; intros.
      - simpl.
        match type of H with
        | P ?m' r0 => replace m with m'; [exact H|]
        end.
        eapply eq_value. exact Heql.
      - simpl. destruct a as [k v].
        destruct m as [l' pl']. simpl in Heql.
        destruct l' as [|[k0 v0] l']. 1: discriminate.
        inversion Heql. subst l' v0 k0. clear Heql.
        destruct (sorted_cons _ _ _ pl') as [A [B _]].
        specialize (IHl {| value := l; _value_ok := A |} eq_refl).
        specialize H0 with (2 := IHl).
        cbn in H0. specialize (H0 k v).
        rewrite B in H0.
        specialize (H0 eq_refl).
        match goal with
        | H: P ?m' ?r |- P ?m ?r => replace m with m'; [exact H|]
        end.
        eapply eq_value. simpl.
        destruct l as [|[k0 v0] l]. 1: reflexivity.
        simpl in pl'|-*. apply Bool.andb_true_iff in pl'. destruct pl' as [C D].
        rewrite C.
        reflexivity. }
    { intros.
      simpl. remember (value m) as l. generalize dependent m.
      induction l; intros.
      - simpl. assumption.
      - simpl. destruct a as [k v].
        destruct m as [l' pl']. simpl in Heql.
        destruct l' as [|[k0 v0] l']. 1: discriminate.
        inversion Heql. subst l' v0 k0. clear Heql.
        destruct (sorted_cons _ _ _ pl') as [HA [HB _]].
        specialize (IHl {| value := l; _value_ok := HA |} eq_refl).
        eapply H. exact IHl. }
  Qed.
End SortedList.
Arguments map : clear implicits.


Require Import TypeSyntax.
Require Import Constraint.
Require Import MSetPositive.

Lemma denote_constraint_nil:
    denote_constraints nil <-> True.
Proof.
    split; auto; intro H; clear H.
    intros rho_den X_den.
    rewrite Forall_forall.
    intros x H; inversion H.
Qed.

Lemma denote_constraint_id_l:
    forall C,
        denote_constraints C <-> denote_constraints (nil ++ C).
Proof.  tauto.  Qed.

Lemma denote_constraint_id_r:
    forall C,
        denote_constraints C
        <->
        denote_constraints (C  ++ nil).
Proof.
    intro C; rewrite <- app_nil_end; tauto.
Qed.

Ltac solve_constr_weak :=
    unfold denote_constraints;
    intros C C' H rho_den X_den;
    specialize (H rho_den X_den);
    rewrite Forall_forall in *;
    intuition.

Lemma denote_constraint_weak_l:
    forall C C',
        denote_constraints (C ++ C') ->
        denote_constraints C.
Proof. solve_constr_weak.  Qed.

Lemma denote_constraint_weak_r:
    forall C C',
        denote_constraints (C ++ C') ->
        denote_constraints C'.
Proof. solve_constr_weak. Qed.

Hint Resolve denote_constraint_weak_l : strengthen.
Hint Resolve denote_constraint_weak_r : strengthen.

Lemma denote_constraint_commute:
    forall C1 C2,
        denote_constraints (C1 ++ C2) <->
        denote_constraints (C2 ++ C1).
Proof.
    unfold denote_constraints.
    intros C1 C2; split; intros H rho_den X_den;
    specialize (H rho_den X_den);
    rewrite Forall_forall in *;
    intro x; specialize (H x);
    rewrite in_app_iff in *;
    tauto.
Qed.
Hint Rewrite denote_constraint_commute.

Lemma constraints_join:
    forall C C',
        denote_constraints C ->
        denote_constraints C' ->
        denote_constraints (C ++ C').
Proof.
    unfold denote_constraints.
    intros C C' H1 H2 rho_den X_den.
    specialize (H1 rho_den X_den).
    specialize (H2 rho_den X_den).
    rewrite Forall_forall in *.
    intros x; specialize (H1 x); specialize (H2 x).
    rewrite in_app_iff; tauto.
Qed.

Lemma lemma_4_7:
    forall C C1 C2,
        (denote_constraints C -> denote_constraints C1) ->
        (denote_constraints C -> denote_constraints C2) ->
        (denote_constraints C -> denote_constraints (C1 ++ C2)).
Proof.
    Local Hint Resolve constraints_join.
    auto.
Qed.


(*
 * Module: Thread
 *
 * Description:
 *  This module defines an SVA Thread that is used in the small-step semantics.
 *
 * Note:
 *  Some of the code for the ThreadList comes from "Software Foundations" by
 *  Benjamin Pierce et. al.
 *)

(* Load Coq Standard Library modules *)
Require Import Arith.
Require Import Bool.
Require Import List.

(* Load SVA Library Modules *)
Require Export IC.

(*
 * Define an SVA thread which includes the following fields:
 *
 *  o A boolean flag indicating whether the state can be swapped on to the CPU
 *  o A program counter value
 *  o A stack of interrupt contexts for interrupts
 *  o A stack of interrupt contexts for saving interrupt contexts
 *)
Inductive SVAThread : Type :=
  | Thread : bool ->
             nat ->
             ICStack ->
             ICStack ->
             SVAThread.
Definition emptyThread := Thread false 0 nil nil.

(*
 * Define a set of SVAThreads.
 *)
Definition ThreadList := list SVAThread.
Definition emptyTL := nil : list SVAThread.
Definition getThread (id : nat) (t : ThreadList) := nth id t emptyThread.
Fixpoint updateThread (id:nat) (thread:SVAThread) (tl:ThreadList) : ThreadList :=
  match tl with
  | nil => nil
  | h :: t =>
    match id with
    | O => thread :: t
    | S n' => h :: updateThread n' thread t
    end
  end.

Definition getThreadPC (t : SVAThread) :=
  match t with
  | Thread valid PC stack istack => PC
end.

Definition canThreadSwap (t : SVAThread) :=
  match t with
  | Thread canSwap PC stack istack => canSwap
end.

Definition getThreadICL (t : SVAThread) :=
  match t with
  | Thread canSwap PC stack istack => stack
  end.

Definition getThreadSICL (t : SVAThread) :=
  match t with
  | Thread canSwap PC stack istack => istack
  end.

Definition getThreadICList (id : nat) (tl : ThreadList) :=
  getThreadICL (getThread id tl).

Definition getThreadSICList (id : nat) (tl : ThreadList) :=
  getThreadSICL (getThread id tl).

Definition threadOnCPU (newpc : nat) (t : SVAThread) :=
  match t with
  | Thread canSwap PC stack istack => Thread true newpc stack istack
end.

Definition threadOffCPU (t : SVAThread) :=
  match t with
  | Thread canSwap PC stack istack => Thread false 0 stack istack
end.

Definition pushSIC (tid : nat) (tl : ThreadList) :=
  updateThread  tid
                (Thread
                  false
                  (getThreadPC (getThread tid tl))
                  (getThreadICList tid tl)
                  (push
                    (itop (getThreadICList tid tl))
                    (getThreadSICList tid tl)))
                tl.

Definition popSIC (tid : nat) (tl : ThreadList) :=
  updateThread  tid
                (Thread
                  false
                  (getThreadPC (getThread tid tl))
                  (push
                    (itop (getThreadSICList tid tl))
                    (pop (getThreadICList tid tl)))
                  (pop (getThreadSICList tid tl)))
                tl.

Definition pushIC (Reg PC SP: nat) (tid : nat) (tl : ThreadList) :=
  updateThread  tid
                (Thread
                  false
                  (getThreadPC (getThread tid tl))
                  (push (IC Reg PC SP 0) (pop (getThreadICList tid tl)))
                  (getThreadSICList tid tl))
                tl.
(*
 * Theorem: updateMaintainListLength
 *
 * Description:
 *  Prove that updating an element in a thread list does not modify
 *  its length.
 *)
Theorem updateMaintainsListLength: forall (tid : nat) (t :SVAThread) (tl :ThreadList),
length tl = length (updateThread tid t tl).
Proof.
intros.
generalize dependent tid.
induction tl.

(* Case 1: Base case: empty list *)
intros.
simpl.
unfold updateThread.
destruct tid.
auto.
auto.

(* Case 2: Induction case: non-empty thread list *)
intros.
simpl.
destruct tid.

unfold updateThread.
simpl.
auto.

unfold updateThread.
simpl.
auto.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.priority prosa.classic.model.suspension.
Require Import prosa.classic.model.schedule.uni.susp.schedule.
Require Import prosa.classic.model.schedule.uni.transformation.construction.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.

(* In this file, we propose a reduction that converts a suspension-aware
   schedule to another suspension-aware schedule where the cost of a certain
   job is inflated and its response time does not decrease. *)
Module SustainabilitySingleCost.

  Import ScheduleWithSuspensions Suspension Priority ScheduleConstruction.

  Section Reduction.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.

    (** Basic Setup & Setting*)

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and assume any (schedule-independent) JLDP policy. *)
    Variable higher_eq_priority: JLDP_policy Job.

    (* Next, consider any suspension-aware schedule of the arrival sequence... *)
    Variable sched_susp: schedule Job.

    (* ...and the associated job suspension times. *)
    Variable job_suspension_duration: job_suspension Job.

    (** Definition of the Reduction *)

    (* Now we proceed with the reduction. Let j be the job to be analyzed. *)
    Variable j: Job.

    (* Next, consider any job cost inflation that does not decrease the cost of job j
       and that preserves the cost of the remaining jobs. *)
    Variable inflated_job_cost: Job -> time.

    (** Schedule Construction *)

    (* We are going to construct a new schedule that copies the original suspension-aware
       schedule and tries to preserve the service received by job j, until the time when
       it completes in the original schedule. *)
    Section ScheduleConstruction.

      (* First, we define the schedule construction function. *)
      Section ConstructionStep.

        (* For any time t, suppose that we have generated the schedule prefix in the
           interval [0, t). Then, we must define what should be scheduled at time t. *)
        Variable sched_prefix: schedule Job.
        Variable t: time.

        (* For simplicity, let's define some local names. *)
        Let job_is_pending := pending job_arrival inflated_job_cost sched_prefix.
        Let job_is_suspended :=
          suspended_at job_arrival inflated_job_cost job_suspension_duration sched_prefix.
        Let actual_job_arrivals_up_to := jobs_arrived_up_to arr_seq.

        (* Recall that a job is ready in the new schedule iff it is pending and not suspended. *)
        Let job_is_ready j t := job_is_pending j t && ~~ job_is_suspended j t.

        (* Then, consider the list of ready jobs at time t in the new schedule. *)
        Definition ready_jobs :=
          [seq j_other <- actual_job_arrivals_up_to t | job_is_ready j_other t].

        (* From the list of ready jobs, we take one of the (possibly many)
           highest-priority jobs, or None, in case there are no ready jobs. *)
        Definition highest_priority_job := seq_min (higher_eq_priority t) ready_jobs.

        (* Then, we construct the new schedule at time t as follows.
           a) If the currently scheduled job in sched_susp is ready to execute in the new schedule
              and has highest priority, pick that job.
           b) Else, pick one of the highest priority ready jobs in the new schedule. *)
        Definition build_schedule : option Job :=
          if highest_priority_job is Some j_hp then
            if sched_susp t is Some j_in_susp then
              if job_is_ready j_in_susp t && higher_eq_priority t j_in_susp j_hp then
                Some j_in_susp
              else
                Some j_hp
            else Some j_hp
          else None.

      End ConstructionStep.

      (* To conclude, starting from the empty schedule, ...*)
      Let empty_schedule : schedule Job := fun t => None.

      (* ...we use the recursive definition above to construct the new schedule. *)
      Definition sched_susp_highercost :=
        build_schedule_from_prefixes build_schedule empty_schedule.

    End ScheduleConstruction.

  End Reduction.

End SustainabilitySingleCost.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Export CoRN.reals.fast.CRArith.
Require Import CoRN.reals.fast.CRIR.
Require Import CoRN.reals.Q_in_CReals.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.reals.fast.CRarctan_small.
Require Import CoRN.transc.MoreArcTan.
Require Import CoRN.tactics.CornTac.
Require Import CoRN.stdlib_omissions.Q.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Set Implicit Arguments.

Local Open Scope Q_scope.
Local Open Scope uc_scope.

Opaque inj_Q CR.

Section Pi.

(**
** Pi (alternate)
(Please import CRpi instead)

This version is slower to compute than CRpi_fast; however it is faster to
compile.

Pi is defined as

68*arctan(1/23) + 32*arctan(1/182) + 40*arctan(1/5118) + 20*arctan(1/6072).
*)

Lemma small_per_23 : (-(1#1) < 1#23 < 1)%Q.
Proof. split; reflexivity. Qed.

Lemma small_per_182 : (-(1#1) < 1#182 < 1)%Q.
Proof. split; reflexivity. Qed.

Lemma small_per_5118 : (-(1#1) < 1#5118 < 1)%Q.
Proof. split; reflexivity. Qed.

Lemma small_per_6072 : (-(1#1) < 1#6072 < 1)%Q.
Proof. split; reflexivity. Qed.

Definition r_pi (r:Q) : CR :=
((scale (68%Z*r) (rational_arctan_small (widen_interval small_per_23)) +
  scale (32%Z*r) (rational_arctan_small (widen_interval small_per_182))) +
 (scale (40%Z*r) (rational_arctan_small (widen_interval small_per_5118)) +
  scale (20%Z*r) (rational_arctan_small (widen_interval small_per_6072))))%CR.

(** To prove that pi is is correct we repeatedly use the arctan sum law.
The problem is that the arctan sum law only works for input between -1
and 1.  We use reflect to show that our use of arctan sum law always
satifies this restriction. *)
Let f (a b:Q) : Q :=
 let (x,y) := a in
 let (z,w) := b in
 Qred ((x*w + y*z)%Z/(y*w-x*z)%Z).

Lemma f_char : forall a b, f a b == (a+b)/(1-a*b).
Proof.
 intros [x y] [w z].
 unfold f.
 rewrite -> Qred_correct.
 destruct (Z.eq_dec (y*z) (x*w)) as [H|H].
  unfold Qmult.
  simpl ((Qnum (x # y) * Qnum (w # z) # Qden (x # y) * Qden (w # z))).
  repeat rewrite <- H.
  replace (y * z - y * z)%Z with 0%Z by ring.
  setoid_replace (1-(y * z # y * z)) with 0.
   change ((x * z + y * w)%Z * 0 == ((x # y) + (w # z)) * 0).
   ring.
  rewrite -> (Qmake_Qdiv (y*z)).
  change (1 - (y * z)%positive / (y * z)%positive == 0).
  field; discriminate.
 unfold Zminus.
 repeat rewrite -> injz_plus.
 change (((x * Zpos z) + (Zpos y * w)) / (Zpos y * Zpos z - x * w) == ((x # y) + (w # z)) / (1 - (x #y)*(w # z))).
 repeat rewrite -> Qmake_Qdiv.
 field.
 repeat split; try discriminate.
 cut (~(y * z)%Z == (x * w)%Z).
  intros X Y.
  apply X.
  replace RHS with ((x * w)%Z + 0) by simpl; ring.
  rewrite <- Y.
  change ((y * z) == (x * w) + (y * z - x * w)).
  ring.
 intros X; apply H.
 unfold Qeq in X.
 simpl in X.
 rewrite Pmult_1_r in X.
 change  ((y * z)%Z = (x * w * 1)%Z) in X.
 rewrite X.
 ring.
Qed.

Lemma ArcTan_plus_ArcTan_Q : forall x y, -(1) <= x <= 1 -> -(1) <= y <= 1 -> ~1-x*y==0 ->
 (ArcTan (inj_Q _ x)[+]ArcTan (inj_Q _ y)[=]ArcTan (inj_Q _ (f x y))).
Proof.
 intros x y [Hx0 Hx1] [Hy0 Hy1] H.
 assert (X:forall z, -(1) <= z -> [--][1][<=]inj_Q IR z).
  intros z Hz.
  stepl ((inj_Q IR (-(1)))).
   apply inj_Q_leEq; assumption.
  eapply eq_transitive.
   apply (inj_Q_inv IR (1)).
  apply un_op_wd_unfolded.
  rstepr (nring 1:IR).
  apply (inj_Q_nring IR 1).
 assert (X0:forall z, z <= 1 -> inj_Q IR z[<=][1]).
  intros z Hz.
  stepr ((inj_Q IR ((1)))).
   apply inj_Q_leEq; assumption.
  rstepr (nring 1:IR).
  apply (inj_Q_nring IR 1).
 assert ([1][-](inj_Q IR x)[*](inj_Q IR y)[#][0]).
  stepl (inj_Q IR (1[-]x[*]y)).
   (stepr (inj_Q IR [0]); [| now apply (inj_Q_nring IR 0)]).
   apply inj_Q_ap; assumption.
  eapply eq_transitive.
   apply inj_Q_minus.
  apply bin_op_wd_unfolded.
   rstepr (nring 1:IR); apply (inj_Q_nring IR 1).
  apply un_op_wd_unfolded.
  apply inj_Q_mult.
 apply eq_transitive with (ArcTan (inj_Q IR x[+]inj_Q IR y[/]([1][-]inj_Q IR x[*]inj_Q IR y)[//]X1)).
  apply ArcTan_plus_ArcTan; first [apply X; assumption |apply X0; assumption].
 apply ArcTan_wd.
 stepl (inj_Q IR ((x[+]y)/([1][-]x*y))).
  apply inj_Q_wd.
  simpl.
  symmetry.
  apply f_char.
 assert (H0:(inj_Q IR ([1][-]x * y))[#][0]).
  (stepr (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]).
  apply inj_Q_ap; assumption.
 apply eq_transitive with (inj_Q IR (x[+]y)[/]inj_Q IR ([1][-]x * y)[//]H0).
  apply (inj_Q_div).
 apply div_wd.
  apply inj_Q_plus.
 eapply eq_transitive.
  apply inj_Q_minus.
 apply bin_op_wd_unfolded.
  rstepr (nring 1:IR).
  apply (inj_Q_nring IR 1).
 apply un_op_wd_unfolded.
 apply inj_Q_mult.
Qed.

Definition ArcTan_multiple : forall x, -(1) <= x <= 1 -> forall n, {True} + {(nring n)[*]ArcTan (inj_Q _ x)[=]ArcTan (inj_Q _ (iter_nat n _ (f x) 0))}.
Proof.
 intros x Hx.
 induction n.
  right.
  abstract ( rstepl ([0]:IR); (stepl (ArcTan [0]); [| now apply ArcTan_zero]); apply ArcTan_wd;
    apply eq_symmetric; apply (inj_Q_nring IR 0)).
 simpl.
 destruct (IHn) as [H|H].
  left; constructor.
 set (y:=(iter_nat n Q (f x) 0)) in *.
 destruct (Qlt_le_dec_fast 1 y) as [_|Y0].
  left; constructor.
 destruct (Qlt_le_dec_fast y (-(1))) as [_|Y1].
  left; constructor.
 destruct (Qeq_dec (1-x*y) 0) as [_|Y2].
  left; constructor.
 right.
 abstract ( rstepl (ArcTan (inj_Q IR x)[+](nring n[*]ArcTan (inj_Q IR x))); csetoid_rewrite H;
   apply ArcTan_plus_ArcTan_Q; try assumption; split; assumption).
Defined.

Lemma reflect_right : forall A B (x:{A}+{B}), (match x with left _ => False | right _ => True end) -> B.
Proof.
 intros A B x.
 elim x.
  contradiction.
 trivial.
Qed.

Lemma Pi_Formula :
(((nring 17)[*]ArcTan (inj_Q IR (1 /  23%Z))[+]
  (nring  8)[*]ArcTan (inj_Q IR (1 / 182%Z))[+]
  (nring 10)[*]ArcTan (inj_Q IR (1 / 5118%Z))[+]
  (nring 5)[*]ArcTan (inj_Q IR (1 / 6072%Z)))[=]
 Pi[/]FourNZ).
Proof.
 assert (H0:-(1) <= (1/(23%Z)) <= 1).
  split; discriminate.
 assert (H1:-(1) <= (1/(182%Z)) <= 1).
  split; discriminate.
 assert (H2:-(1) <= (1/(5118%Z)) <= 1).
  split; discriminate.
 assert (H3:-(1) <= (1/(6072%Z)) <= 1).
  split; discriminate.
 set (y0:=(iter_nat 17 _ (f (1/23%Z)) 0)).
 set (y1:=(iter_nat 8 _ (f (1/182%Z)) 0)).
 set (y2:=(iter_nat 10 _ (f (1/5118%Z)) 0)).
 set (y3:=(iter_nat 5 _ (f (1/6072%Z)) 0)).
 rstepl (nring 17[*]ArcTan (inj_Q IR (1 / 23%Z))[+]
   nring 8[*]ArcTan (inj_Q IR (1 / 182%Z))[+]
     (nring 10[*]ArcTan (inj_Q IR (1 / 5118%Z))[+]
       nring 5[*]ArcTan (inj_Q IR (1 / 6072%Z)))).
 csetoid_replace ((nring 17)[*]ArcTan (inj_Q IR (1 / 23%Z))) (ArcTan (inj_Q IR y0));
   [|apply (reflect_right (ArcTan_multiple H0 17)); vm_compute; constructor].
 csetoid_replace ((nring 8)[*]ArcTan (inj_Q IR (1 / 182%Z))) (ArcTan (inj_Q IR y1));
   [|apply (reflect_right (ArcTan_multiple H1 8)); vm_compute; constructor].
 csetoid_replace ((nring 10)[*]ArcTan (inj_Q IR (1 / 5118%Z))) (ArcTan (inj_Q IR y2));
   [|apply (reflect_right (ArcTan_multiple H2 10)); vm_compute; constructor].
 csetoid_replace ((nring 5)[*]ArcTan (inj_Q IR (1 / 6072%Z))) (ArcTan (inj_Q IR y3));
   [|apply (reflect_right (ArcTan_multiple H3 5)); vm_compute; constructor].
 vm_compute in y0.
 vm_compute in y1.
 vm_compute in y2.
 vm_compute in y3.
 csetoid_replace (ArcTan (inj_Q IR y0)[+]ArcTan (inj_Q IR y1)) (ArcTan (inj_Q IR (f y0 y1)));
   [|apply ArcTan_plus_ArcTan_Q; try split; vm_compute; discriminate].
 csetoid_replace (ArcTan (inj_Q IR y2)[+]ArcTan (inj_Q IR y3)) (ArcTan (inj_Q IR (f y2 y3)));
   [|apply ArcTan_plus_ArcTan_Q; try split; vm_compute; discriminate].
 set (z0 := (f y0 y1)).
 set (z1 := (f y2 y3)).
 vm_compute in z0.
 vm_compute in z1.
 csetoid_replace (ArcTan (inj_Q IR z0)[+]ArcTan (inj_Q IR z1)) (ArcTan (inj_Q IR (f z0 z1)));
   [|apply ArcTan_plus_ArcTan_Q; try split; vm_compute; discriminate].
 set (z3:= (f z0 z1)).
 vm_compute in z3.
 eapply eq_transitive;[|apply ArcTan_one].
 apply ArcTan_wd.
 rstepr (nring 1:IR).
 apply (inj_Q_nring IR 1).
Qed.

Lemma r_pi_correct : forall r,
 (r_pi r == IRasCR ((inj_Q IR r)[*]Pi))%CR.
Proof.
 intros r.
 unfold r_pi.
 repeat rewrite <- (CRmult_scale).
 setoid_replace ((68*r)) with ((4*r*17)) by (simpl; ring).
 setoid_replace (32*r) with (4*r*8) by (simpl; ring).
 setoid_replace (40*r) with (4*r*10) by (simpl; ring).
 setoid_replace (20*r) with (4*r*5) by (simpl; ring).
 repeat rewrite <- CRmult_Qmult.
 transitivity ('4 * 'r *(' 17 * rational_arctan_small (widen_interval small_per_23) +
   ' 8 * rational_arctan_small (widen_interval small_per_182) + (' 10 * rational_arctan_small (widen_interval small_per_5118) +
     ' 5 * rational_arctan_small (widen_interval small_per_6072))))%CR.
  ring.
 repeat rewrite rational_arctan_small_correct.
 repeat rewrite <- IR_inj_Q_as_CR.
 repeat (rewrite <- IR_mult_as_CR || rewrite <- IR_plus_as_CR).
 apply IRasCR_wd.
 rstepr (Four[*]inj_Q IR r[*]Pi[/]FourNZ).
 apply mult_wd.
  apply mult_wdl.
  apply (inj_Q_nring IR 4).
 eapply eq_transitive;[|apply Pi_Formula].
 rstepr (nring 17[*]ArcTan (inj_Q IR (1 / 23%Z))[+]
   nring 8[*]ArcTan (inj_Q IR (1 / 182%Z))[+]
     (nring 10[*]ArcTan (inj_Q IR (1 / 5118%Z))[+]
       nring 5[*]ArcTan (inj_Q IR (1 / 6072%Z)))).
 repeat apply bin_op_wd_unfolded; try apply eq_reflexive.
    apply (inj_Q_nring IR 17).
   apply (inj_Q_nring IR 8).
  apply (inj_Q_nring IR 10).
 apply (inj_Q_nring IR 5).
Qed.

Definition CRpi : CR := (r_pi 1).

Lemma CRpi_correct : (IRasCR Pi == CRpi)%CR.
Proof.
 unfold CRpi.
 rewrite -> r_pi_correct.
 apply IRasCR_wd.
 rstepl ((nring 1)[*]Pi).
 apply mult_wdl.
 apply eq_symmetric.
 apply (inj_Q_nring IR 1).
Qed.

End Pi.
(* begin hide *)
#[global]
Hint Rewrite CRpi_correct : IRtoCR.
(* end hide *)


(* $Id: FunctSeries.v,v 1.17 2003/03/13 12:06:19 lcf Exp $ *)

Require Export FunctSequence.
Require Export Series.

Section Definitions.

(* Tex_Prose
\chapter{Series of Functions}

We now turn our attention to series of functions.  Like it was already the case for sequences, we will mainly rewrite the results we proved for series of real numbers in a different way.

\begin{convention} Throughout this section:
\begin{itemize}
\item \verb!a! and \verb!b! will be real numbers and the interval $[a,b]$ will be denoted by \verb!I!;
\item \verb!f, g! and \verb!h! will denote sequences of \emph{continuous} functions;
\item \verb!F, G! and \verb!H! will denote continuous functions.
\end{itemize}
\end{convention}

\section{Definitions}

As before, we will consider only sequences of continuous functions defined in a compact interval.  For this, partial Sums are defined and convergence is simply the convergence of the sequence of partial Sums.
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variable f:nat->PartIR.

(* Begin_Tex_Verb *)
Definition fun_seq_part_sum [n:nat] := (FSum0 n f).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma fun_seq_part_sum_cont : ((n:nat)(Continuous_I Hab (f n)))->
  (n:nat)(Continuous_I Hab (fun_seq_part_sum n)).
(* End_Tex_Verb *)
Intros; Unfold fun_seq_part_sum.
Contin.
Qed.

(* Begin_Tex_Verb *)
Definition fun_series_convergent := {contf:? &
  (Cauchy_fun_seq ?? Hab
    fun_seq_part_sum (fun_seq_part_sum_cont contf))}.
(* End_Tex_Verb *)

(* Tex_Prose
For what comes up next we need to know that the convergence of a series of functions implies pointwise convergence of the corresponding real number series.
*)

(* Begin_Tex_Verb *)
Lemma fun_series_conv_imp_conv : fun_series_convergent->
  (x:IR)(I x)->(Hx:?)(convergent [n:nat]((f n) x (Hx n))).
(* End_Tex_Verb *)
Intros.
Red.
Red.
Intros e He.
Elim H; Intros incF convF.
Elim (convF ? He).
Intros N HN.
Exists N; Intros.
Apply AbsIR_imp_AbsSmall.
Simpl in HN.
EApply leEq_wdl.
Apply (HN m N H1 (le_n N) x H0).
Apply AbsIR_wd.
Apply cg_minus_wd; Unfold seq_part_sum; Apply Sum0_wd; Intros; Rational.
Qed.

(* Tex_Prose
We then define the Sum of the series as being the pointwise Sum of the corresponding series.
*)

(* Begin_Tex_Verb *)
Hypothesis H:fun_series_convergent.
(* End_Tex_Verb *)

Local contf:=(ProjS1 H).
Local incf:=[n:nat](contin_imp_inc ???? (contf n)).

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_strext : (x,y:IR)(Hx:(I x))(Hy:(I y))
  (((series_sum ?
    (fun_series_conv_imp_conv H x Hx [n:nat](incf n x Hx)))[#]
  (series_sum ?
    (fun_series_conv_imp_conv H y Hy [n:nat](incf n y Hy))))->
  (x[#]y)).
(* End_Tex_Verb *)
Intros.
Unfold series_sum in H0.
Elim (Lim_strext ?? H0); Intros m Hm.
Simpl in Hm; Unfold seq_part_sum in Hm.
Elim (Sum0_strext ???? Hm); Intros i H1 H2.
Exact (pfstrx ?????? H2).
Qed.

(* Begin_Tex_Verb *)
Definition Fun_Series_Sum : PartIR.
(* End_Tex_Verb *)
Apply Build_PartFunct with pfpfun:=[x:IR][Hx:(I x)](series_sum ? (fun_series_conv_imp_conv H x Hx [n:nat](incf n x Hx))).
Unfold I; Apply compact_wd.
Exact Fun_Series_Sum_strext.
Defined.

End Definitions.

Implicits Fun_Series_Sum [1 2 3 4].

Hints Resolve fun_seq_part_sum_cont : continuous.

Section More_Definitions.

Variables a,b:IR.
Hypothesis Hab:a[<=]b.

Variable f:nat->PartIR.
(* Tex_Prose
A series can also be absolutely convergent.
*)

(* Begin_Tex_Verb *)
Definition fun_series_abs_convergent := (fun_series_convergent ?? Hab [n:nat](FAbs (f n))).
(* End_Tex_Verb *)

End More_Definitions.

Section Operations.

(* Tex_Prose
\section{Algebraic Properties}

All of these are analogous to the properties for series of real numbers, so we won't comment much about them.
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

(* Begin_Tex_Verb *)
Lemma fun_seq_part_sum_n :
  (f:nat->PartIR)(H':(n:nat)(Continuous_I Hab (f n)))
  (m,n:nat)(lt O n)->(le m n)->(Feq I
    (fun_seq_part_sum f n){-}(fun_seq_part_sum f m)
    (FSum m (pred n) f)).
(* End_Tex_Verb *)
Intros.
Unfold fun_seq_part_sum.
Apply eq_imp_Feq.
Unfold I; Apply contin_imp_inc; Contin.
Unfold I; Apply contin_imp_inc; Contin.
Intros; Simpl.
Unfold Sum Sum1.
Rewrite (S_pred n O); Auto.
Apply cg_minus_wd; Apply Sum0_wd; Intros; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_fun_const_series : (x:nat->IR)(convergent x)->
  (fun_series_convergent ?? Hab [n:nat]{-C-}(x n)).
(* End_Tex_Verb *)
Intros.
Red.
Exists [n:nat](Continuous_I_const ?? Hab (x n)).
Apply Cauchy_fun_seq2_seq.
Red; Intros e He.
Elim (H e He); Intros N HN.
Exists N; Intros.
Simpl.
Apply AbsSmall_imp_AbsIR.
Apply AbsSmall_wd_rht_unfolded with (seq_part_sum x m)[-](seq_part_sum x N).
Apply HN; Assumption.
Unfold seq_part_sum; Simpl.
Apply cg_minus_wd; Apply Sum0_wd; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_const_series_sum : (y:nat->IR)(H:(convergent y))
  (H':(fun_series_convergent ?? Hab [n:nat]{-C-}(y n)))
  (x:IR)(Hx:(I x))((Fun_Series_Sum H') x Hx)[=]
    (series_sum ? H).
(* End_Tex_Verb *)
Intros.
Simpl.
Apply series_sum_wd.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_zero_fun_series :
  (fun_series_convergent ?? Hab [n:nat]{-C-}Zero).
(* End_Tex_Verb *)
Apply conv_fun_const_series with x:=[n:nat](Zero::IR).
Apply conv_zero_series.
Qed.

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_zero :
  (H:(fun_series_convergent ?? Hab [n:nat]{-C-}Zero))
  (x:IR)(Hx:?)((Fun_Series_Sum H) x Hx)[=]Zero.
(* End_Tex_Verb *)
Intros.
Simpl.
Apply series_sum_zero.
Qed.

(* Begin_Tex_Verb *)
Variables f,g:nat->PartIR.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma fun_series_convergent_wd : ((n:nat)(Feq I (f n) (g n)))->
  (fun_series_convergent ?? Hab f)->
  (fun_series_convergent ?? Hab g).
(* End_Tex_Verb *)
Intros.
Red; Red in H0.
Elim H0; Intros contF convF.
Cut (n:nat)(Continuous_I Hab (g n)); Intros.
Exists H1.
Apply Cauchy_fun_seq_wd with (fun_seq_part_sum f) (fun_seq_part_sum_cont ???? contF).
2: Assumption.
Intros.
Apply eq_imp_Feq.
Apply contin_imp_inc; Contin.
Apply contin_imp_inc; Contin.
Intros; Simpl.
Apply Sum0_wd.
Intro; Elim (H i); Intros.
Inversion_clear a0; Auto.
Apply Continuous_I_wd with (f n); Auto.
Qed.

(* Begin_Tex_Verb *)
Hypothesis convF : (fun_series_convergent ?? Hab f).
Hypothesis convG : (fun_series_convergent ?? Hab g).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_wd' : ((n:nat)(Feq I (f n) (g n)))->
  (Feq I (Fun_Series_Sum convF) (Fun_Series_Sum convG)).
(* End_Tex_Verb *)
Intros.
Apply eq_imp_Feq.
Included.
Included.
Intros; Simpl.
Apply series_sum_wd.
Intro; Elim (H n); Intros.
Inversion_clear a0; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_fun_series_plus :
  (fun_series_convergent ?? Hab [n:nat](f n){+}(g n)).
(* End_Tex_Verb *)
Elim convF; Intros contF convF'.
Elim convG; Intros contG convG'.
LetTac H:=[n:nat](Continuous_I_plus ????? (contF n) (contG n)); Exists H.
Cut (n:nat)(Continuous_I Hab (fun_seq_part_sum f n){+}(fun_seq_part_sum g n)); [Intro | Contin].
Apply Cauchy_fun_seq_wd with f:=[n:nat](fun_seq_part_sum f n){+}(fun_seq_part_sum g n) contf:=H0.
2: EApply fun_Cauchy_prop_plus; Auto; [Apply convF' | Apply convG'].
Intros; Apply eq_imp_Feq.
Included.
Apply contin_imp_inc; Contin.
Intros; Simpl.
Apply eq_symmetric_unfolded; EApply eq_transitive_unfolded.
2: Apply Sum0_plus_Sum0.
Apply Sum0_wd; Intros; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_plus :
  (H:(fun_series_convergent ?? Hab [n:nat](f n){+}(g n)))
  (Feq I (Fun_Series_Sum H)
         (Fun_Series_Sum convF){+}(Fun_Series_Sum convG)).
(* End_Tex_Verb *)
Intros.
Apply eq_imp_Feq.
Included.
Included.
Intros; Simpl.
Elim convF; Intros contF convF'.
Elim convG; Intros contG convG'.
Cut (convergent
  [n:nat](pfpfun ? ? (contin_imp_inc ???? (contF n) x (ProjIR1 Hx')))[+](pfpfun ? ? (contin_imp_inc ???? (contG n) x (ProjIR2 Hx')))); Intros.
EApply eq_transitive_unfolded.
2: Apply series_sum_plus with
  x:=[n:nat](pfpfun ? ? (contin_imp_inc ???? (contF n) x (ProjIR1 Hx')))
  y:=[n:nat](pfpfun ? ? (contin_imp_inc ???? (contG n) x (ProjIR2 Hx')))
  H:=H1.
Apply series_sum_wd; Intro; Rational.
Red; Red; Intros.
Elim H; Intros cont H'.
Elim (H' ? H1); Intros N HN.
Exists N; Intros.
Apply AbsIR_imp_AbsSmall.
EApply leEq_wdl.
Apply (HN m N H2 (le_n N) x H0).
Apply AbsIR_wd; Unfold fun_seq_part_sum.
Simpl.
Unfold seq_part_sum; Apply cg_minus_wd; Apply Sum0_wd; Intros; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_fun_series_minus :
  (fun_series_convergent ?? Hab [n:nat](f n){-}(g n)).
(* End_Tex_Verb *)
Elim convF; Intros contF convF'.
Elim convG; Intros contG convG'.
LetTac H:=[n:nat](Continuous_I_minus ????? (contF n) (contG n)); Exists H.
Cut (n:nat)(Continuous_I Hab (fun_seq_part_sum f n){-}(fun_seq_part_sum g n)); [Intro | Contin].
Apply Cauchy_fun_seq_wd with f:=[n:nat](fun_seq_part_sum f n){-}(fun_seq_part_sum g n) contf:=H0.
2: EApply fun_Cauchy_prop_minus; Auto; [Apply convF' | Apply convG'].
Intros; Apply eq_imp_Feq.
Included.
Apply contin_imp_inc; Contin.
Intros; Simpl.
Apply eq_symmetric_unfolded.
Apply eq_transitive_unfolded with (Sum0 n [i:nat]((f i) x (ProjIR1 Hx i)))[+](Sum0 n [i:nat][--]((g i) x (ProjIR2 Hx i))).
EApply eq_transitive_unfolded.
2: Apply Sum0_plus_Sum0.
Apply Sum0_wd; Intros; Rational.
Unfold cg_minus.
Apply bin_op_wd_unfolded.
Algebra.
EApply eq_transitive_unfolded.
2: Apply inv_Sum0.
Apply Sum0_wd; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_minus :
  (H:(fun_series_convergent ?? Hab [n:nat](f n){-}(g n)))
  (Feq I (Fun_Series_Sum H)
         (Fun_Series_Sum convF){-}(Fun_Series_Sum convG)).
(* End_Tex_Verb *)
Intros.
Apply eq_imp_Feq.
Included.
Included.
Intros; Simpl.
Elim convF; Intros contF convF'.
Elim convG; Intros contG convG'.
Cut (convergent
  [n:nat](pfpfun ? ? (contin_imp_inc ???? (contF n) x (ProjIR1 Hx')))[-](pfpfun ? ? (contin_imp_inc ???? (contG n) x (ProjIR2 Hx')))); Intros.
Apply eq_transitive_unfolded with
  (series_sum ? (fun_series_conv_imp_conv ???? convF x (ProjIR1 Hx') [n:nat](contin_imp_inc ???? (contF n) x (ProjIR1 Hx'))))[-]
  (series_sum ? (fun_series_conv_imp_conv ???? convG x (ProjIR2 Hx') [n:nat](contin_imp_inc ???? (contG n) x (ProjIR2 Hx')))).
EApply eq_transitive_unfolded.
2: Apply series_sum_minus with
  x:=[n:nat](pfpfun ? ? (contin_imp_inc ???? (contF n) x (ProjIR1 Hx')))
  y:=[n:nat](pfpfun ? ? (contin_imp_inc ???? (contG n) x (ProjIR2 Hx')))
  H:=H1.
Apply series_sum_wd; Intro; Rational.
Apply cg_minus_wd; Apply series_sum_wd; Intro; Rational.
Red; Red; Intros.
Elim H; Intros cont H'.
Elim (H' ? H1); Intros N HN.
Exists N; Intros.
Apply AbsIR_imp_AbsSmall.
EApply leEq_wdl.
Apply (HN m N H2 (le_n N) x H0).
Apply AbsIR_wd; Unfold fun_seq_part_sum.
Simpl.
Unfold seq_part_sum; Apply cg_minus_wd; Apply Sum0_wd; Intros; Rational.
Qed.

(* Tex_Prose
\begin{convention} Let \verb!c:IR!.
\end{convention}
*)

Variable c:IR.
Variable H:PartIR.
Hypothesis contH:(Continuous_I Hab H).

(* Begin_Tex_Verb *)
Lemma conv_fun_series_mult_scal :
  (fun_series_convergent ?? Hab [n:nat]H{*}(f n)).
(* End_Tex_Verb *)
Elim convF; Intros contF convF'.
LetTac H':=[n:nat](Continuous_I_mult ????? contH (contF n)); Exists H'.
Cut (n:nat)(Continuous_I Hab (fun_seq_part_sum f n)); [Intro | Contin].
Cut (n:nat)(Continuous_I Hab H{*}(fun_seq_part_sum f n)); [Intro | Contin].
Unfold I; Apply Cauchy_fun_seq_wd with [n:nat]H{*}(fun_seq_part_sum f n) H1.
2: Apply fun_Cauchy_prop_mult with f:=[n:nat]H contf:=[n:nat]contH g:=(fun_seq_part_sum f) contg:=H0.
Intro; FEQ.
Apply contin_imp_inc; Contin.
Simpl.
Unfold seq_part_sum.
Apply eq_symmetric_unfolded.
EApply eq_transitive_unfolded.
2: Apply Sum0_comm_scal' with x:=[m:nat]((f m) x (ProjIR2 Hx m)).
Apply Sum0_wd; Intros; Rational.
Apply fun_Cauchy_prop_const.
Apply Cauchy_fun_seq_wd with f:=(fun_seq_part_sum f) contf:=(fun_seq_part_sum_cont ???? contF).
2: Assumption.
Intro; Apply Feq_reflexive; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_mult_scal :
  (H':(fun_series_convergent ?? Hab [n:nat]H{*}(f n)))
  (Feq I (Fun_Series_Sum H') H{*}(Fun_Series_Sum convF)).
(* End_Tex_Verb *)
Elim convF; Intros contF convF'.
Intros.
Unfold I; FEQ.
Cut (convergent [n:nat](Part H x (ProjIR1 Hx'))[*]((f n) x (contin_imp_inc ???? (contF n) ? (ProjIR2 Hx')))); Intros.
Apply eq_transitive_unfolded with
  (series_sum [n:nat](Part H x (ProjIR1 Hx'))[*]((f n) x (contin_imp_inc ???? (contF n) ? (ProjIR2 Hx'))) H1).
2: Simpl; Apply series_sum_mult_scal with x:=[n:nat]((f n) x (contin_imp_inc ???? (contF n) ? (ProjIR2 Hx'))).
Simpl; Unfold series_sum.
Apply Lim_wd'; Intros; Simpl.
Unfold seq_part_sum; Apply Sum0_wd; Intros; Rational.
Red; Red; Intros.
Elim H'; Intros H'' H'''.
Elim (H''' ? H1); Intros N HN.
Exists N; Intros.
Apply AbsIR_imp_AbsSmall.
EApply leEq_wdl.
Apply (HN m N H2 (le_n N) x Hx).
Apply AbsIR_wd; Simpl.
Unfold seq_part_sum; Apply cg_minus_wd; Apply Sum0_wd; Intros; Rational.
Qed.

End Operations.

Section More_Operations.

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variable f:nat->PartIR.
Hypothesis convF : (fun_series_convergent ?? Hab f).

(* Begin_Tex_Verb *)
Lemma conv_fun_series_inv :
  (fun_series_convergent ?? Hab [n:nat]{--}(f n)).
(* End_Tex_Verb *)
Elim convF; Intros contF convF'.
Exists [n:nat](Continuous_I_inv ???? (contF n)).
Cut (n:nat)(Continuous_I Hab {--}(fun_seq_part_sum f n)); Intros.
Apply Cauchy_fun_seq_wd with f:=[n:nat]{--}(fun_seq_part_sum f n) contf:=H.
2: Apply fun_Cauchy_prop_inv with (fun_seq_part_sum_cont ???? contF).
Intro; FEQ.
Apply contin_imp_inc; Contin.
Simpl; Unfold seq_part_sum.
Apply eq_symmetric_unfolded; EApply eq_transitive_unfolded.
2: Apply inv_Sum0.
Apply Sum0_wd; Intro; Rational.
Assumption.
Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_inv :
  (H:(fun_series_convergent ?? Hab [n:nat]{--}(f n)))
  (Feq I (Fun_Series_Sum H) {--}(Fun_Series_Sum convF)).
(* End_Tex_Verb *)
Intros.
FEQ.
Cut (convergent [n:nat][--]((f n) x (contin_imp_inc ???? (ProjS1 convF n) x Hx'))); Intros.
Simpl; Apply eq_transitive_unfolded with (series_sum ? H1).
2: Apply series_sum_inv with x:=[n:nat]((f n) x (contin_imp_inc ???? (ProjS1 convF n) x Hx')).
Unfold series_sum; Apply Lim_wd'; Intros; Simpl.
Unfold seq_part_sum; Apply Sum0_wd; Intros.
Rational.
Apply conv_series_inv with x:=[n:nat]((f n) x (contin_imp_inc ???? (ProjS1 convF n) x Hx')).
Apply fun_series_conv_imp_conv with Hab:=Hab Hx:=[n:nat](contin_imp_inc ???? (ProjS1 convF n) x Hx'); Assumption.
Qed.

End More_Operations.

Section Other_Results.

Variables a,b:IR.
Hypothesis Hab:a[<=]b.

Variable f:nat->PartIR.

Hypothesis convF:(fun_series_convergent a b Hab f).

(* Tex_Prose
The following relate the Sum series with the limit of the sequence of partial Sums; as a corollary we get the continuity of the Sum of the series.
*)

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_char' : (contf,H:?)(Feq (Compact Hab)
  (Fun_Series_Sum convF)
  (Cauchy_fun_seq_Lim ?? Hab (fun_seq_part_sum f) contf H)).
(* End_Tex_Verb *)
Intros.
FEQ.
Simpl; Unfold series_sum.
Apply Lim_wd'; Simpl; Intros.
Unfold seq_part_sum; Apply Sum0_wd; Intros; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_series_conv : (H,H':?)(conv_fun_seq' a b Hab
  (fun_seq_part_sum f) (Fun_Series_Sum convF) H H').
(* End_Tex_Verb *)
Intros.
Inversion_clear convF.
Apply conv_fun_seq'_wdr with
  contf:=(fun_seq_part_sum_cont ???? x)
  contF:=(Cauchy_cont_Lim ????? H0).
2: Apply Cauchy_conv_fun_seq'.
Apply Feq_symmetric; Apply Fun_Series_Sum_char'.
Qed.

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_cont :
  (Continuous_I Hab (Fun_Series_Sum convF)).
(* End_Tex_Verb *)
Intros.
Inversion_clear convF.
EApply Continuous_I_wd.
Apply Feq_symmetric; Apply (Fun_Series_Sum_char' [n:nat](fun_seq_part_sum_cont ???? x n) H).
Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_char : (Feq (Compact Hab)
  (Cauchy_fun_seq_Lim ?? Hab
    (fun_seq_part_sum f) ? (ProjS2 convF))
  (Fun_Series_Sum convF)).
(* End_Tex_Verb *)
Intros.
FEQ.
Simpl.
Unfold series_sum; Apply Lim_wd'.
Intro; Simpl.
Unfold seq_part_sum; Apply Sum0_wd; Intros; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Fun_Series_Sum_as_Lim : (Hf,H':?)(conv_fun_seq' ?? Hab
  (fun_seq_part_sum f) (Fun_Series_Sum convF) Hf H').
(* End_Tex_Verb *)
Intros.
Apply conv_fun_seq'_wdr with
  (fun_seq_part_sum_cont ???? (ProjS1 convF)) (Cauchy_fun_seq_Lim ????? (ProjS2 convF)) (Cauchy_cont_Lim ????? (ProjS2 convF)).
Apply Fun_Series_Sum_char.
Apply Cauchy_conv_fun_seq'.
Qed.

End Other_Results.

Hints Resolve Fun_Series_Sum_cont : continuous.

Section Convergence_Criteria.

(* Tex_Prose
\section{Convergence Criteria}

Most of the convergence criteria for series of real numbers carry over to series of real-valued functions, so again we just present them without comments.
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variable f:nat->PartIR.
Hypothesis contF : (n:nat)(Continuous_I Hab (f n)).

(* Begin_Tex_Verb *)
Lemma fun_str_comparison : (g:nat->PartIR)
  (fun_series_convergent ?? Hab g)->
  {k:nat | ((n:nat)(le k n)->(x:IR)((I x)->(Hx,Hx':?)
    (AbsIR ((f n) x Hx))[<=](Part (g n) x Hx')))}->
  (fun_series_convergent ?? Hab f).
(* End_Tex_Verb *)
LetTac H0:=contF.
Intros.
Elim H1; Intros k Hk.
Exists H0.
Apply Cauchy_fun_seq2_seq.
Red; Intros.
Elim H; Intros contG convG.
Cut {N:nat | (lt k N)/\((m:nat)(le N m)->(x:IR)(I x)->(Hx,Hx':?)
  (AbsSmall e (Part (fun_seq_part_sum g m) x Hx)[-](Part (fun_seq_part_sum g N) x Hx')))}; Intros.
Elim H3; Clear H3.
Intros N HN; Elim HN; Clear HN; Intros HN' HN.
Exists N; Intros.
LetTac H':=[n:nat](contin_imp_inc ???? (fun_seq_part_sum_cont ???? contG n)).
Apply leEq_transitive with (Part (fun_seq_part_sum g m) x (H' m x Hx))[-](Part (fun_seq_part_sum g N) x (H' N x Hx)).
Cut (n:nat)(included (Compact Hab) (Pred (FAbs (f n)))); Intros.
Cut (Pred (FSum N (pred m) [n:nat](FRestr (H4 n))) x); Intros.
Apply leEq_transitive with (Part (FSum N (pred m) [n:nat](FRestr (H4 n))) x H5).
Cut (Pred (FSum N (pred m) [n:nat](FRestr (contin_imp_inc ???? (H0 n)))) x); Intros.
Apply leEq_wdl with (AbsIR (Part (FSum N (pred m) [n:nat](FRestr (contin_imp_inc ???? (H0 n)))) x H6)).
Opaque Frestr.
Simpl.
Transparent Frestr.
EApply leEq_wdr.
Apply triangle_SumIR.
Rewrite <- (S_pred m k); Auto; Apply lt_le_trans with N; Auto.
Simpl; Apply Sum_wd; Intros; Apply AbsIR_wd; Rational.
Apply AbsIR_wd; Apply eq_symmetric_unfolded.
Cut (Pred ((fun_seq_part_sum f m){-}(fun_seq_part_sum f N)) x); Intros.
Opaque fun_seq_part_sum.
Apply eq_transitive_unfolded with (pfpfun ? ? H7).
Simpl; Rational.
Unfold Frestr.
Apply Feq_imp_eq with I.
Apply Feq_transitive with (FSum N (pred m) f).
Unfold I; Apply fun_seq_part_sum_n; Auto with arith.
Apply le_lt_trans with k; [Idtac | Apply lt_le_trans with N]; Auto with arith.
FEQ.
Unfold I; Apply contin_imp_inc; Contin.
Simpl.
Red; Intros; Auto.
Simpl.
Apply Sum_wd; Intros; Rational.
Auto.
Split; Simpl.
Apply (contin_imp_inc ???? (fun_seq_part_sum_cont ???? H0 m)); Auto.
Apply (contin_imp_inc ???? (fun_seq_part_sum_cont ???? H0 N)); Auto.
Simpl; Auto.
Cut (Pred (FSum N (pred m) g) x); Intros.
Apply leEq_wdr with (pfpfun ? ? H6).
Apply FSum_resp_leEq.
Rewrite <- (S_pred m k); Auto; Apply lt_le_trans with N; Auto.
Intros.
Simpl.
Apply Hk.
Apply le_trans with N; Auto with arith.
Simpl in HxF.
Apply (HxF O).
Cut (Pred ((fun_seq_part_sum g m){-}(fun_seq_part_sum g N)) x); Intros.
Apply eq_symmetric_unfolded.
Apply eq_transitive_unfolded with (pfpfun ? ? H7).
Simpl; Rational.
Apply Feq_imp_eq with I.
Unfold I; Apply fun_seq_part_sum_n; Auto with arith.
Apply le_lt_trans with k; [Idtac | Apply lt_le_trans with N]; Auto with arith.
Auto.
Split; Simpl.
Apply (contin_imp_inc ???? (fun_seq_part_sum_cont ???? contG m)); Auto.
Apply (contin_imp_inc ???? (fun_seq_part_sum_cont ???? contG N)); Auto.
Simpl; Intro; Apply (contin_imp_inc ???? (contG n)); Auto.
Simpl; Auto.
Unfold I; Simpl; Apply contin_imp_inc; Auto.
EApply leEq_transitive.
Apply leEq_AbsIR.
Apply AbsSmall_imp_AbsIR.
Apply HN; Assumption.
Elim (convG ? H2).
Intros N HN; Exists (S (max N k)).
Cut (le N (max N k)); [Intro | Apply le_max_l].
Cut (le k (max N k)); [Intro | Apply le_max_r].
Split.
Auto with arith.
Intros.
Apply AbsIR_imp_AbsSmall.
Cut (le N m); [Intro | Apply le_trans with (max N k); Auto with arith].
EApply leEq_wdl.
Transparent fun_seq_part_sum.
Simpl in Hx'.
Apply (HN m ? H7 (le_S ?? H3) x H6).
Opaque fun_seq_part_sum.
Apply AbsIR_wd; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_comparison : (g:nat->PartIR)
  (fun_series_convergent ?? Hab g)->
  ((n:nat)(x:IR)(I x)->(Hx,Hx':?)
    (AbsIR ((f n) x Hx))[<=]((g n) x Hx'))->
  (fun_series_convergent ?? Hab f).
(* End_Tex_Verb *)
Intros.
Apply fun_str_comparison with g; Auto.
Exists O; Intros; Apply H0; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma abs_imp_conv : (fun_series_abs_convergent ?? Hab f)->
  (fun_series_convergent ?? Hab f).
(* End_Tex_Verb *)
Intros.
Apply fun_comparison with [n:nat](FAbs (f n)).
Apply H.
Intros; Simpl; Apply eq_imp_leEq; Apply AbsIR_wd; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_ratio_test_conv : {N:nat & {c:IR &
  c[<]One | (Zero[<=]c) /\
  (x:IR)(I x)->(n:nat)(le N n)->(Hx,Hx':?)
    (AbsIR ((f (S n)) x Hx'))[<=]
      c[*](AbsIR ((f n) x Hx))}}->
  (fun_series_convergent ?? Hab f).
(* End_Tex_Verb *)
Intro.
Elim H; Clear H; Intros N H.
Elim H; Clear H; Intros c Hc1 H.
Elim H; Clear H; Intros H0c H.
Cut (x:IR)(I x)->(n:nat)(le N n)->(Hx,Hx':?)(AbsIR ((f n) x Hx'))[<=](AbsIR ((f N) x Hx))[*](c[^](minus n N)).
Intro.
Apply fun_str_comparison with [n:nat]((FAbs (f N)){*}({-C-} c[^](minus n N))).
2: Exists N; Simpl; Intros.
2: Simpl in H0; Apply H0; Auto with arith.
Apply conv_fun_series_mult_scal with f:=[n:nat]({-C-}c[^](minus n N)).
Apply conv_fun_const_series with x:=[n:nat]c[^](minus n N).
Apply join_series with (power_series c).
Apply power_series_conv; Auto.
Exists N.
Exists O.
Intro.
Rewrite plus_sym; Rewrite Minus.minus_plus.
Algebra.
Contin.
Do 3 Intro; Induction n.
Intro.
Cut N=O; [Intro | Auto with arith].
Rewrite H2.
Intros.
Apply eq_imp_leEq.
Simpl.
Step (AbsIR (pfpfun ? ? Hx'))[*]One; Apply mult_wd_lft; Apply AbsIR_wd; Algebra.
Intro.
Elim (le_lt_eq_dec ?? H1); Intro.
Intros; Apply leEq_transitive with c[*](AbsIR ((f n) x (contin_imp_inc ???? (contF n) x H0))).
Apply H; Auto with arith.
Apply leEq_wdr with ((AbsIR ((f N) x Hx))[*](c[^](minus n N))[*]c).
RStepr c[*]((AbsIR (pfpfun ? ? Hx))[*](c[^](minus n N))).
Apply mult_resp_leEq_lft.
Apply Hrecn; Auto with arith.
Assumption.
Rewrite <- minus_Sn_m.
Simpl; Rational.
Auto with arith.
Rewrite b0; Intros.
Rewrite <- minus_n_n.
Apply eq_imp_leEq.
Simpl; EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply mult_one.
Apply AbsIR_wd; Algebra.
Qed.

End Convergence_Criteria.


Require Import rt.util.all.
Require Import rt.model.jitter.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import SporadicTaskset.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: nat;
      task_period: nat;
      task_deadline: nat;
      task_jitter: nat
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1 == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2) &&
      (task_jitter t1 == task_jitter t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/andP [/eqP ID /eqP COST] /eqP PERIOD] /eqP DL] /eqP JITTER].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [/orP [EQ | /eqP DL] | /eqP JITTER]; last by apply JITTER; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP PERIOD]; last by apply PERIOD; inversion BUG.
        by apply ID; inversion BUG.
        by apply DL; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    Definition concrete_taskset :=
      taskset_of concrete_task_eqType.

  End ConcreteTaskset.

End ConcreteTask.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import Def.
Require Import HyperDef.
Require Import TraceCriterion.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section HyperCriterion.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Set.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.
  Local Definition hprop__S := hprop trace__S.
  Local Definition hprop__T := hprop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition sat__S := sat Source_Semantics.
  Local Definition sat__T := sat Target_Semantics.
  Local Definition hsat__S := hsat Source_Semantics.
  Local Definition hsat__T := hsat Target_Semantics.

  Local Definition cmp := compile_whole Source Target compilation_chain.

  Local Notation "W ↓" := (cmp W) (at level 50).

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition adjunction :=  induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition rel_adjunction_law : Adjunction_law τ' σ' := adjunction_law adjunction.

  Local Definition τP := τTP compilation_chain
                             Source_Semantics Target_Semantics
                             τ'.

  Local Definition σP := σTP compilation_chain
                             Source_Semantics Target_Semantics
                             σ'.

  Local Definition τHP := τHP compilation_chain
                              Source_Semantics Target_Semantics
                              τ'.

  Local Definition σHP := σHP compilation_chain
                          Source_Semantics Target_Semantics
                          σ'.

  Definition rel_HC :=  forall W t__T, beh__T (W ↓) t__T <-> (exists t__S, rel t__S t__T /\ beh__S W t__S).

  Lemma rel_HC' : rel_HC <-> forall W, beh__T (W ↓) = τ' (beh__S W).
    split => Hrel W.
    apply functional_extensionality => t__T. apply: prop_extensionality.
    rewrite (Hrel W). by firstorder.
    rewrite (Hrel W). by firstorder.
  Qed.

  Theorem rel_HC_τHP : rel_HC <-> τHP.
  Proof.
    rewrite rel_HC'. split.
    - move => H_rel W h__S. now exists (beh__S W).
    - move => H_τHP W. specialize (H_τHP W (fun π__S => π__S = beh__S W)).
      have Hfoo : hsat__S W (fun π__S => π__S = beh__S W) by auto.
      destruct (H_τHP Hfoo) as [bs [Heq H]]. subst. exact H.
  Qed.

  (*CA: if τ ⇆ σ is an insertion then
        tilde_HC =>  σHP
        but not able to prove the vicerversa holds
        (quite convinced it is not true)
  *)

  Lemma rel_HC_σHP : (Insertion_snd τ' σ') ->
    rel_HC -> σHP.
  Proof.
    rewrite rel_HC' => HIns Hrel W H__T [b__T [bt_HT Heq]].
    move: (Hrel W). rewrite /beh__T /beh__S Heq HIns.
    move => Heq__T. now subst.
  Qed.

  Lemma σHP_rel_HC : (Reflection_fst τ' σ') ->
    σHP -> rel_HC.
  Proof.
    rewrite rel_HC' => Hrefl Hσpres W.
    move: (Hσpres W (fun π__T => π__T = τ' (beh__S W))).
    rewrite /σhP => σ_pres_behW. apply: σ_pres_behW.
    have: (HyperDef.σ__h σ' (eq^~ (τ' (beh__S W)))) = (fun π__S => π__S = (beh__S W)).
    { rewrite /HyperDef.σ__h /lift.
      apply: functional_extensionality => x.
      apply: prop_extensionality.
      split.
      move => [b2 [H1 H2]]. subst. apply: Hrefl.
      move => Heq. rewrite Heq. exists (τ' (beh__S W)).
      split; [reflexivity | by rewrite Hrefl]. }
    move => Heq. by rewrite Heq.
   Qed.

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

  (* rel_TC /\ rel_TC_fwd -> rel_HC ? *)

  Local Definition rel_TC := rel_TC compilation_chain
                                    Source_Semantics Target_Semantics
                                    rel.

  Local Definition rel_FC1 := rel_FC1 compilation_chain
                                      Source_Semantics Target_Semantics
                                      rel.

  Local Definition rel_FC2 := rel_FC2 compilation_chain
                                      Source_Semantics Target_Semantics
                                      rel.

  (* under the assumption rel is a total function from source to target traces
     HC comes as consequence of TC and FC
   *)
  Theorem rel_total_map_TC_plus_FC1_HC :
   (forall s, exists! t, rel s t) ->
    rel_TC -> rel_FC1 -> rel_HC.
  Proof.
   setoid_rewrite rel_TC'. setoid_rewrite rel_FC1'.
   rewrite rel_HC' => rel_map bcc fcc W.
   apply: mutual_inclusion.
   + by apply: bcc.
   + rewrite rel_adjunction_law => s behWs t rel_s_t.
     move: (fcc W s behWs). move => [t' [rel_s_t' beh_cmpW_t']].
     have Heq: t = t'.
     { move: (rel_map s). move => [t0 [rel_s_t0 eq_t0]].
         by rewrite -(eq_t0 t rel_s_t) -(eq_t0 t' rel_s_t'). }
       by rewrite Heq.
   Qed.

  Theorem TC_plus_FC2_HC :
    rel_TC -> rel_FC2 -> rel_HC.
  Proof.
    setoid_rewrite rel_TC'. setoid_rewrite rel_FC2'.
    rewrite rel_HC' => bcc fcc W.
    apply: mutual_inclusion.
    + exact (bcc W).
    + rewrite rel_adjunction_law. exact (fcc W).
  Qed.

End HyperCriterion.


Require Export Shift0Dollar.Simplified.Terms.

(* ANCHOR Contexts
 *)
Inductive T {A} :=
| T_nil  : T
| T_cons : val A → K A → T → T  (* (v$K) · T *)
.
Arguments T A : clear implicits.

Fixpoint plugT {A} (trail : T A) e :=
  match trail with
  | T_nil => e
  | T_cons v k t => <{ v $ k [{plugT t e}] }>
  end.
Instance PlugT : Plug T := @plugT.

Inductive redex {A} :=
| redex_beta     : tm ^A → val A → redex (* (λ e) v *)
| redex_dollar   : val A → val A → redex (* v v' *)
| redex_let_beta : val A → tm ^A → redex (* let x = v in e *)

| redex_shift    : val A → K A → val A → redex (* w $ K[S₀ v] *)
.
Arguments redex A : clear implicits.

Definition redex_to_term {A} (r : redex A) : tm A :=
  match r with
  | redex_beta   e v => <{ (λ e) v }>
  | redex_dollar v v' => <{ v $ v' }>
  | redex_let_beta v e => <{ let v in e }>
  | redex_shift w k v => <{ w $ k [S₀ v] }>
  end.
Coercion redex_to_term : redex >-> tm.

Lemma inj_redex : ∀ {A} (r r' : redex A),
  redex_to_term r = redex_to_term r' → r = r'.
Proof.
  intros; destruct r, r'; cbn in *; inversion H; clear H; subst; auto.
Admitted.

(* ANCHOR Decompose
 *)
 Fixpoint decompose (e : tm ∅) : dec T redex ∅ :=
    match e with
    | tm_val v => dec_value v
    | tm_non p => decomposeP p
    end
  with decomposeP (p : non ∅) : dec T redex ∅ :=
    match p with
    | <{ v v' }> =>
      match v with
      | <{ var a }> => from_void a
      | <{ S₀ }>    => dec_stuck K_nil v'
      | <{ λ e }>   => dec_redex K_nil T_nil (redex_beta e v')
      end
    | <{ w $ e }> =>
      match decompose e with
      | dec_stuck k v   => dec_redex K_nil T_nil (redex_shift w k v) (* w $ k[S₀ v] *)
      | dec_redex k t r => dec_redex K_nil (T_cons w k t) r          (* w $ k[t[r]] *)
      | dec_value v     => dec_redex K_nil T_nil (redex_dollar w v)  (* w $ v *)
      end
    | <{ let e in e' }> =>
      match decompose e with
      | dec_stuck k v   => dec_stuck (K_let k e') v (* let k[S₀ v] in e' *)
      | dec_redex k t r => dec_redex (K_let k e') t r          (* let k[t[r]] in e' *)
      | dec_value v     => dec_redex K_nil T_nil (redex_let_beta v e')  (* let v       in e' *)
      end
    end.

(* ANCHOR Evaluation
 *)
Definition contract (r : redex ∅) : tm ∅ :=
    match r with
    (* (λ x. e) v  ~>  e [x := v] *)
    | redex_beta e v => <{ e [0 := v] }>

    (* w $ v  ~>  w v *)
    | redex_dollar v1 v2 => <{ v1 v2 }>

    (* let x = v in e  ~>  e [x := v] *)
    | redex_let_beta v e => <{ e [0 := v] }>

    (* w $ K[S₀ v]  ~>  v (λ x. w $ K[x]) *)
    | redex_shift w k v  => <{ v (λ ↑w $ ↑k[0]) }>
    end.

Definition optional_step e :=
  match decompose e with
  | dec_redex k t r => Some <{ k[t[{contract r}]] }>
  | _ => None
  end.

Reserved Notation "e1 ~> e2" (at level 40).
Inductive contr : tm ∅ → tm ∅ → Prop :=
| contr_tm : ∀ r, redex_to_term r ~> contract r
where "e1 ~> e2" := (contr e1 e2).
Global Hint Constructors contr : core.

Reserved Notation "e1 --> e2" (at level 40).
Inductive step : tm ∅ → tm ∅ → Prop :=
| step_tm : ∀ (k : K ∅) (t : T ∅) (e1 e2 : tm ∅), e1 ~> e2 → <{ k[t[e1]] }> --> <{ k[t[e2]] }>
where "e1 --> e2" := (step e1 e2).
Global Hint Constructors step : core.

Notation "e1 -->* e2" := (multi step e1 e2) (at level 40).

Lemma step_contr : ∀ {e1 e2},
  e1 ~> e2 →
  e1 --> e2.
Proof.
  intros.
  apply (step_tm K_nil T_nil e1 e2).
  assumption.
Qed.
Lemma multi_contr : ∀ {e1 e2},
  e1 ~> e2 →
  e1 -->* e2.
Proof.
  intros. apply (multi_step _ _ _ _ (step_contr H)); auto.
Qed.
Lemma multi_contr_multi : ∀ {e1 e2 e3},
  e1 ~> e2 →
  e2 -->* e3 →
  e1 -->* e3.
Proof.
  intros. eapply multi_step; try eapply (step_tm K_nil T_nil); cbn; eassumption.
Qed.
Definition contr_beta : ∀ e (v : val ∅), <{ (λ e) v }> ~> <{ e [ 0 := v ] }> := λ e v, contr_tm (redex_beta e v).
Definition contr_dollar : ∀ (v1 v2 : val ∅), <{ v1 $ v2 }> ~> <{ v1 v2 }> := λ v1 v2, contr_tm (redex_dollar v1 v2).
Definition contr_let_beta : ∀ (v : val ∅) e, <{ let v in e }> ~> <{ e [ 0 := v ] }> := λ v e, contr_tm (redex_let_beta v e).
Definition contr_shift : ∀ (w : val ∅) (k : K ∅) (v : val ∅), <{ w $ k [S₀ v] }> ~> <{ v (λ ↑w $ ↑k[0]) }> := λ w k v, contr_tm (redex_shift w k v).
Global Hint Resolve step_contr contr_beta contr_dollar contr_shift contr_let_beta : core.

Lemma deterministic_contr : ∀ e e1 e2,
  e ~> e1 →
  e ~> e2 →
  e1 = e2.
Proof.
  intros e e1 e2 H1 H2.
  inversion H1; clear H1; subst.
  inversion H2; clear H2; subst.
  apply inj_redex in H0; subst; reflexivity.
Qed.

Lemma redex_when_contr : ∀ e1 e2,
  e1 ~> e2 →
  ∃ r1, e1 = redex_to_term r1.
Proof.
  intros. inversion H; clear H; subst.
  exists r; auto.
Qed.

(* Lemma deterministic_step : ∀ e e1 e2,
  e --> e1 →
  e --> e2 →
  e1 = e2.
Proof.
  intros e e1 e2 H1 H2.
  inversion H1; clear H1; subst.
  inversion H2; clear H2; subst.
  apply redex_when_contr in H as HH; destruct HH as [r0 HH]; subst.
  apply redex_when_contr in H1 as HH; destruct HH as [r1 HH]; subst.
  assert (dec_redex k0 t0 r1 = dec_redex k t r0) as Hktr.
  { repeat rewrite <- decompose_plug_redex. f_equal; assumption. }
  inversion Hktr; clear Hktr; subst.
  repeat f_equal.
  apply (deterministic_contr r0); assumption.
Qed. *)

Fixpoint eval i e :=
  match i with
  | 0 => e
  | S j =>
    match optional_step e with
    | Some e => eval j e
    | None => e
    end
  end.

Section Examples.
  Definition _id : val ∅ := <{ λ 0 }>.
  Definition _const : val ∅ := <{ λ λ 1 }>.

  Compute (eval 10 <{ _id $ _const $ S₀ (λ 0) }>).
  Compute (eval 10 <{ _const $ _id $ S₀ (λ 0) }>).

  Definition _e1 : tm ∅ := <{
    _id $
      let λ 0 0 in
      let S₀ 0 in
      0
  }>.
  Compute (eval 0 _e1).
  Compute (eval 1 _e1).
  Compute (eval 2 _e1).
  Compute (eval 3 _e1).
  Compute (eval 5 _e1).
  Compute (eval 9 _e1).

End Examples.