(** * MoreStlc: More on the Simply Typed Lambda-Calculus *)

(* $Date: 2011-04-20 14:26:52 -0400 (Wed, 20 Apr 2011) $ *)

Require Export Stlc.
Require Import Relations.

(* ###################################################################### *)
(** * Simple Extensions to STLC *)

(** The simply typed lambda-calculus has enough structure to make its
    theoretical properties interesting, but it is not yet much of a
    programming language.  In this chapter, we begin to close the gap
    with real-world languages by introducing a number of familiar
    features that have straightforward treatments at the level of
    typing. *)

(** *** Numbers *)

(** Adding types, constants, and primitive operations for numbers is
    easy -- just a matter of combining the two halves of the [Stlc]
    chapter. *)

(** *** [let]-bindings *)

(** When writing a complex expression, it is often useful to give
    names to some of its subexpressions: this avoids repetition and
    often increases readability.  Most languages provide one or more
    ways of doing this.  In OCaml (and Coq), for example, we can write
    [let x=t1 in t2] to mean ``evaluate the expression [t1] and bind
    the name [x] to the resulting value while evaluating [t2].''

    Our [let]-binder follows OCaml's in choosing a call-by-value
    evaluation order, where the [let]-bound term must be fully
    evaluated before evaluation of the [let]-body can begin.  The
    typing rule [T_Let] tells us that the type of a [let] can be
    calculated by calculating the type of the [let]-bound term,
    extending the context with a binding with this type, and in this
    enriched context calculating the type of the body, which is then
    the type of the whole [let] expression.

    At this point in the course, it's probably easier simply to look
    at the rules defining this new feature as to wade through a lot of
    english text conveying the same information.  Here they are:

    Syntax:
<<
       t ::=                Terms
           | ...               (other terms same as before)
           | let x=t in t      let-binding
>>
    Reduction:
[[[
                                 t1 ==> t1'
                     ----------------------------------               (ST_Let1)
                     let x=t1 in t2 ==> let x=t1' in t2

                        ----------------------------              (ST_LetValue)
                        let x=v1 in t2 ==> [v1/x] t2
]]]
    Typing:
[[[
                Gamma |- t1 : T1      Gamma , x:T1 |- t2 : T2
                --------------------------------------------            (T_Let)
                        Gamma |- let x=t1 in t2 : T2
]]]
 *)

(** *** Pairs *)

(** Our functional programming examples have made frequent use of
    _pairs_ of values.  The type of such pairs is called a _product
    type_.

    The formalization of pairs is almost too simple to be worth
    discussing.  However, let's look briefly at the various parts of
    the definition to emphasize the common pattern.

    In Coq, the primitive way of extracting the components of a pair
    is _pattern matching_.  An alternative style is to take [fst] and
    [snd] -- the first- and second-projection operators -- as
    primitives.  Just for fun, let's do our products this way.  For
    example, here's how we'd write a function that takes a pair of
    numbers and returns the pair of their sum and difference:
<<
       \x:Nat*Nat.
          let sum = x.fst + x.snd in
          let diff = x.fst - x.snd in
          (sum,diff)
>>

    Adding pairs to the simply typed lambda-calculus, then, involves
    adding two new forms of term -- pairing, written [(t1,t2)], and
    projection, written [t.fst] for the first projection from [t] and
    [t.snd] for the second projection -- plus one new type constructor,
    [T1*T2], called the _product_ of [T1] and [T2].

    Syntax:
<<
       t ::=                Terms
           | ...
           | (t,t)             pair
           | t.fst             first projection
           | t.snd             second projection

       v ::=                Values
           | ...
           | (v,v)             pair value

       T ::=                Types
           | ...
           | T * T             product type
>>

   For evaluation, we need several new rules specifying how pairs and
   projection behave.
[[[
                              t1 ==> t1'
                         --------------------                        (ST_Pair1)
                         (t1,t2) ==> (t1',t2)

                              t2 ==> t2'
                         --------------------                        (ST_Pair2)
                         (v1,t2) ==> (v1,t2')

                              t1 ==> t1'
                          ------------------                          (ST_Fst1)
                          t1.fst ==> t1'.fst

                          ------------------                       (ST_FstPair)
                          (v1,v2).fst ==> v1

                              t1 ==> t1'
                          ------------------                          (ST_Snd1)
                          t1.snd ==> t1'.snd

                          ------------------                       (ST_SndPair)
                          (v1,v2).snd ==> v2
]]]
    Rules [ST_FstPair] and [ST_SndPair] specify that, when a fully
    evaluated pair meets a first or second projection, the result is
    the appropriate component.  The congruence rules [ST_Fst1] and
    [ST_Snd1] allow reduction to proceed under projections, when the
    term being projected from has not yet been fully evaluated.
    [ST_Pair1] and [ST_Pair2] evaluate the parts of pairs: first the
    left part, and then -- when a value appears on the left -- the right
    part.  The ordering arising from the use of the metavariables [v]
    and [t] in these rules enforces a left-to-right evaluation
    strategy for pairs.  (Note the implicit convention that
    metavariables like [v] and [v1] can only denote values.)  We've
    also added a clause to the definition of values, above, specifying
    that [(v1,v2)] is a value.  The fact that the components of a pair
    value must themselves be values ensures that a pair passed as an
    argument to a function will be fully evaluated before the function
    body starts executing.

   The typing rules for pairs and projections are straightforward.
[[[
               Gamma |- t1 : T1       Gamma |- t2 : T2
               ---------------------------------------                 (T_Pair)
                       Gamma |- (t1,t2) : T1*T2

                        Gamma |- t1 : T11*T12
                        ---------------------                           (T_Fst)
                        Gamma |- t1.fst : T11

                        Gamma |- t1 : T11*T12
                        ---------------------                           (T_Snd)
                        Gamma |- t1.snd : T12
]]]
   The rule [T_Pair] says that [(t1,t2)] has type [T1*T2] if [t1] has
   type [T1] and [t2] has type [T2].  Conversely, the rules [T_Fst]
   and [T_Snd] tell us that, if [t1] has a product type
   [T11*T12] (i.e., if it will evaluate to a pair), then the types of
   the projections from this pair are [T11] and [T12]. *)

(** *** Sums *)

(** Many programs need to deal with values that can take two distinct
   forms.  For example, we might identify employees in an accounting
   application using using _either_ their name _or_ their id number.
   A search function might return _either_ a matching value _or_ an
   error code.

   These are specific examples of a binary _sum type_,
   which describes a set of values drawn from exactly two given types, e.g.
<<
       Nat + Bool
>>
   We create elements of these types by _tagging_ elements of the
   component types.  For example, if [n] is a [Nat] then [inl v] is an
   element of [Nat+Bool]; similarly, if [b] is a [Bool] then [inr b]
   is a [Nat+Bool].  The names of the tags [inl] and [inr] arise from
   thinking of them as functions

<<
   inl : Nat -> Nat + Bool
   inr : Bool -> Nat + Bool
>>

   that "inject" elements of [Nat] or [Bool] into the left and right
   components of the sum type [Nat+Bool].  (But note that we don't
   actually treat them as functions in the way we formalize them:
   [inl] and [inr] are keywords, and [inl t] and [inr t] are primitive
   syntactic forms, not function applications.  This allows us to give
   them their own special typing rules.)

   In general, the elements of a type [T1 + T2] consist of the
   elements of [T1] tagged with the token [inl], plus the elements of
   [T2] tagged with [inr].

   To _use_ elements of sum types, we introduce a [case] construct (a
   very simplified form of Coq's [match]) to destruct them. For
   example, the following procedure converts a [Nat+Bool] into a
   [Nat]:

<<
    getNat =
      \x:Nat+Bool.
        case x of
          inl n => n
        | inr b => if b then 1 else 0
>>

    More formally...

    Syntax:
<<
       t ::=                Terms
           | ...
           | inl T t           tagging (left)
           | inr T t           tagging (right)
           | case t of         case
               inl x => t
             | inr x => t

       v ::=                Values
           | ...
           | inl T v           tagged value (left)
           | inr T v           tagged value (right)

       T ::=                Types
           | ...
           | T + T             sum type
>>

   Evaluation:

[[[
                              t1 ==> t1'
                        ----------------------                         (ST_Inl)
                        inl T t1 ==> inl T t1'

                              t1 ==> t1'
                        ----------------------                         (ST_Inr)
                        inr T t1 ==> inr T t1'

                              t0 ==> t0'
                   -------------------------------------------       (ST_Case)
                   case t0 of inl x1 => t1 | inr x2 => t2 ==>
                   case t0' of inl x1 => t1 | inr x2 => t2

            ----------------------------------------------         (ST_CaseInl)
            case (inl T v0) of inl x1 => t1 | inl x2 => t2
                           ==>  [v0/x1] t1

            ----------------------------------------------         (ST_CaseInr)
            case (inr T v0) of inl x1 => t1 | inl x2 => t2
                           ==>  [v0/x2] t2
]]]

Typing:
[[[
                          Gamma |- t1 :  T1
                     ----------------------------                       (T_Inl)
                     Gamma |- inl T2 t1 : T1 + T2

                           Gamma |- t1 : T2
                     ----------------------------                       (T_Inr)
                     Gamma |- inr T1 t1 : T1 + T2

                         Gamma |- t0 : T1+T2
                       Gamma , x1:T1 |- t1 : T
                       Gamma , x2:T2 |- t2 : T
         ---------------------------------------------------           (T_Case)
         Gamma |- case t0 of inl x1 => t1 | inr x2 => t2 : T
]]]

    The reason for the type annotation on the [inl] and [inr] forms
    has to do with uniqueness of types.  Without this extra
    information, the typinf rule [T_Inl], for example, would have to
    say that, once we have shown that [t1] is an element of type [T1],
    we can derive that [inl t1] is an element of [T1 + T2] for _any_
    type T2.  For example, we could derive both [inl 5 : Nat + Nat]
    and [inl 5 : Nat + Bool] (and infinitely many other types).
    This failure of uniqueness of types would mean that we cannot
    build a typechecking algorithm simply by "reading the rules from
    bottom to top" as we could for all the other features seen so far.

    There are various ways to deal with this difficulty.  One simple
    one -- which we've adopted here -- forces the programmer to
    explicitly annotate the "other side" of a sum type when performing
    an injection.  This is rather heavyweight for programmers (and so
    real languages adopt other solutions), but it is easy to
    understand and formalize. *)

(** *** Lists *)

(** The typing features we have seen can be classified into _base
    types_ like [Bool], and _type constructors_ like [->] and [*] that
    build new types from old ones.  Another useful type constructor is
    [List].  For every type [T], the type [List T] describes
    finite-length lists whose elements are drawn from [T].

    In principle, we could develop lists given facilities for defining
    variants and for defining _recursive_ types.  But we've skipped
    the details of the former, and giving semantics to the latter is
    non-trivial. Instead, we'll just discuss the special case of lists
    directly.

    Below we give the syntax, semantics, and typing rules for lists.
    Except for the fact that explicit type annotations are mandatory
    on [nil] and cannot appear on [cons], these lists are essentially
    identical to those we built in Coq.  We use [lcase] to destruct
    lists, to avoid dealing with questions like "what is the [head] of
    the empty list?"  So, for example, here is a function that
    calculates the sum of the first two elements of a list of numbers:

<<
    \x:List Nat.
    lcase x of nil -> 0
       | a::x' -> lcase x' of nil -> a
                     | b::x'' -> a+b
>>

    While we say that [cons v1 v2] is a value, we really mean that
    [v2] should also be a list -- we'll have to enforce this in the
    formal definition of value. *)

(**
    Syntax:
<<
       t ::=                Terms
           | ...
           | nil T
           | cons t t
           | lcase t of nil -> t | x::x -> t

       v ::=                Values
           | ...
           | nil T             nil value
           | cons v v          cons value

       T ::=                Types
           | ...
           | List T            list of Ts
>>
   Reduction:
[[[
                                 t1 ==> t1'
                       --------------------------                    (ST_Cons1)
                       cons t1 t2 ==> cons t1' t2

                                 t2 ==> t2'
                       --------------------------                    (ST_Cons2)
                       cons v1 t2 ==> cons v1 t2'

                              t1 ==> t1'
                ----------------------------------------             (ST_Lcase1)
                (lcase t1 of nil -> t2 | h::t -> t3) ==>
                (lcase t1' of nil -> t2 | h::t -> t3)

               ---------------------------------------            (ST_LcaseNil)
               (lcase nil T of nil -> t2 | h::t -> t3)
                                ==> t2

            ----------------------------------------------       (ST_LcaseCons)
            (lcase (cons vh vt) of nil -> t2 | h::t -> t3)
                          ==> [vh/h,vt/t]t3
]]]

   Typing:
[[[
                          -----------------------                       (T_Nil)
                          Gamma |- nil T : List T

                Gamma |- t1 : T      Gamma |- t2 : List T
                -----------------------------------------              (T_Cons)
                       Gamma |- cons t1 t2: List T

                        Gamma |- t1 : List T1
                           Gamma |- t2 : T
                   Gamma , h:T1, t:List T1 |- t3 : T
          -------------------------------------------------           (T_Lcase)
          Gamma |- (lcase t1 of nil -> t2 | h::t -> t3) : T
]]]
*)

(** *** General Recursion *)

(** Another facility found in most programming languages (including
    Coq) is the ability to define recursive functions.  For example,
    we might like to be able to define the factorial function like
    this:
<<
   fact = \x:Nat.
             if x=0 then 1 else x * (fact (pred x)))
>>
   But this would require quite a bit of work to formalize: we'd have
   to introduce a notion of "function definitions" and carry around an
   "environment" of such definitions in the definition of the [step]
   relation.

   Here is another way that is straightforward to formalize: instead
   of writing recursive definitions where the right-hand side can
   contain the identifier being defined, we can define a _fixed-point
   operator_ that performs the "unfolding" of the recursive definition
   in the right-hand side lazily during reduction.
<<
   fact =
       fix
         (\f:Nat->Nat.
            \x:Nat.
               if x=0 then 1 else x * (f (pred x)))
>>
   The intuition is that the higher-order function [f] passed to [fix]
   is a _generator_ for the [fact] function: if [fact] is applied to a
   function that approximates the desired behavior of [fact] up to
   some number [n] (that is, a function that returns correct results
   on inputs less than or equal to [n]), then it returns a better
   approximation to [fact] -- a function that returns correct results
   for inputs up to [n+1].  Applying [fix] to this generator returns
   its _fixed point_ -- a function that gives the desired behavior for
   all inputs [n].

   (The term "fixed point" has exactly the same sense as in ordinary
   mathematics, where a fixed point of a function [f] is an input [x]
   such that [f(x) = x].  Here, a fixed point of a function [F] of
   type (say) [(Nat->Nat)->(Nat->Nat)] is a function [f] such that [F
   f] is behaviorally equivalent to [f].)

   Syntax:
<<
       t ::=                Terms
           | ...
           | fix t             fixed-point operator
>>
   Reduction:
[[[
                                 t1 ==> t1'
                             ------------------                       (ST_Fix1)
                             fix t1 ==> fix t1'

                -------------------------------------------         (ST_FixAbs)
                fix (\x:T1.t2) ==> [(fix(\x:T1.t2)) / x] t2
]]]
   Typing:
[[[
                            Gamma |- t1 : T1->T1
                            --------------------                        (T_Fix)
                            Gamma |- fix t1 : T1
]]]
 *)

(** **** Exercise: 1 star (halve_fix) *)
(** Translate this recursive definition into one using [fix]:
<<
   halve =
     \x:Nat.
        if x=0 then 0
        else if (pred x)=0 then 0
        else 1 + (halve (pred (pred x))))
>>
(* FILL IN HERE *)
[]
*)

(** **** Exercise: 1 star, recommended (fact_steps) *)
(** Write down the sequence of steps that the term [fact 1] goes
    through to reduce to a normal form (assuming the usual reduction
    rules for arithmetic operations).

    (* FILL IN HERE *)
[]
*)

(** The ability to form the fixed point of a function of type [T->T]
    for any [T] has some surprising consequences.  In particular, it
    implies that _every_ type is inhabited by some term.  To see this,
    observe that, for every type [T], we can define the term
[[
    fix (\x:T.x)
]]
    By [T_Fix]  and [T_Abs], this term has type [T].  By [ST_FixAbs]
    it reduces to itself, over and over again.  Thus it is an
    _undefined element_ of [T].

    More usefully, here's an example using [fix] to define a
    two-argument recursive function:
<<
    equal =
      fix
        (\eq:Nat->Nat->Bool.
           \m:Nat. \n:Nat.
             if m=0 then iszero n
             else if n=0 then false
             else eq (pred m) (pred n))
>>

    And finally, here is an example where [fix] is used to define a
    _pair_ of recursive functions (illustrating the fact that the type
    [T1] in the rule [T_Fix] need not be a function type):
<<
    evenodd =
      fix
        (\eo: (Nat->Bool * Nat->Bool).
           let e = \n:Nat. if n=0 then true  else eo.snd (pred n) in
           let o = \n:Nat. if n=0 then false else eo.fst (pred n) in
           (e,o))

    even = evenodd.fst
    odd  = evenodd.snd
>>

*)

(* ###################################################################### *)
(** ** Records and Variants (Optional) *)

(** As a final example of a basic extension of the STLC, let's look
    briefly at how to formalize _records_ and their types.  This
    extension is conceptually a straightforward generalization of
    pairs and product types, but notationally it becomes a little
    heavier; for this reason, we postpone its formal treatment to a
    separate chapter ([Records]).

    This material is not included in the extended exercise below.  It
    can be skipped or skimmed, if desired. *)

(* ################################# *)
(** *** The [Unit] Type *)

(** Another handy base type, found especially in languages in the ML
    family, is the singleton type [Unit].  It has a single element --
    the term constant [unit] (with a small [u]) -- and a typing rule
    making [unit] an element of [Unit].  We also add [unit] to the set
    of possible result values of computations -- indeed, [unit] is the
    _only_ possible result of evaluating an expression of type [Unit].

Syntax:
<<
       t ::=                Terms
           | ...
           | unit              unit value

       v ::=                Values
           | ...
           | unit              unit

       T ::=                Types
           | ...
           | Unit              Unit type
>>
    Typing:
[[[
                         --------------------                          (T_Unit)
                         Gamma |- unit : Unit
]]]

    It may seem a little strange to bother defining a type that has
    just one element -- after all, wouldn't every computation living
    in such a type be trivial?

    This is a fair question, and indeed in the STLC the [Unit] type is
    not especially critical (though we'll see one use for it a bit
    below).  Where [Unit] really comes in handy is in richer languages
    with various sorts of _side effects_ -- e.g., assignment
    statements that mutate variables or pointers, exceptions and other
    sorts of nonlocal control structures, etc.  In such languages, it
    is convenient to have a type for the (trivial) result of an
    expression that is evaluated only for its effect. *)

(* ###################################################################### *)
(** *** Records *)

(** Another familiar structure from everyday programming languages is
    _records_.  Intuitively, records can be obtained from pairs by two
    kinds of generalization:   they are n-ary products (rather than just binary)
    and their fields are accessed by _label_ (rather than position).

    Syntax:
<<
       t ::=                          Terms
           | ...
           | {i1=t1, ..., in=tn}         record
           | t.i                         projection

       v ::=                          Values
           | ...
           | {i1=v1, ..., in=vn}         record value

       T ::=                          Types
           | ...
           | {i1:T1, ..., in:Tn}         record type
>>
   Intuitively, the generalization is pretty obvious.  But it's worth
   noticing that what we've actually written is rather informal: in
   particular, we've written "[...]" in several places to mean "any
   number of these," and we've omitted explicit mention of the usual
   side-condition that the labels of a record should not contain
   repetitions.  It is possible to devise informal notations that are
   more precise, but these tend to be quite heavy and to obscure the
   main points of the definitions.  So we'll leave these a bit loose
   here (they are informal anyway, after all) and do the work of
   tightening things up elsewhere (in [Records.v]).

   Reduction:
[[[
                              ti ==> ti'
                 ------------------------------------                  (ST_Rcd)
                     {i1=v1, ..., im=vm, in=ti, ...}
                 ==> {i1=v1, ..., im=vm, in=ti', ...}

                              t1 ==> t1'
                            --------------                           (ST_Proj1)
                            t1.i ==> t1'.i

                      -------------------------                    (ST_ProjRcd)
                      {..., i=vi, ...}.i ==> vi
]]]
   Again, these rules are a bit informal.  For example, the first rule
   is intended to be read "if [ti] is the leftmost field that is not a
   value and if [ti] steps to [ti'], then the whole record steps..."
   In the last rule, the intention is that there should only be one
   field called i, and that all the other fields must contain values.

   Typing:
[[[
            Gamma |- t1 : T1     ...     Gamma |- tn : Tn
          --------------------------------------------------            (T_Rcd)
          Gamma |- {i1=t1, ..., in=tn} : {i1:T1, ..., in:Tn}

                    Gamma |- t : {..., i:Ti, ...}
                    -----------------------------                      (T_Proj)
                          Gamma |- t.i : Ti
]]]

*)

(* ###################################################################### *)
(** *** Encoding Records *)

(** There are several ways to make the above definitions precise.

      - We can directly formalize the syntactic forms and inference
        rules, staying as close as possible to the form we've given
        them above.  This is conceptually straightforward, and it's
        probably what we'd want to do if we were building a real
        compiler -- in particular, it will allow is to print error
        messages in the form that programmers will find easy to
        understand.  But the formal versions of the rules will not be
        pretty at all!

      - We could look for a smoother way of presenting records -- for
        example, a binary presentation with one constructor for the
        empty record and another constructor for adding a single field
        to an existing record, instead of a single monolithic
        constructor that builds a whole record at once.  This is the
        right way to go if we are primarily interested in studying the
        metatheory of the calculi with records, since it leads to
        clean and elegant definitions and proofs.  The file [Records.v]
        shows how this can be done.

      - Alternatively, if we like, we can avoid formalizing records
        altogether, by stipulating that record notations are just
        informal shorthands for more complex expressions involving
        pairs and product types.  We sketch this approach here.

    First, observe that we can encode arbitrary-size tuples using
    nested pairs and the [unit] value.  To avoid overloading the pair
    notation [(t1,t2)], we'll use curly braces without labels to write
    down tuples, so [{}] is the empty tuple, [{5}] is a singleton
    tuple, [{5,6}] is a 2-tuple (morally the same as a pair),
    [{5,6,7}] is a triple, etc.
<<
    {}                 ---->  unit
    {t1, t2, ..., tn}  ---->  (t1, trest)
                              where {t2, ..., tn} ----> trest
>>
    Similarly, we can encode tuple types using nested product types:
<<
    {}                 ---->  Unit
    {T1, T2, ..., Tn}  ---->  T1 * TRest
                              where {T2, ..., Tn} ----> TRest
>>
    The operation of projecting a field from a tuple can be encoded
    using a sequence of second projections followed by a first projection:
<<
    t.0        ---->  t.fst
    t.(n+1)    ---->  (t.snd).n
>>

    Next, suppose that there is some total ordering on record labels,
    so that we can associate each label with a unique natural number.
    This number is called the _position_ of the label.  For example,
    we might assign positions like this:
<<
      LABEL   POSITION
      a       0
      b       1
      c       2
      ...     ...
      foo     1004
      ...     ...
      bar     10562
      ...     ...
>>

    We use these positions to encode record values as tuples (i.e., as
    nested pairs) by sorting the fields according to their positions.
    For example:
<<
      {a=5, b=6}      ---->   {5,6}
      {a=5, c=7}      ---->   {5,unit,7}
      {c=7, a=5}      ---->   {5,unit,7}
      {c=5, b=3}      ---->   {unit,3,5}
      {f=8,c=5,a=7}   ---->   {7,unit,5,unit,unit,8}
      {f=8,c=5}       ---->   {unit,unit,5,unit,unit,8}
>>
    Note that each field appears in the position associated with its
    label, that the size of the tuple is determined by the label with
    the highest position, and that we fill in unused positions with
    [unit].

    We do exactly the same thing with record types:
<<
      {a:Nat, b:Nat}      ---->   {Nat,Nat}
      {c:Nat, a:Nat}      ---->   {Nat,Unit,Nat}
      {f:Nat,c:Nat}       ---->   {Unit,Unit,Nat,Unit,Unit,Nat}
>>

    Finally, record projection is encoded as a tuple projection from
    the appropriate position:
<<
      t.l  ---->  t.(position of l)
>>

    It is not hard to check that all the typing rules for the original
    "direct" presentation of records are validated by this
    encoding.  (The reduction rules are "almost validated" -- not
    quite, because the encoding reorders fields.) *)

(** Of course, this encoding will not be very efficient if we
    happen to use a record with label [bar]!  But things are not
    actually as bad as they might seem: for example, if we assume that
    our compiler can see the whole program at the same time, we can
    _choose_ the numbering of labels so that we assign small positions
    to the most frequently used labels.  Indeed, there are industrial
    compilers that essentially do this! *)

(** *** Variants *)

(** Just as products can be generalized to records, sums can be
    generalized to n-ary labeled types called _variants_.  Instead of
    [T1+T2], we can write something like [<l1:T1,l2:T2,...ln:Tn>]
    where [l1],[l2],... are field labels which are used both to build
    instances and as case arm labels.

    These n-ary variants give us almost enough mechanism to build
    arbitrary inductive data types like lists and trees from
    scratch -- the only thing missing is a way to allow _recursion_ in
    type definitions.  We won't cover this here, but detailed
    treatments can be found in many textbooks -- e.g., Types and
    Programming Languages. *)

(* ###################################################################### *)
(** * Formalizing the Extensions *)

(** **** Exercise: 4 stars, recommended (STLC_extensions) *)
(** Formalizing the extensions (not including the optional ones) is
    left to you.  We've provided the necessary extensions to the
    syntax of terms and types, and we've included a few examples that
    you can test your definitions with to make sure they are working
    as expected.  You'll fill in the rest of the definitions and
    extend all the proofs accordingly.

    A good strategy is to work on the extensions one at a time, in
    multiple passes, rather than trying to work through the file from
    start to finish in a single pass.  For each definition or proof,
    begin by reading carefully through the parts that are provided for
    you, referring to the text in the [Stlc] chapter for high-level
    intuitions and the embedded comments for detailed mechanics.

    A good order for attempting the extensions is:
      - numbers first (since they are both familiar and simple)
      - products
      - let (which involves binding)
      - sums (which involve slightly more complex binding)
      - lists (which involve yet more complex binding)
      - [fix] *)

Module STLCExtended.

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

Inductive ty : Type :=
  | ty_arrow : ty -> ty -> ty
  | ty_prod  : ty -> ty -> ty
  | ty_sum   : ty -> ty -> ty
  | ty_List  : ty -> ty
  | ty_Nat   : ty.

Tactic Notation "ty_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ty_arrow"
  | Case_aux c "ty_prod" | Case_aux c "ty_sum"
  | Case_aux c "ty_List" | Case_aux c "ty_Nat" ].

Inductive tm : Type :=
  (* pure STLC *)
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
  (* pairs *)
  | tm_pair : tm -> tm -> tm
  | tm_fst : tm -> tm
  | tm_snd : tm -> tm
  (* sums *)
  | tm_inl : ty -> tm -> tm
  | tm_inr : ty -> tm -> tm
  | tm_case : tm -> id -> tm -> id -> tm -> tm
          (* i.e., [case t0 of inl x1 => t1 | inr x2 => t2] *)
  (* lists *)
  | tm_nil : ty -> tm
  | tm_cons : tm -> tm -> tm
  | tm_lcase : tm -> tm -> id -> id -> tm -> tm
          (* i.e., [lcase t1 of | nil -> t2 | x::y -> t3] *)
  (* numbers *)
  | tm_nat : nat -> tm
  | tm_succ : tm -> tm
  | tm_pred : tm -> tm
  | tm_mult : tm -> tm -> tm
  | tm_if0  : tm -> tm -> tm -> tm
  (* let *)
  | tm_let : id -> tm -> tm -> tm
          (* i.e., [let x = t1 in t2] *)
  (* fix *)
  | tm_fix  : tm -> tm.

(** Note that, for brevity, we've omitted booleans and instead
    provided a single [if0] form combining a zero test and a
    conditional.  That is, instead of writing
<<
       if x = 0 then ... else ...
>>
    we'll write this:
<<
       if0 x then ... else ...
>>
*)

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_pair" | Case_aux c "tm_fst" | Case_aux c "tm_snd"
  | Case_aux c "tm_inl" | Case_aux c "tm_inr" | Case_aux c "tm_case"
  | Case_aux c "tm_nil" | Case_aux c "tm_cons" | Case_aux c "tm_lcase"
  | Case_aux c "tm_nat" | Case_aux c "tm_succ" | Case_aux c "tm_pred"
  | Case_aux c "tm_mult" | Case_aux c "tm_if0"
  | Case_aux c "tm_let" | Case_aux c "tm_fix" ].

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

Fixpoint subst (x:id) (s:tm) (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 x s t1))
  | tm_app t1 t2 =>
      tm_app (subst x s t1) (subst x s t2)
  (* FILL IN HERE *)
  | _ => t  (* ... and delete this line *)
  end.

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

(** Next we define the values of our language. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tm_abs x T11 t12)
  (* FILL IN HERE *)
  .

Hint Constructors value.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tm_app (tm_abs x T11 t12) v2) ==> (subst x v2 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')
  (* FILL IN HERE *)

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"
    (* FILL IN HERE *)
  ].

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

Hint Constructors step.

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

Definition context := partial_map ty.

(** Next we define the typing rules.  These are nearly direct
    transcriptions of the inference rules shown above. *)

Inductive has_type : context -> tm -> ty -> Prop :=
  (* Typing rules for proper terms *)
  | 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
  (* FILL IN HERE *)
  .

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"
    (* FILL IN HERE *)
].

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

(** This section presents formalized versions of the examples from
    above (plus several more).  The ones at the beginning focus on
    specific features; you can use these to make sure your definition
    of a given feature is reasonable before moving on to extending the
    proofs later in the file with the cases relating to this feature.
    The later examples require all the features together, so you'll
    need to come back to these when you've got all the definitions
    filled in. *)

Module Examples.

(** *** Preliminaries *)

(** First, let's define a few variable names: *)

Notation a := (Id 0).
Notation f := (Id 1).
Notation g := (Id 2).
Notation l := (Id 3).
Notation k := (Id 6).
Notation i1 := (Id 7).
Notation i2 := (Id 8).
Notation x := (Id 9).
Notation y := (Id 10).
Notation processSum := (Id 11).
Notation n := (Id 12).
Notation eq := (Id 13).
Notation m := (Id 14).
Notation evenodd := (Id 15).
Notation even := (Id 16).
Notation odd := (Id 17).
Notation eo := (Id 18).

(** Next, a bit of Coq hackery to automate searching for typing
    derivations.  You don't need to understand this bit in detail --
    just have a look over it so that you'll know what to look for if
    you ever find yourself needing to make custom extensions to
    [auto].

    The following [Hint] declarations say that, whenever [auto]
    arrives at a goal of the form [(has_type G (tm_app e1 e1) T)], it
    should consider [eapply T_App], leaving an existential variable
    for the middle type T1, and similar for [lcase]. That variable
    will then be filled in during the search for type derivations for
    [e1] and [e2].  We also include a hint to "try harder" when
    solving equality goals; this is useful to automate uses of
    [T_Var] (which includes an equality as a precondition). *)

Hint Extern 2 (has_type _ (tm_app _ _) _) =>
  eapply T_App; auto.
(* You'll want to uncomment the following line once
   you've defined the [T_Lcase] constructor for the typing
   relation: *)
(*
Hint Extern 2 (has_type _ (tm_lcase _ _ _ _ _) _) =>
  eapply T_Lcase; auto.
*)
Hint Extern 2 (_ = _) => compute; reflexivity.

(** *** Numbers *)

Module Numtest.

(* if0 (pred (succ (pred (2 * 0))) then 5 else 6 *)
Definition test :=
  tm_if0
    (tm_pred
      (tm_succ
        (tm_pred
          (tm_mult
            (tm_nat 2)
            (tm_nat 0)))))
    (tm_nat 5)
    (tm_nat 6).

(** Remove the comment braces once you've implemented enough of the
    definitions that you think this should work. *)

(*
Example typechecks :
  has_type (@empty ty) test ty_Nat.
Proof.
  unfold test.
  (* This typing derivation is quite deep, so we need to increase the
     max search depth of [auto] from the default 5 to 10. *)
  auto 10.
Qed.

Example numtest_reduces :
  test ==>* tm_nat 5.
Proof.
  unfold test. normalize.
Qed.
*)

End Numtest.

(** *** Products *)

Module Prodtest.

(* ((5,6),7).fst.snd *)
Definition test :=
  tm_snd
    (tm_fst
      (tm_pair
        (tm_pair
          (tm_nat 5)
          (tm_nat 6))
        (tm_nat 7))).

(*
Example typechecks :
  has_type (@empty ty) test ty_Nat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test ==>* tm_nat 6.
Proof. unfold test. normalize. Qed.
*)

End Prodtest.

(** *** [let] *)

Module LetTest.

(* let x = pred 6 in succ x *)
Definition test :=
  tm_let
    x
    (tm_pred (tm_nat 6))
    (tm_succ (tm_var x)).

(*
Example typechecks :
  has_type (@empty ty) test ty_Nat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test ==>* tm_nat 6.
Proof. unfold test. normalize. Qed.
*)

End LetTest.

(** *** Sums *)

Module Sumtest1.

(* case (inl Nat 5) of
     inl x => x
   | inr y => y *)

Definition test :=
  tm_case (tm_inl ty_Nat (tm_nat 5))
    x (tm_var x)
    y (tm_var y).

(*
Example typechecks :
  has_type (@empty ty) test ty_Nat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test ==>* (tm_nat 5).
Proof. unfold test. normalize. Qed.
*)

End Sumtest1.

Module Sumtest2.

(* let processSum =
     \x:Nat+Nat.
        case x of
          inl n => n
          inr n => if0 n then 1 else 0 in
   (processSum (inl Nat 5), processSum (inr Nat 5))    *)

Definition test :=
  tm_let
    processSum
    (tm_abs x (ty_sum ty_Nat ty_Nat)
      (tm_case (tm_var x)
         n (tm_var n)
         n (tm_if0 (tm_var n) (tm_nat 1) (tm_nat 0))))
    (tm_pair
      (tm_app (tm_var processSum) (tm_inl ty_Nat (tm_nat 5)))
      (tm_app (tm_var processSum) (tm_inr ty_Nat (tm_nat 5)))).

(*
Example typechecks :
  has_type (@empty ty) test (ty_prod ty_Nat ty_Nat).
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test ==>* (tm_pair (tm_nat 5) (tm_nat 0)).
Proof. unfold test. normalize. Qed.
*)

End Sumtest2.

(** *** Lists *)

Module ListTest.

(* let l = cons 5 (cons 6 (nil Nat)) in
   lcase l of
     nil => 0
   | x::y => x*x *)

Definition test :=
  tm_let l
    (tm_cons (tm_nat 5) (tm_cons (tm_nat 6) (tm_nil ty_Nat)))
    (tm_lcase (tm_var l)
       (tm_nat 0)
       x y (tm_mult (tm_var x) (tm_var x))).

(*
Example typechecks :
  has_type (@empty ty) test ty_Nat.
Proof. unfold test. eauto 20. Qed.

Example reduces :
  test ==>* (tm_nat 25).
Proof. unfold test. normalize. Qed.
*)

End ListTest.

(** *** [fix] *)

Module FixTest1.

(* fact := fix
             (\f:nat->nat.
                \a:nat.
                   if a=0 then 1 else a * (f (pred a))) *)
Definition fact :=
  tm_fix
    (tm_abs f (ty_arrow ty_Nat ty_Nat)
      (tm_abs a ty_Nat
        (tm_if0
           (tm_var a)
           (tm_nat 1)
           (tm_mult
              (tm_var a)
              (tm_app (tm_var f) (tm_pred (tm_var a))))))).

(** (Warning: you may be able to typecheck [fact] but still have some
    rules wrong!) *)

(*
Example fact_typechecks :
  has_type (@empty ty) fact (ty_arrow ty_Nat ty_Nat).
Proof. unfold fact. auto 10.
Qed.
*)

(*
Example fact_example:
  (tm_app fact (tm_nat 4)) ==>* (tm_nat 24).
Proof. unfold fact. normalize. Qed.
*)

End FixTest1.

Module FixTest2.

(* map :=
     \g:nat->nat.
       fix
         (\f:[nat]->[nat].
            \l:[nat].
               case l of
               | [] -> []
               | x::l -> (g x)::(f l)) *)
Definition map :=
  tm_abs g (ty_arrow ty_Nat ty_Nat)
    (tm_fix
      (tm_abs f (ty_arrow (ty_List ty_Nat) (ty_List ty_Nat))
        (tm_abs l (ty_List ty_Nat)
          (tm_lcase (tm_var l)
            (tm_nil ty_Nat)
            a l (tm_cons (tm_app (tm_var g) (tm_var a))
                         (tm_app (tm_var f) (tm_var l))))))).

(*
(* Make sure you've uncommented the last [Hint Extern] above... *)
Example map_typechecks :
  has_type empty map
    (ty_arrow (ty_arrow ty_Nat ty_Nat)
      (ty_arrow (ty_List ty_Nat)
        (ty_List ty_Nat))).
Proof. unfold map. auto 10. Qed.

Example map_example :
  tm_app (tm_app map (tm_abs a ty_Nat (tm_succ (tm_var a))))
         (tm_cons (tm_nat 1) (tm_cons (tm_nat 2) (tm_nil ty_Nat)))
  ==>* (tm_cons (tm_nat 2) (tm_cons (tm_nat 3) (tm_nil ty_Nat))).
Proof. unfold map. normalize. Qed.
*)

End FixTest2.

Module FixTest3.

(* equal =
      fix
        (\eq:Nat->Nat->Bool.
           \m:Nat. \n:Nat.
             if0 m then (if0 n then 1 else 0)
             else if0 n then 0
             else eq (pred m) (pred n))   *)

Definition equal :=
  tm_fix
    (tm_abs eq (ty_arrow ty_Nat (ty_arrow ty_Nat ty_Nat))
      (tm_abs m ty_Nat
        (tm_abs n ty_Nat
          (tm_if0 (tm_var m)
            (tm_if0 (tm_var n) (tm_nat 1) (tm_nat 0))
            (tm_if0 (tm_var n)
              (tm_nat 0)
              (tm_app (tm_app (tm_var eq)
                              (tm_pred (tm_var m)))
                      (tm_pred (tm_var n)))))))).

(*
Example equal_typechecks :
  has_type (@empty ty) equal (ty_arrow ty_Nat (ty_arrow ty_Nat ty_Nat)).
Proof. unfold equal. auto 10.
Qed.
*)

(*
Example equal_example1:
  (tm_app (tm_app equal (tm_nat 4)) (tm_nat 4)) ==>* (tm_nat 1).
Proof. unfold equal. normalize. Qed.
*)

(*
Example equal_example2:
  (tm_app (tm_app equal (tm_nat 4)) (tm_nat 5)) ==>* (tm_nat 0).
Proof. unfold equal. normalize. Qed.
*)

End FixTest3.

Module FixTest4.

(* let evenodd =
         fix
           (\eo: (Nat->Nat * Nat->Nat).
              let e = \n:Nat. if0 n then 1 else eo.snd (pred n) in
              let o = \n:Nat. if0 n then 0 else eo.fst (pred n) in
              (e,o)) in
    let even = evenodd.fst in
    let odd  = evenodd.snd in
    (even 3, even 4)
*)

Definition eotest :=
  tm_let evenodd
    (tm_fix
      (tm_abs eo (ty_prod (ty_arrow ty_Nat ty_Nat) (ty_arrow ty_Nat ty_Nat))
        (tm_pair
          (tm_abs n ty_Nat
            (tm_if0 (tm_var n)
              (tm_nat 1)
              (tm_app (tm_snd (tm_var eo)) (tm_pred (tm_var n)))))
          (tm_abs n ty_Nat
            (tm_if0 (tm_var n)
              (tm_nat 0)
              (tm_app (tm_fst (tm_var eo)) (tm_pred (tm_var n))))))))
  (tm_let even (tm_fst (tm_var evenodd))
  (tm_let odd (tm_snd (tm_var evenodd))
  (tm_pair
    (tm_app (tm_var even) (tm_nat 3))
    (tm_app (tm_var even) (tm_nat 4))))).

(*
Example eotest_typechecks :
  has_type (@empty ty) eotest (ty_prod ty_Nat ty_Nat).
Proof. unfold eotest. eauto 30.
Qed.
*)

(*
Example eotest_example1:
  eotest ==>* (tm_pair (tm_nat 0) (tm_nat 1)).
Proof. unfold eotest. normalize. Qed.
*)

End FixTest4.

End Examples.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** The proofs of progress and preservation for this system are
    essentially the same (though of course somewhat longer) as for the
    pure simply typed lambda-calculus. *)

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

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  (* Theorem: Suppose empty |- t : T.  Then either
       1. t is a value, or
       2. t ==> t' for some t'.
     Proof: By induction on the given typing derivation. *)
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  has_type_cases (induction Ht) Case; intros HeqGamma; subst.
  Case "T_Var".
    (* The final rule in the given typing derivation cannot be [T_Var],
       since it can never be the case that [empty |- x : T] (since the
       context is empty). *)
    inversion H.
  Case "T_Abs".
    (* If the [T_Abs] rule was the last used, then [t = tm_abs x T11 t12],
       which is a value. *)
    left...
  Case "T_App".
    (* If the last rule applied was T_App, then [t = t1 t2], and we know
       from the form of the rule that
         [empty |- t1 : T1 -> T2]
         [empty |- t2 : T1]
       By the induction hypothesis, each of t1 and t2 either is a value
       or can take a step. *)
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
      (* If both [t1] and [t2] are values, then we know that
         [t1 = tm_abs x T11 t12], since abstractions are the only values
         that can have an arrow type.  But
         [(tm_abs x T11 t12) t2 ==> subst x t2 t12] by [ST_AppAbs]. *)
        inversion H; subst; try (solve by inversion).
        exists (subst x t2 t12)...
      SSCase "t2 steps".
        (* If [t1] is a value and [t2 ==> t2'], then [t1 t2 ==> t1 t2']
           by [ST_App2]. *)
        destruct H0 as [t2' Hstp]. exists (tm_app t1 t2')...
    SCase "t1 steps".
      (* Finally, If [t1 ==> t1'], then [t1 t2 ==> t1' t2] by [ST_App1]. *)
      destruct H as [t1' Hstp]. exists (tm_app t1' t2)...
  (* FILL IN HERE *)
Qed.

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

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

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 y Hafi.
    unfold extend. remember (beq_id x y) as e.
    destruct e...
  (* FILL IN HERE *)
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; inversion Hafi; subst...
  Case "T_Abs".
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold extend in Hctx.
    apply not_eq_beq_id_false in H2. rewrite H2 in Hctx...
  (* FILL IN HERE *)
Qed.

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

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 x v t) S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- (subst x v t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow directly
     from the IH, with the exception of tm_var and tm_abs.
     The former aren't automatic because we must reason about how the
     variables interact. *)
  tm_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tm_var".
    simpl. rename i into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [extend Gamma x U y = Some S].  We want to
       show that [Gamma |- subst x v y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then we know that [U = S], and that [subst x v y = v].
       So what we really must show is that if [empty |- v : U] then
       [Gamma |- v : U].  We have already proven a more general version
       of this theorem, called context invariance. *)
      apply beq_id_eq in Heqe. subst.
      unfold extend in H1. rewrite <- beq_id_refl in H1.
      inversion H1; subst. clear H1.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
    (* If [x <> y], then [Gamma y = Some S] and the substitution has no
       effect.  We can show that [Gamma |- y : S] by [T_Var]. *)
      apply T_Var... unfold extend in H1. rewrite <- Heqe in H1...
  Case "tm_abs".
    rename i into y. rename t into T11.
    (* If [t = tm_abs y T11 t0], then we know that
         [Gamma,x:U |- tm_abs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- subst x v t0 S].

       We can calculate that
         subst x v t = tm_abs y T11 (if beq_id x y
                                      then t0
                                      else subst x v t0)
       And we must show that [Gamma |- subst x v t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_id x y then t0 else subst x v t0 : T12]
       We consider two cases: [x = y] and [x <> y].
    *)
    apply T_Abs...
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then the substitution has no effect.  Context
       invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
       equivalent.  Since the former context shows that [t0 : T12], so
       does the latter. *)
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
    (* If [x <> y], then the IH and context invariance allow us to show that
         [Gamma,x:U,y:T11 |- t0 : T12]       =>
         [Gamma,y:T11,x:U |- t0 : T12]       =>
         [Gamma,y:T11 |- subst x v t0 : T12] *)
      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...
  (* FILL IN HERE *)
Qed.

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.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then [empty |- t' : T]. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.  Many cases are
     contradictory ([T_Var], [T_Abs]).  We show just the interesting ones. *)
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    (* If the last rule used was [T_App], then [t = t1 t2], and three rules
       could have been used to show [t ==> t']: [ST_App1], [ST_App2], and
       [ST_AppAbs]. In the first two cases, the result follows directly from
       the IH. *)
    inversion HE; subst...
    SCase "ST_AppAbs".
      (* For the third case, suppose
           [t1 = tm_abs x T11 t12]
         and
           [t2 = v2].
         We must show that [empty |- subst x v2 t12 : T2].
         We know by assumption that
             [empty |- tm_abs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  (* FILL IN HERE *)
Qed.
(** [] *)

End STLCExtended.


From Hammer Require Import Hammer.

Require Import Bool OrderedType ZArith OrderedType OrderedTypeEx FMapInterface.

Set Implicit Arguments.
Local Open Scope positive_scope.
Local Unset Elimination Schemes.

Fixpoint append (i j : positive) : positive :=
match i with
| xH => j
| xI ii => xI (append ii j)
| xO ii => xO (append ii j)
end.

Lemma append_assoc_0 :
forall (i j : positive), append i (xO j) = append (append i (xO xH)) j.
Proof. hammer_hook "FMapPositive" "FMapPositive.append_assoc_0".
induction i; intros; destruct j; simpl;
try rewrite (IHi (xI j));
try rewrite (IHi (xO j));
try rewrite <- (IHi xH);
auto.
Qed.

Lemma append_assoc_1 :
forall (i j : positive), append i (xI j) = append (append i (xI xH)) j.
Proof. hammer_hook "FMapPositive" "FMapPositive.append_assoc_1".
induction i; intros; destruct j; simpl;
try rewrite (IHi (xI j));
try rewrite (IHi (xO j));
try rewrite <- (IHi xH);
auto.
Qed.

Lemma append_neutral_r : forall (i : positive), append i xH = i.
Proof. hammer_hook "FMapPositive" "FMapPositive.append_neutral_r".
induction i; simpl; congruence.
Qed.

Lemma append_neutral_l : forall (i : positive), append xH i = i.
Proof. hammer_hook "FMapPositive" "FMapPositive.append_neutral_l".
simpl; auto.
Qed.

Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.

Module E:=PositiveOrderedTypeBits.
Module ME:=KeyOrderedType E.

Definition key := positive : Type.

Inductive tree (A : Type) :=
| Leaf : tree A
| Node : tree A -> option A -> tree A -> tree A.

Scheme tree_ind := Induction for tree Sort Prop.

Definition t := tree.

Section A.
Variable A:Type.

Arguments Leaf {A}.

Definition empty : t A := Leaf.

Fixpoint is_empty (m : t A) : bool :=
match m with
| Leaf => true
| Node l None r => (is_empty l) && (is_empty r)
| _ => false
end.

Fixpoint find (i : key) (m : t A) : option A :=
match m with
| Leaf => None
| Node l o r =>
match i with
| xH => o
| xO ii => find ii l
| xI ii => find ii r
end
end.

Fixpoint mem (i : key) (m : t A) : bool :=
match m with
| Leaf => false
| Node l o r =>
match i with
| xH => match o with None => false | _ => true end
| xO ii => mem ii l
| xI ii => mem ii r
end
end.

Fixpoint add (i : key) (v : A) (m : t A) : t A :=
match m with
| Leaf =>
match i with
| xH => Node Leaf (Some v) Leaf
| xO ii => Node (add ii v Leaf) None Leaf
| xI ii => Node Leaf None (add ii v Leaf)
end
| Node l o r =>
match i with
| xH => Node l (Some v) r
| xO ii => Node (add ii v l) o r
| xI ii => Node l o (add ii v r)
end
end.

Fixpoint remove (i : key) (m : t A) : t A :=
match i with
| xH =>
match m with
| Leaf => Leaf
| Node Leaf o Leaf => Leaf
| Node l o r => Node l None r
end
| xO ii =>
match m with
| Leaf => Leaf
| Node l None Leaf =>
match remove ii l with
| Leaf => Leaf
| mm => Node mm None Leaf
end
| Node l o r => Node (remove ii l) o r
end
| xI ii =>
match m with
| Leaf => Leaf
| Node Leaf None r =>
match remove ii r with
| Leaf => Leaf
| mm => Node Leaf None mm
end
| Node l o r => Node l o (remove ii r)
end
end.

Fixpoint xelements (m : t A) (i : key) : list (key * A) :=
match m with
| Leaf => nil
| Node l None r =>
(xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH)))
| Node l (Some x) r =>
(xelements l (append i (xO xH)))
++ ((i, x) :: xelements r (append i (xI xH)))
end.

Definition elements (m : t A) := xelements m xH.

Fixpoint cardinal (m : t A) : nat :=
match m with
| Leaf => 0%nat
| Node l None r => (cardinal l + cardinal r)%nat
| Node l (Some _) r => S (cardinal l + cardinal r)
end.

Section CompcertSpec.

Theorem gempty:
forall (i: key), find i empty = None.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.gempty".
destruct i; simpl; auto.
Qed.

Theorem gss:
forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.gss".
induction i; destruct m; simpl; auto.
Qed.

Lemma gleaf : forall (i : key), find i (Leaf : t A) = None.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.gleaf".   exact gempty. Qed.

Theorem gso:
forall (i j: key) (x: A) (m: t A),
i <> j -> find i (add j x m) = find i m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.gso".
induction i; intros; destruct j; destruct m; simpl;
try rewrite <- (gleaf i); auto; try apply IHi; congruence.
Qed.

Lemma rleaf : forall (i : key), remove i Leaf = Leaf.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.rleaf".   destruct i; simpl; auto. Qed.

Theorem grs:
forall (i: key) (m: t A), find i (remove i m) = None.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.grs".
induction i; destruct m.
simpl; auto.
destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto.
rewrite (rleaf i); auto.
cut (find i (remove i (Node ll oo rr)) = None).
destruct (remove i (Node ll oo rr)); auto; apply IHi.
apply IHi.
simpl; auto.
destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto.
rewrite (rleaf i); auto.
cut (find i (remove i (Node ll oo rr)) = None).
destruct (remove i (Node ll oo rr)); auto; apply IHi.
apply IHi.
simpl; auto.
destruct m1; destruct m2; simpl; auto.
Qed.

Theorem gro:
forall (i j: key) (m: t A),
i <> j -> find i (remove j m) = find i m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.gro".
induction i; intros; destruct j; destruct m;
try rewrite (rleaf (xI j));
try rewrite (rleaf (xO j));
try rewrite (rleaf 1); auto;
destruct m1; destruct o; destruct m2;
simpl;
try apply IHi; try congruence;
try rewrite (rleaf j); auto;
try rewrite (gleaf i); auto.
cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2));
[ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto
| apply IHi; congruence ].
destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
auto.
destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
auto.
cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2));
[ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto
| apply IHi; congruence ].
destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
auto.
destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
auto.
Qed.

Lemma xelements_correct:
forall (m: t A) (i j : key) (v: A),
find i m = Some v -> List.In (append j i, v) (xelements m j).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_correct".
induction m; intros.
rewrite (gleaf i) in H; discriminate.
destruct o; destruct i; simpl; simpl in H.
rewrite append_assoc_1; apply in_or_app; right; apply in_cons;
apply IHm2; auto.
rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
rewrite append_neutral_r; apply in_or_app; injection H as ->;
right; apply in_eq.
rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto.
rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
congruence.
Qed.

Theorem elements_correct:
forall (m: t A) (i: key) (v: A),
find i m = Some v -> List.In (i, v) (elements m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.elements_correct".
intros m i v H.
exact (xelements_correct m i xH H).
Qed.

Fixpoint xfind (i j : key) (m : t A) : option A :=
match i, j with
| _, xH => find i m
| xO ii, xO jj => xfind ii jj m
| xI ii, xI jj => xfind ii jj m
| _, _ => None
end.

Lemma xfind_left :
forall (j i : key) (m1 m2 : t A) (o : option A) (v : A),
xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xfind_left".
induction j; intros; destruct i; simpl; simpl in H; auto; try congruence.
destruct i; simpl in *; auto.
Qed.

Lemma xelements_ii :
forall (m: t A) (i j : key) (v: A),
List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_ii".
induction m.
simpl; auto.
intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
apply in_or_app.
left; apply IHm1; auto.
right; destruct (in_inv H0).
injection H1 as -> ->; apply in_eq.
apply in_cons; apply IHm2; auto.
left; apply IHm1; auto.
right; apply IHm2; auto.
Qed.

Lemma xelements_io :
forall (m: t A) (i j : key) (v: A),
~List.In (xI i, v) (xelements m (xO j)).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_io".
induction m.
simpl; auto.
intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
apply (IHm1 _ _ _ H0).
destruct (in_inv H0).
congruence.
apply (IHm2 _ _ _ H1).
apply (IHm1 _ _ _ H0).
apply (IHm2 _ _ _ H0).
Qed.

Lemma xelements_oo :
forall (m: t A) (i j : key) (v: A),
List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_oo".
induction m.
simpl; auto.
intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
apply in_or_app.
left; apply IHm1; auto.
right; destruct (in_inv H0).
injection H1 as -> ->; apply in_eq.
apply in_cons; apply IHm2; auto.
left; apply IHm1; auto.
right; apply IHm2; auto.
Qed.

Lemma xelements_oi :
forall (m: t A) (i j : key) (v: A),
~List.In (xO i, v) (xelements m (xI j)).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_oi".
induction m.
simpl; auto.
intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
apply (IHm1 _ _ _ H0).
destruct (in_inv H0).
congruence.
apply (IHm2 _ _ _ H1).
apply (IHm1 _ _ _ H0).
apply (IHm2 _ _ _ H0).
Qed.

Lemma xelements_ih :
forall (m1 m2: t A) (o: option A) (i : key) (v: A),
List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_ih".
destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
destruct (in_inv H0).
congruence.
apply xelements_ii; auto.
absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
apply xelements_ii; auto.
Qed.

Lemma xelements_oh :
forall (m1 m2: t A) (o: option A) (i : key) (v: A),
List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_oh".
destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
apply xelements_oo; auto.
destruct (in_inv H0).
congruence.
absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
apply xelements_oo; auto.
absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
Qed.

Lemma xelements_hi :
forall (m: t A) (i : key) (v: A),
~List.In (xH, v) (xelements m (xI i)).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_hi".
induction m; intros.
simpl; auto.
destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
generalize H0; apply IHm1; auto.
destruct (in_inv H0).
congruence.
generalize H1; apply IHm2; auto.
generalize H0; apply IHm1; auto.
generalize H0; apply IHm2; auto.
Qed.

Lemma xelements_ho :
forall (m: t A) (i : key) (v: A),
~List.In (xH, v) (xelements m (xO i)).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_ho".
induction m; intros.
simpl; auto.
destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
generalize H0; apply IHm1; auto.
destruct (in_inv H0).
congruence.
generalize H1; apply IHm2; auto.
generalize H0; apply IHm1; auto.
generalize H0; apply IHm2; auto.
Qed.

Lemma find_xfind_h :
forall (m: t A) (i: key), find i m = xfind i xH m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.find_xfind_h".
destruct i; simpl; auto.
Qed.

Lemma xelements_complete:
forall (i j : key) (m: t A) (v: A),
List.In (i, v) (xelements m j) -> xfind i j m = Some v.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_complete".
induction i; simpl; intros; destruct j; simpl.
apply IHi; apply xelements_ii; auto.
absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io.
destruct m.
simpl in H; tauto.
rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H).
absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi.
apply IHi; apply xelements_oo; auto.
destruct m.
simpl in H; tauto.
rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H).
absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi.
absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho.
destruct m.
simpl in H; tauto.
destruct o; simpl in H; destruct (in_app_or _ _ _ H).
absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
destruct (in_inv H0).
congruence.
absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
Qed.

Theorem elements_complete:
forall (m: t A) (i: key) (v: A),
List.In (i, v) (elements m) -> find i m = Some v.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.elements_complete".
intros m i v H.
unfold elements in H.
rewrite find_xfind_h.
exact (xelements_complete i xH m v H).
Qed.

Lemma cardinal_1 :
forall (m: t A), cardinal m = length (elements m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.cardinal_1".
unfold elements.
intros m; set (p:=1); clearbody p; revert m p.
induction m; simpl; auto; intros.
rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto.
destruct o; rewrite app_length; simpl; omega.
Qed.

End CompcertSpec.

Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v.

Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m.

Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m.

Definition eq_key (p p':key*A) := E.eq (fst p) (fst p').

Definition eq_key_elt (p p':key*A) :=
E.eq (fst p) (fst p') /\ (snd p) = (snd p').

Definition lt_key (p p':key*A) := E.lt (fst p) (fst p').

Global Instance eqk_equiv : Equivalence eq_key := _.
Global Instance eqke_equiv : Equivalence eq_key_elt := _.
Global Instance ltk_strorder : StrictOrder lt_key := _.

Lemma mem_find :
forall m x, mem x m = match find x m with None => false | _ => true end.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.mem_find".
induction m; destruct x; simpl; auto.
Qed.

Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.Empty_alt".
unfold Empty, MapsTo.
intuition.
generalize (H a).
destruct (find a m); intuition.
elim (H0 a0); auto.
rewrite H in H0; discriminate.
Qed.

Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.Empty_Node".
intros l o r.
split.
rewrite Empty_alt.
split.
destruct o; auto.
generalize (H 1); simpl; auto.
split; rewrite Empty_alt; intros.
generalize (H (xO a)); auto.
generalize (H (xI a)); auto.
intros (H,(H0,H1)).
subst.
rewrite Empty_alt; intros.
destruct a; auto.
simpl; generalize H1; rewrite Empty_alt; auto.
simpl; generalize H0; rewrite Empty_alt; auto.
Qed.

Section FMapSpec.

Lemma mem_1 : forall m x, In x m -> mem x m = true.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.mem_1".
unfold In, MapsTo; intros m x; rewrite mem_find.
destruct 1 as (e0,H0); rewrite H0; auto.
Qed.

Lemma mem_2 : forall m x, mem x m = true -> In x m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.mem_2".
unfold In, MapsTo; intros m x; rewrite mem_find.
destruct (find x m).
exists a; auto.
intros; discriminate.
Qed.

Variable  m m' m'' : t A.
Variable x y z : key.
Variable e e' : A.

Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.MapsTo_1".   intros; rewrite <- H; auto. Qed.

Lemma find_1 : MapsTo x e m -> find x m = Some e.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.find_1".   unfold MapsTo; auto. Qed.

Lemma find_2 : find x m = Some e -> MapsTo x e m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.find_2".   red; auto. Qed.

Lemma empty_1 : Empty empty.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.empty_1".
rewrite Empty_alt; apply gempty.
Qed.

Lemma is_empty_1 : Empty m -> is_empty m = true.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.is_empty_1".
induction m; simpl; auto.
rewrite Empty_Node.
intros (H,(H0,H1)).
subst; simpl.
rewrite IHt0_1; simpl; auto.
Qed.

Lemma is_empty_2 : is_empty m = true -> Empty m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.is_empty_2".
induction m; simpl; auto.
rewrite Empty_alt.
intros _; exact gempty.
rewrite Empty_Node.
destruct o.
intros; discriminate.
intro H; destruct (andb_prop _ _ H); intuition.
Qed.

Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.add_1".
unfold MapsTo.
intro H; rewrite H; clear H.
apply gss.
Qed.

Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.add_2".
unfold MapsTo.
intros; rewrite gso; auto.
Qed.

Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.add_3".
unfold MapsTo.
intro H; rewrite gso; auto.
Qed.

Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.remove_1".
intros; intro.
generalize (mem_1 H0).
rewrite mem_find.
red in H.
rewrite H.
rewrite grs.
intros; discriminate.
Qed.

Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.remove_2".
unfold MapsTo.
intro H; rewrite gro; auto.
Qed.

Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.remove_3".
unfold MapsTo.
destruct (E.eq_dec x y).
subst.
rewrite grs; intros; discriminate.
rewrite gro; auto.
Qed.

Lemma elements_1 :
MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.elements_1".
unfold MapsTo.
rewrite InA_alt.
intro H.
exists (x,e).
split.
red; simpl; unfold E.eq; auto.
apply elements_correct; auto.
Qed.

Lemma elements_2 :
InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.elements_2".
unfold MapsTo.
rewrite InA_alt.
intros ((e0,a),(H,H0)).
red in H; simpl in H; unfold E.eq in H; destruct H; subst.
apply elements_complete; auto.
Qed.

Lemma xelements_bits_lt_1 : forall p p0 q m v,
List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p.
Proof using. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_bits_lt_1".
intros.
generalize (xelements_complete _ _ _ _ H); clear H; intros.
revert p0 H.
induction p; destruct p0; simpl; intros; eauto; try discriminate.
Qed.

Lemma xelements_bits_lt_2 : forall p p0 q m v,
List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0.
Proof using. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_bits_lt_2".
intros.
generalize (xelements_complete _ _ _ _ H); clear H; intros.
revert p0 H.
induction p; destruct p0; simpl; intros; eauto; try discriminate.
Qed.

Lemma xelements_sort : forall p, sort lt_key (xelements m p).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xelements_sort".
induction m.
simpl; auto.
destruct o; simpl; intros.

apply (SortA_app (eqA:=eq_key_elt)); auto with *.
constructor; auto.
apply In_InfA; intros.
destruct y0.
red; red; simpl.
eapply xelements_bits_lt_2; eauto.
intros x0 y0.
do 2 rewrite InA_alt.
intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
red; red; simpl.
destruct H0.
injection H0 as H0 _; subst.
eapply xelements_bits_lt_1; eauto.
apply E.bits_lt_trans with p.
eapply xelements_bits_lt_1; eauto.
eapply xelements_bits_lt_2; eauto.

apply (SortA_app (eqA:=eq_key_elt)); auto with *.
intros x0 y0.
do 2 rewrite InA_alt.
intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
red; red; simpl.
apply E.bits_lt_trans with p.
eapply xelements_bits_lt_1; eauto.
eapply xelements_bits_lt_2; eauto.
Qed.

Lemma elements_3 : sort lt_key (elements m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.elements_3".
unfold elements.
apply xelements_sort; auto.
Qed.

Lemma elements_3w : NoDupA eq_key (elements m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.elements_3w".
apply ME.Sort_NoDupA.
apply elements_3.
Qed.

End FMapSpec.

Variable B : Type.

Section Mapi.

Variable f : key -> A -> B.

Fixpoint xmapi (m : t A) (i : key) : t B :=
match m with
| Leaf => @Leaf B
| Node l o r => Node (xmapi l (append i (xO xH)))
(option_map (f i) o)
(xmapi r (append i (xI xH)))
end.

Definition mapi m := xmapi m xH.

End Mapi.

Definition map (f : A -> B) m := mapi (fun _ => f) m.

End A.

Lemma xgmapi:
forall (A B: Type) (f: key -> A -> B) (i j : key) (m: t A),
find i (xmapi f m j) = option_map (f (append j i)) (find i m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xgmapi".
induction i; intros; destruct m; simpl; auto.
rewrite (append_assoc_1 j i); apply IHi.
rewrite (append_assoc_0 j i); apply IHi.
rewrite (append_neutral_r j); auto.
Qed.

Theorem gmapi:
forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A),
find i (mapi f m) = option_map (f i) (find i m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.gmapi".
intros.
unfold mapi.
replace (f i) with (f (append xH i)).
apply xgmapi.
rewrite append_neutral_l; auto.
Qed.

Lemma mapi_1 :
forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
MapsTo x e m ->
exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.mapi_1".
intros.
exists x.
split; [red; auto|].
apply find_2.
generalize (find_1 H); clear H; intros.
rewrite gmapi.
rewrite H.
simpl; auto.
Qed.

Lemma mapi_2 :
forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'),
In x (mapi f m) -> In x m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.mapi_2".
intros.
apply mem_2.
rewrite mem_find.
destruct H as (v,H).
generalize (find_1 H); clear H; intros.
rewrite gmapi in H.
destruct (find x m); auto.
simpl in *; discriminate.
Qed.

Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
MapsTo x e m -> MapsTo x (f e) (map f m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.map_1".
intros; unfold map.
destruct (mapi_1 (fun _ => f) H); intuition.
Qed.

Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
In x (map f m) -> In x m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.map_2".
intros; unfold map in *; eapply mapi_2; eauto.
Qed.

Section map2.
Variable A B C : Type.
Variable f : option A -> option B -> option C.

Arguments Leaf {A}.

Fixpoint xmap2_l (m : t A) : t C :=
match m with
| Leaf => Leaf
| Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r)
end.

Lemma xgmap2_l : forall (i : key) (m : t A),
f None None = None -> find i (xmap2_l m) = f (find i m) None.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xgmap2_l".
induction i; intros; destruct m; simpl; auto.
Qed.

Fixpoint xmap2_r (m : t B) : t C :=
match m with
| Leaf => Leaf
| Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r)
end.

Lemma xgmap2_r : forall (i : key) (m : t B),
f None None = None -> find i (xmap2_r m) = f None (find i m).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xgmap2_r".
induction i; intros; destruct m; simpl; auto.
Qed.

Fixpoint _map2 (m1 : t A)(m2 : t B) : t C :=
match m1 with
| Leaf => xmap2_r m2
| Node l1 o1 r1 =>
match m2 with
| Leaf => xmap2_l m1
| Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2)
end
end.

Lemma gmap2: forall (i: key)(m1:t A)(m2: t B),
f None None = None ->
find i (_map2 m1 m2) = f (find i m1) (find i m2).
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.gmap2".
induction i; intros; destruct m1; destruct m2; simpl; auto;
try apply xgmap2_r; try apply xgmap2_l; auto.
Qed.

End map2.

Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') :=
_map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end).

Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
(x:key)(f:option elt->option elt'->option elt''),
In x m \/ In x m' ->
find x (map2 f m m') = f (find x m) (find x m').
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.map2_1".
intros.
unfold map2.
rewrite gmap2; auto.
generalize (@mem_1 _ m x) (@mem_1 _ m' x).
do 2 rewrite mem_find.
destruct (find x m); simpl; auto.
destruct (find x m'); simpl; auto.
intros.
destruct H; intuition; try discriminate.
Qed.

Lemma  map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
(x:key)(f:option elt->option elt'->option elt''),
In x (map2 f m m') -> In x m \/ In x m'.
Proof.
intros.
generalize (mem_1 H); clear H; intros.
rewrite mem_find in H.
unfold map2 in H.
rewrite gmap2 in H; auto.
generalize (@mem_2 _ m x) (@mem_2 _ m' x).
do 2 rewrite mem_find.
destruct (find x m); simpl in *; auto.
destruct (find x m'); simpl in *; auto.
Qed.

Section Fold.

Variables A B : Type.
Variable f : key -> A -> B -> B.

Fixpoint xfoldi (m : t A) (v : B) (i : key) :=
match m with
| Leaf _ => v
| Node l (Some x) r =>
xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3)
| Node l None r =>
xfoldi r (xfoldi l v (append i 2)) (append i 3)
end.

Lemma xfoldi_1 :
forall m v i,
xfoldi m v i = fold_left (fun a p => f (fst p) (snd p) a) (xelements m i) v.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.xfoldi_1".
set (F := fun a p => f (fst p) (snd p) a).
induction m; intros; simpl; auto.
destruct o.
rewrite fold_left_app; simpl.
rewrite <- IHm1.
rewrite <- IHm2.
unfold F; simpl; reflexivity.
rewrite fold_left_app; simpl.
rewrite <- IHm1.
rewrite <- IHm2.
reflexivity.
Qed.

Definition fold m i := xfoldi m i 1.

End Fold.

Lemma fold_1 :
forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B),
fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.fold_1".
intros; unfold fold, elements.
rewrite xfoldi_1; reflexivity.
Qed.

Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool :=
match m1, m2 with
| Leaf _, _ => is_empty m2
| _, Leaf _ => is_empty m1
| Node l1 o1 r1, Node l2 o2 r2 =>
(match o1, o2 with
| None, None => true
| Some v1, Some v2 => cmp v1 v2
| _, _ => false
end)
&& equal cmp l1 l2 && equal cmp r1 r2
end.

Definition Equal (A:Type)(m m':t A) :=
forall y, find y m = find y m'.
Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' :=
(forall k, In k m <-> In k m') /\
(forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp).

Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
Equivb cmp m m' -> equal cmp m m' = true.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.equal_1".
induction m.

destruct 1.
simpl.
apply is_empty_1.
red; red; intros.
assert (In a (Leaf A)).
rewrite H.
exists e; auto.
destruct H2; red in H2.
destruct a; simpl in *; discriminate.

destruct m'.

destruct 1.
simpl.
destruct o.
assert (In xH (Leaf A)).
rewrite <- H.
exists a; red; auto.
destruct H1; red in H1; simpl in H1; discriminate.
apply andb_true_intro; split; apply is_empty_1; red; red; intros.
assert (In (xO a) (Leaf A)).
rewrite <- H.
exists e; auto.
destruct H2; red in H2; simpl in H2; discriminate.
assert (In (xI a) (Leaf A)).
rewrite <- H.
exists e; auto.
destruct H2; red in H2; simpl in H2; discriminate.

destruct 1.
assert (Equivb cmp m1 m'1).
split.
intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto.
intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto.
assert (Equivb cmp m2 m'2).
split.
intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto.
intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto.
simpl.
destruct o; destruct o0; simpl.
repeat (apply andb_true_intro; split); auto.
apply (H0 xH); red; auto.
generalize (H xH); unfold In, MapsTo; simpl; intuition.
destruct H4; try discriminate; eauto.
generalize (H xH); unfold In, MapsTo; simpl; intuition.
destruct H5; try discriminate; eauto.
apply andb_true_intro; split; auto.
Qed.

Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
equal cmp m m' = true -> Equivb cmp m m'.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMap.equal_2".
induction m.

simpl.
split; intros.
split.
destruct 1; red in H0; destruct k; discriminate.
destruct 1; elim (is_empty_2 H H0).
red in H0; destruct k; discriminate.

destruct m'.

simpl.
destruct o; intros; try discriminate.
destruct (andb_prop _ _ H); clear H.
split; intros.
split; unfold In, MapsTo; destruct 1.
destruct k; simpl in *; try discriminate.
destruct (is_empty_2 H1 (find_2 _ _ H)).
destruct (is_empty_2 H0 (find_2 _ _ H)).
destruct k; simpl in *; discriminate.
unfold In, MapsTo; destruct k; simpl in *; discriminate.

destruct o; destruct o0; simpl; intros; try discriminate.
destruct (andb_prop _ _ H); clear H.
destruct (andb_prop _ _ H0); clear H0.
destruct (IHm1 _ _ H2); clear H2 IHm1.
destruct (IHm2 _ _ H1); clear H1 IHm2.
split; intros.
destruct k; unfold In, MapsTo in *; simpl; auto.
split; eauto.
destruct k; unfold In, MapsTo in *; simpl in *.
eapply H4; eauto.
eapply H3; eauto.
congruence.
destruct (andb_prop _ _ H); clear H.
destruct (IHm1 _ _ H0); clear H0 IHm1.
destruct (IHm2 _ _ H1); clear H1 IHm2.
split; intros.
destruct k; unfold In, MapsTo in *; simpl; auto.
split; eauto.
destruct k; unfold In, MapsTo in *; simpl in *.
eapply H3; eauto.
eapply H2; eauto.
try discriminate.
Qed.

End PositiveMap.

Module PositiveMapAdditionalFacts.
Import PositiveMap.

Theorem gsspec:
forall (A:Type)(i j: key) (x: A) (m: t A),
find i (add j x m) = if E.eq_dec i j then Some x else find i m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMapAdditionalFacts.gsspec".
intros.
destruct (E.eq_dec i j) as [ ->|]; [ apply gss | apply gso; auto ].
Qed.

Theorem gsident:
forall (A:Type)(i: key) (m: t A) (v: A),
find i m = Some v -> add i v m = m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMapAdditionalFacts.gsident".
induction i; intros; destruct m; simpl; simpl in H; try congruence.
rewrite (IHi m2 v H); congruence.
rewrite (IHi m1 v H); congruence.
Qed.

Lemma xmap2_lr :
forall (A B : Type)(f g: option A -> option A -> option B)(m : t A),
(forall (i j : option A), f i j = g j i) ->
xmap2_l f m = xmap2_r g m.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMapAdditionalFacts.xmap2_lr".
induction m; intros; simpl; auto.
rewrite IHm1; auto.
rewrite IHm2; auto.
rewrite H; auto.
Qed.

Theorem map2_commut:
forall (A B: Type) (f g: option A -> option A -> option B),
(forall (i j: option A), f i j = g j i) ->
forall (m1 m2: t A),
_map2 f m1 m2 = _map2 g m2 m1.
Proof. hammer_hook "FMapPositive" "FMapPositive.PositiveMapAdditionalFacts.map2_commut".
intros A B f g Eq1.
assert (Eq2: forall (i j: option A), g i j = f j i).
intros; auto.
induction m1; intros; destruct m2; simpl;
try rewrite Eq1;
repeat rewrite (xmap2_lr f g);
repeat rewrite (xmap2_lr g f);
auto.
rewrite IHm1_1.
rewrite IHm1_2.
auto.
Qed.

End PositiveMapAdditionalFacts.


From Equations Require Import Equations DepElimDec.
From Opetopic Require Import HoTT_light.
Import Id_Notations.
Import Sigma_Notations.
Set Universe Polymorphism.
Require Import Relations.
(* Require Import Equations.ConstantsType. *)

Set Equations Transparent.
Notation Σ i j := (sigma i j).

Record Poly@{i} (I : Type@{i}) :=
  { Op : I -> Type@{i};
    Param : forall {i : I}, Op i -> I -> Type@{i} }.
Arguments Op {I}.
Arguments Param {I} _ {i} _ _.

(* Total space of the constructors/operations, indexed by their input type *)
Definition Ops {I : Type} (P : Poly I) := sigma I (Op P).

(* Total space of the parameters/inputs of a given operation/constructor *)
Definition Arity {I} (P : Poly I) {i} (f : Op P i) := sigma I (Param P f).

(* Functions that decorate every parameter of a constructor *)
Definition Decor@{i} {I : Type@{i}} (P : Poly I) (X : I -> Type@{i}) {i} (f : Op P i) :=
  forall j, Param P f j -> X j.

(* Type of polynomials decorated with X *)
Definition decor@{i} {I : Type@{i}} (P : Poly I) (X : I -> Type@{i}) : I -> Type@{i} :=
  fun i => Σ (Op P i) (Decor P X).

(** Just use standard tuple notation for sigmas *)
Notation "( x , .. , y , z )" :=
  (@sigmaI _ _ x .. (@sigmaI _ _ y z) ..)
    (right associativity, at level 0,
     format "( x ,  .. ,  y  ,  z )").

Section Trees.
  Universe i.
  Context {I : Type@{i}} (P : Poly I).

  Inductive W : I -> Type@{i} :=
  | lf (i : I) : W i
  | nd {i : I} (d : Σ (Op P i) (fun f => forall j, Param P f j -> W j)) : W i.

  Derive Signature for W.
  Derive NoConfusion NoConfusionHom for W.

  Definition W_elim :
    ∀ P' : ∀ i : I, W i → Type,
      (∀ i : I, P' i (lf i))
      → (∀ (i : I) (d : Σ (Op P i) (λ f0 : Op P i, ∀ j : I, Param P f0 j → W j)),
            (forall (j : I) (p : Param P d.1 j), P' j (d.2 j p)) ->
            P' i (nd d))
    → ∀ (i : I) (w : W i), P' i w.
  Proof.
    intros P' Hl Hnd.
    fix IH 2.
    destruct w.
    apply Hl.
    apply Hnd.
    intros j p. apply IH.
  Defined.

  (* Leaf w j represents the type of paths to leaves of the tree with index j. *)
  Fixpoint Leaf {i} (w : W i) (j : I) :=
    match w with
    | lf k => k = j
    | nd &(f & ϕ) => Σ I (fun k => Σ (Param P f k) (fun p => Leaf (ϕ k p) j))
    end.

  (* Leaf w j represents the type of paths to nodes labelled with o. *)
  Equations Node {i} (w : W i) (o : Ops P) : Type :=
  Node (lf k) o := Empty;
  Node {i:=_} (nd (sigmaI f ϕ)) o :=
                     ((o = (_, f)) +
                      (Σ I (fun k => Σ (Param P f k) (fun p => Node (ϕ k p) o))))%type.

  (* A frame for a tree [w] and operation [f] is an equivalence between
     paths to leaves in [w] indexed by [j] to parameters of [f] of the same index. *)
  Definition Frame {i} (w : W i) (f : Op P i) :=
    forall j, Leaf w j <~> Param P f j.

  Definition InFrame (o : Ops P) : Type :=
    let '(i, f) := o in
    Σ (W i) (fun w => Frame w f).

  Definition OutFrame {i} (w : W i) : Type :=
    Σ (Op P i) (Frame w).

  Definition Relator : Type :=
    forall (i : I) (w : W i) (f : Op P i), Frame w f → Type.

  (* A corrola for [f] is a tree with a single node labelled with [f] whose
     parameters are all leaves. *)

  Definition corrola {i} (f : Op P i) : W i :=
    nd (f, fun j p => lf j).

  Equations corrola_leaf_param {i} (f : Op P i) j (l : Leaf (corrola f) j) : Param P f j :=
  corrola_leaf_param f _ (sigmaI _ (sigmaI p id_refl)) := p.

  Equations corrola_param_leaf {i} (f : Op P i) j (p : Param P f j) : Leaf (corrola f) j :=
  corrola_param_leaf f j p := (j, p, id_refl).

  Program Definition corrola_leaf_equiv {i} (f : Op P i) j :
    Leaf (corrola f) j <~> Param P f j :=
    @BuildEquiv _ _ (corrola_leaf_param f j)
                (@BuildIsEquiv _ _ _ (corrola_param_leaf f j)
                               (fun _ => id_refl) _ _).

  Next Obligation.
    intros [k [p d]]. unfold corrola_param_leaf, corrola_leaf_param.
    destruct d. exact id_refl.
  Defined.

  Next Obligation.
    destruct x as [k [p d]]. destruct d. unfold corrola_param_leaf, corrola_leaf_param.
    simpl. exact id_refl.
  Defined.

  Notation idp := id_refl.

  Equations graft {i : I} (w : W i) (ψ : ∀ j, Leaf w j → W j) : W i :=
  graft (lf i) ψ := ψ i idp ;
  graft (nd (sigmaI f ϕ)) ψ := nd &(f & λ j p, graft (ϕ j p) (λ k l, ψ k &(j , p & l))).

  Equations graft_leaf_in {i : I} (w : W i) (ψ : ∀ j, Leaf w j → W j)
      (j : I) (k : I) (l : Leaf w k) (m : Leaf (ψ k l) j) : Leaf (graft w ψ) j :=
  graft_leaf_in (lf i) ψ j _ id_refl m := m;
  graft_leaf_in (nd (sigmaI f ϕ)) ψ j k (sigmaI h (sigmaI p l)) m :=
      sigmaI _ h (sigmaI _ p (graft_leaf_in (ϕ h p) (λ k₁ l₁, ψ k₁ &(h , p & l₁)) j k l m)).

  Equations graft_leaf_elim {i : I} (w : W i)
        (ψ : ∀ j, Leaf w j → W j)  (j : I) (Q : forall (l : Leaf (graft w ψ) j), Type)
        (σ : forall (k : I) (l : Leaf w k) (m : Leaf (ψ k l) j), Q (graft_leaf_in w ψ j k l m))
        (l : Leaf (graft w ψ) j) : Q l :=
  graft_leaf_elim (lf i) ψ j Q σ l := σ i id_refl l;
  graft_leaf_elim (nd (sigmaI f ϕ)) ψ j Q σ (sigmaI h (sigmaI p l)) :=
    graft_leaf_elim (ϕ h p) (λ j₁ l₁, ψ j₁ &(h , p & l₁)) j
                    (λ l₁, Q &(h , p & l₁)) (λ k₁ l₁ m₁, σ k₁ &(h , p & l₁) m₁) l.

  Lemma graft_leaf_elim_β {i : I} (w : W i)
        (ψ : ∀ j, Leaf w j → W j)  (j : I) (Q : forall (l : Leaf (graft w ψ) j), Type)
        (σ : forall (k : I) (l : Leaf w k) (m : Leaf (ψ k l) j), Q (graft_leaf_in w ψ j k l m))
        (k : I) (l : Leaf w k) (m : Leaf (ψ k l) j) :
    graft_leaf_elim w ψ j Q σ (graft_leaf_in w ψ j k l m) = σ k l m.
  Proof.
    revert_until i. revert i. fix aux 2.
    intros i w. destruct w. intros.
    simpl. destruct l. constructor.
    intros. simpl. destruct d as [op phi]; simpl in l. destruct l as [h [p l]].
    apply (aux _ (phi h p) (λ j₁ l₁, ψ j₁ (h , p, l₁))
                    _ (λ l₁, Q (h , p, l₁)) (λ k₁ l₁ m₁, σ k₁ (h, p, l₁) m₁) k l m).
  Defined.

  Equations graft_leaf_rec {Q : Type} {i : I} (w : W i)
        (ψ : ∀ j, Leaf w j → W j)  (j : I)
        (σ : forall (k : I) (l : Leaf w k) (m : Leaf (ψ k l) j), Q)
        (l : Leaf (graft w ψ) j) : Q :=
  graft_leaf_rec (lf i) ψ j σ l := σ i id_refl l;
  graft_leaf_rec (nd (sigmaI f ϕ)) ψ j σ (sigmaI h (sigmaI p l)) :=
    graft_leaf_rec (ϕ h p) (λ j₁ l₁, ψ j₁ (h, p, l₁)) j
                   (λ k₁ l₁ m₁, σ k₁ (h, p, l₁) m₁) l.

  Lemma graft_leaf_rec_β {i : I} (w : W i)
        (ψ : ∀ j, Leaf w j → W j)  (j : I) (Q : Type)
        (σ : forall (k : I) (l : Leaf w k) (m : Leaf (ψ k l) j), Q)
        (k : I) (l : Leaf w k) (m : Leaf (ψ k l) j) :
    graft_leaf_rec w ψ j σ (graft_leaf_in w ψ j k l m) = σ k l m.
  Proof.
    revert_until i. revert i. fix aux 2.
    intros i w. destruct w. intros.
    simpl. destruct l. constructor.
    intros. simpl. destruct d as [op phi]; simpl in l. destruct l as [h [p l]].
    apply (aux _ (phi h p) (λ j₁ l₁, ψ j₁ (h , p, l₁))
                    _ Q (λ k₁ l₁ m₁, σ k₁ (h , p, l₁) m₁) k l m).
  Defined.

  Lemma graft_unit {i : I} (w : W i) : graft w (λ j l, lf j) = w.
  Proof.
    revert i w. fix aux 2.
    destruct w; intros.
    simpl. reflexivity.
    destruct d as [f ϕ]. simpl.
    apply ap. apply ap.
    apply path_forall. intros x.
    apply path_forall. intros p.
    apply aux.
  Defined.

  Lemma graft_assoc {i : I} (w : W i)
      (ψ₀ : ∀ j, Leaf w j → W j)
      (ψ₁ : ∀ j k (l : Leaf w k), Leaf (ψ₀ k l) j → W j) :
    graft (graft w ψ₀) (λ j, graft_leaf_rec w ψ₀ j (ψ₁ j))
    = graft w (λ j l, graft (ψ₀ j l) (λ k m, ψ₁ k j l m)).
  Proof.
    revert i w ψ₀ ψ₁.
    fix aux 2.
    destruct w; intros.
    simpl. reflexivity.
    destruct d as [f ϕ]. simpl.
    apply ap. apply ap.
    apply path_forall. intros x.
    apply path_forall. intros p.
    apply aux.
  Defined.

  Definition slice (R : Relator) : Poly (Σ I (Op P)) :=
    {| Op '(i, f) := Σ (W i) (λ w, Σ (Frame w f) (R _ w f)) ;
       Param i w g := Node w.1 g |}.

End Trees.

Infix "/" := (slice).

CoInductive PolyDomain (I : Type) (P : Poly I) :=
  { R : Relator P;
    Dm : PolyDomain _ (P / R) }.
Arguments Node : simpl never.
Section Substitution.
  Context {I : Type} (P : Poly I) (R : Relator P).

  Equations subst {i : I} (w : W P i)
           (k : forall (g : Σ I (Op P)), Node P w g -> InFrame P g) : W P i :=
    subst (lf i) κ := lf _ i ;
    subst (nd i (sigmaI f ϕ)) κ :=
      let '(w, alpha) := κ (i , f) (inl id_refl) in
      let k' j l g n := κ g (inr (j , equiv_fun (alpha j) l , n)) in
      let ε j l := subst (ϕ j (equiv_fun (alpha j) l)) (k' j l) in
      graft P w ε.
  Set Program Mode.

  Lemma subst_lf_to {i : I} (w : W P i) (κ : forall (g : Ops P), Node P w g → InFrame P g)
    (j : I) (l : Leaf P (subst w κ) j) : Leaf P w j.
  Proof.
    revert dependent w; revert i. refine (W_elim P _ _ _). intros i κ l.
    - exact l.
    - intros i [f ϕ] Pd κ.
      set (wa := (κ (i, f) (inl 1))).
      set (κ' j l g n := κ g (inr (j , equiv_fun (wa.2 j) l, n))).
      set (ψ j l := subst (ϕ j (equiv_fun (wa.2 j) l)) (κ' j l)).
      simpl.
      refine (graft_leaf_rec P _ _ j _).
      intros k l0 l1. exists k.
      set (ϕk := ϕ k ((wa.2 k) l0)).
      unfold InFrame in *.
      eexists. subst ψ. simpl in l1. eapply Pd. simpl. eapply l1.
  Defined.

  (* Lemma subst_lf_from {i : I} (w : W P i) (κ : forall (g : Ops P), Node P w g → InFrame P g) *)
  (*   (j : I) (l : Leaf P (subst w κ) j) : Leaf P w j. *)
  (* Proof. *)
  (*   revert dependent w; revert i. refine (W_elim P _ _ _). intros i κ l. *)
  (*   - exact l. *)
  (*   - intros i [f ϕ] Pd κ. *)
  (*     set (wa := (κ (i, f) (inl 1))). *)
  (*     set (κ' j l g n := κ g (inr (j , equiv_fun (wa.2 j) l, n))). *)
  (*     set (ψ j l := subst (ϕ j (equiv_fun (wa.2 j) l)) (κ' j l)). *)
  (*     simpl. *)
  (*     refine (graft_leaf_rec P _ _ j _). *)
  (*     intros k l0 l1. exists k. *)
  (*     set (ϕk := ϕ k ((wa.2 k) l0)). *)
  (*     unfold InFrame in *. *)
  (*     eexists. subst ψ. simpl in l1. eapply Pd. simpl. eapply l1. *)
  (* Defined. *)
  Axiom cheat : forall {A}, A.
  Equations flatten {i : I} {f : Op P i} (pd : W (P / R) (i , f)) : Σ (W P i) (fun fw => Frame P fw f) :=
    flatten (lf _) := sigmaI _ (corrola P f) (corrola_leaf_equiv _ _);
    flatten (nd (sigmaI (sigmaI w (sigmaI α r)) κ)) :=
     let κ' g n := flatten (κ g n) in
     sigmaI _ (subst w κ') _.
  Next Obligation.
    red. apply cheat.
  Defined.
End Substitution.

(* where *)
(* flatten_frm_to {i : I} {f : Op P i}  (pd : W (P / R) (i , f)) (j : I)  (l : Leaf P (flatten pd) j) : Param P f j := *)
(* flatten_frm_to (lf _) j (sigmaI _ (sigmaI p idp)) := p; *)
(* flatten_frm_to (nd (sigmaI (sigmaI w (sigmaI α r)) κ)) j l := f (α j) (substitute-lf-to w κ j l) *)
(* where *)
(* substitute_lf_to {i : I} (w : W P i) (κ : (c : Σ I (Op P)) → Node P w c → W (P // R) c) (j : I) (l : Leaf P (substitute w κ) j) : Leaf P w j := *)
(* substitute_lf_to (lf i) κ j l := l ; *)
(* substitute_lf_to (nd i (sigmaI f ϕ)) κ j l := *)
(*     let pd := κ (i , f) (inl idp) in *)
(*     let p j l := flatten-frm-to pd j l in *)
(*     let κ' j l ic n := κ ic (inr (j , p j l , n)) in *)
(*     let ε j l := substitute (ϕ j (p j l)) (fun ic n =>  κ ic (inr (j , p j l , n))) in *)
(*     let (k , l₀ , l₁) := graft-leaf-from P (flatten pd) ε j l in *)
(*     let p' := flatten-frm-to pd k l₀ in *)
(*     let l' := substitute-lf-to (ϕ k (p k l₀)) (κ' k l₀) j l₁ *)
(*     in (k , p' , l') *)
(* . *)


(* Revealed a missing re-consideration of postponed problems *)

Module A.
Inductive flat_type := Unit | Prod (A B : flat_type).
Inductive exprf (op : flat_type -> flat_type -> Type) {var : Type} : flat_type
-> Type :=
| Op {t1 tR} (opc : op t1 tR) (args : exprf op t1) : exprf op tR.
Inductive op : flat_type -> flat_type -> Type := .
Arguments Op {_ _ _ _} _ _.
Definition bound_op {var}
           {src2 dst2}
           (opc2 : op src2 dst2)
  : forall (args2 : exprf op (var:=var) src2), Op opc2 args2 = Op opc2 args2
  := match opc2 return (forall args2, Op opc2 args2 = Op opc2 args2) with end.
End A.

(* A shorter variant *)
Module B.
Inductive exprf (op : unit -> Type) : Type :=
| A : exprf op
| Op tR (opc : op tR) (args : exprf op) : exprf op.
Inductive op : unit -> Type := .
Definition bound_op (dst2 : unit) (opc2 : op dst2)
  : forall (args2 : exprf op), Op op dst2 opc2 args2 = A op
  := match opc2 in op h return (forall args2 : exprf ?[U], Op ?[V] ?[I] opc2 args2 = A op) with end.
End B.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D : Universe, ((wd_ A B /\ (wd_ D C /\ (col_ A B D /\ col_ A B C))) -> col_ A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.