(** * StlcProp: Properties of STLC *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(** Typing is preserved under "extensions" to the context [Gamma].
    (Recall the definition of "inclusion" from Maps.v.) *)

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

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

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

(* ================================================================= *)
(** ** A Substitution Lemma *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    You can state your counterexample informally in words, with a brief
    explanation. *)

(* FILL IN HERE *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      Formally: *)

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

Hint Constructors appears_free_in : core.

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

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

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

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

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

(* FILL IN HERE *)

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

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

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

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

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

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

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

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

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

    Complete the following proof. *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(* FILL IN HERE *)

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

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

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

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

and the following typing rule:

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

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

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

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

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

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

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

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

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

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

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

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

    Suppose instead that we remove the rule [ST_App1] from the [step]
    relation. Which of the following properties of the STLC remain
    true in the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

End STLCProp.

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

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

Module STLCArith.
Import STLC.

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

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

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

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

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

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

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

(** **** Exercise: 5 stars, standard (stlc_arith)

    Finish formalizing the definition and properties of the STLC
    extended with arithmetic. This is a longer exercise. Specifically:

    1. Copy the core definitions for STLC that we went through,
        as well as the key lemmas and theorems, and paste them
        into the file at this point. Do not copy examples, exercises,
        etc. (In particular, make sure you don't copy any of the []
        comments at the end of exercises, to avoid confusing the
        autograder.)

        You should copy over five definitions:
          - Fixpoint subst
          - Inductive value
          - Inductive step
          - Inductive has_type
          - Inductive appears_free_in

        And five theorems, with their proofs:
          - Lemma weakening
          - Lemma weakening_empty
          - Lemma substitution_preserves_typing
          - Theorem preservation
          - Theorem progress

        It will be helpful to also copy over "Reserved Notation",
        "Notation", and "Hint Constructors" for these things.

    2. Edit and extend the four definitions (subst, value, step,
        and has_type) so they are appropriate for the new STLC
        extended with arithmetic.

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

(* FILL IN HERE *)

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

End STLCArith.

(* 2021-08-11 15:11 *)


Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import ddT.
Require Import gen_tacs.
Require Import gen_seq.
Require Import List_lemmasT.
Require Import existsT.
Require Import univ_gen_ext.
Require Import dd_fc.

Declare Scope My_scope.
Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Global Parameter V : Set.

Parameter eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* In this file we define two calculi based on multisets for the propositonal intuitionistic modal logic
   iGL. The first one, called GL4ip, is the main calculus for iGL. The second one, named PSGL4ip,
   is essentially the calculus GL4ip with further restrictions on the application of the
   rules. In other words, the calculus PSGL4ip is a proof-search oriented version of GL4ip. *)

(* Definitions Language *)

(* First, let us define the propositional formulae we use here. *)

Inductive MPropF : Type :=
 | Var : V -> MPropF
 | Bot : MPropF
 | And : MPropF -> MPropF -> MPropF
 | Or : MPropF -> MPropF -> MPropF
 | Imp : MPropF -> MPropF -> MPropF
 | Box : MPropF -> MPropF
.

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A → B" := (Imp A B) (at level 16, right associativity) : My_scope.
Notation "A ∨ B" := (Or A B) (at level 16, right associativity) : My_scope.
Notation "A ∧ B" := (And A B) (at level 16, right associativity) : My_scope.
Notation "⊥" := Bot (at level 0)  : My_scope.

Lemma eq_dec_form : forall x y : MPropF, {x = y}+{x <> y}.
Proof.
induction x.
- intros. destruct y.
  * pose (eq_dec_propvar v v0). destruct s. left ; subst ; reflexivity.
    right. intro. inversion H. apply n. assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * left. reflexivity.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n.
    assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n.
    assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n.
    assumption.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx y). destruct s. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption.
Qed.

Fixpoint weight_form (A : MPropF) : nat :=
match A with
 | # P => 1
 | Bot => 1
 | And B C => 2 + (weight_form B) + (weight_form C)
 | Or B C => 1 + (weight_form B) + (weight_form C)
 | Imp B C => 1 + (weight_form B) + (weight_form C)
 | Box B => 1 + (weight_form B)
end.

(* Now, we can define properties of formulae. *)

Definition is_atomicT (A : MPropF) : Type :=
                  (existsT2 (P : V), A = # P) + (A = Bot).

Definition is_boxedT (A : MPropF) : Type :=
                  exists (B : MPropF), A = Box B.

Definition is_boxedT2 (A : MPropF) : Type :=
                  existsT2 (B : MPropF), A = Box B.

Definition is_primeT (A : MPropF) : Type :=
                  is_atomicT A + is_boxedT A.

(* We can define some types of lists formulae. For example, we can define
   lists of formulae which contain only propositional variables, or
   boxed formulae, or a combination of both. These are useful to define
   the rules. *)

Definition is_Atomic (Γ : list (MPropF)) : Prop :=
    forall (A : MPropF), (In A Γ) -> ((exists (P : V), A = # P) \/ (A = ⊥)).

Definition is_Boxed_list (Γ : list (MPropF)) : Prop :=
    forall (A : MPropF), (In A Γ) -> (exists (B : MPropF), A = Box B).

Definition is_Prime (Γ : list (MPropF)) : Prop :=
    forall (A : MPropF), (In A Γ) ->
    (exists (B : MPropF), A = Box B) \/ (exists (P : V), A = # P) \/ (A = ⊥).

(* With these properties we can define restrictions of univ_gen_ext on
   formulae. *)

Definition atom_gen_ext := univ_gen_ext (fun x => (is_atomicT x)).

Definition nobox_gen_ext := univ_gen_ext (fun x => (is_boxedT x) -> False).

Definition prim_gen_ext := univ_gen_ext (fun x => (is_primeT x)).

(* Some lemmas about gen_ext. *)

Lemma nobox_gen_ext_injective : forall (l0 l1 l : list (MPropF)), (is_Boxed_list l0) -> (is_Boxed_list l1) ->
                                (nobox_gen_ext l0 l) -> (nobox_gen_ext l1 l) -> l1 = l0.
Proof.
intros l0 l1 l Hl0 Hl1 gen. generalize dependent l1.
induction gen.
- intros. inversion X. reflexivity.
- intros. inversion X.
  * subst. assert (l0 = l). apply IHgen. intro. intros. apply Hl0. apply in_cons. assumption.
    intro. intros. apply Hl1. apply in_cons. assumption. assumption. rewrite H. reflexivity.
  * subst. exfalso. apply H1. apply Hl0. apply in_eq.
- intros. apply IHgen. intro. intros. apply Hl0. assumption.
  intro. intros. apply Hl1. assumption. inversion X.
  subst. exfalso. apply p. apply Hl1. apply in_eq. subst. assumption.
Qed.

(* The next definitions help to define the combination of a list of boxed
   formulae and the unboxing of all the formulae in that list. *)

Definition unBox_formula (A : MPropF) : MPropF :=
  match A with
              | # P => # P
              | ⊥ => ⊥
              | And A B => And A B
              | Or A B => Or A B
              | Imp A B => Imp A B
              | Box A => A
              end
.

Fixpoint XBoxed_list (Γ : list (MPropF)) : list (MPropF):=
  match Γ with
  | [ ] => [ ]
  | h :: t => (unBox_formula h :: h :: XBoxed_list t)
  end
.

Fixpoint top_boxes (l : list (MPropF)) : list (MPropF) :=
match l with
  | nil => nil
  | h :: t => match h with
                | Box A => (Box A) :: top_boxes t
                | _ => top_boxes t
              end
end.

(* Now that we have defined these, we can prove some properties about them. *)

Lemma XBox_app_distrib :
  forall (l1 l2: list (MPropF)), XBoxed_list (l1 ++ l2) = (XBoxed_list l1) ++ (XBoxed_list l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l with (l:=l2). simpl. reflexivity.
- intro l2. simpl. rewrite IHl1. reflexivity.
Qed.

Lemma subl_of_boxl_is_boxl :
  forall (l1 l2: list (MPropF)), (incl l1 l2) -> (is_Boxed_list l2) -> (is_Boxed_list l1).
Proof.
intros. unfold is_Boxed_list. intros. apply H in H1. apply H0 in H1.
destruct H1. exists x. assumption.
Qed.

Lemma tl_of_boxl_is_boxl :
  forall (h : MPropF) (t l : list (MPropF)) (H: l = h :: t),
         (is_Boxed_list l) -> (is_Boxed_list t).
Proof.
intros. unfold is_Boxed_list. intros. assert (Hyp: In A l).
rewrite H. simpl. right. apply H1. apply H0 in Hyp. destruct Hyp.
exists x. assumption.
Qed.

Lemma list_preserv_XBoxed_list : forall (l : list (MPropF)), incl l (XBoxed_list l).
Proof.
induction l.
- simpl. unfold incl. intros. inversion H.
- simpl. unfold incl. intros. inversion H.
  * subst. apply in_cons. apply in_eq.
  * apply in_cons. apply in_cons. apply IHl. assumption.
Qed.

Lemma is_box_is_in_boxed_list : forall l (A : MPropF), In A l -> is_Boxed_list l -> (exists B, Box B = A).
Proof.
induction l.
- intros. inversion H.
- intros. inversion H.
  + subst. unfold is_Boxed_list in H0. pose (H0 A).
    apply e in H. destruct H. exists x. symmetry. assumption.
  + apply IHl. assumption. unfold is_Boxed_list. intros. unfold is_Boxed_list in H0.
    pose (H0 A0). apply e. apply in_cons. assumption.
Qed.

Lemma top_boxes_distr_app : forall (l1 l2 : list (MPropF)),
      top_boxes (l1 ++ l2) = (top_boxes l1) ++ (top_boxes l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct a ; try apply IHl1.
  simpl. rewrite IHl1. reflexivity.
Qed.

Lemma box_in_top_boxes : forall l1 l2 A, existsT2 l3 l4, top_boxes (l1 ++ Box A :: l2) = l3 ++ Box A :: l4.
Proof.
intros. exists (top_boxes l1). exists (top_boxes l2). rewrite top_boxes_distr_app. auto.
Qed.

Lemma is_Boxed_list_top_boxes : forall l, is_Boxed_list (top_boxes l).
Proof.
intros. induction l.
- simpl. intro. intros. inversion H.
- intro. destruct a.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. destruct H.
    * exists a. auto.
    * apply IHl. assumption.
Qed.

Lemma nobox_gen_ext_top_boxes : forall l, nobox_gen_ext (top_boxes l) l.
Proof.
induction l.
- simpl. apply univ_gen_ext_refl.
- destruct a.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_cons. assumption.
Qed.

Definition Seq := (prod (list (MPropF)) (MPropF)).

(* Finally, we can define the rules which constitute our calculi. We gather
   them in cacluli in a definition appearing later. *)

Inductive IdPRule : rlsT Seq :=
  | IdPRule_I : forall (P : V) (Γ0 Γ1 : list (MPropF)),
          IdPRule [] (pair (Γ0 ++ # P :: Γ1) (# P))
.

Inductive IdRule : rlsT Seq :=
  | IdRule_I : forall A Γ0 Γ1,
          IdRule [] (pair (Γ0 ++ A :: Γ1) A)
.

Inductive BotLRule : rlsT Seq :=
  | BotLRule_I : forall Γ0 Γ1 A,
          BotLRule [] (pair (Γ0 ++ (⊥) :: Γ1) A)
.

Inductive AndRRule : rlsT Seq :=
  | AndRRule_I : forall A B Γ,
          AndRRule [(pair Γ A) ; (pair Γ B)]
                    (pair Γ (And A B))
.

Inductive AndLRule : rlsT Seq :=
  | AndLRule_I : forall A B C Γ0 Γ1,
          AndLRule [(pair (Γ0 ++ A :: B :: Γ1) C)]
                    (pair (Γ0 ++ (And A B) :: Γ1) C)
.

Inductive OrR1Rule : rlsT Seq :=
  | OrR1Rule_I : forall A B Γ,
          OrR1Rule [(pair Γ A)]
                    (pair Γ (Or A B))
.

Inductive OrR2Rule : rlsT Seq :=
  | OrR2Rule_I : forall A B Γ,
          OrR2Rule [(pair Γ B)]
                    (pair Γ (Or A B))
.

Inductive OrLRule : rlsT Seq :=
  | OrLRule_I : forall A B C Γ0 Γ1,
          OrLRule [(pair (Γ0 ++ A :: Γ1) C) ; (pair (Γ0 ++ B :: Γ1) C)]
                    (pair (Γ0 ++ (Or A B) :: Γ1) C)
.

Inductive ImpRRule : rlsT Seq :=
  | ImpRRule_I : forall A B Γ0 Γ1,
          ImpRRule [(pair (Γ0 ++ A :: Γ1) B)]
                    (pair (Γ0 ++ Γ1) (Imp A B))
.

Inductive AtomImpL1Rule  : rlsT Seq :=
  | AtomImpL1Rule_I : forall P A C Γ0 Γ1 Γ2,
          AtomImpL1Rule [(pair (Γ0 ++ # P :: Γ1 ++ A :: Γ2) C)]
                    (pair (Γ0 ++ # P :: Γ1 ++ (Imp (# P) A) :: Γ2) C)
.

Inductive AtomImpL2Rule  : rlsT Seq :=
  | AtomImpL2Rule_I : forall P A C Γ0 Γ1 Γ2,
          AtomImpL2Rule [(pair (Γ0 ++ A :: Γ1 ++ # P :: Γ2) C)]
                    (pair (Γ0 ++ (Imp (# P) A) :: Γ1 ++ # P :: Γ2) C)
.

Inductive AndImpLRule  : rlsT Seq :=
  | AndImpLRule_I : forall A B C D Γ0 Γ1,
          AndImpLRule [(pair (Γ0 ++  (Imp A (Imp B C)) :: Γ1) D)]
                    (pair (Γ0 ++  (Imp (And A B) C) :: Γ1) D)
.

Inductive OrImpLRule  : rlsT Seq :=
  | OrImpLRule_I : forall A B C D Γ0 Γ1 Γ2,
          OrImpLRule [(pair (Γ0 ++ (Imp A C) :: Γ1 ++ (Imp B C) :: Γ2) D)]
                    (pair (Γ0 ++ (Imp (Or A B) C) :: Γ1 ++ Γ2) D)
.

Inductive ImpImpLRule  : rlsT Seq :=
  | ImpImpLRule_I : forall A B C D Γ0 Γ1,
          ImpImpLRule [(pair (Γ0 ++ (Imp B C) :: Γ1) (Imp A B)) ; (pair (Γ0 ++ C :: Γ1) D)]
                    (pair (Γ0 ++ (Imp (Imp A  B) C) :: Γ1) D)
.

Inductive BoxImpLRule  : rlsT Seq :=
  | BoxImpLRule_I : forall A B C BΓ Γ0 Γ1,
          (is_Boxed_list BΓ) -> (* have MS of boxed formulae prem L*)
          (nobox_gen_ext BΓ (Γ0 ++ Γ1)) -> (* extend BΓ in Γ0, the L of the ccl *)
          BoxImpLRule [(pair ((XBoxed_list BΓ) ++ [Box A]) A) ; (pair (Γ0 ++ B :: Γ1) C)]
                    (pair (Γ0 ++ (Imp (Box A) B) :: Γ1) C)
.

Inductive GLRRule : rlsT Seq :=
  | GLRRule_I : forall A BΓ Γ,
          (is_Boxed_list BΓ) -> (* have MS of boxed formulae prem L*)
          (nobox_gen_ext BΓ Γ) -> (* extend BΓ in Γ0, the L of the ccl *)
         GLRRule [(pair ((XBoxed_list BΓ) ++ [Box A]) A)] (pair Γ (Box A))
.

(* At last we can define our calculus GLS and its proof-search version PSGLS. *)

Inductive GL4ip_rules : rlsT  Seq :=
  | IdP : forall ps c, IdPRule ps c -> GL4ip_rules ps c
  | BotL : forall ps c, BotLRule ps c -> GL4ip_rules ps c
  | AndR : forall ps c, AndRRule ps c -> GL4ip_rules ps c
  | AndL : forall ps c, AndLRule ps c -> GL4ip_rules ps c
  | OrR1 : forall ps c, OrR1Rule ps c -> GL4ip_rules ps c
  | OrR2 : forall ps c, OrR2Rule ps c -> GL4ip_rules ps c
  | OrL : forall ps c, OrLRule ps c -> GL4ip_rules ps c
  | ImpR : forall ps c, ImpRRule ps c -> GL4ip_rules ps c
  | AtomImpL1 : forall ps c, AtomImpL1Rule ps c -> GL4ip_rules ps c
  | AtomImpL2 : forall ps c, AtomImpL2Rule ps c -> GL4ip_rules ps c
  | AndImpL : forall ps c, AndImpLRule ps c -> GL4ip_rules ps c
  | OrImpL : forall ps c, OrImpLRule ps c -> GL4ip_rules ps c
  | ImpImpL : forall ps c, ImpImpLRule ps c -> GL4ip_rules ps c
  | BoxImpL : forall ps c, BoxImpLRule ps c -> GL4ip_rules ps c
  | GLR : forall ps c, GLRRule ps c -> GL4ip_rules ps c
.

(* Then, we define PSGL4ip. *)

Inductive PSGL4ip_rules : rlsT  Seq :=
  | PSId : forall ps c, IdRule ps c -> PSGL4ip_rules ps c
  | PSBotL : forall ps c, BotLRule ps c -> PSGL4ip_rules ps c
  | PSAndR : forall ps c, (IdRule [] c -> False) ->
                                      (BotLRule [] c -> False) ->AndRRule ps c -> PSGL4ip_rules ps c
  | PSAndL : forall ps c, (IdRule [] c -> False) ->
                                     (BotLRule [] c -> False) ->AndLRule ps c -> PSGL4ip_rules ps c
  | PSOrR1 : forall ps c, (IdRule [] c -> False) ->
                                      (BotLRule [] c -> False) ->OrR1Rule ps c -> PSGL4ip_rules ps c
  | PSOrR2 : forall ps c, (IdRule [] c -> False) ->
                                      (BotLRule [] c -> False) ->OrR2Rule ps c -> PSGL4ip_rules ps c
  | PSOrL : forall ps c, (IdRule [] c -> False) ->
                                   (BotLRule [] c -> False) -> OrLRule ps c -> PSGL4ip_rules ps c
  | PSImpR : forall ps c, (IdRule [] c -> False) ->
                                     (BotLRule [] c -> False) ->ImpRRule ps c -> PSGL4ip_rules ps c
  | PSAtomImpL1 : forall ps c, (IdRule [] c -> False) ->
                                               (BotLRule [] c -> False) -> AtomImpL1Rule ps c -> PSGL4ip_rules ps c
  | PSAtomImpL2 : forall ps c, (IdRule [] c -> False) ->
                                               (BotLRule [] c -> False) ->AtomImpL2Rule ps c -> PSGL4ip_rules ps c
  | PSAndImpL : forall ps c, (IdRule [] c -> False) ->
                                           (BotLRule [] c -> False) -> AndImpLRule ps c -> PSGL4ip_rules ps c
  | PSOrImpL : forall ps c, (IdRule [] c -> False) ->
                                         (BotLRule [] c -> False) -> OrImpLRule ps c -> PSGL4ip_rules ps c
  | PSImpImpL : forall ps c, (IdRule [] c -> False) ->
                                           (BotLRule [] c -> False) -> ImpImpLRule ps c -> PSGL4ip_rules ps c
  | PSBoxImpL : forall ps c, (IdRule [] c -> False) ->
                                           (BotLRule [] c -> False) -> BoxImpLRule ps c -> PSGL4ip_rules ps c
  | PSGLR : forall ps c, (IdRule [] c -> False) ->
                                    (BotLRule [] c -> False) -> GLRRule ps c -> PSGL4ip_rules ps c
.

Definition GL4ip_prv s := derrec GL4ip_rules (fun _ => False) s.
Definition PSGL4ip_prv s := derrec PSGL4ip_rules (fun _ => False) s.


Require Import Omega.

Require Import big_vs_small.
Require Import bigstep.
Require Import coinduction.
Require Import datatypes.
Require Import MminusNoo.
Require Import Ndiv2oo.
Require Import smallstep.
Require Import streams_vs_lists.
Require Import UndefNoo.

(* Function pminus(m,n) = m-n       if m>=n
                          undefined otherwise

   Example machine: 1 1 -> 1 R
                    1 B -> 2 R
                    2 0 -> 2 R
                    2 1 -> 3 0
                    3 0 -> 3 L
                    3 B -> 4 L
                    4 B -> 4 L
                    4 1 -> 5 B
                    5 B -> 5 R
                    5 0 -> 2 R

Definition pminus: Spec := (1,  one, 1,      R) ::
                           (1,  B  , 2,      R) ::
                           (2, zero, 2,      R) ::
                           (2,  one, 3, W zero) ::
                           (3, zero, 3,      L) ::
                           (3,    B, 4,      L) ::
                           (4,    B, 4,      L) ::
                           (4,  one, 5,    W B) ::
                           (5,    B, 5,      R) ::
                           (5, zero, 2,      R) :: nil.
*)

(************************ Auxiliary objects and properties  ***************)

Lemma zeros_comm2: forall n l,
      (app_ls (zeros n) (Cons zero l)) = (Cons zero (app_ls (zeros n) l)).
induction n; simpl; intros.
reflexivity.
rewrite IHn. reflexivity.
Qed.

Lemma blanks_comm2: forall n l,
      (app_ls (blanks n) (Cons B l)) = (Cons B (app_ls (blanks n) l)).
induction n; simpl; intros.
reflexivity.
rewrite IHn. reflexivity.
Qed.

Lemma blanks_step2: forall n l,
      (Cons B (app_ls (blanks n) l)) = (app_ls (blanks (S n)) l).
simpl. reflexivity.
Qed.

Lemma zeros_step2: forall n l,
      (Cons zero (app_ls (zeros n) l)) = (app_ls (zeros (S n)) l).
simpl. reflexivity.
Qed.

(************************ Convergence proof ************************)

Lemma sf_1: forall m l r,
      sf pminus (pair l (app_ls (ones (S m)) (Cons B r))) 1
                (pair (Cons B (app_ls (ones (S m)) l)) r) 2.
induction m; simpl; intros.

apply sfI with 1 (pair (Cons one l) (Cons B r)).
apply s1R. auto.
apply sfI with 2 (pair (Cons B (Cons one l)) r).
apply s1R. auto.
apply sf0.

apply sfI with 1 (pair (Cons one l) (app_ls (ones (S m)) (Cons B r))).
apply s1R. auto.
rewrite <- ones_comm. replace (Cons one (app_ls (ones m) (Cons one l)))
                      with (app_ls (ones (S m)) (Cons one l)).
apply IHm. auto.
Qed.

Lemma pminus_stops_aux_2to2: forall k l,
      bf pminus (pair l (app_ls (zeros k) Bs)) 2
                (pair (app_ls (zeros k) l) Bs) 2.
induction k; simpl; intros.
apply bfH. unfold is_value. auto.
apply bfR with 2.
auto. simpl.
rewrite <- zeros_comm2. apply IHk.
Qed.

Lemma sf_2: forall k l r,
      sf pminus (pair l (app_ls (zeros k) r)) 2
                (pair (app_ls (zeros k) l) r) 2.
induction k; simpl; intros.
apply sf0.
apply sfI with 2 (pair (Cons zero l) (app_ls (zeros k) r)).
apply s1R. auto.
rewrite <- zeros_comm2. apply IHk.
Qed.

Lemma sf_3: forall k l r,
      sf pminus (pair (app_ls (zeros k) l) (Cons zero r)) 3
                (pair l (app_ls (zeros k) (Cons zero r))) 3.
induction k; simpl; intros.

apply sf0.

apply sfI with 3 (pair (app_ls (zeros k) l) (Cons zero (Cons zero r))).
apply s1L. auto.
rewrite <- zeros_comm2. apply IHk.
Qed.

Lemma sf_4: forall k l r,
      sf pminus (pair (app_ls (blanks k) l) (Cons B r)) 4
                (pair l (app_ls (blanks k) (Cons B r))) 4.
induction k; simpl; intros.

apply sf0.

apply sfI with 4 (pair (app_ls (blanks k) l) (Cons B (Cons B r))).
apply s1L. auto.
rewrite <- blanks_comm2. apply IHk.
Qed.

Lemma sf_5: forall k l r,
      sf pminus (pair l (app_ls (blanks k) r)) 5
                (pair (app_ls (blanks k) l) r) 5.
induction k; simpl; intros.

apply sf0.

apply sfI with 5 (pair (Cons B l) (app_ls (blanks k) r)).
apply s1R. auto.
rewrite <- blanks_comm2. apply IHk.
Qed.

(*
core property: from state 5, in the end you reach state 2 and stop
*)
Lemma pminus_stops_5_B_0: forall n m k,
      m >= n ->
      bf pminus (pair (app_ls (blanks (S (S k))) (app_ls (ones m) Bs))
                      (app_ls (zeros (S k)) (app_ls (ones n) Bs)))
                5
                (pair (app_ls (zeros (n+(S k)))
                              (app_ls (blanks (n+(S (S k))))
                              (app_ls (ones (Init.Nat.sub m n)) Bs)))
                      Bs)
                2.
double induction n m; simpl; intros.

(* m=n=0 *)

apply bfR with 2.
auto. simpl.
rewrite <- zeros_comm2. apply pminus_stops_aux_2to2.

(* m=p+1, n=0 *)

clear H H0.
apply bfR with 2.
auto. simpl.
rewrite <- zeros_comm2. apply pminus_stops_aux_2to2.

(* m=0, n=p+1 *)

omega.

(* m=q+1, n=p+1 *)

clear H. apply bfR with 2.
auto. simpl.
apply sf_to_bf with
      (pair (app_ls (zeros k) (Cons zero (Cons B (Cons B
                    (app_ls (blanks k) (Cons one (app_ls (ones n0) Bs)))))))
            (Cons one (app_ls (ones n1) Bs))) 2.
apply sf_2.

apply bfW with 3 zero.
auto. simpl.
apply sf_to_bf with
      (pair (Cons zero (Cons B (Cons B (app_ls (blanks k)
                       (Cons one (app_ls (ones n0) Bs))))))
            (app_ls (zeros k) (Cons zero (app_ls (ones n1) Bs)))) 3.

apply sf_3.

rewrite zeros_comm2. apply bfL with 3.
auto. simpl. apply bfL with 3.
auto. simpl. apply bfL with 4.
auto. simpl.

apply sf_to_bf with
      (pair (Cons one (app_ls (ones n0) Bs))
            (app_ls (blanks k) (Cons B (Cons B (Cons zero
                    (Cons zero  (app_ls (zeros k)
                    (app_ls (ones n1) Bs)))))))) 4.

apply sf_4.

rewrite blanks_comm. rewrite blanks_comm. simpl.
apply bfL with 4.
auto. simpl. apply bfW with 5 B.
auto. simpl. apply bfR with 5.
auto. simpl. apply bfR with 5.
auto. simpl. apply bfR with 5.
auto. simpl.

apply sf_to_bf with
      (pair (app_ls (blanks k) (Cons B (Cons B (Cons B
                    (app_ls (ones n0) Bs)))))
            (Cons zero (Cons zero (app_ls (zeros k)
                   (app_ls (ones n1) Bs))))) 5.

apply sf_5.

do 3 rewrite blanks_comm. simpl.  rewrite blanks_step2.
rewrite zeros_step2. rewrite (zeros_step2 (n1 + S k)).
assert (S (n1 + S k) = (n1 + S (S k))). omega. rewrite H; clear H.
rewrite (blanks_step2 (n1 + S (S k))).
assert (S (n1 + S (S k)) = (n1 + S (S (S k)))). omega. rewrite H; clear H.
apply H0. omega.
Qed.

Lemma pminus_stops: forall n m,
      m >= n ->
      bf pminus (pair Bs (app_ls (ones (S m))
                                 (Cons B (app_ls (ones (S n)) Bs)))) 1
                (pair (app_ls (zeros (n+1)) (app_ls (blanks (n+2))
                      (app_ls (ones (m-n)) Bs))) Bs) 2.

(*
move from the starting state 1 after the B that separates m and n
*)
intros.
apply sf_to_bf with (pair (Cons B (app_ls (ones (S m)) Bs))
                          (app_ls (ones (S n)) Bs)) 2.
apply sf_1.

(*
mandatory transitions from state 2 to 5, to erase a "1" for both m ed n
*)
simpl. apply bfW with 3 zero.
auto. simpl. apply bfL with 3.
auto. simpl. apply bfL with 4.
auto. simpl. apply bfW with 5 B.
auto. simpl. apply bfR with 5.
auto. simpl. apply bfR with 5.
auto. simpl.

rewrite blanks_step. rewrite blanks_comm.
rewrite zeros_step.
apply pminus_stops_5_B_0. assumption.
Qed.


Require Export Utf8.
Require Export Classical.
Require Export FunctionalExtensionality.
Require Import Arith.
Require Import Lia.
(* coqc -Q FOPL FOPL FOPL/FOPL.v *)

(**)
  Definition f_equal2 : forall (A B C : Type) (f : A -> B -> C) (x0 x1 : A) (y0 y1 : B),
    x0 = x1 -> y0 = y1 -> f x0 y0 = f x1 y1 :=
  fun (A B C : Type) (f : A → B → C) (x0 x1 : A) (y0 y1 : B) (H : x0 = x1) (H0 : y0 = y1) =>
  match H in (_ = x) return (_ = f x _) with
  | eq_refl =>
    match H0 in (_ = x) return (_ = f _ x) with
    | eq_refl => eq_refl
    end
  end.

  Lemma lt_lt_max_l : forall n m r, n < m -> n < max m r.
  Proof.
    unfold lt.
    intros.
    assert (lml := (Nat.le_max_l m r)).
    apply Nat.le_trans with (m := m).
    auto.
    auto.
  Qed.

  Lemma lt_lt_max_r : forall n m r, n < m -> n < max r m.
  Proof.
    unfold lt.
    intros.
    assert (lml := (Nat.le_max_r r m)).
    apply Nat.le_trans with (m := m).
    auto.
    auto.
  Qed.

  Lemma le_le_max_l : forall n m r, n <= m -> n <= max m r.
  Proof.
    intros.
    assert (lml := (Nat.le_max_l m r)).
    apply Nat.le_trans with (m := m).
    auto.
    auto.
  Qed.

  Lemma le_le_max_r : forall n m r, n <= m -> n <= max r m.
  Proof.
    intros.
    assert (lml := (Nat.le_max_r r m)).
    apply Nat.le_trans with (m := m).
    auto.
    auto.
  Qed.

(**)

Class Lang := {fc0 : Type; fc1 : Type; fc2 : Type; pd0 : Type; pd1 : Type; pd2 : Type}.

Inductive Term {L : Lang} :=
| var : nat -> Term
| cns : Term
| Fc0 : fc0 -> Term
| Fc1 : fc1 -> Term -> Term
| Fc2 : fc2 -> Term -> Term -> Term.

Inductive Formula {L : Lang} :=
| eql : Term -> Term -> Formula
| Pd0 : pd0 -> Formula
| Pd1 : pd1 -> Term -> Formula
| Pd2 : pd2 -> Term -> Term -> Formula
| imp : Formula -> Formula -> Formula
| neg : Formula -> Formula
| fal : Formula -> Formula.

Notation "' v " := (var v) (at level 5).
Notation "𝟬" := ('0).
Notation "𝟭" := ('1).
Notation "𝟮" := ('2).
Notation "𝟯" := ('3).
Notation "[O]" := (cns) (at level 0).
Notation "a [=] b" := (eql a b) (at level 60, right associativity).
Notation "p [->] q" := (imp p q) (at level 62, right associativity, q at level 200).
Notation "[~] p" := (neg p) (at level 61, right associativity).
Notation "[fal] p" := (fal p) (at level 66, right associativity).
Notation "[∀] p" := (fal p) (at level 66, right associativity).

Definition andl {L : Lang} p q := neg (imp p (neg q)).
Notation "p [/\] q" := (andl p q) (at level 63, right associativity).
Definition orl {L : Lang}  p q := imp (neg p) q.
Notation "p [\/] q" := (orl p q) (at level 64, right associativity).
Definition iffl {L : Lang} p q := (p[->]q)[/\](q[->]p).
Notation "p [<->] q" := (iffl p q) (at level 65, right associativity, q at level 200).
Definition ext {L : Lang}  p := neg (fal (neg p)).
Notation "[ext] p" := (ext p) (at level 66, right associativity).
Notation "[∃] p" := (ext p) (at level 66, right associativity).
Notation "a [=/=] b" := ([~] a [=] b) (at level 60, no associativity).

Definition slide {A : Type} (s : nat -> A) (n : A) : nat -> A := fun x0 =>
  match x0 with
  | 0 => n
  | S m => s m
  end.

Definition embed {A : Type} (s : nat -> A) (a : A) : nat -> A := fun n =>
  match n with
  | 0 => a
  | _ => s n
  end.

Notation "( n ; s )" := (slide s n) (at level 0).
Notation "( n .; s )" := (embed s n) (at level 0).

Fixpoint rewc {L : Lang} (s : nat -> Term) (c : Term) : Term :=
  match c with
  | var v     => s v
  | cns       => cns
  | Fc0 c     => Fc0 c
  | Fc1 c x   => Fc1 c (rewc s x)
  | Fc2 c x y => Fc2 c (rewc s x) (rewc s y)
  end.

Definition sfc {L : Lang} (c : Term) := rewc (fun x => (var (S x))) c.

Fixpoint rew {L : Lang} (s : nat -> Term) (p0 : Formula) : Formula :=
  match p0 with
  | eql x y   => eql (rewc s x) (rewc s y)
  | Pd0 c     => Pd0 c
  | Pd1 c x   => Pd1 c (rewc s x)
  | Pd2 c x y => Pd2 c (rewc s x) (rewc s y)
  | imp p q   => imp (rew s p) (rew s q)
  | neg p     => neg (rew s p)
  | fal p     => fal (rew ((var 0); fun x => (sfc (s x))) p)
  end.

Notation "p .[ s ]" := (rew s p) (at level 50).
Notation "p .[ n ; s ]" := (p .[(n;s)]) (at level 50).
Notation "\0" := (fun x => (var x)) (at level 0).
Definition sf {L : Lang} (p : Formula) : Formula := p .[fun x => (var (S x))].
Definition alt {L : Lang} (p : Formula) : Formula := p.[fun x => '(pred x)].
Notation "🠙 t" := (sfc t) (at level 5, right associativity).
Notation "🡑 p" := (sf p) (at level 5, right associativity).
Notation "🡓 p" := (alt p) (at level 5, right associativity).
Definition norm {L : Lang} c p := p .[fun x => c].

Notation "p /( x )" := (p .[x;\0]) (at level 50).
Notation "p /( x , y )" := (p .[x; (y; \0)]) (at level 50).
Notation "p /( x , y , z )" := (p .[x; (y; (z; \0))]) (at level 50).
Notation "p //( x )" := (p .[(x.;\0)]) (at level 50).

(** ** Syntax Facts *)
Section basic_facts.
  Variable L : Lang.

  Lemma nested_rewc : forall s0 s1 t, (rewc s1 (rewc s0 t)) = rewc (fun x => rewc s1 (s0 x)) t.
  Proof.
    intros.
    induction t.
    - simpl.
      auto.
    - simpl.
      auto.
    - simpl.
      auto.
    - simpl.
      rewrite IHt.
      auto.
    - simpl.
      rewrite IHt1.
      rewrite IHt2.
      auto.
  Qed.

  Lemma rewcsf_rwec : forall t0 s t, rewc (t0;s) (sfc t) = rewc s t.
  Proof.
    intros. unfold sfc.
    induction t.
    - simpl.
      auto.
    - simpl.
      auto.
    - simpl.
      auto.
    - simpl.
      rewrite IHt.
      auto.
    - simpl.
      rewrite IHt1.
      rewrite IHt2.
      auto.
  Qed.

  Lemma nested_rew : forall p s0 s1, p.[s0].[s1] = p.[fun x => rewc s1 (s0 x)].
  Proof.
    induction p.
    - simpl.
      intros.
      rewrite nested_rewc.
      rewrite nested_rewc.
      auto.
    - simpl.
      auto.
    - simpl.
      intros.
      rewrite nested_rewc.
      auto.
    - simpl.
      intros.
      rewrite nested_rewc.
      rewrite nested_rewc.
      auto.
    - simpl.
      intros.
      rewrite <- IHp1.
      rewrite <- IHp2.
      auto.
    - simpl.
      intros.
      rewrite <- IHp.
      auto.
    - simpl.
      intros.
      rewrite IHp.
      assert (
        (fun x => rewc ((var 0); fun x0 => sfc (s1 x0)) (((var 0); fun x0 => sfc (s0 x0)) x)) =
        ((var 0); fun x => sfc (rewc s1 (s0 x)))
      ).
      + apply functional_extensionality.
        intros.
        destruct x.
        simpl.
        auto.
        simpl.
        rewrite rewcsf_rwec.
        unfold sfc.
        rewrite nested_rewc.
        auto.
      + rewrite H.
        auto.
  Qed.

  Lemma neg_sbs : forall p t, (neg p)/(t) = neg (p/(t)).
  Proof.
    intros.
    simpl.
    auto.
  Qed.

  Lemma fal_eq : forall p q, p = q -> [fal]p = [fal]q.
  Proof.
    intros.
    rewrite <- H.
    reflexivity.
  Qed.

  Lemma rewc_id : forall t, t = rewc \0 t.
  Proof.
    induction t.
    - simpl. auto.
    - simpl. auto.
    - simpl. auto.
    - simpl.
      rewrite <- IHt.
      auto.
    - simpl.
      rewrite <- IHt1.
      rewrite <- IHt2.
      auto.
  Qed.

  Lemma rew_id : forall p, p = p.[\0].
  Proof.
    induction p.
    - simpl.
      rewrite <- rewc_id.
      rewrite <- rewc_id.
      auto.
    - simpl. auto.
    - simpl.
      rewrite <- rewc_id.
      auto.
    - simpl.
      rewrite <- rewc_id.
      rewrite <- rewc_id.
      auto.
    - simpl.
      rewrite <- IHp1.
      rewrite <- IHp2.
      auto.
    - simpl.
      rewrite <- IHp.
      auto.
    - simpl.
      assert (\0 = ((var 0); fun x => sfc (var x))).
      + unfold sfc.
        apply functional_extensionality.
        intros.
        destruct x.
        simpl.
        auto.
        simpl.
        auto.
      + rewrite <- H.
        rewrite <- IHp.
        auto.
  Qed.

  Lemma rewc_sfc : forall t u, t = rewc (u; \0) (sfc t).
  Proof.
    unfold sfc.
    intros.
    rewrite nested_rewc.
    simpl.
    apply rewc_id.
  Qed.

  Lemma alt_sf : forall p, alt (sf p) = p.
  Proof.
    intros.
    unfold alt, sf.
    rewrite nested_rew.
    simpl.
    rewrite rew_id.
    auto.
  Qed.

End basic_facts.

Fixpoint Art {L : Lang} (t0 : Term) : nat :=
  match t0 with
  | var n     => S n
  | cns       => 0
  | Fc0 _     => 0
  | Fc1 _ x   => Art x
  | Fc2 _ x y => max (Art x) (Art y)
  end.

Fixpoint Ar {L : Lang} (p0 : Formula) : nat :=
  match p0 with
  | eql t u   => max (Art t) (Art u)
  | Pd0 _     => 0
  | Pd1 _ x   => Art x
  | Pd2 _ x y => max (Art x) (Art y)
  | imp p q   => max (Ar p) (Ar q)
  | neg p     => Ar p
  | fal p     => pred (Ar p)
  end.

Section rew_facts.
  Variable L : Lang.

  Lemma rewc_rewc : forall t s0 s1, (forall n, n < Art t -> s0 n = s1 n) -> rewc s0 t = rewc s1 t.
  Proof.
    intros.
    induction t.
    - simpl.
      apply H.
      simpl.
      lia.
    - simpl.
      auto.
    - simpl.
      auto.
    - simpl.
      assert (rewc s0 t = rewc s1 t).
      apply IHt.
      intros.
      apply H.
      simpl.
      auto.
      rewrite <- H0.
      auto.
    - simpl.
      assert (rewc s0 t1 = rewc s1 t1).
      apply IHt1.
      intros.
      apply H.
      simpl.
      apply lt_lt_max_l. auto.
      assert (rewc s0 t2 = rewc s1 t2).
      apply IHt2.
      intros.
      apply H.
      simpl.
      apply lt_lt_max_r. auto.
      rewrite <- H0.
      rewrite <- H1.
      auto.
  Qed.

  Lemma rew_rew : forall p s0 s1, (forall n, n < Ar p -> s0 n = s1 n) -> p .[s0] = p .[s1].
  Proof.
    induction p.
    - simpl.
      intros.
      assert (rewc s0 t = rewc s1 t).
      apply rewc_rewc.
      intros.
      apply H.
      apply lt_lt_max_l. auto.
      assert (rewc s0 t0 = rewc s1 t0).
      apply rewc_rewc.
      intros.
      apply H.
      apply lt_lt_max_r. auto.
      rewrite <- H0.
      rewrite <- H1.
      auto.
    - simpl.
      auto.
    - simpl.
      intros.
      assert (rewc s0 t = rewc s1 t).
      apply rewc_rewc.
      intros.
      auto.
      rewrite <- H0.
      auto.
    - simpl.
      intros.
      assert (rewc s0 t = rewc s1 t).
      apply rewc_rewc.
      intros.
      apply H.
      apply lt_lt_max_l. auto.
      assert (rewc s0 t0 = rewc s1 t0).
      apply rewc_rewc.
      intros.
      apply H.
      apply lt_lt_max_r. auto.
      rewrite <- H0.
      rewrite <- H1.
      auto.
    - simpl.
      intros.
      assert (p1 .[s0] = p1 .[s1]).
      + apply IHp1.
        intros.
        apply H.
        apply lt_lt_max_l.
        auto.
      + assert (p2 .[s0] = p2 .[s1]).
        apply IHp2.
        intros.
        apply H.
        apply lt_lt_max_r.
        auto.
      rewrite <- H0.
      rewrite <- H1.
      auto.
    - simpl.
      intros.
      rewrite <- (IHp s0 s1 H).
      auto.
    - simpl.
      intros.
      assert (p .[(var 0); fun x => sfc (s0 x)] = p .[(var 0); fun x => sfc (s1 x)]).
      + apply IHp.
        unfold sfc. intros.
        destruct n.
        simpl. auto.
        simpl.
        assert (s0 n = s1 n).
        * apply H.
          lia.
        * rewrite <- H1.
          auto.
      + rewrite <- H0.
        auto.
  Qed.

  Lemma constant_rew : forall t s, Art t = 0 -> t = rewc s t.
  Proof.
    intros.
    assert ( rewc \0 t = rewc s t).
    - apply rewc_rewc.
      rewrite H.
      lia.
    - rewrite <- H0.
      apply rewc_id.
  Qed.

  Lemma sentence_rew : forall p s, Ar p = 0 -> p = p .[s].
  Proof.
    intros.
    assert (p .[\0] = p .[s]).
    - apply rew_rew.
      rewrite H.
      intros.
      destruct n.
      lia.
      lia.
    - rewrite <- H0.
      apply rew_id.
  Qed.

  Lemma form1_p_ps : forall p s, Ar p = 1 -> (var 0 = s 0) -> p = p .[s].
  Proof.
    intros.
    assert (p .[\0] = p .[s]).
    - apply rew_rew.
      rewrite H.
      intros.
      destruct n.
      auto.
      lia.
    - rewrite <- H1.
      apply rew_id.
  Qed.

  Lemma form2_ps_ps : forall p s0 s1, Ar p = 2 -> (s0 0 = s1 0) -> (s0 1 = s1 1) -> p .[s0] = p .[s1].
  Proof.
    intros.
    apply rew_rew.
    rewrite H.
    intros.
    destruct n.
    auto.
    destruct n.
    auto.
    lia.
  Qed.

  Lemma form3_ps_ps : forall p s0 s1, Ar p = 3 -> (s0 0 = s1 0) -> (s0 1 = s1 1) -> (s0 2 = s1 2) -> p .[s0] = p .[s1].
  Proof.
    intros.
    apply rew_rew.
    intros.
    destruct n. auto.
    destruct n. auto.
    destruct n. auto.
    lia.
  Qed.

  Lemma form3_rw0 : forall p s, Ar p = 3 -> p/(s 0, s 1, s 2) = p .[s].
  Proof.
    intros.
    apply rew_rew.
    rewrite H.
    intros.
    destruct n.
    simpl. auto.
    destruct n.
    simpl. auto.
    destruct n.
    simpl. auto.
    lia.
  Qed.

  Lemma sbs_rew0 : forall p s,
    Ar p = 0 -> p.[s] = p.
  Proof.
    intros.
    rewrite rew_id.
    apply rew_rew.
    intros.
    lia.
  Qed.

  Lemma sbs_rew1 : forall p t s,
    Ar p = 1 -> p/(t).[s] = p/(rewc s t).
  Proof.
    intros.
    rewrite nested_rew.
    apply rew_rew.
    intros.
    destruct n.
    simpl. auto.
    lia.
  Qed.

  Lemma sbs_rew2 : forall p t0 t1 s,
    Ar p = 2 -> p/(t0, t1).[s] = p/(rewc s t0, rewc s t1).
  Proof.
    intros.
    rewrite nested_rew.
    apply rew_rew.
    intros.
    destruct n.
    simpl. auto.
    destruct n.
    simpl. auto.
    lia.
  Qed.

  Lemma sbs_rew3 : forall p t0 t1 t2 s,
    Ar p = 3 -> p/(t0, t1, t2).[s] = p/(rewc s t0, rewc s t1, rewc s t2).
  Proof.
    intros.
    rewrite nested_rew.
    apply rew_rew.
    intros.
    destruct n.
    simpl. auto.
    destruct n.
    simpl. auto.
    destruct n.
    simpl. auto.
    lia.
  Qed.

  Lemma Art_rew_le: forall t s n,
    (forall m, m < Art t -> Art (s m) <= n) ->
    Art (rewc s t) <= n.
  Proof.
    intros.
    induction t.
    - simpl. auto.
    - simpl. lia.
    - simpl. lia.
    - simpl. auto.
    - simpl.
      simpl in H.
      apply Nat.max_lub.
      apply IHt1. intros. apply H. lia.
      apply IHt2. intros. apply H. lia.
  Qed.

  Lemma Ar_rew_le : forall p s n,
    (forall m, m < Ar p -> Art (s m) <= n) -> Ar (p.[s]) <= n.
  Proof.
    assert(le_pred : forall n m, n <= S m -> pred n <= m).
    {intros. lia. }
    induction p.
    - simpl.
      intros.
      apply Nat.max_lub.
      rewrite (Art_rew_le _ _ n). lia. intros. apply H. lia.
      rewrite (Art_rew_le _ _ n). lia. intros. apply H. lia.
    - simpl. lia.
    - simpl.
      intros.
      rewrite (Art_rew_le _ _ n). lia. intros. apply H. lia.
    - simpl.
      intros.
      apply Nat.max_lub.
      rewrite (Art_rew_le _ _ n). lia. intros. apply H. lia.
      rewrite (Art_rew_le _ _ n). lia. intros. apply H. lia.
    - simpl.
      intros.
      apply Nat.max_lub.
      apply IHp1. intros. apply H. lia.
      apply IHp2. intros. apply H. lia.
    - simpl.
      intros.
      apply IHp. intros. apply H. lia.
    - simpl.
      intros.
      unfold sfc.
      apply le_pred.
      apply IHp.
      intros.
      destruct m.
      simpl. lia.
      simpl.
      apply Art_rew_le. simpl.
      intros.
      assert(Art (s m) <= n).
      apply H. lia.
      lia.
  Qed.

  Lemma of_constant : forall p t,
    Ar p <= 1 -> Art t = 0 -> Ar (p/(t)) = 0.
  Proof.
    intros.
    assert(Ar (p/(t)) <= 0).
    apply Ar_rew_le.
    intros.
    destruct m.
    simpl. lia.
    lia.
    lia.
  Qed.

End rew_facts.


Add LoadPath "../Coq".

Require Import Homotopy CWComplexes PushoutNonDep.

Set Implicit Arguments.

Local Arguments transport : default implicits.
Local Arguments map : default implicits.

Definition path_through { A : Type } { x y : A }
 ( p : x == y ) : forall w z : A,
 ( w == x ) -> ( y == z ) -> ( w == z ).
 intros w z q r.
 exact ( q @ p @ r ).
Defined.

Section CylMaps.

  Hypotheses (A B C : Type) ( f : A -> B ) ( g : A -> C ).
  Hypotheses (Q R S : Type) ( h : Q -> R ) ( k : Q -> S ).

  Let Pfg := pushout f g.
  Let Phk := pushout h k.

  Hypotheses ( aq : A -> Q ) ( br : B -> R  ) ( cs : C -> S )
             ( hbr : br o f == h o aq ) ( hcs : cs o g == k o aq ).

  Let from_b : B -> Pfg := (po_from_b f g).
  Let from_c : C -> Pfg := (po_from_c f g).
  Let fg_cyl : from_b o f == from_c o g := pushout_cyl f g.
  Let pt_fg_cyl := happly fg_cyl.

  Let from_r : R -> Phk := (po_from_b h k).
  Let from_s : S -> Phk := (po_from_c h k).
  Let hk_cyl : from_r o h == from_s o k := pushout_cyl h k.
  Let pt_hk_cyl := happly hk_cyl.

  Lemma map_of_pushouts_data : func_data f g  Phk.
  exists (from_r o br, from_s o cs ).
  simpl.
  path_via ( from_r o h o aq ).
  apply (map (compose from_r)).
  exact hbr.
  path_via ( from_s o k o aq ).
  apply (map (fun x => x o aq)).
  apply pushout_cyl.
  apply (map (compose from_s)).
  exact (! hcs).
  Defined.

  Definition map_of_pushouts : Pfg -> Phk := pushout_rec map_of_pushouts_data.
  Let map_of_pushouts_rec_data := global_func_data map_of_pushouts.
  Definition map_of_pushouts_comps := pushout_triv_comps map_of_pushouts_data.

  Definition map_hbr_comp : map_of_pushouts o from_b == from_r o br :=
    map (@fst _ _) (map pr1 map_of_pushouts_comps).

  Definition map_hcs_comp : map_of_pushouts o from_c == from_s o cs :=
    map (@snd _ _) (map pr1 map_of_pushouts_comps).

  Definition map_of_pushouts_cyl_comp :
   transport (fun bc => fst bc o f == snd bc o g)
      (map pr1 map_of_pushouts_comps) (pr2 map_of_pushouts_rec_data)
   ==
   pr2 map_of_pushouts_data := fiber_path map_of_pushouts_comps.

  Definition map_of_pushouts_cylCat_comp :
    ! (map (fun bc => fst bc o f ) (map pr1 map_of_pushouts_comps)) @
      (pr2 map_of_pushouts_rec_data) @
      (map (fun bc => snd bc o g ) (map pr1 map_of_pushouts_comps)) ==
      pr2 map_of_pushouts_data.
  Proof.
    apply (path_through map_of_pushouts_cyl_comp); try auto.
    assert ( h2 := trans_paths ((B -> Phk) * (C -> Phk)) (A -> Phk)
                   (fun bc => fst bc o f)
                   (fun bc => snd bc o g)).
    apply opposite.
    unfold compose in h2.
    unfold compose.
    apply h2.
  Defined.

  Lemma m_o_p_ptwise_comp_cyl : forall a : A,
    !(happly map_hbr_comp (f a)) @ map (map_of_pushouts) (pt_fg_cyl a) @ (happly map_hcs_comp (g a))
  ==
    map from_r (happly hbr a)
         @
    (pt_hk_cyl (aq a))
         @
     ! map from_s (happly hcs a).
  Proof.
    intro.
    assert ( h1 := map (fun x => happly x a) map_of_pushouts_cylCat_comp).
    unfold compose in h1.
    unfold map_of_pushouts_data in h1.
    simpl projT2 in h1.
    unfold happly at 2 in h1.
    apply (path_through h1).
    unfold happly.
    do_concat_map.
    apply concat2.
    apply concat2.
    unfold map_hbr_comp.
     fold map_of_pushouts_data.
     fold Phk.
     set (PR := map pr1 map_of_pushouts_comps).
     unfold compose in PR. fold PR.
     clearbody PR.
     undo_compose_map.
     apply (concat (y :=
      ! map (fun h0 => h0 a) (map (fun bc x => fst bc (f x)) PR))).
     undo_compose_map. apply opposite.
     unfold compose.
     exact (opposite_map _ _ (fun h0 => h0 a) _ _
             (map (fun bc x => fst bc (f x)) PR) ).
     apply opposite.
     apply map_postcompose.
    unfold map_hcs_comp.
     fold map_of_pushouts_data.
     fold Phk.
      set (PR := map pr1 map_of_pushouts_comps).
      unfold compose in PR. fold PR.
     clearbody PR.
     undo_compose_map.
    do_concat_map.
    associate_right.
    apply concat2.
    undo_compose_map.
    unfold compose at 5. assert (w := map_postcompose _ _ from_r hbr a).
    apply (fun x => x @ w).
    unfold happly. undo_compose_map.
    apply concat2.
    unfold pt_hk_cyl. unfold hk_cyl.
    unfold happly.
    undo_compose_map.
    undo_compose_map.
    do_opposite_map.
    exact (opposite_map _ _ ((fun h0 => h0 a) o compose from_s) _ _ hcs).
    assert ( w := map_postcompose _ _ from_s hcs a).
    apply (fun x => x @ w).
    unfold happly. undo_compose_map.
  Defined.

End CylMaps.


Require Import List.
(* why is this import here? *)
Require Import Undecidability.PCP.PCP.

(* A string is a list of symbols. *)
Definition string X := list X.

Module RuleNotation.
Notation "x / y" := (x, y).
End RuleNotation.
Import RuleNotation.

(* A string rewriting system SRS is a list of rules x / y
  such that x rewrites to y. *)
Definition SRS X := list (string X * string X).

(* If u / v is a rewriting rule, then x ++ u ++ y rewrites to x ++ v ++ y. *)
Inductive rew {X : Type} (R : SRS X) : string X -> string X -> Prop :=
  rewB x y u v : In (u / v) R -> rew R (x ++ u ++ y) (x ++ v ++ y).
(* rewt is the reflexive, transitive closure of rew. *)
Inductive rewt {X : Type} (R : SRS X) : string X -> string X -> Prop :=
  rewR z : rewt R z z
| rewS x y z : rew R x y -> rewt R y z -> rewt R x z.

(* String rewriting SR is
  given a string rewriting system R and two strings x and y,
  determine whether x rewrites to y in R. *)
Definition SR : SRS nat * string nat * string nat -> Prop :=
  fun '(R, x, y) => rewt R x y.

Definition swap {X Y} : X * Y -> Y * X := fun '(x,y) => (y,x).

(* Thue system reachability TSR is
  given a string rewriting system R and two strings x and y,
  determine whether x is equivalent to y in R. *)
Definition TSR : SRS nat * string nat * string nat -> Prop :=
    fun '(R, x, y) => rewt (R ++ map swap R) x y.


Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Ropp_0.

Local Open Scope R_scope.

Lemma Rabs_R0 : Rabs R0 = R0.

Proof.
  unfold Rabs.
  destruct (Rcase_abs R0) as [ hl | hr ].
  {
    rewrite Ropp_0.
    reflexivity.
  }
  { reflexivity. }
Qed.


Require Import LC.Util.Fin.
Require Import LC.Util.Vec.
Require Import LC.Util.Star.
Require Import LC.LC.

Definition TRUE {n} : Term n :=
  Lam (Lam (var 1)).

#[export]
Instance TRUE_Const : Const (@TRUE).
Proof.
  constructor; reflexivity.
Defined.

Lemma TRUE_normal {n} :
  @normal n TRUE.
Proof.
  exact I.
Qed.

Definition FALSE {n} : Term n :=
  Lam (Lam (var 0)).

Lemma FALSE_normal {n} :
  @normal n FALSE.
Proof.
  exact I.
Qed.

#[export]
Instance FALSE_Const : Const (@FALSE).
Proof.
  constructor; reflexivity.
Qed.

Lemma TRUE_reds {n} : forall M N : Term n,
  reds (App (App TRUE M) N) M.
Proof.
  intros M N.
  unfold TRUE.
  normal_order.
Qed.

Lemma FALSE_reds {n} : forall M N : Term n,
  reds (App (App FALSE M) N) N.
Proof.
  intros M N.
  unfold FALSE.
  normal_order.
Qed.

#[global]
Opaque TRUE FALSE.


Require Import list_examples.

Definition reverse_code :=
  Push 0::While (Over::nil)
    (Dup 1::Plus1++Load::Swap::Dup 2::Plus1++Store::Swap::nil)
  ::Swap::Drop::Ret::nil.

Inductive reverse_spec : cfg -> (cfg -> Prop) -> Prop :=
  reverse_claim : forall l, fun_claim reverse_spec
  "reverse" reverse_code
    1 (rep_list l) 1 (rep_list (rev l))
 |loop_claim : forall lx lp, loop_claim reverse_spec
  0 reverse_code
    2 (fun p x => rep_list lx x :* rep_list lp p)
    1 (rep_list (rev_append lx lp)).

Lemma reverse_proof : sound stack_step reverse_spec.
Proof. list_solver;
rewrite <- rev_alt in * |-;
list_run. Qed.


Inductive List (A : Type) : Type :=
| Empty : List A
| NonEmpty : NonEmptyList A -> List A

with NonEmptyList (A : Type) : Type :=
| Cons  : A -> List A -> NonEmptyList A.

Arguments Empty    {A}.
Arguments NonEmpty {A} _.
Arguments Cons     {A} _ _.

(** Despite being weird, these lists are equivalent to the ordinary lists. *)

Require List.

Module TheSameAsOrdinary.

Import List.
Import ListNotations.

Fixpoint f {A : Type} (w : List A) : list A :=
match w with
| Empty => []
| NonEmpty (Cons x l) => x :: f l
end.

Fixpoint g {A : Type} (l : list A) : List A :=
match l with
| [] => Empty
| h :: t => NonEmpty (Cons h (g t))
end.

Lemma fg :
  forall {A : Type} (w : List A), g (f w) = w.
Proof.
  fix IH 2.
  destruct w as [| [h t]]; cbn.
    reflexivity.
    rewrite IH. reflexivity.
Qed.

Lemma gf :
  forall {A : Type} (l : list A), f (g l) = l.
Proof.
  induction l as [| h t]; cbn.
    reflexivity.
    rewrite IHt. reflexivity.
Qed.

End TheSameAsOrdinary.

Definition isEmpty {A : Type} (l : List A) : bool :=
match l with
| Empty => true
| NonEmpty _ => false
end.

Definition neisEmpty {A : Type} (ne : NonEmptyList A) : bool :=
  false.

Fixpoint len {A : Type} (l : List A) : nat :=
match l with
| Empty => 0
| NonEmpty ne => nelen ne
end

with nelen {A : Type} (ne : NonEmptyList A) : nat :=
match ne with
| Cons h t => 1 + len t
end.

Fixpoint app {A : Type} (l1 l2 : List A) : List A :=
match l1 with
| Empty => l2
| NonEmpty ne => NonEmpty (neapp ne l2)
end

with neapp {A : Type} (ne : NonEmptyList A) (l : List A) : NonEmptyList A :=
match ne with
| Cons h t => Cons h (app t l)
end.

Fixpoint snoc {A : Type} (x : A) (l : List A) : NonEmptyList A :=
match l with
| Empty => Cons x Empty
| NonEmpty ne => nesnoc x ne
end

with nesnoc {A : Type} (x : A) (ne : NonEmptyList A) : NonEmptyList A :=
match ne with
| Cons h t => Cons h (NonEmpty (snoc x t))
end.

Fixpoint rev {A : Type} (l : List A) : List A :=
match l with
| Empty => Empty
| NonEmpty ne => NonEmpty (nerev ne)
end

with nerev {A : Type} (ne : NonEmptyList A) : NonEmptyList A :=
match ne with
| Cons h t => snoc h (rev t)
end.

Fixpoint map {A B : Type} (f : A -> B) (l : List A) : List B :=
match l with
| Empty => Empty
| NonEmpty n => NonEmpty (nemap f n)
end

with nemap {A B : Type} (f : A -> B) (ne : NonEmptyList A) : NonEmptyList B :=
match ne with
| Cons h l => Cons (f h) (map f l)
end.

Fixpoint filter {A : Type} (p : A -> bool) (l : List A) : List A :=
match l with
| Empty => Empty
| NonEmpty ne => nefilter p ne
end

with nefilter {A : Type} (p : A -> bool) (ne : NonEmptyList A) : List A :=
match ne with
| Cons h t => if p h then NonEmpty (Cons h (filter p t)) else filter p t
end.

Fixpoint join {A : Type} (l : List (List A)) : List A :=
match l with
| Empty => Empty
| NonEmpty ne => nejoin ne
end

with nejoin {A : Type} (ne : NonEmptyList (List A)) : List A :=
match ne with
| Cons h t => app h (join t)
end.

Fixpoint bind {A B : Type} (l : List A) (f : A -> List B) : List B :=
match l with
| Empty => Empty
| NonEmpty ne => nebind ne f
end

with nebind {A B : Type} (ne : NonEmptyList A) (f : A -> List B) : List B :=
match ne with
| Cons h t => app (f h) (bind t f)
end.

Fixpoint replicate (n : nat) {A : Type} (x : A) {struct n} : List A :=
match n with
| 0 => Empty
| S n' => NonEmpty (Cons x (replicate n' x))
end.

Fixpoint take (n : nat) {A : Type} (l : List A) : List A :=
match l with
| Empty => Empty
| NonEmpty ne => netake n ne
end

with netake (n : nat) {A : Type} (ne : NonEmptyList A) : List A :=
match n, ne with
| 0, _ => Empty
| S n', Cons h t => NonEmpty (Cons h (take n' t))
end.

(*
iterate i iter
head, tail i uncons
last, init i unsnoc
*)

Fixpoint drop (n : nat) {A : Type} (l : List A) : List A :=
match l with
| Empty => Empty
| NonEmpty ne => nedrop n ne
end

with nedrop (n : nat) {A : Type} (ne : NonEmptyList A) : List A :=
match n, ne with
| 0, _ => Empty
| S n', Cons h t => drop n' t
end.

Fixpoint nth (n : nat) {A : Type} (l : List A) : option A :=
match l with
| Empty => None
| NonEmpty ne => nenth n ne
end

with nenth (n : nat) {A : Type} (ne : NonEmptyList A) : option A :=
match n, ne with
| 0, Cons h _ => Some h
| S n', Cons _ t => nth n' t
end.

Fixpoint zipWith {A B C : Type} (f : A -> B -> C) (la : List A) (lb : List B) : List C :=
match la, lb with
| Empty, _ => Empty
| _, Empty => Empty
| NonEmpty na, NonEmpty nb => NonEmpty (nezipWith f na nb)
end

with nezipWith {A B C : Type} (f : A -> B -> C)
  (na : NonEmptyList A) (nb : NonEmptyList B) : NonEmptyList C :=
match na, nb with
| Cons ha ta, Cons hb tb => Cons (f ha hb) (zipWith f ta tb)
end.

Lemma app_Empty_r :
  forall {A : Type} (l : List A),
    app l Empty = l.
Proof.
  fix IH 2.
  destruct l as [| [h t]]; cbn.
    reflexivity.
    rewrite IH. reflexivity.
Qed.

Lemma snoc_app :
  forall {A : Type} (l1 l2 : List A) (x : A),
    NonEmpty (snoc x (app l1 l2)) = app l1 (NonEmpty (snoc x l2)).
Proof.
  fix IH 2.
  destruct l1 as [| [h1 t1]]; cbn; intros.
    reflexivity.
    rewrite IH. reflexivity.
Qed.

Lemma rev_app :
  forall {A : Type} (l1 l2 : List A),
    rev (app l1 l2) = app (rev l2) (rev l1).
Proof.
  fix IH 2.
  destruct l1 as [| [h1 t1]]; cbn; intros.
    rewrite app_Empty_r. reflexivity.
    rewrite IH. rewrite snoc_app. reflexivity.
Qed.