(** * Stlc: The Simply Typed Lambda-Calculus *)

(* $Date: 2012-07-25 16:43:16 -0400 (Wed, 25 Jul 2012) $ *)

Require Export Types.

(* ###################################################################### *)
(** * The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core calculus
    embodying the key concept of _functional abstraction_, which shows
    up in pretty much every real-world programming language in some
    form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous
    chapter when formalizing this calculus (syntax, small-step
    semantics, typing rules) and its main properties (progress and
    preservation).  The new technical challenges (which will take some
    work to deal with) all arise from the mechanisms of _variable
    binding_ and _substitution_. *)

(* ###################################################################### *)
(** ** Overview *)

(** The STLC is built on some collection of _base types_ -- booleans,
    numbers, strings, etc.  The exact choice of base types doesn't
    matter -- the construction of the language and its theoretical
    properties work out pretty much the same -- so for the sake of
    brevity let's take just [Bool] for the moment.  At the end of the
    chapter we'll see how to add more base types, and in later
    chapters we'll enrich the pure STLC with other useful constructs
    like pairs, records, subtyping, and mutable state.

    Starting from the booleans, we add three things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out here in informal BNF notation -- we'll
    formalize it below).

*)

(** Informal concrete syntax:
<<
       t ::= x                       variable
           | \x:T.t1                 abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional
>>
*)

(** The [\] symbol in a function abstraction [\x:T.t1] is often
    written as a greek "lambda" (hence the name of the calculus).  The
    variable [x] is called the _parameter_ to the function; the term
    [t1] is its _body_.  The annotation [:T] specifies the type of
    arguments that the function can be applied to.

    Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true].

      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (Note that, as in Coq, a two-argument function
        is really a one-argument function whose body is also a
        one-argument function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].
        Note that, as in Coq, application associates to the left --
        i.e., this expression is parsed as [((\x:Bool. \y:Bool. x)
        false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    Another point to note is that the STLC doesn't provide any
    primitive syntax for defining _named_ functions -- all functions
    are "anonymous."  We'll see in chapter [MoreStlc] that it is easy
    to add named functions to what we've got -- indeed, the
    fundamental naming and binding mechanisms are exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**
<<
      T ::= Bool
          | T1 -> T2
>>
    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool] (i.e. [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool]

      - [\f:Bool->Bool. f (f true)] has type [(Bool->Bool) -> Bool]

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)] has type [Bool]
*)

(* ###################################################################### *)
(** ** Syntax *)

Module STLC.

(* ################################### *)
(** *** Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* ################################### *)
(** *** Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "ttrue"
  | Case_aux c "tfalse" | Case_aux c "tif" ].

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use _type inference_ to fill in missing annotations.  We're
    not considering type inference here, to keep things simple. *)

(** Some examples... *)

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool)->(Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

(* ###################################################################### *)
(** ** Operational Semantics *)

(** To define the small-step semantics of STLC terms, we begin -- as
    always -- by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

(* ################################### *)
(** *** Values *)

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  (An [if]
    expression is never a value.)

    Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do.

    Third, for abstractions, we have a choice:

      - We can say that [\x:T.t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T.t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Coq (in its built-in functional programming langauge) makes the
    first choice -- for example,
         Eval simpl in (fun x:bool => 3 + 4)
    yields [fun x:bool => 7].  But most real-world functional
    programming languages make the second choice -- reduction of a
    function's body only begins when the function is actually applied
    to an argument.  We also make the second choice here.

    Finally, having made the choice not to reduce under abstractions,
    we don't need to worry about whether variables are values, since
    we'll always be reducing programs "from the outside in," and that
    means the [step] relation will always be working with closed
    terms (ones with no free variables).  *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | t_true :
      value ttrue
  | t_false :
      value tfalse.

Hint Constructors value.

(* ###################################################################### *)
(** *** Free Variables and Substitution *)

(** Now we come to the heart of the matter: the operation of
    substituting one term for a variable in another term.

    This operation will be used below to define the operational
    semantics of function application, where we will need to
    substitute the argument term for the function parameter in the
    function's body.  For example, we reduce
       (\x:Bool. if x then true else x) false
    to [false] by substituting [false] for the parameter [x] in the
    body of the function.  In general, we need to be able to
    substitute some given term [s] for occurrences of some variable
    [x] in another term [t].  In informal discussions, this is usually
    written [ [x:=s]t ] and pronounced "substitute [x] with [s] in [t]."

    Here are some examples:

      - [[x:=true] (if x then x else false)] yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)] yields [\y:Bool. if y then true else false]
      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x]. *)

(** Here is the definition, informally...
   [x:=s]x = s
   [x:=s]y = y                                   if x <> y
   [x:=s](\x:T11.t12)   = \x:T11. t12
   [x:=s](\y:T11.t12)   = \y:T11. [x:=s]t12      if x <> y
   [x:=s](t1 t2)        = ([x:=s]t1) ([x:=s]t2)
   [x:=s]true           = true
   [x:=s]false          = false
   [x:=s](if t1 then t2 else t3) =
                   if [x:=s]t1 then [x:=s]t2 else [x:=s]t3
]]
    ... and formally: *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else (subst x s t1))
  | tapp t1 t2 =>
      tapp (subst x s t1) (subst x s t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif (subst x s t1) (subst x s t2) (subst x s t3)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x y] that mention
    variables are not bound by some enclosing lambda), we can avoid
    this extra complexity here. *)

(* ################################### *)
(** *** Reduction *)

(** The small-step reduction relation for STLC now follows the same
    pattern as the ones we have seen before.  Intuitively, to reduce a
    function application, we first reduce its left-hand side until it
    becomes a literal function; then we reduce its right-hand
    side (the argument) until it is also a value; and finally we
    substitute the argument for the bound variable in the body of the
    function.  This last rule, written informally as
      (\x:T.t12) v2 ==> [x:=v2]t12
    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'
*)
(** ... plus the usual rules for booleans:
                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

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

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

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

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

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2" | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse" | Case_aux c "ST_If" ].

Hint Constructors step.

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

(* ##################################### *)
(** *** Examples *)

(** Example:
    ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)
i.e.
    (idBB idB) ==>* idB
*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** A more automatic proof *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Again, we can use the [normalize] tactic from above to simplify
    the proof. *)

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  normalize.
Qed.

(** **** Exercise: 2 stars (step_example3) *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example3 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.

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

(* ###################################################################### *)
(** ** Typing *)

(* ################################### *)
(** *** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place "typing judgment", informally
    written [Gamma |- t : T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** We hide the definition of partial maps in a module since it is
    actually defined in [SfLib]. *)

Module PartialMap.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.

End PartialMap.

Definition context := partial_map ty.

(* ################################### *)
(** *** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x : T

                      Gamma , x:T11 |- t12 : T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 : T11->T12

                        Gamma |- t1 : T11->T12
                          Gamma |- t2 : T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 : T12

                         --------------------                          (T_True)
                         Gamma |- true : Bool

                        ---------------------                         (T_False)
                        Gamma |- false : Bool

       Gamma |- t1 : Bool    Gamma |- t2 : T    Gamma |- t3 : T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 : T
*)

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tvar x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T11 T12 Gamma t1 t2,
      has_type Gamma t1 (TArrow T11 T12) ->
      has_type Gamma t2 T11 ->
      has_type Gamma (tapp t1 t2) T12
  | T_True : forall Gamma,
       has_type Gamma ttrue TBool
  | T_False : forall Gamma,
       has_type Gamma tfalse TBool
  | T_If : forall t1 t2 t3 T Gamma,
       has_type Gamma t1 TBool ->
       has_type Gamma t2 T ->
       has_type Gamma t3 T ->
       has_type Gamma (tif t1 t2 t3) T.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If" ].

Hint Constructors has_type.

(* ################################### *)
(** *** Examples *)

Example typing_example_1 :
  has_type empty (tabs x TBool (tvar x)) (TArrow TBool TBool).
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  has_type empty (tabs x TBool (tvar x)) (TArrow TBool TBool).
Proof. auto.  Qed.

Hint Unfold beq_id beq_nat extend.

(** Another example:
     empty |- \x:A. \y:A->A. y (y x))
           : A -> (A->A) -> A.
*)

Example typing_example_2 :
  has_type empty
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x)))))
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using extend_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** **** Exercise: 2 stars, optional (typing_example_2_full) *)
(** Prove the same result without using [auto], [eauto], or
    [eapply]. *)

Example typing_example_2_full :
  has_type empty
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x)))))
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3) *)
(** Formally prove the following typing derivation holds: *)
(**
   empty |- (\x:Bool->B. \y:Bool->Bool. \z:Bool.
               y (x z))
         : T.
*)

Example typing_example_3 :
  exists T,
    has_type empty
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z))))))
      T.

Proof with auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,
    ~ exists T,
        empty |- (\x:Bool. \y:Bool, x y) : T.
*)

Example typing_nonexample_1 :
  ~ exists T,
      has_type empty
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y))))
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  (* rewrite extend_neq in H1. rewrite extend_eq in H1. *)
  inversion H1.  Qed.

(** **** Exercise: 3 stars (typing_nonexample_3) *)
(** Another nonexample:
    ~ (exists S, exists T,
          empty |- (\x:S. x x) : T).
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        has_type empty
          (tabs x S
             (tapp (tvar x) (tvar x)))
          T).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, optional (typing_statements) *)

(** Which of the following propositions are provable?
       - [y:Bool |- \x:Bool.x : Bool->Bool]

       - [exists T,  empty |- (\y:Bool->Bool. \x:Bool. y x) : T]

       - [exists T,  empty |- (\y:Bool->Bool. \x:Bool. x y) : T]

       - [exists S, x:S |- (\y:Bool->Bool. y) x : S]

       - [exists S, exists T,  x:S |- (x x x) : T]

[]
*)

(** **** Exercise: 1 star (more_typing_statements) *)

(** Which of the following propositions are provable?  For the
    ones that are, give witnesses for the existentially bound
    variables.
       - [exists T,  empty |- (\y:B->B->B. \x:B, y x) : T]

       - [exists T,  empty |- (\x:A->B, \y:B->C, \z:A, y (x z)):T]

       - [exists S, exists U, exists T,  x:S, y:U |- \z:A. x (y z) : T]

       - [exists S, exists T,  x:S |- \y:A. x (x y) : T]

       - [exists S, exists U, exists T,  x:S |- x (\z:U. z x) : T]

[]
*)

(* ###################################################################### *)
(** ** Properties *)

(* ###################################################################### *)
(** *** 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 an evaluation step. *)

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

(** _Proof_: by induction on the derivation of [|- t : 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 know immediately that [t] is a value.

    - If the last rule of the derivation was [T_App], then [t = t1
      t2], and we know that [t1] and [t2] are also well typed in the
      empty context; in particular, there exists a type [T2] such that
      [|- t1 : T2 -> T] and [|- t2 : T2].  By the induction
      hypothesis, either [t1] is a value or it can take an evaluation
      step.

        - If [t1] is a value, we now consider [t2], which by the other
          induction hypothesis must also either be a value or take an
          evaluation 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 was [T_If], then [t = if t1
      then t2 else t3], where [t1] has type [Bool].  By the IH, [t1]
      is either 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 ty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma...
  Case "T_Var".
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  Case "T_App".
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    SCase "t1 is a value".
      destruct IHHt2...
      SSCase "t2 is also a value".
        (* Since [t1] is a value and has an arrow type, it
           must be an abs. Sometimes this is proved separately
           and called a "canonical forms" lemma. *)
        inversion H; subst. exists ([x0:=t2]t)...
        solve by inversion. solve by inversion.
      SSCase "t2 steps".
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    SCase "t1 steps".
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  Case "T_If".
    right. destruct IHHt1...

    SCase "t1 is a value".
      (* Since [t1] is a value of boolean type, it must
         be true or false *)
      inversion H; subst. solve by inversion.
      SSCase "t1 = true". eauto.
      SSCase "t1 = false". eauto.

    SCase "t1 also steps".
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.

(** **** Exercise: 3 stars, optional (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,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  t_cases (induction t) Case; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** *** Free Occurrences *)

(** 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]  *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"
  | Case_aux c "afi_if1" | Case_aux c "afi_if2"
  | Case_aux c "afi_if3" ].

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

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

(* ###################################################################### *)
(** *** Substitution *)

(** We first need a technical lemma connecting free variables and
    typing contexts.  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 ->
   has_type Gamma t 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 was [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 was [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:T11.t12], and [x] appears free in [t12]; 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 [t12] is well typed under [(Gamma, y:T11)], so the IH
        allows us to conclude that [x] is assigned some type by the
        extended context [(Gamma, y:T11)].  To conclude that [Gamma]
        assigns a type to [x], we appeal to lemma [extend_neq], noting
        that [x] and [y] are different variables. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    apply not_eq_beq_id_false in H.
    rewrite extend_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed -- that is, it has no free variables. *)

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

(** Sometimes, when we have a proof [Gamma |- t : T], we will 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,
     has_type Gamma t T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     has_type Gamma' t T.

(** _Proof_: By induction on the derivation of [Gamma |- t : 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 : T] by [T_Var].

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

        By [T_Abs], it suffices to show that [Gamma', y:T11 |- t12 :
        T12].  By the IH (setting [Gamma'' = Gamma', y:T11]), it
        suffices to show that [Gamma, y:T11] and [Gamma', y:T11] agree
        on all the variables that appear free in [t12].

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

      - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
        t1 : T2 -> T] and [Gamma |- t2 : 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].  However, we note that all
        free variables in [t1] are also free in [t1 t2], and similarly
        for free variables in [t2]; hence the desired result follows
        by the two IHs.
*)

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  has_type_cases (induction H) Case; intros; auto.
  Case "T_Var".
    apply T_Var. rewrite <- H0...
  Case "T_Abs".
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [extend Gamma x T11] *)
    unfold extend. remember (beq_id x0 x1) as e. destruct e...
  Case "T_App".
    apply T_App with T11...
Qed.

(** 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 been
    able to assign 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 should be
    able to substitute [v] for each of the occurrences of [x] in [t]
    and obtain a new term that still has type [T]. *)

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

Lemma substitution_preserves_typing : forall Gamma x U t t' T,
     has_type (extend Gamma x U) t T ->
     has_type empty t' U   ->
     has_type Gamma ([x:=t']t) T.

(** One technical subtlety in the statement of the lemma is that we
    assign [t'] the type [U] in the _empty_ context -- in other words,
    we assume [t'] is closed.  This assumption considerably simplifies
    the [T_Abs] case of the proof (compared to assuming [Gamma |- t' :
    U], which would be the other reasonable assumption at this point)
    because the context invariance lemma then tells us that [t'] has
    type [U] in any context at all -- we don't have to worry about
    free variables in [t'] clashing with the variable being introduced
    into the context by [T_Abs].

    _Proof_: We prove, by induction on [t], that, for all [T] and
    [Gamma], if [Gamma,x:U |- t : T] and [|- t' : U], then [Gamma |-
    [x:=t']t : 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 [Gamma, x:U |- x : T] we
            conclude that [U = T].  We must show that [[x:=t']x = t'] has
            type [T] under [Gamma], given the assumption that [t'] has
            type [U = T] under the empty context.  This follows from
            context invariance: if a closed term has type [T] in the
            empty context, it has that type in any context.

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

      - If [t] is an abstraction [\y:T11. t12], then the IH tells us,
        for all [Gamma'] and [T'], that if [Gamma',x:U |- t12 : T']
        and [|- t' : U], then [Gamma' |- [x:=t']t12 : T'].

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

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=t']t = t], so we just need to show [Gamma |-
        t : T].  But we know [Gamma,x:U |- t : T], and since the
        variable [y] does not appear free in [\y:T11. t12], the
        context invariance lemma yields [Gamma |- t : T].

        Second, suppose [x <> y].  We know [Gamma,x:U,y:T11 |- t12 :
        T12] by inversion of the typing relation, and [Gamma,y:T11,x:U
        |- t12 : T12] follows from this by the context invariance
        lemma, so the IH applies, giving us [Gamma,y:T11 |- [x:=t']t12 :
        T12].  By [T_Abs], [Gamma |- \y:T11. [x:=t']t12 : T11->T12], and
        by the definition of substitution (noting that [x <> y]),
        [Gamma |- \y:T11. [x:=t']t12 : T11->T12] 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.

    Another technical note: This proof is a rare case where an
    induction on terms, rather than typing derivations, yields a
    simpler argument.  The reason for this is that the assumption
    [has_type (extend Gamma x U) t T] is not completely generic, in
    the sense that one of the "slots" in the typing relation -- namely
    the context -- is not just a variable, and this means that Coq's
    native induction tactic does not give us the induction hypothesis
    that we want.  It is possible to work around this, but the needed
    generalization is a little tricky.  The term [t], on the other
    hand, _is_ completely generic. *)

Proof with eauto.
  intros Gamma x U t t' T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  t_cases (induction t) Case; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  Case "tvar".
    rename i into y. remember (beq_id x y) as e. destruct e.
    SCase "x=y".
      apply beq_id_eq in Heqe. subst.
      rewrite extend_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      apply T_Var. rewrite extend_neq in H2...
  Case "tabs".
    rename i into y. apply T_Abs.
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
Qed.

(** 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. *)

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

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

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.

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

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

    - If the last rule in the derivation was [T_App], then [t = t1
      t2].  There are three cases to consider, one for each rule that
      could have been 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 IH [t1'] has the same type as [t1], and
          hence [t1' t2] has the same type as [t1 t2].

        - The [ST_App2] case is similar.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T11.t12] and [t1 t2] steps to [[x:=t2]t12]; the
          desired result now follows from the fact that substitution
          preserves types.

    - If the last rule in the derivation was [T_If], then [t = if t1
      then t2 else t3], and there are again three cases depending on
      how [t] steps.

        - If [t] steps to [t2] or [t3], 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 induction hypothesis.
*)

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

(** **** Exercise: 2 stars, recommended (subject_expansion_stlc) *)
(** An exercise in Types.v asked about the subject
    expansion property for the simple language of arithmetic and
    boolean expressions.  Does this property hold for STLC?  That
    is, is it always the case that, if [t ==> t'] and [has_type
    t' T], then [has_type t T]?  If so, prove it.  If not, give a
    counter-example.

(* FILL IN HERE *)
[]
*)

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

(** **** Exercise: 2 stars, 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 soundness : forall t t' T,
  has_type empty t 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 (types_unique) *)
(** Another pleasant property of the STLC is that types are
    unique: a given term (in a given context) has at most one
    type. *)
(** Formalize this statement and prove it. *)

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

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

(** **** Exercise: 1 star (progress_preservation_statement) *)
(** Without peeking, write down the progress and preservation
    theorems for the simply typed lambda-calculus. *)
(** [] *)

(** **** Exercise: 2 stars (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 : T
    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]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (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]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (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]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (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]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars (stlc_variation5) *)
(** Suppose instead that we add the following new rule to the typing relation:
                 Gamma |- t1 : Bool->Bool->Bool
                     Gamma |- t2 : Bool
                 ------------------------------          (T_FunnyApp)
                    Gamma |- t1 t2 : 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]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars (stlc_variation6) *)
(** Suppose instead that we add the following new rule to the typing relation:
                     Gamma |- t1 : Bool
                     Gamma |- t2 : Bool
                    ---------------------               (T_FunnyApp')
                    Gamma |- t1 t2 : 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]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars (stlc_variation7) *)
(** Suppose we add the following new rule to the typing
    relation of the STLC:
                         ------------------- (T_FunnyAbs)
                         |- \x:Bool.t : 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]

      - Progress

      - Preservation

[]
*)

End STLC.

(* ###################################################################### *)
(* ###################################################################### *)
(** * Optional 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.

(* ###################################################################### *)
(** ** Syntax and Operational Semantics *)

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

Inductive ty : Type :=
  | TArrow : ty -> ty -> ty
  | TNat   : ty.

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

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tnat  : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0  : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "tnat"
  | Case_aux c "tsucc" | Case_aux c "tpred"
  | Case_aux c "tmult" | Case_aux c "tif0" ].

(** **** Exercise: 4 stars, optional (stlc_arith) *)
(** Finish formalizing the definition and properties of the STLC extended
    with arithmetic.  Specifically:

    - Copy the whole development of STLC that we went through above (from
      the definition of values through the Progress theorem), and
      paste it into the file at this point.

    - Extend the definitions of the [subst] operation and the [step]
      relation to include appropriate clauses for the arithmetic operators.

    - Extend the proofs of all the properties of the original STLC to deal
      with the new syntactic forms.  Make sure Coq accepts the whole file. *)

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

End STLCArith.


(** A theory of dependent inductive families (here W-types) as a subset
    of a W-type *)

Require Import ZF ZFpairs ZFrelations ZFord ZFstable ZFind_w ZFfixfun.

Section DependentW.

(** Parameters of W-types *)
Variable A : set.
Variable B : set -> set.
Hypothesis Bm : morph1 B.
Let Bext : ext_fun A B.
apply morph_is_ext; trivial.
Qed.

(** Index type *)
Variable Arg : set.

(** Constraints on the subterms *)
Hypothesis f : set -> set -> set.
Hypothesis fm : morph2 f.
Hypothesis ftyp : forall x i,
  x ∈ A -> i ∈ B x -> f x i ∈ Arg.

(** Instance introduced by the constructors *)
Hypothesis g : set -> set -> Prop.
Hypothesis gm : Proper (eq_set==>eq_set==>iff) g.

(** The intended type operator:

    [Inductive Wd : Arg->Type := C (x:A) (_:forall i:B x, Wd(f x i)) : Wd(g x).

    is encoded as

    [Inductive Wd' (a:Arg) : Type := C' (x:A) (_:g x=a) (_:forall i:B x, Wd(f x i)).
 *)
Definition W_Fd (X:set->set) (a:set) :=
  Σ x ∈ subset A (fun x => g x a), Π i ∈ B x, X (f x i).

Instance W_Fd_morph :
  Proper ((eq_set ==> eq_set) ==> eq_set ==> eq_set) W_Fd.
do 3 red; intros.
apply sigma_ext; intros.
 apply subset_morph; auto with *.
 red; intros.
 rewrite H0; reflexivity.

 apply subset_elim1 in H1.
 apply cc_prod_ext; auto with *.
 red; intros.
 apply H.
 apply fm; auto.
Qed.

Lemma W_Fd_mono : mono_fam Arg W_Fd.
do 2 red; intros.
apply sigma_mono.
 do 2 red; intros.
 apply subset_elim1 in H3.
 apply cc_prod_ext; auto with *.
 red; intros.
 apply H; apply fm; auto.

 do 2 red; intros.
 apply subset_elim1 in H3.
 apply cc_prod_ext; auto with *.
 red; intros.
 apply H0; apply fm; auto.

 red; intros.
 rewrite subset_ax in H3|-*; destruct H3 as (?,(z',?,?)).
 split; trivial.
 exists z'; trivial.

 intros.
 apply subset_elim1 in H3.
 apply cc_prod_covariant; auto with *.
  do 2 red; intros.
  apply H0; apply fm; auto with *.

  intros.
  rewrite <- H4; apply H1; auto.
Qed.
Hint Resolve W_Fd_mono.

Lemma W_Fd_incl_W_F X Y :
  ext_fun Arg X ->
  (forall a, a ∈ Arg -> X a ⊆ Y) ->
  forall a, a ∈ Arg -> W_Fd X a ⊆ W_F A B Y.
intros.
apply sigma_mono.
 do 2 red; intros.
 apply subset_elim1 in H2.
 apply cc_prod_ext; auto with *.
 red; intros.
 apply H; auto.
 apply fm; trivial.

 do 2 red; intros; apply cc_arr_morph; auto with *.

 red; intros.
 apply subset_elim1 in H2; trivial.

 intros.
 apply subset_elim1 in H2.
 unfold cc_arr; apply cc_prod_covariant; auto with *.
Qed.
(*
Lemma W_Fd_def X Y :
  ext_fun Arg X ->
  (forall a, a ∈ Arg -> X a ⊆ Y) ->
  forall a, a ∈ Arg ->
  W_Fd X a == subset (W_F A B Y) (fun w =>
        g (fst w) == a /\
        forall i, i ∈ B (fst w) -> cc_app (snd w) i ∈ X (f (fst w) i)).
intros.
apply incl_eq.
 red; intros.
 rewrite subset_ax.
 split.
  revert H2; apply W_Fd_incl_W_F; trivial.

  exists z; auto with *.
  assert (fst z ∈ A).
   apply fst_typ_sigma in H2.
   apply subset_elim1 in H2; trivial.
  split; intros.
   apply fst_typ_sigma in H2.
   rewrite subset_ax in H2; destruct H2 as (_,(a',?,?)).
   rewrite H2; trivial.

   apply snd_typ_sigma with (y:=fst z) in H2; auto with *.
    apply cc_prod_elim with (1:=H2); trivial.

    do 2 red; intros.
    apply subset_elim1 in H5.
    apply cc_prod_ext; auto with *.
    red; intros; auto.
    apply H; auto with *.
    apply fm; trivial.

 red; intros.
 rewrite subset_ax in H2; destruct H2 as (?,(z',?,(?,?))).
 apply W_F_elim in H2; trivial.
 destruct H2 as (?,(?,?)).
 rewrite H7; apply couple_intro_sigma.
  do 2 red; intros.
  apply subset_elim1 in H8.
  apply cc_prod_ext; auto with *.
  red; intros.
  apply H; auto with *.
  apply fm; trivial.

  apply subset_intro; trivial.
  rewrite H3; trivial.

  apply cc_prod_intro; intros.
   do 2 red; intros; apply cc_app_morph; auto with *.

   do 2 red; intros.
   apply H; auto with *.
   apply fm; auto with *.

   assert (x ∈ B (fst z')).
    revert H8; apply eq_elim; apply Bext; trivial.
    apply fst_morph; trivial.
   specialize H5 with (1:=H9).
   revert H5; apply in_set_morph.
    rewrite H3; reflexivity.

    apply H; auto.
    rewrite H3; reflexivity.
Qed.
*)
(** Predicate characterizing the elements of the W-type that respect the
    index constraints *)
Inductive instance a w : Prop :=
  | I_node :
      fst w ∈ A ->
      g (fst w) a ->
      (forall i, i ∈ B (fst w) -> instance (f (fst w) i) (cc_app (snd w) i)) ->
      instance a w.

Instance inst_m : Proper (eq_set ==> eq_set ==> iff) instance.
apply morph_impl_iff2; auto with *.
do 4 red; intros.
revert y H y0 H0.
induction H1; constructor; intros.
 rewrite <- H4; trivial.

 rewrite <- H3; rewrite <- H4; trivial.

 apply H2 with i.
  rewrite (Bext _ _ H (fst_morph _ _ H4)); trivial.

  rewrite H4; reflexivity.

  rewrite H4; reflexivity.
Qed.

Lemma inst_inv o :
  isOrd o ->
  forall a, a ∈ Arg ->
  subset (TI (W_F A B) o) (instance a) == TIF Arg W_Fd o a.
induction 1 using isOrd_ind; intros.
rewrite TIF_eq; auto with *.
apply eq_set_ax; intros z.
rewrite subset_ax.
rewrite TI_eq; auto with *.
2:apply W_F_morph; trivial.
rewrite sup_ax.
 rewrite sup_ax.
  split; intros.
   destruct H3 as ((o',?,?),(z',?,?)).
   exists o'; trivial.
   apply W_F_elim in H4; trivial.
   destruct H4 as (?,(?,?)).
   rewrite H8.
   apply couple_intro_sigma.
    do 2 red; intros.
    apply subset_elim1 in H9.
    apply cc_prod_ext; auto with *.
    red; intros; apply TIF_morph; auto with *.
    apply fm; trivial.

    destruct H6 as (?,?,_).
    rewrite <- H5 in H9.
    apply subset_intro; trivial.

    apply cc_prod_intro; intros.
     do 2 red; intros; apply cc_app_morph; auto with *.

     do 2 red; intros.
     apply TIF_morph; auto with *.
     apply fm; auto with *.

     rewrite <- H1; auto.
     apply subset_intro; auto.
     rewrite <- H5 in H6.
     destruct H6 as (_,_,?); auto.

   destruct H3 as (o',?,?).
   split.
    exists o'; trivial.
    revert H4; apply W_Fd_incl_W_F; trivial.
     do 2 red; intros; apply TIF_morph; auto with *.

     intros.
     rewrite <- H1; auto.
     red; intros.
     apply subset_elim1 in H5; trivial.

     exists z; auto with *.
     assert (fst z ∈ A).
      apply fst_typ_sigma in H4.
      apply subset_elim1 in H4; trivial.
     constructor; intros; trivial.
      apply fst_typ_sigma in H4.
      rewrite subset_ax in H4.
      destruct H4 as (?,(x',?,?)).
      rewrite H6; trivial.

      apply snd_typ_sigma with (y:=fst z) in H4; auto with *.
       apply cc_prod_elim with (2:=H6) in H4.
       rewrite <- H1 in H4; auto.
       rewrite subset_ax in H4; destruct H4 as (_,(w',?,?)).
       rewrite H4; trivial.

       do 2 red; intros.
       apply subset_elim1 in H7.
       apply cc_prod_ext; auto.
       red; intros; apply TIF_morph; auto with *.
       apply fm; auto.

  do 2 red; intros.
  apply W_Fd_morph; auto with *.
  red; intros; apply TIF_morph; auto.

 do 2 red; intros.
 apply W_F_morph; auto with *.
 apply TI_morph; auto.
Qed.

(** Fixpoint of the W_Fd operator *)
Definition Wd := TIF Arg W_Fd (W_ord A B).

Lemma Wd_eqn : forall a, a ∈ Arg -> Wd a == W_Fd Wd a.
intros.
apply incl_eq.
 unfold Wd; rewrite <- TIF_mono_succ; auto with *.
 apply TIF_incl; auto with *.
  apply isOrd_succ.
  apply W_o_o; trivial.

  apply lt_osucc; apply W_o_o; trivial.

 apply W_o_o; trivial.

 red; intros.
 unfold Wd; rewrite <- inst_inv; trivial.
 2:apply W_o_o; trivial.
 apply subset_intro.
  change (z ∈ W A B).
  rewrite W_eqn; trivial.
  revert H0; apply W_Fd_incl_W_F; intros; auto.
   do 2 red; intros.
   apply TIF_morph; auto with *.

   red; intros.
   unfold Wd in H1.
   rewrite <- inst_inv in H1; auto.
   2:apply W_o_o; trivial.
   apply subset_elim1 in H1; trivial.

  unfold Wd in H0; rewrite <- TIF_mono_succ in H0; auto.
   rewrite <- inst_inv in H0; auto.
   2:apply isOrd_succ; apply W_o_o; trivial.
   rewrite subset_ax in H0; destruct H0 as (_,(?,?,?)).
   rewrite H0; trivial.

   apply W_Fd_morph.

   apply W_o_o; trivial.
Qed.

(*

(** Predicate characterizing the elements of the W-type that respect the
    index constraints *)
Inductive instance a w : Prop :=
| I_node :
    g (fst w) == a ->
    (forall i, i ∈ B (fst w) -> instance (f (fst w) i) (cc_app (snd w) i)) ->
    instance a w.

(** The intended type operator *)
Definition W_Fd (X:set->set) (a:set) :=
  subset (W_F A B (sup Arg X)) (instance a).

Instance W_Fd_morph :
  Proper ((eq_set ==> eq_set) ==> eq_set ==> eq_set) W_Fd.
do 3 red; intros.
apply subset_morph.
 apply W_F_morph; auto with *.
 apply sup_morph; auto with *.
 red; auto.

 red; intros.
 split; destruct 1; split; intros; auto.
  rewrite <- H0; trivial.
  rewrite H0; trivial.
Qed.

Lemma W_Fd_mono : mono_fam Arg W_Fd.
unfold W_Fd; do 3 red; intros.
rewrite subset_ax in H3|-*.
destruct H3; split; trivial.
revert H3; apply W_F_mono; auto with *.
red; intros.
rewrite sup_ax in H3|-*; auto with *.
destruct H3 as (a',?,?); exists a'; trivial.
revert H5; apply H1; trivial.
Qed.
Hint Resolve W_Fd_mono.

Lemma inst_inv o :
  isOrd o ->
  forall a, a ∈ Arg ->
  subset (TI (W_F A B) o) (instance a) == TIF Arg W_Fd o a.
induction 1 using isOrd_ind; intros.
rewrite TIF_eq; auto with *.
apply eq_set_ax; intros z.
rewrite subset_ax.
rewrite TI_eq; auto with *.
2:apply W_F_morph; trivial.
rewrite sup_ax.
 rewrite sup_ax.
  split; intros.
   destruct H3 as ((o',?,?),(z',?,?)).
   exists o'; trivial.
   rewrite H5; apply subset_intro; trivial.
   apply W_F_elim in H4; trivial.
   destruct H4 as (?,(?,?)).
   rewrite <- H5; rewrite H8.
   apply W_F_intro; intros; auto with *.
    do 2 red; intros; apply cc_app_morph; auto with *.
   rewrite sup_ax.
    destruct H6.
    exists (f (fst z') i).
     rewrite <- H5; auto.
    rewrite <- H1; auto.
    2:rewrite <- H5; auto.
    rewrite H5; apply subset_intro.
     rewrite <- H5; auto.

     apply H10.
     revert H9; apply eq_elim; apply Bext; auto.
     apply fst_morph; trivial.

    do 2 red; intros; apply TIF_morph; auto with *.

   destruct H3 as (o',?,?).
   unfold W_Fd at 1 in H4; rewrite subset_ax in H4.
   destruct H4 as (?,(z',?,?)).
   split.
    exists o'; trivial.
    revert H4; apply W_F_mono; auto with *.
    red; intros w ?.
    rewrite sup_ax in H4.
     destruct H4 as (a',?,?).
     rewrite <- H1 in H7; trivial.
     apply subset_elim1 in H7; trivial.

     do 2 red; intros; apply TIF_morph; auto with *.

    exists z'; trivial.

  do 2 red; intros; apply W_Fd_morph; auto with *.
  red; intros; apply TIF_morph; auto with *.

 do 2 red; intros; apply W_F_morph; trivial.
 apply TI_morph; trivial.
Qed.

(** Fixpoint of the W_Fd operator *)
Definition Wd := TIF Arg W_Fd (W_ord A B).

Lemma Wd_eqn : forall a, a ∈ Arg -> Wd a == W_Fd Wd a.
intros.
apply incl_eq.
 unfold Wd; rewrite <- TIF_mono_succ; auto with *.
 apply TIF_incl; auto with *.
  apply isOrd_succ.
  apply W_o_o; trivial.

  apply lt_osucc; apply W_o_o; trivial.

 apply W_o_o; trivial.

 red; intros.
 unfold W_Fd in H0.
 rewrite subset_ax in H0; destruct H0 as (?,(z',?,?)).
 unfold Wd; rewrite <- inst_inv; trivial.
 2:apply W_o_o; trivial.
 rewrite H1; apply subset_intro; trivial.
 rewrite <- H1.
 change (z ∈ W A B).
 rewrite W_eqn; trivial.
 revert H0; apply W_F_mono; auto with *.
 red; intros.
 rewrite sup_ax in H0.
  destruct H0 as (a',?,?).
  unfold Wd in H3; rewrite <- inst_inv in H3; trivial.
  2:apply W_o_o; trivial.
  apply subset_elim1 in H3; trivial.

 do 2 red; intros.
 apply TIF_morph; auto with *.
Qed.
*)

End DependentW.


Require Import RuntimeDefinitions.
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.

(* Enclave ID Equality *)
Definition equal_enclave_IDs (e0 : enclave_ID) (e1 : enclave_ID): bool :=
  match e0, e1 with
  | enclave_ID_active e0_val, enclave_ID_active e1_val => eqb e0_val e1_val
  | _, _ => false
  end.
Definition equal_enclave_IDs_prop (e0 : enclave_ID) (e1 : enclave_ID): Prop :=
  match e0, e1 with
  | enclave_ID_active e0_val, enclave_ID_active e1_val => eq e0_val e1_val
  | _, _ => False
  end.

(* Contains Way ID *)
Fixpoint recursive_contains_way_ID (w : way_ID) (T : PLRU_tree): bool :=
  match T with
  | subtree sigma e T1 T2 => (recursive_contains_way_ID w T1) || (recursive_contains_way_ID w T2)
  | subtree_leaf L =>
    match L with
    | leaf w' e => eqb w w'
    end
  end.
Definition contains_way_ID (w: way_ID) (T: PLRU_tree): bool := recursive_contains_way_ID w T.

(* Contains Way ID (Prop) *)
Fixpoint recursive_contains_way_ID_prop (w : way_ID) (T : PLRU_tree): Prop :=
  match T with
  | subtree sigma e T1 T2 => (recursive_contains_way_ID_prop w T1) \/ (recursive_contains_way_ID_prop w T2)
  | subtree_leaf L =>
    match L with
    | leaf w' e => eq w w'
    end
  end.
Definition contains_way_ID_prop (w: way_ID) (T: PLRU_tree): Prop := recursive_contains_way_ID_prop w T.

(* Common Enclave *)
Definition common_enclave (T1 : PLRU_tree) (T2 : PLRU_tree): enclave_ID :=
  match T1, T2 with
  | subtree _ e _ _, subtree _ e' _ _ =>
    if equal_enclave_IDs e e'
    then e
    else enclave_ID_inactive
  | _, _ => enclave_ID_inactive
  end.

(* Update *)
Fixpoint recursive_update (T : PLRU_tree) (w : way_ID) (e: enclave_ID): PLRU_tree :=
  match T with
  | subtree select_bit e0 T1 T2 =>
    if equal_enclave_IDs e e0
    then
      if (contains_way_ID w T1)
      then subtree LMRU e (recursive_update T1 w e) T2
      else
        if (contains_way_ID w T2)
        then subtree RMRU e T1 (recursive_update T2 w e)
        else subtree select_bit e T1 T2
    else subtree select_bit (common_enclave T1 T2) (recursive_update T1 w e) (recursive_update T2 w e)
  | subtree_leaf L =>
    match L with
    | leaf w' e' =>
      match e' with
      | enclave_ID_inactive =>
        if (eqb w w')
        then subtree_leaf (leaf w e)
        else subtree_leaf L
      | enclave_ID_active _ => subtree_leaf L
      end
    end
  end.
Definition update (T: PLRU_tree) (w: way_ID) (e: enclave_ID): PLRU_tree := recursive_update T w e.

(* Contains Enclave *)
Fixpoint contains_enclave (e: enclave_ID) (T: PLRU_tree): bool :=
  match T with
  | subtree _ e0 T1 T2 => (equal_enclave_IDs e e0) || (contains_enclave e T1) || (contains_enclave e T1)
  | subtree_leaf L =>
    match L with
    | leaf _ e0 => equal_enclave_IDs e e0
    end
  end.
Fixpoint contains_enclave_prop (e: enclave_ID) (T: PLRU_tree): Prop :=
  match T with
  | subtree _ e0 T1 T2 => (equal_enclave_IDs_prop e e0) \/ (contains_enclave_prop e T1) \/ (contains_enclave_prop e T1)
  | subtree_leaf L =>
    match L with
    | leaf _ e0 => equal_enclave_IDs_prop e e0
    end
  end.

(* Replace *)
Fixpoint recursive_replace (T: PLRU_tree) (e: enclave_ID): option way_ID :=
  match T with
  | subtree select_bit e0 T1 T2 =>
    match (equal_enclave_IDs e e0) with
    | true =>
      match select_bit with
      | LMRU => recursive_replace T2 e
      | RMRU => recursive_replace T1 e
      end
    | false =>
      match contains_enclave e T1 with
      | true => recursive_replace T1 e
      | false =>
        match contains_enclave e T2 with
        | true => recursive_replace T2 e
        | false => None
        end
      end
    end
  | subtree_leaf L =>
    match L with
    | leaf w e0 =>
      match (equal_enclave_IDs e e0) with
      | true => Some w
      | false => None
      end
    end
  end.
Definition replace (T: PLRU_tree) (e: enclave_ID): option way_ID := recursive_replace T e.


Require Import Coq.Bool.Bvector.
Require Import Coq.ZArith.BinInt.
Require Import Coq.ZArith.Zdigits.
Require Import CPidgin.App.Instruction.
Require Import CPidgin.Control.Applicative.
Require Import CPidgin.Control.Flip.
Require Import CPidgin.Control.Functor.
Require Import CPidgin.Control.Monad.
Require Import CPidgin.Data.Bits.
Require Import CPidgin.Data.Either.
Require Import CPidgin.Data.List.
Require Import CPidgin.Data.Maybe.

Module Machine.

Import Bits.
Import Either.
Import Flip.
Import Instruction.
Import List.
Import Maybe.
Import Monad.

(* Time in the machine model. *)
Definition Time := B64.

(* A stack in the machine model. *)
Definition Stack := List B64.

(* A register in the machine model. *)
Inductive Register : Type :=
    | Reg : B64 -> Register.

(* The machine state in the machine model. *)
Inductive Machine : Type :=
    | Mach : Stack -> Register -> Time -> Machine.

(* An empty machine state. *)
Definition emptyMachine : Machine :=
    Mach [] (Reg (nat_to_B64 0)) (nat_to_B64 0).

(* Module for the time delay function. *)
Module TimeDelay.

    Local Open Scope Z_scope.

    (* Delay the machine by a fixed amount of time. *)
    Definition timeDelay (m : Machine) (tn : nat) : Machine :=
        match m with
            | Mach s r t1 => Mach s r (Z_to_B64 ((Z.of_nat tn) + (B64_to_Z t1)))
        end.

End TimeDelay.

Export TimeDelay.

(* Possible errors during a computation. *)
Inductive MachineError : Type :=
    | MachineErrorUnknownInstruction
    | MachineErrorStackUnderflow.

(* The result of a computation can be a MachineError or a Machine state. *)
Definition MResult := Either MachineError Machine.

(* Return a MachineError as a computation result. *)
Definition exception (e : MachineError) : MResult :=
    Left e.

(* Evaluate a NOP instruction with the given machine state. *)
Definition evalNOP (mach : Machine) : MResult :=
    match mach with
        | Mach s r t => mret (timeDelay (Mach s r t) NOP_DELAY)
    end.

(* Evaluate an IMM instruction with the given machine state. *)
Definition evalIMM (mach : Machine) (v : B64) : MResult :=
    match mach with
        | Mach s r t => mret (timeDelay (Mach s (Reg v) t) IMM_DELAY)
    end.

(* Evaluate a PUSH instruction with the given machine state. *)
Definition evalPUSH (mach : Machine) : MResult :=
    match mach with
        | Mach s (Reg r) t =>
            mret (timeDelay (Mach (r :: s) (Reg r) t) PUSH_DELAY)
    end.

(* Evaluate a POP instruction with the given machine state. *)
Definition evalPOP (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t =>
            exception MachineErrorStackUnderflow
        | Mach (s :: ss) r t =>
            mret (timeDelay (Mach ss (Reg s) t) POP_DELAY)
    end.

(* Evaluate a SEL instruction with the given machine state. *)
Definition evalSEL (mach : Machine) (offset : nat) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach ss r t =>
            match (nth offset ss) with
                | Just a =>
                    mret
                        (timeDelay
                            (Mach (removeNth offset ss) (Reg a) t)
                            SEL_DELAY)
                | Nothing => exception MachineErrorStackUnderflow
            end
    end.

(* Evaluate a SHL instruction with the given machine state. *)
Definition evalSHL (mach : Machine) (n : nat) : MResult :=
    match mach with
        | Mach ss (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_shl_iter n r)) t) SHL_DELAY)
    end.

(* Evaluate a SHR instruction with the given machine state. *)
Definition evalSHR (mach : Machine) (n : nat) : MResult :=
    match mach with
        | Mach ss (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_shr_iter n r)) t) SHR_DELAY)
    end.

(* Evaluate an AND instruction with the given machine state. *)
Definition evalAND (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_and s r)) t) AND_DELAY)
    end.

(* Evaluate an OR instruction with the given machine state. *)
Definition evalOR (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_or s r)) t) OR_DELAY)
    end.

(* Evaluate an XOR instruction with the given machine state. *)
Definition evalXOR (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_xor s r)) t) XOR_DELAY)
    end.

(* Evaluate an EQL instruction with the given machine state. *)
Definition evalEQL (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_eql s r)) t) EQL_DELAY)
    end.

(* Evaluate a LT instruction with the given machine state. *)
Definition evalLT (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_lt s r)) t) LT_DELAY)
    end.

(* Evaluate a GT instruction with the given machine state. *)
Definition evalGT (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_gt s r)) t) GT_DELAY)
    end.

(* Evaluate a LE instruction with the given machine state. *)
Definition evalLE (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_le s r)) t) LE_DELAY)
    end.

(* Evaluate a GE instruction with the given machine state. *)
Definition evalGE (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_ge s r)) t) GE_DELAY)
    end.

(* Evaluate a NEQ instruction with the given machine state. *)
Definition evalNEQ (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_neq s r)) t) NEQ_DELAY)
    end.

(* Evaluate a ADD instruction with the given machine state. *)
Definition evalADD (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_add s r)) t) ADD_DELAY)
    end.

(* Evaluate a SUB instruction with the given machine state. *)
Definition evalSUB (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_sub s r)) t) SUB_DELAY)
    end.

(* Evaluate a MUL instruction with the given machine state. *)
Definition evalMUL (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_mul s r)) t) MUL_DELAY)
    end.

(* Evaluate a DIV instruction with the given machine state. *)
Definition evalDIV (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_div s r)) t) DIV_DELAY)
    end.

(* Evaluate a MOD instruction with the given machine state. *)
Definition evalMOD (mach : Machine) : MResult :=
    match mach with
        | Mach [] r t => exception MachineErrorStackUnderflow
        | Mach (s :: ss) (Reg r) t =>
            mret (timeDelay (Mach ss (Reg (B64_mod s r)) t) MOD_DELAY)
    end.

(* Evaluate an instruction on the given machine state. *)
Definition eval (ins : Instruction) (mach : Machine) : MResult :=
        match ins with
            | NOP => evalNOP mach
            | IMM val => evalIMM mach val
            | PUSH => evalPUSH mach
            | POP => evalPOP mach
            | SEL n => evalSEL mach n
            | SHL n => evalSHL mach n
            | SHR n => evalSHR mach n
            | AND => evalAND mach
            | OR => evalOR mach
            | XOR => evalXOR mach
            | EQL => evalEQL mach
            | LT => evalLT mach
            | GT => evalGT mach
            | LE => evalLE mach
            | GE => evalGE mach
            | NEQ => evalNEQ mach
            | ADD => evalADD mach
            | SUB => evalSUB mach
            | MUL => evalMUL mach
            | DIV => evalDIV mach
            | MOD => evalMOD mach
        end.

(* Evaluate a sequence of instructions. *)
Definition evalSequence (ins : List Instruction) (mach : Machine) : MResult :=
    foldlM (flip eval) mach ins.

(* Push arguments into a machine. *)
Fixpoint pushArgs (args : List B64) (mach : Machine) : MResult :=
    match args with
        | [] => mret mach
        | (x :: xs) =>
            match mach with
                | Mach s r t =>
                    pushArgs xs (timeDelay (Mach (x :: s) r t) PUSH_DELAY)
            end
    end.

(* Evaluate a function with the given list of arguments. *)
Definition evalFunction (ins : List Instruction) (args: List B64)
                (mach : Machine) : MResult :=
    pushArgs (reverse args) mach >>= evalSequence ins.

(* Decode a machine state into a return value. *)
Definition getReturnValue (x : Machine) : Either MachineError B64 :=
    match x with
    | Mach s (Reg r) t => Right r
    end.

(* Call a function, returning its return value according to the ABI. *)
Definition callFunction (ins : List Instruction) (args: List B64)
    : Either MachineError B64 :=
    evalFunction ins args emptyMachine >>= getReturnValue.

End Machine.


From iris_examples.logrel_heaplang Require Export ltyping.
From iris.heap_lang.lib Require Import assert.
From iris.algebra Require Import auth.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import notation proofmode.

(* Semantic typing of a symbol ADT (taken from Dreyer's POPL'18 talk) *)
Definition symbol_adt_inc : val := λ: "x" <>, FAA "x" #1.
Definition symbol_adt_check : val := λ: "x" "y", assert: "y" < !"x".
Definition symbol_adt : val := λ: <>,
  let: "x" := Alloc #0 in (symbol_adt_inc "x", symbol_adt_check "x").
Definition symbol_adt_ty `{heapG Σ} : lty Σ :=
  (() → ∃ A, (() → A) * (A → ()))%lty.

(* The required ghost theory *)
Class symbolG Σ := { symbol_inG :> inG Σ (authR mnatUR) }.
Definition symbolΣ : gFunctors := #[GFunctor (authR mnatUR)].

Instance subG_symbolΣ {Σ} : subG symbolΣ Σ → symbolG Σ.
Proof. solve_inG. Qed.

Section symbol_ghosts.
  Context `{!symbolG Σ}.

  Definition counter (γ : gname) (n : nat) : iProp Σ := own γ (● (n : mnat)).
  Definition symbol (γ : gname) (n : nat) : iProp Σ := own γ (◯ (S n : mnat)).

  Global Instance counter_timeless γ n : Timeless (counter γ n).
  Proof. apply _. Qed.
  Global Instance symbol_timeless γ n : Timeless (symbol γ n).
  Proof. apply _. Qed.

  Lemma counter_exclusive γ n1 n2 : counter γ n1 -∗ counter γ n2 -∗ False.
  Proof.
    apply bi.wand_intro_r. rewrite -own_op own_valid /=. by iDestruct 1 as %[].
  Qed.
  Global Instance symbol_persistent γ n : Persistent (symbol γ n).
  Proof. apply _. Qed.

  Lemma counter_alloc n : (|==> ∃ γ, counter γ n)%I.
  Proof.
    iMod (own_alloc (● (n:mnat) ⋅ ◯ (n:mnat))) as (γ) "[Hγ Hγf]";
      first by apply auth_both_valid.
    iExists γ. by iFrame.
  Qed.

  Lemma counter_inc γ n : counter γ n ==∗ counter γ (S n) ∗ symbol γ n.
  Proof.
    rewrite -own_op.
    apply own_update, auth_update_alloc, mnat_local_update. omega.
  Qed.

  Lemma symbol_obs γ s n : counter γ n -∗ symbol γ s -∗ ⌜(s < n)%nat⌝.
  Proof.
    iIntros "Hc Hs".
    iDestruct (own_valid_2 with "Hc Hs") as %[?%mnat_included _]%auth_both_valid.
    iPureIntro. omega.
  Qed.
End symbol_ghosts.

Typeclasses Opaque counter symbol.

Section ltyped_symbol_adt.
  Context `{heapG Σ, symbolG Σ}.

  Definition symbol_adtN := nroot .@ "symbol_adt".

  Definition symbol_inv (γ : gname) (l : loc) : iProp Σ :=
    (∃ n : nat, l ↦ #n ∗ counter γ n)%I.

  Definition lty_symbol (γ : gname) : lty Σ := Lty (λ w,
    ∃ n : nat, ⌜w = #n⌝ ∧ symbol γ n)%I.

  Lemma ltyped_symbol_adt Γ : Γ ⊨ symbol_adt : symbol_adt_ty.
  Proof.
    iIntros (vs) "!# _ /=". iApply wp_value.
    iIntros "!#" (v ->). wp_lam. wp_alloc l as "Hl"; wp_pures.
    iMod (counter_alloc 0) as (γ) "Hc".
    iMod (inv_alloc symbol_adtN _ (symbol_inv γ l) with "[Hl Hc]") as "#?".
    { iExists 0%nat. by iFrame. }
    do 2 (wp_lam; wp_pures).
    iExists (lty_symbol γ), _, _; repeat iSplit=> //.
    - repeat rewrite /lty_car /=. iIntros "!#" (? ->). wp_pures.
      iInv symbol_adtN as (n) ">[Hl Hc]". wp_faa.
      iMod (counter_inc with "Hc") as "[Hc #Hs]".
      iModIntro; iSplitL; last eauto.
      iExists (S n). rewrite Nat2Z.inj_succ -Z.add_1_r. iFrame.
    - repeat rewrite /lty_car /=. iIntros "!#" (v).
      iDestruct 1 as (n ->) "#Hs". wp_pures. iApply wp_assert.
      wp_bind (!_)%E. iInv symbol_adtN as (n') ">[Hl Hc]". wp_load.
      iDestruct (symbol_obs with "Hc Hs") as %?. iModIntro. iSplitL.
      { iExists n'. iFrame. }
      wp_op. rewrite bool_decide_true; last lia. eauto.
  Qed.
End ltyped_symbol_adt.


Require Export BoilerplateSemantics.
Set Implicit Arguments.

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

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tall {Γ t T} (v: Value t) (wt: Typing Γ t (tall T)) :
  ∃ t1, t = tabs t1.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_texist {Γ t T} (v: Value t) (wt: Typing Γ t (texist T)) :
  ∃ T11 t12, t = pack T11 t12 (texist T).
Proof.
  depind wt; try contradiction; exists U, t2; reflexivity.
Qed.

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

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

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - dependent destruction wt1; eauto using subst_evar_typing.
  - dependent destruction wt; eauto using subst_etvar_typing.
  - inversion wt1; subst; clear wt1.
    rewrite tsubstTm_substTm0_comm.
    rewrite tsubstTm_tshiftTm_reflection.
    eapply subst_evar_typing; eauto.
    rewrite <- (tsubstTy_tshiftTy_reflection T11 T2).
    eapply subst_etvar_typing; eauto.
Qed.


(* *****************************************************************)
(*                                                                 *)
(*               Verified polyhedral AST generation                *)
(*                                                                 *)
(*                 Nathanaël Courant, Inria Paris                  *)
(*                                                                 *)
(*  Copyright Inria. All rights reserved. This file is distributed *)
(*  under the terms of the GNU Lesser General Public License as    *)
(*  published by the Free Software Foundation, either version 2.1  *)
(*  of the License, or (at your option) any later version.         *)
(*                                                                 *)
(* *****************************************************************)

Require Import ZArith.
Require Import List.
Require Import Psatz.

Require Import Linalg.
Require Import ImpureAlarmConfig.

Require Import PolyLang.
Require Import ASTGen.
Require Import PolyLoop.
Require Import PolyLoopSimpl.
Require Import LoopGen.
Require Import Loop.
Require Import Misc.

Open Scope Z_scope.

Definition complete_generate d n pi :=
  BIND polyloop <- generate d n pi -;
  polyloop_to_loop (n - d)%nat polyloop.

Theorem complete_generate_preserve_sem :
  forall d n pi env mem1 mem2,
    (d <= n)%nat ->
    WHEN st <- complete_generate d n pi THEN
    loop_semantics st env mem1 mem2 ->
    length env = (n - d)%nat ->
    (forall c, In c pi.(pi_poly) -> fst c =v= resize n (fst c)) ->
    env_poly_lex_semantics (rev env) n (pi :: nil) mem1 mem2.
Proof.
  intros d n pi env mem1 mem2 Hdn st Hst Hloop Henv Hsize.
  unfold complete_generate in Hst.
  bind_imp_destruct Hst polyloop Hpolyloop.
  eapply generate_preserves_sem; eauto.
  eapply polyloop_to_loop_correct; eauto.
Qed.

Definition complete_generate_lex_many d n pis :=
  BIND polyloop <- generate_loop_many d n pis -;
  BIND simp <- polyloop_simplify polyloop (n - d)%nat nil -;
  polyloop_to_loop (n - d)%nat simp.

Theorem complete_generate_lex_many_preserve_sem :
  forall d n pis env mem1 mem2,
    (d <= n)%nat ->
    WHEN st <- complete_generate_lex_many d n pis THEN
    loop_semantics st env mem1 mem2 ->
    length env = (n - d)%nat ->
    pis_have_dimension pis n ->
    env_poly_lex_semantics (rev env) n pis mem1 mem2.
Proof.
  intros d n pis env mem1 mem2 Hdn st Hst Hloop Henv Hpis.
  unfold complete_generate_lex_many in Hst.
  bind_imp_destruct Hst polyloop Hpolyloop; bind_imp_destruct Hst simp Hsimp.
  eapply generate_loop_many_preserves_sem; eauto; [|unfold generate_invariant; auto].
  eapply polyloop_simplify_correct; [|exact Hsimp| | |]; auto; [unfold poly_nrl; simpl; lia|].
  eapply polyloop_to_loop_correct; eauto.
Qed.

Definition complete_generate_many es n pis :=
  let k := list_max (map (fun pi => length pi.(pi_schedule)) pis) in
  let epis := elim_schedule k es pis in
  complete_generate_lex_many (n + k - es)%nat (n + k)%nat epis.

Theorem complete_generate_many_preserve_sem :
  forall es n pis env mem1 mem2,
    (es <= n)%nat ->
    WHEN st <- complete_generate_many es n pis THEN
    loop_semantics st env mem1 mem2 ->
    length env = es ->
    pis_have_dimension pis n ->
    (forall pi, In pi pis -> (poly_nrl pi.(pi_schedule) <= n)%nat) ->
    env_poly_semantics (rev env) n pis mem1 mem2.
Proof.
  intros es n pis env mem1 mem2 Hes st Hst Hloop Henv Hpis Hpis2.
  unfold complete_generate_many in Hst.
  eapply complete_generate_lex_many_preserve_sem in Hst; [|lia].
  eapply poly_elim_schedule_semantics_env_preserve; [| |apply Hst|]; auto; try lia.
  - rewrite rev_length; auto.
  - unfold pis_have_dimension, elim_schedule in *. rewrite forallb_map, forallb_forall in *.
    intros pi Hpi; specialize (Hpis pi Hpi). reflect.
    rewrite pi_elim_schedule_nrl by (apply list_max_ge; rewrite in_map_iff; exists pi; auto).
    specialize (Hpis2 pi Hpi); lia.
  - intros k pi Hpi. apply nth_error_In in Hpi. apply list_max_ge. rewrite in_map_iff; exists pi; auto.
Qed.


(** * Push-Button Synthesis of Barrett Reduction *)
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.derive.Derive.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ErrorT.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Crypto.Stringification.Language.
Require Import Crypto.Arithmetic.BarrettReduction.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Arithmetic.UniformWeight.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.Fancy.Compiler.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Require Import Crypto.PushButtonSynthesis.Primitives.
Require Import Crypto.PushButtonSynthesis.BarrettReductionReificationCache.
Require Import Crypto.PushButtonSynthesis.InvertHighLow.
Import ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope bool_scope.

Import
  Language.Compilers
  Language.Wf.Compilers
  Stringification.Language.Compilers.
Import Compilers.API.

Import COperationSpecifications.Primitives.
Import COperationSpecifications.BarrettReduction.

Import Associational Positional.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Local Opaque reified_barrett_red_gen. (* needed for making [autorewrite] not take a very long time *)

Section rbarrett_red.
  Context {output_language_api : ToString.OutputLanguageAPI}
          {pipeline_opts : PipelineOptions}
          {pipeline_to_string_opts : PipelineToStringOptions}
          {synthesis_opts : SynthesisOptions}
          (M : Z)
          (machine_wordsize : machine_wordsize_opt).

  Let value_range := r[0 ~> (2^machine_wordsize - 1)%Z]%zrange.
  Let flag_range := r[0 ~> 1]%zrange.
  Let bound := Some value_range.
  Let mu := (2 ^ (2 * machine_wordsize)) / M.
  Let muLow := mu mod (2 ^ machine_wordsize).
  Let consts_list := [M; muLow].

  Definition possible_values_of_machine_wordsize
    := [1; machine_wordsize / 2; machine_wordsize; 2 * machine_wordsize]%Z.
  Local Notation possible_values := possible_values_of_machine_wordsize.

  Local Instance no_select_size : no_select_size_opt := no_select_size_of_no_select machine_wordsize.
  Local Instance split_mul_to : split_mul_to_opt := split_mul_to_of_should_split_mul machine_wordsize possible_values.
  Local Instance split_multiret_to : split_multiret_to_opt := split_multiret_to_of_should_split_multiret machine_wordsize possible_values.

  Local Instance fancy_args : translate_to_fancy_opt
    := (Some {| BoundsPipeline.invert_low log2wordsize := invert_low log2wordsize consts_list;
                BoundsPipeline.invert_high log2wordsize := invert_high log2wordsize consts_list;
                BoundsPipeline.value_range := value_range;
                BoundsPipeline.flag_range := flag_range |}).

  Local Instance fancy_args_good : translate_to_fancy_opt_correct.
  Proof using Type.
    cbv [translate_to_fancy_opt_correct translate_to_fancy fancy_args invert_low invert_high constant_to_scalar constant_to_scalar_single consts_list fold_right];
      split; intros; break_innermost_match_hyps; Z.ltb_to_lt; subst; congruence.
  Qed.

  Lemma mut_correct :
    0 < machine_wordsize ->
    Partition.partition (uweight machine_wordsize) (1 + 1) (muLow + 2 ^ machine_wordsize) = [muLow; 1].
  Proof using mu.
    intros; cbn. subst muLow.
    assert (0 < 2^machine_wordsize) by ZeroBounds.Z.zero_bounds.
    pose proof (Z.mod_pos_bound mu (2^machine_wordsize) ltac:(lia)).
    rewrite !uweight_S, weight_0; auto using uwprops with lia.
    autorewrite with zsimplify.
    Modulo.push_Zmod. autorewrite with zsimplify. Modulo.pull_Zmod.
    rewrite <-Modulo.Z.mod_pull_div by lia.
    autorewrite with zsimplify. RewriteModSmall.Z.rewrite_mod_small.
    reflexivity.
  Qed.
  Lemma Mt_correct :
    0 < machine_wordsize ->
    2^(machine_wordsize - 1) < M < 2^machine_wordsize ->
    Partition.partition (uweight machine_wordsize) 1 M = [M].
  Proof using Type.
    intros; cbn. assert (0 < 2^(machine_wordsize-1)) by ZeroBounds.Z.zero_bounds.
    rewrite !uweight_S, weight_0; auto using uwprops with lia.
    autorewrite with zsimplify. RewriteModSmall.Z.rewrite_mod_small.
    reflexivity.
  Qed.

  (** Note: If you change the name or type signature of this
        function, you will need to update the code in CLI.v *)
  Definition check_args {T} (requests : list string) (res : Pipeline.ErrorT T)
    : Pipeline.ErrorT T
    := fold_right
         (fun '(b, e) k => if b:bool then Error e else k)
         res
         [
            ((negb (1 <? machine_wordsize))%Z, Pipeline.Value_not_ltZ "machine_wordsize ≤ 1" 1 machine_wordsize);
            ((negb (2 ^ (machine_wordsize-1) <? M))%Z, Pipeline.Value_not_ltZ "M ≤ 2^(machine_wordsize-1)" (2^(machine_wordsize-1)) M);
            ((negb (M <? 2 ^ machine_wordsize))%Z, Pipeline.Value_not_ltZ "2 ^ machine_wordsize ≤ M" M (2^machine_wordsize));
            ((negb (muLow + 2 ^ machine_wordsize =? ((2 ^ 2) ^ machine_wordsize) / M))%Z, Pipeline.Values_not_provably_equalZ "muLow + 2^machine_wordsize ≠ (2 ^ 2) ^ machine_wordsize) / M" (muLow + 2^machine_wordsize) (((2 ^ 2) ^ machine_wordsize) / M));
            (negb ((2 * (((2 ^ 2) ^ machine_wordsize) mod M) <=? 2 ^ (machine_wordsize + 1) - (muLow + 2 ^ machine_wordsize)))%Z, Pipeline.Value_not_leZ ("(2 * ((2 ^ 2) ^ machine_wordsize) mod M)  2 ^ (machine_wordsize + 1) - (muLow + 2 ^ machine_wordsize)") (2 * (((2 ^ 2) ^ machine_wordsize) mod M)) (2 ^ (machine_wordsize + 1) - (muLow + 2 ^ machine_wordsize))) ].

  Local Arguments Z.mul !_ !_.

  Local Ltac use_curve_good_t :=
    repeat first [ assumption
                 | progress cbv [EquivModulo.Z.equiv_modulo]
                 | progress rewrite ?Z.mul_0_r, ?Pos.mul_1_r, ?Z.mul_1_r in *
                 | reflexivity
                 | lia
                 | progress cbn in *
                 | progress intros
                 | solve [ auto with zarith ]
                 | rewrite Z.log2_pow2 by use_curve_good_t ].

  Context (requests : list string)
          (curve_good : check_args requests (Success tt) = Success tt).

  Lemma use_curve_good
    : 1 < machine_wordsize
      /\ 2 ^ (machine_wordsize - 1) <= M < 2 ^ machine_wordsize
      /\ muLow + 2 ^ machine_wordsize = (2 ^ 2) ^ machine_wordsize / M
      /\ 2 ^ (machine_wordsize - 1) < M < 2 ^ machine_wordsize
      /\ 2 * ((2 ^ 2) ^ machine_wordsize mod M) <= 2 ^ (machine_wordsize + 1) - (muLow + 2 ^ machine_wordsize).
  Proof using curve_good.
    prepare_use_curve_good ().
    { use_curve_good_t. }
  Qed.

  Definition barrett_red
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values
         (reified_barrett_red_gen
            @ GallinaReify.Reify M
            @ GallinaReify.Reify (machine_wordsize:Z)
            @ GallinaReify.Reify (machine_wordsize:Z)
            @ GallinaReify.Reify 1%nat
            @ GallinaReify.Reify [muLow;1]
            @ GallinaReify.Reify [M])
         (bound, (bound, tt))
         bound.

  Definition sbarrett_red (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "barrett_red" barrett_red
          (fun _ _ _ => @nil string).

  Local Ltac solve_barrett_red_preconditions :=
    repeat first [ lia
                 | assumption
                 | match goal with |- ?x = ?x => reflexivity end
                 | apply use_curve_good
                 | progress autorewrite with zsimplify
                 | progress intros
                 | progress cbv [weight]
                 | rewrite mut_correct
                 | rewrite Mt_correct
                 | rewrite uweight_eq_alt'
                 | rewrite Z.pow_mul_r by lia ].

  Local Strategy -100 [barrett_red]. (* needed for making Qed not take forever *)
  Local Opaque expr.Interp. (* to prevent [autorewrite with interp_gen_cache] from taking forever *)
  Lemma barrett_red_correct res (Hres : barrett_red = Success res)
    : barrett_red_correct machine_wordsize M (API.Interp res).
  Proof using M curve_good.
    cbv [barrett_red_correct]; intros.
    assert (1 < machine_wordsize) by apply use_curve_good.
    pose proof (Z.mod_pos_bound mu (2^machine_wordsize) ltac:(lia)).
    rewrite <-Fancy.fancy_reduce_correct with (mu := muLow + 2^machine_wordsize) (width:=machine_wordsize) (sz:=1%nat) (mut:=[muLow;1]) (Mt:=[M]) by solve_barrett_red_preconditions.
    remember Fancy.fancy_reduce eqn:?. (* to prevent [reflexivity] from taking forever *)
    prove_correctness' ltac:(fun _ => idtac) use_curve_good.
    { subst; reflexivity. }
    { cbv [ZRange.type.base.option.is_bounded_by ZRange.type.base.is_bounded_by bound is_bounded_by_bool value_range upper lower]. rewrite Bool.andb_true_iff, !Z.leb_le. lia. }
    { cbv [ZRange.type.base.option.is_bounded_by ZRange.type.base.is_bounded_by bound is_bounded_by_bool value_range upper lower]. rewrite Bool.andb_true_iff, !Z.leb_le. lia. }
  Qed.

  Lemma Wf_barrett_red res (Hres : barrett_red = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.
End rbarrett_red.

Module Export Hints.
#[global]
  Hint Opaque
       barrett_red
  : wf_op_cache.
#[global]
  Hint Immediate
       Wf_barrett_red
  : wf_op_cache.
End Hints.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section LeadersHaveLeaderLogs.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition leaders_have_leaderLogs net :=
    forall h,
      type (snd (nwState net h)) = Leader ->
      exists ll,
        In (currentTerm (snd (nwState net h)), ll) (leaderLogs (fst (nwState net h))).

  Class leaders_have_leaderLogs_interface : Prop :=
    {
      leaders_have_leaderLogs_invariant :
        forall (net : network),
          refined_raft_intermediate_reachable net ->
          leaders_have_leaderLogs net
    }.
End LeadersHaveLeaderLogs.