(** * Subtyping *)

(* $Date: 2011-05-07 21:28:52 -0400 (Sat, 07 May 2011) $ *)

Require Export MoreStlc.

(* ###################################################### *)
(** * Concepts *)

(** We now turn to the study of _subtyping_, perhaps the most
    characteristic feature of the static type systems used by many
    recently designed programming languages. *)

(* ###################################################### *)
(** ** A Motivating Example *)

(** In the simply typed lamdba-calculus with records, the term
<<
    (\r:{y:Nat}. (r.y)+1) {x=10,y=11}
>>
   is not typable: it involves an application of a function that wants
   a one-field record to an argument that actually provides two
   fields, while the [T_App] rule demands that the domain type of the
   function being applied must match the type of the argument
   precisely.

   But this is silly: we're passing the function a _better_ argument
   than it needs!  The only thing the body of the function can
   possibly do with its record argument [r] is project the field [y]
   from it: nothing else is allowed by the type.  So the presence or
   absence of an extra [x] field should make no difference at all.
   So, intuitively, it seems that this function should be applicable
   to any record value that has at least a [y] field.

   Looking at the same thing from another point of view, a record with
   more fields is "at least as good in any context" as one with just a
   subset of these fields, in the sense that any value belonging to
   the longer record type can be used _safely_ in any context
   expecting the shorter record type.  If the context expects
   something with the shorter type but we actually give it something
   with the longer type, nothing bad will happen (formally, the
   program will not get stuck).

   The general principle at work here is called _subtyping_.  We say
   that "[S] is a subtype of [T]", informally written [S <: T], if a
   value of type [S] can safely be used in any context where a value
   of type [T] is expected.  The idea of subtyping applies not only to
   records, but to all of the type constructors in the language --
   functions, pairs, etc. *)

(** ** Subtyping and Object-Oriented Languages *)

(** Subtyping plays a fundamental role in many programming
    languages -- in particular, it is closely related to the notion of
    _subclassing_ in object-oriented languages.

    An _object_ (in Java, C[#], etc.) can be thought of as a record,
    some of whose fields are functions ("methods") and some of whose
    fields are data values ("fields" or "instance variables").
    Invoking a method [m] of an object [o] on some arguments [a1..an]
    consists of projecting out the [m] field of [o] and applying it to
    [a1..an].

    The type of an object can be given as either a _class_ or an
    _interface_.  Both of these provide a description of which methods
    and which data fields the object offers.

    Classes and interfaces are related by the _subclass_ and
    _subinterface_ relations.  An object belonging to a subclass (or
    subinterface) is required to provide all the methods and fields of
    one belonging to a superclass (or superinterface), plus possibly
    some more.

    The fact that an object from a subclass (or sub-interface) can be
    used in place of one from a superclass (or super-interface) provides
    a degree of flexibility that is is extremely handy for organizing
    complex libraries.  For example, a graphical user interface
    toolkit like Java's Swing framework might define an abstract
    interface [Component] that collects together the common fields and
    methods of all objects having a graphical representation that can
    be displayed on the screen and that can interact with the user.
    Examples of such object would include the buttons, checkboxes, and
    scrollbars of a typical GUI.  A method that relies only on this
    common interface can now be applied to any of these objects.

    Of course, real object-oriented languages include many other
    features besides these.  Fields can be updated.  Fields and
    methods can be declared [private].  Classes also give _code_ that
    is used when constructing objects and implementing their methods,
    and the code in subclasses cooperate with code in superclasses via
    _inheritance_.  Classes can have static methods and fields,
    initializers, etc., etc.

    To keep things simple here, we won't deal with any of these
    issues -- in fact, we won't even talk any more about objects or
    classes.  (There is a lot of discussion in Types and Programming
    Languages, if you are interested.)  Instead, we'll study the core
    concepts behind the subclass / subinterface relation in the
    simplified setting of the STLC. *)

(** ** The Subsumption Rule *)

(** Our goal for this chapter is to add subtyping to the simply typed
    lambda-calculus (with products).  This involves two steps:

      - Defining a binary _subtype relation_ between types.

      - Enriching the typing relation to take subtyping into account.

    The second step is actually very simple.  We add just a single rule
    to the typing relation -- the so-called _rule of subsumption_:
[[[
                         Gamma |- t : S     S <: T
                         -------------------------                      (T_Sub)
                               Gamma |- t : T
]]]
    This rule says, intuitively, that we can "forget" some of the
    information that we know about a term. *)
(** For example, we may know that [t] is a record with two
    fields (e.g., [S = {x:A->A, y:B->B}]], but choose to forget about
    one of the fields ([T = {y:B->B}]) so that we can pass [t] to a
    function that expects just a single-field record. *)

(** ** The Subtype Relation *)

(** The first step -- the definition of the relation [S <: T] -- is
    where all the action is.  Let's look at each of the clauses of its
    definition.  *)

(** *** Products *)

(** First, product types.  We consider one pair to be "better than"
    another if each of its components is.
[[[
                            S1 <: T1    S2 <: T2
                            --------------------                        (S_Prod)
                               S1*S2 <: T1*T2
]]]
*)

(** *** Arrows *)

(** Suppose we have two functions [f] and [g] with these types:
<<
       f : C -> {x:A,y:B}
       g : (C->{y:B}) -> D
>>
    That is, [f] is a function that yields a record of type
    [{x:A,y:B}], and [g] is a higher-order function that expects
    its (function) argument to yield a record of type [{y:B}].  (And
    suppose, even though we haven't yet discussed subtyping for
    records, that [{x:A,y:B}] is a subtype of [{y:B}]) Then the
    application [g f] is safe even though their types do not match up
    precisely, because the only thing [g] can do with [f] is to apply
    it to some argument (of type [C]); the result will actually be a
    two-field record, while [g] will be expecting only a record with a
    single field, but this is safe because the only thing [g] can then
    do is to project out the single field that it knows about, and
    this will certainly be among the two fields that are present.

    This example suggests that the subtyping rule for arrow types
    should say that two arrow types are in the subtype relation if
    their results are:
[[[
                                  S2 <: T2
                              ----------------                        (S_Arrow2)
                              S1->S2 <: S1->T2
]]]
    We can generalize this to allow the arguments of the two arrow
    types to be in the subtype relation as well:
[[[
                            T1 <: S1    S2 <: T2
                            --------------------                      (S_Arrow)
                              S1->S2 <: T1->T2
]]]
    Notice, here, that the argument types are subtypes "the other way
    round": in order to conclude that [S1->S2] to be a subtype of
    [T1->T2], it must be the case that [T1] is a subtype of [S1].  The
    arrow constructor is said to be _contravariant_ in its first
    argument and _covariant_ in its second.

    The intuition is that, if we have a function [f] of type [S1->S2],
    then we know that [f] accepts elements of type [S1]; clearly, [f]
    will also accept elements of any subtype [T1] of [S1]. The type of
    [f] also tells us that it returns elements of type [S2]; we can
    also view these results belonging to any supertype [T2] of
    [S2]. That is, any function [f] of type [S1->S2] can also be viewed
    as having type [T1->T2]. *)

(** *** Top *)

(** It is natural to give the subtype relation a maximal element -- a
    type that lies above every other type and is inhabited by
    all (well-typed) values.  We do this by adding to the language one
    new type constant, called [Top], together with a subtyping rule
    that places it above every other type in the subtype relation:
[[[
                                   --------                             (S_Top)
                                   S <: Top
]]]
    The [Top] type is an analog of the [Object] type in Java and C[#]. *)

(** *** Structural Rules *)

(** To finish off the subtype relation, we add two "structural rules"
    that are independent of any particular type constructor: a rule of
    _transitivity_, which says intuitively that, if [S] is better than
    [U] and [U] is better than [T], then [S] is better than [T]...
[[[
                              S <: U    U <: T
                              ----------------                        (S_Trans)
                                   S <: T
]]]
    ... and a rule of _reflexivity_, since any type [T] is always just
    as good as itself:
[[[
                                   ------                              (S_Refl)
                                   T <: T
]]]
*)

(** *** Records *)

(** What about subtyping for record types?

   The basic intuition about subtyping for record types is that it is
   always safe to use a "bigger" record in place of a "smaller" one.
   That is, given a record type, adding extra fields will always
   result in a subtype.  If some code is expecting a record with
   fields [x] and [y], it is perfectly safe for it to receive a record
   with fields [x], [y], and [z]; the [z] field will simply be ignored.
   For example,
<<
       {x:Nat,y:Bool} <: {x:Nat}
       {x:Nat} <: {}
>>
   This is known as "width subtyping" for records.

   We can also create a subtype of a record type by replacing the type
   of one of its fields with a subtype.  If some code is expecting a
   record with a field [x] of type [T], it will be happy with a record
   having a field [x] of type [S] as long as [S] is a subtype of
   [T]. For example,
<<
       {a:{x:Nat}} <: {a:{}}
>>
   This is known as "depth subtyping".

   Finally, although the fields of a record type are written in a
   particular order, the order does not really matter. For example,
<<
       {x:Nat,y:Bool} <: {y:Bool,x:Nat}
>>
   This is known as "permutation subtyping".

   We could try formalizing these requirements in a single subtyping
   rule for records as follows:
[[[
                        for each jk in j1..jn,
                    exists ip in i1..im, such that
                          jk=ip and Sp <: Tk
                  ----------------------------------                    (S_Rcd)
                  {i1:S1...im:Sm} <: {j1:T1...jn:Tn}
]]]
   That is, the record on the left should have all the field labels of
   the one on the right (and possibly more), while the types of the
   common fields should be in the subtype relation. However, This rule
   is rather heavy and hard to read.  If we like, we can decompose it
   into three simpler rules, which can be combined using [S_Trans] to
   achieve all the same effects.

    First, adding fields to the end of a record type gives a subtype:
[[[
                               n > m
                 ---------------------------------                 (S_RcdWidth)
                 {i1:T1...in:Tn} <: {i1:T1...im:Tm}
]]]
   We can use [S_RcdWidth] to drop later fields of a multi-field
   record while keeping earlier fields, showing for example that
   [{y:B, x:A} <: {y:B}].

   Second, we can apply subtyping inside the components of a compound
   record type:
[[[
                       S1 <: T1  ...  Sn <: Tn
                  ----------------------------------               (S_RcdDepth)
                  {i1:S1...in:Sn} <: {i1:T1...in:Tn}
]]]
   For example, we can use [S_RcdDepth] and [S_RcdWidth] together to
   show that [{y:{z:B}, x:A} <: {y:{}}].

   Third, we need to be able to reorder fields. The example we
   originally had in mind was [{x:A,y:B} <: {y:B}].  We
   haven't quite achieved this yet: using just [S_RcdDepth] and
   [S_RcdWidth] we can only drop fields from the _end_ of a record
   type.  So we need:
[[[
         {i1:S1...in:Sn} is a permutation of {i1:T1...in:Tn}
         ---------------------------------------------------        (S_RcdPerm)
                  {i1:S1...in:Sn} <: {i1:T1...in:Tn}
]]]

   Further examples:
      - [{x:A,y:B}] <: [{y:B,x:A}].
      - [{}->{j:A} <: {k:B}->Top]
      - [Top->{k:A,j:B} <: C->{j:B}]
*)

(** It is worth noting that real languages may choose not to adopt
    all of these subtyping rules. For example, in Java:

    - A subclass may not change the argument or result types of a
      method of its superclass (i.e., no depth subtyping or no arrow
      subtyping, depending how you look at it).

    - Each class has just one superclass ("single inheritance" of
      classes)

      - Each class member (field or method) can be assigned a single
        index, adding new indices "on the right" as more members are
        added in subclasses (i.e., no permutation for classes)

    - A class may implement multiple interfaces -- so-called "multiple
      inheritance" of interfaces (i.e., permutation is allowed for
      interfaces). *)

(** *** Records, via Products and Top (optional) *)

(** Exactly how we formalize all this depends on how we are choosing
    to formalize records and their types.  If we are treating them as
    part of the core language, then we need to write down subtyping
    rules for them.  The file [RecordSub.v] shows how this extension
    works.

    On the other hand, if we are treating them as a derived form that
    is desugared in the parser, then we shouldn't need any new rules:
    we should just check that the existing rules for subtyping product
    and [Unit] types give rise to reasonable rules for record
    subtyping via this encoding. To do this, we just need to make one
    small change to the encoding described earlier: instead of using
    [Unit] as the base case in the encoding of tuples and the "don't
    care" placeholder in the encoding of records, we use [Top].  So:
<<
    {a:Nat, b:Nat} ----> {Nat,Nat}       i.e. (Nat,(Nat,Top))
    {c:Nat, a:Nat} ----> {Nat,Top,Nat}   i.e. (Nat,(Top,(Nat,Top)))
>>
    The encoding of record values doesn't change at all.  It is
    easy (and instructive) to check that the subtyping rules above are
    validated by the encoding.  For the rest of this chapter, we'll
    follow this approach. *)

(* ###################################################### *)
(** * Core definitions *)

(** We've already sketched the significant extensions that we'll need
    to make to the STLC: (1) add the subtype relation and (2) extend
    the typing relation with the rule of subsumption.  To make
    everything work smoothly, we'll also implement some technical
    improvements to the presentation from the last chapter.  The rest
    of the definitions -- in particular, the syntax and operational
    semantics of the language -- are identical to what we saw in the
    last chapter.  Let's first do the identical bits. *)

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

(** Just for the sake of more interesting examples, we'll make one
    more very small extension to the pure STLC: an arbitrary set of
    additional _base types_ like [String], [Person], [Window], etc.
    We won't bother adding any constants belonging to these types or
    any operators on them, but we could easily do so. *)

(** In the rest of the chapter, we formalize just base types,
    booleans, arrow types, [Unit], and [Top], leaving product types as
    an exercise. *)

Inductive ty : Type :=
  | ty_Top   : ty
  | ty_Bool  : ty
  | ty_base  : id -> ty
  | ty_arrow : ty -> ty -> ty
  | ty_Unit  : ty
.

Tactic Notation "ty_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ty_Top" | Case_aux c "ty_Bool"
  | Case_aux c "ty_base" | Case_aux c "ty_arrow"
  | Case_aux c "ty_Unit" |
  ].

Inductive tm : Type :=
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
  | tm_true : tm
  | tm_false : tm
  | tm_if : tm -> tm -> tm -> tm
  | tm_unit : tm
.

Tactic Notation "tm_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tm_var" | Case_aux c "tm_app"
  | Case_aux c "tm_abs" | Case_aux c "tm_true"
  | Case_aux c "tm_false" | Case_aux c "tm_if"
  | Case_aux c "tm_unit"
  ].

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

(** The definition of substitution remains the same as for the
    ordinary STLC. *)

Fixpoint subst (s:tm) (x:id) (t:tm) : tm :=
  match t with
  | tm_var y =>
      if beq_id x y then s else t
  | tm_abs y T t1 =>
      tm_abs y T (if beq_id x y then t1 else (subst s x t1))
  | tm_app t1 t2 =>
      tm_app (subst s x t1) (subst s x t2)
  | tm_true =>
      tm_true
  | tm_false =>
      tm_false
  | tm_if t1 t2 t3 =>
      tm_if (subst s x t1) (subst s x t2) (subst s x t3)
  | tm_unit =>
      tm_unit
  end.

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

(** Likewise the definitions of the [value] property and the [step]
    relation. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tm_abs x T t)
  | t_true :
      value tm_true
  | t_false :
      value tm_false
  | v_unit :
      value tm_unit
.

Hint Constructors value.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tm_app (tm_abs x T t12) v2) ==> (subst v2 x t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tm_app t1 t2) ==> (tm_app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tm_app v1 t2) ==> (tm_app v1  t2')
  | ST_IfTrue : forall t1 t2,
      (tm_if tm_true t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tm_if tm_false t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tm_if t1 t2 t3) ==> (tm_if 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.

(* ###################################################################### *)
(** * Subtyping *)

(** Now we come to the interesting part.  We begin by defining
    the subtyping relation and developing some of its important
    technical properties. *)

(* ################################### *)
(** ** Definition *)

(** The definition of subtyping is just what we sketched in the
    motivating discussion. *)

Inductive subtype : ty -> ty -> Prop :=
  | S_Refl : forall T,
    subtype T T
  | S_Trans : forall S U T,
    subtype S U ->
    subtype U T ->
    subtype S T
  | S_Top : forall S,
    subtype S ty_Top
  | S_Arrow : forall S1 S2 T1 T2,
    subtype T1 S1 ->
    subtype S2 T2 ->
    subtype (ty_arrow S1 S2) (ty_arrow T1 T2)
.

(** Note that we don't need any special rules for base types: they are
    automatically subtypes of themselves (by [S_Refl]) and [Top] (by
    [S_Top]), and that's all we want. *)

Hint Constructors subtype.

Tactic Notation "subtype_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "S_Refl" | Case_aux c "S_Trans"
  | Case_aux c "S_Top" | Case_aux c "S_Arrow"
  ].

(* ############################################### *)
(** ** Subtyping Examples and Exercises *)

Module Examples.

Notation x := (Id 0).
Notation y := (Id 1).
Notation z := (Id 2).

Notation A := (ty_base (Id 6)).
Notation B := (ty_base (Id 7)).
Notation C := (ty_base (Id 8)).

Notation String := (ty_base (Id 9)).
Notation Float := (ty_base (Id 10)).
Notation Integer := (ty_base (Id 11)).

(** **** Exercise: 2 stars, optional (subtyping judgements) *)

(** (Do this exercise after you have added product types to the
    language, at least up to this point in the file).

    Using the encoding of records into pairs, define pair types
    representing the record types
[[
    Person   := { name : String }
    Student  := { name : String ;
                  gpa  : Float }
    Employee := { name : String ;
                  ssn  : Integer }
]]
*)
Definition Person : ty :=
(* FILL IN HERE *) admit.
Definition Student : ty :=
(* FILL IN HERE *) admit.
Definition Employee : ty :=
(* FILL IN HERE *) admit.

Example sub_student_person :
  subtype Student Person.
Proof.
(* FILL IN HERE *) Admitted.

Example sub_employee_person :
  subtype Employee Person.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

Example subtyping_example_0 :
  subtype (ty_arrow C Person)
          (ty_arrow C ty_Top).
(* C->Person <: C->Top *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get
    full benefit from the exercises, make sure you also
    understand how to prove them on paper! *)

(** **** Exercise: 1 star, optional (subtyping_example_1) *)
Example subtyping_example_1 :
  subtype (ty_arrow ty_Top Student)
          (ty_arrow (ty_arrow C C) Person).
(* Top->Student <: (C->C)->Person *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, optional (subtyping_example_2) *)
Example subtyping_example_2 :
  subtype (ty_arrow ty_Top Person)
          (ty_arrow Person ty_Top).
(* Top->Person <: Person->Top *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples.

(** **** Exercise: 1 star, optional (subtype_instances_tf_1) *)
(** Suppose we have types [S], [T], [U], and [V] with [S <: T]
    and [U <: V].  Which of the following subtyping assertions
    are then true?  Write _true_ or _false_ after each one.
    (Note that [A], [B], and [C] are base types.)

    - [T->S <: T->S]

    - [Top->U <: S->Top]

    - [(C->C) -> (A*B)  <:  (C->C) -> (Top*B)]

    - [T->T->U <: S->S->V]

    - [(T->T)->U <: (S->S)->V]

    - [((T->S)->T)->U <: ((S->T)->S)->V]

    - [S*V <: T*U]

[]
*)

(** **** Exercise: 1 star (subtype_instances_tf_2) *)
(** Which of the following statements are true?  Write TRUE or FALSE
    after each one.
[[
      forall S T,
          S <: T  ->
          S->S   <:  T->T

      forall S T,
           S <: A->A ->
           exists T,
              S = T->T  /\  T <: A

      forall S T1 T1,
           S <: T1 -> T2 ->
           exists S1 S2,
              S = S1 -> S2  /\  T1 <: S1  /\  S2 <: T2

      exists S,
           S <: S->S

      exists S,
           S->S <: S

      forall S T2 T2,
           S <: T1*T2 ->
           exists S1 S2,
              S = S1*S2  /\  S1 <: T1  /\  S2 <: T2
]]
[] *)

(** **** Exercise: 1 star (subtype_concepts_tf) *)
(** Which of the following statements are true, and which are false?
    - There exists a type that is a supertype of every other type.

    - There exists a type that is a subtype of every other type.

    - There exists a pair type that is a supertype of every other
      pair type.

    - There exists a pair type that is a subtype of every other
      pair type.

    - There exists an arrow type that is a supertype of every other
      arrow type.

    - There exists an arrow type that is a subtype of every other
      arrow type.

    - There is an infinite descending chain of distinct types in the
      subtype relation---that is, an infinite sequence of types
      [S0], [S1], etc., such that all the [Si]'s are different and
      each [S(i+1)] is a subtype of [Si].

    - There is an infinite _ascending_ chain of distinct types in
      the subtype relation---that is, an infinite sequence of types
      [S0], [S1], etc., such that all the [Si]'s are different and
      each [S(i+1)] is a supertype of [Si].

[]
*)

(** **** Exercise: 2 stars (proper_subtypes) *)
(** Is the following statement true or false?  Briefly explain your
    answer.
[[
    forall T,
         ~(exists n, T = ty_base n) ->
         exists S,
            S <: T  /\  S <> T
]]
[]
*)

(** **** Exercise: 2 stars (small_large_1) *)
(**
   - What is the _smallest_ type [T] ("smallest" in the subtype
     relation) that makes the following assertion true?
[[
       empty |- (\p:T*Top. p.fst) ((\z:A.z), unit) : A->A
]]

   - What is the _largest_ type [T] that makes the same assertion true?

[]
*)

(** **** Exercise: 2 stars (small_large_2) *)
(**
   - What is the _smallest_ type [T] that makes the following
     assertion true?
[[
       empty |- (\p:(A->A * B->B). p) ((\z:A.z), (\z:B.z)) : T
]]

   - What is the _largest_ type [T] that makes the same assertion true?

[]
*)

(** **** Exercise: 2 stars, optional (small_large_3) *)
(**
   - What is the _smallest_ type [T] that makes the following
     assertion true?
[[
       a:A |- (\p:(A*T). (p.snd) (p.fst)) (a , \z:A.z) : A
]]

   - What is the _largest_ type [T] that makes the same assertion true?

[]
*)

(** **** Exercise: 2 stars (small_large_4) *)
(**
   - What is the _smallest_ type [T] that makes the following
     assertion true?
[[
       exists S,
         empty |- (\p:(A*T). (p.snd) (p.fst)) : S
]]

   - What is the _largest_ type [T] that makes the same
     assertion true?

[]
*)

(** **** Exercise: 2 stars (smallest_1) *)
(** What is the _smallest_ type [T] that makes the following
    assertion true?
[[
      exists S, exists t,
        empty |- (\x:T. x x) t : S
]]
[]
*)

(** **** Exercise: 2 stars (smallest_2) *)
(** What is the _smallest_ type [T] that makes the following
    assertion true?
[[
      empty |- (\x:Top. x) ((\z:A.z) , (\z:B.z)) : T
]]
[]
*)

(** **** Exercise: 3 stars, optional (count_supertypes) *)
(** How many supertypes does the record type [{x:A, y:C->C}] have?  That is,
    how many different types [T] are there such that [{x:A, y:C->C} <:
    T]?  (We consider two types to be different if they are written
    differently, even if each is a subtype of the other.  For example,
    [{x:A,y:B}] and [{y:B,x:A}] are different.)

[]
*)

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

(** The only change to the typing relation is the addition of the rule
    of subsumption, [T_Sub]. *)

Definition context := id -> (option ty).
Definition empty : context := (fun _ => None).
Definition extend (Gamma : context) (x:id) (T : ty) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Inductive has_type : context -> tm -> ty -> Prop :=
  (* Same as before *)
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tm_var x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tm_abs x T11 t12) (ty_arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (ty_arrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tm_app t1 t2) T2
  | T_True : forall Gamma,
       has_type Gamma tm_true ty_Bool
  | T_False : forall Gamma,
       has_type Gamma tm_false ty_Bool
  | T_If : forall t1 t2 t3 T Gamma,
       has_type Gamma t1 ty_Bool ->
       has_type Gamma t2 T ->
       has_type Gamma t3 T ->
       has_type Gamma (tm_if t1 t2 t3) T
  | T_Unit : forall Gamma,
      has_type Gamma tm_unit ty_Unit
  (* New rule of subsumption *)
  | T_Sub : forall Gamma t S T,
      has_type Gamma t S ->
      subtype S T ->
      has_type Gamma t T.

Hint Constructors has_type.

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"
  | Case_aux c "T_Unit"
  | Case_aux c "T_Sub" ].

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

Module Examples2.
Import Examples.

(** Do the following exercises after you have added product types to
    the language.  For each informal typing judgement, write it as a
    formal statement in Coq and prove it. *)

(** **** Exercise: 1 star, optional (typing_example_0) *)
(* empty |- ((\z:A.z), (\z:B.z)) : (A->A * B->B) *)
(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 2 stars, optional (typing_example_1) *)
(* empty |- (\x:(Top * B->B). x.snd) ((\z:A.z), (\z:B.z)) : B->B *)
(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 2 stars, optional (typing_example_2) *)
(* empty |- (\z:(C->C)->(Top * B->B). (z (\x:C.x)).snd)
              (\z:C->C. ((\z:A.z), (\z:B.z)))
           : B->B *)
(* FILL IN HERE *)
(** [] *)

End Examples2.

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

(** The fundamental properties of the system that we want to check are
    the same as always: progress and preservation.  Unlike the
    extension of the STLC with references, we don't need to change the
    _statements_ of these properties to take subtyping into account.
    However, their proofs do become a little bit more involved. *)

(* ###################################################################### *)
(** ** Inversion Lemmas for Subtyping *)

(** Before we look at the properties of the typing relation, we need
    to record a couple of critical structural properties of the subtype
    relation:
       - [Bool] is the only subtype of [Bool]
       - every subtype of an arrow type _is_ an arrow type. *)

(** These are called _inversion lemmas_ because they play the same
    role in later proofs as the built-in [inversion] tactic: given a
    hypothesis that there exists a derivation of some subtyping
    statement [S <: T] and some constraints on the shape of [S] and/or
    [T], each one reasons about what this derivation must look like to
    tell us something further about the shapes of [S] and [T] and the
    existence of subtype relations between their parts. *)

(** **** Exercise: 2 stars, optional (sub_inversion_Bool) *)
Lemma sub_inversion_Bool : forall U,
     subtype U ty_Bool ->
       U = ty_Bool.
Proof with auto.
  intros U Hs.
  remember ty_Bool as V.
  (* FILL IN HERE *) Admitted.

(** **** Exercise: 3 stars, optional (sub_inversion_arrow) *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (ty_arrow V1 V2) ->
     exists U1, exists U2,
       U = (ty_arrow U1 U2) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (ty_arrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  (* FILL IN HERE *) Admitted.

(** [] *)

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

(** We'll see first that the proof of the progress theorem doesn't
    change too much -- we just need one small refinement.  When we're
    considering the case where the term in question is an application
    [t1 t2] where both [t1] and [t2] are values, we need to know that
    [t1] has the _form_ of a lambda-abstraction, so that we can apply
    the [ST_AppAbs] reduction rule.  In the ordinary STLC, this is
    obvious: we know that [t1] has a function type [T11->T12], and
    there is only one rule that can be used to give a function type to
    a value -- rule [T_Abs] -- and the form of the conclusion of this
    rule forces [t1] to be an abstraction.

    In the STLC with subtyping, this reasoning doesn't quite work
    because there's another rule that can be used to show that a value
    has a function type: subsumption.  Fortunately, this possibility
    doesn't change things much: if the last rule used to show [Gamma
    |- t1 : T11->T12] is subsumption, then there is some
    _sub_-derivation whose subject is also [t1], and we can reason by
    induction until we finally bottom out at a use of [T_Abs].

    This bit of reasoning is packaged up in the following lemma, which
    tells us the possible "canonical forms" (i.e. values) of function
    type. *)

(** **** Exercise: 3 stars, optional (canonical_forms_of_arrow_types) *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
  has_type Gamma s (ty_arrow T1 T2) ->
  value s ->
  exists x, exists S1, exists s2,
     s = tm_abs x S1 s2.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Similarly, the canonical forms of type [Bool] are the constants
    [true] and [false]. *)

Lemma canonical_forms_of_Bool : forall Gamma s,
  has_type Gamma s ty_Bool ->
  value s ->
  (s = tm_true \/ s = tm_false).
Proof with eauto.
  intros Gamma s Hty Hv.
  remember ty_Bool as T.
  has_type_cases (induction Hty) Case; try solve by inversion...
  Case "T_Sub".
    subst. apply sub_inversion_Bool in H. subst...
Qed.

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

(** The proof of progress proceeds like the one for the pure
    STLC, except that in several places we invoke canonical forms
    lemmas... *)

(** _Theorem_ (Progress): For any term [t] and type [T], if [empty |-
    t : T] then [t] is a value or [t ==> t'] for some term [t'].

    _Proof_: Let [t] and [T] be given, with [empty |- t : T].  Proceed
    by induction on the typing derivation.

    The cases for [T_Abs], [T_Unit], [T_True] and [T_False] are
    immediate because abstractions, [unit], [true], and [false] are
    already values.  The [T_Var] case is vacuous because variables
    cannot be typed in the empty context.  The remaining cases are
    more interesting:

    - If the last step in the typing derivation uses rule [T_App],
      then there are terms [t1] [t2] and types [T1] and [T2] such that
      [t = t1 t2], [T = T2], [empty |- t1 : T1 -> T2], and [empty |-
      t2 : T1].  Moreover, by the induction hypothesis, either [t1] is
      a value or it steps, and either [t2] is a value or it steps.
      There are three possibilities to consider:

      - Suppose [t1 ==> t1'] for some term [t1'].  Then [t1 t2 ==> t1' t2]
        by [ST_App1].

      - Suppose [t1] is a value and [t2 ==> t2'] for some term [t2'].
        Then [t1 t2 ==> t1 t2'] by rule [ST_App2] because [t1] is a
        value.

      - Finally, suppose [t1] and [t2] are both values.  By Lemma
        [canonical_forms_for_arrow_types], we know that [t1] has the
        form [\x:S1.s2] for some [x], [S1], and [s2].  But then
        [(\x:S1.s2) t2 ==> [t2/x]s2] by [ST_AppAbs], since [t2] is a
        value.

    - If the final step of the derivation uses rule [T_If], then there
      are terms [t1], [t2], and [t3] such that [t = if t1 then t2 else
      t3], with [empty |- t1 : Bool] and with [empty |- t2 : T] and
      [empty |- t3 : T].  Moreover, by the induction hypothesis,
      either [t1] is a value or it steps.

       - If [t1] is a value, then by the canonical forms lemma for
         booleans, either [t1 = true] or [t1 = false].  In either
         case, [t] can step, using rule [ST_IfTrue] or [ST_IfFalse].

       - If [t1] can step, then so can [t], by rule [ST_If].

    - If the final step of the derivation is by [T_Sub], then there is
      a type [S] such that [S <: T] and [empty |- t : S].  The desired
      result is exactly the induction hypothesis for the typing
      subderivation.
*)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  has_type_cases (induction Ht) Case;
    intros HeqGamma; subst...
  Case "T_Var".
    inversion H.
  Case "T_App".
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists (subst t2 x t12)...
      SSCase "t2 steps".
        destruct H0 as [t2' Hstp]. exists (tm_app t1 t2')...
    SCase "t1 steps".
      destruct H as [t1' Hstp]. exists (tm_app t1' t2)...
  Case "T_If".
    right.
    destruct IHHt1.
    SCase "t1 is a value"...
      assert (t1 = tm_true \/ t1 = tm_false)
        by (eapply canonical_forms_of_Bool; eauto).
      inversion H0; subst...
      destruct H. rename x into t1'. eauto.

Qed.

(* ########################################## *)
(** ** Inversion Lemmas for Typing *)

(** The proof of the preservation theorem also becomes a little more
    complex with the addition of subtyping.  The reason is that, as
    with the "inversion lemmas for subtyping" above, there are a
    number of facts about the typing relation that are "obvious from
    the definition" in the pure STLC (and hence can be obtained
    directly from the [inversion] tactic) but that require real proofs
    in the presence of subtyping because there are multiple ways to
    derive the same [has_type] statement.

    The following "inversion lemma" tells us that, if we have a
    derivation of some typing statement [Gamma |- \x:S1.t2 : T] whose
    subject is an abstraction, then there must be some subderivation
    giving a type to the body [t2]. *)

(** _Lemma_: If [Gamma |- \x:S1.t2 : T], then there is a type [S2]
    such that [Gamma, x:S1 |- t2 : S2] and [S1 -> S2 <: T].

    (Notice that the lemma does _not_ say, "then [T] itself is an arrow
    type" -- this is tempting, but false!)

    _Proof_: Let [Gamma], [x], [S1], [t2] and [T] be given as
     described.  Proceed by induction on the derivation of [Gamma |-
     \x:S1.t2 : T].  Cases [T_Var], [T_App], are vacuous as those
     rules cannot be used to give a type to a syntactic abstraction.

     - If the last step of the derivation is a use of [T_Abs] then
       there is a type [T12] such that [T = S1 -> T12] and [Gamma,
       x:S1 |- t2 : T12].  Picking [T12] for [S2] gives us what we
       need: [S1 -> T12 <: S1 -> T12] follows from [S_Refl].

     - If the last step of the derivation is a use of [T_Sub] then
       there is a type [S] such that [S <: T] and [Gamma |- \x:S1.t2 :
       S].  The IH for the typing subderivation tell us that there is
       some type [S2] with [S1 -> S2 <: S] and [Gamma, x:S1 |- t2 :
       S2].  Picking type [S2] gives us what we need, since [S1 -> S2
       <: T] then follows by [S_Trans]. *)

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (tm_abs x S1 t2) T ->
     (exists S2, subtype (ty_arrow S1 S2) T
              /\ has_type (extend Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (tm_abs x S1 t2) as t.
  has_type_cases (induction H) Case;
    inversion Heqt; subst; intros; try solve by inversion.
  Case "T_Abs".
    exists T12...
  Case "T_Sub".
    destruct IHhas_type as [S2 [Hsub Hty]]...
  Qed.

(** Similarly... *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (tm_var x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (tm_var x) as t.
  has_type_cases (induction Hty) Case; intros;
    inversion Heqt; subst; try solve by inversion.
  Case "T_Var".
    exists T...
  Case "T_Sub".
    destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (tm_app t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (ty_arrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (tm_app t1 t2) as t.
  has_type_cases (induction Hty) Case; intros;
    inversion Heqt; subst; try solve by inversion.
  Case "T_App".
    exists T1...
  Case "T_Sub".
    destruct IHHty as [U1 [Hty1 Hty2]]...
Qed.

Lemma typing_inversion_true : forall Gamma T,
  has_type Gamma tm_true T ->
  subtype ty_Bool T.
Proof with eauto.
  intros Gamma T Htyp. remember tm_true as tu.
  has_type_cases (induction Htyp) Case;
    inversion Heqtu; subst; intros...
Qed.

Lemma typing_inversion_false : forall Gamma T,
  has_type Gamma tm_false T ->
  subtype ty_Bool T.
Proof with eauto.
  intros Gamma T Htyp. remember tm_false as tu.
  has_type_cases (induction Htyp) Case;
    inversion Heqtu; subst; intros...
Qed.

Lemma typing_inversion_if : forall Gamma t1 t2 t3 T,
  has_type Gamma (tm_if t1 t2 t3) T ->
  has_type Gamma t1 ty_Bool
  /\ has_type Gamma t2 T
  /\ has_type Gamma t3 T.
Proof with eauto.
  intros Gamma t1 t2 t3 T Hty.
  remember (tm_if t1 t2 t3) as t.
  has_type_cases (induction Hty) Case; intros;
    inversion Heqt; subst; try solve by inversion.
  Case "T_If".
    auto.
  Case "T_Sub".
    destruct (IHHty H0) as [H1 [H2 H3]]...
Qed.

Lemma typing_inversion_unit : forall Gamma T,
  has_type Gamma tm_unit T ->
    subtype ty_Unit T.
Proof with eauto.
  intros Gamma T Htyp. remember tm_unit as tu.
  has_type_cases (induction Htyp) Case;
    inversion Heqtu; subst; intros...
Qed.

(** The inversion lemmas for typing and for subtyping between arrow
    types can be packaged up as a useful "combination lemma" telling
    us exactly what we'll actually require below. *)

Lemma abs_arrow : forall x S1 s2 T1 T2,
  has_type empty (tm_abs x S1 s2) (ty_arrow T1 T2) ->
     subtype T1 S1
  /\ has_type (extend empty x S1) s2 T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

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

(** The context invariance lemma follows the same pattern as in the
    pure STLC. *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tm_var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tm_app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tm_app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tm_abs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tm_if t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tm_if t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tm_if t1 t2 t3)
.

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
  Case "T_Var".
    apply T_Var... rewrite <- Heqv...
  Case "T_Abs".
    apply T_Abs... apply IHhas_type. intros x0 Hafi.
    unfold extend. remember (beq_id x x0) as e.
    destruct e...
  Case "T_App".
    apply T_App with T1...
  Case "T_If".
    apply T_If...

Qed.

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 with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case;
      subst; inversion Hafi; subst...
  Case "T_Abs".
    destruct (IHHtyp H4) as [T Hctx]. exists T.
    unfold extend in Hctx. apply not_eq_beq_id_false in H2.
    rewrite H2 in Hctx...  Qed.

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

(** The _substitution lemma_ is proved along the same lines as for the
    pure STLC.  The only significant change is that there are several
    places where, instead of the built-in [inversion] tactic, we use
    the inversion lemmas that we proved above to extract structural
    information from assumptions about the well-typedness of
    subterms. *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (extend Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma (subst v x t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  tm_cases (induction t) Case; intros; simpl.
  Case "tm_var".
    rename i into y.
    destruct (typing_inversion_var _ _ _ Htypt)
        as [T [Hctx Hsub]].
    unfold extend in Hctx.
    remember (beq_id x y) as e. destruct e...
    SCase "x=y".
      apply beq_id_eq in Heqe. subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra)
          as [T' HT']...
      inversion HT'.
  Case "tm_app".
    destruct (typing_inversion_app _ _ _ _ Htypt)
        as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  Case "tm_abs".
    rename i into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    apply T_Sub with (ty_arrow T1 T2)... 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...
  Case "tm_true".
      assert (subtype ty_Bool S)
        by apply (typing_inversion_true _ _  Htypt)...
  Case "tm_false".
      assert (subtype ty_Bool S)
        by apply (typing_inversion_false _ _  Htypt)...
  Case "tm_if".
    assert (has_type (extend Gamma x U) t1 ty_Bool
            /\ has_type (extend Gamma x U) t2 S
            /\ has_type (extend Gamma x U) t3 S)
      by apply (typing_inversion_if _ _ _ _ _ Htypt).
    destruct H as [H1 [H2 H3]].
    apply IHt1 in H1. apply IHt2 in H2. apply IHt3 in H3.
    auto.
  Case "tm_unit".
    assert (subtype ty_Unit S)
      by apply (typing_inversion_unit _ _  Htypt)...
Qed.

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

(** The proof of preservation now proceeds pretty much as in earlier
    chapters, using the substitution lemma at the appropriate point
    and again using inversion lemmas from above to extract structural
    information from typing assumptions. *)

(** _Theorem_ (Preservation): If [t], [t'] are terms and [T] is a type
    such that [empty |- t : T] and [t ==> t'], then [empty |- t' :
    T].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We
    go by induction on the structure of this typing derivation,
    leaving [t'] general.  The cases [T_Abs], [T_Unit], [T_True], and
    [T_False] cases are vacuous because abstractions and constants
    don't step.  Case [T_Var] is vacuous as well, since the context is
    empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then [t1 =
       \x:S.t12] for some type [S] and term [t12], and [t' =
       [t2/x]t12].

       By lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by the substitution lemma
       ([substitution_preserves_typing]) that [empty |- [t2/x]
       t12 : T2] as desired.

      - If the final step of the derivation uses rule [T_If], then
        there are terms [t1], [t2], and [t3] such that [t = if t1 then
        t2 else t3], with [empty |- t1 : Bool] and with [empty |- t2 :
        T] and [empty |- t3 : T].  Moreover, by the induction
        hypothesis, if [t1] steps to [t1'] then [empty |- t1' : Bool].
        There are three cases to consider, depending on which rule was
        used to show [t ==> t'].

           - If [t ==> t'] by rule [ST_If], then [t' = if t1' then t2
             else t3] with [t1 ==> t1'].  By the induction hypothesis,
             [empty |- t1' : Bool], and so [empty |- t' : T] by [T_If].

           - If [t ==> t'] by rule [ST_IfTrue] or [ST_IfFalse], then
             either [t' = t2] or [t' = t3], and [empty |- t' : T]
             follows by assumption.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].  [] *)

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    inversion HE; subst...
    SCase "ST_AppAbs".
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T...
Qed.

(* ###################################################### *)
(** ** Exercises on Typing *)

(** **** Exercise: 2 stars (variations) *)
(** Each part of this problem suggests a different way of
    changing the definition of the STLC with Unit and
    subtyping.  (These changes are not cumulative: each part
    starts from the original language.)  In each part, list which
    properties (Progress, Preservation, both, or neither) become
    false.  If a property becomes false, give a counterexample.
    - Suppose we add the following typing rule:
[[[
                            Gamma |- t : S1->S2
                    S1 <: T1      T1 <: S1     S2 <: T2
                    -----------------------------------              (T_Funny1)
                            Gamma |- t : T1->T2
]]]

    - Suppose we add the following reduction rule:
[[[
                             ------------------                     (ST_Funny21)
                             unit ==> (\x:Top. x)
]]]

    - Suppose we add the following subtyping rule:
[[[
                               --------------                        (S_Funny3)
                               Unit <: Top->Top
]]]

    - Suppose we add the following subtyping rule:
[[[
                               --------------                        (S_Funny4)
                               Top->Top <: Unit
]]]

    - Suppose we add the following evaluation rule:
[[[
                             -----------------                      (ST_Funny5)
                             (unit t) ==> (t unit)
]]]

    - Suppose we add the same evaluation rule _and_ a new typing rule:
[[[
                             -----------------                      (ST_Funny5)
                             (unit t) ==> (t unit)

                           ----------------------                    (T_Funny6)
                           empty |- Unit : Top->Top
]]]

    - Suppose we _change_ the arrow subtyping rule to:
[[[
                          S1 <: T1       S2 <: T2
                          -----------------------                    (S_Arrow')
                               S1->S2 <: T1->T2
]]]

[]
*)

(* ###################################################################### *)
(** * Exercise: Adding Products *)

(** **** Exercise: 4 stars, optional (products) *)
(** Adding pairs, projections, and product types to the system we have
    defined is a relatively straightforward matter.  Carry out this
    extension:

    - Add constructors for pairs, first and second projections, and
      product types to the definitions of [ty] and [tm].  (Don't
      forget to add corresponding cases to [ty_cases] and [tm_cases].)

    - Extend the well-formedness relation in the obvious way.

    - Extend the operational semantics with the same reduction rules
      as in the last chapter.

    - Extend the subtyping relation with this rule:
[[[
                        S1 <: T1     S2 <: T2
                        ---------------------                     (Sub_Prod)
                          S1 * S2 <: T1 * T2
]]]
    - Extend the typing relation with the same rules for pairs and
      projections as in the last chapter.

    - Extend the proofs of progress, preservation, and all their
      supporting lemmas to deal with the new constructs.  (You'll also
      need to add some completely new lemmas.)  []
*)


(** * Library file that should be used for the term projects of introduction
to functional programming 2015. This file is based on SfLib.v of Software
Foundations by Benjamin Pierce and others. *)

(** * From the Coq Standard Library *)

Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export NPeano.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

(** * From Logic.v *)

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

(**  Identifiers *)

(** We define a new inductive datatype [Id] so that we won't confuse
    identifiers and numbers. *)

Inductive id : Type :=
  Id : nat -> id.

Definition beq_id (x x' : id) : bool :=
  match x, x' with
  | Id y, Id y' => beq_nat y y'
  end.
Lemma beq_id_refl : forall x : id,
  true = beq_id x x.
Proof.
  intros x; destruct x as [y]; simpl; apply beq_nat_refl.
Qed.
Lemma beq_id_eq: forall x x' : id,
  true = beq_id x x' -> x = x'.
Proof.
  intros x x' H; destruct x as [y]; destruct x' as [y']; simpl in H.
  apply beq_nat_eq in H. rewrite H. reflexivity.
Qed.


(** remove printing ~ *)
(** printing ~ %\textasciitilde% *)
(** printing R $R$ *)
(** printing done %\texttt{\emph{done}}% *)
(** printing congr %\texttt{\emph{congr}}% *)
(** printing of %\texttt{\emph{of}}% *)
(** printing suff %\texttt{\emph{suff}}% *)
(** printing have %\texttt{\emph{have}}% *)
(** printing View %\texttt{\emph{View}}% *)
(** printing From %\textsf{{From}}% *)

(**

%\chapter{Views and Boolean Reflection}
\label{ch:boolrefl}%

*)

(**

In %Chapter~\ref{ch:eqrew}%, we have seen how custom rewriting rules
and truth tables can be encoded in Coq using its support for indexed
datatype families, so they are of great help for constructing the
proofs by case analysis and rewriting. In this chapter, we will show
how the custom rewriting machinery can be taken to the whole new level
and be used to facilitate the reasoning about _computable_ properties
and predicates. We will consider a series of insights that lead to the
idea of the _small-scale reflection_, the heart of the Ssreflect
%\index{small-scale reflection|textbf}% %\index{reflection|see
{small-scale reflection}}% framework, which blurs the boundaries
between computable predicates defined in the sort [Prop] (see
%Chapter~\ref{ch:logic}%) and Coq's recursive functions returning a
result of type [bool] (in the spirit of the definitions that we have
seen in %Chapter~\ref{ch:funprog}%). That said, in the vast number of
cases these two are just the sides of the same coin and, hence, should
be treated uniformly, serving to facilitate the reasoning in two
different directions: %\index{reflection|see {small-scale
reflection}}%

- expressing quantifications and building the proofs by means of
  _constructive reasoning_ with logical connectives as datatypes
  defined in the sort [Prop];

- employing brute-force computations for quantifier-free goals within
  the Coq framework itself, taken as a programming language, in order
  to reduce the goals to be proved by means of simply _computing_
  them.

We will elaborate more on the differences between predicates stated by
means of [Prop] and [bool] in %Section~\ref{sec:propbool}%. The term
_small-scale reflection_, which gives the name to the whole framework
of Ssreflect, emphasizes the two complementary ways of building
proofs: by means of intuitionistic inference (i.e., using the
constructors of datatypes defined in [Prop]) and by means of mere
computation (i.e., with [bool]-returning function). These two ways,
therefore, serve as each other's "reflections" and, moreover, both are
implemented within the same system, without the need to appeal to
Coq's meta-object protocol,%\footnote{In contrast, reflection
mechanism in Java, Python or Ruby actually does appeal to the
meta-object protocol, e.g., \index{meta-object protocol} the structure
of the classes, which lies beyond the formally defined semantics of
the language itself and, hence, allows one to modify the program's
behaviour at runtime.}% which makes this reflection _small-scale_.

Unfortunately, the proper explanation of the implementation of the
reflection mechanism between [Prop] and [bool] in Ssreflect strongly
relies on the _views_ machinery, so let us begin by describing it
first.

%\newpage%

* Proving with views in Ssreflect
%\label{sec:views}\index{views|textbf}%

*)

From mathcomp
Require Import ssreflect ssrnat prime ssrbool eqtype.

(* begin hide *)
Module BoolReflect.
(* end hide *)

(**

Let us assume we have the following implication to prove:

*)

Lemma imp_trans4 P Q R S: (P -> Q) -> (R -> S) -> (Q -> R) -> P -> S.
Proof.
move=>H1 H2 H3.

(**
[[
  P : Type
  Q : Type
  R : Type
  S : Type
  H1 : P -> Q
  H2 : R -> S
  H3 : Q -> R
  ============================
   P -> S
]]

Since we are proficient in the proofs via implications, it is not
difficult to construct the explicit proof term by a series of [apply:]
tactic calls or via the [exact:] tactic, as it has been show in
%Chapter~\ref{ch:logic}%. Let us do something different, though,
namely _weaken_ the top assumption of the goal by means of applying
the hypothesis [H1] to it, so the overall goal will become [Q -> S].

*)

move=>p; move: (H1 p).

(**

This proof pattern of "switching the view" turns out to be so frequent
that Ssreflect introduces a special _view_ tactical %\texttt{/}% for
it, which is typically combined with the standard [move] or [case]
tactics. In particular, the last proof line could be replaced by the
following:

*)

Undo.
move/H1.

(**

[[
  ...
  H1 : P -> Q
  H2 : R -> S
  H3 : Q -> R
  ============================
   Q -> S
]]

The assumption [H1] used for weakening is usually referred to as a
%\index{view lemma}% _view lemma_. The spaces before and after
%\texttt{/}% are optional. One can also _chain_ the views into one
series, so the current proof can be completed as follows:

*)

by move/H3 /H2.
Qed.

(**

** Combining views and bookkeeping

The view tactical can be also combined with the standard bookkeeping
machinery, so it will apply the specified view lemma to the
corresponding assumption of the goal, as demonstrated by the following
proof script, which use the partially-applied assumption [H p] as a
view lemma:

*)

Goal forall P Q R, P -> (P -> Q -> R) -> Q -> R.
Proof.
by move=>P Q R p H /(H p).

(**

In fact, this proof can be shortened even further by using the view
notation for the _top_ assumption (denoted using the underscore):

*)

Undo.
move=> P Q R p.
by move/(_ p).
Qed.

(**

The last proof script first moved four assumptions to the context, so
the goal became [(P -> Q -> R) -> Q -> R]. Next, it partially applied
the top assumption [(P -> Q -> R)] to [p : P] from the context and
moved the result back to the goal, so it became [(Q -> R) -> Q -> R],
which is trivially provable.

It is also possible to use views in combination with the [case]
tactics, which first performs the "view switch" via the view lemma
provided and then case-analysed on the result, as demonstrated by the
following proof script:

*)

Goal forall P Q R, (P -> Q /\ R) -> P -> R.
Proof.
move=> P Q R H.
by case/H.
Qed.

(**

What has happened is that the combined tactic [case/H] first switched
the top assumption of the goal from [P] to [Q /\ R] and then
case-analysed on it, which gave the proof of [R] right away, allowing
us to conclude the proof.

** Using views with equivalences
%\label{seq:viewseq}%

So far we have explored only views that help to weaken the hypothesis
using the view lemma, which is an implication. In fact, Ssreflect's
view mechanism is elaborate enough to deal with view lemmas defined
by means of equivalence (double implication) %\texttt{<->}%, and the
system can figure out itself, "in which direction" the view lemma
should be applied. Let us demonstrate it with the following example,
which makes use of the hypothesis [STequiv],%\footnote{The Coq's
command \texttt{Hypothesis} is a synonym for \texttt{Axiom} and
\texttt{Variable}.\ccom{Hypothesis}\ccom{Variable}\ccom{Axiom}}% whose
nature is irrelevant for the illustration purposes:

*)

Variables S T: bool -> Prop.
Hypothesis STequiv : forall a b, T a <-> S (a || b).

Lemma ST_False a b: (T a -> False) -> S (a || b) -> False.
Proof.
by move=>H /STequiv.
Qed.

(**

** Declaring view hints

In the example from %Section~\ref{seq:viewseq}%, we have seen how
views can deal with equivalences. The mentioned elaboration, which
helped the system to recognize, in which direction the double
implication hypothesis [STequiv] should have been used, is not
hard-coded into Ssreflect. Instead, it is provided by a flexible
mechanism of %\index{view hints}% _view hints_, which allows one to
specify view lemmas that should be applied _implicitly_ whenever it is
necessary and can be figured out unambiguously.

In the case of the proof of the [ST_False] lemma the view hint [iffRL]
from the included module [ssreflect]%\footnote{Implicit view hints are
defined by means of \texttt{Hint View}\ccom{Hint View} command, added
to Coq by Ssreflect. See the implementation of the module
%[ssrbool]%\ssrm{ssrbool} and Section 9.8 of the Reference
Manual~\cite{Gontier-al:TR}.}% %\ssrm{ssreflect}% has been "fired" in
order to adapt the hypothesis [STequiv], so the adapted variant could
be applied as a view lemma to the argument of type [S (a || b)].

*)

Check iffRL.

(**
[[
iffRL
     : forall P Q : Prop, (P <-> Q) -> Q -> P
]]

The type of [iffRL] reveals that what it does is simply switching the
equivalence to the implication, which works right-to-left, as captured
by the name. Let us now redo the proof of the [ST_False] lemma to see
what is happening under the hood:

*)

Lemma ST_False' a b: (T a -> False) -> S (a || b) -> False.
Proof.
move=> H.
move/(iffRL (STequiv a b)).
done.
Qed.

(**

The view switch on the second line of the proof is what has been done
implicitly in the previous case: the implicit view [iffRL] has been
applied to the call of [STequiv], which was in its turn supplied the
necessary arguments [a] and [b], inferred by the system from the goal,
so the type of [(STequiv a b)] would match the parameter type of
[iffRL], and the whole application would allow to make a view switch
in the goal.  What is left behind the scenes is the rest of the
attempts made by Coq/Ssreflect in its search for a suitable implicit
view, which ended when the system has finally picked [iffRL].

In general, the design of powerful view hints is non-trivial, as they
should capture precisely the situation when the "view switch" is
absolutely necessary and the implicit views will not "fire"
spuriously. In the same time, implicit view hints is what allows for
the smooth implementation of the boolean reflection, as we will
discuss in %Section~\ref{sec:reflect}%.

** Applying view lemmas to the goal

Similarly to how they are used for _assumptions_, views can be used to
interpret the goal by means of combining the Coq's standard [apply]
and [exact] tactics with the view tactical%~\texttt{/}%. In the case
if [H] is a view lemma, which is just an implication [P -> Q], where
[Q] is the statement of the goal, the enhanced tactic [apply/ H] will
work exactly as the standard Ssreflect's [apply:], that is, it will
replace the goal [Q] with [H]'s assumption [P] to prove.

However, interpreting goals via views turns out to be very beneficial
in the presence of implicit view hints. For example, let us consider
the following proposition to prove.

*)

Definition TS_neg: forall a, T (negb a) -> S ((negb a) || a).
Proof.
move=>a H.
apply/STequiv.
done.
Qed.

(**

The view switch on the goal via [apply/STequiv] immediately changed
the goal from [S ((negb a) || a)] to [T (negb a)], so the rest of the
proof becomes trivial. Again, notice that the system managed to infer
the right arguments for the [STequiv] hypothesis by analysing the
goal.

Now, if we print the body of [TS_neg], we will be able to see how an
application of the implicit application of the view lemma [iffLR] of
type [forall P Q : Prop, (P <-> Q) -> P -> Q] has been inserted,
allowing for the construction of the proof term:

*)

Print TS_neg.

(**

[[
TS_neg =
  fun (a : bool) (H : T (negb a)) =>
  (fun F : T (negb a) =>
     iffLR (Q:=S (negb a || a)) (STequiv (negb a) a) F) H
     : forall a : bool, T (negb a) -> S (negb a || a)
]]

*)

(** * %\texttt{Prop} versus \textbf{\textsf{bool}}%
%\label{sec:propbool}%

As we have already explored in the previous chapters, in CIC, the
logical foundation of Coq, there is a number of important distinctions
between logical propositions and boolean values.  In particular, there
is an infinite number of ways to represent different propositions in
the sort [Prop] by means of defining the datatypes. In contrast, the
type [bool] is represented just by two values: [true] and
[false]. Moreover, as it was discussed in %Chapter~\ref{ch:logic}%, in
Coq only those propositions are considered to be _true_, whose proof
term can be constructed. And, of course, there is no such thing as a
"proof term of [true]", as [true] is simply a value.

A more interesting question, though, is for which propositions [P]
from the sort [Prop] the proofs can be computed _automatically_ by
means of running a program, whose result will be an answer to the
question "Whether [P] holds?". Therefore, such programs should always
_terminate_ and, upon terminating, say "true" or "false". The
propositions, for which a construction of such programs (even a very
inefficient one) is possible, are referred to %\index{decidability}%
as _decidable_ ones. Alas, as it was discussed in
%Section~\ref{sec:propsort} of Chapter~\ref{ch:logic}%, quite a lot of
interesting propositions are undecidable. Such properties include the
classical halting problem %\index{halting problem}% ("Whether the
program [p] terminates or not?") and any higher-order formulae, i.e.,
such that contain quantifiers. For instance, it is not possible to
implement a higher-order function, which would take two arbitrary
functions $f_1$ and $f_2$ of type [nat -> nat] and return a boolean
answer, which would indicate whether these two functions are equal
(point-wise) or not, as it would amount to checking the result of the
both function on each natural number, which, clearly, wouldn't
terminate. Therefore, propositional equality of functions is a good
example of a proposition, which is undecidable in general, so we
cannot provide a terminating procedure for any values of its arguments
(i.e., $f_1$ and $f_2$).

However, the _undecidability_ of higher-order propositions (like the
propositional equality of functions) does not make them _non-provable_
for particular cases, as we have clearly observed thorough the past
few chapters. It usually takes a human intuition, though, to construct
a proof of an undecidable proposition by means of combining a number
of hypotheses (i.e., constructing a proof term), which is what one
does when building a proof using tactics in Coq. For instance, if we
have some extra insight about the two functions $f_1$ and $f_2$, which
are checked for equality, we might be able to construct the proof of
them being equal or not, in the similar ways as we have carried the
proofs so far. Again, even if the functions are unknown upfront, it
does not seem possible to implement an always-terminating procedure
that would automatically decide whether they are equal or not.

The above said does not mean that all possible propositions should be implemented as instances of [Prop], making their clients to always construct their proofs, when it is necessary, since, fortunately, some propositions are _decidable_, so it is possible to construct a decision procedure for them. A good example of such proposition is a predicate, which ensures that a number [n] is prime. Of course, in Coq one can easily encode primality of a natural number by means of the following inductive predicate, which ensures that [n] is prime if it is [1] or has no other natural divisors but [1] and [n] itself.

%\ssrd{isPrime}%

*)

Definition isPrime n : Prop :=
  forall n1 n2, n = n1 * n2 -> (n1 = 1 /\ n2 = n) \/ (n1 = n /\ n2 = 1).

(**

Such definition, although correct, is quite inconvenient to use, as it
does not provide a direct way to _check_ whether some particular
number (e.g., 239) is prime or not. Instead, it requires one to
construct a proof of primality for _each_ particular case using the
constructors (or the contradiction, which would imply that the number
is not prime). As it's well known, there is a terminating procedure to
compute whether the number is prime or not by means of _enumerating_
all potential divisors of [n] from [1] to the square root of [n]. Such
procedure is actually implemented in the Ssreflect's [prime]
%\ssrm{prime}% module and proved correct with respect to the
definition similar to the one above,%\footnote{Although the
implementation and the proof are somewhat non-trivial, as they require
to build a primitively-recursive function, which performs the
enumeration, so we do not consider them here.}% so now one can test
the numbers by equality by simply _executing_ the appropriate function
and getting a boolean answer:

*)

Eval compute in prime 239.
(**
[[
     = true
     : bool
]]

Therefore, we can summarize that the _decidability_ is what draws the
line between propositions encoded by means of Coq's [Prop] datatypes
and procedures, returning a [bool] result. [Prop] provides a way to
encode a _larger_ class of logical statements, in particular, thanks
to the fact that it allows one to use quantifiers and, therefore,
encode higher-order propositions. The price to pay for the
expressivity is the necessity to explicitly construct the proofs of
the encoded statements, which might lead to series of tedious and
repetitive scripts. [bool]-returning functions, when implemented in
Coq, are decidable by construction (as Coq enforces termination), and,
therefore, provide a way to compute the propositions they
implement. Of course, in order to be reduced to [true] or [false], all
quantifiers should be removed by means of instantiated the
corresponding bound variables, after which the computation becomes
possible.

For instance, while the expression [(prime 239) || (prime 42)] can be
evaluated to [true] right away, whereas the expression

[[
forall n, (prime n) || prime (n + 1)
]]

is not even well-typed. The reason for this is that polymorphic
[forall]-quantification in Coq does not admit _values_ to come after
the comma (so the dependent function type "$\Pi{}n:~\textsf{nat}, n$"
is malformed), similarly to how one cannot write a _type_ [Int -> 3]
in Haskell%\index{Haskell}%, as it does not make sense. This
expression can be, however, _coerced_ into [Prop] by means of
comparing the boolean expression with [true] using propositional
equality

[[
forall n, ((prime n) || prime (n + 1) = true)
]]

which makes the whole expression to be of type [Prop]. This last
example brings us to the insight that the [bool]-returning functions
(i.e., decidable predicates) can be naturally _injected_
%\index{injection}% into propositions of sort [Prop] by simply
comparing their result with [true] via propositional equality, defined
in Chapter%~\ref{ch:eqrew}%. This is what is done by Ssreflect
automatically using the implicit%\index{coercion}\ccom{Coercion}%
_coercion_, imported by the [ssrbool] module:%\ssrm{ssrbool}%

[[
Coercion is_true (b: bool) := b = true
]]

This coercion can be seen as an implicit type conversion, familiar
from the languages like Scala or Haskell,
%\index{Scala}\index{Haskell}%and it inserted by Coq automatically
every time it expects to see a proposition of sort [Prop], but instead
encounters a boolean value. Let us consider the following goal as an
example:

*)

Goal prime (16 + 14) -> False.
Proof. done. Qed.

(**

As we can see, the proof is rather short, and, in fact, done by
Coq/Ssreflect fully automatically. In fact, the system first
_computes_ the value of [prime (16 + 14)], which is, obviously
[false]. Then the boolean value [false] is coerced into the
propositional equality [false = true], as previously described. The
equality is then automatically discriminated (%see
Section~\ref{sec:discr}%), which allows the system to infer the
falsehood, completing the proof.

This example and the previous discussion should convey the idea that
_decidable propositions should be implemented as computable functions
returning a boolean result_. This simple design pattern makes it
possible to take full advantage of the computational power of Coq as a
programming language and prove decidable properties automatically,
rather than by means of imposing a burden of constructing an explicit
proof. We have just seen how a boolean result can be easily injected
back to the world of propositions. This computational approach to
proofs is what has been taken by Ssreflect to the extreme, making the
proofs about common mathematical constructions to be very short, as
most of the proof obligations simply _do not appear_, as the system is
possible to reduce them by means of performing the computations on the
fly. Even though, as discussed, some propositions can be only encoded
as elements of [Prop], our general advice is to rely on the
computations whenever it is possible.

In the following subsections we will elaborate on some additional
specifications and proof patterns, which are enabled by using boolean
values instead of full-fledged propositions from [Prop].

** Using conditionals in predicates

The ternary conditional operator [if-then-else] is something that
programmers use on a regular basis. However, when it comes to the
specifications in the form of Coq's standard propositions it turns out
one cannot simply employ the [if-then-else] connective in them, as it
expects its conditional argument to be of type [bool]. This
restriction is, again, a consequence of the fact that the result of
[if-then-else] expression should be computable, which conflicts with
the fact that not every proposition is decidable and, hence, there is
no sound way overload the conditional operator, so it would rely on
the existence of the proof of its conditional (or its negation).

[[
Definition prime_spec_bad n m : Prop := m = (if isPrime n then 1 else 2).

Error: In environment
m : nat
n : nat
The term "isPrime n" has type "Prop" while it is expected to have type "bool".
]]

Fortunately, the computable predicates are free from this problem, so
on can freely use them in the conditionals:

*)

Definition prime_spec n m : Prop := m = (if prime n then 1 else 2).

(**

** Case analysing on a boolean assumption

Another advantage of the boolean predicates is that they automatically
come with a natural case analysis principle: reasoning about an
outcome of a particular predicate, one can always consider two
possibilities: when it returned [true] or [false].%\footnote{We have
already seen an instance of such case analysis in the proof of the
%[leqP]% lemma in Section~\ref{sec:enccustom} of
Chapter~\ref{ch:eqrew}, although deliberately did not elaborate on it
back then.}% This makes it particularly pleasant to reason about the
programs and specifications that use conditionals, which is
demonstrated by the following example.

*)

Definition discr_prime n := (if prime n then 0 else 1) + 1.

(**

Let us now prove that the definition [prime_spec] gives a precise
specification of the function [discr_prime]:

*)

Lemma discr_prime_spec : forall n, prime_spec n (discr_prime n).
Proof.
move=>n. rewrite /prime_spec /discr_prime.

(**

[[
  n : nat
  ============================
   (if prime n then 0 else 1) + 1 = (if prime n then 1 else 2)
]]

The proof of the specification is totally in the spirit of what one
would have done when proving it manually: we just case-analyse on the
value of [prime n], which is either [true] or [false]. Similarly to
the way the rewritings are handled by means of unification, in both
cases the system substitutes [prime n] with its boolean value in the
specification as well. The evaluation completes the proof.

*)

by case: (prime n).
Qed.

(**

Another common use case of boolean predicates comes from the
possibility to perform a case analysis on the boolean _computable
equality_, which can be employed in the proof proceeding by an
argument "let us assume [a] to be equal to [b] (or not)". As already
hinted by the example with the function equality earlier in this
section, the computable equality is not always possible to
implement. Fortunately, it can be implemented for a large class of
datatypes, such as booleans, natural numbers, lists and sets (of
elements with computable equality), and it was implemented in
Ssreflect, so one can take an advantage of it in the
proofs.%\footnote{The way the computable equality is encoded so it
would work uniformly for different types is an interesting topic by
itself, so we postpone its explanation until
Chapter~\ref{ch:depstruct}}%

*)

(** * %The \textsf{\textbf{reflect}} type family%
%\label{sec:reflect}%

Being able to state all the properties of interest in a way that they
are decidable is a true blessing. However, even though encoding
everything in terms of [bool]-returning functions and connectives
comes with the obvious benefits, reasoning in terms of [Prop]s might
be more convenient when the information of the structure of the proofs
matters. For instance, let us consider the following situation:

*)

Variables do_check1 do_check2 : nat -> bool.
Hypothesis H: forall n, do_check2 n -> prime n.

Lemma check_prime n : (do_check1 n) && (do_check2 n) -> prime n.

(**

The lemma [check_prime] employs the boolean conjunction [&&] from the
[ssrbool] module in its assumption, so we know that its result is some
boolean value. However simply case-analysing on its component does not
bring any results. What we want indeed is a way to _decompose_ the
boolean conjunction into the components and then use the hypothesis
[H]. This is what could be accomplished easily, had we employed the
_propositional conjunction_ [/\] instead, as it comes with a
case-analysis principle.

*)

(** %\ccom{Abort}% *)
Abort.

(**

This is why we need a mechanism to conveniently switch between two
possible representation. Ssreflect solves this problem by employing
the familiar rewriting machinery (%see Section~\ref{sec:indexed} of
Chapter~\ref{ch:eqrew}%) and introducing the inductive predicate
family [reflect], which connects propositions and booleans:

%\ssrd{reflect}%
%\index{reflect datatype@{\textsf{reflect} datatype}}%

*)

Print Bool.reflect.

(**
[[
Inductive reflect (P : Prop) : bool -> Set :=
  | ReflectT of   P : reflect P true
  | ReflectF of ~ P : reflect P false.
]]

Similarly to the custom rewriting rules, the [reflect] predicate is
nothing but a convenient way to encode a "truth" table with respect to
the predicate [P], which is [reflect]'s only parameter. In other
words, the propositions [(reflect P b)] ensures that [(is_true b)] and
[P] are logically equivalent and can be replaced one by another. For
instance, the following rewriting lemmas %\index{rewriting lemma}% can
be proved for the simple instances of [Prop].

*)

Lemma trueP : reflect True true.
Proof. by constructor. Qed.

Lemma falseP : reflect False false.
Proof. by constructor. Qed.

(**

The proofs with boolean truth and falsehood can be then completed by
case analysis, as with any other rewriting rules:

*)

Goal false -> False.
Proof. by case:falseP. Qed.

(**

** Reflecting logical connectives

The true power of the [reflect] predicate, though, is that it might be
put to work with arbitrary logical connectives and user-defined
predicates, therefore delivering the rewriting principles, allowing
one to switch between [bool] and [Prop] (in the decidable case) by
means of rewriting lemmas. Ssreflect comes with a number of such
lemmas, so let us consider one of them, [andP].

*)

Lemma andP (b1 b2 : bool) : reflect (b1 /\ b2) (b1 && b2).
Proof. by case b1; case b2; constructor=> //; case. Qed.

(**

Notice that [andP] is stated over two boolean variables, [b1] and
[b2], which, nevertheless, are treated as instances of [Prop] in the
conjunction [/\], being implicitly coerced.

We can now put this lemma to work and prove our initial example:

*)

Lemma check_prime n : (do_check1 n) && (do_check2 n) -> prime n.
Proof.
case: andP=>//.

(**
[[
  n : nat
  ============================
   do_check1 n /\ do_check2 n -> true -> prime n
]]

Case analysis on the rewriting rule [andP] generates two goals, and
the second one has [false] as an assumption, so it is discharged
immediately by using %\texttt{//}\ssrtl{//}%. The remaining goal has a
shape that we can work with, so we conclude the proof by applying the
hypothesis [H] declared above.

*)

by case=>_ /H.
Qed.

(**

Although the example above is a valid usage of the reflected
propositions, Ssreflect leverages the rewriting with respect to
boolean predicates even more by defining a number of _hint views_ for
the rewriting lemmas that make use of the [reflect] predicates. This
allows one to use the rewriting rules (e.g., [andP]) in the form of
_views_ %\index{views}%, which can be applied directly to an
assumption or a goal, as demonstrated by the next definition.

*)

Definition andb_orb b1 b2: b1 && b2 -> b1 || b2.
Proof.
case/andP=>H1 H2.
by apply/orP; left.
Qed.

(**

The first line of the proof switched the top assumption from the
boolean conjunction to the propositional one by means of [andP] used
as a view. The second line applied the [orP] view, doing the similar
switch in the goal, completing the proof by using a constructor of the
propositional disjunction.

*)

Print andb_orb.

(**

Let us take a brief look to the obtained proof term for [andb_orb].

[[
andb_orb =
fun (b1 b2 : bool) (goal : b1 && b2) =>
(fun F : forall (a : b1) (b : b2),
                (fun _ : b1 /\ b2 => is_true (b1 || b2)) (conj a b) =>
 match
   elimTF (andP b1 b2) goal as a return ((fun _ : b1 /\ b2 => is_true (b1 || b2)) a)
 with
 | conj x x0 => F x x0
 end)
  (fun (H1 : b1) (_ : b2) =>
   (fun F : if true then b1 \/ b2 else ~ (b1 \/ b2) =>
    introTF (c:=true) orP F) (or_introl H1))
     : forall b1 b2 : bool, b1 && b2 -> b1 || b2
]]

As we can see, the calls to the rewriting lemmas [andP] and [orP] were
implicitly "wrapped" into the call of hints [elimTF] and [introTF],
correspondingly. Defined via the conditional operator, both these view
hints allowed us to avoid the second redundant goal, which we would be
be forced to deal with, had we simply gone with case analysis on
[andP] and [orP] as rewriting rules.

*)

Check elimTF.

(**
[[
elimTF
     : forall (P : Prop) (b c : bool),
       reflect P b -> b = c -> if c then P else ~ P
]]

%\begin{exercise}[Reflecting exclusive disjunction]%

Let us define a propositional version of the _exclusive or_
%\index{exclusive disjunction}% predicate:

*)

Definition XOR (P Q: Prop) := (P \/ Q) /\ ~(P /\ Q).

(**
%\noindent%
as well as its boolean version (in a curried form, so it takes just
one argument and returns a function):

*)

Definition xorb b := if b then negb else fun x => x.

(**
%\noindent%
Now, prove the following _generalized_ reflection lemma [xorP_gen] and
its direct consequence, the usual reflection lemma [xorP]:

%\hint% Recall that the _reflect_ predicate is just a rewriting rule,
 so one can perform a case analysis on it.

*)

Lemma xorP_gen (b1 b2 : bool)(P1 P2: Prop):
  reflect P1 b1 -> reflect P2 b2 -> reflect (XOR P1 P2) (xorb b1 b2).
(* begin hide *)
Proof.
case=>H1; case=>H2; constructor; rewrite /XOR.
- by case; case=>H; apply.
- split; first by left.
  by case=>_ H; apply: H2.
- split; first by right.
  by case=>H _; apply: H1.
- intuition.
Qed.
(* end hide *)

Lemma xorP (b1 b2 : bool): reflect (XOR b1 b2) (xorb b1 b2).
(* begin hide *)
Proof.
by apply: xorP_gen; case:b1=>//=; case:b2=>//=; constructor.
Qed.
(* end hide *)

(**
%\end{exercise}%

%\begin{exercise}[Alternative formulation of exclusive disjunction]%

Let us consider an alternative version of exclusive or, defined by
means of the predicate [XOR']:

*)

Definition XOR' (P Q: Prop) := (P /\ ~Q) \/ (~P /\ Q).
(**
%\noindent%

Prove the following equivalence lemma between to versions of [XOR]:

*)

Lemma XORequiv P Q: XOR P Q <-> XOR' P Q.
(* begin hide *)
Proof.
split.
- case; case=>[p|q] H.
  - by left; split=>// q; apply: H.
  by right; split=>// p; apply H.
case; case=>p q.
- split=>[| H]; first by left.
  by apply: q; case: H.
split; first by right.
by case=>/p.
Qed.
(* end hide *)

(**
%\noindent%
The final step is to use the equivalence we have just proved in order
to establish an alternative version of the reflective correspondence
of exclusive disjunction.

%\hint% Use the [Search] machinery to look for lemmas that might help
 to leverage the equivalence between two predicates and make the
 following proof to be a one-liner.

*)

(* Search _ (reflect _ _). *)
Lemma xorP' (b1 b2 : bool): reflect (XOR' b1 b2) (xorb b1 b2).
(* begin hide *)
Proof.
by apply: (equivP (xorP b1 b2) (XORequiv _ _)).
Qed.
(* end hide *)

(**

%\end{exercise}%

Unsurprisingly, every statement about exclusive or, e.g., its
commutativity and associativity, is extremely easy to prove when it is
considered as a boolean function.

*)

Lemma xorbC (b1 b2: bool) : (xorb b1 b2) = (xorb b2 b1).
Proof. by case: b1; case: b2. Qed.

Lemma xorbA (b1 b2 b3: bool) : (xorb (xorb b1 b2) b3) = (xorb b1 (xorb b2 b3)).
Proof. by case: b1; case: b2; case: b3=>//. Qed.

(**

It is also not difficult to prove the propositional counterparts of
the above lemmas for decidable propositions, reflected by them, hence
the following exercise.

%\begin{exercise}%

Prove the following specialized lemmas for decidable propositions
represented by booleans (without using the [intuition] tactic):

*)

Lemma xorCb (b1 b2: bool) : (XOR b1 b2) <-> (XOR b2 b1).
(* begin hide *)
Proof.
by split; move/xorP; rewrite xorbC; move/xorP.
Qed.
(* end hide *)

Lemma xorAb (b1 b2 b3: bool) : (XOR (XOR b1 b2) b3) <-> (XOR b1 (XOR b2 b3)).
(* begin hide *)
Proof.
split=>H.
apply: (xorP_gen b1 (xorb b2 b3) b1 (XOR b2 b3)); first by case: b1 {H}; constructor.
- by apply/xorP.
- rewrite -xorbA.
  apply/(xorP_gen (xorb b1 b2) b3 (XOR b1 b2) b3)=>//; first by apply/xorP.
  by case: b3 {H} =>//; constructor.
apply: (xorP_gen (xorb b1 b2) b3 (XOR b1 b2) b3).
- by apply/xorP.
- by case: b3 {H}; constructor.
rewrite xorbA.
apply/(xorP_gen b1 (xorb b2 b3) b1 (XOR b2 b3))=>//; last by apply/xorP.
by case: b1 {H} =>//; constructor.
Qed.
(* end hide *)

(**

%\hint% In the proof of [xorAb] the generalized reflection lemma
 [xorP_gen] might come in handy.

%\hint% A redundant assumption [H] in the context can be erased by
 typing [clear H] %\ttac{clear}% or [move => {H}]. The latter form can
 be combined with any bookkeeping sequence, not only with [move]
 tactics.

%\hint% The Coq's embedded tactic [intuition] can be helpful for
 automatically solving goals in propositional logic.%\ttac{intuition}%

%\end{exercise}%

** Reflecting decidable equalities
%\label{sec:eqrefl}%

Logical connectives are not the only class of inductive predicates
that is worth building a [reflect]-based rewriting principle for.
Another useful class of decidable propositions, which are often
reflected, are equalities.

Postponing the description of a generic mechanism for declaring
polymorphic decidable equalities until %Chapter~\ref{ch:depstruct}%,
let us see how switching between decidable [bool]-returning equality
[==] (defined in the Ssreflect's module [eqtype]%\ssrm{eqtype}%) and
the familiar propositional equality can be beneficial.

*)

Definition foo (x y: nat) := if x == y then 1 else 0.

(**

The function [foo] naturally uses the natural numbers' boolean
equality [==] in its body, as it is the only one that can be used in
the conditional operator. The next goal, though, assumes the
propositional equality of [x] and [y], which are passed to [foo] as
arguments.

*)

Goal forall x y, x = y -> foo x y = 1.
Proof.
move=>x y; rewrite /foo.

(**

[[
  x : nat
  y : nat
  ============================
   x = y -> (if x == y then 1 else 0) = 1
]]

The rewriting rule/view lemma [eqP], imported from [eqtype] allows us
to switch from propositional to boolean equality, which
makes the assumption to be [x == y]. Next, we combine the implicit
fact that [x == y] in the assumption of a proposition is in fact [(x
== y) = true] to perform in-place rewriting (see
%Section~\ref{sec:in-place}%) by means of the %\texttt{->}\ssrtl{->}%
tactical, so the rest of the proof is simply by computation.

*)

by move/eqP=>->.
Qed.

(**

%\begin{exercise}%

Sometimes, the statement ``there exists unique $x$ and $y$, such that
$P(x, y)$ holds'' is mistakingly formalized as $\exists ! x~\exists !
y~P(x, y)$. In fact, the latter assertion is much weaker than the
previous one. The goal of this exercise is to demonstrate this
formally.%\footnote{I am grateful to Vladimir Reshetnikov
(\href{https://twitter.com/vreshetnikov}{\texttt{@vreshetnikov}}) for
making this observation on Twitter.}%

First, prove the following lemma, stating that the first assertion can
be weakened from the second one.

*)

Lemma ExistsUnique1 A (P : A -> A -> Prop):
  (exists !x, exists y, P x y) ->
  (exists !x, exists y, P y x) ->
  (exists !x, exists !y, P x y).

(**

The notation [exists ! x, P x] is an abbreviation for the sigma-type,
whose second component is the higher-order predicate [unique], defined
as follows:

*)

Print unique.

(**
[[
unique =
fun (A : Type) (P : A -> Prop) (x : A) =>
P x /\ (forall x' : A, P x' -> x = x')
     : forall A : Type, (A -> Prop) -> A -> Prop
]]

As we can see, the definition [unique] not just ensures that [P x]
holds (the left conjunct), but also that any [x'] satisfying [P] is,
in fact, equal to [x]. As on the top level [unique] is merely a
conjunction, it can be decomposed by [case] and proved using the
[split] tactics.

*)

(* begin hide *)
Proof.
case=>x1[[y1 Pxy1]] G1[x2[[y2 Pxy2]] G2]; exists y2; split.
- by exists x2; split=>// x0 Pxy0; apply: G2; exists y2.
move=>x'. move:(G1 x')=>E G3.
rewrite -E; last by case: G3=>y'; case=> Z _; exists y'.
suff X: x1 = y2; first by [].
by apply: G1; exists x2.
Qed.
(* end hide *)

(**

Next, let us make sure that the statement in the conclusion of lemma
[ExistsUnique1], in fact, admits predicates, satisfied by non-uniquely
defined pair [(x, y)]. You goal is to prove that the following
predicate [Q], which obviously satisfied by [(true, true)], [(false,
true)] and [(false, false)] is nevertheless a subject of the second
statement.

*)

Definition Q x y : Prop :=
  (x == true) && (y == true) || (x == false).

Lemma qlm : (exists !x, exists !y, Q x y).

(* begin hide *)
Proof.
exists true; split; first by exists true; split=> //; case.
case=>//; rewrite /Q; case; case=>/=; case=>_ G.
- by move:(G false (eqxx false)).
by move:(G true (eqxx true)).
Qed.
(* end hide *)

(**

%\hint% The following lemma [eqxx], stating that the boolean equality
 [x == x] always holds, might be useful for instantiating arguments
 for hypotheses you will get during the proof.

*)

Check eqxx.

(**
[[
eqxx
     : forall (T : eqType) (x : T), x == x
]]

Finally, you are invited to prove that the second statement is
_strictly_ weaker than the first one by proving the following lemma,
which states that the reversed implication of the two statements for
an arbitrary predicate [P] implies falsehood.

*)

Lemma ExistsUnique2 :
  (forall A (P : A -> A -> Prop),
   (exists !x, exists !y, P x y) ->
   (exists !x, exists y, P x y) /\ (exists !x, exists y, P y x)) ->
  False.

(* begin hide *)
Proof.
move/(_ _ _ qlm); rewrite /Q/=; case=> H1 H2.
case: H1; case; case; case; case=> //= _.
- move=>G1; move:(G1 false)=>/=G2.
  by suff: true = false by []; last by apply: G2; exists true.
- move=>G1; move:(G1 true)=>/=G2.
  by suff: false = true by []; last by apply: G2; exists true.
- move=>G1; move:(G1 true)=>/=G2.
  by suff: false = true by []; last by apply: G2; exists true.
Qed.
(* end hide *)

(**
%\end{exercise}%
*)

(* begin hide *)
End BoolReflect.
(* end hide *)