Inductive 𝔻 : Type :=
  pair : 𝔻 -> 𝔻 -> 𝔻
| fst : 𝔻 -> 𝔻
| snd : 𝔻 -> 𝔻
| ax : 𝔻
| unit : 𝔻.

Inductive judgment : Type :=
  eq : 𝔻 -> 𝔻 -> 𝔻 -> judgment
| prop : 𝔻 -> judgment
| ver : 𝔻 -> judgment
| eval : 𝔻 -> 𝔻 -> judgment
| hyp : judgment -> judgment -> judgment.

Notation "M = N ∈ A" := (eq A M N) (at level 100).
Notation "M ⇓ N" := (eval M N) (right associativity, at level 60).
Notation "N ⇐ M" := (hyp M N) (right associativity, at level 60).

Open Scope core_scope.

Module Meaning.
  Record t : Type :=
    {presupposition : Type;
     meaning : presupposition -> Type}.
End Meaning.

Module Evidence.
  Record t (m : Meaning.t) : Type :=
    {presupposition : Meaning.presupposition m;
     meaning : Meaning.meaning m presupposition}.
End Evidence.

Module PER.
  Record t (D : Type) : Type :=
    {relation : D -> D -> Type;
     symmetric : forall M N, relation M N -> relation N M;
     transitive : forall M N O, relation M N -> relation N O -> relation M O}.
End PER.

Inductive evals : 𝔻 -> 𝔻 -> Type :=
  pairCanon : forall {M N}, evals (pair M N) (pair M N)
| axCanon : evals ax ax
| unitCanon : evals unit unit
| fstEval : forall {MN M N M'}, evals MN (pair M N) -> evals M M' -> evals (fst MN) M'
| sndEval : forall {MN M N N'}, evals MN (pair M N) -> evals N N' -> evals (snd MN) N'.

Hint Resolve pairCanon axCanon fstEval sndEval unitCanon.

Inductive unitRelation : 𝔻 -> 𝔻 -> Type :=
  unitAx : unitRelation ax ax.

Hint Resolve unitAx.

Ltac invert_unitRelation :=
  match goal with
    [H : unitRelation _ _ |- _] => inversion H; clear H
  end.

Theorem unitPer : PER.t 𝔻.
Proof.
  split with unitRelation; intuition;
  repeat invert_unitRelation; eauto.
Defined.

Fixpoint denotes (A : 𝔻) (R : PER.t 𝔻) : Type :=
  match A with
    unit => R = unitPer
  | _ => False
  end.

Open Scope type_scope.

Definition isProp (P : 𝔻) :=
  {P' : 𝔻 & evals P P' & { R : PER.t 𝔻 & denotes P' R}}.

Fixpoint presupposition (J : judgment) : Type :=
  match J with
    relates A M N => isProp A
  | eq A M N => isProp A
  | ver A => isProp A
  | hyp J1 J2 => presupposition J1 * presupposition J2
  | _ => True
  end.

Fixpoint meaning (J : judgment) : presupposition J -> Type.
Proof.
  induction J.

  (* M ~ N @ A *)
  + intro p; destruct p as [P' _ [[R _ _] _]].
    exact {M : 𝔻 & {N : 𝔻 & (evals 𝔻0 M * evals 𝔻1 N) & R M N }}.

  (* A prop *)
  + intro p; exact (isProp 𝔻0).

  (* A ver *)
  + intro p; destruct p as [P' _ [[R _ _] _]].
    exact {M : 𝔻 & R M M}.

  (* M ⇒ N *)
  + intro p; exact (evals 𝔻0 𝔻1).

  (* J2 (J1) *)
  + intro p; destruct p as [p1 p2].
    exact (IHJ1 p1 -> IHJ2 p2).
Defined.

Definition evident (J : judgment) : Type :=
  {p : presupposition J & meaning J p}.

Notation "⊨ J" := (evident J) (right associativity, at level 90).

Lemma test : ⊨ fst (pair ax ax) ⇓ ax.
Proof.
  compute; eauto.
Qed.

Ltac invert_evals :=
  match goal with
    [H : evals _ _ |- _] => inversion H
  end.

Lemma welp : ⊨ (fst ax ⇓ ax) ⇐ (ax ⇓ pair ax ax).
Proof.
  compute; split with (I, I); intro.
  invert_evals.
Qed.

Lemma unitIsProp : ⊨ prop (fst (pair unit ax)).
Proof.
  compute; split; eauto.
Qed.


(** * ImpCEvalFun: Evaluation Function for Imp *)

(** We saw in the [Imp] chapter how a naive approach to defining a
    function representing evaluation for Imp runs into difficulties.
    There, we adopted the solution of changing from a functional to a
    relational definition of evaluation.  In this optional chapter, we
    consider strategies for getting the functional approach to
    work. *)

(* ################################################################# *)
(** * A Broken Evaluator *)

(* IMPORTS *)
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Arith.
Require Import Imp.
Require Import Maps.
(* /IMPORTS *)

(** Here was our first try at an evaluation function for commands,
    omitting [WHILE]. *)

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        t_update st l (aeval st a1)
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st  (* bogus *)
  end.

(** As we remarked in chapter [Imp], in a traditional functional
    programming language like ML or Haskell we could write the WHILE
    case as follows:

    | WHILE b1 DO c1 END => if (beval st b1) then ceval_step1 st (c1;;
        WHILE b1 DO c1 END) else st

    Coq doesn't accept such a definition ([Error: Cannot guess
    decreasing argument of fix]) because the function we want to
    define is not guaranteed to terminate. Indeed, the changed
    [ceval_step1] function applied to the [loop] program from [Imp.v]
    would never terminate. Since Coq is not just a functional
    programming language, but also a consistent logic, any potentially
    non-terminating function needs to be rejected. Here is an
    invalid(!) Coq program showing what would go wrong if Coq allowed
    non-terminating recursive functions:

     Fixpoint loop_false (n : nat) : False := loop_false n.

    That is, propositions like [False] would become
    provable (e.g., [loop_false 0] would be a proof of [False]), which
    would be a disaster for Coq's logical consistency.

    Thus, because it doesn't terminate on all inputs, the full version
    of [ceval_step1] cannot be written in Coq -- at least not without
    one additional trick... *)

(* ################################################################# *)
(** * A Step-Indexed Evaluator *)

(** The trick we need is to pass an _additional_ parameter to the
    evaluation function that tells it how long to run.  Informally, we
    start the evaluator with a certain amount of "gas" in its tank,
    and we allow it to run until either it terminates in the usual way
    _or_ it runs out of gas, at which point we simply stop evaluating
    and say that the final result is the empty memory.  (We could also
    say that the result is the current state at the point where the
    evaluator runs out fo gas -- it doesn't really matter because the
    result is going to be wrong in either case!) *)

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_state
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          t_update st l (aeval st a1)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

(** _Note_: It is tempting to think that the index [i] here is
    counting the "number of steps of evaluation."  But if you look
    closely you'll see that this is not the case: for example, in the
    rule for sequencing, the same [i] is passed to both recursive
    calls.  Understanding the exact way that [i] is treated will be
    important in the proof of [ceval__ceval_step], which is given as
    an exercise below.

    One thing that is not so nice about this evaluator is that we
    can't tell, from its result, whether it stopped because the
    program terminated normally or because it ran out of gas.  Our
    next version returns an [option state] instead of just a [state],
    so that we can distinguish between normal and abnormal
    termination. *)

Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (t_update st l (aeval st a1))
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

(** We can improve the readability of this version by introducing a
    bit of auxiliary notation to hide the plumbing involved in
    repeatedly matching against optional states. *)

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (t_update st l (aeval st a1))
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

(* Compute
     (test_ceval empty_state
         (X ::= ANum 2;;
          IFB BLe (AId X) (ANum 1)
            THEN Y ::= ANum 3
            ELSE Z ::= ANum 4
          FI)).
   ====>
      Some (2, 0, 4)   *)

(** **** Exercise: 2 stars, recommended (pup_to_n)  *)
(** Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].  Make sure
   your solution satisfies the test that follows. *)

Definition pup_to_n : com
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(*
Example pup_to_n_1 :
  test_ceval (t_update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.
*)
(** [] *)

(** **** Exercise: 2 stars, optional (peven)  *)
(** Write a [While] program that sets [Z] to [0] if [X] is even and
    sets [Z] to [1] otherwise.  Use [ceval_test] to test your
    program. *)

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

(* ################################################################# *)
(** * Relational vs. Step-Indexed Evaluation *)

(** As for arithmetic and boolean expressions, we'd hope that
    the two alternative definitions of evaluation would actually
    amount to the same thing in the end.  This section shows that this
    is the case. *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      c / st \\ st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  - (* i = 0 -- contradictory *)
    intros c st st' H. inversion H.

  - (* i = S i' *)
    intros c st st' H.
    destruct c;
           simpl in H; inversion H; subst; clear H.
      + (* SKIP *) apply E_Skip.
      + (* ::= *) apply E_Ass. reflexivity.

      + (* ;; *)
        destruct (ceval_step st c1 i') eqn:Heqr1.
        * (* Evaluation of r1 terminates normally *)
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        * (* Otherwise -- contradiction *)
          inversion H1.

      + (* IFB *)
        destruct (beval st b) eqn:Heqr.
        * (* r = true *)
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        * (* r = false *)
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      + (* WHILE *) destruct (beval st b) eqn :Heqr.
        * (* r = true *)
         destruct (ceval_step st c i') eqn:Heqr1.
         { (* r1 = Some s *)
           apply E_WhileTrue with s. rewrite Heqr.
           reflexivity.
           apply IHi'. rewrite Heqr1. reflexivity.
           apply IHi'. simpl in H1. assumption. }
         { (* r1 = None *) inversion H1. }
        * (* r = false *)
          inversion H1.
          apply E_WhileFalse.
          rewrite <- Heqr. subst. reflexivity.  Qed.

(** **** Exercise: 4 stars (ceval_step__ceval_inf)  *)
(** Write an informal proof of [ceval_step__ceval], following the
    usual template.  (The template for case analysis on an inductively
    defined value should look the same as for induction, except that
    there is no induction hypothesis.)  Make your proof communicate
    the main ideas to a human reader; do not simply transcribe the
    steps of the formal proof.

(* FILL IN HERE *)
[]
*)

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  - (* i1 = 0 *)
    simpl in Hceval. inversion Hceval.
  - (* i1 = S i1' *)
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    destruct c.
    + (* SKIP *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ::= *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ;; *)
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* st1'o = None *)
        inversion Hceval.

    + (* IFB *)
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval;
        assumption.

    + (* WHILE *)
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* i1'o = None *)
        simpl in Hceval. inversion Hceval.  Qed.

(** **** Exercise: 3 stars, recommended (ceval__ceval_step)  *)
(** Finish the following proof.  You'll need [ceval_step_more] in a
    few places, as well as some basic facts about [<=] and [plus]. *)

Theorem ceval__ceval_step: forall c st st',
      c / st \\ st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem ceval_and_ceval_step_coincide: forall c st st',
      c / st \\ st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* ################################################################# *)
(** * Determinism of Evaluation Again *)

(** Using the fact that the relational and step-indexed definition of
    evaluation are the same, we can give a slicker proof that the
    evaluation _relation_ is deterministic. *)

Theorem ceval_deterministic' : forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega.  Qed.

(** $Date: 2017-05-24 10:56:51 -0400 (Wed, 24 May 2017) $ *)


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Classical_reasoning.

(** We assert the classical principle of double negation elimination *)
Variable DNE : forall A : Prop, ~ ~ A -> A.

(* https://en.wikipedia.org/wiki/Drinker_paradox *)
Lemma drinker_paradox (P : nat -> Prop) :
  exists x, P x -> forall y, P y.
Proof.
Admitted.

(* This closes the section, discharging over DNE *)
End Classical_reasoning.

Check drinker_paradox.

Section Misc.

Variables A B : Type.
Implicit Types x y : A * B.

Lemma prod_inj x y :
  x = y <-> (x.1, x.2) = (y.1, y.2).
Proof.
Admitted.

End Misc.

Section Arithmetics.

Lemma min_plus_r  n m p  :
  minn n m = n -> minn n (m + p) = n.
Proof.
Admitted.

Lemma min_plus_minus m n p :
  minn n m + minn (n - m) p = minn n (m + p).
Proof.
Admitted.

Fixpoint zero (n : nat) : nat :=
  if n is n'.+1 then zero n'
  else 0.

Lemma zero_returns_zero n :
  zero n = 0.
Proof.
Admitted.

(**
Claim: every amount of postage that is at least 12 cents can be made
       from 4-cent and 5-cent stamps. *)
(** Hint: no need to use induction here *)
Lemma stamps n : 12 <= n -> exists s4 s5, s4 * 4 + s5 * 5 = n.
Proof.
Admitted.

End Arithmetics.

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

(** Bonus track: properties of functions and their composition.
    Feel free to skip this part.
 *)

(** Solutions for the exercises in seminar02.v, we are going to need them later *)
Section eq_comp.
Variables A B C D : Type.

(** Note: [rewrite !compA] would fail because it keeps adding [id \o ...]
    this is due to the fact that [compA] is a convertible rule,
    so it clashes with Miller pattern unification *)
Lemma compA (f : A -> B) (g : B -> C) (h : C -> D) :
  h \o g \o f = h \o (g \o f).
Proof. by []. Qed.

Lemma eq_compl (f g : A -> B) (h : B -> C) :
  f =1 g -> h \o f =1 h \o g.
Proof. by move=> eq_fg; apply: eq_comp. Qed.

Lemma eq_compr (f g : B -> C) (h : A -> B) :
  f =1 g -> f \o h =1 g \o h.
Proof. by move=> eq_fg; apply: eq_comp. Qed.

Lemma eq_idl (g1 g2 : A -> B) (f : B -> B) :
  f =1 id -> f \o g1 =1 f \o g2 -> g1 =1 g2.
Proof. by move=> f_id g12f a; move: (g12f a)=> /=; rewrite !f_id. Qed.

Lemma eq_idr (f1 f2 : A -> B) (g : A -> A) :
  g =1 id -> f1 \o g =1 f2 \o g -> f1 =1 f2.
Proof. by move=> g_id f12g a; move: (f12g a)=> /=; rewrite g_id. Qed.

End eq_comp.

(** You might want to use the lemmas from seminar02.v, section [eq_comp] *)
Section PropertiesOfFunctions.

Section SurjectiveEpic.
Context {A B : Type}.

(* https://en.wikipedia.org/wiki/Surjective_function *)
(** Note: This definition is too strong in Coq's setting, see [epic_surj] below *)
Definition surjective (f : A -> B) :=
  exists g : B -> A, f \o g =1 id.

(** This is a category-theoretical counterpart of surjectivity:
    https://en.wikipedia.org/wiki/Epimorphism *)
Definition epic (f : A -> B) :=
  forall C (g1 g2 : B -> C), g1 \o f =1 g2 \o f -> g1 =1 g2.

Lemma surj_epic f : surjective f -> epic f.
Proof.
Admitted.

Lemma epic_surj f : epic f -> surjective f.
  (** Why is this not provable? *)
Abort.

End SurjectiveEpic.

Section EpicProperties.
Context {A B C : Type}.

Lemma epic_comp (f : B -> C) (g : A -> B) :
  epic f -> epic g -> epic (f \o g).
Proof.
Admitted.

Lemma comp_epicl (f : B -> C) (g : A -> B) :
  epic (f \o g) -> epic f.
Proof.
Admitted.

Lemma retraction_epic (f : B -> A) (g : A -> B) :
  (f \o g =1 id) -> epic f.
Proof.
Admitted.

End EpicProperties.

(** The following section treats some properties of injective functions:
    https://en.wikipedia.org/wiki/Injective_function *)

Section InjectiveMonic.

Context {B C : Type}.

(** This is a category-theoretical counterpart of injectivity:
    https://en.wikipedia.org/wiki/Monomorphism *)
Definition monic (f : B -> C) :=
  forall A (g1 g2 : A -> B), f \o g1 =1 f \o g2 -> g1 =1 g2.

Lemma inj_monic f : injective f -> monic f.
Proof.
Admitted.

Lemma monic_inj f : monic f -> injective f.
Proof.
Admitted.

End InjectiveMonic.

Section MonicProperties.
Context {A B C : Type}.

Lemma monic_comp (f : B -> C) (g : A -> B) :
  monic f -> monic g -> monic (f \o g).
Proof.
Admitted.

Lemma comp_monicr (f : B -> C) (g : A -> B) :
  monic (f \o g) -> monic g.
Proof.
Admitted.

Lemma section_monic (f : B -> A) (g : A -> B) :
  (g \o f =1 id) -> monic f.
Proof.
Admitted.

End MonicProperties.

End PropertiesOfFunctions.


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

Module ConcreteJob.

  Import ConcreteTask.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_job :=
    {
      job_id: nat;
      job_cost: nat;
      job_deadline: nat;
      job_jitter: nat;
      job_task: concrete_task_eqType
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete jobs. *)
    Definition job_eqdef (j1 j2: concrete_job) :=
      (job_id j1 == job_id j2) &&
      (job_cost j1 == job_cost j2) &&
      (job_deadline j1 == job_deadline j2) &&
      (job_jitter j1 == job_jitter j2) &&
      (job_task j1 == job_task j2).

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

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_job_eqMixin := EqMixin eqn_job.
    Canonical concrete_job_eqType := Eval hnf in EqType concrete_job concrete_job_eqMixin.

   End Defs.

End ConcreteJob.


(** * StlcProp: Properties of STLC *)

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

(** In this chapter, we develop the fundamental theory of the Simply
    Typed Lambda Calculus -- in particular, the type safety
    theorem. *)

(* ################################################################# *)
(** * Canonical Forms *)

(** As we saw for the very simple language in the [Types]
    chapter, the first step in establishing basic properties of
    reduction and types is to identify the possible _canonical
    forms_ (i.e., well-typed values) belonging to each type.  For
    [Bool], these are again the boolean values [true] and [false]; for
    arrow types, they are lambda-abstractions.

    Formally, we will need these lemmas only for terms that are not
    only well typed but _closed_ -- i.e., well typed in the empty
    context. *)

Lemma canonical_forms_bool : forall t,
  empty |- t \in Bool ->
  value t ->
  (t = <{true}>) \/ (t = <{false}>).
Proof.
  intros t HT HVal.
  destruct HVal; auto.
  inversion HT.
Qed.

Lemma canonical_forms_fun : forall t T1 T2,
  empty |- t \in (T1 -> T2) ->
  value t ->
  exists x u, t = <{\x:T1, u}>.
Proof.
  intros t T1 T2 HT HVal.
  destruct HVal as [x ? t1| |] ; inversion HT; subst.
  exists x, t1. reflexivity.
Qed.

(* ################################################################# *)
(** * Progress *)

(** The _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or it
    can take a reduction step.  The proof is a relatively
    straightforward extension of the progress proof we saw in the
    [Types] chapter.  We give the proof in English first, then
    the formal version. *)

Theorem progress : forall t T,
  empty |- t \in T ->
  value t \/ exists t', t --> t'.

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

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_True], [T_False], and [T_Abs] cases are trivial, since in
      each of these cases we can see by inspecting the rule that [t]
      is a value.

    - If the last rule of the derivation is [T_App], then [t] has the
      form [t1 t2] for some [t1] and [t2], where [|- t1 \in T2 -> T]
      and [|- t2 \in T2] for some type [T2].  The induction hypothesis
      for the first subderivation says that either [t1] is a value or
      else it can take a reduction step.

        - If [t1] is a value, then consider [t2], which by the
          induction hypothesis for the second subderivation must also
          either be a value or take a step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation is [T_If], then [t = if
      t1 then t2 else t3], where [t1] has type [Bool].  The first IH
      says that [t1] either is a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [true] or [false].  If it is [true], then [t] steps to
          [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_If]). *)
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  induction Ht; subst Gamma; auto.
  (* auto solves all three cases in which t is a value *)
  - (* T_Var *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    discriminate H.

  - (* T_App *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    + (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        eapply canonical_forms_fun in Ht1; [|assumption].
        destruct Ht1 as [x [t0 H1]]. subst.
        exists (<{ [x:=t2]t0 }>)...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists (<{t1 t2'}>)...

    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists (<{t1' t2}>)...

  - (* T_If *)
    right. destruct IHHt1...

    + (* t1 is a value *)
      destruct (canonical_forms_bool t1); subst; eauto.

    + (* t1 also steps *)
      destruct H as [t1' Hstp]. exists <{if t1' then t2 else t3}>...
Qed.

(** **** Exercise: 3 stars, advanced (progress_from_term_ind)

    Show that progress can also be proved by induction on terms
    instead of induction on typing derivations. *)

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t --> t'.
Proof.
  intros t.
  induction t; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Preservation *)

(** The other half of the type soundness property is the
    preservation of types during reduction.  For this part, we'll need
    to develop some technical machinery for reasoning about variables
    and substitution.  Working from top to bottom (from the high-level
    property we are actually interested in to the lowest-level
    technical lemmas that are needed by various cases of the more
    interesting proofs), the story goes like this:

      - The _preservation theorem_ is proved by induction on a typing
        derivation, pretty much as we did in the [Types] chapter.
        The one case that is significantly different is the one for
        the [ST_AppAbs] rule, whose definition uses the substitution
        operation.  To see that this step preserves typing, we need to
        know that the substitution itself does.  So we prove a...

      - _substitution lemma_, stating that substituting a (closed,
        well-typed) term [s] for a variable [x] in a term [t]
        preserves the type of [t].  The proof goes by induction on the
        form of [t] and requires looking at all the different cases in
        the definition of substitition.  This time, for the variables
        case, we discover that we need to deduce from the fact that a
        term [s] has type S in the empty context the fact that [s] has
        type S in every context. For this we prove a...

      - _weakening_ lemma, showing that typing is preserved under
        "extensions" to the context [Gamma].

   To make Coq happy, of course, we need to formalize the story in the
   opposite order, starting with weakening... *)

(* ================================================================= *)
(** ** The Weakening Lemma *)

(** First, we show that typing is preserved under "extensions" to the
    context [Gamma].  (Recall the definition of "includedin" from
    Maps.v.) *)

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

(** The following simple corollary is what we actually need below. *)

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

(* ================================================================= *)
(** ** The Substitution Lemma *)

(** Now we come to the conceptual heart of the proof that reduction
    preserves types -- namely, the observation that _substitution_
    preserves types. *)

(** Formally, the so-called _substitution lemma_ says this:
    Suppose we have a term [t] with a free variable [x], and suppose
    we've assigned a type [T] to [t] under the assumption that [x] has
    some type [U].  Also, suppose that we have some other term [v] and
    that we've shown that [v] has type [U].  Then, since [v] satisfies
    the assumption we made about [x] when typing [t], we can
    substitute [v] for each of the occurrences of [x] in [t] and
    obtain a new term that still has type [T].

    _Lemma_: If [x|->U; Gamma |- t \in T] and [|- v \in U],
    then [Gamma |- [x:=v]t \in T]. *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
  x |-> U ; Gamma |- t \in T ->
  empty |- v \in U   ->
  Gamma |- [x:=v]t \in T.

(** The substitution lemma can be viewed as a kind of "commutation
    property."  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ]; the result is the same either
    way.

    _Proof_: We show, by induction on [t], that for all [T] and
    [Gamma], if [x|->U; Gamma |- t \in T] and [|- v \in U], then
    [Gamma |- [x:=v]t \in T].

      - If [t] is a variable there are two cases to consider,
        depending on whether [t] is [x] or some other variable.

          - If [t = x], then from the fact that [x|->U; Gamma |- x \in
            T] we conclude that [U = T].  We must show that [[x:=v]x =
            v] has type [T] under [Gamma], given the assumption that
            [v] has type [U = T] under the empty context.  This
            follows from the weakening lemma.

          - If [t] is some variable [y] that is not equal to [x], then
            we need only note that [y] has the same type under [x|->U;
            Gamma] as under [Gamma].

      - If [t] is an abstraction [\y:S, t0], then [T = S->T1] and
        the IH tells us, for all [Gamma'] and [T0], that if [x|->U;
        Gamma' |- t0 \in T0], then [Gamma' |- [x:=v]t0 \in T0].
        Moreover, by inspecting the typing rules we see it must be
        the case that [y|->S; x|->U; Gamma |- t0 \in T1].

        The substitution in the conclusion behaves differently
        depending on whether [x] and [y] are the same variable.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=v]t = t], so we just need to show [Gamma |-
        t \in T].  Using [T_Abs], we need to show that [y|->S; Gamma
        |- t0 \in T1]. But we know [y|->S; x|->U; Gamma |- t0 \in T1],
        and the claim follows since [x = y].

        Second, suppose [x <> y]. Again, using [T_Abs],
        we need to show that [y|->S; Gamma |- [x:=v]t0 \in T1].
        Since [x <> y], we have
        [y|->S; x|->U; Gamma = x|->U; y|->S; Gamma]. So
        we have [x|->U; y|->S; Gamma |- t0 \in T1]. Then, the
        the IH applies (taking [Gamma' = y|->S; Gamma]), giving us
        [y|->S; Gamma |- [x:=v]t0 \in T1], as required.

      - If [t] is an application [t1 t2], the result follows
        straightforwardly from the definition of substitution and the
        induction hypotheses.

      - The remaining cases are similar to the application case. *)

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

(** One technical subtlety in the statement of the above lemma is that
    we assume [v] has type [U] in the _empty_ context -- in other
    words, we assume [v] is closed.  (Since we are using a simple
    definition of substition that is not capture-avoiding, it doesn't
    make sense to substitute non-closed terms into other terms.
    Fortunately, closed terms are all we need!)
 *)

(** **** Exercise: 3 stars, advanced (substitution_preserves_typing_from_typing_ind)

    Show that substitution_preserves_typing can also be
    proved by induction on typing derivations instead
    of induction on terms. *)
Lemma substitution_preserves_typing_from_typing_ind : forall Gamma x U t v T,
  x |-> U ; Gamma |- t \in T ->
  empty |- v \in U   ->
  Gamma |- [x:=v]t \in T.
Proof.
  intros Gamma x U t v T Ht Hv.
  remember (x |-> U; Gamma) as Gamma'.
  generalize dependent Gamma.
  induction Ht; intros Gamma' G; simpl; eauto.
 (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Main Theorem *)

(** We now have the ingredients we need to prove preservation: if a
    closed, well-typed term [t] has type [T] and takes a step to [t'],
    then [t'] is also a closed term with type [T].  In other words,
    the small-step reduction relation preserves types. *)

Theorem preservation : forall t t' T,
  empty |- t \in T  ->
  t --> t'  ->
  empty |- t' \in T.

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

    - We can immediately rule out [T_Var], [T_Abs], [T_True], and
      [T_False] as final rules in the derivation, since in each of these
      cases [t] cannot take a step.

    - If the last rule in the derivation is [T_App], then [t = t1 t2],
      and there are subderivations showing that [|- t1 \in T2->T] and
      [|- t2 \in T2] plus two induction hypotheses: (1) [t1 --> t1']
      implies [|- t1' \in T2->T] and (2) [t2 --> t2'] implies [|- t2'
      \in T2].  There are now three subcases to consider, one for
      each rule that could be used to show that [t1 t2] takes a step
      to [t'].

        - If [t1 t2] takes a step by [ST_App1], with [t1] stepping to
          [t1'], then, by the first IH, [t1'] has the same type as
          [t1] ([|- t1' \in T2->T]), and hence by [T_App] [t1' t2] has
          type [T].

        - The [ST_App2] case is similar, using the second IH.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T0,t0] and [t1 t2] steps to [[x0:=t2]t0]; the desired
          result now follows from the substitution lemma.

    - If the last rule in the derivation is [T_If], then [t = if
      t1 then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T1], and
      [|- t3 \in T1], and with three induction hypotheses: (1) [t1 -->
      t1'] implies [|- t1' \in Bool], (2) [t2 --> t2'] implies [|- t2'
      \in T1], and (3) [t3 --> t3'] implies [|- t3' \in T1].

      There are again three subcases to consider, depending on how [t]
      steps.

        - If [t] steps to [t2] or [t3] by [ST_IfTrue] or
          [ST_IfFalse], the result is immediate, since [t2] and [t3]
          have the same type as [t].

        - Otherwise, [t] steps by [ST_If], and the desired
          conclusion follows directly from the first induction
          hypothesis. *)

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

(** **** Exercise: 2 stars, standard, especially useful (subject_expansion_stlc)

    An exercise in the [Types] chapter asked about the _subject
    expansion_ property for the simple language of arithmetic and
    boolean expressions.  This property did not hold for that language,
    and it also fails for STLC.  That is, it is not always the case that,
    if [t --> t'] and [empty |- t' \in T], then [empty |- t \in T].
    Show this by giving a counter-example that does _not involve
    conditionals_. *)

(* FILL IN HERE *)

Theorem not_subject_expansion:
  exists t t' T, t --> t' /\ (empty |- t' \in T) /\ ~ (empty |- t \in T).
Proof.
  (* Write "exists <{ ... }>" to use STLC notation. *)
  (* FILL IN HERE *) Admitted.

(* Do not modify the following line: *)
Definition manual_grade_for_subject_expansion_stlc : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * Type Soundness *)

(** **** Exercise: 2 stars, standard, optional (type_soundness)

    Put progress and preservation together and show that a well-typed
    term can _never_ reach a stuck state.  *)

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

Corollary type_soundness : forall t t' T,
  empty |- t \in T ->
  t -->* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Uniqueness of Types *)

(** **** Exercise: 3 stars, standard (unique_types)

    Another nice property of the STLC is that types are unique: a
    given term (in a given context) has at most one type. *)

Theorem unique_types : forall Gamma e T T',
  Gamma |- e \in T ->
  Gamma |- e \in T' ->
  T = T'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Context Invariance (Optional) *)

(** Another standard technical lemma associated with typed languages
    is _context invariance_. It states that typing is preserved under
    "inessential changes" to the context [Gamma] -- in particular,
    changes that do not affect any of the free variables of the
    term. In this section, we establish this property for our system,
    introducing some other standard terminology on the way.  *)

(** First, we need to define the _free variables_ in a term -- i.e.,
    variables that are used in the term in positions that are _not_ in
    the scope of an enclosing function abstraction binding a variable
    of the same name.

    More technically, a variable [x] _appears free in_ a term _t_ if
    [t] contains some occurrence of [x] that is not under an
    abstraction labeled [x]. For example:
      - [y] appears free, but [x] does not, in [\x:T->U, x y]
      - both [x] and [y] appear free in [(\x:T->U, x y) x]
      - no variables appear free in [\x:T->U, \y:T, x y]

      Formally: *)

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

Hint Constructors appears_free_in : core.

(** The _free variables_ of a term are just the variables that appear
    free in it.  This gives us another way to define _closed_ terms --
    arguably a better one, since it applies even to ill-typed
    terms.  Indeed, this is the standard definition of the term
    "closed." *)

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

(** Conversely, an _open_ term is one that may contain free
    variables.  (I.e., every term is an open term; the closed terms
    are a subset of the open ones.  "Open" precisely means "possibly
    containing free variables.") *)

(** **** Exercise: 1 star, standard, optional (afi)

    (Officially optional, but strongly recommended!) In the space
    below, write out the rules of the [appears_free_in] relation in
    informal inference-rule notation.  (Use whatever notational
    conventions you like -- the point of the exercise is just for you
    to think a bit about the meaning of each rule.)  Although this is
    a rather low-level, technical definition, understanding it is
    crucial to understanding substitution and its properties, which
    are really the crux of the lambda-calculus. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_afi : option (nat*string) := None.
(** [] *)

(** Next, we show that if a variable [x] appears free in a term [t],
    and if we know [t] is well typed in context [Gamma], then it
    must be the case that [Gamma] assigns a type to [x]. *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.

(** _Proof_: We show, by induction on the proof that [x] appears free
    in [t], that, for all contexts [Gamma], if [t] is well typed under
    [Gamma], then [Gamma] assigns some type to [x].

    - If the last rule used is [afi_var], then [t = x], and from the
      assumption that [t] is well typed under [Gamma] we have
      immediately that [Gamma] assigns a type to [x].

    - If the last rule used is [afi_app1], then [t = t1 t2] and [x]
      appears free in [t1].  Since [t] is well typed under [Gamma], we
      can see from the typing rules that [t1] must also be, and the IH
      then tells us that [Gamma] assigns [x] a type.

    - Almost all the other cases are similar: [x] appears free in a
      subterm of [t], and since [t] is well typed under [Gamma], we
      know the subterm of [t] in which [x] appears is well typed under
      [Gamma] as well, and the IH gives us exactly the conclusion we
      want.

    - The only remaining case is [afi_abs].  In this case [t =
      \y:T1,t1] and [x] appears free in [t1], and we also know that
      [x] is different from [y].  The difference from the previous
      cases is that, whereas [t] is well typed under [Gamma], its body
      [t1] is well typed under [y|->T1; Gamma], so the IH allows us
      to conclude that [x] is assigned some type by the extended
      context [y|->T1; Gamma].  To conclude that [Gamma] assigns a
      type to [x], we appeal to lemma [update_neq], noting that [x]
      and [y] are different variables. *)

(** **** Exercise: 2 stars, standard (free_in_context)

    Complete the following proof. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  induction H as [| | |y T1 t1 H H0 IHappears_free_in| | |];
         intros; try solve [inversion H0; eauto].
  (* FILL IN HERE *) Admitted.
(** [] *)

(** From the [free_in_context] lemma, it immediately follows that any
    term [t] that is well typed in the empty context is closed (it has
    no free variables). *)

(** **** Exercise: 2 stars, standard, optional (typable_empty__closed) *)
Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Finally, we establish _context_invariance_.  It is useful in cases
    when we have a proof of some typing relation [Gamma |- t \in T],
    and we need to replace [Gamma] by a different context [Gamma'].
    When is it safe to do this?  Intuitively, it must at least be the
    case that [Gamma'] assigns the same types as [Gamma] to all the
    variables that appear free in [t]. In fact, this is the only
    condition that is needed. *)

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.

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

    - If the last rule in the derivation was [T_Var], then [t = x] and
      [Gamma x = T].  By assumption, [Gamma' x = T] as well, and hence
      [Gamma' |- t \in T] by [T_Var].

    - If the last rule was [T_Abs], then [t = \y:T2, t1], with [T =
      T2 -> T1] and [y|->T2; Gamma |- t1 \in T1].  The induction
      hypothesis states that for any context [Gamma''], if [y|->T2;
      Gamma] and [Gamma''] assign the same types to all the free
      variables in [t1], then [t1] has type [T1] under [Gamma''].
      Let [Gamma'] be a context which agrees with [Gamma] on the free
      variables in [t]; we must show [Gamma' |- \y:T2, t1 \in T2 -> T1].

      By [T_Abs], it suffices to show that [y|->T2; Gamma' |- t1 \in
      T1].  By the IH (setting [Gamma'' = y|->T2;Gamma']), it
      suffices to show that [y|->T2;Gamma] and [y|->T2;Gamma'] agree
      on all the variables that appear free in [t1].

      Any variable occurring free in [t1] must be either [y] or some
      other variable.  [y|->T2; Gamma] and [y|->T2; Gamma'] clearly
      agree on [y].  Otherwise, note that any variable other than [y]
      that occurs free in [t1] also occurs free in [t = \y:T2, t1],
      and by assumption [Gamma] and [Gamma'] agree on all such
      variables; hence so do [y|->T2; Gamma] and [y|->T2; Gamma'].

    - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
      t1 \in T2 -> T] and [Gamma |- t2 \in T2].  One induction
      hypothesis states that for all contexts [Gamma'], if [Gamma']
      agrees with [Gamma] on the free variables in [t1], then [t1] has
      type [T2 -> T] under [Gamma']; there is a similar IH for [t2].
      We must show that [t1 t2] also has type [T] under [Gamma'],
      given the assumption that [Gamma'] agrees with [Gamma] on all
      the free variables in [t1 t2].  By [T_App], it suffices to show
      that [t1] and [t2] each have the same type under [Gamma'] as
      under [Gamma].  But all free variables in [t1] are also free in
      [t1 t2], and similarly for [t2]; hence the desired result
      follows from the induction hypotheses. *)

(** **** Exercise: 3 stars, standard, optional (context_invariance)

    Complete the following proof. *)
Proof.
  intros.
  generalize dependent Gamma'.
  induction H as [| ? x0 ????? | | | |]; intros; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The context invariance lemma can actually be used in place of the
    weakening lemma to prove the crucial substitution lemma stated
    earlier. *)

(* ################################################################# *)
(** * Additional Exercises *)

(** **** Exercise: 1 star, standard, optional (progress_preservation_statement)

    (Officially optional, but strongly recommended!) Without peeking
    at their statements above, write down the progress and
    preservation theorems for the simply typed lambda-calculus (as Coq
    theorems).  You can write [Admitted] for the proofs. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_progress_preservation_statement : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (stlc_variation1)

    Suppose we add a new term [zap] with the following reduction rule

                         ---------                  (ST_Zap)
                         t --> zap

and the following typing rule:

                      ------------------            (T_Zap)
                      Gamma |- zap \in T

    Which of the following properties of the STLC remain true in
    the presence of these rules?  For each property, write either
    "remains true" or "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)

(* Do not modify the following line: *)
Definition manual_grade_for_stlc_variation1 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (stlc_variation2)

    Suppose instead that we add a new term [foo] with the following
    reduction rules:

                       -----------------                (ST_Foo1)
                       (\x:A, x) --> foo

                         ------------                   (ST_Foo2)
                         foo --> true

    Which of the following properties of the STLC 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]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)

(* Do not modify the following line: *)
Definition manual_grade_for_stlc_variation2 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (stlc_variation3)

    Suppose instead that we remove the rule [ST_App1] from the [step]
    relation. Which of the following properties of the STLC 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]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)

(* Do not modify the following line: *)
Definition manual_grade_for_stlc_variation3 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (stlc_variation4)

    Suppose instead that we add the following new rule to the
    reduction relation:

            ----------------------------------        (ST_FunnyIfTrue)
            (if true then t1 else t2) --> true

    Which of the following properties of the STLC 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]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (stlc_variation5)

    Suppose instead that we add the following new rule to the typing
    relation:

                 Gamma |- t1 \in Bool->Bool->Bool
                     Gamma |- t2 \in Bool
                 ------------------------------          (T_FunnyApp)
                    Gamma |- t1 t2 \in Bool

    Which of the following properties of the STLC 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]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (stlc_variation6)

    Suppose instead that we add the following new rule to the typing
    relation:

                     Gamma |- t1 \in Bool
                     Gamma |- t2 \in Bool
                    ---------------------               (T_FunnyApp')
                    Gamma |- t1 t2 \in Bool

    Which of the following properties of the STLC 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]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (stlc_variation7)

    Suppose we add the following new rule to the typing relation
    of the STLC:

                         ------------------- (T_FunnyAbs)
                         |- \x:Bool,t \in Bool

    Which of the following properties of the STLC 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]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)
(** [] *)

End STLCProp.

(* ================================================================= *)
(** ** Exercise: STLC with Arithmetic *)

(** To see how the STLC might function as the core of a real
    programming language, let's extend it with a concrete base
    type of numbers and some constants and primitive
    operators. *)

Module STLCArith.
Import STLC.

(** To types, we add a base type of natural numbers (and remove
    booleans, for brevity). *)

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

(** To terms, we add natural number constants, along with
    successor, predecessor, multiplication, and zero-testing. *)

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

Notation "{ x }" := x (in custom stlc at level 1, x constr).

Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.

Notation "'Nat'" := Ty_Nat (in custom stlc at level 0).
Notation "'succ' x" := (tm_succ x) (in custom stlc at level 0,
                                     x custom stlc at level 0).
Notation "'pred' x" := (tm_pred x) (in custom stlc at level 0,
                                     x custom stlc at level 0).
Notation "x * y" := (tm_mult x y) (in custom stlc at level 1,
                                      left associativity).
Notation "'if0' x 'then' y 'else' z" :=
  (tm_if0 x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).
Coercion tm_const : nat >-> tm.

(** In this extended exercise, your job is to finish formalizing the
    definition and properties of the STLC extended with arithmetic.
    Specifically:

    Fill in the core definitions for STLCArith, by starting
    with the rules and terms which are the same as STLC.
    Then prove the key lemmas and theorems we provide.
    You will need to define and prove helper lemmas, as before.

    It will be necessary to also fill in "Reserved Notation",
    "Notation", and "Hint Constructors".

    Hint: If you get an error "STLC.tm" found instead of term "tm" then Coq is picking
    up the old notation for ie: subst instead of the new notation
    for STLCArith, so you need to overwrite the old with the notation
    before you can use it.

    Make sure Coq accepts the whole file before submitting
*)

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).

(** **** Exercise: 5 stars, standard (STLCArith.subst) *)
Fixpoint subst (x : string) (s : tm) (t : tm) : tm
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Inductive value : tm -> Prop :=
  (* FILL IN HERE *)
.

Hint Constructors value : core.

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

Inductive step : tm -> tm -> Prop :=
  (* FILL IN HERE *)
where "t '-->' t'" := (step t t').

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

Hint Constructors step : core.

(* An example *)

Example Nat_step_example : exists t,
<{(\x: Nat, \y: Nat, x * y ) 3 2 }> -->* t.
Proof. (* FILL IN HERE *) Admitted.

(* Typing *)

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 101, t custom stlc, T custom stlc at level 0).

Inductive has_type : context -> tm -> ty -> Prop :=
  (* FILL IN HERE *)
where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type : core.

(* An example *)

Example Nat_typing_example :
   empty |- ( \x: Nat, \y: Nat, x * y ) 3 2 \in Nat.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** The Technical Theorems *)

(** The next lemmas are proved _exactly_ as before. *)

(** **** Exercise: 4 stars, standard (STLCArith.weakening) *)
Lemma weakening : forall Gamma Gamma' t T,
     includedin Gamma Gamma' ->
     Gamma  |- t \in T  ->
     Gamma' |- t \in T.
Proof. (* FILL IN HERE *) Admitted.

(* FILL IN HERE *)

(** [] *)

(* Preservation *)
(* Hint: You will need to define and prove the same helper lemmas we used before *)

(** **** Exercise: 4 stars, standard (STLCArith.preservation) *)
Theorem preservation : forall t t' T,
  empty |- t \in T  ->
  t --> t'  ->
  empty |- t' \in T.
Proof with eauto. (* FILL IN HERE *) Admitted.

(** [] *)

(* Progress *)

(** **** Exercise: 4 stars, standard (STLCArith.progress) *)
Theorem progress : forall t T,
  empty |- t \in T ->
  value t \/ exists t', t --> t'.
Proof with eauto. (* FILL IN HERE *) Admitted.
(** [] *)

End STLCArith.

(* 2022-08-08 17:31 *)


Require Import L Encodings DecidableRecognisable Markov Enumerable.

Implicit Types P Q : term -> Prop.

(** * Reducability *)

Definition computable_gen X Y (xenc : X -> term) (yenc : Y -> term) f :=
  exists u, proc u /\ forall s, u (xenc s) ▷ (yenc (f s)).

Definition computable_fun f := computable_gen tenc tenc f.

Record mreducible P Q : Prop :=
  { f : term -> term ;
    f_red : forall s, P s <-> Q (f s) ;
    f_comp : computable_fun f ;
  }.
Notation "P ⪯ Q" := (mreducible P Q) (at level 40, no associativity).

Lemma mreducible_sane P Q :
  mreducible P Q <-> exists u, proc u /\ forall s, exists t, u (tenc s) ▷ tenc t /\ (P s <-> Q t).
Proof.
  split.
  - intros [f ? (u & ? & ?)].
    exists u. split; value.
    intros. exists (f s). split; eauto.
  - intros (u & ? & ?). assert (forall s, exists t, u (tenc s) ▷ tenc t) as [f ?] %  L_computable_computable by firstorder.
    exists f.
    + intros. destruct (H0 s) as (t & ? & ?).
      enough (f s = t) as ->. eassumption.
      specialize (e s). eapply tenc_inj. now rewrite <- e, <- H1.
    + firstorder.
Qed.

Instance mreducible_preorder : PreOrder mreducible.
Proof.
  econstructor.
  - exists (fun s => s).
    + firstorder.
    + exists I. split; value. intros. solveeq.
  - intros P Q R [f1 H1 [u1 []]] [f2 H3 [u2 []]].
    exists (fun s => f2 (f1 s)).
    + firstorder.
    + exists (lambda (u2 (u1 0))). split; value.
      intros. eapply evaluates_equiv. split; value.
      specialize (H0 s). specialize (H4 (f1 s)).
      solveeq.
Qed.

Lemma mreducible_ext P Q P' Q' :
  (forall s, P s <-> P' s) -> (forall s, Q s <-> Q' s) -> P ⪯ Q -> P' ⪯ Q'.
Proof.
  intros ? ? [f ? ?]. exists f; firstorder.
Qed.

Lemma mreducible_comp P Q :
  P ⪯ Q -> (fun s => ~ P s) ⪯ (fun s => ~ Q s).
Proof.
  intros [f ? ?]. exists f; firstorder.
Qed.

Lemma mreducible_comp_conv :
  (forall P Q, (fun s => ~ P s) ⪯ (fun s => ~ Q s) -> P ⪯ Q) ->
  Markov_Eva.
Proof.
  intros ? ? ? ?. specialize (H eva (fun s => ~~ eva s)).
  destruct H.
  - eapply mreducible_ext with (P :=  (fun s0 : term => ~ eva s0)) (Q :=  (fun s0 : term => ~ eva s0)); try reflexivity.
    firstorder.
  - eapply f_red. intros ?. eapply H1. intros ?. now eapply f_red in H2.
Qed.

Lemma mreducible_dec P Q :
  decidable Q -> P ⪯ Q -> decidable P.
Proof.
  intros (u & Hp & H) [f ? (v & ? & ?)].
  exists (lambda (u (v 0))). split; value.
  intros s. assert (lambda (u (v 0)) (tenc s) ≡ u (v (tenc s))) as -> by solveeq.
  rewrite H1. firstorder.
Qed.

Lemma mreducible_red P Q s t :
  Q s -> ~ Q t -> decidable P -> P ⪯ Q.
Proof.
  intros ? ? ?. pose proof (decidable_dec H1) as [f ?].
  destruct H1 as (u & ? & ?).
  exists (fun x => if f x then s else t).
  - intros x. specialize (H2 x). destruct (f x); firstorder congruence.
  - exists (lambda (u 0 (tenc s) (tenc t))). split; value.
    intros x. assert ((lambda (((u 0) (tenc s)) (tenc t))) (tenc x) ≡ u (tenc x) (tenc s) (tenc t)) as -> by solveeq.
    destruct (H3 x) as [ [-> % H2 ->] | [? ->] ].
    + solveeq.
    + rewrite <- H2 in H4. destruct (f x); try congruence. solveeq.
Qed.

Lemma mreducible_recognisable P Q :
  recognisable Q -> P ⪯ Q -> recognisable P.
Proof.
  intros (u & ? & ?) [f ? (v & ? & ?)].
  exists (lambda (u (v 0))). split; value.
  intros s. assert (lambda (u (v 0)) (tenc s) ≡ u (v (tenc s))) as -> by solveeq.
  now rewrite H2, f_red, H0.
Qed.

Lemma mreducible_full P :
  P ⪯ (fun s => True) <-> (forall s, P s).
Proof.
  split.
  - firstorder.
  - intros. eapply mreducible_ext with (P := fun _ => True) (Q := fun _ => True); firstorder.
Qed.

Lemma mreducible_empty P :
  P ⪯ (fun s => False) <-> (forall s, ~ P s).
Proof.
  split.
  - firstorder.
  - intros. eapply mreducible_ext with (P := fun _ => False) (Q := fun _ => False); firstorder. exact 0.
Qed.

Lemma eva_red :
  (fun s => eva (s (tenc s))) ⪯ eva.
Proof.
  exists (fun s => app s (tenc s)).
  - firstorder.
  - exists (lambda (App 0 (Q 0))). split; value.
    intros. eapply evaluates_equiv. split; value.
    transitivity (App (tenc s) (Q (tenc s))). solveeq.
    now rewrite Q_correct, App_correct.
Qed.

Lemma recognisable_iff P :
  recognisable P <-> P ⪯ eva.
Proof.
  split.
  - intros (u & ? & ?).
    exists (fun x => u (tenc x)).
    + eassumption.
    + exists (lambda (App (tenc u) (Q 0))). split; value.
      intros. eapply evaluates_equiv; split; value.
      redL. now rewrite Q_correct, App_correct.
  - intros ?. eapply mreducible_recognisable.
    eapply recognisable_eva. eassumption.
Qed.

Lemma preceq_lub P Q : exists R,
    P ⪯ R /\ Q ⪯ R /\ forall R', P ⪯ R' -> Q ⪯ R' -> R ⪯ R'.
Proof.
  exists (fun s => match s with
             app 0 s => P s
           | app _ s => Q s
           | s => Q s
           end).
  repeat split.
  - {
      exists (fun s => app 0 s).
      - cbn. firstorder.
      - exists (lambda (App (tenc 0) 0)). split; value. intros.
        eapply evaluates_equiv; split; value.
        transitivity (App (tenc 0) (tenc s)). solveeq.
        now rewrite App_correct.
    }
  - {
      exists (fun s => app 1 s).
      - cbn. firstorder.
      - exists (lambda (App (tenc 1) 0)). split; value. intros.
        eapply evaluates_equiv; split; value.
        transitivity (App (tenc 1) (tenc s)). solveeq.
        now rewrite App_correct.
    }
  - intros D [f] [g].
    exists (fun s => match s with
             | app 0 s => f s
             | app _ s => g s
             | _ => g s
             end).
    cbn. intros. destruct s as [ | [[] | | ] |]; cbn; firstorder.
    destruct f_comp as (u & ? & ?), f_comp0 as (v & ? & ?).
    exists (lambda (0 (lambda (v 1)) (lambda (lambda (1 (lambda (0 (u 1) (lambda (v 2)))) (lambda (lambda (v 2))) (lambda (v 1))))) (lambda (v 1)))).
    split; value. intros. eapply evaluates_equiv; split; value.
    destruct s as [ | [ [] | | ] | ] eqn:E.
    + specialize (H2 s). subst. solveeq.
    + specialize (H0 t1). subst. solveeq.
    + specialize (H2 t1). specialize (H0 t1). subst. solveeq.
    + specialize (H2 t2). specialize (H0 t2). solveeq.
    + specialize (H2 t1). solveeq.
    + specialize (H2 s). subst. solveeq.
Qed.


Require Import Coq.omega.Omega.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export DeclarationEvaluation.

(******************************************************************************)
(* Well-formedness                                                            *)
(******************************************************************************)

Lemma kind_wf h K : wfKind h K.
Proof.
  induction K; eauto using wfKind.
Qed.
Hint Resolve kind_wf.

(******************************************************************************)
(* Leftover boilerplate                                                       *)
(******************************************************************************)

Lemma strengthening_evar_kinding {Γ s S Γ1 T K} (wT: Kinding Γ1 T K) :
  ∀ {x Γ2}, subst_evar Γ S s x Γ1 Γ2 → Kinding Γ2 T K.
Proof.
  induction wT; simpl; intros; econstructor; eauto with infra.
Qed.

(******************************************************************************)
(* Agreement                                                                  *)
(******************************************************************************)

Lemma tyeq_kinding {Γ T U K} : TyEq Γ T U K → Kinding Γ T K ∧ Kinding Γ U K.
Proof.
  induction 1; destruct_conjs; repeat econstructor;
    eauto using subst_etvar_Kinding with infra.
Qed.

Lemma tyeq_kinding_left {Γ T U K} : TyEq Γ T U K → Kinding Γ T K.
Proof. apply tyeq_kinding. Qed.

Lemma tyeq_kinding_right {Γ T U K} : TyEq Γ T U K → Kinding Γ U K.
Proof. apply tyeq_kinding. Qed.

Lemma tred_tyeq {Γ S T K} : TRed Γ S T K → TyEq Γ S T K.
Proof.
  induction 1; try (econstructor; eauto using K_TVar; fail); eapply Q_Trans;
    [ eauto using Q_App, Q_Abs | eauto using Q_Beta, tyeq_kinding_right ].
Qed.

Lemma tredstar_tyeq {Γ S T K} : TRedStar Γ S T K → TyEq Γ S T K.
Proof.
  induction 1; try (econstructor; eauto; fail); eauto using Q_Trans, tred_tyeq.
Qed.

Hint Extern 2 (Kinding _ _ _) =>
  match goal with
    | H: TyEq     _ _ _ _ |- _ =>
      destruct (tyeq_kinding H); clear H
    | H: TRed     _ _ _ _ |- _ =>
      destruct (tyeq_kinding (tred_tyeq H)); clear H
    | H: TRedStar _ _ _ _ |- _ =>
      destruct (tyeq_kinding (tredstar_tyeq H)); clear H
  end.

Lemma tred_kinding_left {Γ T U K} : TRed Γ T U K → Kinding Γ T K.
Proof. eauto. Qed.

Lemma tred_kinding_right {Γ T U K} : TRed Γ T U K → Kinding Γ U K.
Proof. eauto. Qed.

(* Definition 30.3.18 *)
Inductive wf_env : Env → Prop :=
  | wf_empty                      : wf_env empty
  | wf_evar  {Γ T} (wΓ: wf_env Γ) : Kinding Γ T star → wf_env (evar Γ T)
  | wf_etvar {Γ K} (wΓ: wf_env Γ) : wf_env (etvar Γ K).

(* 30.3.19 *)
Lemma lookup_evar_kinding {Γ} (wΓ: wf_env Γ) :
  ∀ {x T}, lookup_evar Γ x T → Kinding Γ T star.
Proof.
  induction wΓ; inversion 1; subst; simpl;
    eauto using shift_etvar_Kinding, shift_evar_Kinding with infra.
Qed.

Lemma typing_kinding {Γ t T} (wfΓ : wf_env Γ) (wt: Typing Γ t T) :
  Kinding Γ T star.
Proof.
  induction wt; eauto using lookup_evar_kinding;
    try (econstructor; eauto; fail).
  - constructor; auto.
    specialize (IHwt (wf_evar wfΓ jm5)).
    eapply strengthening_evar_kinding; eauto.
    exact (subst_evar_here _ _ t).
  - specialize (IHwt1 wfΓ).
    dependent destruction IHwt1; auto.
  - constructor; eauto with infra.
    specialize (IHwt (wf_etvar wfΓ)).
    eauto using strengthening_evar_kinding.
  - specialize (IHwt wfΓ).
    dependent destruction IHwt.
    eauto using subst_etvar_Kinding with infra.
Qed.

Lemma QR_Refl {Γ T K} (wT: Kinding Γ T K) : TRed Γ T T K.
Proof.
  induction wT; econstructor; eauto.
Qed.

Lemma QRS_Trans {Γ S T U K} :
  TRedStar Γ S T K → TRedStar Γ T U K → TRedStar Γ S U K.
Proof.
  intros P Q; revert S P; induction Q; eauto using QRS_Cons.
Qed.

Lemma QRS_Arrow1 {Γ S1 S2} (r: TRedStar Γ S1 S2 star) :
  ∀ {T}, Kinding Γ T star → TRedStar Γ (tarr S1 T) (tarr S2 T) star.
Proof.
  depind r; simpl; econstructor; eauto using QR_Refl, Kinding, TRed.
Qed.

Lemma QRS_Arrow2 {Γ T1 T2} (r: TRedStar Γ T1 T2 star) :
  ∀ {S}, Kinding Γ S star → TRedStar Γ (tarr S T1) (tarr S T2) star.
Proof.
  depind r; simpl; econstructor; eauto using QR_Refl, Kinding, TRed.
Qed.

Lemma QRS_Arrow {Γ S1 S2 T1 T2} :
  TRedStar Γ S1 S2 star → TRedStar Γ T1 T2 star →
  TRedStar Γ (tarr S1 T1) (tarr S2 T2) star.
Proof.
  intros; eapply QRS_Trans;
  [ eauto using QRS_Arrow1 | eauto using QRS_Arrow2 ].
Qed.

Lemma QRS_Abs {Γ K K2 S T} (r: TRedStar (etvar Γ K) S T K2) :
  TRedStar Γ (tabs K S) (tabs K T) (karr K K2).
Proof.
  depind r; econstructor; eauto using Kinding, TRed.
Qed.

Lemma QRS_App1 {Γ S T K K2} (r: TRedStar Γ S T (karr K K2)) :
  ∀ U, Kinding Γ U K → TRedStar Γ (tapp S U) (tapp T U) K2.
Proof.
  depind r; simpl; econstructor; eauto using QR_Refl, Kinding, TRed.
Qed.

Lemma QRS_App2 {Γ T U K K2} (r: TRedStar Γ T U K) :
  ∀ S, Kinding Γ S (karr K K2) → TRedStar Γ (tapp S T) (tapp S U) K2.
Proof.
  depind r; simpl; econstructor; eauto using QR_Refl, Kinding, TRed.
Qed.

Lemma QRS_App {Γ S1 T1 S2 T2 K K2} :
  TRedStar Γ S1 T1 (karr K K2) → TRedStar Γ S2 T2 K →
  TRedStar Γ (tapp S1 S2) (tapp T1 T2) K2.
Proof.
  intros; eapply QRS_Trans;
  [ eauto using QRS_App1 | eauto using QRS_App2 ].
Qed.

Lemma QRS_All {Γ K S T} (r: TRedStar (etvar Γ K) S T star) :
  TRedStar Γ (tall K S) (tall K T) star.
Proof.
  depind r; simpl; econstructor; eauto using Kinding, TRed with infra.
Qed.

(******************************************************************************)
(* Confluence                                                                 *)
(******************************************************************************)

(* Lemma 30.3.6 *)
Inductive subst_tred (Γ: Env) (S1 S2: Ty) : Trace ty → Env → Env → Prop :=
  | sr_here {K} (wS1: wfTy (domainEnv Γ) S1) (wS2: wfTy (domainEnv Γ) S2) :
      TRed Γ S1 S2 K → subst_tred Γ S1 S2 X0 (etvar Γ K) Γ
  | sr_tvar {Γ1 Γ2 X K} :
      subst_tred Γ S1 S2 X Γ1 Γ2 →
      subst_tred Γ S1 S2 (XS ty X) (etvar Γ1 K) (etvar Γ2 K).
Hint Constructors subst_tred.

Lemma subst_tred_substhvl {Γ S1 S2 X Γ1 Γ2} (sub: subst_tred Γ S1 S2 X Γ1 Γ2) :
  substhvl_ty (domainEnv Γ) X (domainEnv Γ1) (domainEnv Γ2).
Proof.
  induction sub; eauto with infra.
Qed.
Hint Resolve subst_tred_substhvl.

Lemma subst_tred_index {Γ S1 S2 X Γ1 Γ2} (sub: subst_tred Γ S1 S2 X Γ1 Γ2) :
  ∀ {Y K}, lookup_etvar Γ1 Y K →
    TRed Γ2 (tsubstIndex X S1 Y) (tsubstIndex X S2 Y) K.
Proof.
  induction sub; inversion 1; subst; simpl; repeat constructor;
    eauto using shift_etvar_TRed with infra.
Qed.

(* Lemma 30.3.7 *)
Lemma subst_tred_tred {Γ S1 S2 Γ1 T1 T2 K} (r: TRed Γ1 T1 T2 K) :
  ∀ {Y Γ2}, subst_tred Γ S1 S2 Y Γ1 Γ2 →
    TRed Γ2 (tsubstTy Y S1 T1) (tsubstTy Y S2 T2) K.
Proof.
  induction r; simpl; intros; try rewrite tsubstTy_tsubstTy0_comm;
  try econstructor; eauto using subst_tred_index.
Qed.

Fixpoint tred_complete (T : Ty) : Ty :=
  match T with
    | tvar X              => tvar X
    | tabs K T            => tabs K (tred_complete T)
    | tapp (tabs K T1) T2 => tsubstTy X0 (tred_complete T2) (tred_complete T1)
    | tapp T1 T2          => tapp (tred_complete T1) (tred_complete T2)
    | tarr T1 T2          => tarr (tred_complete T1) (tred_complete T2)
    | tall K T            => tall K (tred_complete T)
  end.

Lemma tred_triangle {Γ S T K} (r : TRed Γ S T K) : TRed Γ T (tred_complete S) K.
Proof with simpl; eauto using QR_Refl, TRed.
  induction r; intros...
  - dependent destruction r1...
    dependent destruction IHr1...
  - eauto using subst_tred_tred with wf infra.
Qed.

(* Lemma 30.3.8 *)
Lemma tred_single_step_diamond :
  ∀ {Γ S T U K}, TRed Γ S T K → TRed Γ S U K →
    ∃ V, TRed Γ T V K ∧ TRed Γ U V K.
Proof.
  intros; exists (tred_complete S); eauto using tred_triangle.
Qed.

(* Lemma 30.3.9 *)
Lemma tred_strip {Γ S U K} (r: TRedStar Γ S U K) :
  ∀ V, TRed Γ S V K → ∃ W, TRed Γ U W K ∧ TRedStar Γ V W K.
Proof.
  induction r; simpl; intros V SV.
  - eauto using QRS_Nil.
  - destruct (IHr V SV) as (W & TV & VW).
    destruct (tred_single_step_diamond TV jm36) as (Z & UZ & VZ).
    eauto using QRS_Cons.
Qed.

Lemma tred_confluence {Γ S T V K} :
  TRedStar Γ S T K → TRedStar Γ S V K →
  ∃ W, TRedStar Γ T W K ∧ TRedStar Γ V W K.
Proof.
  intros ST; revert V; induction ST; intros V SV.
  - eauto using TRedStar.
  - destruct (IHST _ SV) as (W & TW & VW).
    destruct (tred_strip TW _ jm36) as (Z & WZ & UZ).
    eauto using QRS_Cons.
Qed.

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

(* Lemma 30.3.11 *)
Lemma teq_tred {Γ S T K} (eq : TyEq Γ S T K) :
  ∃ U, TRedStar Γ S U K ∧ TRedStar Γ T U K.
Proof.
  induction eq.
  - destruct_conjs; eauto using QRS_Arrow.
  - destruct_conjs; eauto using QRS_Abs.
  - destruct_conjs; eauto using QRS_App.
  - destruct_conjs; eauto using QRS_All.
  - exists (tsubstTy X0 T2 T12); split.
    + eauto 10 using TRedStar, TRed, K_App, K_Abs, QR_Refl.
    + eauto using QRS_Nil, subst_etvar_Kinding with infra.
  - eauto using QRS_Nil.
  - destruct_conjs; eauto.
  - destruct IHeq1 as [V1 [SV1 UV1]].
    destruct IHeq2 as [V2 [UV2 TV2]].
    destruct (tred_confluence UV1 UV2) as [V' [V1V V2V]].
    eauto using QRS_Trans.
Qed.

(* Lemma 30.3.12.1 *)
Lemma tred_tarr_preservation {Γ S1 S2 T} (H : TRedStar Γ (tarr S1 S2) T star) :
  ∃ T1 T2, T = tarr T1 T2 ∧ TRedStar Γ S1 T1 star ∧ TRedStar Γ S2 T2 star.
Proof.
  depind H; simpl; intros.
  - dependent destruction jm34. eauto 10 using TRedStar.
  - destruct (IHTRedStar) as [T1 [T2 [Teq [S1T1 S2T2]]]]; subst.
    dependent destruction jm36; exists T0, T3; eauto 20 using TRedStar.
Qed.

(* Lemma 30.3.12.2 *)
Lemma tred_tall_preservation {Γ K1 S2 T} (H : TRedStar Γ (tall K1 S2) T star) :
  ∃ T2, T = tall K1 T2 ∧ TRedStar (etvar Γ K1) S2 T2 star.
Proof.
  depind H; simpl; intros.
  - dependent destruction jm34.
    exists S2; repeat split; auto; constructor; auto.
  - destruct (IHTRedStar) as [T1 [Teq S2T2]]; subst.
    inversion jm36; exists T2; repeat split; eauto 20 using QRS_Cons.
Qed.

Lemma can_form_tarr' {t S T1 T2} (v: Value t) (wt: Typing empty t S) :
  TyEq empty S (tarr T1 T2) star → ∃ t' T1', t = abs T1' t'.
Proof.
  depind wt; intros; try contradiction; eauto using Q_Trans.
  - destruct (teq_tred H) as [V [H1 H2]].
    destruct (tred_tarr_preservation H2) as [T3 [T4 [Teq]]].
    destruct (tred_tall_preservation H1) as [T5 [Teq2]].
    subst; discriminate.
Qed.

Lemma can_form_tarr {t T1 T2} (v: Value t) (wt: Typing empty t (tarr T1 T2)) :
  ∃ t' T1', t = abs T1' t'.
Proof.
  eapply (can_form_tarr' v wt).
  eapply Q_Refl; eauto using wf_empty, typing_kinding with infra.
Qed.

Lemma can_form_tall' {t S} (v: Value t) (wt: Typing empty t S) :
  ∀ K1 T2, TyEq empty S (tall K1 T2) star →
  ∃ t' K1', t = tyabs K1' t'.
Proof.
  depind wt; intros; try contradiction; eauto using Q_Trans.
  - destruct (teq_tred H) as [V [H1 H2]].
    destruct (tred_tarr_preservation H1) as [T3 [T4 [Teq]]].
    destruct (tred_tall_preservation H2) as [T5 [Teq2]].
    subst; discriminate.
Qed.

Lemma can_form_tall {t K1 T2} (v: Value t) (wt: Typing empty t (tall K1 T2)) :
  ∃ t' K1', t = tyabs K1' t'.
Proof.
  eapply (can_form_tall' v wt).
  eauto using Q_Refl, wf_empty, typing_kinding.
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with destruct_conjs; subst; eauto using red.
  depind wt; simpl; auto.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [v1|[t1' r1]]...
    destruct (can_form_tall v1 wt)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma tyeq_tarr_inversion {Γ S1 S2 T1 T2} :
  TyEq Γ (tarr S1 S2) (tarr T1 T2) star →
  TyEq Γ S1 T1 star ∧ TyEq Γ S2 T2 star.
Proof.
  intro q; destruct (teq_tred q) as [V [SV TV]].
  destruct (tred_tarr_preservation TV) as [V1' [V2' [Veq' [T1V1 T2V2]]]].
  destruct (tred_tarr_preservation SV) as [V1 [V2 [Veq [S1V1 S2V2]]]]; subst.
  dependent destruction Veq; split; eapply Q_Trans;
    eauto using tredstar_tyeq, Q_Symm.
Qed.

Lemma abs_inversion' {Γ S S1 s2} (wt: Typing Γ (abs S1 s2) S) :
  ∀ {T1 T2}, TyEq Γ S (tarr T1 T2) star →
        TyEq Γ T1 S1 star ∧ Typing (evar Γ S1) s2 T2.
Proof.
  depind wt; simpl; intros; eauto using Q_Trans.
  - destruct (tyeq_tarr_inversion H);
      eauto using Q_Symm, T_Eq with infra.
Qed.

Lemma abs_inversion {Γ S1 T1 T2 s2} (wΓ: wf_env Γ)
  (wt: Typing Γ (abs S1 s2) (tarr T1 T2)) :
  TyEq Γ T1 S1 star ∧ Typing (evar Γ S1) s2 T2.
Proof.
  apply abs_inversion' with (1 := wt);
    eauto using Q_Refl, typing_kinding.
Qed.

Lemma tyeq_tall_inversion {Γ J1 K1 S2 T2} :
  TyEq Γ (tall J1 S2) (tall K1 T2) star →
  J1 = K1 ∧ TyEq (etvar Γ K1) S2 T2 star.
Proof.
  intro q; destruct (teq_tred q) as [V [SV TV]].
  destruct (tred_tall_preservation TV) as [V2' [Veq' T2V2]].
  destruct (tred_tall_preservation SV) as [V2  [Veq S2V2]]; subst.
  dependent destruction Veq; split; auto; eapply (Q_Trans _ _ S2 V2);
    eauto with infra; [idtac | eapply Q_Symm];
    eauto using tredstar_tyeq with infra.
Qed.

Lemma tabs_inversion' {Γ S J1 s2} (wt: Typing Γ (tyabs J1 s2) S) :
  ∀ K1 T2, TyEq Γ S (tall K1 T2) star → J1 = K1 ∧ Typing (etvar Γ K1) s2 T2.
Proof.
  depind wt; simpl; intros.
  - destruct (tyeq_tall_inversion H); subst; eauto 8 using T_Eq with infra.
  - apply IHwt; eauto using Q_Trans.
Qed.

Lemma tabs_inversion {Γ J1 K1 T2 s2} (wΓ: wf_env Γ)
  (wt: Typing Γ (tyabs J1 s2) (tall K1 T2)) :
  J1 = K1 ∧ Typing (etvar Γ J1) s2 T2.
Proof.
  assert (J1 = K1 ∧ Typing (etvar Γ K1) s2 T2).
  apply (tabs_inversion' wt); eauto using Q_Refl, typing_kinding.
  destruct_conjs; subst; auto.
Qed.

Lemma preservation {Γ t U} (wΓ: wf_env Γ) (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - destruct (abs_inversion wΓ wt1) as [eq11 wt12].
    eauto using T_Eq, subst_evar_Typing with infra.
  - destruct (tabs_inversion wΓ wt) as [e11 wt12]; subst;
      eauto using subst_etvar_Typing with infra.
Qed.


Require Import Coq.Strings.String.
Require Import Coq.Unicode.Utf8.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat choice
  seq ssrint rat ssralg ssrnum intdiv.

From extructures Require Import ord fset.

From deriving Require Import deriving.

From Netter Require Import Extra.

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

Local Open Scope fset_scope.

(** Variables correspond to state variables that appear in user source
code. They carry a number so that we can always generate fresh variables with
the same base name (though this functionality is not being used right now). *)

Inductive var := Var {vname : string; vnum : nat}.

Definition var_indDef := Eval simpl in [indDef for var_rect].
Canonical var_indType := IndType var var_indDef.
Definition var_eqMixin := Eval simpl in [derive eqMixin for var].
Canonical var_eqType := EqType var var_eqMixin.
Definition var_choiceMixin := [derive choiceMixin for var].
Canonical var_choiceType := Eval hnf in ChoiceType var var_choiceMixin.
Definition var_ordMixin := Eval simpl in [derive ordMixin for var].
Canonical var_ordType := OrdType var var_ordMixin.
Definition var_countMixin := [derive countMixin for var].
Canonical var_countType := Eval hnf in CountType var var_countMixin.

(** A symbol is either a state variable or a formula identifier.  This
distinction does not exist in the Haskell implementation, but we introduce it
here because the substitution and evaluation functions have different behaviors
on state variables and formulas. For simplicity, symbols can only be used in
integer expressions below; thus, the states of our language will only store
integers as well. *)

Inductive symbol :=
| SVar of var
| SFor of nat.

Coercion SVar : var >-> symbol.

Definition var_of_sym (s : symbol) : option var :=
  if s is SVar v then Some v else None.

Lemma SVarK : pcancel SVar var_of_sym.
Proof. by case. Qed.

Definition symbol_indDef := [indDef for symbol_rect].
Canonical symbol_indType := Eval hnf in IndType symbol symbol_indDef.
Definition symbol_eqMixin := [derive eqMixin for symbol].
Canonical symbol_eqType := Eval hnf in EqType symbol symbol_eqMixin.
Definition symbol_choiceMixin := [derive choiceMixin for symbol].
Canonical symbol_choiceType := Eval hnf in ChoiceType symbol symbol_choiceMixin.
Definition symbol_ordMixin := [derive ordMixin for symbol].
Canonical symbol_ordType := Eval hnf in OrdType symbol symbol_ordMixin.
Definition symbol_countMixin := [derive countMixin for symbol].
Canonical symbol_countType := Eval hnf in CountType symbol symbol_countMixin.

(** Various operators that appear in the syntax. *)

Inductive comp_op :=
| Leq
| Ltq.

Definition comp_op_indDef := [indDef for comp_op_rect].
Canonical comp_op_indType := Eval hnf in IndType comp_op comp_op_indDef.
Definition comp_op_eqMixin := [derive eqMixin for comp_op].
Canonical comp_op_eqType := Eval hnf in EqType comp_op comp_op_eqMixin.
Definition comp_op_choiceMixin := [derive choiceMixin for comp_op].
Canonical comp_op_choiceType := Eval hnf in ChoiceType comp_op comp_op_choiceMixin.
Definition comp_op_ordMixin := [derive ordMixin for comp_op].
Canonical comp_op_ordType := Eval hnf in OrdType comp_op comp_op_ordMixin.
Definition comp_op_countMixin := [derive countMixin for comp_op].
Canonical comp_op_countType := Eval hnf in CountType comp_op comp_op_countMixin.

Inductive log_op :=
| And
| Or.

Definition log_op_indDef := [indDef for log_op_rect].
Canonical log_op_indType := Eval hnf in IndType log_op log_op_indDef.
Definition log_op_eqMixin := [derive eqMixin for log_op].
Canonical log_op_eqType := Eval hnf in EqType log_op log_op_eqMixin.
Definition log_op_choiceMixin := [derive choiceMixin for log_op].
Canonical log_op_choiceType := Eval hnf in ChoiceType log_op log_op_choiceMixin.
Definition log_op_ordMixin := [derive ordMixin for log_op].
Canonical log_op_ordType := Eval hnf in OrdType log_op log_op_ordMixin.
Definition log_op_countMixin := [derive countMixin for log_op].
Canonical log_op_countType := Eval hnf in CountType log_op log_op_countMixin.

Inductive arith_op :=
| Plus
| Times
| Minus.

Definition arith_op_indDef := [indDef for arith_op_rect].
Canonical arith_op_indType := Eval hnf in IndType arith_op arith_op_indDef.
Definition arith_op_eqMixin := [derive eqMixin for arith_op].
Canonical arith_op_eqType := Eval hnf in EqType arith_op arith_op_eqMixin.
Definition arith_op_choiceMixin := [derive choiceMixin for arith_op].
Canonical arith_op_choiceType := Eval hnf in ChoiceType arith_op arith_op_choiceMixin.
Definition arith_op_ordMixin := [derive ordMixin for arith_op].
Canonical arith_op_ordType := Eval hnf in OrdType arith_op arith_op_ordMixin.
Definition arith_op_countMixin := [derive countMixin for arith_op].
Canonical arith_op_countType := Eval hnf in CountType arith_op arith_op_countMixin.

Inductive trunc_op :=
| Ceil
| Floor.

Definition trunc_op_indDef := [indDef for trunc_op_rect].
Canonical trunc_op_indType := Eval hnf in IndType trunc_op trunc_op_indDef.
Definition trunc_op_eqMixin := [derive eqMixin for trunc_op].
Canonical trunc_op_eqType := Eval hnf in EqType trunc_op trunc_op_eqMixin.
Definition trunc_op_choiceMixin := [derive choiceMixin for trunc_op].
Canonical trunc_op_choiceType := Eval hnf in ChoiceType trunc_op trunc_op_choiceMixin.
Definition trunc_op_ordMixin := [derive ordMixin for trunc_op].
Canonical trunc_op_ordType := Eval hnf in OrdType trunc_op trunc_op_ordMixin.
Definition trunc_op_countMixin := [derive countMixin for trunc_op].
Canonical trunc_op_countType := Eval hnf in CountType trunc_op trunc_op_countMixin.

(** The syntax of expressions proper.  In the Haskell code, expressions are
untyped, but here they are segregated into boolean, integer and rational
expressions for convenience. *)

Unset Elimination Schemes.
Inductive bexpr :=
| BConst of bool
| BEqB   of bexpr & bexpr
| BEqZ   of zexpr & zexpr
| BEqQ   of qexpr & qexpr
| BTest  of bexpr & bexpr & bexpr
| BCompZ of comp_op & zexpr & zexpr
| BCompQ of comp_op & qexpr & qexpr
| BLogOp of log_op & bexpr & bexpr
| BNot   of bexpr

with zexpr :=
| ZSym   of symbol
| ZConst of int
| ZTest  of bexpr & zexpr & zexpr
| ZArith of arith_op & zexpr & zexpr
| ZTrunc of trunc_op & qexpr

with qexpr :=
| QConst of rat
| QTest  of bexpr & qexpr & qexpr
| QArith of arith_op & qexpr & qexpr
| QOfZ   of zexpr.
Set Elimination Schemes.

Scheme bexpr_rect := Induction for bexpr Sort Type
with   zexpr_rect := Induction for zexpr Sort Type
with   qexpr_rect := Induction for qexpr Sort Type.

Combined Scheme expr_rect from bexpr_rect, zexpr_rect, qexpr_rect.

Scheme bexpr_ind := Induction for bexpr Sort Prop
with   zexpr_ind := Induction for zexpr Sort Prop
with   qexpr_ind := Induction for qexpr Sort Prop.

Combined Scheme expr_ind from bexpr_ind, zexpr_ind, qexpr_ind.

Definition expr_indDef := [indDef for expr_rect].
Canonical bexpr_indType := IndType bexpr expr_indDef.
Canonical zexpr_indType := IndType zexpr expr_indDef.
Canonical qexpr_indType := IndType qexpr expr_indDef.
(* EqType *)
Lemma bexpr_eqMixin : Equality.mixin_of bexpr.
Proof. exact: [derive nored eqMixin for bexpr]. Qed.
Canonical bexpr_eqType := EqType bexpr bexpr_eqMixin.
Lemma zexpr_eqMixin : Equality.mixin_of zexpr.
Proof. exact: [derive nored eqMixin for zexpr]. Qed.
Canonical zexpr_eqType := EqType zexpr zexpr_eqMixin.
Lemma qexpr_eqMixin : Equality.mixin_of qexpr.
Proof. exact: [derive nored eqMixin for qexpr]. Qed.
Canonical qexpr_eqType := EqType qexpr qexpr_eqMixin.
(* ChoiceType *)
Lemma bexpr_choiceMixin : Choice.mixin_of bexpr.
Proof. exact: [derive choiceMixin for bexpr]. Qed.
Canonical bexpr_choiceType := ChoiceType bexpr bexpr_choiceMixin.
Lemma zexpr_choiceMixin : Choice.mixin_of zexpr.
Proof. exact: [derive choiceMixin for zexpr]. Qed.
Canonical zexpr_choiceType := ChoiceType zexpr zexpr_choiceMixin.
Lemma qexpr_choiceMixin : Choice.mixin_of qexpr.
Proof. exact: [derive choiceMixin for qexpr]. Qed.
Canonical qexpr_choiceType := ChoiceType qexpr qexpr_choiceMixin.
(* Ord *)
Lemma bexpr_ordMixin : Ord.mixin_of bexpr.
Proof. exact: [derive nored ordMixin for bexpr]. Qed.
Canonical bexpr_ordType := OrdType bexpr bexpr_ordMixin.
Lemma zexpr_ordMixin : Ord.mixin_of zexpr.
Proof. exact: [derive nored ordMixin for zexpr]. Qed.
Canonical zexpr_ordType := OrdType zexpr zexpr_ordMixin.
Lemma qexpr_ordMixin : Ord.mixin_of qexpr.
Proof. exact: [derive nored ordMixin for qexpr]. Qed.
Canonical qexpr_ordType := OrdType qexpr qexpr_ordMixin.

(** Evaluate expressions given an interpretation of symbols [f]. *)

Section Eval.

Implicit Types (be : bexpr) (ze : zexpr) (qe : qexpr).

Fixpoint eval_bexpr f be : bool :=
  match be with
  | BConst b => b
  | BEqB be1 be2 => eval_bexpr f be1 == eval_bexpr f be2
  | BEqZ ze1 ze2 => eval_zexpr f ze1 == eval_zexpr f ze2
  | BEqQ qe1 qe2 => eval_qexpr f qe1 == eval_qexpr f qe2
  | BTest be be1 be2 => if eval_bexpr f be then eval_bexpr f be1
                        else eval_bexpr f be2
  | BCompZ Leq ze1 ze2 => (eval_zexpr f ze1 <= eval_zexpr f ze2)%R
  | BCompZ Ltq ze1 ze2 => (eval_zexpr f ze1 <  eval_zexpr f ze2)%R
  | BCompQ Leq qe1 qe2 => (eval_qexpr f qe1 <= eval_qexpr f qe2)%R
  | BCompQ Ltq qe1 qe2 => (eval_qexpr f qe1 <  eval_qexpr f qe2)%R
  | BLogOp And be1 be2 => eval_bexpr f be1 && eval_bexpr f be2
  | BLogOp Or  be1 be2 => eval_bexpr f be1 || eval_bexpr f be2
  | BNot be => ~~ eval_bexpr f be
  end

with eval_zexpr f ze : int :=
  match ze with
  | ZSym v => f v
  | ZConst n => n
  | ZTest be ze1 ze2 => if eval_bexpr f be then eval_zexpr f ze1
                        else eval_zexpr f ze2
  | ZArith Plus ze1 ze2 => eval_zexpr f ze1 + eval_zexpr f ze2
  | ZArith Times ze1 ze2 => eval_zexpr f ze1 * eval_zexpr f ze2
  | ZArith Minus ze1 ze2 => eval_zexpr f ze1 - eval_zexpr f ze2
  | ZTrunc Ceil qe =>
    let q := eval_qexpr f qe in
    ((numq q %/ denq q)%Z * denq q)%R
  | ZTrunc Floor qe =>
    let q := eval_qexpr f qe in
    let c := ((numq q %/ denq q)%Z * denq q)%R in
    if q == ratz c then c else (c + 1)%R
  end

with eval_qexpr f qe : rat :=
  match qe with
  | QConst x => x
  | QTest be qe1 qe2 => if eval_bexpr f be then eval_qexpr f qe1
                        else eval_qexpr f qe2
  | QArith Plus qe1 qe2 => eval_qexpr f qe1 + eval_qexpr f qe2
  | QArith Times qe1 qe2 => eval_qexpr f qe1 * eval_qexpr f qe2
  | QArith Minus qe1 qe2 => eval_qexpr f qe1 - eval_qexpr f qe2
  | QOfZ ze => ratz (eval_zexpr f ze)
  end.

(** Substitute an expression for a symbol. *)

Fixpoint subst_bexpr f be : bexpr :=
  match be with
  | BConst _ => be
  | BEqB be1 be2 => BEqB (subst_bexpr f be1) (subst_bexpr f be2)
  | BEqZ ze1 ze2 => BEqZ (subst_zexpr f ze1) (subst_zexpr f ze2)
  | BEqQ qe1 qe2 => BEqQ (subst_qexpr f qe1) (subst_qexpr f qe2)
  | BTest be be1 be2 =>
    BTest (subst_bexpr f be) (subst_bexpr f be1) (subst_bexpr f be2)
  | BCompZ o ze1 ze2 => BCompZ o (subst_zexpr f ze1) (subst_zexpr f ze2)
  | BCompQ o qe1 qe2 => BCompQ o (subst_qexpr f qe1) (subst_qexpr f qe2)
  | BLogOp o be1 be2 => BLogOp o (subst_bexpr f be1) (subst_bexpr f be2)
  | BNot be => BNot (subst_bexpr f be)
  end

with subst_zexpr f ze : zexpr :=
  match ze with
  | ZSym v => f v
  | ZConst _ => ze
  | ZTest be ze1 ze2 =>
    ZTest (subst_bexpr f be) (subst_zexpr f ze1) (subst_zexpr f ze2)
  | ZArith o ze1 ze2 =>
    ZArith o (subst_zexpr f ze1) (subst_zexpr f ze2)
  | ZTrunc o qe =>
    ZTrunc o (subst_qexpr f qe)
  end

with subst_qexpr f qe : qexpr :=
  match qe with
  | QConst _ => qe
  | QTest be qe1 qe2 =>
    QTest (subst_bexpr f be) (subst_qexpr f qe1) (subst_qexpr f qe2)
  | QArith o qe1 qe2 => QArith o (subst_qexpr f qe1) (subst_qexpr f qe2)
  | QOfZ ze => QOfZ (subst_zexpr f ze)
  end.

Ltac solve_subst_exprP :=
  match goal with
  | [e : ?x = ?y |- context[?x]] =>
    rewrite {}e
  end.

(** Substitution commutes with evaluation. *)

Lemma subst_exprP f g :
  (forall e,
      eval_bexpr f (subst_bexpr g e) =
      eval_bexpr (fun v => eval_zexpr f (g v)) e) /\
  (forall e,
      eval_zexpr f (subst_zexpr g e) =
      eval_zexpr (fun v => eval_zexpr f (g v)) e) /\
  (forall e,
      eval_qexpr f (subst_qexpr g e) =
      eval_qexpr (fun v => eval_zexpr f (g v)) e).
Proof.
apply: expr_ind=> //=; try by (move=> *; repeat solve_subst_exprP).
Qed.

Lemma subst_bexprP f g e :
  eval_bexpr f (subst_bexpr g e) =
  eval_bexpr (fun v => eval_zexpr f (g v)) e.
Proof.
by case: (subst_exprP f g)=> [?[??]].
Qed.

Lemma subst_zexprP f g e :
  eval_zexpr f (subst_zexpr g e) =
  eval_zexpr (fun v => eval_zexpr f (g v)) e.
Proof.
by case: (subst_exprP f g)=> [?[??]].
Qed.

Lemma subst_qexprP f g e :
  eval_qexpr f (subst_qexpr g e) =
  eval_qexpr (fun v => eval_zexpr f (g v)) e.
Proof.
by case: (subst_exprP f g)=> [?[??]].
Qed.

End Eval.

(** Compute all symbols used in an expression. *)

Fixpoint bexpr_syms be :=
  match be with
  | BConst _         => fset0
  | BEqB be1 be2     => bexpr_syms be1 :|: bexpr_syms be2
  | BEqZ ze1 ze2     => zexpr_syms ze1 :|: zexpr_syms ze2
  | BEqQ qe1 qe2     => qexpr_syms qe1 :|: qexpr_syms qe2
  | BTest be be1 be2 => bexpr_syms be  :|: bexpr_syms be1 :|: bexpr_syms be2
  | BCompZ _ ze1 ze2 => zexpr_syms ze1 :|: zexpr_syms ze2
  | BCompQ _ qe1 qe2 => qexpr_syms qe1 :|: qexpr_syms qe2
  | BLogOp _ be1 be2 => bexpr_syms be1 :|: bexpr_syms be2
  | BNot be          => bexpr_syms be
  end

with zexpr_syms ze :=
  match ze with
  | ZSym v           => fset1 v
  | ZConst _         => fset0
  | ZTest be ze1 ze2 => bexpr_syms be  :|: zexpr_syms ze1 :|: zexpr_syms ze2
  | ZArith _ ze1 ze2 => zexpr_syms ze1 :|: zexpr_syms ze2
  | ZTrunc _ qe      => qexpr_syms qe
  end

with qexpr_syms qe :=
  match qe with
  | QConst _         => fset0
  | QTest be qe1 qe2 => bexpr_syms be  :|: qexpr_syms qe1 :|: qexpr_syms qe2
  | QArith _ qe1 qe2 => qexpr_syms qe1 :|: qexpr_syms qe2
  | QOfZ ze          => zexpr_syms ze
  end.

Ltac solve_eq_in_eval_exprP :=
  move=> *;
  repeat match goal with
         | [H : is_true (fsubset (_ :|: _) _) |- _] =>
           rewrite fsubUset in H
         | [H : is_true (_ && _) |- _] =>
           case/andP: H=> ??
         | [IH : ?P -> _, H : ?P |- _] =>
           move/(_ H) in IH
         | [H : ?x = _ |- context[?x]] => rewrite {}H
         | [x : _ |- _] =>
           match goal with
           | [ |- context[match x with _ => _ end]] =>
             case: x=> * /=
           end
         end.

Implicit Types V : {fset symbol}.

(** Symbols that do not appear in an expression have no effect when evaluating
it. *)

Lemma eq_in_eval_expr V f g :
  {in V, f =1 g} ->
  (forall be, fsubset (bexpr_syms be) V ->
              eval_bexpr f be = eval_bexpr g be) /\
  (forall ze, fsubset (zexpr_syms ze) V ->
              eval_zexpr f ze = eval_zexpr g ze) /\
  (forall qe, fsubset (qexpr_syms qe) V ->
              eval_qexpr f qe = eval_qexpr g qe).
Proof.
move=> efg; apply: expr_ind=> //=; try by solve_eq_in_eval_exprP.
move=> v; rewrite fsub1set; exact: efg.
Qed.

Lemma eq_in_eval_bexpr V f g :
  {in V, f =1 g} ->
  forall e, fsubset (bexpr_syms e) V ->
  eval_bexpr f e = eval_bexpr g e.
Proof. by move=> /eq_in_eval_expr [? [? ?]]. Qed.

Lemma eq_in_eval_zexpr V f g :
  {in V, f =1 g} ->
  forall e, fsubset (zexpr_syms e) V ->
  eval_zexpr f e = eval_zexpr g e.
Proof. by move=> /eq_in_eval_expr [? [? ?]]. Qed.

Lemma eq_eval_bexpr f g :
  f =1 g ->
  forall e, eval_bexpr f e = eval_bexpr g e.
Proof.
move=> fg ?; apply: eq_in_eval_bexpr (fsubsetxx _).
move=> ??; exact: fg.
Qed.

Lemma eq_eval_zexpr f g :
  f =1 g ->
  forall e, eval_zexpr f e = eval_zexpr g e.
Proof.
move=> fg ?; apply: eq_in_eval_zexpr (fsubsetxx _).
move=> ??; exact: fg.
Qed.

(** The [formulas] type defines formula environments, which are maps from nats
(formula identifiers) to integer expressions.  The definitions on this list can
mention other formulas.  The indices are always references to formulas that
appear later on the list.  Thus, the definitions are well founded. *)

Definition formulas := seq (nat * zexpr).

(** Given a formula environment [defs], a state [st] and a formula [f], we can
evaluate [f] under the environment [defs] and state [st].  *)

Fixpoint feval_forms (defs : formulas) st (f : nat) : int :=
  if defs is (f', e) :: fs then
    if f' == f then
      let eval s := match s with
                    | SVar v => st v
                    | SFor f => feval_forms fs st f
                    end in
      eval_zexpr eval e
    else feval_forms fs st f
  else 0.

Definition feval_sym defs st s : int :=
  match s with
  | SVar v => st v
  | SFor f => feval_forms defs st f
  end.

(** Compute the set of state variables that are needed to evaluate a formula [f]
under a formula environment [defs].  *)

Fixpoint formula_vars (defs : formulas) (f : nat) : {fset var} :=
  if defs is (f', e) :: defs then
    if f' == f then
      \bigcup_(s <- zexpr_syms e)
         match s with
         | SVar v   => fset1 v
         | SFor f'' => formula_vars defs f''
         end
    else formula_vars defs f
  else fset0.

Definition sym_vars defs s : {fset var} :=
  match s with
  | SVar v => fset1 v
  | SFor f => formula_vars defs f
  end.

(** If two states [st1] and [st2] agree on the state variables that are needed
to compute the value of [s] under the formulas [defs], then evaluating [s] under
the two yields the same result. *)

Lemma eq_in_feval_sym defs st1 st2 s :
  {in sym_vars defs s, st1 =1 st2} ->
  feval_sym defs st1 s = feval_sym defs st2 s.
Proof.
case: s=> [v|f] /= est; first by apply: est; exact/fset1P.
elim: defs f est=> [|[f e] defs IH] //= f'.
case: (altP (f =P f'))=> [{f'} _|ne] est; last exact: IH.
apply/eq_in_eval_zexpr; last exact/fsubsetxx.
move=> [v|f'] in_e.
  by apply: est; apply/bigcupP; exists (SVar v); rewrite // in_fset1 eqxx.
by apply: IH=> // v in_f'; apply: est; apply/bigcupP; exists (SFor f').
Qed.

(** Lift symbol evaluation and variable dependencies to expressions. *)

Definition feval_bexpr defs st e :=
  eval_bexpr (feval_sym defs st) e.

Definition feval_zexpr defs st e :=
  eval_zexpr (feval_sym defs st) e.

Definition feval_qexpr defs st e :=
  eval_qexpr (feval_sym defs st) e.

Definition bexpr_vars defs e :=
  \bigcup_(s <- bexpr_syms e) sym_vars defs s.

Definition zexpr_vars defs e :=
  \bigcup_(s <- zexpr_syms e) sym_vars defs s.

Definition qexpr_vars defs e :=
  \bigcup_(s <- qexpr_syms e) sym_vars defs s.

Lemma eq_in_feval_bexpr defs st1 st2 e :
  {in bexpr_vars defs e, st1 =1 st2} ->
  feval_bexpr defs st1 e = feval_bexpr defs st2 e.
Proof.
move=> est; rewrite /feval_bexpr /bexpr_vars.
apply/eq_in_eval_bexpr; last exact: fsubsetxx.
move=> s s_e; apply: eq_in_feval_sym=> v v_s.
by apply: est; apply/bigcupP; exists s.
Qed.

Lemma eq_in_feval_zexpr defs st1 st2 e :
  {in zexpr_vars defs e, st1 =1 st2} ->
  feval_zexpr defs st1 e = feval_zexpr defs st2 e.
Proof.
move=> est; rewrite /feval_zexpr /zexpr_vars.
apply/eq_in_eval_zexpr; last exact: fsubsetxx.
move=> s s_e; apply: eq_in_feval_sym=> v v_s.
by apply: est; apply/bigcupP; exists s.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e511m481_23limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.