(** * MoreStlc: More on the Simply Typed Lambda-Calculus *)
(* Version of 4/23/2010 *)

Require Export Stlc.
Require Import Relations.

(* ###################################################################### *)
(** * Typechecking for STLC *)

(** The [has_type] relation defines what it means for a term to belong
    to a type (in some context).  But it doesn't, by itself, tell us
    how to _check_ whether or not a term is well typed.

    Fortunately, the rules defining [has_type] are _syntax directed_
    -- they exactly follow the shape of the term.  This makes it
    straightforward to translate the typing rules into clauses of a
    typechecking _function_ that takes a term and a context and either
    returns the term's type or else signals that the term is not
    typable. *)

Module STLCChecker.
Import STLC.

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

(** First, we need a function to compare two types for equality... *)

Fixpoint beq_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | ty_base i, ty_base i' =>
      beq_id i i'
  | ty_arrow T11 T12, ty_arrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | _,_ =>
      false
  end.

(** ... and we need to establish the usual two-way connection between
    the boolean result returned by [beq_ty] and the logical
    proposition that its inputs are equal. *)

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    symmetry. apply beq_id_refl.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity.  Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  Case "T1=ty_base i".
    symmetry in H0. apply beq_id_eq in H0. subst...
  Case "T1=ty_arrow T1_1 T1_2".
    apply andb_true in H0. destruct H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst...  Qed.

(* ###################################################################### *)
(** ** The Typechecker *)

(** Now here's the typechecker.  It works by walking over the
    structure of the given term, returning either [Some T] or [None].
    Each time we make a recursive call to find out the types of the
    subterms, we need to pattern-match on the results to make sure
    that they are not [None].  Also, in the [tm_app] case, we use
    pattern matching to extract the left- and right-hand sides of the
    function's arrow type (and fail if the type of the function is not
    [ty_arrow T11 T12] for some [T1] and [T2]). *)

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tm_var x => Gamma x
  | tm_abs x T11 t12 => match type_check (extend Gamma x T11) t12 with
                          | Some T12 => Some (ty_arrow T11 T12)
                          | _ => None
                        end
  | tm_app t1 t2 => match type_check Gamma t1, type_check Gamma t2 with
                      | Some (ty_arrow T11 T12),Some T2 =>
                        if beq_ty T11 T2 then Some T12 else None
                      | _,_ => None
                    end
  end.

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

(** To verify that this typechecking algorithm is the correct one, we
    show that it is _sound_ and _complete_ for the original [has_type]
    relation -- that is, [type_check] and [has_type] define the same
    partial function. *)

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  (tm_cases (induction t) Case); intros Gamma T Htc; inversion Htc.
  Case "tm_var"...
  Case "tm_app".
    remember (type_check Gamma t1) as TO1.
    remember (type_check Gamma t2) as TO2.
    destruct TO1 as [T1|]; try solve by inversion;
    destruct T1 as [|T11 T12]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    remember (beq_ty T11 T2) as b.
    destruct b; try solve by inversion.
    symmetry in Heqb. apply beq_ty__eq in Heqb.
    inversion H0; subst...
  Case "tm_abs".
    rename i into y. rename t into T1.
    remember (extend Gamma y T1) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve by inversion.
    inversion H0; subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  (typing_cases (induction Hty) Case); simpl.
  Case "T_Var"...
  Case "T_Abs". rewrite IHHty...
  Case "T_App".
    rewrite IHHty1. rewrite IHHty2.
    rewrite (beq_ty_refl T11)...
Qed.

End STLCChecker.

(* ###################################################################### *)
(** * 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 more familiar languages by introducing a number of familiar
    features that have straightforward treatments at the level of
    typing. *)

(** *** Numbers and Booleans *)

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

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

(** Another useful base type, found especially in languages in the ML
    family, is the singleton type [Unit].  In contrast to the
    uninterpreted base types of the simply typed lambda-calculus, this
    type _is_ interpreted, in the simplest possible way: we explicitly
    introduce 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].
<<
       t ::=                Terms:
           | ...               (other terms same as before)
           | unit              unit value

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

       T ::=                Types:
           | ...
           | Unit              Unit type
>>
*)

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

(** When writing a complex expression, it is often useful---both for
    avoiding repetition and for increasing readability---to give names
    to some of its subexpressions.  Most languages provide one or more
    ways of doing this.  In OCaml, 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 ML'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 just as easy to simply
    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:
           | ...
           | 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---by this point in the book, it should be about as easy
    to read a set of inference rules (or a formal [Inductive]
    definition) as to wade through a description in English conveying
    the same information.  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 product:
<<
       \x:nat*nat.
          let sum = x.fst + x.snd in
          let prod = x.fst * x.snd in
          (sum,prod)
>>

    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.
   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].
[[[
               Gamma |- t1 : T1       Gamma |- t2 : T2
               ---------------------------------------                 (T_Pair)
                       Gamma |- (t1,t2) : T1*T2

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

                        Gamma |- t1 : T11*T12
                        ---------------------                           (T_Snd)
                        Gamma |- t1.snd : T12

]]]
 *)

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

    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 [case] (a very
    simplified form of Coq's [match]) 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.
          case x of
            nil -> 0
          | a::x' -> case 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
           | case 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_Case1)
                   (case t1 of nil -> t2 | h::t -> t3)
               --> (case t1' of nil -> t2 | h::t -> t3)

               ---------------------------------------------       (ST_CaseNil)
               (case nil T of nil -> t2 | h::t -> t3) --> t2

            ---------------------------------------------         (ST_CaseCons)
            (case (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_Case)
              Gamma |- (case 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 be 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 [f] 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].

   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 (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 a function
    [diverge_T] as follows:
[[
      diverge_T = \x:Unit. fix (\x:Unit.x);
]]
    Whenever [diverge_T] is applied to a [unit] argument, we get a
    non-terminating evaluation sequence in which [ST-AppAbs] is
    applied over and over, always yielding the same term.  That is,
    for every type [T], the term [diverge_T unit] is an _undefined
    element_ of [T]. *)

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

(** **** Exercise: 5 stars (STLC_extensions) *)
(** Formalizing the extensions 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.) *)

Module STLCExtended.

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

Inductive ty : Type :=
  | ty_base  : id -> ty
  | ty_arrow : ty -> ty -> ty
  | ty_unit  : ty
  | ty_pair  : ty -> ty -> ty
  | ty_list  : ty -> ty
  | ty_nat   : ty.

Tactic Notation "ty_cases" tactic(first) tactic(c) :=
  first;
  [ c "ty_base" | c "ty_arrow" | c "ty_unit" |
    c "ty_pair" | c "ty_list" | c "ty_nat" ].

Inductive tm : Type :=
    (* pure STLC *)
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
    (* unit *)
  | tm_unit : tm
    (* pairs *)
  | tm_pair : tm -> tm -> tm
  | tm_fst : tm -> tm
  | tm_snd : tm -> tm
    (* lists *)
  | tm_nil : ty -> tm
  | tm_cons : tm -> tm -> tm
  | tm_case : tm -> tm -> id -> id -> tm -> tm
          (* i.e., [case 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 chosen a compressed version of the
    numeric operations, with a single [if0] form combining a zero test
    and a conditional. *)

Tactic Notation "tm_cases" tactic(first) tactic(c) :=
  first;
  [ c "tm_var" | c "tm_app" | c "tm_abs" |
    c "tm_unit" |
    c "tm_pair" | c "tm_fst" | c "tm_snd" |
    c "tm_nil" | c "tm_cons" | c "tm_case" |
    c "tm_nat" | c "tm_succ" | c "tm_pred" | c "tm_mult" | c "tm_if0" |
    c "tm_let" |
    c "tm_fix" ].

(** Some variables, for use in examples... *)

Notation a := (Id 0).
Notation f := (Id 1).
Notation g := (Id 2).
Notation l := (Id 3).
Notation A := (ty_base (Id 4)).
Notation B := (ty_base (Id 5)).
Notation k := (Id 6).
Notation i1 := (Id 7).
Notation i2 := (Id 8).

(* ###################################################################### *)
(** *** 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) tactic(c) :=
  first;
  [ c "ST_AppAbs" | c "ST_App1" | 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 *)

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

(** 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) tactic(c) :=
  first;
  [ c "T_Var" | c "T_Abs" | c "T_App"
    (* FILL IN HERE *)
].

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

(** **** Exercise: 2 stars (examples) *)
(** Finish the proofs. *)
(* 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!) *)

(* These hints improve the automation for [has_type].

  It says 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 [case]. 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.
(** <<
(* Uncomment this once you've defined the [T_Case] constructor for
   the typing relation: *)
Hint Extern 2 (has_type _ (tm_case _ _ _ _ _) _) => eapply T_Case; auto.
>> *)
Hint Extern 2 (_ = _) => compute; reflexivity.

Example fact_typechecks :
  has_type empty fact (ty_arrow ty_nat ty_nat).
Proof with auto.
(* FILL IN HERE *) Admitted.

Example fact_example:
  (tm_app fact (tm_nat 4)) -->* (tm_nat 24).
Proof.
  (* FILL IN HERE *) Admitted.

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

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

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 with auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

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


(*
 * Copyright (C) BedRock Systems Inc. 2020-2022
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

From bedrock.lang.bi Require Import prelude big_op.
Require Import iris.proofmode.proofmode.
Import ChargeNotation.

#[local] Set Primitive Projections.
#[local] Open Scope N_scope.

(** * Spec building block: Contender tokens *)

(**
Contender tokens enable verified code to limit the number of
contenders racing to call some method. Contender tokens are relevant
to, e.g., ticket locks with finitely many tickets.
*)

(**
[P n] represents [n] contender tokens. It's important that we use [n :
N] rather than [n : nat] for specs that cough up, e.g., [contender γ
INT_MAX].
*)
Class ContenderToken {PROP : bi} (P : N → PROP) : Prop := {
  contender_timeless n :> Timeless (P n);
  contender_affine   n :> Affine (P n);

  (**
  [contender_op] or the derived rule [contender_alloc] are used to
  split off individual contender tokens.

  _Example:_ Suppose there are 8 cores and ticket lock tickets occupy
  16 bits. When an initializing core A allocates a lock, it gets a
  bunch of contender tokens, written [contender γ (2 ^ 16 - 1)]. When
  A informs some other core B about this lock, A has [n ≠ 0] tokens
  left and peels off a single token using [contender_alloc]. A passes
  [contender γ 1] to B and keeps the remaining [n - 1] tokens. After
  doling out a token per core in this way, A can discard the remaining
  [2 ^ 16 - 9] tokens.
  *)
  contender_op n1 n2 : P (n1 + n2) -|- P n1 ** P n2;
}.

Section with_contender.
  Context {PROP : bi} {P : N -> PROP} `{CT : !ContenderToken P}.
  #[local] Set Default Proof Using "CT".

  Lemma contender_alloc (n : N) :
    n ≠ 0 → P n -|- P (N.pred n) ** P 1.
  Proof.
    intros. have {1}-> : (n = N.pred n + 1)%N by lia. exact: contender_op.
  Qed.

  Lemma contender_allocN (tk c : N) :
    (tk <= c)%N ->
    P c -|- P (c - tk) ** P tk.
  Proof.
    intros. have {1}->: (c = (c - tk) + tk)%N by lia. exact: contender_op.
  Qed.

  Lemma contender_split (n : N) :
    P n -|- P 0 ** P 1 ^^ n.
  Proof.
    induction n as [|n IH] using N.peano_ind.
    - by rewrite power_0 right_id.
    - by rewrite -N.add_1_r contender_op power_add power_1 IH assoc.
  Qed.

  Lemma contender_split_leaking_0 (n : N) :
    P n |-- P 1 ^^ n.
  Proof. rewrite contender_split. iIntros "[? $]". Qed.

  (** Proof mode *)
  #[global] Instance contender_into_sep n1 n2 :
    IntoSep (P (n1 + n2)) (P n1) (P n2).
  Proof. by rewrite /IntoSep contender_op. Qed.
  #[global] Instance contender_from_sep n1 n2 :
    FromSep (P (n1 + n2)) (P n1) (P n2).
  Proof. by rewrite /FromSep contender_op. Qed.

End with_contender.

#[global] Instance ContenderToken_sep {PROP : bi} (P Q : N -> PROP) :
  ContenderToken P -> ContenderToken Q ->
  ContenderToken (funI n => P n ** Q n).
Proof.
  constructor; [apply _..|].
  intros n1 n2. trans ((P n1 ** P n2) ** (Q n1 ** Q n2)).
  - by rewrite !contender_op.
  - rewrite !bi.sep_assoc. rewrite -(bi.sep_assoc (P n1) (P n2) (Q n1)).
    rewrite (bi.sep_comm (P n2) (Q n1)). by rewrite bi.sep_assoc.
Qed.


Require Import Base.
Require Import Circuit.
Require Import Monad.
Require Import Setoid.

Require Import StateSpace.Definitions.

Require Import List.
Import ListNotations.
Open Scope list_scope.

Import EnsembleNotation.
Open Scope ensemble_scope.

Module Type NameType.
  Parameter name : Set.
  Parameter name_eq_dec : eq_dec name.
  Existing Instance name_eq_dec.
  Export EnsembleNotation.
  Open Scope ensemble_scope.

End NameType.

Module StateSpaceTactics (Export name : NameType).

  Add Parametric Morphism : event_in
    with signature Same_set name ==> @eq (option (event name value)) ==> iff as event_in_equiv.
  Proof.
    intros.
    apply event_in_equiv; auto.
  Qed.
  Add Parametric Morphism : state_equiv_on
    with signature (Same_set name) ==> (@eq (option (state name)))
                                   ==> (@eq (option (state name))) ==> iff
    as state_equiv_on_equiv.
  Proof.
    intros.
    apply state_equiv_on_equiv; auto.
  Qed.

  Ltac rewrite_state_equiv :=
  match goal with
  | [ H : state_equiv_on ?X (Some ?σ') (Some _) |- context[?σ' _] ] =>
    rewrite H; [ try unfold update | decompose_set_structure]
  | [ H : state_equiv_on ?X (Some _) (Some ?σ') |- context[?σ' _] ] =>
    rewrite <- H; [ try unfold update | decompose_set_structure]
  end.

  Ltac rewrite_state_equiv_branch y :=
  match goal with
  | [ Hequiv : state_equiv_on ?X (Some ?σ) (Some ?σ')
    |- context[ ?σ' y ] ] =>
      let Hy := fresh "Hy" in
      destruct (y ∈? X) as [Hy | Hy];
        [ rewrite_state_equiv | clear Hequiv]
  end.

  Lemma union_inversion_left : forall (S1 S2 : StateSpace name) σ x v σ',
    (S1 ∥ S2) ⊢ σ →{Some (Event x v)} Some σ' ->
    x ∈ space_domain S1 ->
    S1 ⊢ σ →{Some (Event x v)} Some σ'.
  Proof.
    intros ? ? ? ? ? ? Hstep Hdom.
    inversion Hstep; subst; auto.
    (* the only remaining case is when x ∉ dom(S1), a contradiction *)
    { absurd (event_in (space_domain S1) (Some (Event x v))); auto.
      constructor; auto.
    }
  Qed.

  Lemma union_inversion_l : forall (S1 S2 : StateSpace name) σ e σ',
    (S1 ∥ S2) ⊢ σ →{e} Some σ' ->
    event_in (space_domain S1) e ->
    ~ event_in (space_domain S2) e ->
    S1 ⊢ σ →{e} Some σ'
    /\ state_equiv_on (space_domain S2) (Some σ) (Some σ').
  Proof.
    intros ? ? ? ? ? Hstep H1 H2.
    inversion Hstep; subst; split; auto;
      try contradiction.
    contradict H2.
    inversion H; subst; auto;
    match goal with
    [ H : event_in (_ ?S2) ?e |- event_in (space_domain ?S2) ?e ] =>
      inversion H; subst;
      constructor;
      unfold space_domain; solve_set
    end.
  Qed.

  Lemma union_inversion_right : forall (S1 S2 : StateSpace name) σ x v σ',
      (S1 ∥ S2) ⊢ σ →{Some (Event x v)} Some σ' ->
      x ∈ space_domain S2 ->
      S2 ⊢ σ →{Some (Event x v)} Some σ'.
  Proof.
    intros ? ? ? ? ? ? Hstep Hdom.
    inversion Hstep; subst; auto.
    (* the only remaining case is when x ∉ dom(S2), a contradiction *)
    { absurd (event_in (space_domain S2) (Some (Event x v))); auto.
      constructor; auto.
    }
  Qed.

  Lemma union_inversion_r : forall (S1 S2 : StateSpace name) σ e σ',
    (S1 ∥ S2) ⊢ σ →{e} Some σ' ->
    ~ event_in (space_domain S1) e ->
    event_in (space_domain S2) e ->
    S2 ⊢ σ →{e} Some σ'
    /\ state_equiv_on (space_domain S1) (Some σ) (Some σ').
  Proof.
    intros ? ? ? ? ? Hstep H1 H2.
    inversion Hstep; subst; split; auto;
      try contradiction.
    contradict H1.
    inversion H; subst; auto;
    match goal with
    [ H : event_in (_ ?S2) ?e |- event_in (space_domain ?S2) ?e ] =>
      inversion H; subst;
      constructor;
      unfold space_domain; solve_set
    end.
  Qed.

  Lemma union_inversion_lr : forall (S1 S2 : StateSpace name) σ x v σ',
    (S1 ∥ S2) ⊢ σ →{Some (Event x v)} Some σ' ->
    x ∈ space_domain S1 ∩ space_domain S2 ->
    S1 ⊢ σ →{Some (Event x v)} Some σ' /\ S2 ⊢ σ →{Some (Event x v)} Some σ'.
  Proof.
    intros ? ? ? ? ? ? Hstep Hdom.
    split; [eapply union_inversion_left | eapply union_inversion_right];
      eauto; decompose_set_structure.
  Qed.

  Lemma union_inversion : forall (S1 S2 : StateSpace name) e σ σ',
    (S1 ∥ S2) ⊢ σ →{e} Some σ' ->
    S1 ⊢ σ →{e} Some σ' \/ S2 ⊢ σ →{e} Some σ'.
  Proof.
    intros S1 S2 e σ σ' Hstep.
    inversion Hstep; auto.
  Qed.

  Lemma union_inversion_eps : forall (S1 S2 : StateSpace name) σ σ',
    (S1 ∥ S2) ⊢ σ →{None} Some σ' ->
       (S1 ⊢ σ →{None} Some σ' /\ state_equiv_on (space_domain S2) (Some σ) (Some σ'))
    \/ (S2 ⊢ σ →{None} Some σ' /\ state_equiv_on (space_domain S1) (Some σ) (Some σ')).
  Proof.
    intros S1 S2 σ σ' Hstep.
    inversion Hstep; subst; auto.
    inversion H;
    match goal with
    | [ H : event_in _ None |- _ ] => inversion H
    end.
  Qed.

  Lemma union_internal_inversion_right : forall (S1 S2 : StateSpace name) σ x v σ',
      well_formed S1 ->
      well_formed S2 ->
      space_internal S1 ⊥ space_domain S2 ->
      space_domain S1 ⊥ space_internal S2 ->
      (S1 ∥ S2) ⊢ σ →{ Some (Event x v)} Some σ' ->
      x ∉ space_domain S2 ->
      state_equiv_on (space_internal S2) (Some σ') (Some σ).
  Proof.
    intros ? ? ? ? ? ? Hwf1 Hwf2 Hdisj1 Hdisj2 Hstep Hx y Hy.
    inversion Hstep as [ ? ? H_event_in Hstep' Hequiv
                       | ? ? H_event_in Hstep' Hequiv
                       | ? ? Hevent Hstep1 Hstep2]; subst; auto.
    * unfold state_equiv_on in Hequiv.
      rewrite Hequiv; auto.
      unfold space_domain; solve_set.
    * contradict H_event_in.
      constructor.
      apply wf_space in Hstep; auto.
      2:{ apply wf_union; auto. }
      simpl in Hstep.
      decompose_set_structure; unfold space_domain in *;
        try solve_set;
        try (contradict Hx; solve_set).

    * inversion Hevent as [Hevent1 Hevent2 | Hevent1 Hevent2 | Hevent1 Hevent2];
        inversion Hevent2; subst;
          contradict Hx; unfold space_domain; solve_set.
  Qed.

  Lemma hide_inversion : forall (S : StateSpace name) σ x e σ',
      (hide x S) ⊢ σ →{Some e} Some σ' ->
      S ⊢ σ →{Some e} Some σ'.
  Proof.
    intros ? ? ? ? ? Hstep.
    inversion Hstep; auto.
  Qed.

  Lemma hide_inversion_None : forall (S : StateSpace name) σ x σ',
      (hide x S) ⊢ σ →{None} Some σ' ->
      S ⊢ σ →{None} Some σ' \/ exists v, S ⊢ σ →{Some (Event x v)} Some σ'.
  Proof.
    intros ? ? ? ? Hstep.
    inversion Hstep; subst; auto.
    right. exists v. auto.
  Qed.

  Lemma func_space_output_inversion : forall I (o : name) f (σ : state name) x v σ',
      o ∉ from_list I ->
      func_space I o f ⊢ σ →{Some (Event x v)} Some σ' ->
      x = o ->
      v = f σ.
  Proof.
    intros ? ? ? ? ? ? ? Ho Hstep ?. subst.
    inversion Hstep; try find_contradiction.
    subst. auto.
  Qed.

  Lemma func_space_output_unstable : forall I (o : name) f σ x v σ',
      o ∉ from_list I ->
      func_space I o f ⊢ σ →{Some (Event x v)} Some σ' ->
      x = o ->
      σ x <> v.
  Proof.
    intros ? ? ? ? ? ? ? ? Hstep Heq.
    subst.
    inversion Hstep; subst; try find_contradiction; auto.
  Qed.

  Lemma func_space_output_neq : forall I (o : name) f σ v σ' y,
      o ∉ from_list I ->
      func_space I o f ⊢ σ →{Some (Event o v)} Some σ' ->
      y ∈ from_list I ->
      σ' y = σ y.
  Proof.
    intros ? ? ? ? ? ? ? ? Hstep Hneq.
    inversion Hstep; subst;
    match goal with
    | [ H : state_equiv_on _ _ (Some ?σ') |- ?σ' _ = _ ] => rewrite <- H;
      [unfold update | try solve_set]
    end;
      compare_next; auto.
  Qed.

  Lemma func_space_inversion_None : forall I (o : name) f (σ : state name) σ',
      func_space I o f ⊢ σ →{None} Some σ' ->
      False.
  Proof.
    intros. inversion H.
  Qed.

Lemma func_space_inversion : forall I o f σ e σ',
  o ∉ from_list I ->
  func_space I o f ⊢ σ →{e} Some σ' ->
  match e with
  | None => False
  | Some (Event y v) => state_equiv_on (from_list I ∪ singleton o) (Some (update σ y v)) (Some σ')
                    /\ (y = o -> (v = f σ /\ f σ <> σ o))
                    /\ (y ∈ from_list I -> v <> σ y /\ (f σ = σ o \/ f σ = f (update σ y v)))
  end.
Proof.
  intros ? ? ? ? ? ? Hwf Hstep.
  inversion Hstep; subst.
  * split; auto. split; auto.
    intro Hi; subst; find_contradiction.
  * split; auto. split; auto.
    { intros Heq; subst; find_contradiction. }
  * split; auto. split; auto.
    { intros Hin. find_contradiction. }
Qed.

  Lemma flop_inversion_output : forall set reset clk old_clk D Q σ v σ',
    all_disjoint [set; reset;clk;old_clk;D;Q] ->
    σ set = Bit1 ->
    σ reset = Bit1 ->
    flop set reset clk old_clk D Q ⊢ σ →{Some (Event Q v)} Some σ' ->
    σ clk = Bit1 /\
    σ old_clk <> Bit1 /\
    v = σ D /\
     state_equiv_on (from_list [set;reset;clk;D;Q;old_clk])
        (Some (update (update σ Q v) old_clk (σ clk)))
        (Some σ').
  Proof.
    intros ? ? ? ? ? ? ? ? ? ? Hset Hreset Hstep.
    inversion Hstep; subst; auto; clear Hstep;
      try find_contradiction.
    + contradict H5. simpl. solve_set.
  Qed.

  Lemma flop_inversion_clk_stable : forall set reset clk old_clk D Q σ v σ',
    all_disjoint [set;reset;clk;old_clk;D;Q] ->
    (flop set reset clk old_clk D Q) ⊢ σ →{Some (Event clk v)} Some σ' ->
    σ set = Bit1 ->
    σ reset = Bit1 ->
    σ clk = σ old_clk.
  Proof.
    intros ? ? ? ? ? ? ? ? ? Hdisjoint Hstep Hset Hreset.
    inversion Hstep; try (subst; find_contradiction; fail); auto.
  Qed.

  Lemma flop_inversion_clk_equiv : forall set reset clk old_clk D Q σ v σ',
    all_disjoint [set;reset;clk;old_clk;D;Q] ->
    (flop set reset clk old_clk D Q) ⊢ σ →{Some (Event clk v)} Some σ' ->
    σ set = Bit1 ->
    σ reset = Bit1 ->
    (* equivalent on everything except old_clk *)
    state_equiv_on (from_list (set::reset::clk::D::Q::nil)) (Some (update σ clk v)) (Some σ').
  Proof.
    intros ? ? ? ? ? ? ? ? ? Hdisjoint Hstep Hset Hreset.
    inversion Hstep; try (subst; find_contradiction; fail); auto.
    * intros x Hx; unfold update.
      rewrite_state_equiv.
      auto.
    * intros x Hx; unfold update.
      rewrite_state_equiv; try solve_set.
      compare old_clk x; auto.
      { (* if equal *) decompose_set_structure. (* contradiction with all_disjoint *) }

    * intros x Hx; unfold update.
      rewrite_state_equiv; try solve_set.
  Qed.
  Lemma flop_inversion_clk_Bit0 : forall set reset clk old_clk D Q σ σ',
    all_disjoint [set;reset;clk;old_clk;D;Q] ->
    (flop set reset clk old_clk D Q) ⊢ σ →{Some (Event clk Bit0)} Some σ' ->
    σ set = Bit1 ->
    σ reset = Bit1 ->
    σ' old_clk = Bit0.
  Proof.
    intros ? ? ? ? ? ? ? ? Hdisjoint Hstep Hset Hreset.
    inversion Hstep; subst; try find_contradiction.
    * decompose_set_structure. (* contradiction of clk ∈ from_list [set;reset;D] *)
    * rewrite_state_equiv; try solve_set.
      reduce_eqb; auto.
  Qed.

  Lemma flop_inversion_clk : forall set reset clk old_clk D Q σ v σ',
    all_disjoint [set;reset;clk;old_clk;D;Q] ->
    (flop set reset clk old_clk D Q) ⊢ σ →{Some (Event clk v)} Some σ' ->
    σ set = Bit1 ->
    σ reset = Bit1 ->
    σ clk = σ old_clk /\
    state_equiv_on (from_list (set::reset::clk::D::Q::old_clk::nil))
                   (Some (update (update σ clk v) old_clk (if v =? Bit1 then σ old_clk else v)))
                   (Some σ').
  Proof.
    intros ? ? ? ? ? ? ? ? ? Hdisjoint Hstep Hset Hreset.
    split.
    * eapply flop_inversion_clk_stable; eauto.
    * intros x Hx. unfold update.
      inversion Hstep; subst; try find_contradiction;
        rewrite_state_equiv; try solve_set.
      + (* contradiction *) decompose_set_structure.
      + compare_next; auto.
      + compare_next; auto.
        compare_next; auto.
  Qed.

Ltac unfold_SS recurse_flag loc_flag S :=
  match S with

  | func_space ?I0 ?x ?f => idtac
  | ?S1 ∥ ?S2            =>
    (* If the recurse_flag is true then we want to unfold recursively; if false,
    only unfold the head term, in this case, already a Union *)
    maybe_do recurse_flag ltac:(unfold_SS recurse_flag loc_flag S1);
    maybe_do recurse_flag ltac:(unfold_SS recurse_flag loc_flag S2)
  | hide ?x ?S'          =>
    maybe_do recurse_flag ltac:(unfold_SS recurse_flag loc_flag S')
  | flop ?set ?reset ?clk ?old_clk ?D ?Q => idtac
  | delay_space ?S0 ?sens ?guard ?guardb    =>
    maybe_do recurse_flag ltac:(unfold_SS recurse_flag loc_flag S0)

  (* func *)
  | _ => let I := fresh "I" in
         let o := fresh "o" in
         let f := fresh "f" in
         evar (I : list name);
         evar (o : name);
         evar (f : state name -> value);
         replace_with_in S (func_space I o f) loc_flag;
         unfold I, o, f in *;
         clear I o f;
         [ | reflexivity]

  (* union *)
  | _ => let S1 := fresh "S1" in
         let S2 := fresh "S2" in
         evar (S1 : StateSpace name);
         evar (S2 : StateSpace name);
         replace_with_in S (S1 ∥ S2) loc_flag;
         unfold S1, S2 in *;
         [ | reflexivity];
         maybe_do recurse_flag ltac:(let S1' := eval unfold S1 in S1 in
                                let S2' := eval unfold S2 in S2 in
                                unfold_SS recurse_flag loc_flag S1';
                                unfold_SS recurse_flag loc_flag S2');
         clear S1 S2
  (* hide *)
  | _ => let x0 := fresh "x0" in
         let S0 := fresh "S0" in
         evar (x0 : name);
         evar (S0 : StateSpace name);
         replace_with_in S (hide x0 S0) loc_flag;
         unfold x0, S0 in *;
         [ | reflexivity];
         maybe_do recurse_flag ltac:(let S0' := eval unfold S0 in S0 in
                                unfold_SS recurse_flag loc_flag S0');
         clear x0 S0

  (* flop *)
  | _ => let set := fresh "set" in
         let reset := fresh "reset" in
         let clk := fresh "clk" in
         let old_clk := fresh "old_clk" in
         let D := fresh "D" in
         let Q := fresh "Q" in
         evar (set : name); evar (reset : name);
         evar (clk : name); evar (old_clk : name);
         evar (D : name); evar (Q : name);
         replace_with_in S (flop set reset clk old_clk D Q) loc_flag;
         unfold set, reset, clk, old_clk, D, Q in *;
         clear set reset clk old_clk D Q;
         [ | reflexivity]

  (* delay space *)
  | _ => let S0 := fresh "S0" in
         let sens := fresh "sens" in
         let guard := fresh "guard" in
         let guardb := fresh "guardb" in
         evar (S0 : StateSpace name);
         evar (sens : list name);
         evar (guard : state name -> Prop);
         evar (guardb : state name -> bool);
         replace_with_in S (delay_space S0 sens guard guardb) loc_flag;
         unfold S0, sens, guard, guardb in *;
         [ | reflexivity];
         maybe_do recurse_flag ltac:(let S0' := eval unfold S0 in S0 in
                                unfold_SS recurse_flag loc_flag S0');
         clear S0 sens guard guardb
  end.
  Tactic Notation "unfold_StateSpace" constr(S) :=
    (unfold_SS true false S).
  Tactic Notation "unfold_StateSpace_1" constr(S) :=
    (unfold_SS false false S).
  Tactic Notation "unfold_StateSpace" constr(S) "in" "*" :=
    (unfold_SS true true S).
  Tactic Notation "unfold_StateSpace_1" constr(S) "in" "*" :=
    (unfold_SS false true S).
  Tactic Notation "unfold_StateSpace" constr(S) "in" hyp(H) :=
    (unfold_SS true H S).
  Tactic Notation "unfold_StateSpace_1" constr(S) "in" hyp(H) :=
    (unfold_SS false H S).

End StateSpaceTactics.


(* Cases with let-in in constructors types *)

Unset Printing Allow Match Default Clause.

Inductive t : Set :=
    k : let x := t in x -> x.

Print t_rect.

Record TT : Type := CTT { f1 := 0 : nat; f2: nat; f3 : f1=f1 }.

Eval cbv in fun d:TT => match d return 0 = 0 with CTT a _ b => b end.
Eval lazy in fun d:TT => match d return 0 = 0 with CTT a _ b => b end.

(* Do not contract nested patterns with dependent return type *)
(* see bug #1699 *)

Require Import Arith.

Definition proj (x y:nat) (P:nat -> Type) (def:P x) (prf:P y) : P y :=
  match eq_nat_dec x y return P y with
  | left eqprf =>
    match eqprf in (_ = z) return (P z) with
    | refl_equal => def
    end
  | _ => prf
 end.

Print proj.

(* Use notations even below aliases *)

Require Import List.

Fixpoint foo (A:Type) (l:list A) : option A :=
  match l with
  | nil => None
  | x0 :: nil => Some x0
  | x0 :: (x1 :: xs) as l0 => foo A l0
  end.

Print foo.

(* Accept and use notation with binded parameters *)

Inductive I (A: Type) : Type := C : A -> I A.
Notation "x <: T" := (C T x) (at level 38).

Definition uncast A (x : I A) :=
match x with
 | x <: _ => x
end.

Print uncast.

(* Do not duplicate the matched term *)

Axiom A : nat -> bool.

Definition foo' :=
  match A 0 with
    | true => true
    | x => x
  end.

Print foo'.

(* Was bug #3293 (eta-expansion at "match" printing time was failing because
   of let-in's interpreted as being part of the expansion)  *)

Axiom b : bool.
Axiom P : bool -> Prop.
Inductive B : Prop := AC : P b -> B.
Definition f : B -> True.

Proof.
intros [x].
destruct b as [|] ; exact Logic.I.
Defined.

Print f.

(* Was enhancement request #5142 (error message reported on the most
   general return clause heuristic) *)

Inductive gadt : Type -> Type :=
| gadtNat : nat -> gadt nat
| gadtTy : forall T, T -> gadt T.

Fail Definition gadt_id T (x: gadt T) : gadt T :=
  match x with
  | gadtNat n => gadtNat n
  end.

(* A variant of #5142 (see Satrajit Roy's example on coq-club (Oct 17, 2016)) *)

Inductive type:Set:=Nat.
Inductive tbinop:type->type->type->Set:= TPlus : tbinop Nat Nat Nat.
Inductive texp:type->Set:=
 |TNConst:nat->texp Nat
 |TBinop:forall t1 t2 t, tbinop t1 t2 t->texp t1->texp t2->texp t.
Definition typeDenote(t:type):Set:= match t with Nat => nat end.

(* We expect a failure on TBinop *)
Fail Fixpoint texpDenote t (e:texp t):typeDenote t:=
  match e with
  | TNConst n => n
  | TBinop t1 t2 _ b e1 e2 => O
  end.

(* Test notations with local definitions in constructors *)

Inductive J := D : forall n m, let p := n+m in nat -> J.
Notation "{{ n , m , q }}" := (D n m q).

Check fun x : J => let '{{n, m, _}} := x in n + m.
Check fun x : J => let '{{n, m, p}} := x in n + m + p.

(* Cannot use the notation because of the dependency in p *)

Check fun x => let '(D n m p q) := x in n+m+p+q.

(* This used to succeed, being interpreted as "let '{{n, m, p}} := ..." *)

Fail Check fun x : J => let '{{n, m, _}} p := x in n + m + p.

(* Test use of idents bound to ltac names in a "match" *)

Lemma lem1 : forall k, k=k :>nat * nat.
let x := fresh "aa" in
let y := fresh "bb" in
let z := fresh "cc" in
let k := fresh "dd" in
refine (fun k : nat * nat => match k as x return x = x with (y,z) => eq_refl end).
Qed.
Print lem1.

Lemma lem2 : forall k, k=k :> bool.
let x := fresh "aa" in
let y := fresh "bb" in
let z := fresh "cc" in
let k := fresh "dd" in
refine (fun k => if k as x return x = x then eq_refl else eq_refl).
Qed.
Print lem2.

Lemma lem3 : forall k, k=k :>nat * nat.
let x := fresh "aa" in
let y := fresh "bb" in
let z := fresh "cc" in
let k := fresh "dd" in
refine (fun k : nat * nat => let (y,z) as x return x = x := k in eq_refl).
Qed.
Print lem3.

Lemma lem4 x : x+0=0.
match goal with |- ?y = _ => pose (match y with 0 => 0 | S n => 0 end) end.
match goal with |- ?y = _ => pose (match y as y with 0 => 0 | S n => 0 end) end.
match goal with |- ?y = _ => pose (match y as y return y=y with 0 => eq_refl | S n => eq_refl end) end.
match goal with |- ?y = _ => pose (match y return y=y with 0 => eq_refl | S n => eq_refl end) end.
match goal with |- ?y + _ = _ => pose (match y with 0 => 0 | S n => 0 end) end.
match goal with |- ?y + _ = _ => pose (match y as y with 0 => 0 | S n => 0 end) end.
match goal with |- ?y + _ = _ => pose (match y as y return y=y with 0 => eq_refl | S n => eq_refl end) end.
match goal with |- ?y + _ = _ => pose (match y return y=y with 0 => eq_refl | S n => eq_refl end) end.
Show.
Abort.

Lemma lem5 (p:nat) : eq_refl p = eq_refl p.
let y := fresh "n" in (* Checking that y is hidden *)
  let z := fresh "e" in (* Checking that z is hidden *)
  match goal with
  |- ?y = _ => pose (match y as y in _ = z return y=y /\ z=z with eq_refl => conj eq_refl eq_refl end)
  end.
let y := fresh "n" in
  let z := fresh "e" in
  match goal with
  |- ?y = _ => pose (match y in _ = z return y=y /\ z=z with eq_refl => conj eq_refl eq_refl end)
  end.
let y := fresh "n" in
  let z := fresh "e" in
  match goal with
  |- eq_refl ?y = _ => pose (match eq_refl y in _ = z return y=y /\ z=z with eq_refl => conj eq_refl eq_refl end)
  end.
let p := fresh "p" in
  let z := fresh "e" in
  match goal with
  |- eq_refl ?p = _ => pose (match eq_refl p in _ = z return p=p /\ z=z with eq_refl => conj eq_refl eq_refl end)
  end.
Show.

Set Printing Allow Match Default Clause.

(***************************************************)
(* Testing strategy for factorizing cases branches *)

(* Factorization + default clause *)
Check fun x => match x with Eq => 1 | _ => 0 end.

(* No factorization *)
Unset Printing Factorizable Match Patterns.
Check fun x => match x with Eq => 1 | _ => 0 end.
Set Printing Factorizable Match Patterns.

(* Factorization but no default clause *)
Unset Printing Allow Match Default Clause.
Check fun x => match x with Eq => 1 | _ => 0 end.
Set Printing Allow Match Default Clause.

(* No factorization in printing all mode *)
Set Printing All.
Check fun x => match x with Eq => 1 | _ => 0 end.
Unset Printing All.

(* Several clauses *)
Inductive K := a1|a2|a3|a4|a5|a6.
Check fun x => match x with a3 | a4 => 3 | _ => 2 end.
Check fun x => match x with a3 => 3 | a2 | a1 => 4 | _ => 2 end.
Check fun x => match x with a4 => 3 | a2 | a1 => 4 | _ => 2 end.
Check fun x => match x with a3 | a4 | a1 => 3 | _ => 2 end.

(* Test redundant clause within a disjunctive pattern *)
Fail Check fun n m => match n, m with 0, 0 | _, S _ | S 0, _ | S (S _ | _), _ => false end.


Set Implicit Arguments.

Require Import Coq.Arith.Max.
Require Import decidable_IN.
Require Import sublist.
Require Import language_syntax.

(** * Fresh Constants *)

(** Remember that [constants] play the role of [parameters]. We will
  show that fresh constants are as good as fresh parameters.

  [new] chooses a fresh name which does not belong to a given list
  of constants. *)

Definition new (l:list name) : name := S (fold_right max 0 l).

(** [new] produces a non-zero and fresh name. *)

Lemma new_no_zero : forall (l:list name), new l <> 0.
Proof.
  unfold new; intros; auto with arith.
Qed.

Lemma IN_less : forall (n:name)(l:list name),
  n @ l ->
  n < new l.
Proof.
  unfold new; induction l; simpl; intro H; [elim H | ].
  case_var; auto with arith.
  apply lt_le_trans with (m:= S (fold_right max 0 l)); eauto 2 with arith.
Qed.

Lemma new_fresh : forall l : list name, (new l) # l.
Proof.
  intros l H.
  elim (lt_irrefl (new l)).
  apply IN_less; exact H.
Qed.

(** One can use [new] to choose a fresh name. *)

Lemma fresh_out_t : forall (t : trm),
  (new (oc_t t)) # (oc_t t).
Proof.
  intro t.
  exact (new_fresh (oc_t t)).
Qed.

Lemma fresh_out : forall (A :fml),
  (new (oc A)) # (oc A).
Proof.
  intros A.
  exact (new_fresh (oc A)).
Qed.

Definition fresh_out_c (Ga:context) : name := new (oc_c Ga).

Definition fresh (x:name)(Ga:context) : Prop :=
  x # (oc_c Ga).

Lemma fresh_out_spec : forall (Ga : context),
  fresh (fresh_out_c Ga) Ga.
Proof.
  unfold fresh; unfold fresh_out_c; intros Ga.
  exact (new_fresh (oc_c Ga)).
Qed.

Lemma fresh_fml_peel : forall a A Ga,
  fresh a (A::Ga) ->
  a # (oc A).
Proof.
  unfold fresh; simpl; intros; auto with datatypes.
Qed.

Lemma fresh_peel : forall a A Ga,
  fresh a (A::Ga) ->
  fresh a Ga.
Proof.
  unfold fresh; simpl; intros; auto with datatypes.
Qed.

(** The following two tactics help in dealing with [~ In], especially
  when it argues about fresh names. *)

Ltac destruct_notin :=
  match goal with
    | H : ~ (IN ?decA ?x (?l ++ ?m)) |- _  =>
      destruct (notIN_app_1 decA x l m H); clear H; destruct_notin
    | H : ?x = new ?L |- _ =>
      let Hnew := fresh "Hnew" in
      generalize (new_fresh L); intro Hnew; rewrite <- H in Hnew;
        clear H; destruct_notin
    | x := ?l |- _ =>
      assert (x = l); auto; clearbody x; destruct_notin
    | _ => idtac
  end.

Ltac solve_notin :=
  intros;
  destruct_notin;
  repeat first [ apply notIN_app_2
               | apply notIN_cons_3
               | apply notIN_singleton_1
               | apply notIN_empty_1
               ];
  auto;
  try tauto;
  fail "Not solvable by [solve_notin]; try [destruct_notin]".