(** * Types: Type Systems *)

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of the simplest
    imaginable language, to introduce the basic ideas of types and
    typing rules and the fundamental theorems about type systems:
    _type preservation_ and _progress_.  In chapter [Stlc] we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq!). *)
Add LoadPath "~/Desktop/CS386L-Programming-Language/plf".
Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Arith.Arith.
Require Import Maps.
Require Import Imp.
Require Import Smallstep.

Hint Constructors multi.

(* ################################################################# *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with a tiny toy language.  We want it to have the potential
    for programs to go wrong because of runtime type errors, so we
    need something a tiny bit more complex than the language of
    constants and addition that we used in chapter [Smallstep]: a
    single kind of data (e.g., numbers) is too simple, but just two
    kinds (numbers and booleans) gives us enough material to tell an
    interesting story.

    The language definition is completely routine. *)

(* ================================================================= *)
(** ** Syntax *)

(** Here is the syntax, informally:

    t ::= true
        | false
        | if t then t else t
        | 0
        | succ t
        | pred t
        | iszero t

    And here it is formally: *)

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tzero : tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tiszero : tm -> tm.

(** _Values_ are [true], [false], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_true : bvalue ttrue
  | bv_false : bvalue tfalse.

Inductive nvalue : tm -> Prop :=
  | nv_zero : nvalue tzero
  | nv_succ : forall t, nvalue t -> nvalue (tsucc t).

Definition value (t:tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold update.

(* ================================================================= *)
(** ** Operational Semantics *)

(** Here is the single-step relation, first informally... *)
(**

                    ------------------------------                  (ST_IfTrue)
                    if true then t1 else t2 ==> t1

                   -------------------------------                 (ST_IfFalse)
                   if false then t1 else t2 ==> t2

                              t1 ==> t1'
            ------------------------------------------------            (ST_If)
            if t1 then t2 else t3 ==> if t1' then t2 else t3

                              t1 ==> t1'
                         --------------------                         (ST_Succ)
                         succ t1 ==> succ t1'

                             ------------                         (ST_PredZero)
                             pred 0 ==> 0

                           numeric value v1
                        ---------------------                     (ST_PredSucc)
                        pred (succ v1) ==> v1

                              t1 ==> t1'
                         --------------------                         (ST_Pred)
                         pred t1 ==> pred t1'

                          -----------------                     (ST_IszeroZero)
                          iszero 0 ==> true

                           numeric value v1
                      --------------------------                (ST_IszeroSucc)
                      iszero (succ v1) ==> false

                              t1 ==> t1'
                       ------------------------                     (ST_Iszero)
                       iszero t1 ==> iszero t1'
*)

(** ... and then formally: *)

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

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
  | ST_Succ : forall t1 t1',
      t1 ==> t1' ->
      (tsucc t1) ==> (tsucc t1')
  | ST_PredZero :
      (tpred tzero) ==> tzero
  | ST_PredSucc : forall t1,
      nvalue t1 ->
      (tpred (tsucc t1)) ==> t1
  | ST_Pred : forall t1 t1',
      t1 ==> t1' ->
      (tpred t1) ==> (tpred t1')
  | ST_IszeroZero :
      (tiszero tzero) ==> ttrue
  | ST_IszeroSucc : forall t1,
       nvalue t1 ->
      (tiszero (tsucc t1)) ==> tfalse
  | ST_Iszero : forall t1 t1',
      t1 ==> t1' ->
      (tiszero t1) ==> (tiszero t1')

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

(** Notice that the [step] relation doesn't care about whether
    expressions make global sense -- it just checks that the operation
    in the _next_ reduction step is being applied to the right kinds
    of operands.  For example, the term [succ true] (i.e.,
    [tsucc ttrue] in the formal syntax) cannot take a step, but the
    almost as obviously nonsensical term

       succ (if true then true else true)

    can take a step (once, before becoming stuck). *)

(* ================================================================= *)
(** ** Normal Forms and Values *)

(** The first interesting thing to notice about this [step] relation
    is that the strong progress theorem from the [Smallstep] chapter
    fails here.  That is, there are terms that are normal forms (they
    can't take a step) but not values (because we have not included
    them in our definition of possible "results of reduction").  Such
    terms are _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t:tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

(** **** Exercise: 2 stars (some_term_is_stuck)  *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (tsucc ttrue).
  unfold stuck,step_normal_form.
  split; intros H.
  - destruct H. inversion H;subst. inversion H1.
  - inversion H;subst.
    + inversion H0;subst.
    + inversion H0;subst. inversion H2.
Qed.
(** [] *)

(** However, although values and normal forms are _not_ the same in this
    language, the set of values is included in the set of normal
    forms.  This is important because it shows we did not accidentally
    define things so that some value could still take a step. *)

(** **** Exercise: 3 stars (value_is_nf)  *)

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.

  unfold step_normal_form, not. intros.
  inversion H.
  + inversion H0. inversion H1;subst;inversion H2.
  + induction H1.
    - destruct H0. inversion H0.
    - apply IHnvalue. inversion H1;subst.
      right. assumption. right. assumption. destruct H0.
      inversion H0;subst. exists t1'. assumption.

Qed.

(** (Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways.) *)
(** [] *)

(** **** Exercise: 3 stars, optional (step_deterministic)  *)
(** Use [value_is_nf] to show that the [step] relation is also
    deterministic. *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Typing *)

(** The next critical observation is that, although this
    language has stuck terms, they are always nonsensical, mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | TBool : ty
  | TNat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T] and pronounced "[t] has type [T]."  The [|-] symbol
    is called a "turnstile."  Below, we're going to see richer typing
    relations where one or more additional "context" arguments are
    written to the left of the turnstile.  For the moment, the context
    is always empty. *)
(**
                           ----------------                            (T_True)
                           |- true \in Bool

                          -----------------                           (T_False)
                          |- false \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------                (T_If)
                    |- if t1 then t2 else t3 \in T

                             ------------                              (T_Zero)
                             |- 0 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Succ)
                          |- succ t1 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Pred)
                          |- pred t1 \in Nat

                            |- t1 \in Nat
                        ---------------------                        (T_IsZero)
                        |- iszero t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_True :
       |- ttrue \in TBool
  | T_False :
       |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T,
       |- t1 \in TBool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- tif t1 t2 t3 \in T
  | T_Zero :
       |- tzero \in TNat
  | T_Succ : forall t1,
       |- t1 \in TNat ->
       |- tsucc t1 \in TNat
  | T_Pred : forall t1,
       |- t1 \in TNat ->
       |- tpred t1 \in TNat
  | T_Iszero : forall t1,
       |- t1 \in TNat ->
       |- tiszero t1 \in TBool

where "'|-' t '\in' T" := (has_type t T).

Hint Constructors has_type.

Example has_type_1 :
  |- tif tfalse tzero (tsucc tzero) \in TNat.
Proof.
  apply T_If.
    - apply T_False.
    - apply T_Zero.
    - apply T_Succ.
       + apply T_Zero.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not consider
    what happens when the term is reduced -- in particular, it does
    not calculate the type of its normal form. *)

Example has_type_not :
  ~ (|- tif tfalse tzero ttrue \in TBool).
Proof.
  intros Contra. solve_by_inverts 2.  Qed.

(** **** Exercise: 1 star, optional (succ_hastype_nat__hastype_nat)  *)
Example succ_hastype_nat__hastype_nat : forall t,
  |- tsucc t \in TNat ->
  |- t \in TNat.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Canonical forms *)

(** The following two lemmas capture the fundamental property that the
    definitions of boolean and numeric values agree with the typing
    relation. *)

Lemma bool_canonical : forall t,
  |- t \in TBool -> value t -> bvalue t.
Proof.
  intros t HT HV.
  inversion HV; auto.
  induction H; inversion HT; auto.
Qed.

Lemma nat_canonical : forall t,
  |- t \in TNat -> value t -> nvalue t.
Proof.
  intros t HT HV.
  inversion HV.
  inversion H; subst; inversion HT.
  auto.
Qed.

(* ================================================================= *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are not stuck -- or conversely, if a
    term is well typed, then either it is a value or it can take at
    least one step.  We call this _progress_. *)

(** **** Exercise: 3 stars (finish_progress)  *)
Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.

(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the parts we've given of the informal proof in the
    following exercise before starting -- this will save you a lot of
    time.) *)
Proof with auto.
  intros t T HT.
  induction HT...
  (* The cases that were obviously values, like T_True and
     T_False, were eliminated immediately by auto *)
  - (* T_If *)
    right. inversion IHHT1; clear IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2...
      exists t3...
    + (* t1 can take a step *)
      inversion H as [t1' H1].
      exists (tif t1' t2 t3)...
  - inversion HT;subst.
    + destruct IHHT.
      * left. right. apply nv_succ. apply nat_canonical in H2; assumption.
      * right. destruct H2. exists (tsucc x). apply ST_Succ. assumption.
    + left. right. constructor. constructor.
    + destruct IHHT.
      * left. right. constructor. apply nat_canonical in HT;assumption.
      * right. destruct H0. exists (tsucc x). constructor. assumption.
    + destruct IHHT.
      * left. right. constructor. apply nat_canonical in HT;assumption.
      * right. destruct H0. exists (tsucc x). constructor. assumption.
  - right. inversion IHHT; clear IHHT;inversion H.
    solve_by_inverts 2.
    + inversion H0. exists tzero. constructor. exists t. constructor. assumption.
    + exists (tpred x). constructor. apply H0.
  - right;inversion IHHT;clear IHHT.
    + inversion H. solve_by_inverts 2. inversion H0.
      exists (ttrue). constructor. exists (tfalse). constructor. apply H1.
    + destruct H. exists (tiszero x). constructor. apply H.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_progress_informal)  *)
(** Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t ==> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].  By the IH, either [t1] is a value or else [t1] can step
        to some [t1'].

            - If [t1] is a value, then by the canonical forms lemmas
              and the fact that [|- t1 \in Bool] we have that [t1]
              is a [bvalue] -- i.e., it is either [true] or [false].
              If [t1 = true], then [t] steps to [t2] by [ST_IfTrue],
              while if [t1 = false], then [t] steps to [t3] by
              [ST_IfFalse].  Either way, [t] can step, which is what
              we wanted to show.

            - If [t1] itself can take a step, then, by [ST_If], so can
              [t].

      - (* FILL IN HERE *)
 *)
(** [] *)

(** This theorem is more interesting than the strong progress theorem
    that we saw in the [Smallstep] chapter, where _all_ normal forms
    were values.  Here a term can be stuck, but only if it is ill
    typed. *)

(* ================================================================= *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is also a well-typed term. *)

(** **** Exercise: 2 stars (finish_preservation)  *)
Theorem preservation : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.

(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try solve_by_invert.
    - (* T_If *) inversion HE; subst; clear HE.
      + (* ST_IFTrue *) assumption.
      + (* ST_IfFalse *) assumption.
      + (* ST_If *) apply T_If; try assumption.
        apply IHHT1; assumption.
    - inversion HE;subst;clear HE.
      apply T_Succ. apply IHHT. assumption.
    - inversion HE;subst;clear HE.
      + constructor.
      + inversion HT;subst. apply H1.
      + constructor. apply IHHT. assumption.
    - inversion HE;subst;clear HE.
      + constructor.
      + constructor.
      + constructor. apply IHHT. assumption.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_preservation_informal)  *)
(** Complete the following informal proof: *)

(** _Theorem_: If [|- t \in T] and [t ==> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].

        Inspecting the rules for the small-step reduction relation and
        remembering that [t] has the form [if ...], we see that the
        only ones that could have been used to prove [t ==> t'] are
        [ST_IfTrue], [ST_IfFalse], or [ST_If].

           - If the last rule was [ST_IfTrue], then [t' = t2].  But we
             know that [|- t2 \in T], so we are done.

           - If the last rule was [ST_IfFalse], then [t' = t3].  But we
             know that [|- t3 \in T], so we are done.

           - If the last rule was [ST_If], then [t' = if t1' then t2
             else t3], where [t1 ==> t1'].  We know [|- t1 \in Bool] so,
             by the IH, [|- t1' \in Bool].  The [T_If] rule then gives us
             [|- if t1' then t2 else t3 \in T], as required.

      - (* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 3 stars (preservation_alternate_proof)  *)
(** Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proofs to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.
Proof with eauto.
  intros.
  generalize dependent T.
  induction H0;intros;
  try (inversion H;subst;constructor;try assumption);
  try (inversion H;subst;assumption);
  try (apply IHstep;assumption).
  - inversion H0;subst. inversion H2. assumption.
  - inversion H0;subst. constructor.
Qed.
(** [] *)

(** The preservation theorem is often called _subject reduction_,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

(* ================================================================= *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we see that a
    well-typed term can never reach a stuck state.  *)

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

Corollary soundness : forall t t' T,
  |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP.  apply (preservation x y T HT H).
  unfold stuck. split; auto.   Qed.

(* ################################################################# *)
(** * Aside: the [normalize] Tactic *)

(** When experimenting with definitions of programming languages
    in Coq, we often want to see what a particular concrete term steps
    to -- i.e., we want to find proofs for goals of the form [t ==>*
    t'], where [t] is a completely concrete term and [t'] is unknown.
    These proofs are quite tedious to do by hand.  Consider, for
    example, reducing an arithmetic expression using the small-step
    relation [astep]. *)

Module NormalizePlayground.
Import Smallstep.

Example step_example1 :
  (P (C 3) (P (C 3) (C 4)))
  ==>* (C 10).
Proof.
  apply multi_step with (P (C 3) (C 7)).
    apply ST_Plus2.
      apply v_const.
      apply ST_PlusConstConst.
  apply multi_step with (C 10).
    apply ST_PlusConstConst.
  apply multi_refl.
Qed.

(** The proof repeatedly applies [multi_step] until the term reaches a
    normal form.  Fortunately The sub-proofs for the intermediate
    steps are simple enough that [auto], with appropriate hints, can
    solve them. *)

Hint Constructors step value.
Example step_example1' :
  (P (C 3) (P (C 3) (C 4)))
  ==>* (C 10).
Proof.
  eapply multi_step. auto. simpl.
  eapply multi_step. auto. simpl.
  apply multi_refl.
Qed.

(** The following custom [Tactic Notation] definition captures this
    pattern.  In addition, before each step, we print out the current
    goal, so that we can follow how the term is being reduced. *)

Tactic Notation "print_goal" :=
  match goal with |- ?x => idtac x end.

Tactic Notation "normalize" :=
  repeat (print_goal; eapply multi_step ;
            [ (eauto 10; fail) | (instantiate; simpl)]);
  apply multi_refl.

Example step_example1'' :
  (P (C 3) (P (C 3) (C 4)))
  ==>* (C 10).
Proof.
  normalize.
  (* The [print_goal] in the [normalize] tactic shows
     a trace of how the expression reduced...
         (P (C 3) (P (C 3) (C 4)) ==>* C 10)
         (P (C 3) (C 7) ==>* C 10)
         (C 10 ==>* C 10)
  *)
Qed.

(** The [normalize] tactic also provides a simple way to calculate the
    normal form of a term, by starting with a goal with an existentially
    bound variable. *)

Example step_example1''' : exists e',
  (P (C 3) (P (C 3) (C 4)))
  ==>* e'.
Proof.
  eapply ex_intro. normalize.
(* This time, the trace is:
       (P (C 3) (P (C 3) (C 4)) ==>* ?e')
       (P (C 3) (C 7) ==>* ?e')
       (C 10 ==>* ?e')
   where ?e' is the variable ``guessed'' by eapply. *)
Qed.

(** **** Exercise: 1 star (normalize_ex)  *)
Theorem normalize_ex : exists e',
  (P (C 3) (P (C 2) (C 1)))
  ==>* e'.
Proof.
  eapply ex_intro. normalize.
Qed.
(** [] *)

(** **** Exercise: 1 star, optional (normalize_ex')  *)
(** For comparison, prove it using [apply] instead of [eapply]. *)

Theorem normalize_ex' : exists e',
  (P (C 3) (P (C 2) (C 1)))
  ==>* e'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

End NormalizePlayground.

Tactic Notation "print_goal" :=
  match goal with |- ?x => idtac x end.
Tactic Notation "normalize" :=
  repeat (print_goal; eapply multi_step ;
            [ (eauto 10; fail) | (instantiate; simpl)]);
  apply multi_refl.

(* ================================================================= *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars, recommended (subject_expansion)  *)
(** Having seen the subject reduction property, one might
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t ==> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so.)

   t=(tif ttrue t' tzero) ==> t'
   but (tif ttrue t' tzero) is neither NAT nor BOOL

    (* FILL IN HERE *)
*)

(** [] *)

(** **** Exercise: 2 stars (variation1)  *)
(** Suppose, that we add this new rule to the typing relation:

      | T_SuccBool : forall t,
           |- t \in TBool ->
           |- tsucc t \in TBool

   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]

      - Progress

      - Preservation

    [] *)

(** **** Exercise: 2 stars (variation2)  *)
(** Suppose, instead, that we add this new rule to the [step] relation:

      | ST_Funny1 : forall t2 t3,
           (tif ttrue t2 t3) ==> t3

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 2 stars, optional (variation3)  *)
(** Suppose instead that we add this rule:

      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 ==> t2' ->
           (tif t1 t2 t3) ==> (tif t1 t2' t3)

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 2 stars, optional (variation4)  *)
(** Suppose instead that we add this rule:

      | ST_Funny3 :
          (tpred tfalse) ==> (tpred (tpred tfalse))

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 2 stars, optional (variation5)  *)
(** Suppose instead that we add this rule:

      | T_Funny4 :
            |- tzero \in TBool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 2 stars, optional (variation6)  *)
(** Suppose instead that we add this rule:

      | T_Funny5 :
            |- tpred tzero \in TBool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 3 stars, optional (more_variations)  *)
(** Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
*)
(** [] *)

(** **** Exercise: 1 star (remove_predzero)  *)
(** The reduction rule [ST_PredZero] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of zero to
    be undefined, rather than being defined to be zero.  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep)  *)
(** Suppose our evaluation relation is defined in the big-step style.
    State appropriate analogs of the progress and preservation
    properties. (You do not need to prove them.)

    Can you see any limitations of either of your properties?
    Do they allow for nonterminating commands?
    Why might we prefer the small-step semantics for stating
    preservation and progress?

(* FILL IN HERE *)
*)
(** [] *)

(** $Date: 2017-11-21 11:43:02 -0600 (Tue, 21 Nov 2017) $ *)


Require Import Coq.Program.Program.
Require Import datatypes.
Require Import Coq.Lists.List.
Require Import eqchain.

Definition fmap {F : PolyF} {μF A B : Type}
           {ia1 : F_initial_algebra F A μF}
           {ia2 : F_initial_algebra F B μF}
           (f : A -> B)
  := ⦇ in_ ∘ F❲ f ❳[id] ⦈.

Section data_functor.

  Variable (F : PolyF) (μF : Type) (A B C : Type)
           (ia1 : F_initial_algebra F A μF)
           (ia2 : F_initial_algebra F B μF)
           (ia3 : F_initial_algebra F C μF)
           (ia : F_initial_algebra F A μF).

  Theorem map_map_fusion :
    forall (f : A -> B) (g : B -> C),
      (fmap g) ∘ (fmap f) = fmap (g ∘ f).
  Proof.
    intros; unfold fmap.
    assert ( (fmap g) ∘ in_ ∘ F❲f❳[id] = in_ ∘ F❲g ∘ f❳[id] ∘ F❲id❳[fmap g] ) as H0.
    {
      unfold fmap.
      Left
      = ( ⦇in_ ∘ F❲g❳[id]⦈ ∘ in_ ∘ F❲f❳[id] ).
      = ( in_ ∘ (F❲g❳[id] ∘ F❲id❳[⦇in_ ∘ F❲g❳[id]⦈]) ∘ F❲f❳[id] )  { by cata_cancel }.
      = ( in_ ∘ (F❲g❳[⦇in_ ∘ F❲g❳[id]⦈] ∘ F❲f❳[id]) )  { by fmap_functor_dist }.
      = ( in_ ∘ (F❲g ∘ f❳[⦇in_ ∘ F❲g❳[id]⦈]) )  { by fmap_functor_dist }.
      = ( in_ ∘ (F❲g ∘ f❳[id] ∘ F❲id❳[⦇in_ ∘ F❲g❳[id]⦈]) )  { by fmap_functor_dist }.
      = Right.
    }
    unfold fmap in H0.
    Left
    = ( ⦇ in_ ∘ F❲g❳[id] ⦈ ∘ ⦇ in_ ∘ F❲f❳[id] ⦈ ).
    = ( ⦇in_ ∘ F ❲g ∘ f❳[id] ⦈ )  { apply cata_fusion }.
    = Right.
  Qed.

End data_functor.

Definition list_cata (A X : Type) (f : unit + (A * X) -> X) : (list A) -> X :=
  fix cata (la : list A)
    := match la with
       | nil       => f (inl tt)
       | cons a xs => f (inr (a, (cata xs)))
       end.

Definition list_in (A : Type) (ual : unit + (A * (list A))) : list A :=
  match ual with
  | inl tt => nil
  | inr al => let (a,l) := al in cons a l
  end.

Instance list_ia (A : Type)
  : F_initial_algebra (Sum one (Prod arg1 arg2)) A (list A) :=
  {
    cata := list_cata A;
    in_  := list_in A
  }.
Proof.
  intros. split.
  - intros H; extensionality l; induction l.
    + specialize (equal_f H (inl tt)) as H0.
      cbv in H0; cbv; easy.
    + specialize (equal_f H (inr (a, l))) as H0.
      cbv in H0; cbv. rewrite H0. rewrite IHl. easy.
  - intros H; extensionality l. induction l.
    + rewrite H; induction a; specialize (equal_f H []) as H0. easy.
    + rewrite H. induction b; specialize (equal_f H (cons a b)) as H0.
      easy.
Defined.

Eval cbv in (fmap (plus 10) [1 ; 2 ; 3 ; 4 ; 5]).


Set Loose Hint Behavior "Strict".

(* Adapted from http://poleiro.info/posts/2013-04-03-parse-errors-as-type-errors.html,
   https://github.com/arthuraa/poleiro/blob/master/theories/ForceOption.v
   to produce N instead of nat *)

Require Export Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.NArith.NArith.

Local Open Scope char_scope.

Local Open Scope N_scope.

Definition binDigitToN (c : ascii) : option N :=
  match c with
    | "0" => Some 0
    | "1" => Some 1
    | _   => None
  end.

Open Scope string_scope.

Fixpoint readBinNAux (s : string) (acc : N) : option N :=
  match s with
    | "" => Some acc
    | String c s' =>
      match binDigitToN c with
        | Some n => readBinNAux s' (2 * acc + n)
        | None => None
      end
  end.

Definition readBinN (s : string) : option N := readBinNAux s 0.

Goal readBinN "11111111" = Some 255.
Proof. reflexivity. Qed.

Definition forceOption A Err (o : option A) (err : Err) : match o with
                                                            | Some _ => A
                                                            | None => Err
                                                          end :=
  match o with
    | Some a => a
    | None => err
  end.

Inductive parseError := ParseError.

Definition bin (s : string) := forceOption N parseError (readBinN s) ParseError.

Goal bin"11111111" = 255.
Proof. reflexivity. Qed.

Goal bin"1011" = 11.
Proof. reflexivity. Qed.

Goal bin"1O" = ParseError.
Proof. reflexivity. Qed.


From CertiCoq.Plugin Require Import CertiCoq.

Require Import Arith PArith List String Ascii.
Require Import ExtLib.Data.String.

Import ListNotations.

(* Example 1: printing axioms *)

Axiom (print_nat : nat -> unit).
Axiom (print_str : string -> unit).
Axiom (new_line : unit -> unit).

Definition print_list (l : list nat) : unit :=
  let aux :=
      fix aux l :=
        match l with
        | [] => tt
        | [x] => print_nat x
        | x :: l =>
          let _ := print_nat x in
          let _ := print_str ";" in
          aux l
        end in
  let _ := print_str "[" in
  let _ := aux l in
  let _ := print_str "]" in new_line tt.

Definition print_lst := print_list [1;2;3;4;5].

CertiCoq Compile print_lst
Extract Constants [ print_nat => "print_gallina_nat", print_str => "print_gallina_string", new_line => "print_new_line" ]
Include [ "print.h" ].

(* Example 2: int 63 *)

Axiom (int63 : Type).
Axiom (add_int63 : int63 -> int63 -> int63).
Axiom (minus : int63 -> int63 -> int63).
Axiom (mul : int63 -> int63 -> int63).
Axiom (print_int63 : int63 -> unit).

Axiom (zero_int63 : int63).
Axiom (one_int63 : int63).

Fixpoint fib_aux (n : nat) (prev0 prev1 : int63) :=
  match n with
  | 0 => prev0
  | 1 => prev1
  | S n => fib_aux n prev1 (add_int63 prev0 prev1)
  end.

Definition fib (n : nat) := fib_aux n zero_int63 one_int63.

Definition fibn : unit :=
  let _ := print_int63 (fib 11) in
  new_line tt.

CertiCoq Compile fibn
Extract Constants [ add_int63 => "add_int63", zero_int63 => "zero_int63", one_int63 => "one_int63", print_int63 => "print_int63", new_line => "print_new_line" ]
Include [ "int63.h" ].

(* Example 3: list_sum with int63 -- add_int63 is first class *)

Definition list_sum_int63 :=
  let n := List.fold_left add_int63 (List.repeat one_int63 100) zero_int63 in
  let _ := print_int63 n in new_line tt.

CertiCoq Compile list_sum_int63
Extract Constants [ add_int63 => "add_int63", zero_int63 => "zero_int63", one_int63 => "one_int63", print_int63 => "print_int63", new_line => "print_new_line" ]
Include [ "int63.h" ].

(* "Dummy" example with tinfo (tifno is not used by the C function) *)

Definition list_sum_int63_tinfo :=
  let n := List.fold_left add_int63 (List.repeat one_int63 100) zero_int63 in
  let _ := print_int63 n in new_line tt.

CertiCoq Compile list_sum_int63_tinfo
Extract Constants [ add_int63 => "add_int63" with tinfo, zero_int63 => "zero_int63", one_int63 => "one_int63", print_int63 => "print_int63" with tinfo, new_line => "print_new_line" ]
Include [ "int63_tinfo.h" ].


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).

Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday :
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_Nil: forall (l: lst), append l Nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  - simpl. rewrite <- IHl1. f_equal.
  - simpl. rewrite 2 append_Nil. reflexivity.
  - simpl. rewrite append_Nil.  reflexivity.
  - simpl. rewrite 2 append_Nil. reflexivity.
Qed.

Theorem append_rev_Cons:
  forall (l1 l2: lst) (x: natural),
    rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
  induction l1; induction l2; try (simpl; reflexivity).
  { intro. simpl. rewrite IHl1. simpl. lfind. Admitted.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.priority rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.global.basic.schedule rt.model.schedule.global.basic.interference
               rt.model.schedule.global.basic.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module ConstrainedDeadlines.

  Import Job SporadicTaskset ScheduleOfSporadicTask SporadicTaskset
         TaskArrival Interference Priority Platform.

  Section Lemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

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

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

    (* ... and any schedule of this arrival sequence. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* Assume all jobs have valid parameters, ...*)
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* In this section we prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed.  *)
    Section NoMultipleJobs.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: JLDP_policy Job.
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
      Hypothesis H_respects_JLDP_policy:
        respects_JLDP_policy job_arrival job_cost arr_seq sched higher_eq_priority.

      (* Consider task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j,
          arrives_in arr_seq j -> job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs must arrive to execute, ... *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched.

      (* Assume that the schedule satisfies the sporadic task model ...*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Variable H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_arrival job_cost sched j t.

      (* Assume that any previous jobs of tsk have completed by the period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          job_arrival j_other + task_period tsk_other <= t ->
          completed job_cost sched j_other (job_arrival j_other + task_period (job_task j_other)).

      Let scheduled_task_other_than (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t && (tsk_other != tsk).

      (* Then, there can be at most one pending job of each task at time t. *)
      Lemma platform_at_most_one_pending_job_of_each_task :
        forall j1 j2,
          arrives_in arr_seq j1 ->
          arrives_in arr_seq j2 ->
          pending job_arrival job_cost sched j1 t ->
          pending job_arrival job_cost sched j2 t ->
          job_task j1 = job_task j2 ->
          j1 = j2.
      Proof.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARR1 ARR2 PENDING1 PENDING2 SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARR1 ARR2 SAMEtsk BEFORE1).
          exploit (PREV j1 (job_task j1) ARR1);
            [by done | by apply leq_trans with (n := job_arrival j2) | intros COMP1].
          apply NOTCOMP1.
          apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1));
            try (by done).
          by apply leq_trans with (n := job_arrival j2).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); try (by done); [by red; ins; subst | intro SPO'].
          exploit (PREV j2 (job_task j2) ARR2);
            [by done | by apply leq_trans with (n := job_arrival j1) | intros COMP2].
          apply NOTCOMP2.
          apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2));
            try (by done).
          by apply leq_trans with (n := job_arrival j1).
        }
      Qed.

      (* Therefore, all processors are busy with tasks other than tsk. *)
      Lemma platform_cpus_busy_with_interfering_tasks :
        count (scheduled_task_other_than tsk) ts = num_cpus.
      Proof.
        have UNIQ := platform_at_most_one_pending_job_of_each_task.
        rename H_all_jobs_from_taskset into FROMTS,
               H_sequential_jobs into SEQUENTIAL, H_work_conserving into WORK,
               H_respects_JLDP_policy into PRIO,
               H_j_backlogged into BACK, H_jobs_come_from_arrival_sequence into FROMarr,
               H_job_of_tsk into JOBtsk, H_valid_job_parameters into JOBPARAMS,
               H_valid_task into TASKPARAMS,
               H_all_previous_jobs_completed into PREV, H_completed_jobs_dont_execute into COMP,
               H_jobs_must_arrive_to_execute into ARRIVE.
        apply work_conserving_eq_work_conserving_count in WORK.
        unfold valid_sporadic_job, valid_realtime_job,
               respects_JLDP_policy, completed_jobs_dont_execute,
               sporadic_task_model, is_valid_sporadic_task,
               jobs_of_same_task_dont_execute_in_parallel,
               sequential_jobs in *.
        apply/eqP; rewrite eqn_leq; apply/andP; split.
        {
          apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
            first by apply sub_count; first by red; move => x /andP [SCHED _].
          unfold task_is_scheduled.
          apply count_exists; first by destruct ts.
          {
            intros cpu x1 x2 SCHED1 SCHED2.
            unfold task_scheduled_on in *.
            destruct (sched cpu t); last by done.
            move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
            by rewrite -SCHED1 -SCHED2.
          }
        }
        {
          rewrite -(WORK j t) // -count_predT.
          apply leq_trans with (n := count (fun j => scheduled_task_other_than tsk (job_task j)) (jobs_scheduled_at sched t));
            last first.
          {
            rewrite -count_map.
            apply count_sub_uniqr; last first.
            {
              move => tsk' /mapP [j' INj' JOBtsk']; subst; apply FROMTS.
              by rewrite mem_scheduled_jobs_eq_scheduled in INj'; eauto 2.
            }
            rewrite map_inj_in_uniq; first by apply scheduled_jobs_uniq.
            red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
            rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
            have ARRin1: arrives_in arr_seq j1 by apply (FROMarr j1 t).
              have ARRin2: arrives_in arr_seq j2 by apply (FROMarr j2 t).
              by apply UNIQ; try (by done); apply scheduled_implies_pending.
          }
          {
            apply sub_in_count; intros j' SCHED' _.
            rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
            unfold scheduled_task_other_than; apply/andP; split.
            {
              move: SCHED' => /existsP [cpu /eqP SCHED'].
              by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
            }
            {
              apply/eqP; red; intro SAMEtsk; symmetry in SAMEtsk.
              move: BACK => /andP [PENDING NOTSCHED].
              have ARRin': arrives_in arr_seq j' by apply (FROMarr j' t).
              exploit (UNIQ j j'); try (by done);
                [by apply scheduled_implies_pending | by rewrite -SAMEtsk |].
              by intro EQjob; subst; rewrite SCHED' in NOTSCHED.
            }
          }
        }
      Qed.

    End NoMultipleJobs.

    (* In this section we also prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed, but in the specific case
       of fixed-priority scheduling.  *)
    Section NoMultipleJobsFP.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: FP_policy sporadic_task.
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
      Hypothesis H_respects_JLDP_policy:
        respects_FP_policy job_arrival job_cost job_task arr_seq sched higher_eq_priority.

      (* Consider any task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j,
          arrives_in arr_seq j -> job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs must arrive to execute, ... *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched.

      (* Assume that jobs arrive sporadically. *)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Variable H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t <= job_arrival j + task_period tsk. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_arrival job_cost sched j t.
      Hypothesis H_t_before_period: t < job_arrival j + task_period tsk.

      (* Recall the definition of a higher-priority task (with respect to tsk). *)
      Let is_hp_task := higher_priority_task higher_eq_priority tsk.

      (* Assume that any jobs of higher-priority tasks complete by their period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          is_hp_task tsk_other ->
          completed job_cost sched j_other (job_arrival j_other + task_period tsk_other).

      (* Assume that any jobs of tsk prior to j complete by their period. *)
      Hypothesis H_all_previous_jobs_of_tsk_completed :
        forall j0,
          arrives_in arr_seq j0 ->
          job_task j0 = tsk ->
          job_arrival j0 < job_arrival j ->
          completed job_cost sched j0 (job_arrival j0 + task_period tsk).

      Definition scheduled_task_with_higher_eq_priority (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t &&
        is_hp_task tsk_other.

      (* Then, there can be at most one pending job of higher-priority tasks at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_interfering_tasks :
        forall j1 j2,
          arrives_in arr_seq j1 ->
          arrives_in arr_seq j2 ->
          pending job_arrival job_cost sched j1 t ->
          pending job_arrival job_cost sched j2 t ->
          job_task j1 = job_task j2 ->
          is_hp_task (job_task j1) ->
          j1 = j2.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARR1 ARR2 PENDING1 PENDING2 SAMEtsk INTERF.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARR1 ARR2 SAMEtsk BEFORE1).
          exploit (PREV j1 (job_task j1) ARR1); [by done | by apply INTERF | intros COMP1].
          apply NOTCOMP1.
          apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1));
            try (by done).
          by apply leq_trans with (n := job_arrival j2).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); try (by done); [by red; ins; subst j2 | intro SPO'].
          exploit (PREV j2 (job_task j2) ARR2);
            [by done | by rewrite -SAMEtsk | intro COMP2 ].
          apply NOTCOMP2.
          apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2));
            try (by done).
          by apply leq_trans with (n := job_arrival j1).
        }
      Qed.

      (* Also, there can be at most one pending job of tsk at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_tsk :
        forall j',
          arrives_in arr_seq j' ->
          pending job_arrival job_cost sched j' t ->
          job_task j' = tsk ->
          j' = j.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO,
               H_valid_task into PARAMS,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk.
        intros j' ARR' PENDING' SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: BACK PENDING' => /andP [/andP [ARRIVED /negP NOTCOMP] NOTSCHED]
                               /andP [ARRIVED' /negP NOTCOMP'].
        destruct (leqP (job_arrival j') (job_arrival j)) as [BEFORE | BEFORE'].
        {
          exploit (SPO j' j DIFF ARR' H_j_arrives); [by rewrite JOBtsk | by done | intro SPO'].
          apply NOTCOMP'.
          apply completion_monotonic with (t0 := job_arrival j' + task_period tsk); try (by done);
            first by apply leq_trans with (n := job_arrival j); [by rewrite -SAMEtsk | by done].
          {
            apply PREVtsk; try (by done).
            apply leq_trans with (n := job_arrival j' + task_period tsk); last by rewrite -SAMEtsk.
            rewrite -addn1; apply leq_add; first by done.
            by unfold is_valid_sporadic_task in *; des.
          }
        }
        {
          unfold has_arrived in *.
          rewrite leqNgt in ARRIVED'; move: ARRIVED' => /negP BUG; apply BUG.
          apply leq_trans with (n := job_arrival j + task_period tsk); first by done.
          by rewrite -JOBtsk; apply SPO; try (by done);
            [by red; ins; subst j' | by rewrite SAMEtsk | by apply ltnW].
        }
      Qed.

      (* Therefore, all processors are busy with tasks other than tsk. *)
      Lemma platform_fp_cpus_busy_with_interfering_tasks :
        count (scheduled_task_with_higher_eq_priority tsk) ts = num_cpus.
      Proof.
        have UNIQ := platform_fp_no_multiple_jobs_of_interfering_tasks.
        have UNIQ' := platform_fp_no_multiple_jobs_of_tsk.
        rename H_all_jobs_from_taskset into FROMTS, H_sequential_jobs into SEQUENTIAL,
               H_work_conserving into WORK, H_respects_JLDP_policy into PRIO,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk,
               H_sporadic_tasks into SPO, H_valid_job_parameters into JOBPARAMS,
               H_valid_task into TASKPARAMS, H_all_previous_jobs_completed into PREV,
               H_completed_jobs_dont_execute into COMP, H_jobs_come_from_arrival_sequence into FROMarr,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_jobs_must_arrive_to_execute into ARRIVE.
        apply work_conserving_eq_work_conserving_count in WORK.
        unfold valid_sporadic_job, valid_realtime_job,
               respects_FP_policy, respects_JLDP_policy, FP_to_JLDP,
               completed_jobs_dont_execute, sequential_jobs,
               sporadic_task_model, is_valid_sporadic_task,
               jobs_of_same_task_dont_execute_in_parallel,
               is_hp_task in *.
        apply/eqP; rewrite eqn_leq; apply/andP; split.
        {
          apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
            first by apply sub_count; red; move => x /andP [SCHED _].
          unfold task_is_scheduled.
          apply count_exists; first by destruct ts.
          {
            intros cpu x1 x2 SCHED1 SCHED2.
            unfold task_scheduled_on in *.
            destruct (sched cpu t); last by done.
            move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
            by rewrite -SCHED1 -SCHED2.
          }
        }
        {
          rewrite -(WORK j t) // -count_predT.
          apply leq_trans with (n := count (fun j =>
            scheduled_task_with_higher_eq_priority tsk (job_task j)) (jobs_scheduled_at sched t));
            last first.
          {
            rewrite -count_map.
            apply leq_trans with (n := count predT [seq x <- (map (fun j => job_task j) (jobs_scheduled_at sched t)) | scheduled_task_with_higher_eq_priority tsk x]);
              first  by rewrite count_filter; apply sub_count; red; ins.
            apply leq_trans with (n := count predT [seq x <- ts | scheduled_task_with_higher_eq_priority tsk x]);
              last by rewrite count_predT size_filter.
            apply count_sub_uniqr; last first.
            {
              red; intros tsk' IN'.
              rewrite mem_filter in IN'; move: IN' => /andP [SCHED IN'].
              rewrite mem_filter; apply/andP; split; first by done.
              move: IN' => /mapP [j' IN'] ->; apply FROMTS.
              by rewrite mem_scheduled_jobs_eq_scheduled in IN'; eauto 2.
            }
            {
              rewrite filter_map.
              rewrite map_inj_in_uniq; first by apply filter_uniq, scheduled_jobs_uniq.
              red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
              rewrite 2!mem_filter in SCHED1 SCHED2.
              move: SCHED1 SCHED2 => /andP [/andP [_ HP1] SCHED1] /andP [/andP [_ HP2] SCHED2].
              rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
              have ARRin1: arrives_in arr_seq j1 by apply (FROMarr j1 t).
              have ARRIn2: arrives_in arr_seq j2 by apply (FROMarr j2 t).
              by apply UNIQ; try (by done); apply scheduled_implies_pending.
            }
          }
          {
            apply sub_in_count; intros j' SCHED' _.
            rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
            apply/andP; split.
            {
              move: SCHED' => /existsP [cpu /eqP SCHED'].
              by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
            }
            apply/andP; split; first by rewrite -JOBtsk; apply PRIO with (t := t).
            {
              apply/eqP; red; intro SAMEtsk.
              generalize SCHED'; intro PENDING'.
              have ARRin': arrives_in arr_seq j' by apply (FROMarr j' t).
              apply scheduled_implies_pending with (job_arrival0 := job_arrival)
                (job_cost0 := job_cost) in PENDING'; try (by done).
              specialize (UNIQ' j' ARRin' PENDING' SAMEtsk); subst j'.
              by move: BACK => /andP [_ NOTSCHED]; rewrite SCHED' in NOTSCHED.
            }
          }
        }
      Qed.

    End NoMultipleJobsFP.

  End Lemmas.

End ConstrainedDeadlines.


Theorem no_intermediate: ~ exists p : Prop, ~ (p <-> True) /\ ~ (p <-> False).
Proof.
  unfold "~". intros H.
  inversion H.
  inversion H0.
  apply H2. unfold "<->".
  split.
  (* left *)
  intros. apply H1.
  split. (* left *)
         intros. exact I.
         (* right *)
         intros. exact H3.
  (* right *)
  intros.
  inversion H3.
Qed.


Require Import Coq.NArith.NArith.
Require Import Coq.Arith.Arith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.Tactics.BreakMatch.
Import ListNotations.

Lemma Permutation_partition {A} (l : list A) f :
    Permutation.Permutation l (fst (partition f l) ++ snd (partition f l)).
Proof using Type.
  induction l; cbn; break_match; cbn in *; eauto.
  etransitivity. econstructor. eassumption.
  eapply Permutation.Permutation_middle.
Qed.

Global Instance fold_right_Proper_commutative_associative_Permutation {A op}
       (Hcomm : forall x y, op x y = op y x)
       (Hassoc : forall x y z, op x (op y z) = op (op x y) z)
  : Proper (eq ==> @Permutation A ==> eq) (fold_right op) | 1000.
Proof using Type.
  intros init init' <- xs ys; induction 1; cbn;
    rewrite ?Hassoc;
    repeat match goal with
           | [ |- context[op ?x ?y] ]
             => lazymatch goal with
                | [ |- context[op y x] ]
                  => rewrite (Hcomm x y)
                end
           end;
    try reflexivity;
    try now repeat match goal with H : _ |- _ => rewrite H; clear H end.
Qed.

Module Nat.
  Global Instance fold_right_Proper_Permutation_add
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Nat.add) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Nat.add_comm | hnf; apply Nat.add_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_mul
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Nat.mul) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Nat.mul_comm | hnf; apply Nat.mul_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_land
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Nat.land) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Nat.land_comm | hnf; apply Nat.land_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_lor
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Nat.lor) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Nat.lor_comm | hnf; apply Nat.lor_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_lxor
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Nat.lxor) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Nat.lxor_comm | hnf; intros; symmetry; apply Nat.lxor_assoc ]. Qed.
End Nat.

Module N.
  Global Instance fold_right_Proper_Permutation_add
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right N.add) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply N.add_comm | hnf; apply N.add_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_mul
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right N.mul) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply N.mul_comm | hnf; apply N.mul_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_land
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right N.land) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply N.land_comm | hnf; apply N.land_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_lor
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right N.lor) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply N.lor_comm | hnf; apply N.lor_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_lxor
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right N.lxor) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply N.lxor_comm | hnf; intros; symmetry; apply N.lxor_assoc ]. Qed.
End N.

Module Z.
  Global Instance fold_right_Proper_Permutation_add
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Z.add) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Z.add_comm | hnf; apply Z.add_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_mul
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Z.mul) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Z.mul_comm | hnf; apply Z.mul_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_land
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Z.land) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Z.land_comm | hnf; apply Z.land_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_lor
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Z.lor) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Z.lor_comm | hnf; apply Z.lor_assoc ]. Qed.

  Global Instance fold_right_Proper_Permutation_lxor
  : Proper (eq ==> @Permutation _ ==> eq) (fold_right Z.lxor) | 100.
  Proof using Type. apply fold_right_Proper_commutative_associative_Permutation; [ hnf; apply Z.lxor_comm | hnf; intros; symmetry; apply Z.lxor_assoc ]. Qed.
End Z.


(** Parametric Transition Matrices **)
Require Import ListSet.
Require Import Reals.
Require Import List.
Require Import SetoidList.

Require Import State.
Require Import TransitionMatrix.Definitions.
Require Import TransitionMatrix.Real.
Require Import RatExpr.
Require Import Probabilities.

Open Scope R_scope.

Definition Var : Type := RatExpr.Var.
Definition Var_eq_dec := RatExpr.Var_eq_dec.

(** ** Variables in the Matrix **)

Fixpoint var_set_list' (l: list (State * RatExpr)): set Var :=
match l with
  | nil       => empty_set Var
  | e :: rest => set_union Var_eq_dec (vars (snd e)) (var_set_list' rest)
end.

Definition var_set' (r: StateMaps.t RatExpr): set Var :=
    var_set_list' (StateMaps.elements r).

Fixpoint var_set_list (l: list (State * StateMaps.t RatExpr)): set Var :=
match l with
  | nil       => empty_set Var
  | e :: rest => set_union Var_eq_dec (var_set' (snd e)) (var_set_list rest)
end.

Definition var_set (m: TransitionMatrix RatExpr): set Var :=
    var_set_list (StateMaps.elements m).

Lemma vars_injection: forall (m: TransitionMatrix RatExpr) (r: StateMaps.t RatExpr) (s: State) (x: Var),
    StateMaps.MapsTo s r m -> In x (var_set' r) -> In x (var_set m).
Proof.
    intros m r s x H_mapsto H_x_in_r.
    unfold var_set.
    apply StateMaps.elements_1 in H_mapsto.
    elim H_mapsto.
    - (* r is the first element *)
      intros.
      red in H. red in H. destruct H as [H_fst H_snd].
      unfold var_set_list.
      rewrite <- H_snd. simpl.
      apply set_union_intro1. assumption.
    - (* r is in the tail of elements list *)
      intros.
      unfold var_set_list.
      apply set_union_intro2. assumption.
Qed.

(** ** Evaluation **)

Definition eval_row (r: StateMaps.t RatExpr) (u: Evaluation) : StateMaps.t R :=
    StateMaps.map (fun val => eval_expr val u) r.

Definition eval_matrix (m: TransitionMatrix RatExpr) (u: Evaluation): TransitionMatrix R :=
    StateMaps.map (fun r => eval_row r u) m.

Definition expr_sum_in_map (m: StateMaps.t RatExpr) : RatExpr :=
    sum_f_in_map m expr_sum (Const 0).

Lemma commutative_eval_elements:
  forall (m: StateMaps.t RatExpr) (u: Evaluation),
      let eval_snd := (fun p => (fst p, eval_expr (snd p) u)) in
      StateMaps.elements (eval_row m u) = map eval_snd (StateMaps.elements m).
Proof.
    intros.
    unfold eval_row. unfold StateMaps.elements. unfold StateMaps.Raw.elements.
    unfold StateMaps.map. simpl.
    induction StateMaps.this.
    - reflexivity.
    - simpl. rewrite IHt.
      destruct a as [k v]. reflexivity.
Qed.

Lemma eval_sum_in_map:
    forall (m: StateMaps.t RatExpr) (u: Evaluation),
        eval_expr (expr_sum_in_map m) u = sum_in_map (eval_row m u).
Proof.
    intros.
    unfold expr_sum_in_map.
    unfold sum_in_map. unfold sum_f_in_map.
    unfold sum_f.
    rewrite commutative_eval_elements.
    induction (StateMaps.elements (elt:=RatExpr) m).
    - (* nil *)
      reflexivity.
    - (* a:: l *)
      rewrite map_cons.
      unfold fold_right. simpl.
      rewrite distributive_eval_sum.
      unfold fold_right in IHl.
      rewrite IHl. reflexivity.
Qed.

Lemma commutative_eval_find:
    forall (m: TransitionMatrix RatExpr) (s: State) (u: Evaluation),
        StateMaps.In s m ->
        StateMaps.find s (eval_matrix m u) = option_map (fun row => eval_row row u) (StateMaps.find s m).
Proof.
    intros m s u H_s_in_m.
    unfold eval_matrix.
    inversion H_s_in_m as [e H_mapsto].
    apply StateMaps.find_1 in H_mapsto. rewrite -> H_mapsto.
    apply StateMaps.find_2 in H_mapsto.
    apply StateMaps.map_1 with (elt':=StateMaps.t R) (f:=fun r : StateMaps.t RatExpr => eval_row r u) in H_mapsto.
    apply StateMaps.find_1 in H_mapsto. rewrite -> H_mapsto.
    unfold option_map. trivial.
Qed.

Lemma commutative_eval_mapsto:
    forall (r: StateMaps.t RatExpr) (s: State) (u: Evaluation) (v: R),
        StateMaps.MapsTo s v (eval_row r u) ->
            ( exists e: RatExpr, StateMaps.MapsTo s e r
              /\ v = eval_expr e u ).
Proof.
    intros.
    assert (H':=H). (* backing H up *)
  (* we first prove that s in (eval_row r u) implies s in r *)
    apply mapsto_in in H.
    apply StateMaps.map_2 in H. rewrite in_mapsto in H.
    destruct H as [e H].
  (* now we have a witness that s in r *)
    exists e.
    split. apply H.
  (* to prove the equality, we rely on results about 'map' *)
    unfold eval_row in H'.
    apply StateMaps.map_1 with (f:=(fun val : RatExpr => eval_expr val u)) in H.
    symmetry. apply (StateMapsFacts.MapsTo_fun H H').
Qed.

Lemma eval_matrix_in:
    forall (m: TransitionMatrix RatExpr) (s: State) (u: Evaluation),
        StateMaps.In s m <-> StateMaps.In s (eval_matrix m u).
Proof.
    intros. unfold eval_matrix.
    split.
    - (* -> *)
      intros.
      rewrite in_mapsto in H. elim H. intros.
      rewrite in_mapsto. exists (eval_row x u).
      apply StateMaps.map_1 with (f:=(fun r : StateMaps.t RatExpr => eval_row r u)).
      apply H0.
    - (* <- *)
      intros. apply (StateMaps.map_2 H).
Qed.

Lemma eval_matrix_mapsto:
    forall (m: TransitionMatrix RatExpr) (s: State) (r: StateMaps.t RatExpr) (u: Evaluation),
        StateMaps.MapsTo s r m -> StateMaps.MapsTo s (eval_row r u) (eval_matrix m u).
Proof.
    intros m s r u. unfold eval_matrix. apply StateMaps.map_1.
Qed.

Lemma eval_matrix_evaluated_expr:
    forall (m: TransitionMatrix RatExpr) (s: State) (r: StateMaps.t R) (u: Evaluation),
        StateMaps.MapsTo s r (eval_matrix m u) ->
            ( exists e: StateMaps.t RatExpr, StateMaps.MapsTo s e m
              /\ r = eval_row e u ).
Proof.
    intros.
    assert (H':=H). (* backing H up *)
  (* we first prove that s in (eval_row r u) implies s in r *)
    apply mapsto_in in H.
    apply StateMaps.map_2 in H. rewrite in_mapsto in H.
    destruct H as [e H].
  (* now we have a witness that s in r *)
    exists e.
    split. apply H.
  (* to prove the equality, we rely on results about 'map' *)
    unfold eval_matrix in H'.
    apply StateMaps.map_1 with (f:=(fun r : StateMaps.t RatExpr => eval_row r u)) in H.
    symmetry. apply (StateMapsFacts.MapsTo_fun H H').
Qed.

Lemma sum_accumulator_commutative (T: Type):
    forall (g: T -> RatExpr)
           (x: RatExpr)
           (l: list T),
        let f := fun (v: T) (e: RatExpr) => expr_sum e (g v) in
        fold_right f x l = expr_sum x (fold_right f (Const 0) l).
Proof.
    intros.
    induction l.
    - simpl. unfold expr_sum.
      destruct x;
          try rewrite Rplus_0_r;
          try rewrite expr_0_identity;
          reflexivity.
    - simpl. rewrite IHl.
      unfold f.
      rewrite expr_sum_associative'.
      trivial.
Qed.

Lemma sum_in_map: forall (r: StateMaps.t RatExpr) (s: State) (e: RatExpr),
    StateMaps.MapsTo s e r ->
    expr_sum_in_map r = expr_sum e (expr_sum_in_map (StateMaps.remove s r)).
Proof.
    intros.
  (* expose elements of r *)
    unfold expr_sum_in_map. unfold sum_f_in_map.
    unfold sum_f.
  (* now we manipulate the list of elements to expose (s, e) *)
    assert (H':=H). (* backup *)
    apply StateMaps.elements_1 in H.
    apply SetoidList.InA_split in H.
    destruct H as [l1 [a [l2 [H_eq_a H_elem]]]].
    rewrite H_elem.
    rewrite remove_elements' with (e:=e) (l1:=l1) (l2:=l2) (a:=a); try assumption.
  (* finally, let us leverage sums and folds commutative and
     associative properties *)
    rewrite fold_right_app.
    unfold fold_right at 2.
    rewrite expr_sum_commutative'.
    rewrite sum_accumulator_commutative.
    rewrite <- expr_sum_associative'.
    replace
        ((fix fold_right (l : list (StateMaps.key * RatExpr)) : RatExpr :=
           match l with
           | Datatypes.nil => Const 0
           | b :: t => expr_sum (fold_right t) (snd b)
           end) l2)
      with
        (fold_right
          (fun (v : StateMaps.key * RatExpr) (e0 : RatExpr) =>
           expr_sum e0 (snd v)) (Const 0) l2).
      Focus 2. unfold fold_right. trivial.
    rewrite <- sum_accumulator_commutative.
    rewrite <- fold_right_app.
  (* e = snd a *)
    unfold StateMaps.eq_key_elt, StateMaps.Raw.PX.eqke in H_eq_a.
    simpl in H_eq_a.
    destruct H_eq_a as [_ H_e].
    rewrite H_e.
    trivial.
Qed.

Lemma sum_zero_in_map:
    forall (r: StateMaps.t RatExpr),
        (forall s: State, StateMaps.In s r -> StateMaps.MapsTo s (Const 0) r) ->
            expr_sum_in_map r = Const 0.
Proof.
    intros.
    unfold expr_sum_in_map. unfold sum_f_in_map.
    assert (H':
        (forall s: State, StateMaps.In s r -> StateMaps.MapsTo s (Const 0) r ) ->
          (forall p: State * RatExpr, (In p (StateMaps.elements r)) -> snd p = Const 0)).
    {
        intros.
        specialize (H0 (fst p)).
        apply SetoidList.In_InA with (eqA:=StateMaps.eq_key_elt (elt:=RatExpr)) in H1.
        - destruct p as [s e].
          apply StateMaps.elements_2 in H1. assert (H':= H1).
          simpl in H0.
          apply mapsto_in in H1. apply H0 in H1.
          apply StateMapsFacts.MapsTo_fun with (e':=Const 0) (e:=e) in H1.
          + auto.
          + assumption.
        - exact (StateMapsProperties.eqke_equiv RatExpr).
    }
    induction (StateMaps.elements (elt:=RatExpr) r).
    - (* empty list *)
      reflexivity.
    - (* a::l *)
      eapply H' in H.
      + (* main goal *)
        unfold sum_f. unfold fold_right.
        unfold sum_f in IHl. unfold fold_right in IHl.
        rewrite IHl.
        * rewrite H. simpl. rewrite Rplus_0_r. reflexivity.
        * intros.
          { apply H' with (p:=p) in H0.
            - assumption.
            - apply in_cons. assumption.
          }
      + (* proof obligation *)
        apply in_eq.
Qed.

(** ** Evaluation and stochasticity **)
Definition expr_is_stochastic_row (r: StateMaps.t RatExpr) : Prop :=
    (forall (s: State) (e: RatExpr), StateMaps.MapsTo s e r -> expr_is_valid_prob e)
    /\ expr_sum_in_map r = Const 1.

Lemma eval_stochastic_row:
    forall (r: StateMaps.t RatExpr) (u: Evaluation),
        expr_is_stochastic_row r -> is_stochastic_row (eval_row r u).
Proof.
    intros.
    unfold expr_is_stochastic_row in H.
    destruct H as [H_valid_prob H_sum_1].
    unfold is_stochastic_row. split.
    - (* all values are valid probabilities *)
      intros.
      apply commutative_eval_mapsto in H.
      inversion H as [e [H_s_mapsto_e H_v_eval_e]].
      apply H_valid_prob in H_s_mapsto_e.
      rewrite H_v_eval_e.
      apply valid_prob_preservation. assumption.
    - (* sum is 1 *)
      rewrite <- eval_sum_in_map.
      rewrite H_sum_1. reflexivity.
Qed.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Reduction from:
    Left-uniform Two-Inequality Semi-unification (LU2SemiU)
  to:
    System F Typability (SysF_TYP)

  Related Work:
  [1] Wells, Joe B. "Typability and Type-Checking in the Second-Order lambda-Calculus are Equivalent and Undecidable."
      Proceedings Ninth Annual IEEE Symposium on Logic In Computer Science. IEEE, 1994.
*)

Require Import List Lia.
Import ListNotations.
Require Import Undecidability.SystemF.SysF Undecidability.SystemF.Autosubst.syntax.
From Undecidability.SystemF.Util Require Import Facts poly_type_facts pure_term_facts term_facts typing_facts pure_typing_facts pure_typable_prenex.

Require Undecidability.SemiUnification.SemiU.
Module SU := SemiU.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Module Argument.
Section LU2SemiU_to_SysF_TYP.

Variables SUs SUt0 SUt1 : SU.term. (* semi-unification instance *)

(* construct polymorphic type from semi-unification term *)
Fixpoint SU_term_to_poly_type (s: SU.term) :=
  match s with
  | SU.atom n => poly_var n
  | SU.arr s t => poly_arr (SU_term_to_poly_type s) (SU_term_to_poly_type t)
  end.

Definition SUs' := SU_term_to_poly_type SUs.
Definition SUt0' := SU_term_to_poly_type SUt0.
Definition SUt1' := SU_term_to_poly_type SUt1.

Definition N_W := pure_abs (many_pure_app (pure_var 2) [pure_var 0; pure_var 0]).
(* x (\z.y z z) as given by Wells *)
Definition M_W : pure_term := many_pure_app (pure_var 0) [N_W].

Definition t_0_W := (poly_arr (poly_arr (poly_var 0) (poly_var 0)) (poly_var 1)).
Definition t_1_W := poly_arr (poly_arr SUt0' SUt0') (poly_arr (poly_arr SUt1' SUt1') (poly_arr SUs' SUs')).
Definition n_W : nat := locked (poly_var_bound t_1_W).
(* similar to Wells' construction
 ∀((α -> α) -> β) ;
 ∀ .. ∀ (t1 -> t1) -> (t2 -> t2) -> (s -> s) *)
Definition Gamma_W : list poly_type := [poly_abs (poly_abs t_0_W); many_poly_abs n_W t_1_W].

Lemma is_simple_SU_term_to_poly_type {s} : is_simple (SU_term_to_poly_type s) <-> True.
Proof. elim: s; [done | by move=> /= ? + ? + => -> ->]. Qed.

Lemma is_simple_t_1_W : is_simple t_1_W.
Proof.
  by rewrite /t_1_W /= /SUt0' /SUt1' /SUs' ?is_simple_SU_term_to_poly_type.
Qed.

Lemma closed_t_1_W : allfv_poly_type (gt n_W) t_1_W.
Proof. rewrite /n_W -lock. by apply: poly_var_boundP. Qed.

Lemma is_simple_t_0_W : is_simple t_0_W.
Proof. done. Qed.

Lemma closed_t_0_W : allfv_poly_type (gt 2) t_0_W.
Proof. move=> /=. by lia. Qed.

(* introduce assumption poly_abs (poly_abs t_0_W) *)
Definition HM_W1 := pure_typable_intro_prenex M_W t_0_W 2 is_simple_t_0_W closed_t_0_W.

(* introduce assumption many_poly_abs n_W t_1_W *)
Definition HM_W2 := pure_typable_intro_prenex (sval HM_W1) t_1_W n_W is_simple_t_1_W closed_t_1_W.

Lemma SysF_TYPI Gamma {M} : pure_typable Gamma M -> SysF_TYP M.
Proof. move=> [t] /pure_typing_iff_type_assignment ?. by exists Gamma, t. Qed.

Lemma prenex_Gamma_W :
  Forall (fun t => exists n s, t = many_poly_abs n s /\ is_simple s /\ allfv_poly_type (gt n) s) Gamma_W.
Proof.
  apply /Forall_cons_iff. constructor.
  { exists 2, t_0_W. constructor; [done | constructor; [done | by move=> /=; lia ]]. }
  apply /Forall_cons_iff. constructor; last done.
  do 2 eexists. constructor; first by reflexivity.
  by constructor; [apply: is_simple_t_1_W | apply: closed_t_1_W ].
Qed.

(* if Gamma_W ⊢ M_W : poly_var 0 typechecks, then the semi-unification instance (SUs, SUt0, SUt1) is solvable *)
Section InverseTransport.
Local Arguments many_pure_app : simpl never.
Local Arguments map : simpl never.

Lemma map_ren_poly_type_Gamma_W {ξ}: map (ren_poly_type ξ) Gamma_W = Gamma_W.
Proof.
  congr cons. congr cons. apply: ren_poly_type_closed_id.
  rewrite allfv_poly_type_many_poly_abs.
  apply: allfv_poly_type_impl closed_t_1_W.
  move=> ? ?. rewrite iter_scons_lt; by [|lia].
Qed.

(* decompose first layer of Wells' type checking term *)
Lemma decompose_M_W : pure_typable Gamma_W M_W ->
  exists s, pure_typing Gamma_W N_W (poly_arr s s).
Proof.
  move=> [?] /pure_typingE /= [?] [?] [?] [?] [+] [+] [_ ?].
  move=> /pure_typingE' [?] [[?]]. subst.
  move=> /(contains_poly_arrE (n := 2)) [?] [?] [? ?]. subst.
  rewrite map_ren_poly_type_Gamma_W => ?. eexists. by eassumption.
Qed.

(* decompose second layer of Wells' type checking term *)
Lemma decompose_N_W {s} : pure_typing Gamma_W N_W (poly_arr s s) ->
  exists n σ,
    s = many_poly_abs n (subst_poly_type σ (poly_arr SUs' SUs')) /\
    pure_typing (map (ren_poly_type (Nat.add n)) (s :: Gamma_W)) (pure_var 0) (subst_poly_type σ (poly_arr SUt0' SUt0')) /\
    pure_typing (map (ren_poly_type (Nat.add n)) (s :: Gamma_W)) (pure_var 0) (subst_poly_type σ (poly_arr SUt1' SUt1')).
Proof.
  move=> /pure_typingE' /=.
  move=> /pure_typingE /= [n1] [?] [?] [?] [+] [+] [H1C ?].
  move=> /pure_typingE' [?] [?] [+] [+ H2C].
  move=> /pure_typingE' [?] [[?]] H3C. subst.
  move=> H1 H2.
  move: H3C. rewrite ren_poly_type_many_poly_abs /t_1_W /=.
  move=> /contains_poly_arrE [?] [?] [? ?]. subst.
  move: H2C => /containsE [? ?]. subst.
  move: H1C => /containsE ?. subst.
  do 2 eexists.
  constructor; first by rewrite ?poly_type_norm.
  constructor; [move: H1 | move: H2]; by rewrite ?poly_type_norm.
Qed.

(* decompose third layer of Wells' type checking term *)
Lemma decompose_x_W {n σ Gamma s' t'} :
  let s := many_poly_abs n (subst_poly_type σ (poly_arr s' s')) in
  pure_typing ((ren_poly_type (Nat.add n) s) :: Gamma) (pure_var 0) (subst_poly_type σ (poly_arr t' t')) ->
  exists τ, subst_poly_type (funcomp (subst_poly_type τ) σ) s' = subst_poly_type σ t'.
Proof.
  move=> /= /pure_typingE' /= [?] [[?]]. subst.
  rewrite ren_poly_type_many_poly_abs /=.
  move=> /contains_poly_arrE [?] [?] [-> _].
  rewrite ?poly_type_norm. by eexists.
Qed.

(* construct semi-unification term from a polymorphic type pruning quantification *)
Fixpoint prune (s: poly_type) : SU.term :=
  match s with
  | poly_var x => SU.atom (1 + x)
  | poly_arr s t => SU.arr (prune s) (prune t)
  | poly_abs _ => SU.atom 0
  end.

Fact substitute_prune_ex τ t : exists ψ, SU.substitute ψ (prune t) = prune (subst_poly_type τ t).
Proof.
  exists (fun n=> if n is S n then prune (τ n) else SU.atom 0).
  elim: t; [done | by move=> ? + ? /= => -> -> | done ].
Qed.

Fact substitute_prune {σ t} :
  SU.substitute (funcomp prune σ) t = prune (subst_poly_type σ (SU_term_to_poly_type t)).
Proof. elim: t; [done | by move=> ? + ? => /= -> -> ]. Qed.

(* construct semi-unification valuations from polymorphic substitutions *)
Lemma introduce_simple_substitutions {s t σ τ} :
  subst_poly_type (funcomp (subst_poly_type τ) σ) (SU_term_to_poly_type s) = subst_poly_type σ (SU_term_to_poly_type t) ->
  exists ψ, SU.substitute ψ (SU.substitute (funcomp prune σ) s) = SU.substitute (funcomp prune σ) t.
Proof.
  move=> H. have [ψ Hψ] := substitute_prune_ex τ (subst_poly_type σ (SU_term_to_poly_type s)).
  exists ψ. by rewrite ?substitute_prune Hψ -H poly_type_norm.
Qed.

End InverseTransport.

(* typability to semi-unification solution *)
Lemma inverse_transport : SysF_TYP (sval HM_W2) -> SU.LU2SemiU (SUs, SUt0, SUt1).
Proof.
  move=> [Gamma] [t] /pure_typing_iff_type_assignment.
  move=> /pure_typing_tidyI /pure_typableI /(svalP HM_W2) /(svalP HM_W1).
  move=> [?] /(pure_typing_ren_pure_term_allfv_pure_term id (Delta := map tidy Gamma_W)).
  apply: unnest; first done. rewrite ren_pure_term_id => /pure_typableI.
  move=> /(pure_typable_tidy_iff (Gamma1 := [])). apply: unnest; first by apply: prenex_Gamma_W.
  move=> /decompose_M_W [?] /decompose_N_W [?] [σ] [->].
  move=> [/decompose_x_W [?] + /decompose_x_W [?] +].
  move=> /introduce_simple_substitutions [ψ0 ?] /introduce_simple_substitutions [ψ1 ?].
  by exists (funcomp prune σ), ψ0, ψ1.
Qed.

(* if the semi-unification instance (SUs, SUt0, SUt1) is solvable, then Gamma_W ⊢ M_W : poly_var 0 typechecks *)
Section Transport.

(* semi-unification solution *)
Variables φ ψ0 ψ1 : nat -> SU.term.
Variable Hφψ0 : SU.substitute ψ0 (SU.substitute φ SUs) = SU.substitute φ SUt0.
Variable Hφψ1 : SU.substitute ψ1 (SU.substitute φ SUs) = SU.substitute φ SUt1.

Definition t_x_W' := SU_term_to_poly_type (SU.substitute φ SUs).
Definition n_W' := locked (poly_var_bound (poly_arr t_x_W' t_x_W')).
Definition t_x_W : poly_type := many_poly_abs n_W' (poly_arr t_x_W' t_x_W').

Definition t_x_0_W : poly_type := SU_term_to_poly_type (SU.substitute φ SUt0).
Definition t_x_1_W : poly_type := SU_term_to_poly_type (SU.substitute φ SUt1).

Definition ts_0_W : list poly_type := map (fun n => SU_term_to_poly_type (φ n)) (rev (seq 0 n_W)).
Definition ts_1_W : list poly_type := map (fun n => SU_term_to_poly_type (ψ0 n)) (rev (seq 0 n_W')).
Definition ts_2_W : list poly_type := map (fun n => SU_term_to_poly_type (ψ1 n)) (rev (seq 0 n_W')).

Definition x_1_W : term := many_ty_app (var 0) ts_1_W.
Definition x_2_W : term := many_ty_app (var 0) ts_2_W.
Definition Q_W : term := abs t_x_W (many_ty_abs n_W' (app (app (many_ty_app (var 2) ts_0_W) x_1_W) x_2_W)).
(* correctly annotated M_W, similar to Wells' construction *)
Definition P_W : term := app (ty_app (ty_app (var 0) (poly_var 0)) t_x_W) Q_W.

Fact poly_var_bound_SUt0'_n_W : poly_var_bound SUt0' < n_W.
Proof. rewrite /n_W /t_1_W /= -lock. by lia. Qed.

Fact poly_var_bound_SUt1'_n_W : poly_var_bound SUt1' < n_W.
Proof. rewrite /n_W /t_1_W /= -lock. by lia. Qed.

Fact poly_var_bound_SUs'_n_W : poly_var_bound SUs' < n_W.
Proof. rewrite /n_W /t_1_W /= -lock. by lia. Qed.

Lemma SU_term_to_poly_type_SU_substitute {ζ t} :
  subst_poly_type (fun x : nat => SU_term_to_poly_type (ζ x)) (SU_term_to_poly_type t) =
    SU_term_to_poly_type (SU.substitute ζ t).
Proof. elim: t; [done | by move=> /= ? -> ? ->]. Qed.

Lemma subst_poly_type_SU_term_to_poly_type {ζ n t} :
  poly_var_bound (SU_term_to_poly_type t) < n ->
  subst_poly_type
    (fold_right scons poly_var (map (fun x => SU_term_to_poly_type (ζ x)) (seq 0 n)))
    (SU_term_to_poly_type t) =
  SU_term_to_poly_type (SU.substitute ζ t).
Proof.
  move=> ?. rewrite subst_poly_type_map_seq; first by lia.
  by apply: SU_term_to_poly_type_SU_substitute.
Qed.

Fact poly_arr_eq_eq {s t} : s = t -> poly_arr s s = poly_arr t t.
Proof. by move=> ->. Qed.

Lemma typing_x_1_W :
  (forall Gamma, typing (many_poly_abs n_W' (poly_arr t_x_W' t_x_W') :: Gamma) x_1_W (poly_arr t_x_0_W t_x_0_W)).
Proof using Hφψ0.
  move=> Gamma. rewrite /x_1_W. evar (t: poly_type).
  have := @typing_var (many_poly_abs n_W' (poly_arr t_x_W' t_x_W') :: Gamma) 0 t.
  subst t. move=> /(_ ltac:(reflexivity)) /typing_many_ty_appI => /(_ ts_1_W).
  apply: unnest. { by rewrite /ts_1_W map_length rev_length seq_length. }
  congr typing => /=. apply: poly_arr_eq_eq. rewrite /ts_1_W /t_x_W' /t_x_0_W -Hφψ0.
  rewrite -map_rev rev_involutive. apply: subst_poly_type_SU_term_to_poly_type.
  rewrite /n_W' /t_x_W' -lock /=. by lia.
Qed.

Lemma typing_x_2_W :
  (forall Gamma, typing (many_poly_abs n_W' (poly_arr t_x_W' t_x_W') :: Gamma) x_2_W (poly_arr t_x_1_W t_x_1_W)).
Proof using Hφψ1.
  move=> Gamma. rewrite /x_2_W. evar (t: poly_type).
  have := @typing_var (many_poly_abs n_W' (poly_arr t_x_W' t_x_W') :: Gamma) 0 t.
  subst t. move=> /(_ ltac:(reflexivity)) => /typing_many_ty_appI => /(_ ts_2_W).
  apply: unnest. { by rewrite /ts_2_W map_length rev_length seq_length. }
  congr typing => /=. apply: poly_arr_eq_eq. rewrite /ts_2_W /t_x_W' /t_x_1_W -Hφψ1.
  rewrite -map_rev rev_involutive. apply: subst_poly_type_SU_term_to_poly_type.
  rewrite /n_W' /t_x_W' -lock /=. by lia.
Qed.

Lemma typing_Q_W :
  (forall Gamma, typing (many_poly_abs n_W' (poly_arr t_x_W' t_x_W') :: Gamma) x_1_W (poly_arr t_x_0_W t_x_0_W)) ->
  (forall Gamma, typing (many_poly_abs n_W' (poly_arr t_x_W' t_x_W') :: Gamma) x_2_W (poly_arr t_x_1_W t_x_1_W)) ->
  typing Gamma_W Q_W (poly_arr t_x_W t_x_W).
Proof.
  move=> H1 H2.
  apply /typing_abs /typing_many_ty_absI.
  apply: (typing_app (s := (poly_arr t_x_1_W t_x_1_W))); [apply: (typing_app (s := (poly_arr t_x_0_W t_x_0_W))) |].
  - evar (t : poly_type).
    have := @typing_var (map (ren_poly_type (Nat.add n_W')) (t_x_W :: Gamma_W)) 2 t.
    subst t. move=> /(_ ltac:(reflexivity)).
    rewrite ren_poly_type_many_poly_abs.
    move /typing_many_ty_appI => /(_ ts_0_W). apply: unnest.
    { by rewrite /ts_0_W map_length rev_length seq_length. }
    congr typing. rewrite /t_1_W /= -map_rev rev_involutive.
    congr poly_arr; [| congr poly_arr]; apply: poly_arr_eq_eq.
    + have := poly_var_bound_SUt0'_n_W. rewrite /t_x_0_W /SUt0' /ts_0_W.
      move=> ?. rewrite ren_poly_type_poly_var_bound; first by lia.
      by apply: subst_poly_type_SU_term_to_poly_type.
    + have := poly_var_bound_SUt1'_n_W. rewrite /t_x_1_W /SUt1' /ts_0_W.
      move=> ?. rewrite ren_poly_type_poly_var_bound; first by lia.
      by apply: subst_poly_type_SU_term_to_poly_type.
    + have := poly_var_bound_SUs'_n_W. rewrite /t_x_W' /SUs' /ts_0_W.
      move=> ?. rewrite ren_poly_type_poly_var_bound; first by lia.
      by apply: subst_poly_type_SU_term_to_poly_type.
  - rewrite /(map _ (_ :: _)) -/(map _ _). move: (map _ Gamma_W) => Gamma.
    rewrite /t_x_W ren_poly_type_many_poly_abs ren_poly_type_poly_var_bound;
      first by (rewrite /n_W' -lock /=; lia).
    by apply: H1.
  - rewrite /(map _ (_ :: _)) -/(map _ _). move: (map _ Gamma_W) => Gamma.
    rewrite /t_x_W ren_poly_type_many_poly_abs ren_poly_type_poly_var_bound;
      first by (rewrite /n_W' -lock /=; lia).
    by apply: H2.
Qed.

Lemma erase_P_W : erase P_W = M_W.
Proof.
  by rewrite /P_W /= erase_many_ty_abs /= /x_1_W /x_2_W ?erase_many_ty_app.
Qed.

Lemma typing_P_W :
  typing Gamma_W Q_W (poly_arr t_x_W t_x_W) ->
  typing Gamma_W P_W (poly_var 0).
Proof.
  rewrite /P_W. apply: typing_app.
  apply: typing_ty_appI; [apply: typing_ty_appI |]; [by apply: typing_var | done | done].
Qed.

Lemma pure_typable_M_W :
  typing Gamma_W P_W (poly_var 0) ->
  pure_typable Gamma_W M_W.
Proof.
  move=> /typing_to_pure_typing /pure_typableI. by rewrite erase_P_W.
Qed.

End Transport.

(* semi-unification solution to typability *)
Lemma transport : SU.LU2SemiU (SUs, SUt0, SUt1) -> SysF_TYP (sval HM_W2).
Proof.
  move=> [φ] [ψ0] [ψ1] [Hφψ0 HHφψ1]. apply: (SysF_TYPI (map tidy [])).
  apply /(svalP HM_W2) /(svalP HM_W1).
  have := iffRL (pure_typable_tidy_iff _ (Gamma1 := [])).
  move=> /(_ [many_poly_abs 2 t_0_W; many_poly_abs n_W t_1_W]).
  apply; first by apply: prenex_Gamma_W.
  apply: (pure_typable_M_W φ ψ0 ψ1).
  apply: typing_P_W.
  apply: typing_Q_W; [apply: typing_x_1_W | apply: typing_x_2_W]; by eassumption.
Qed.

End LU2SemiU_to_SysF_TYP.
End Argument.

Require Import Undecidability.Synthetic.Definitions.
Import SemiU.

(* Left-uniform Two-Inequality Semi-unification many-one reduces to System F Typability *)
Theorem reduction : LU2SemiU ⪯ SysF_TYP.
Proof.
  exists (fun '(s, t0, t1) => (sval (Argument.HM_W2 s t0 t1))).
  move=> [[s t0] t1]. constructor.
  - exact: Argument.transport.
  - exact: Argument.inverse_transport.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require Reals.Rbasic_fun.
Require Reals.Rtrigo_def.
Require Reals.Rtrigo1.
Require Reals.Ratan.
Require BuiltIn.
Require real.Real.
Require real.Abs.
Require real.Square.

Require Import Reals.

(* Why3 comment *)
(* cos is replaced with (Reals.Rtrigo_def.cos x) by the coq driver *)

(* Why3 comment *)
(* sin is replaced with (Reals.Rtrigo_def.sin x) by the coq driver *)

(* Why3 goal *)
Lemma Pythagorean_identity : forall (x:R),
  (((Reals.RIneq.Rsqr (Reals.Rtrigo_def.cos x)) + (Reals.RIneq.Rsqr (Reals.Rtrigo_def.sin x)))%R = 1%R).
Proof.
intros x.
rewrite Rplus_comm.
apply sin2_cos2.
Qed.

(* Why3 goal *)
Lemma Cos_le_one : forall (x:R),
  ((Reals.Rbasic_fun.Rabs (Reals.Rtrigo_def.cos x)) <= 1%R)%R.
Proof.
intros x.
apply Abs.Abs_le.
apply COS_bound.
Qed.

(* Why3 goal *)
Lemma Sin_le_one : forall (x:R),
  ((Reals.Rbasic_fun.Rabs (Reals.Rtrigo_def.sin x)) <= 1%R)%R.
Proof.
intros x.
apply Abs.Abs_le.
apply SIN_bound.
Qed.

(* Why3 goal *)
Lemma Cos_0 : ((Reals.Rtrigo_def.cos 0%R) = 1%R).
Proof.
apply cos_0.
Qed.

(* Why3 goal *)
Lemma Sin_0 : ((Reals.Rtrigo_def.sin 0%R) = 0%R).
Proof.
apply sin_0.
Qed.

(* Why3 comment *)
(* pi is replaced with Reals.Rtrigo1.PI by the coq driver *)

(* Why3 goal *)
Lemma Pi_interval : ((314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196 / 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%R < Reals.Rtrigo1.PI)%R /\
  (Reals.Rtrigo1.PI < (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038197 / 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%R)%R.
Proof.
replace PI with (4 * (PI / 4))%R by field.
rewrite <- atan_1.
admit. (* to avoid a dependency on CoqInterval *)
(* split ; interval with (i_prec 680). *)
Qed.

(* Why3 goal *)
Lemma Cos_pi : ((Reals.Rtrigo_def.cos Reals.Rtrigo1.PI) = (-1%R)%R).
Proof.
apply cos_PI.
Qed.

(* Why3 goal *)
Lemma Sin_pi : ((Reals.Rtrigo_def.sin Reals.Rtrigo1.PI) = 0%R).
Proof.
apply sin_PI.
Qed.

(* Why3 goal *)
Lemma Cos_pi2 : ((Reals.Rtrigo_def.cos ((05 / 10)%R * Reals.Rtrigo1.PI)%R) = 0%R).
Proof.
replace (5 / 10 * PI)%R with (PI / 2)%R by field.
apply cos_PI2.
Qed.

(* Why3 goal *)
Lemma Sin_pi2 : ((Reals.Rtrigo_def.sin ((05 / 10)%R * Reals.Rtrigo1.PI)%R) = 1%R).
Proof.
replace (5 / 10 * PI)%R with (PI / 2)%R by field.
apply sin_PI2.
Qed.

(* Why3 goal *)
Lemma Cos_plus_pi : forall (x:R),
  ((Reals.Rtrigo_def.cos (x + Reals.Rtrigo1.PI)%R) = (-(Reals.Rtrigo_def.cos x))%R).
Proof.
intros x.
apply neg_cos.
Qed.

(* Why3 goal *)
Lemma Sin_plus_pi : forall (x:R),
  ((Reals.Rtrigo_def.sin (x + Reals.Rtrigo1.PI)%R) = (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
apply neg_sin.
Qed.

(* Why3 goal *)
Lemma Cos_plus_pi2 : forall (x:R),
  ((Reals.Rtrigo_def.cos (x + ((05 / 10)%R * Reals.Rtrigo1.PI)%R)%R) = (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
rewrite cos_sin.
replace (PI / 2 + (x + 5 / 10 * PI))%R with (x + PI)%R by field.
apply neg_sin.
Qed.

(* Why3 goal *)
Lemma Sin_plus_pi2 : forall (x:R),
  ((Reals.Rtrigo_def.sin (x + ((05 / 10)%R * Reals.Rtrigo1.PI)%R)%R) = (Reals.Rtrigo_def.cos x)).
Proof.
intros x.
rewrite cos_sin.
apply f_equal.
field.
Qed.

(* Why3 goal *)
Lemma Cos_neg : forall (x:R),
  ((Reals.Rtrigo_def.cos (-x)%R) = (Reals.Rtrigo_def.cos x)).
Proof.
intros x.
apply cos_neg.
Qed.

(* Why3 goal *)
Lemma Sin_neg : forall (x:R),
  ((Reals.Rtrigo_def.sin (-x)%R) = (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
apply sin_neg.
Qed.

(* Why3 goal *)
Lemma Cos_sum : forall (x:R) (y:R),
  ((Reals.Rtrigo_def.cos (x + y)%R) = (((Reals.Rtrigo_def.cos x) * (Reals.Rtrigo_def.cos y))%R - ((Reals.Rtrigo_def.sin x) * (Reals.Rtrigo_def.sin y))%R)%R).
Proof.
intros x y.
apply cos_plus.
Qed.

(* Why3 goal *)
Lemma Sin_sum : forall (x:R) (y:R),
  ((Reals.Rtrigo_def.sin (x + y)%R) = (((Reals.Rtrigo_def.sin x) * (Reals.Rtrigo_def.cos y))%R + ((Reals.Rtrigo_def.cos x) * (Reals.Rtrigo_def.sin y))%R)%R).
Proof.
intros x y.
apply sin_plus.
Qed.

(* Why3 goal *)
Lemma tan_def : forall (x:R),
  ((Reals.Rtrigo1.tan x) = ((Reals.Rtrigo_def.sin x) / (Reals.Rtrigo_def.cos x))%R).
Proof.
intros x.
apply eq_refl.
Qed.

(* Why3 comment *)
(* atan is replaced with (Reals.Ratan.atan x) by the coq driver *)

(* Why3 goal *)
Lemma Tan_atan : forall (x:R),
  ((Reals.Rtrigo1.tan (Reals.Ratan.atan x)) = x).
Proof.
intros x.
apply atan_right_inv.
Qed.