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

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

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

Add LoadPath "~/Desktop/CS386L-Programming-Language/plf".
Set Warnings "-notation-overridden,-parsing".
Require Import Maps.
Require Import Smallstep.
Require Import Types.

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

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

    Starting from boolean constants and conditionals, we add three
    things:
        - variables
        - function abstractions
        - application

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

       t ::= x                       variable
           | \x:T1.t2                abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional
*)

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

(** Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

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

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

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

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true]. *)
(**
      - [\x:Bool. \y:Bool. x]

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

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

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].

        As in Coq, application associates to the left -- i.e., this
        expression is parsed as [((\x:Bool. \y:Bool. x) false) true].

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

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

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

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

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

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

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**

      T ::= Bool
          | T1 -> T2

    For example:

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

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

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

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

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

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

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

(** We next formalize the syntax of the STLC. *)

Module STLC.

(* ================================================================= *)
(** ** Types *)

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

(* ================================================================= *)
(** ** Terms *)

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

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

Open Scope string_scope.

(** Some examples... *)

Definition x := "x".
Definition y := "y".
Definition z := "z".

Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

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

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

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

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

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

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

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

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

(** [notB = \x:Bool. if x then false else true] *)

Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

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

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

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

(* ================================================================= *)
(** ** Values *)

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

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

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

(** Third, for abstractions, we have a choice:

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

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

    Our usual way of evaluating expressions in Coq makes the first
    choice -- for example,

         Compute (fun x:bool => 3 + 4)

    yields [fun x:bool => 7].

    Most real-world functional programming languages make the second
    choice -- reduction of a function's body only begins when the
    function is actually applied to an argument.  We also make the
    second choice here. *)

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

Hint Constructors value.

(** Finally, we must consider what constitutes a _complete_ program.

    Intuitively, a "complete program" must not refer to any undefined
    variables.  We'll see shortly how to define the _free_ variables
    in a STLC term.  A complete program is _closed_ -- that is, it
    contains no free variables.

    (Conversely, a term with free variables is often called an _open
    term_.)

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

(* ================================================================= *)
(** ** Substitution *)

(** Now we come to the heart of the STLC: the operation of
    substituting one term for a variable in another term.  This
    operation is used below to define the operational semantics of
    function application, where we will need to substitute the
    argument term for the function parameter in the function's body.
    For example, we reduce

       (\x:Bool. if x then true else x) false

    to

       if false then true else false

    by substituting [false] for the parameter [x] in the body of the
    function.

    In general, we need to be able to substitute some given term [s]
    for occurrences of some variable [x] in another term [t].  In
    informal discussions, this is usually written [ [x:=s]t ] and
    pronounced "substitute [x] with [s] in [t]." *)

(** Here are some examples:

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

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

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

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

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

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

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

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

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

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

(** Here is the definition, informally...

       [x:=s]x               = s
       [x:=s]y               = y                      if x <> y
       [x:=s](\x:T11. t12)   = \x:T11. t12
       [x:=s](\y:T11. t12)   = \y:T11. [x:=s]t12      if x <> y
       [x:=s](t1 t2)         = ([x:=s]t1) ([x:=s]t2)
       [x:=s]true            = true
       [x:=s]false           = false
       [x:=s](if t1 then t2 else t3) =
                       if [x:=s]t1 then [x:=s]t2 else [x:=s]t3
*)

(** ... and formally: *)

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

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

where "'[' x ':=' s ']' t" := (subst x s t).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on _closed_ terms (i.e., terms like [\x:Bool. x] that include
    binders for all of the variables they mention), we can avoid this
    extra complexity here, but it must be dealt with when formalizing
    richer languages. *)

(** For example, using the definition of substitution above to
    substitute the _open_ term [s = \x:Bool. r], where [r] is a _free_
    reference to some global resource, for the variable [z] in the
    term [t = \r:Bool. z], where [r] is a bound variable, we would get
    [\r:Bool. \x:Bool. r], where the free reference to [r] in [s] has
    been "captured" by the binder at the beginning of [t].

    Why would this be bad?  Because it violates the principle that the
    names of bound variables do not matter.  For example, if we rename
    the bound variable in [t], e.g., let [t' = \w:Bool. z], then
    [[x:=s]t'] is [\w:Bool. \x:Bool. r], which does not behave the
    same as [[x:=s]t = \r:Bool. \x:Bool. r].  That is, renaming a
    bound variable changes how [t] behaves under substitution. *)

(** See, for example, [Aydemir 2008] for further discussion
    of this issue. *)

(** **** Exercise: 3 stars (substi_correct)  *)
(** The definition that we gave above uses Coq's [Fixpoint] facility
    to define substitution as a _function_.  Suppose, instead, we
    wanted to define substitution as an inductive _relation_ [substi].
    We've begun the definition by providing the [Inductive] header and
    one of the constructors; your job is to fill in the rest of the
    constructors and prove that the relation you've defined coincides
    with the function given above. *)

Inductive substi (s:tm) (x:string) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  | s_var2 : forall y,
      x <> y -> substi s x (tvar y) (tvar y)
  | s_true :
      substi s x ttrue ttrue
  | s_false :
      substi s x tfalse tfalse
  | s_app: forall t1 t2 t1' t2',
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x (tapp t1 t2) (tapp t1' t2')
  | s_abs1 : forall t1 T,
      substi s x (tabs x T t1) (tabs x T t1)
  | s_abs2 : forall x' t1 t1' T,
      x<>x' ->
      substi s x t1 t1'->
      substi s x (tabs x' T t1) (tabs x' T t1')
  | s_if: forall t1 t1' t2 t2' t3 t3',
      substi s x t1 t1'->
      substi s x t2 t2'->
      substi s x t3 t3'->
      substi s x (tif t1 t2 t3) (tif t1' t2' t3')

  (* FILL IN HERE *)
.
Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
  intros. split.
  - generalize dependent t'. induction t;intros.
    + unfold subst in H. destruct (beq_string x0 s0) eqn:Q;subst.
      * apply beq_string_true_iff in Q. rewrite Q. apply s_var1.
      * apply beq_string_false_iff in Q. constructor. assumption.
    + simpl in H. rewrite<-H. constructor.
      * apply IHt1. reflexivity.
      * apply IHt2. reflexivity.
    + simpl in H. destruct (beq_string x0 s0) eqn:Q; subst.
      * apply beq_string_true_iff in Q. rewrite Q. constructor.
      * apply beq_string_false_iff in Q. constructor. assumption.
        apply IHt. reflexivity.
    + simpl in H. rewrite<-H. constructor.
    + simpl in H. rewrite<-H. constructor.
    + simpl in H. rewrite<-H. constructor.
      * apply IHt1. reflexivity.
      * apply IHt2. reflexivity.
      * apply IHt3. reflexivity.
  - generalize dependent t'. induction t;intros.
    + unfold subst. inversion H;subst.
      * rewrite<-beq_string_refl. reflexivity.
      * rewrite<-beq_string_false_iff in H1. rewrite H1. reflexivity.
    + simpl. inversion H;subst. apply IHt1 in H2. apply IHt2 in H4.
      rewrite H2. rewrite H4. reflexivity.
    + simpl. inversion H;subst.
      * rewrite<-beq_string_refl. reflexivity.
      * rewrite<-beq_string_false_iff in H4. rewrite H4. apply IHt in H5.
        rewrite H5. reflexivity.
    + inversion H;subst. constructor.
    + inversion H;subst. constructor.
    + simpl. inversion H;subst.
      apply IHt1 in H3. apply IHt2 in H5. apply IHt3 in H6.
      subst. reflexivity.
Qed.
(** [] *)

(* ================================================================= *)
(** ** Reduction *)

(** The small-step reduction relation for STLC now follows the
    same pattern as the ones we have seen before.  Intuitively, to
    reduce a function application, we first reduce its left-hand
    side (the function) until it becomes an abstraction; then we
    reduce its right-hand side (the argument) until it is also a
    value; and finally we substitute the argument for the bound
    variable in the body of the abstraction.  This last rule, written
    informally as

      (\x:T.t12) v2 ==> [x:=v2]t12

    is traditionally called "beta-reduction". *)

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

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

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'
*)
(** ... plus the usual rules for conditionals:

                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

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

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

(** Formally: *)

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

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

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

Hint Constructors step.

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

(* ================================================================= *)
(** ** Examples *)

(** Example:

      (\x:Bool->Bool. x) (\x:Bool. x) ==>* \x:Bool. x

    i.e.,

      idBB idB ==>* idB
*)

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

(** Example:

      (\x:Bool->Bool. x) ((\x:Bool->Bool. x) (\x:Bool. x))
            ==>* \x:Bool. x

    i.e.,

      (idBB (idBB idB)) ==>* idB.
*)

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

(** Example:

      (\x:Bool->Bool. x)
         (\x:Bool. if x then false else true)
         true
            ==>* false

    i.e.,

       (idBB notB) ttrue ==>* tfalse.
*)

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl.  Qed.

(** Example:

      (\x:Bool -> Bool. x)
         ((\x:Bool. if x then false else true) true)
            ==>* false

    i.e.,

      idBB (notB ttrue) ==>* tfalse.

    (Note that this term doesn't actually typecheck; even so, we can
    ask how it reduces.)
*)

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl.  Qed.

(** We can use the [normalize] tactic defined in the [Types] chapter
    to simplify these proofs. *)

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

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

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof. normalize.  Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof. normalize.  Qed.

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

Lemma step_example5 :
       tapp (tapp idBBBB idBB) idB
  ==>* idB.
Proof.
  normalize.
Qed.

Lemma step_example5_with_normalize :
       tapp (tapp idBBBB idBB) idB
  ==>* idB.
Proof.
  normalize.
Qed.
(** [] *)

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

(** Next we consider the typing relation of the STLC. *)

(* ================================================================= *)
(** ** Contexts *)

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

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

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

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

(** Following the usual notation for partial maps, we could write [Gamma
    & {{x:T}}] for "update the partial function [Gamma] to also map
    [x] to [T]." *)

Definition context := partial_map ty.

(* ================================================================= *)
(** ** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x \in T

                   Gamma & {{ x --> T11 }} |- t12 \in T12
                   --------------------------------------               (T_Abs)
                     Gamma |- \x:T11.t12 \in T11->T12

                        Gamma |- t1 \in T11->T12
                          Gamma |- t2 \in T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 \in T12

                         --------------------                          (T_True)
                         Gamma |- true \in Bool

                        ---------------------                         (T_False)
                        Gamma |- false \in Bool

       Gamma |- t1 \in Bool    Gamma |- t2 \in T    Gamma |- t3 \in T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 \in T

    We can read the three-place relation [Gamma |- t \in T] as:
    "under the assumptions in Gamma, the term [t] has the type [T]." *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

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

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ================================================================= *)
(** ** Examples *)

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

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

Example typing_example_1' :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof. auto.  Qed.

(** Another example:

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

Example typing_example_2 :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using update_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

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

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

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

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  eapply ex_intro. apply T_Abs. apply T_Abs. apply T_Abs.
  eapply T_App.
  apply T_Var;reflexivity.
  eapply T_App;apply T_Var;reflexivity.
Qed.
(** [] *)

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

    ~ exists T,
        empty |- \x:Bool. \y:Bool, x y \in T.
*)

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

(** **** Exercise: 3 stars, optional (typing_nonexample_3)  *)
(** Another nonexample:

    ~ (exists S, exists T,
          empty |- \x:S. x x \in T).
*)

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

End STLC.

(** $Date: 2017-11-28 15:16:24 -0600 (Tue, 28 Nov 2017) $ *)


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import BinPos Zpower ZArith.
Require Floats PrimFloat.
Require JsAst.JsNumber.

(** Floating point numbers use Flocq binary 64 representation (double precision IEEE 754) *)

Definition float : Set := PrimFloat.float.

(** The following definitions already exist in JsAst.JsNumber *)

Definition float_nan : float := PrimFloat.nan.
Definition float_zero : float := PrimFloat.zero.
Definition float_neg_zero : float := PrimFloat.neg_zero.
Definition float_one : float := PrimFloat.one.
Definition float_neg_one : float := Eval compute in (PrimFloat.opp PrimFloat.one).
Definition float_infinity : float := PrimFloat.infinity.
Definition float_neg_infinity : float := PrimFloat.neg_infinity.

Parameter float_min_value : float.
Parameter float_max_value : float.

(* from JsAst *)
Definition float_from_string : string -> float := JsNumber.from_string.
Definition float_to_string : float -> string := JsNumber.to_string.

Definition float_neg : float -> float := PrimFloat.opp.
Definition float_floor : float -> float := JsNumber.floor.
Definition float_absolute : float -> float := PrimFloat.abs.

Definition float_sign : float -> float := (* Note: This sign function is consistent with Math.sign in JavaScript *)
  fun x => match PrimFloat.classify x with
        | FloatClass.PNormal => float_one
        | FloatClass.NNormal => float_neg_one
        | _ => x
        end.

Definition float_add : float -> float -> float := PrimFloat.add.
Definition float_sub : float -> float -> float := PrimFloat.sub.
Definition float_mult : float -> float -> float := PrimFloat.mul.
Definition float_div : float -> float -> float := PrimFloat.div.

(** The following are additional floating point operations used in Q*cert *)

(** Unary operations *)

Parameter float_sqrt : float -> float. (** TODO exists in Flocq *)
Parameter float_exp : float -> float.
Parameter float_log : float -> float.
Parameter float_log10 : float -> float.
Parameter float_ceil : float -> float.

Definition float_eq : float -> float -> bool := PrimFloat.eqb.

Conjecture float_eq_correct :
  forall f1 f2, (float_eq f1 f2 = true <-> f1 = f2).

Require Import EquivDec.
Lemma float_eq_dec : EqDec float eq.
Proof.
  unfold EqDec.
  intros x y.
  case_eq (float_eq x y); intros eqq.
  + left.
    f_equal.
    apply float_eq_correct in eqq.
    trivial.
  + right; intros eqq2.
    red in eqq2.
    apply float_eq_correct in eqq2.
    congruence.
Defined.

Parameter float_pow : float -> float -> float.
Parameter float_min : float -> float -> float. (** TODO: Check in JavaScript spec what happens for min/max *)
Parameter float_max : float -> float -> float.
Parameter float_ne : float -> float -> bool.
Definition float_lt (n1 n2 : float) := PrimFloat.ltb n1 n2.
Definition float_le : float -> float -> bool := PrimFloat.leb.
Definition float_gt (n1 n2: float) : bool := float_lt n2 n1.
Definition float_ge (n1 n2: float) : bool := float_le n2 n1.

Parameter float_of_int : Z -> float. (** Binary normalize *)
Parameter float_truncate : float -> Z. (** Do like parsing ... *)

Definition float_list_min (l:list float) : float :=
  fold_right (fun x y => float_min x y) float_infinity l.

Definition float_list_max (l:list float) : float :=
  fold_right (fun x y => float_max x y) float_neg_infinity l.

Definition float_list_sum (l:list float) : float :=
  fold_right (fun x y => float_add x y) float_zero l.

Definition float_list_arithmean (l:list float) : float :=
  let ll := List.length l in
  match ll with
  | O => float_zero
  | _ => float_div (float_list_sum l) (float_of_int (Z_of_nat ll))
  end.


Require Import AutoSep.

(** A very basic abstract predicate: pairs of words *)

Module Type PAIR.
  Parameter pair : W -> W -> W -> HProp.

  Axiom pair_extensional : forall a b p, HProp_extensional (pair a b p).

  Axiom pair_fwd : forall a b p,
    pair a b p ===> p =*> a * (p ^+ $4) =*> b.

  Axiom pair_bwd : forall a b p,
    p =*> a * (p ^+ $4) =*> b ===> pair a b p.
End PAIR.

Module Pair : PAIR.
  Open Scope Sep_scope.

  Definition pair (a b p : W) : HProp :=
    p =*> a * (p ^+ $4) =*> b.

  Theorem pair_extensional : forall a b p, HProp_extensional (pair a b p).
    reflexivity.
  Qed.

  Theorem pair_fwd : forall a b p,
    pair a b p ===> p =*> a * (p ^+ $4) =*> b.
    unfold pair; sepLemma.
  Qed.

  Theorem pair_bwd : forall a b p,
    p =*> a * (p ^+ $4) =*> b ===> pair a b p.
    unfold pair; sepLemma.
  Qed.
End Pair.

Import Pair.
Hint Immediate pair_extensional.

Definition firstS : spec := SPEC("p") reserving 0
  Al a, Al b,
  PRE[V] pair a b (V "p")
  POST[R] [| R = a |] * pair a b (V "p").

Definition updSecondS : spec := SPEC("p", "x") reserving 0
  Al a, Al b,
  PRE[V] pair a b (V "p")
  POST[_] pair a (V "x") (V "p").

Definition pair := bmodule "pair" {{
  bfunction "first"("p") [firstS]
    "p" <-* "p";;
    Return "p"
  end with bfunction "second"("p", "x") [updSecondS]
    "p" <- "p" + 4;;
    "p" *<- "x";;
    Return 0
  end
}}.

(*TIME Clear Timing Profile. *)

Definition hints : TacPackage.
  (*TIME idtac "pair:prepare". Time *)
  prepare pair_fwd pair_bwd.
Defined.

Theorem pairOk : moduleOk pair.
  (*TIME idtac "pair:verify". Time *)
  vcgen; abstract sep hints.
Qed.

(*TIME Print Timing Profile. *)


(* Branching directed apartness *)

From bisimulations Require Import prelude.
From bisimulations Require Import system.
From bisimulations Require Import relations.
From bisimulations Require Import paths.

Section DirectedBranchingApart.
Context `{System : system X}.

Notation Downstream_property l R p1 p2 := ((Downstream_property l (LL_RR_coRR_relation p1 p2) R)).
Notation Silent_property R p1 p2 := (Downstream_property silent R p1 p2).
Notation Loud_property R p1 p2 := (Downstream_property loud R p1 p2).

Local Definition SilentRefl_relation (R : relation X) (p q : X) : Prop := sc R p q.
Lemma SilentRefl_relation_closed_implication (R1 R2 : relation X) p q :
  (∀ p q, R1 p q → R2 p q) → SilentRefl_relation R1 p q → SilentRefl_relation R2 p q.
Proof. intros H [|]; [left|right]; eauto. Qed.

Local Definition SilentRefl_property (R : relation X) (p : X) : X → Prop :=
  persistently (SilentRefl_relation R p).
Lemma SilentRefl_property_closed_down (R : relation X) p q1 q2 :
  rtc (can_step silent) q1 q2 → SilentRefl_property R p q1 → SilentRefl_property R p q2.
Proof. eapply persistently_closed_down. Qed.
Lemma SilentRefl_property_closed_implication (R1 R2 : relation X) p q :
  (∀ p q, R1 p q → R2 p q) → SilentRefl_property R1 p q → SilentRefl_property R2 p q.
Proof. intros H. eapply persistently_closed_implication_weak.
  intros q2. by eapply SilentRefl_relation_closed_implication.
Qed.

(* db_dapart a b := a can do something b can't do *)
Inductive db_dapart : X → X → Prop :=
  | SilentBkwd p1 p2 q :
    can_step silent p1 p2 →
    db_dapart p2 q →
    db_dapart p1 q
  | SilentRefl p q :
    SilentRefl_property db_dapart p q →
    db_dapart p q
  | Silent p1 p2 q :
    can_step silent p1 p2 →
    db_dapart q p2 →
    Silent_property db_dapart p1 p2 q →
    db_dapart p1 q
  | Loud p1 p2 q :
    can_step loud p1 p2 →
    Loud_property db_dapart p1 p2 q →
    db_dapart p1 q.
Hint Constructors db_dapart : hints.

Notation sb_a := (sc db_dapart).

Theorem db_dapart_strong_ind :
  ∀ P : X → X → Prop,
    (∀ (p1 p2 q : X),
      can_step silent p1 p2 →
      db_dapart p2 q →
      P p2 q →
      P p1 q) →
    (∀ (p q : X),
      SilentRefl_property (rel_join db_dapart P) p q →
      P p q) →
    (∀ (p1 p2 q : X),
      can_step silent p1 p2 →
      db_dapart q p2 →
      P q p2 →
      Silent_property (rel_join db_dapart P) p1 p2 q →
      P p1 q) →
    (∀ (p1 p2 q : X),
      can_step loud p1 p2 →
      Loud_property (rel_join db_dapart P) p1 p2 q →
      P p1 q) →
    ∀ p1 q1 : X, db_dapart p1 q1 → P p1 q1.
Proof.
  intros P Case1 Case2 Case3 Case4.
  fix IH 3.
  intros p1 q1 H.
  inv H as [p1' p2 q1' Hs_p1_p2 Ha_p2_q1|p1' q1' HQ|p1' p2 q1' Hs_p1_p2 Ha_q1_p2 HQ|p1' p2 q1' Hs_p1_p2 HQ];
    [eapply Case1|eapply Case2|eapply Case3|eapply Case4]; eauto with hints;
    intros q2 Hs_q1_q2; specialize (HQ q2 Hs_q1_q2);
    [destruct HQ; [left|right]; split; eauto|..];
    intros q3 Hs_q2_q3; specialize (HQ q3 Hs_q2_q3);
    (destruct HQ; [left|right]; unfold rel_join, sc in *); eauto;
    (destruct H; [left|right]); eauto.
Qed.

Theorem db_dapart_strong_ind' :
  ∀ P : relation X,
    (∀ (p1 p2 q : X),
      can_step silent p1 p2 →
      P p2 q →
      P p1 q) →
    (∀ (p q : X), SilentRefl_property P p q → P p q) →
    (∀ (p1 p2 q : X),
      can_step silent p1 p2 →
      P q p2 →
      Silent_property P p1 p2 q →
      P p1 q) →
    (∀ (p1 p2 q : X),
      can_step loud p1 p2 →
      Loud_property P p1 p2 q →
      P p1 q) →
    ∀ p1 q1 : X, db_dapart p1 q1 → P p1 q1.
Proof. intros P Case1 Case2 Case3 Case4.
  assert (∀ p q, rel_join db_dapart P p q → P p q) by (unfold rel_join; tauto).
  eapply db_dapart_strong_ind; eauto using SilentRefl_property_closed_implication.
  - intros. eapply Case3; eauto using Downstream_property_closed_implication, LL_RR_coRR_relation_MBRT with hints.
  - intros. eapply Case4; eauto using Downstream_property_closed_implication, LL_RR_coRR_relation_MBRT with hints.
Qed.

Lemma Downstream_property_closed_rel_join {R1 R2 : relation X} {l p1 p2 q1} :
  Downstream_property l (rel_join R1 R2) p1 p2 q1 →
  Downstream_property l R1 p1 p2 q1.
Proof. eapply Downstream_property_closed_implication.
  - eapply LL_RR_coRR_relation_MBRT.
  - unfold rel_join. tauto.
Qed.

Instance db_dapart_extend_backwards_one :
  Proper (can_step silent ==> eq ==> flip impl) db_dapart.
Proof.
  intros p1 p2 Hs_p1_p2 q1 q1' <- Ha_p2_q1.
  eauto with hints.
Qed.

Instance db_dapart_extend_backwards :
  Proper (rtc (can_step silent) ==> eq ==> flip impl) db_dapart.
Proof.
  intros p1 p2 Hs_p1_p2 q1 q2 <-.
  revert Hs_p1_p2. revert p1.
  eapply rtc_ind_l; [done|].
  simpl. unfold impl.
  eauto using db_dapart_extend_backwards_one with hints.
Qed.

Instance db_dapart_extend_forward_one {p1} :
  Proper (can_step silent ==> impl) (db_dapart p1).
Proof.
  intros q1 q2 Hs_q1_q2 H.
  induction H as
    [p1 p2 q1 Hs_p1_p2 Ha_p2_q IHa_q|p1 q1 HQ|p1 p2 q1 Hs_p1_p2 Ha_q_p2 IHa_q1_q2 HQ|p1 p2 q1 Hs_p1_p2 HQ]
    using db_dapart_strong_ind.
  - eauto with hints.
  - eapply SilentRefl. eapply SilentRefl_property_closed_down.
    { by eapply rtc_once. }
    revert HQ. eapply SilentRefl_property_closed_implication.
    clear p1 q1 Hs_q1_q2. by intros p1 q1 [].
  - destruct (HQ _ (rtc_refl _ q1) q2 Hs_q1_q2)
      as [[Ha_p1_q1 IHa_p1_q2]|[[Ha_p2_q2 IHA]|[Ha_q2_p2 IHA]]]; simpl in *.
    + by apply IHa_p1_q2.
    + by eapply db_dapart_extend_backwards_one.
    + eapply Downstream_property_closed_rel_join in HQ.
      eapply Silent; try done.
      eapply Downstream_property_closed_down; eauto using rtc_once.
  - eapply Downstream_property_closed_rel_join in HQ.
    eapply Loud; try done.
    eapply Downstream_property_closed_down; eauto using rtc_once.
Qed.

Instance db_dapart_extend_forward {p1} :
  Proper (rtc (can_step silent) ==> impl) (db_dapart p1).
Proof.
  intros q1.
  eapply rtc_ind_r; [done|].
  intros q2 q3 _ Hs_q2_q3 IH H.
  specialize (IH H).
  by eapply db_dapart_extend_forward_one.
Qed.

End DirectedBranchingApart.


(******************************************************************************)
(**)
(******************************************************************************)
(* zmodZeroType R == an zmodType structure for the unit type                  *)

Require Import Coq.Program.Tactics.
From mathcomp Require Import ssreflect ssrfun eqtype choice.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Set Implicit Arguments.
Unset Strict Implicit.
Open Scope ring_scope.

Declare Scope zmod_scope.

Module zmodZero.
  Section Def.
  Definition zeroAdd := fun _ _ : unit => tt.
  Definition zeroNeg := fun _ : unit => tt.
  Definition zeroAbGroupA : associative zeroAdd. Proof. by []. Qed.
  Definition zeroAbGroupC : commutative zeroAdd. Proof. by []. Qed.
  Definition zeroAbGroup0z : left_id tt zeroAdd. Proof. by case. Qed.
  Definition zeroAbGroupIz : left_inverse tt zeroNeg zeroAdd. Proof. by case. Qed.

  Definition type : zmodType :=
    ZmodType unit (GRing.Zmodule.Mixin zeroAbGroupA zeroAbGroupC zeroAbGroup0z zeroAbGroupIz).
  End Def.
End zmodZero.

Notation zmodZeroType := zmodZero.type.
Canonical zmodZeroType.

Close Scope zmod_scope.
Close Scope ring_scope.


Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.ZArith.BinInt.
Require Import Poulet4.Utils.Maps.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Architecture.Target.
Require Import ProD3.core.Coqlib.
Require Import Hammer.Plugin.Hammer.
Import ListNotations.
Open Scope Z_scope.
Open Scope list_scope.

Definition lift {A B C D : Type} (f : B -> C -> D) (g : A -> B) (h : A -> C) : A -> D :=
  fun (a : A) => f (g a) (h a).

Notation "A `/\ B" := (lift and A B) (at level 80, right associativity).
Notation "A `\/ B" := (lift or A B) (at level 85, right associativity).

Section ExtPred.

Notation ident := string.
Notation path := (list string).
Context {tags_t : Type}.
Context {target : @Target tags_t (@Expression tags_t)}.

(* First define some path arithmetic. *)

Fixpoint is_prefix (p1 : path) (p2 : path) : bool :=
  match p1 with
  | [] => true
  | n :: p1 =>
      match p2 with
      | [] => false
      | m :: p2 =>
          if String.eqb n m then is_prefix p1 p2 else false
      end
  end.

Lemma is_prefix_refl : forall p,
  is_prefix p p = true.
Proof.
  intros.
  induction p.
  - reflexivity.
  - simpl. hauto use: eqb_eq inv: bool.
Qed.

Lemma is_prefix_trans : forall p1 p2 p3,
  is_prefix p1 p2 ->
  is_prefix p2 p3 ->
  is_prefix p1 p3.
Proof.
  induction p1; intros.
  - reflexivity.
  - hfcrush use: eqb_eq unfold: is_prefix, is_true inv: list.
Qed.

Lemma is_prefix_cancel : forall p1 p2 p3,
  is_prefix (p1 ++ p2) (p1 ++ p3) = is_prefix p2 p3.
Proof.
  induction p1; intros.
  - reflexivity.
  - simpl. rewrite eqb_refl. auto.
Qed.

Definition in_scope (p1 : path) (p2 : path) : bool :=
  is_prefix p2 p1.

(* Test whether p is inside one of the scopes in ps. *)
Definition in_scopes (p : path) (ps : list path) : bool :=
  existsb (in_scope p) ps.

Lemma in_scopes_trans : forall p1 p2 ps,
  in_scope p1 p2 ->
  in_scopes p2 ps ->
  in_scopes p1 ps.
Proof.
  induction ps; intros.
  - inv H0.
  - simpl. rewrite Reflect.orE.
    simpl in H0. rewrite Reflect.orE in H0. destruct H0.
    + eauto using is_prefix_trans.
    + auto.
Qed.

Lemma in_scopes_app: forall p ps1 ps2,
    in_scopes p (ps1 ++ ps2) = (in_scopes p ps1 || in_scopes p ps2)%bool.
Proof. intros. unfold in_scopes. apply existsb_app. Qed.

Lemma in_scopes_incl: forall exts exts' q,
    (forall x : path, In x exts' -> In x exts) ->
    is_true (in_scopes q exts') -> is_true (in_scopes q exts).
Proof.
  unfold is_true, in_scopes. intros. rewrite existsb_exists in *.
  destruct H0 as [x [? ?]]. exists x. split; auto.
Qed.

Lemma in_scopes_In: forall ps p, In p ps -> in_scopes p ps.
Proof.
  intros. red. unfold in_scopes. rewrite existsb_exists.
  exists p. split; auto. apply is_prefix_refl.
Qed.

(* We define a kind of ext_pred for extern state, that contains two parts
  ep_pred and ep_paths, with a well-formed condition. If ep_paths = [p1,
  p2, ...], then ep_pred is only relevent with objects in directories of
  p1, p2, ... *)

Record ext_pred_body := mk_ext_pred_body {
  ep_pred :> extern_state -> Prop;
  ep_paths : list path
}.

Definition ep_wellformed_prop (ps : list path) (P : extern_state -> Prop) :=
  forall es es' : extern_state,
    (forall p, is_true (in_scopes p ps) -> PathMap.get p es = PathMap.get p es') ->
    P es -> P es'.

Record ext_pred := mk_ext_pred {
  ep_body :> ext_pred_body;
  ep_wellformed : ep_wellformed_prop (ep_paths ep_body) ep_body
}.

Definition mk_ext_pred' a b c :=
  mk_ext_pred (mk_ext_pred_body a b) c.

(* ep_wellformed_prop lemmas *)

Lemma ep_wellformed_prop_True ps :
  ep_wellformed_prop ps (fun _ => True).
Proof.
  unfold ep_wellformed_prop. auto.
Qed.

Lemma ep_wellformed_prop_and : forall (pred1 pred2 : extern_state -> Prop) ps
  (H_pred1 : ep_wellformed_prop ps pred1)
  (H_pred2 : ep_wellformed_prop ps pred2),
  ep_wellformed_prop ps (lift and pred1 pred2).
Proof.
  sfirstorder.
Qed.

Lemma ep_wellformed_prop_and_app : forall (pred1 pred2 : extern_state -> Prop) ps1 ps2
  (H_pred1 : ep_wellformed_prop ps1 pred1)
  (H_pred2 : ep_wellformed_prop ps2 pred2),
  ep_wellformed_prop (ps1 ++ ps2) (lift and pred1 pred2).
Proof.
  intros. red. setoid_rewrite in_scopes_app.
  hauto b: on.
Qed.

Lemma ep_wellformed_prop_wrap1 : forall ps1 (pred : extern_state -> Prop) ps2
  (H_pred : ep_wellformed_prop ps2 pred),
  (forall p : path, in_scopes p ps2 -> in_scopes p ps1) ->
  ep_wellformed_prop ps1 pred.
Proof.
  sfirstorder.
Qed.

Lemma ep_wellformed_prop_wrap2 : forall ps1 (pred : extern_state -> Prop) ps2
  (H_pred : ep_wellformed_prop ps2 pred),
  forallb (fun p : path => in_scopes p ps1) ps2 ->
  ep_wellformed_prop ps1 pred.
Proof.
  intros.
  eapply ep_wellformed_prop_wrap1; only 1 : eauto.
  intros.
  clear -H H0.
  induction ps2.
  - inv H0.
  - simpl in H. rewrite Reflect.andE in H. destruct H.
    simpl in H0. rewrite Reflect.orE in H0. destruct H0.
    + eauto using in_scopes_trans.
    + auto.
Qed.

Local Program Definition prop (P : Prop) : ext_pred :=
  mk_ext_pred' (fun _ => P) [] _.
Next Obligation.
  unfold ep_wellformed_prop; auto.
Qed.

Local Program Definition singleton (p : path) (eo : extern_object) : ext_pred :=
  mk_ext_pred' (fun es => PathMap.get p es = Some eo) [p] _.
Next Obligation.
  unfold ep_wellformed_prop; intros. rewrite <- H; auto.
  unfold in_scopes, in_scope.
  hauto use: is_prefix_refl, ssrbool.orTb.
Qed.

Local Program Definition and (ep1 ep2 : ext_pred) : ext_pred :=
  mk_ext_pred' (ep_pred ep1 `/\ ep_pred ep2) (ep_paths ep1 ++ ep_paths ep2) _.
Next Obligation.
  repeat intro. unfold lift in *. destruct H0.
  destruct ep1 as [[ep1 epp1] ?H]. destruct ep2 as [[ep2 epp2] ?H]. simpl in *.
  split; [eapply H2 with es | eapply H3 with es]; auto; intros; apply H;
    rewrite in_scopes_app; rewrite Reflect.orE; auto.
Qed.

Local Program Definition or (ep1 ep2 : ext_pred) : ext_pred :=
  mk_ext_pred' (ep_pred ep1 `\/ ep_pred ep2) (ep_paths ep1 ++ ep_paths ep2) _.
Next Obligation.
  repeat intro. unfold lift in *.
  destruct ep1 as [[ep1 epp1] ?H]. destruct ep2 as [[ep2 epp2] ?H]. simpl in *.
  destruct H0; [left; eapply H1 with es | right; eapply H2 with es]; auto; intros; apply H;
    rewrite in_scopes_app; rewrite Reflect.orE; auto.
Qed.

Local Program Definition wrap (ps : list path) (eps : list ext_pred)
  (H : forallb (fun (ep : ext_pred) => forallb (fun p => in_scopes p ps) (ep_paths ep)) eps) : ext_pred :=
  mk_ext_pred' (fold_right (lift Logic.and) (fun _ => True) (map (fun (ep : ext_pred) => ep_pred ep) eps)) ps _.
Next Obligation.
  induction eps.
  - apply ep_wellformed_prop_True.
  - simpl in H. rewrite Reflect.andE in H. destruct H.
    simpl.
    eapply ep_wellformed_prop_and; only 2 : auto.
    eapply ep_wellformed_prop_wrap2; eauto using (ep_wellformed a).
Qed.

Local Program Definition ex [A] (ep : A -> ext_pred) (ps : list path)
  (H : forall (x : A), forallb (fun p => in_scopes p ps) (ep_paths (ep x))) : ext_pred :=
  mk_ext_pred' (fun es => exists (x : A), (ep x) es) ps _.
Next Obligation.
  unfold ep_wellformed_prop; intros.
  destruct H1. exists x.
  specialize (H x).
  eapply ep_wellformed_prop_wrap2; eauto using (ep_wellformed (ep x)).
Qed.

Local Program Definition all [A] (ep : A -> ext_pred) (ps : list path)
  (H : forall (x : A), forallb (fun p => in_scopes p ps) (ep_paths (ep x))) : ext_pred :=
  mk_ext_pred' (fun es => forall (x : A), (ep x) es) ps _.
Next Obligation.
  unfold ep_wellformed_prop; intros.
  specialize (H1 x).
  specialize (H x).
  eapply ep_wellformed_prop_wrap2; eauto using (ep_wellformed (ep x)).
Qed.

(* Two ext_pred's are equivalent if their content predicates are the same. *)
Local Definition equiv (ep1 ep2 : ext_pred) : Prop :=
  ep_pred ep1 = ep_pred ep2.

Global Add Parametric Relation : ext_pred equiv
  reflexivity proved by (fun ep => eq_refl (ep_pred ep))
  symmetry proved by (fun ep1 ep2 => eq_sym (x := ep_pred ep1) (y := ep_pred ep2))
  transitivity proved by (fun ep1 ep2 ep3 => eq_trans (x := ep_pred ep1) (y := ep_pred ep2) (z := ep_pred ep3))
  as equiv_rel.

(* Current ununsed, but looks good to have. *)
Add Parametric Morphism : ep_pred with
  signature equiv ==> eq as ep_pred_mor.
Proof. auto. Qed.

Lemma forallb_Forall {A} : forall f (l : list A),
  forallb f l -> Forall (fun x => f x) l.
Proof.
  induction l; intros.
  - constructor.
  - simpl in H.
    destruct (f a) eqn:?H.
    2 : inversion H.
    destruct (forallb f l) eqn:?H.
    2 : inversion H.
    constructor; auto.
Qed.

Lemma forallb_Forall' {A} {d : Inhabitant A} : forall f (l : list A),
  ~~forallb f l -> exists i, 0 <= i < Zlength l /\ ~~f (Znth i l).
Proof.
  induction l; intros.
  - inv H.
  - simpl in H.
    destruct (f a) eqn:?H.
    2 : {
      assert (~~f a) by hauto.
      exists 0. list_solve.
    }
    destruct (forallb f l) eqn:?H.
    1 : inv H.
    destruct (IHl ltac:(intuition)) as [i []].
    exists (i + 1); list_solve.
Qed.

(* TODO give a name for forallb (fun p : path => in_scopes p ps1) ps2 *)

Lemma in_scopes_split : forall ps1 ps2 ps3 ps4,
  forallb (fun p : path => in_scopes p ps1) ps3 ->
  forallb (fun p : path => in_scopes p ps2) ps4 ->
  forallb (fun p : path => in_scopes p (ps1 ++ ps2)) (ps3 ++ ps4).
Proof.
  intros.
  apply forallb_Forall in H.
  apply forallb_Forall in H0.
  rewrite forallb_app, Reflect.andE; split.
  - replace (forallb (fun p : path => in_scopes p (ps1 ++ ps2)) ps3) with true. 2 : {
      symmetry. apply <- forallb_forall.
      intros. rewrite in_scopes_app.
      replace (in_scopes x ps1) with true by list_solve.
      auto.
    }
    auto.
  - replace (forallb (fun p : path => in_scopes p (ps1 ++ ps2)) ps4) with true. 2 : {
      symmetry. apply <- forallb_forall.
      intros. rewrite in_scopes_app.
      replace (in_scopes x ps2) with true by list_solve.
      hauto b:on.
    }
    auto.
Qed.

Lemma in_scopes_refl : forall ps,
  forallb (fun p : path => in_scopes p ps) ps.
Proof.
  induction ps; intros; auto.
  change (a :: ps) with ([a] ++ ps).
  apply in_scopes_split; auto.
  cbn. unfold in_scope. rewrite is_prefix_refl. auto.
Qed.

Lemma ex_and_l : forall {A} (ep1 : A -> ext_pred) ps H ep2,
  ExtPred.equiv
    (ExtPred.and (ExtPred.ex ep1 ps H) ep2)
    (ExtPred.ex (fun x => ExtPred.and (ep1 x) ep2) (ps ++ ep_paths ep2) (fun x => in_scopes_split _ _ _ _ (H x) (in_scopes_refl _))).
Proof.
  intros. red. simpl. clear H.
  apply functional_extensionality; intros.
  apply prop_ext.
  sauto.
Qed.

Lemma ex_and_r : forall {A} ep1 (ep2 : A -> ext_pred) ps H,
  ExtPred.equiv
    (ExtPred.and ep1 (ExtPred.ex ep2 ps H))
    (ExtPred.ex (fun x => ExtPred.and ep1 (ep2 x)) (ep_paths ep1 ++ ps) (fun x => in_scopes_split _ _ _ _ (in_scopes_refl _) (H x))).
Proof.
  intros. red. simpl. clear H.
  apply functional_extensionality; intros.
  apply prop_ext.
  sauto.
Qed.

End ExtPred.


Require Import ssreflect.
Set Bullet Behavior "Strict Subproofs".

Generalizable All Variables.

Require Import Unicode.Utf8 Program.Equality Program.Basics omega.Omega Logic.FunctionalExtensionality.
From ctt Require Import Axioms Var Program Expression Elaborate Tower Closure Sequent.

From ctt Require Theorems.
Module Th := Theorems.

Open Scope program_scope.

Lemma cons_weak_simple {Λ κ} {κs : Env.t Λ} :
  κ ∷ κs ∘ (^1)%ren = κs.
Proof.
  rewrite /compose.
  T.eqcd => x.
  by simplify_eqs.
Qed.

Hint Rewrite @cons_weak_simple : syn_db.
Hint Rewrite <- @elab_ctx_clk_naturality @elab_tm_clk_naturality @elab_tm_var_naturality @elab_tm_var_ren_naturality @elab_tm_ren_naturality @elab_tm_subst_naturality : syn_db.
Hint Unfold compose : syn_db.

Local Hint Extern 40 => autorewrite with syn_db; Program.simplify_subst.
Local Hint Extern 20 => Th.Univ.tac.

Local Hint Resolve Th.General.ty_eq_refl_left Th.General.ty_eq_trans Th.General.ty_eq_symm Th.General.mem_eq_trans Th.General.mem_eq_symm Th.General.env_eq_refl_left Th.General.env_eq_symm Th.General.open_mem_eq_refl_left Th.General.open_ty_eq_refl_left.

Module Conversion.
  Theorem refl {Λ Ψ M} :
    ⟦ Λ ∣ Ψ ⊢ M ≃ M ⟧.
  Proof.
    move=> κs γ V.
    split; eauto.
  Qed.

  Theorem symm {Λ Ψ M1 M2} :
    ⟦ Λ ∣ Ψ ⊢ M1 ≃ M2 ⟧
    → ⟦ Λ ∣ Ψ ⊢ M2 ≃ M1 ⟧.
  Proof.
    move=> D κs γ V.
    specialize (D κs γ V).
    intuition.
  Qed.

  Theorem trans {Λ Ψ M1 M2 M3} :
    ⟦ Λ ∣ Ψ ⊢ M1 ≃ M2 ⟧
    → ⟦ Λ ∣ Ψ ⊢ M2 ≃ M3 ⟧
    → ⟦ Λ ∣ Ψ ⊢ M1 ≃ M3 ⟧.
  Proof.
    move=> 𝒟 ℰ κs γ V.
    specialize (𝒟 κs γ V).
    specialize (ℰ κs γ V).
    intuition.
  Qed.

  Theorem fst_of_pair {Λ Ψ M1 M2} :
    ⟦ Λ ∣ Ψ ⊢ ⟨M1, M2⟩ .1 ≃ M1 ⟧.
  Proof.
    move=> κs γ V.
    split; move=> [𝒟1 𝒟2].
    - split; auto.
      dependent destruction 𝒟1.
      + OpSem.destruct_evals.
      + dependent destruction H.
        * OpSem.destruct_evals.
        * eauto.
    - split; auto; simpl.
      econstructor.
      + apply: OpSem.step_fst_pair.
      + auto.
  Qed.

  Theorem kapp_of_klam {Λ Ψ M k} :
    ⟦ Λ ∣ Ψ ⊢ Expr.kapp (Expr.klam M) k ≃ (M.⦃Ren.inst0 k⦄) ⟧.
  Proof.
    move=> κs γ V.
    split; move=> [𝒟1 𝒟2].
    - split; auto.
      dependent destruction 𝒟1.
      + OpSem.destruct_evals.
      + dependent destruction H.
        * OpSem.destruct_evals.
        * T.use 𝒟1; simplify_subst.
          dependent destruction x; eauto.
    - split; auto; simpl.
      econstructor.
      + apply: OpSem.step_kapp_klam.
      + T.use 𝒟1; simplify_subst.
        dependent destruction x; eauto.
  Qed.
End Conversion.

Module General.
  Theorem hypothesis `{Γ : ECtx.t Λ Ψ} {A} :
    ⟦ Λ ∣ Γ ∙ A ≫ A.[^1] ∋ @0 ≐ @0 ⟧.
  Proof.
    move=> κs Γctx ty γ0 γ1 γ01.
    case: γ01 => [_ γ01].
    auto.
  Qed.

  (* TODO: fix notation ? *)
  Theorem weakening `{Γ : ECtx.t Λ Ψ} i {A B M0 M1} :
    ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ∙ B ≫ (A.[^1]) ∋ (M0.[^1]) ≐ (M1.[^1]) ⟧.
  Proof.
    move=> 𝒟 ℰ κs ℱ 𝒢 γ0 γ1 γ01.
    repeat rewrite -elab_tm_var_ren_naturality.
    simplify_subst.
    apply: 𝒟.
    - by case: ℱ.
    - Th.Univ.tac.
      apply: ℰ; eauto.
      by case: ℱ.
    - by case: γ01.
  Qed.

  Theorem conv_mem `{Γ : ECtx.t Λ Ψ} {A M00} M01 {M1} :
    ⟦ Λ ∣ Ψ ⊢ M00 ≃ M01 ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ M01 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ M00 ≐ M1 ⟧.
  Proof.
    move=> 𝒟 ℰ ? ? ? ? ? ?.
    apply: Th.General.mem_eq_conv.
    - move=> ?; edestruct 𝒟; eassumption.
    - apply: ℰ; eauto.
  Qed.

  Theorem conv_ty `{Γ : ECtx.t Λ Ψ} A1 {A0 M0 M1} :
    ⟦ Λ ∣ Ψ ⊢ A0 ≃ A1 ⟧
    → ⟦ Λ ∣ Γ ≫ A1 ∋ M0 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ A0 ∋ M0 ≐ M1 ⟧.
  Proof.
    move=> 𝒟 ℰ κs ? ? ? ? ?.
    apply: Th.General.mem_eq_conv_ty.
    - move=> ?; edestruct 𝒟; eauto.
    - apply: ℰ; eauto.
      move=> ? ? ?.
      apply: Th.General.ty_eq_conv.
      + move=> ?; edestruct 𝒟; eassumption.
      + apply: Th.General.ty_eq_symm.
        apply: Th.General.ty_eq_conv.
        * move=> ?; edestruct 𝒟; eassumption.
        * eauto.
  Qed.

  Theorem eq_symm `{Γ : ECtx.t Λ Ψ} {A M0 M1} :
    ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ M1 ≐ M0 ⟧.
  Proof.
    move=> 𝒟 κs Γctx ℰ γ0 γ1 γ01.
    apply: Th.General.mem_eq_symm.
    apply: Th.General.replace_ty_in_mem_eq; eauto.
    apply: 𝒟; eauto.
    by apply: Th.General.env_eq_symm.
  Qed.

  Theorem eq_trans `{Γ : ECtx.t Λ Ψ} {A M0 M1 M2} :
    ⟦ Λ ∣ Γ ≫ A ∋ M1 ≐ M2 ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M2 ⟧.
  Proof.
    move=> 𝒟 ℰ ? ? ? ? ? ?.
    apply: Th.General.mem_eq_trans; auto.
    - apply: 𝒟; eauto.
    - apply: ℰ; eauto.
      apply: Th.General.env_eq_refl_left; eauto.
  Qed.

  Theorem eq_refl_left `{Γ : ECtx.t Λ Ψ} {A M0 M1} :
    ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M0 ⟧.
  Proof.
    move=> 𝒟.
    apply: eq_trans.
    - apply: eq_symm.
      eassumption.
    - eassumption.
  Qed.

  Theorem replace_ty `{Γ : ECtx.t Λ Ψ} i {A0 A1 M1 M2} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ Λ ∣ Γ ≫ A0 ∋ M1 ≐ M2 ⟧
    → ⟦ Λ ∣ Γ ≫ A1 ∋ M1 ≐ M2 ⟧.
  Proof.
    move=> 𝒟 ℰ κs ℱ _ ? ? ?.
    apply: Th.General.replace_ty_in_mem_eq.
    - apply: ℰ; [eauto | | eauto].
      apply: Th.General.open_ty_eq_refl_left.
      + assumption.
      + apply: Th.Univ.open_inversionω; eauto.
    - apply: Th.Univ.inversionω.
      apply: 𝒟; eauto.
      apply: Th.General.env_eq_refl_left; eauto.
  Qed.

  Theorem mem_conv_all `{Γ : ECtx.t Λ Ψ} A' M0' M1' {A M0 M1} :
    ⟦ Λ ∣ Ψ ⊢ A ≃ A' ⟧
    → ⟦ Λ ∣ Ψ ⊢ M0 ≃ M0' ⟧
    → ⟦ Λ ∣ Ψ ⊢ M1 ≃ M1' ⟧
    → ⟦ Λ ∣ Γ ≫ A' ∋ M0' ≐ M1' ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M1 ⟧.
  Proof.
    move=> *.
    apply: conv_ty; eauto.
    apply: conv_mem; eauto.
    apply: eq_symm.
    apply: conv_mem; eauto.
    by apply: eq_symm.
  Qed.

  Theorem univ_formation i j `{Γ : ECtx.t Λ Ψ} :
    i < j
    → ⟦ Λ ∣ Γ ≫ 𝕌[j] ∋ 𝕌[i] ≐ 𝕌[i] ⟧.
  Proof.
    move=> ? ? ? ? ? ? ? //=.
    apply: Th.Univ.intro.
    apply: Th.Univ.formation_lvl.
    assumption.
  Qed.
End General.

Module Unit.
  Theorem ax_equality `{Γ : ECtx.t Λ Ψ} :
    ⟦ Λ ∣ Γ ≫ 𝟙 ∋ ★ ≐ ★ ⟧.
  Proof.
    move=> ? ? ? ? ? ?.
    apply: Th.Unit.ax_equality.
  Qed.
End Unit.

Module Bool.
  Theorem univ_eq `{Γ : ECtx.t Λ Ψ} i :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ 𝟚 ≐ 𝟚 ⟧.
  Proof.
    move=> ? ? ? ? ? ?.
    Th.Bool.tac.
  Qed.

  Theorem tt_equality `{Γ : ECtx.t Λ Ψ} :
    ⟦ Λ ∣ Γ ≫ 𝟚 ∋ Expr.tt ≐ Expr.tt ⟧.
  Proof.
    move=> ? ? ? ? ? ?.
    Th.Bool.tac.
  Qed.

  Theorem ff_equality `{Γ : ECtx.t Λ Ψ} :
    ⟦ Λ ∣ Γ ≫ 𝟚 ∋ Expr.ff ≐ Expr.ff ⟧.
  Proof.
    move=> ? ? ? ? ? ?.
    Th.Bool.tac.
  Qed.
End Bool.

Module Arr.
  Theorem univ_eq `{Γ : ECtx.t Λ Ψ} i {A0 A1 B0 B1} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ Λ ∣ Γ ∙ A0 ≫ 𝕌[i] ∋ B0 ≐ B1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ (A0 ⇒ B0) ≐ (A1 ⇒ B1) ⟧.
  Proof.
    move=> 𝒟 ℰ κs ℱ 𝒢 γ0 γ1 γ01 //=.
    apply: Th.Arr.univ_eq.
    - by apply: 𝒟.
    - move=> ? ? //= [_ ℋ] //=.
      simplify_subst.
      T.efwd ℰ.
      + T.use ℰ; eauto.
      + split; [T.use γ01 | T.use ℋ]; eauto.
      + eauto.
      + split; first by assumption.
        apply: Th.General.open_ty_eq_refl_left.
        * assumption.
        * apply: Th.Univ.open_inversionω.
          eauto.
  Qed.

  Theorem intro `{Γ : ECtx.t Λ Ψ} {i A B f0 f1} :
    ⟦ Λ ∣ Γ ∙ A ≫ B ∋ f0 ≐ f1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ∙ A ≫ 𝕌[i] ∋ B ≐ B ⟧
    → ⟦ Λ ∣ Γ ≫ (A ⇒ B) ∋ 𝛌{ f0 } ≐ 𝛌{f1} ⟧.
  Proof.
    move=> 𝒟 ℰ ℱ κs 𝒢 ℋ γ0 γ1 γ01 //=.
    apply: Th.Arr.intro.
    - move=> ? ? //= [_ ℐ] //=.
      simplify_subst.
      T.efwd 𝒟.
      + T.use 𝒟; eauto.
      + split; [T.use γ01 | T.use ℐ]; eauto.
      + apply: Th.Univ.open_inversionω.
        apply: ℱ; auto.
      + split; first by assumption.
        apply: Th.Univ.open_inversionω.
        apply: ℰ; auto.
    - apply: Th.Univ.inversion.
      apply: ℰ; auto.
      apply: Th.General.env_eq_refl_left; eauto.
    - apply: Th.Univ.open_inversion.
      + move=> ? ? γ01' //=.
        simplify_subst.
        apply: ℱ; auto.
        * split; auto.
          apply: Th.Univ.open_inversionω.
          eauto.
        * suff γ00 : τω ⊧ ∥Γ∥ κs ∋⋆ γ0 ∼ γ0.
          ** split; simpl.
             *** T.use γ00; eauto.
             *** case: γ01' => //= _ ℐ.
                 T.use ℐ; eauto.
          ** apply: Th.General.env_eq_refl_left; eauto.
  Qed.

  Theorem elim `{Γ : ECtx.t Λ Ψ} {i A B f0 f1 M0 M1} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ∙ A ≫ 𝕌[i] ∋ B ≐ B ⟧
    → ⟦ Λ ∣ Γ ≫ (A ⇒ B) ∋ f0 ≐ f1 ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ (B ⫽ Sub.inst0 M0) ∋ (f0 ⋅ M0) ≐ (f1 ⋅ M1) ⟧.
  Proof.
    move=> 𝒟 ℰ ℱ 𝒢 κs ℋ ℐ γ0 γ1 γ01.
    autorewrite with syn_db; simpl.
    replace
      ((∥B∥ κs) ⫽ (γ0 ◎ (∥Sub.inst0 M0∥ κs)))%prog
      with ((∥B∥ κs) ⫽ Sub.cong γ0 ⫽ Sub.inst0 ((∥M0∥ κs) ⫽ γ0))%prog.
    - apply: Th.Arr.elim.
      + apply: Th.Univ.inversion.
        apply: 𝒟; eauto.
        apply: Th.General.env_eq_refl_left; eauto.
      + apply: Th.Univ.open_inversion.
        * move=> ? ? //= [_ 𝒥].
          T.efwd ℰ.
          ** T.use ℰ; auto.
          ** suff γ00 : τω ⊧ ∥Γ∥ κs ∋⋆ γ0 ∼ γ0.
             *** split; [T.use γ00 | T.use 𝒥]; eauto.
             *** apply: Th.General.env_eq_refl_left; eauto.
          ** eauto.
          ** split; auto.
             apply: Th.Univ.open_inversionω.
             apply: 𝒟; auto.
      + apply: ℱ; auto.
        apply: Th.Univ.open_inversionω.
        apply: univ_eq; eauto.
      + apply: 𝒢; auto.
        apply: Th.Univ.open_inversionω.
        eauto.
    - simplify_subst.
      dependent induction x; auto.
  Qed.
End Arr.

Module Prod.
  Theorem univ_eq `{Γ : ECtx.t Λ Ψ} i {A0 A1 B0 B1} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ Λ ∣ Γ ∙ A0 ≫ 𝕌[i] ∋ B0 ≐ B1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ (A0 × B0) ≐ (A1 × B1) ⟧.
  Proof.
    move=> 𝒟 ℰ κs Γctx ℱ γ0 γ1 γ01 //=.
    apply: Th.Prod.univ_eq.
    - by apply: 𝒟.
    - move=> ? ? [_ 𝒢] //=.
      simplify_subst.
      T.efwd ℰ.
      + T.use ℰ; eauto.
      + split; [T.use γ01 | T.use 𝒢]; eauto.
      + eauto.
      + split; first by assumption.
        apply: Th.General.open_ty_eq_refl_left.
        * assumption.
        * apply: Th.Univ.open_inversionω.
          eauto.
  Qed.

  Lemma subst `{Γ : Prectx Ψ} {A B0 B1 M0 M1} :
    τω ⊧ Γ ∙ A ≫ B0 ∼ B1
    → τω ⊧ Γ ≫ A ∋ M0 ∼ M1
    → τω ⊧ Γ ≫ (B0 ⫽ Sub.inst0 M0) ∼ (B1 ⫽ Sub.inst0 M1).
  Proof.
    move=> 𝒟 ℰ γ0 γ1 γ01.
    simplify_subst.
    apply: 𝒟.
    split; eauto.
  Qed.

  Theorem intro `{Γ : ECtx.t Λ Ψ} {i A B M00 M01 M10 M11} :
    ⟦ Λ ∣ Γ ≫ A ∋ M00 ≐ M10 ⟧
    → ⟦ Λ ∣ Γ ≫ B ⫽ Sub.inst0 M00 ∋ M01 ≐ M11 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ∙ A ≫ 𝕌[i] ∋ B ≐ B ⟧
    → ⟦ Λ ∣ Γ ≫ A × B ∋ ⟨M00, M01⟩ ≐ ⟨M10, M11⟩ ⟧.
  Proof.
    move=> 𝒟 ℰ ℱ 𝒢 κs Γctx ℋ γ0 γ1 γ01 //=.
    suff 𝒥 : τω ⊧ ∥Γ∥ κs ≫ ∥A∥ κs ∼ ∥A∥ κs.
    - apply: Th.Prod.intro.
      + apply: 𝒟; eauto.
      + T.efwd ℰ.
        * T.use ℰ.
          simplify_subst.
          dependent induction x; auto.
        * auto.
        * apply: Th.General.open_ty_eq_refl_left; auto.
          replace (∥B ⫽ Sub.inst0 M00∥ κs)%prog with ((∥B∥ κs) ⫽ Sub.inst0 (∥M00∥ κs)%prog)%prog.
          ** apply: subst; auto.
             apply: Th.Univ.open_inversionω.
             apply: 𝒢; auto.
          ** replace (∥B ⫽ Sub.inst0 M00∥ κs)%prog with ((∥B ⫽ Sub.inst0 M00∥ κs) ⫽ @Prog.var _)%prog.
             *** rewrite -elab_tm_subst_naturality /elab_subst //=.
                 simplify_subst.
                 rewrite Prog.subst_ret.
                 by dependent induction x.
             *** by rewrite Prog.subst_ret.
        * auto.
      + apply: Th.General.ty_eq_refl_left.
        apply: Th.Univ.inversion.
        apply: ℱ; eauto.
      + move=> //= ? ? [_ /Th.Level.eq_mem_from_level ℐ].
        apply: Th.Univ.inversion.
        repeat rewrite Prog.subst_coh.
        apply: 𝒢; auto.
        split; simpl.
        * T.use (Th.General.env_eq_refl_left Γctx γ01).
          simplify_subst.
        * T.use ℐ.
          simplify_subst.
    - apply: Th.General.open_ty_eq_refl_left; auto.
      apply: Th.Univ.open_inversionω.
      apply: ℱ; auto.
  Qed.
End Prod.

Module KArr.

  Theorem univ_eq `{Γ : ECtx.t Λ Ψ} i {A0 A1} :
    ⟦ S Λ ∣ Γ.⦃^1⦄ ≫ 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ (Expr.karr A0) ≐ (Expr.karr A1) ⟧.
  Proof.
    move=> 𝒟 κs Γctx ℰ γ0 γ1 γ01 //=.
    apply: Th.Univ.intro.
    apply: Th.KArr.formation => κ.
    T.efwd 𝒟; eauto;
    autorewrite with core;
    eauto.
  Qed.

  Theorem intro `{Γ : ECtx.t Λ Ψ} i {A M0 M1} :
    ⟦ S Λ ∣ Γ.⦃^1⦄ ≫ A ∋ M0 ≐ M1 ⟧
    → ⟦ S Λ ∣ Γ.⦃^1⦄ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ≫ Expr.karr A ∋ (Expr.klam M0) ≐ (Expr.klam M1) ⟧.
  Proof.
    move=> 𝒟 ℱ κs ? ℰ ? ? ? //=.
    apply: Th.KArr.intro.
    - Th.Univ.tac.
      apply: univ_eq; eauto.
      apply: Th.General.env_eq_refl_left; eauto.
    - move=> κ.
      T.efwd 𝒟.
      + T.use 𝒟; eauto.
      + eauto.
      + Th.Univ.tac.
        apply: ℱ; eauto.
      + eauto.
  Qed.

  Theorem elim `{Γ : ECtx.t Λ Ψ} {i B f0 f1 k} :
    ⟦ S Λ ∣ Γ.⦃^1⦄ ≫ 𝕌[i] ∋ B ≐ B ⟧
    → ⟦ Λ ∣ Γ ≫ Expr.karr B ∋ f0 ≐ f1 ⟧
    → ⟦ Λ ∣ Γ ≫ B.⦃Ren.inst0 k⦄ ∋ (Expr.kapp f0 k) ≐ (Expr.kapp f1 k) ⟧.
  Proof.
    move=> 𝒟 ℰ κs ℱ 𝒢 γ0 γ1 γ01.
    autorewrite with syn_db; simpl.
    replace (κs ∘ Ren.inst0 k) with (κs k ∷ κs).
    - eapply (@Th.KArr.elim i (fun κ => ((∥ B ∥ κ ∷ κs) ⫽ γ0)%prog)).
      + move=> κ.
        apply: Th.Univ.inversion.
        apply: 𝒟; eauto.
        apply: Th.General.env_eq_refl_left; eauto.
      + apply: ℰ; eauto.
        move=> γ0' γ1' γ01'.
        apply: (Th.Level.eq_ty_from_level i).
        simpl.
        apply: Th.KArr.formation => κ.
        apply: Th.Univ.inversion.
        apply: 𝒟; eauto.
    - T.eqcd => x; dependent destruction x; eauto.
  Qed.
End KArr.

Module Isect.

  Theorem univ_eq `{Γ : ECtx.t Λ Ψ} i {A0 A1} :
    ⟦ S Λ ∣ Γ.⦃^1⦄ ≫ 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ ⋂ A0 ≐ ⋂ A1 ⟧.
  Proof.
    move=> 𝒟 κs Γctx ℰ γ0 γ1 γ01 //=.
    apply: Th.Univ.intro.
    apply: Th.Isect.formation => κ.
    T.efwd 𝒟; eauto;
    autorewrite with core;
    eauto.
  Qed.

  Theorem intro `{Γ : ECtx.t Λ Ψ} i {A M0 M1} :
    ⟦ S Λ ∣ Γ.⦃^1⦄ ≫ A ∋ (M0.⦃^1⦄) ≐ (M1.⦃^1⦄) ⟧
    → ⟦ S Λ ∣ Γ.⦃^1⦄ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ≫ ⋂ A ∋ M0 ≐ M1 ⟧.
  Proof.
    move=> 𝒟 ℱ κs ? ℰ ? ? ? //=.
    apply: Th.Isect.intro.
    - Th.Univ.tac.
      apply: univ_eq; eauto.
      apply: Th.General.env_eq_refl_left; eauto.
    - move=> κ.
      T.efwd 𝒟.
      + T.use 𝒟; eauto.
      + eauto.
      + Th.Univ.tac.
        apply: ℱ; eauto.
      + eauto.
  Qed.

  Theorem irrelevance `{Γ : ECtx.t Λ Ψ} {i A} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A ≐ ⋂ (A.⦃^1⦄) ⟧.
  Proof.
    move=> 𝒟 κs ? ? γ0 γ1 γ01; simplify_eqs.
    replace (λ κ:𝕂, (∥_.⦃_⦄∥ _) ⫽ _)%prog with (λ κ:𝕂, (∥A∥ κs) ⫽ γ1)%prog.
    - apply: Th.Univ.intro.
      apply: Th.Isect.irrelevance.
      apply: Th.Univ.inversion.
      apply: 𝒟; eauto.
    - simplify_subst; eauto.
  Qed.

  Theorem preserves_sigma `{Γ : ECtx.t Λ Ψ} i {A0 B0 A1 B1} :
    ⟦ S Λ ∣ Γ.⦃^1⦄ ≫ 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ S Λ ∣ Γ.⦃^1⦄ ∙ A0 ≫ 𝕌[i] ∋ B0 ≐ B1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ (⋂ (A0 × B0)) ≐ ((⋂ A1) × (⋂ B1)) ⟧.
  Proof.
    move=> 𝒟 ℰ κs ℱ 𝒢 γ0 γ1 γ01 //=.
    apply: Th.Univ.intro.
    simplify_subst.
    apply: Th.Isect.preserves_sigma.
    - move=> κ.
      Th.Univ.tac.
      apply: 𝒟; eauto.
    - move=> κ γ0' γ1' γ01'.
      Th.Univ.tac.
      simplify_subst.
      apply: ℰ.
      + split; auto.
        move=> ? ? ?.
        suff:  ⟦ (S Λ) ∣ Γ .⦃ ^ 1 ⦄ ≫ 𝕌[ i] ∋ A0 ≐ A0 ⟧.
        * move=> H; Th.Univ.tac; apply: H; eauto.
        * move=> ? ? ? ? ? ?; simplify_subst.
          apply: Th.General.mem_eq_trans.
          ** apply: Th.General.mem_eq_symm; eauto.
             apply: 𝒟; eauto.
             apply: Th.General.env_eq_symm; eauto.
          ** apply: 𝒟; eauto.
             apply: Th.General.env_eq_refl_left; eauto.
      + eauto.
      + split; simpl; simplify_subst.
        ** T.use γ01; eauto.
        ** case: γ01' => //= ? ℋ; simpl.
           apply: (Th.Level.eq_mem_from_level i).
           T.use ℋ; eauto.
  Qed.
End Isect.

Module Later.
  Theorem univ_eq `{Γ : ECtx.t Λ Ψ} i {k A0 A1} :
    ⟦ Λ ∣ Γ ≫ ▶[k] 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ ▶[k] A0 ≐ ▶[k] A1 ⟧.
  Proof.
    move=> 𝒟 ? ? ? ? ? ? //=.
    apply: Th.Later.univ_eq.
    apply: 𝒟; try by eassumption.

    move=> ? ? ? //=.
    apply: (Th.Level.eq_ty_from_level (S i)).
    apply: Th.Later.formation.
    apply: Later.next.
    apply: Th.Univ.formation_S.
  Qed.

  Theorem intro `{Γ : ECtx.t Λ Ψ} {k i A M0 M1} :
    ⟦ Λ ∣ Γ ≫ A ∋ M0 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ≫ ▶[k] A ∋ M0 ≐ M1 ⟧.
  Proof.
    move=> 𝒟 ℰ ? ? ? ? ? ? //=.
    apply: Th.Later.intro.
    apply: Later.next.
    apply: 𝒟; auto.

    Th.Univ.tac.
    apply: ℰ; eauto.
  Qed.

  Theorem force `{Γ : ECtx.t Λ Ψ} {i A B} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ ⋂ A ≐ ⋂ B ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ ⋂ ▶[#0] A ≐ ⋂ B ⟧.
  Proof.
    move=> 𝒟 ? ? ? ? ? ? //=.
    apply: Th.Univ.intro.
    apply: Th.Later.force.
    Th.Univ.tac.
    apply: 𝒟; eauto.
  Qed.

  Theorem preserves_sigma `{Γ : ECtx.t Λ Ψ} i κ {A0 B0 A1 B1} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ Λ ∣ Γ ∙ A0 ≫ ▶[κ] 𝕌[i] ∋ B0 ≐ B1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ (▶[κ] (A0 × B0)) ≐ ((▶[κ] A1) × (▶[κ] B1)) ⟧.
  Proof.
    move=> 𝒟 ℰ κs ℱ 𝒢 γ0 γ1 γ01 //=.
    apply: Th.Univ.intro.
    apply: Th.Later.preserves_sigma; simpl in *.
    - apply: Later.next.
      T.efwd 𝒟; eauto.
    - apply: Later.push_universal => γ0'.
      apply: Later.push_universal => γ1'.
      apply: Later.push_universal; case=> _ ℋ.
      simpl in *.
      specialize (𝒟 κs ℱ).
      simpl in *.
      T.efwd ℰ.
      + apply: (Later.map Th.Univ.inversion).
        apply: Th.Later.mem_univ_inversion.
        apply: Th.Later.univ_eq.
        T.use ℰ; eauto.
      + split; simpl.
        * T.use γ01; eauto.
        * apply: (Th.Level.eq_mem_from_level i).
          T.use ℋ; eauto.
      + move=> ? ? ? //=.
        apply: (Th.Level.eq_ty_from_level (S i)).
        apply: Th.Later.formation.
        apply: Later.next.
        apply: Th.Univ.formation_S.
      + split; eauto.
        move=> γ0'' γ1'' γ01''.
        suff: (τω ⊧ ((∥A0∥ κs) ⫽ γ0'') ∼ ((∥A1∥ κs) ⫽ γ0'')) ∧ (τω ⊧ ((∥A0∥ κs) ⫽ γ1'') ∼ ((∥A1∥ κs) ⫽ γ0'')).
        * case=> H0 H1.
          apply: Th.General.ty_eq_trans; eauto.
        * split; apply: Th.Univ.inversionω.
          ** T.efwd 𝒟.
             *** eauto.
             *** apply: Th.General.env_eq_refl_left; eauto.
             *** eauto.
          ** T.efwd 𝒟.
             *** eauto.
             *** apply: Th.General.env_eq_symm; eauto.
             *** eauto.
  Qed.

  Theorem preserves_pi `{Γ : ECtx.t Λ Ψ} i κ {A0 B0 A1 B1} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A0 ≐ A1 ⟧
    → ⟦ Λ ∣ Γ ∙ A0 ≫ ▶[κ] 𝕌[i] ∋ B0 ≐ B1 ⟧
    → ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ (▶[κ] (A0 ⇒ B0)) ≐ ((▶[κ] A1) ⇒ (▶[κ] B1)) ⟧.
  Proof.
    move=> 𝒟 ℰ κs ℱ 𝒢 γ0 γ1 γ01 //=.
    apply: Th.Univ.intro.
    apply: Th.Later.preserves_pi; simpl in *.
    - apply: Later.next.
      T.efwd 𝒟; eauto.
    - apply: Later.push_universal => γ0'.
      apply: Later.push_universal => γ1'.
      apply: Later.push_universal; case=> _ ℋ.
      simpl in *.
      specialize (𝒟 κs ℱ).
      simpl in *.
      T.efwd ℰ.
      + apply: (Later.map Th.Univ.inversion).
        apply: Th.Later.mem_univ_inversion.
        apply: Th.Later.univ_eq.
        T.use ℰ; eauto.
      + split; simpl.
        * T.use γ01; eauto.
        * apply: (Th.Level.eq_mem_from_level i).
          T.use ℋ; eauto.
      + move=> ? ? ? //=.
        apply: (Th.Level.eq_ty_from_level (S i)).
        apply: Th.Later.formation.
        apply: Later.next.
        apply: Th.Univ.formation_S.
      + split; eauto.
        move=> γ0'' γ1'' γ01''.
        suff: (τω ⊧ ((∥A0∥ κs) ⫽ γ0'') ∼ ((∥A1∥ κs) ⫽ γ0'')) ∧ (τω ⊧ ((∥A0∥ κs) ⫽ γ1'') ∼ ((∥A1∥ κs) ⫽ γ0'')).
        * case=> H0 H1.
          apply: Th.General.ty_eq_trans; eauto.
        * split; apply: Th.Univ.inversionω.
          ** T.efwd 𝒟.
             *** eauto.
             *** apply: Th.General.env_eq_refl_left; eauto.
             *** eauto.
          ** T.efwd 𝒟.
             *** eauto.
             *** apply: Th.General.env_eq_symm; eauto.
             *** eauto.
  Qed.

  Theorem induction `{Γ : ECtx.t Λ Ψ} k {i A M0 M1} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ A ≐ A ⟧
    → ⟦ Λ ∣ Γ ∙ ▶[k] A ≫ A.[^1] ∋ M0 ≐ M1 ⟧
    → ⟦ Λ ∣ Γ ≫ A ∋ μ{ M0 } ≐ μ{ M1 } ⟧.
  Proof.
    move=> 𝒟 ℰ κs ? ℱ ? ? γ01 //=.
    apply: (Th.Later.loeb_induction_closed (κs k)).
    - apply: Th.Univ.inversion.
      apply: 𝒟; eauto.
    - move=> //= ? ? [_ 𝒢]; simplify_subst.

      T.efwd ℰ.
      + T.use ℰ; eauto.
      + split; [T.use γ01 | T.use 𝒢]; eauto.
      + move=> //= ? ? [? ?].
        simplify_subst.
        apply: ℱ; eauto.
      + split; first by [assumption].
        move=> //= ? ? ?.
        apply: (Th.Level.eq_ty_from_level i).
        apply: Th.Later.formation.
        apply: Later.next.
        apply: Th.Univ.inversion.
        apply: 𝒟; eauto.
  Qed.
End Later.

Module Examples.

  (* Guarded stream of bits. *)
  Example BitStream {Λ Ψ} : Expr.t Λ Ψ :=
    Expr.klam (μ{ 𝟚 × ▶[#0] @1 }%etm).

  Arguments BitStream [Λ Ψ].

  (* Coinductive sequence of bits. *)
  Example BitSeq {Λ Ψ} : Expr.t Λ Ψ :=
    (⋂ (Expr.kapp BitStream #0%eclk))%etm.

  Example BitStream_wf_aux `{Γ : ECtx.t Λ Ψ} i {k} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ μ{ 𝟚 × ▶[k] @1 } ≐  μ{ 𝟚 × ▶[k] @1 } ⟧.
  Proof.
    apply: (Later.induction k).
    - apply: General.univ_formation; eauto.
    - apply: Prod.univ_eq.
      + apply: Bool.univ_eq.
      + apply: Later.univ_eq.
        suff Q: @1%etm = (@0 .[^1])%etm; auto.
        rewrite !Q {Q}.

        suff Q : (▶[k] 𝕌[i])%etm = ((▶[k] 𝕌[i]).[^1])%etm; auto.
        rewrite !Q {Q}.

        apply: General.weakening.
        * apply: General.hypothesis.
        * apply: Later.univ_eq.
          apply: Later.intro; apply: General.univ_formation; auto.
  Qed.

  Example BitStream_wf `{Γ : ECtx.t Λ Ψ} i {k} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ (Expr.kapp BitStream k) ≐ (Expr.kapp BitStream k) ⟧.
  Proof.
    apply: General.mem_conv_all.
    - apply: Conversion.refl.
    - apply: Conversion.kapp_of_klam.
    - apply: Conversion.kapp_of_klam.
    - apply: BitStream_wf_aux.
  Qed.

  Example BitSeq_wf `{Γ : ECtx.t Λ Ψ} {i} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ BitSeq ≐ BitSeq ⟧.
  Proof.
    apply: Isect.univ_eq.
    apply: BitStream_wf.
  Qed.

  Example Ones {Λ Ψ} : Expr.t Λ Ψ :=
    μ{ ⟨Expr.tt, @0⟩ }%etm.

  Example BitStream_unfold `{Γ : ECtx.t Λ Ψ} {i k} :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ Expr.kapp BitStream k ≐ (𝟚 × ▶[k] Expr.kapp BitStream k) ⟧.
  Proof.
    apply: General.mem_conv_all.
    - apply: Conversion.refl.
    - apply: Conversion.kapp_of_klam.
    - apply: Conversion.refl.
    - replace ((μ{ 𝟚 × ▶[ #0] @1}) .⦃ Ren.inst0 k ⦄)%etm with ((μ{ 𝟚 × ▶[ k ] @1})%etm : Expr.t Λ Ψ).
      + apply: (General.conv_mem (𝟚 × ▶[k] μ{ 𝟚 × ▶[k] @1})%etm).
        * move=> ? ?; apply: OpSem.fix_unfold.
        * apply: Prod.univ_eq.
          ** apply: Bool.univ_eq.
          ** apply: Later.univ_eq.
             apply: General.eq_symm.
             apply: General.conv_mem.
             *** apply: Conversion.kapp_of_klam.
             *** replace (((μ{ 𝟚 × ▶[ #0] @1}) .⦃ Ren.inst0 k ⦄)%etm : Expr.t Λ (S Ψ)) with ((μ{ 𝟚 × ▶[ k ] @1})%etm : Expr.t Λ (S Ψ)).
                 **** apply: Later.intro.
                      ***** apply: BitStream_wf_aux.
                      ***** apply: (General.univ_formation i (S i)); auto.
                 **** dependent induction k; auto.
      + dependent induction k; auto.
  Qed.

  Example Ones_wf_guarded `{Γ : ECtx.t Λ Ψ} {k} :
    ⟦ Λ ∣ Γ ≫ Expr.kapp BitStream k ∋ Ones ≐ Ones ⟧.
  Proof.
    apply: (Later.induction k).
    - apply: BitStream_wf.
    - apply: (General.replace_ty 0).
      + apply: General.eq_symm.
        apply: BitStream_unfold.
      + apply: Prod.intro.
        * by apply: Bool.tt_equality.
        * by apply: General.hypothesis.
        * by apply: (Bool.univ_eq 0).
        * apply: (Later.univ_eq 0).
          apply: Later.intro.
          ** by apply: BitStream_wf.
          ** by apply: General.univ_formation.
             Unshelve.
             constructor.
  Qed.

  Example Ones_wf_infinite `{Γ : ECtx.t Λ Ψ} :
    ⟦ Λ ∣ Γ ≫ BitSeq ∋ Ones ≐ Ones ⟧.
  Proof.
    apply: Isect.intro.
    apply: Ones_wf_guarded.
    apply: (BitStream_wf 0).
  Qed.

  Example BitSeq_unfold `{Γ : ECtx.t Λ Ψ} i :
    ⟦ Λ ∣ Γ ≫ 𝕌[i] ∋ BitSeq ≐ (𝟚 × BitSeq) ⟧.
  Proof.
    apply: General.eq_trans.
    - apply: General.eq_trans.
      + apply: Prod.univ_eq.
        * apply: General.eq_symm.
          apply: Isect.irrelevance.
          apply: Bool.univ_eq.
        * apply: Later.force.
          apply: BitSeq_wf.
      + apply: Isect.preserves_sigma.
        * apply: Bool.univ_eq.
        * apply: Later.univ_eq.
          apply: Later.intro.
          ** by apply: BitStream_wf.
          ** by apply: General.univ_formation.
    - apply: Isect.univ_eq.
      apply: BitStream_unfold.
  Qed.
End Examples.


From refinedc.typing Require Import typing.
From refinedc.project.learning.src.example Require Import generated_code.
Set Default Proof Using "Type".

(* Generated from [src/example.c]. *)
Section spec.
  Context `{!typeG Σ} `{!globalG Σ}.

  (* Type definitions. *)

  (* Specifications for function [add3]. *)
  Definition type_of_add3 :=
    fn(∀ (nx, ny, nz) : nat * nat * nat; (nx @ (int (u32))), (ny @ (int (u32))), (nz @ (int (u32))); ⌜nx + ny ≤ max_int u32⌝ ∗ ⌜(nx + ny) + nz ≤ max_int u32⌝)
      → ∃ () : (), ((nx + ny + nz) @ (int (u32))); True.

  (* Specifications for function [main]. *)
  Definition type_of_main :=
    fn(∀ () : (); True) → ∃ () : (), ((0) @ (int (i32))); True.
End spec.


Require Import List.
Require Import Omega.

Require Import Assembler.
Require Import MachineModel.
Require Import OperationalSemantics.
Require Import LabelledOperationalSemantics.
Require Import Labels.
Require Import MyTactics.

(*==============================================
   Lemmas  on the labelled operational semantics
==============================================*)

Lemma unused_mem_ext :
  forall (p1 p2 : Address) (r1 r2 : RegisterFile) (f1 f2 : Flags) (ctx1 ctx2 : MemExt) (c1 c2 : MemSec) (l : Label),
    (forall (r : Address) (v : Value), l <>  Write_out r v  )->
    protected p1 ->
    protected p2 ->
    (p1,r1,f1, plug ctx1 c1) ~~ l ~~> (p2, r2, f2, plug ctx1 c2) ->
    (p1,r1,f1, plug ctx2 c1) ~~ l ~~> (p2, r2, f2, plug ctx2 c2).
Proof.
intros p1 p2 r1 r2 f1 f2 ct1 ct2 c11 c21 l neql Hp1 Hp2 Tr1.
inversion Tr1.
(*call*)
contradiction_by_jump.
(*ret*)
contradiction_by_jump.
(*callback*)
contradiction_by_jump.
(*retback*)
contradiction_by_jump.
(*writeout  contradiction*)
rewrite <- H4 in neql. unfold not in neql. destruct neql with (r := (r1 rd)) (v := (r1 rs)). reflexivity.
(*internal *)
apply los_eval_int.
  assert (m = c11). apply (plug_same_memory me ct1 c11 m). auto. rewrite <- H10.
  assert (m' = c21). apply (plug_same_memory me ct1 c21 m'). auto. rewrite <- H11. auto.
  assert (m = c11). apply (plug_same_memory me ct1 c11 m). auto. rewrite <- H10. auto.
(*external*)
inversion H4; contradiction_by_jump.
(*tick in sec*)
  apply los_eval_int_halt.
  assert (m = c11). apply (plug_same_memory me ct1 c11 m). apply H3. rewrite <- H10.
  assert (m' = c21). apply (plug_same_memory me ct1 c21 m'). apply H8. rewrite <- H11. apply H4.
  assert (m = c11). apply (plug_same_memory me ct1 c11 m). auto. rewrite <- H10. auto.
(*tick in ext*)
  inversion H4; contradiction_by_jump.
Qed.

(*==============================================
   Lemmas  on the operational semantics
==============================================*)

Lemma unused_mem_sec :
  forall (p1 p2 : Address) (r1 r2 : RegisterFile) (f1 f2 : Flags) (ctx1 ctx2 : MemExt) (c11 c21 : MemSec),
    unprotected p1 ->
    unprotected p2 ->
    (p1,r1,f1, plug ctx1 c11) ---> (p2, r2, f2, plug ctx2 c11) ->
    (p1,r1,f1, plug ctx1 c21) ---> (p2, r2, f2, plug ctx2 c21).
Proof.
intros p1 p2 r1 r2 f1 f2 ct1 ct2 c11 c21 Hp1 Hp2 Tr1.
inversion Tr1.
(*call*)
contradiction_by_jump.
(*ret*)
contradiction_by_jump.
(*callback*)
contradiction_by_jump.
(*retback*)
contradiction_by_jump.
(*writeout*)
contradiction_by_jump.
(*internal *)
inversion H0; contradiction_by_jump.
(*external*)
apply eval_ext.
  assert (me = ct1). apply (plug_same_memory me ct1 c11 m). auto. rewrite <- H8.
  assert (me' = ct2). apply (plug_same_memory me' ct2 c11 m). auto. rewrite <- H9. auto.
Qed.


Require RTL.
Require Import Utf8.
Import Coqlib.
Import Maps.
Import Globalenvs.
Import AST.
Import Smallstep.
Import RTL.

Unset Elimination Schemes.

Section TUNNEL.

  Context (f: code) (entrypoint: node).

  Definition height (pc: node) : nat :=
    (S (Pos.to_nat entrypoint) - Pos.to_nat pc)%nat.

  Definition lt (x y: node) : Prop :=
    (height x < height y)%nat.

  Remark lt_wf : well_founded lt.
  Proof. apply well_founded_ltof. Qed.

  Fixpoint tunnel (pc: node) (m: PTree.t node) (WF: Acc lt pc) : PTree.t node.
  Proof.
    refine (
    let 'Acc_intro REC := WF in
    match plt entrypoint pc with
    | left LT => m
    | right GE =>
      tunnel (Pos.succ pc)
      match f ! pc with
      | Some (Inop pc') =>
        let dst := match m ! pc' with Some q => q | None => pc' end in
        PTree.set pc dst m
      | _ => m
      end
      (REC _ _)
    end).
  Proof.
    clear -GE;
    abstract (unfold Plt in GE; unfold lt, height; Psatz.lia).
  Defined.

  Fixpoint nop_sequence (n: nat) i o : Prop :=
    match n with
    | O => i = o
    | S n' =>
      ∃ p, f ! i = Some (Inop p) ∧ nop_sequence n' p o
    end.

  Definition tunnel_spec (m: PTree.t node) : Prop :=
    ∀ i o,
      m ! i = Some o → ∃ n, nop_sequence (S n) i o.

  Remark empty_tunnel_correct : tunnel_spec (PTree.empty _).
  Proof. intros i o. rewrite PTree.gempty. discriminate. Qed.

  Fixpoint tunnel_correct (pc: node) (m: PTree.t node) (WF: Acc lt pc) :
    tunnel_spec m → tunnel_spec (tunnel pc m WF).
  Proof.
    intros H.
    destruct WF as [ REC ].
    simpl. case plt. auto.
    intros GE.
    apply tunnel_correct. clear tunnel_correct.
    intros i o.
    destruct (f ! pc) as [ () | ] eqn: Hi; auto.
    rewrite PTree.gsspec. case peq; auto.
    intros ->. intros Ho; inv Ho.
    destruct (m ! _) as [ q | ] eqn: Hq.
    destruct (H _ _ Hq) as [ len Hlen ].
    exists (S len). simpl. eauto.
    exists O. simpl. eauto.
  Qed.

  Definition get_dest m pc : node :=
    match m ! pc with
    | Some pc' => pc'
    | None => pc
    end.

  Definition skip_nops s (i: instruction) : instruction :=
    match i with
    | Inop pc => Inop (s pc)
    | Iop op args dst pc => Iop op args dst (s pc)
    | Iload ϰ addr args dst pc => Iload ϰ addr args dst (s pc)
    | Istore ϰ addr args src pc => Istore ϰ addr args src (s pc)
    | Icall sg ros args dst pc => Icall sg ros args dst (s pc)
    | Ibuiltin ef args dst pc => Ibuiltin ef args dst (s pc)
    | Icond cond args a b => Icond cond args (s a) (s b)
    | Ijumptable b tgt => Ijumptable b (map s tgt)
    | Itailcall _ _ _
    | Ireturn _
      => i
    end.

  Definition skip_the_nops (m: PTree.t node) : code :=
    let s pc := get_dest m pc in
    PTree.map (λ _, skip_nops s) f.

End TUNNEL.

Definition transf_function (f: function) : function :=
  let 'mkfunction sg params sz c ep := f in
  let m := tunnel c ep xH (PTree.empty _) (lt_wf ep _) in
  mkfunction sg params sz (skip_the_nops c m) (get_dest m ep).

Lemma transf_function_at {f pc i} :
  (fn_code f) ! pc = Some i →
  (fn_code (transf_function f)) ! pc = Some (skip_nops (get_dest (
                                                            tunnel (fn_code f) (fn_entrypoint f) xH (PTree.empty _) (lt_wf (fn_entrypoint f) _))) i).
Proof.
  intros H.
  destruct f; simpl in *.
  unfold skip_the_nops. rewrite PTree.gmap, H. reflexivity.
Qed.

Lemma get_dest_tunnel f pc :
  ∃ n,
    nop_sequence (fn_code f) n pc
    (get_dest
     (tunnel (fn_code f) (fn_entrypoint f) 1%positive
             (PTree.empty node) (lt_wf _ _)) pc).
Proof.
  unfold get_dest.
  generalize (tunnel_correct (fn_code f) (fn_entrypoint f) xH (PTree.empty _) (lt_wf _ _) (empty_tunnel_correct _) pc).
  destruct (_ ! pc).
  - intros H. destruct (H _ eq_refl) as (idx & NOPS). eauto.
  - exists O. reflexivity.
Qed.

Definition transf_fundef (fd: fundef) : fundef :=
  match fd with
  | Internal fn => Internal (transf_function fn)
  | External ef => fd
  end.

Definition transf_program : program → program :=
  transform_program transf_fundef.

Definition match_stackframe (sf sf': stackframe) : Prop :=
  let 'Stackframe dst f sp pc rs := sf in
  let 'Stackframe dst' f' sp' pc' rs' := sf' in
  dst' = dst ∧ f' = transf_function f ∧ sp' = sp ∧ rs' = rs ∧
  ∃ idx, nop_sequence (fn_code f) idx pc pc'.

Definition match_stack := list_forall2 match_stackframe.

Definition match_state (idx: nat) (s s': state) : Prop :=
  match s with
  | State stk f sp pc rs m =>
    ∃ pc' stk',
    nop_sequence (fn_code f) idx pc pc' ∧
    match_stack stk stk' ∧
    s' = State stk' (transf_function f) sp pc' rs m
  | Callstate stk fd args m =>
    ∃ stk',
    match_stack stk stk' ∧
    s' = Callstate stk' (transf_fundef fd) args m
  | Returnstate stk v m =>
    idx = O ∧
    ∃ stk',
    match_stack stk stk' ∧
    s' = Returnstate stk' v m
  end.

Lemma find_function_preserved p ros rs fd :
  find_function (Genv.globalenv p) ros rs = Some fd →
  find_function (Genv.globalenv (transf_program p)) ros rs = Some (transf_fundef fd).
Proof.
  destruct ros as [ r | s ].
  - simpl. eauto using Genv.find_funct_transf.
  - simpl. unfold transf_program. rewrite (Genv.find_symbol_transf).
    case Genv.find_symbol. 2: discriminate.
    eauto using Genv.find_funct_ptr_transf.
Qed.

Lemma funsig_preserved fd :
  funsig (transf_fundef fd) = funsig fd.
Proof. destruct fd as [ () | ]; auto. Qed.

Lemma stack_size_preserved f :
  fn_stacksize (transf_function f) = fn_stacksize f.
Proof. destruct f. reflexivity. Qed.

Lemma entry_point_transf_function f :
  fn_entrypoint (transf_function f) =
  get_dest (tunnel (fn_code f) (fn_entrypoint f) xH (PTree.empty _) (lt_wf _ _))
           (fn_entrypoint f).
Proof. destruct f; reflexivity. Qed.

Inductive tag {A: Type} : A → Prop := Tag a : tag a.

Theorem simulation p :
  forward_simulation (semantics p) (semantics (transf_program p)).
Proof.
  refine
    (Forward_simulation
       (semantics p) (semantics (transf_program p))
       Wf_nat.lt_wf
       match_state
       _ _ _ _
    )
  .

  - simpl. intros s ().
    unfold transf_program. simpl.
    intros b f m0 H H0 H1 H2.
    exists O, (Callstate nil (transf_fundef f) nil m0).
    split. econstructor.
    eauto using Genv.init_mem_transf.
    erewrite Genv.find_symbol_transf; eauto.
    erewrite Genv.find_funct_ptr_transf; eauto.
    rewrite funsig_preserved; eauto.
    unfold match_stack. eauto using list_forall2_nil.

  - simpl. intros idx s1 s2 r M F.
    revert M. case F. clear. simpl.
    intros r m (-> & stk' & H & ->). inv H. constructor.

  - simpl.
    Hint Unfold match_stack.
    Hint Unfold match_stackframe.
    Hint Resolve funsig_preserved.
    intros s1 tr s1' STEP idx s2 M.
    destruct s1 as [ stk f sp pc rs m | stk fd args m | stk r m ];
    simpl in M.
    + destruct M as (pc' & stk' & NOPS & STK & ->).
      destruct idx as [ | idx ].
      * simpl in NOPS. subst pc'.
        inv STEP;
          repeat
          match goal with
          | H : Op.eval_operation _ _ _ _ _ = _ |- _ =>
            rewrite <- (Op.eval_operation_preserved _ _ (Genv.find_symbol_transf transf_fundef p)) in H
          | H : Op.eval_addressing _ _ _ _ = _ |- _ =>
            rewrite <- (Op.eval_addressing_preserved _ _ (Genv.find_symbol_transf transf_fundef p)) in H
          | H : find_function _ _ _  = _ |- _ =>
            apply (find_function_preserved p) in H
          | H : Events.eval_builtin_args _ _ _ _ _ _ |- _ =>
            apply (Events.eval_builtin_args_preserved _ (Genv.find_symbol_transf transf_fundef p))
                  in H
          | H : Events.external_call _ _ _ _ _ _ _ |- _ =>
            generalize (Events.external_call_symbols_preserved _ _ _ _ _ _ _ _
                                                               H
                                                               (Genv.find_symbol_transf transf_fundef p)
                                                               (Genv.public_symbol_transf _ _)
                                                               (Genv.find_var_info_transf _ _)
                       );
              clear H; intros H
          | H : appcontext[ fn_stacksize _ ] |- _ =>
            rewrite <- (stack_size_preserved f) in H
          | H : (fn_code f) ! _ = Some _ |- _ =>
            apply transf_function_at in H; simpl in H
          | H : appcontext[ get_dest ?m ?pc ], K: tag ?pc |- _ => idtac
          | H : appcontext[ get_dest ?m ?pc ] |- _ =>
            pose proof (Tag pc);
              let nop := fresh nop in
              let Hnop := fresh Hnop in
            destruct (get_dest_tunnel f pc) as (nop & Hnop)
          end;
          try (
              eexists nop, _; split;
              [ left; apply plus_one; econstructor (eauto; fail)
              | simpl; eauto;
                try (eexists (Stackframe _ _ _ _ _ :: _); eauto 14 using list_forall2_cons)
              ];
              fail
            ).
        eexists O, _. split. left. apply plus_one. econstructor (eauto; fail).
        simpl. eauto.
        destruct (get_dest_tunnel f ifnot) as (nop' & Hnop').
        eexists (if b then nop else nop'), _. split.
        left. apply plus_one. econstructor (eauto; fail).
        simpl. destruct b; eauto.
        destruct (get_dest_tunnel f pc') as (nop & Hnop).
        eexists nop, _. split. left. apply plus_one.
        eapply exec_Ijumptable; eauto.
        rewrite list_nth_z_map, H9. reflexivity.
        simpl. eauto.
        eexists _, _. split. left. apply plus_one. econstructor (eauto; fail).
        simpl. eauto.
      * destruct NOPS as (n & Hn & NOPS).
        inv STEP;
          repeat match goal with
                 | H : ?a = ?b |- _ => subst a || subst b
                 | H : ?a = Some _, K : ?a = Some _ |- _ =>
                   rewrite H in K; inversion K; clear K
                 end.
        eexists idx, _.
        split. right. split. apply star_refl.
        Psatz.lia. simpl. eauto.
    + destruct M as (stk' & STK & ->).
      inv STEP.
      * destruct (get_dest_tunnel f (fn_entrypoint f)) as (nop & Hnop).
        eexists nop, _. split.
        left. apply plus_one.
        rewrite <- (stack_size_preserved f) in *.
        econstructor (eauto; fail).
        eexists _, _. split. eauto.
        split. eauto. rewrite entry_point_transf_function.
        f_equal. destruct f; reflexivity.
      * eexists O, _. split.
        left. apply plus_one.
        generalize (Events.external_call_symbols_preserved _ _ _ _ _ _ _ _
                                                           H5
                                                           (Genv.find_symbol_transf transf_fundef p)
                                                           (Genv.public_symbol_transf _ _)
                                                           (Genv.find_var_info_transf _ _)
                   ); clear H5; intros H5.
        econstructor (eauto; fail).
        simpl. eauto.
    + destruct M as (-> & stk' & STK & ->).
      inv STEP.
      destruct stk' as [ | () stk' ]; inv STK.
      destruct H2 as ( -> & -> & -> & -> & nop & Hnop).
      eexists nop, _. split.
      left. apply plus_one. constructor.
      simpl; eauto.
  - simpl. apply Genv.public_symbol_transf.
Qed.


Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Bag.
Require Import Dict.
Require Import Misc.
Require Import CpdtTactics.
Require Import JamesTactics.
Require Import Coq.Program.Basics.
Require Import EqDec.
Require Import Enumerable.
Require Import BGPSpec.
Require Import KonneTactics.
Require Import Equality.
Require Import Graph.
Require Import FunctionalExtensionality.
Require Import SymbolicExecution.
Import EqNotations.
Import ListNotations.

Section BGPSpecFacts.
  Context `{PrefixClass}.
  Context `{TopologyClass}.
  Context `{PathAttributesClass}.
  Context `{forall r, ConfigurationClass r}.
  Existing Instance enumerableIncoming.
  Existing Instance eqDecIncoming.

  Opaque eqDecide.
  Opaque enumerate.
  Hint Unfold lookup update update' overwrite overwrite' build edge.
  Hint Unfold fst snd proj1_sig const id.
  Hint Unfold routerHandler messageHandling import' export' bindRoutingInformation
              connection emptyRIB argMax.

  Lemma routerStateOk : forall r s d p ns (R:reachable ns),
    let ribs := lookup (routerState ns) r in
    let outs := build(fun s => import' r s p (lookup (adjRIBsIn ribs) (s,p))) in
    exists s', localPref' (lookup outs s) <= localPref' (lookup outs s') /\
               (lookup (locRIB ribs) p = lookup outs s') /\
               (lookup (adjRIBsOut ribs) (d,p) = export' r s' d p (lookup outs s')).
  Proof.
    intros.
    exists(argMax' (fun s => localPref' (lookup outs s)) injected).
    constructor. {
      specialize (allSmallerThanArgMax (fun s => localPref' (lookup outs s))); intro.
      intuition.
    } {
      induction R as [|ns ns'' _ IHR t].
      - constructor; repeat symbolic_execution'' congruence.
      - destruct t as [m r' rs' ls' | m c rs' ls'].
        + unfold build in *.
          intuition.
          * repeat symbolic_execution'' congruence.
          * repeat symbolic_execution'' congruence.
        + unfold build in *.
          destruct c as [s'r' c].
          destruct s'r' as [s' r'].
          intuition.
          * repeat symbolic_execution'' congruence.
          * repeat symbolic_execution'' congruence.
    }
  Qed.

  Lemma routerStateOk' : forall r d p ns (R:reachable ns),
    let ribs := lookup (routerState ns) r in
    let outs := build (fun s => import' r s p (lookup (adjRIBsIn ribs) (s,p))) in
    let s' := argMax' (fun s => localPref' (lookup outs s)) injected in
      lookup (locRIB ribs) p = lookup outs s' /\
      lookup (adjRIBsOut ribs) (d,p) = export' r s' d p (lookup outs s').
  Proof.
    intros.
    induction R as [|ns ns'' _ IHR t].
    - constructor; repeat symbolic_execution'' congruence.
    - destruct t as [m r' rs' ls' | m c rs' ls'].
      + unfold build in *.
        intuition.
        * repeat symbolic_execution'' congruence.
        * repeat symbolic_execution'' congruence.
      + unfold build in *.
        destruct c as [s'r' c].
        destruct s'r' as [s'' r'].
        intuition.
        * repeat symbolic_execution'' congruence.
        * repeat symbolic_execution'' congruence.
  Qed.
End BGPSpecFacts.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall Qprime Cprime P Q Aprime C A X Y Z : Universe, ((wd_ Qprime Cprime /\ (wd_ Cprime P /\ (wd_ P Q /\ (wd_ Qprime Q /\ (wd_ Qprime P /\ (wd_ Cprime Q /\ (wd_ Aprime P /\ (wd_ Q Aprime /\ (wd_ Aprime A /\ (wd_ Cprime C /\ (wd_ P A /\ (wd_ P C /\ (wd_ Q C /\ (wd_ C A /\ (wd_ Cprime Aprime /\ (wd_ X Y /\ (wd_ A Q /\ (wd_ P Y /\ (wd_ Y Z /\ (wd_ X P /\ (col_ P Q Z /\ (col_ Aprime P A /\ (col_ Cprime P C /\ (col_ P C Y /\ col_ P A X)))))))))))))))))))))))) -> col_ P Cprime Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.