(** This file is heavily annotated for a tutorial introduction to VST. We
    assume that our readers have already had some experience in Coq. *)

(** First, import the entire Floyd proof automation system, which includes
    the VeriC program logic and the MSL theory of separation logic. *)
Require Import VST.floyd.proofauto.
(** This file is auxiliary tactics that we will use in this tutorial. *)
Require Import EV.AuxiliaryTac.

(** These are the C programs that we will verify. *)
Require EV.add EV.abs EV.append EV.max3 EV.swap EV.tri EV.gcd EV.fact EV.test_null EV.reverse.

Module Verif_uadd.

(** Here is the first C function that we are going to verify. It is a super
    simple one (you can also find it in [add.c]:

      unsigned int uadd(unsigned int x, unsigned int y) {
        unsigned int z;
        z = x + y;
        return z;
      }

    Now, import the [add.v] file, produced by CompCert's clightgen from
    [add.c]. The file [add.v] defines abbreviations for identifiers (variable
    names, etc.) of the C program, such as _x, _add. It also defines "prog",
    which is the entire abstract syntax tree of the C program. *)
Import EV.add.

(** Always copy the following two lines before verification. They are used to
    set up global environment. *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** Before proving a program correct, we first need to state what does
    "correct" mean. Here is [uadd]'s specification: *)
Definition uadd_spec :=
 DECLARE _uadd
  WITH x: Z, y: Z
  PRE  [ _x OF tuint, _y OF tuint ]
     PROP  ()
     LOCAL (temp _x (Vint (Int.repr x)); temp _y (Vint (Int.repr y)))
     SEP   ()
  POST [ tuint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (x + y))))
     SEP   ().

(** It characterizes the precondition required for calling the function, and
    the postcondition guaranteed by the function. It says: for any integers
    [x] and [y], if the program variable [_x] has value [x] and the program
    variable [_y] has value [y], the the return value is [x+y]. **)

Check Int.repr.
  (* Int.repr : Z -> int *)
Check Vint.
  (* Vint : int -> val *)

(** [Int.repr] is a function turning an integer into a 32-bit integer. In VST,
    32-bit integers have type [int]. [Vint] turns a 32-bit integer into a C
    value. In VST, C values have type [val], which can be a 32-bit integer,
    a 64-bit integer, a floating point number or an address. *)

Check _x.
Print ident.
(** In VST, we always use names like [_x] to represent program variables and
    use Coq variables like [x] to represent logical variables. Program
    variables are represented by their indices, which are positive integers.

    If we review this specification, its main structure is:

        DECLARE _function_name_
          WITH _logical_variable_list_
          PRE  [ _function_argument_list_ ]
            _precondition_
          POST [ _return_type_ ]
            _postcondition_

    In the argument list of [uadd_spec], we use [tuint] to represent the C
    type of unsigned int. VST uses CompCert's type definitions. Usually, type
    definitions use names starting with "t", e.g. [tint], [tuint], [tchar],
    [tvoid] etc.

    VST requires users to write precondition in a [PROP-LOCAL-SEP] form.
    Postconditions and other assertions must be written in a [PROP-LOCAL-SEP]
    or existential [PROP-LOCAL-SEP] form. The [LOCAL] part describes the values
    of program variables. For example, [temp _x E] says the value of [_x] is
    [E]. We will see how to use the [PROP] part and the [SEP] part later.

    The following line defines the global function spec, characterizing the
    preconditions and postconditions of all the functions that your will verify
    and the functions that your proved-correct program may call. Here we
    include only one. *)

Definition Gprog : funspecs := ltac:(with_library prog [ uadd_spec ]).

(** For each function definition in the C program, we prove that the
    function-body (in this case, [f_uadd]) satisfies its specification (in
    this case, [uadd_spec]). *)
Lemma body_uadd: semax_body Vprog Gprog f_uadd uadd_spec.
Proof.
  (** The start_function tactic "opens up" a semax_body proof goal
      into a Hoare triple. *)
  start_function.
  (** The current proof goal is a Hoare triple. It is indeed

          semax Delta Precondition Command Postcondition.

      [semax] mainly means what follows is a Hoare triple. [Delta] is the
      C program's context which you can usually ignore. For convenience,
      VST chooses to only demonstrate the precondition and the first C
      command. Later commands and the postcondition is hidden.

      You can use [unfold] to reveal this hidden information. *)
  unfold MORE_COMMANDS, abbreviate.
  (** Usually you do not need to do this. *)
Abort.

(** Let's redo this proof without unfolding those hidden parts. *)
Lemma body_uadd: semax_body Vprog Gprog f_uadd uadd_spec.
Proof.
  start_function.
  (** For each assignment statement, "symbolically execute" it
      using the [forward] tactic. The backend of [forward] is a
      combination of Hoare logic's sequence rule and forward
      assignment rule. *)
  forward. (* z = x + y; *)
  (** If you compare the current proof goal with the original one, you
      will find that the first command is eaten. The precondition is
      replaced by the strongest postcondition of the original precondition
      and that eaten assignment command. *)
  rewrite add_repr.
  forward. (* return z; *)
Qed.

End Verif_uadd.

Module Verif_add_first_try.

(** Now we try to verify the second function [add]:

      int add(int x, int y) {
        int z;
        z = x + y;
        return z;
      }
*)
Import EV.add.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** You may intend to write exactly the same specification as [uadd]'s. Let's
    try and see whether it works or not. *)
Definition add_spec :=
 DECLARE _add
  WITH x: Z, y: Z
  PRE  [ _x OF tint, _y OF tint ]
     PROP  ()
     LOCAL (temp _x (Vint (Int.repr x)); temp _y (Vint (Int.repr y)))
     SEP   ()
  POST [ tint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (x + y))))
     SEP   ().

Definition Gprog : funspecs :=
         ltac:(with_library prog [ add_spec ]).

Lemma body_add: semax_body Vprog Gprog f_add add_spec.
Proof.
  start_function.
  forward. (* z = x + y; *)
  (** Oops! VST generates an unexpected proof goal. In this proof goal,
      [tc_expr] says that expressions evaluating is legal. Specifically,
      VST asks whether evaluating [_x + _y] is safe, if the precondition
      holds. *)
  hint.
  (** [hint] is a VST's tactic. You can always use it when you do not
      know what to do. *)
  entailer!.
  (** [entailer!] is a VST's tactic to simplify (and solve, if possible)
      assertion derivations. Here, we need to prove that [x] and [y] is
      in the signed 32-bit range. This is reasonable -- C standard says
      arithmetic overflow is undefined behavior (unless their type is
      unsigned). We have to prove that our program is always safe to execute.

      In more details, [Int.signed] turns a 32-bit integer back to an integer
      using signed encoding.

      At this position, this goal is not provable. If we go back and review
      our proof. The proof itself has nothing wrong. What's wrong is the
      specification. *)
Abort.

End Verif_add_first_try.

Module Verif_add.

Import EV.add.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** Now we try to redefine the specification [add_spec]. *)
Definition add_spec :=
 DECLARE _add
  WITH x: Z, y: Z
  PRE  [ _x OF tint, _y OF tint ]
     PROP  (0 <= x < 100; 0 <= y < 100)  (* <-- new *)
     LOCAL (temp _x (Vint (Int.repr x)); temp _y (Vint (Int.repr y)))
     SEP   ()
  POST [ tint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (x + y))))
     SEP   ().

(** We add a line in the precondition. It requires [x], [y] to be small. In
    general, the [PROP] clauses are a list of Coq [Prop]s which describes
    logical variables' properties. *)

Definition Gprog : funspecs :=
         ltac:(with_library prog [ add_spec ]).

Lemma body_add: semax_body Vprog Gprog f_add add_spec.
Proof.
  start_function.
  forward. (* z = x + y; *)
  (** Symbolic execution works well this time. It does not generate any
      side condition because VST automatically understand that [x+y] is
      in signed 32-bit range due to the assumptions [H] and [H0]. *)
  rewrite add_repr.
  forward. (* return z; *)
Qed.

End Verif_add.

Module Verif_slow_add.

Import EV.add.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** C function [slow_add]:

      int slow_add(int x, int y) {
        while (x > 0) {
          x = x - 1;
          y = y + 1;
        }
        return y;
      }

    We grab this example from Benjamin Pierce's Software Foundation. While
    he explains this example in a toy language, we write it in a real languge
    C and verify this C function. *)

Definition slow_add_spec :=
 DECLARE _slow_add
  WITH x: Z, y: Z
  PRE  [ _x OF tint, _y OF tint ]
     PROP  (0 <= x < 100; 0 <= y < 100)
     LOCAL (temp _x (Vint (Int.repr x)); temp _y (Vint (Int.repr y)))
     SEP   ()
  POST [ tint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (x + y))))
     SEP   ().

Definition Gprog : funspecs :=
         ltac:(with_library prog [ slow_add_spec ]).

Lemma body_slow_add: semax_body Vprog Gprog f_slow_add slow_add_spec.
Proof.
  start_function.
  (** This time we need to reason about a while-loop. We can use the tactic
      [forward-while] provided by VST. BTW, if you forget its name, you can
      always use [hint] for help.

      You must supply a loop invariant when you use [forward_while], in
      this case [EX x', EX y' PROP(...)LOCAL(...)(SEP(...)]. [EX] is the
      existential quantifier in VST's assertion language. *)
  forward_while
    (EX x': Z, EX y': Z,
      (PROP  ((x' + y' = x + y)%Z; 0 <= x' < 100; 0 <= y' < 200)
       LOCAL (temp _x (Vint (Int.repr x'));
              temp _y (Vint (Int.repr y')))
       SEP ())).
  (** The forward_while tactic leaves four subgoals. *)
  { (* Precondition implies loop invariant *)
    Exists x.
    Exists y.
    (** The [Exists] tacitc is used to instantiate the existential
        quantifiers on the right hand side. *)
    entailer!.
  }
  { (* Loop invariant implies typechecking of loop condition *)
    entailer!.
  }
  { (* Loop body preserves loop invariant. *)
    forward. (* x = x - 1; *)
    forward. (* y = y + 1; *)
    Exists (x' - 1, y' + 1).
    unfold fst, snd.
    entailer!.
  }
  (* After loop *)
  assert (x' = 0).
  { omega. }
  assert (y' = x + y).
  { omega. }
  subst.
  forward. (* return y; *)
Qed.

End Verif_slow_add.

Module Verif_abs.

Import EV.abs.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** The following example explains how to verify if-commands. Her is a C
    function:

      int abs(int x) {
        if (x < 0)
          return -x;
        else
          return x;
      }

    This function will work well as long as the input value is not [- 2^31]. *)

Definition abs_spec :=
 DECLARE _abs
  WITH x: Z
  PRE  [ _x OF tint ]
     PROP  (- Int.max_signed <= x <= Int.max_signed)
     LOCAL (temp _x (Vint (Int.repr x)))
     SEP   ()
  POST [ tint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (Z.abs x))))
     SEP   ().

Definition Gprog : funspecs :=
         ltac:(with_library prog [ abs_spec ]).

Lemma body_slow_add: semax_body Vprog Gprog f_abs abs_spec.
Proof.
  start_function.
  (** In order to verify an if-command, we can use [forward_if]. Sometimes,
      VST requires your to offer a postcondtion for the whole if-command. At
      this position, it is not necessary because the postcondition of this
      if-command must be the postcondition in function specification.*)
  forward_if.
  {
    forward. (* return - x; *)
    + (* Prove that evaluating [-x] is safe. *)
      (* On the right hand side, [!! _] maps a Coq proposition to an Hoare
         logic assertion. *)
      entailer!.
      change (Int.signed Int.zero) with 0.
      rep_omega.
    + entailer!.
      (* Prove that [Z.abs] is [-x]. *)
      f_equal.
      f_equal.
      rewrite Z.abs_neq.
      - reflexivity.
      - omega.
  }
  {
    forward. (* return x; *)
    entailer!.
    (* Prove that [Z.abs] is [x]. *)
    f_equal.
    f_equal.
    rewrite Z.abs_eq.
    - reflexivity.
    - omega.
  }
Qed.

End Verif_abs.

Module Verif_fact.

Import EV.fact.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** The following two C functions calculate the factorial function in two
    different implementations. We will use them to demonstrate how to verify
    function calls and for loops in VST.

      unsigned int fact(unsigned int n) {
        if (n == 0)
          return 1;
        else
          return n * fact(n - 1);
      }

      unsigned int fact_loop (unsigned int n) {
        unsigned int i;
        unsigned int r;
        r = 1;
        for (i = 0; i < n; ++ i)
          r = (i+1) * r;
        return r;
      }

    Specification: *)

Definition fact_spec :=
 DECLARE _fact
  WITH n: nat
  PRE  [ _n OF tuint ]
     PROP  (Z.of_nat n <= Int.max_unsigned)
     LOCAL (temp _n (Vint (Int.repr (Z.of_nat n))))
     SEP   ()
  POST [ tuint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (Z.of_nat (fact n)))))
     SEP   ().

Definition fact_loop_spec :=
 DECLARE _fact_loop
  WITH n: nat
  PRE  [ _n OF tuint ]
     PROP  (Z.of_nat n <= Int.max_unsigned)
     LOCAL (temp _n (Vint (Int.repr (Z.of_nat n))))
     SEP   ()
  POST [ tuint ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr (Z.of_nat (fact n)))))
     SEP   ().

Print fact.
Check Z.of_nat.
(** The Coq function [fact] has type [nat -> nat] and represents the factorial
    function. Moreover, [Z.of_nat] maps natural numbers to integers. *)

Lemma Nat2Z_nonzero: forall n,
  Z.of_nat n <> 0 ->
  exists n', Z.of_nat n = Z.of_nat n' + 1 /\ n = S n'.
Proof.
  intros.
  destruct n as [| n'].
  + simpl in H.
    omega.
  + exists n'.
    rewrite Nat2Z.inj_succ.
    omega.
Qed.

Definition Gprog : funspecs :=
         ltac:(with_library prog [ fact_spec; fact_loop_spec ]).

Lemma body_fact: semax_body Vprog Gprog f_fact fact_spec.
Proof.
  start_function.
  forward_if.
  { (* If then *)
    assert (n = O). { omega. }
    subst n; clear H0.
    forward. (* return 1; *)
  }
  { (* If else *)
    apply Nat2Z_nonzero in H0.
    destruct H0 as [n' [? ?]].
    rewrite H0.
    (** The original C command is

            return n * fact(n-1);

        Clightgen will automatically split it into two commands. The new
        program has one auxiliary variable [_t'1]:

            _t'1 = fact(n-1);
            return n * _t'1;

        In order to symbolic execute a function call, we should use
        [forward_call]. The parameter of [forward_call] corresponds to the
        logical variable list in the function specification. *)
    forward_call n'. (* _t'1 = fact(n-1); *)
    (** Why do we write [n'] here? Let's take a look at [fact]'s spec.

          DECLARE _fact
            WITH n: nat
            PRE  [ _n OF tuint ]
               PROP  (Z.of_nat n <= Int.max_unsigned)
               LOCAL (temp _n (Vint (Int.repr (Z.of_nat n))))
               SEP   ()
            POST [ tuint ]
               PROP  ()
               LOCAL (temp ret_temp (Vint (Int.repr (Z.of_nat (fact n)))))
               SEP   ().

        It says: for any natural number [n], if the program variable [_n]
        has value [n], then the return value is [fact n]. Here, we use [n]
        as a parameter in order to state a family of Hoare triples. Thus,
        when this [fact] function is called, when we want to use this
        assumption, we need to instantiate this parameter. *)
    { (* [LOCAL] clauses of callee's precondition. *)
      entailer!.
      f_equal.
      f_equal.
      f_equal.
      omega.
    }
    { (* [PROP] clauses of callee's precondition *)
      omega.
    }
    forward. (* return n * _t'1; *)
    entailer!.
    f_equal.
    f_equal.
    rewrite <- H0.
    rewrite <- Nat2Z.inj_mul.
    reflexivity.
  }
Qed.

(** Remark 1. This proof is about a recursive function. In the proof,
    we use the assumption that the recursive call obeys the behavior
    described by [fact_spec]. Is this a circlic proof? No. VST proves
    its backend Hoare logic proof rule sound by induction over the steps
    involved in execution. BTW, its soundness can also be proved by induction
    over the number of function calls happened in execution.

    Remark 2. We put a simple restriction on [n]:

        Z.of_nat n <= Int.max_unsigned.

    On one hand, it is necessary. If n is a natural number larger than
    [Int.max_unsigned] (the largest number represented by unsigned 32-bit
    integer), the its 32-bit representation does not represent itself.
    On the other hand, the restriction does not need to be too strong. It is
    true that when [n >= 15], [fact n] is not in the range of unsigned 32-bit
    numbers. However, we can still prove that the return value of our C
    function [fact] is the last 32 bits of [fact n]. Also, the arithmetic
    overflow will not cause run time error since we use [unsigned int] as its
    C type. *)

Lemma body_fact_loop: semax_body Vprog Gprog f_fact_loop fact_loop_spec.
Proof.
  start_function.
  forward. (* r = 1; *)
  (** VST provides [forward_for_simple_bound] for loops with form:

          for (i = lo; i < hi; ++ i) ...

      We can use [hint] to see what argument does this tactic need. *)
  hint.
  (** VST automatically generates lower bounds but requires its users to
      provide upper bounds. *)
  forward_for_simple_bound
    (Z.of_nat n)
    (EX i: Z, EX i': nat,
      PROP (i = Z.of_nat i')
      LOCAL (temp _r (Vint (Int.repr (Z.of_nat (fact i'))));
             temp _n (Vint (Int.repr (Z.of_nat n))))
      SEP   ()).
  { (* Precondition implies the loop invariant. *)
    Exists O.
    entailer!.
  }
  { (* Loop body preserves the loop invariant. *)
    rename i'0 into i'.
    forward. (* r = (i+1) * r; *)
    Exists (S i').
    entailer!.
    split.
    + rewrite Nat2Z.inj_succ.
      omega.
    + f_equal.
      f_equal.
      assert (Z.of_nat i' + 1 = Z.of_nat (S i')).
      { rewrite Nat2Z.inj_succ. omega. }
      rewrite H1.
      rewrite <- Nat2Z.inj_mul.
      reflexivity.
  }
  Intros i'.
  (** This VST tactic [Intros] is similar to Coq's built-in [intros]. It
      extracts existentially quantified variables in preconditions and
      [PROP] clauses in preconditions into Coq assumptions. *)
  apply Nat2Z.inj in H0.
  subst i'.
  forward. (* return r; *)
Qed.

End Verif_fact.

Module Verif_swap.

Import EV.swap.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** In the rest part of this tutorial, we demonstrate verify C programs that
    manipulate memory explicitely using pointers.

      struct int_pair {
        int a;
        int b;
      };

      void int_swap (int * px, int * py) {
        int t;
        t = * px;
        * px = * py;
        * py = t;
      }

      void int_pair_swap (struct int_pair * p) {
        int t;
        t = p -> a;
        p -> a = p -> b;
        p -> b = t;
      }

      void int_pair_swap2 (struct int_pair * p) {
        int_swap (& (p -> a), & (p -> b));
      }
*)

(** In the specification, we need to describe C pointer type. In CompCert,
    [tptr t] represents the pointers to type [t]. Moreover, we need to talk
    about data which is not stored as a program variable but stored in an
    address. Specifically, this [int_swap] function swaps the number stored
    in address [px] and address [py]. For describing data stored in
    addresses, we use [SEP] clauses. For example,

        data_at Tsh tint (Vint x) px

    says [Vint x] is stored at [px]. The second argument [Tsh] reads "top
    share". It says owns full permissions of this unit of memory. We can
    read from it, write to it and even deallocate it. Users can put other
    restrictions on read/write permissions. For convenience, we only use
    [Tsh] in this tutorial. The third argument [tint] describes the type of
    this address.

    Why using this name [SEP]? Because VST uses them to talk about data
    stored in disjoint pieces of memory. In other words,

         SEP   (data_at Tsh tint (Vint x) px;
                data_at Tsh tint (Vint y) py)

    implies that [px] and [py] are different. *)

Definition int_swap_spec :=
 DECLARE _int_swap
  WITH x: int, y: int, px: val, py: val
  PRE  [ _px OF (tptr tint), _py OF (tptr tint) ]
     PROP  ()
     LOCAL (temp _px px; temp _py py)
     SEP   (data_at Tsh tint (Vint x) px;
            data_at Tsh tint (Vint y) py)
  POST [ tvoid ]
     PROP  ()
     LOCAL ()
     SEP   (data_at Tsh tint (Vint x) py;
            data_at Tsh tint (Vint y) px).

(** This is a convenience definition for [struct int_pair]. *)

Definition tpair: type := Tstruct _int_pair noattr.

(** The value of a [int_pair] type is a pair of integers. VST allows users
    to write pairs as [data_at]'s argument when the C type is a struct with
    two fields. *)
Definition int_pair_swap_spec :=
 DECLARE _int_pair_swap
  WITH x: int, y: int, p: val
  PRE  [ _p OF (tptr tpair) ]
     PROP  ()
     LOCAL (temp _p p)
     SEP   (data_at Tsh tpair (Vint x, Vint y) p)
  POST [ tvoid ]
     PROP  ()
     LOCAL ()
     SEP   (data_at Tsh tpair (Vint y, Vint x) p).

Definition int_pair_swap2_spec :=
 DECLARE _int_pair_swap2
  WITH x: int, y: int, p: val
  PRE  [ _p OF (tptr tpair) ]
     PROP  ()
     LOCAL (temp _p p)
     SEP   (data_at Tsh tpair (Vint x, Vint y) p)
  POST [ tvoid ]
     PROP  ()
     LOCAL ()
     SEP   (data_at Tsh tpair (Vint y, Vint x) p).

Definition Gprog : funspecs :=
         ltac:(with_library prog [ int_swap_spec; int_pair_swap_spec; int_pair_swap2_spec ]).

Lemma body_int_swap: semax_body Vprog Gprog
                            f_int_swap int_swap_spec.
Proof.
  start_function.
  (** Originally, the C program is only three lines:

        t = * px;
        * px = * py;
        * py = t;

      Clightgen split the second line into two so that every assignment
      command performs at most one read or write operation on data stored
      in memory (in other words, stored at explicitly at addresses). *)
  forward. (* t = * px; *)
  forward. (* _t'1 = * py; *)
  forward. (* * px = _t'1; *)
  forward. (* * py = t; *)
  (** The star operator "*" between two [data_at] is called separating
      conjunction. Specifically, [P * Q] means that [P] and [Q] hold on two
      disjoint pieces of memory. Of course, "*" has commutativity and
      associativity. *)
  entailer!.
Qed.

(** Verifying [int_pair_swap] is easy. Just remember that [data_at] can
    describe complicated C data types. *)
Lemma body_int_pair_swap: semax_body Vprog Gprog
                            f_int_pair_swap int_pair_swap_spec.
Proof.
  start_function.
  forward. (* t = p -> a; *)
  forward. (* _t'1 = p -> b; *)
  forward. (* p -> a = _t'1; *)
  forward. (* p -> b = t; *)
  entailer!.
Qed.

(** Here, we want to redo this proof and introduce more VST's tactics in this
    process. We will demonstrate [unfold_data_at], [gather_SEP], and
    [replace_SEP]. *)
Lemma body2_int_pair_swap: semax_body Vprog Gprog
                            f_int_pair_swap int_pair_swap_spec.
Proof.
  start_function.
  unfold_data_at (data_at Tsh tpair _ _).
  (** Besides [data_at], VST provides [field_at] which can be treated as
      a generalized version of [data_at]. For example,

          field_at Tsh tpair [StructField _a] (Vint x) p

      says [x] is store at field [_a] of a struct [tpair] at address [p].
      The tactic [unfold_data_at] can turn a [data_at] clause with a
      complicated C data type into smaller pieces.If you want to destruct
      [field_at] into even smallest pieces, use [unfold_field_at]. *)
  forward. (* t = p -> a; *)
  (** VST's forward symbolic execution can recognize bot [data_at] and
      [field_at]. But it cannot understand other user defined predicates in
      [SEP] clauses. We will see such examples later. *)
  forward. (* _t'1 = p -> b; *)
  forward. (* p -> a = _t'1; *)
  (** At some position, you might want to gather two [SEP] clauses together,
      or replace one [SEP] clause with an equivalent form. Here are
      examples: *)
  gather_SEP
    (field_at _ _ [StructField _a] _ _)
    (field_at _ _ [StructField _b] _ _).
  replace_SEP 0
    (data_at Tsh tpair (Vint y, Vint y) p).
  (** VST requires us to prove that this replacement is sound. *)
  {
    unfold_data_at (data_at _ _ _ _).
    entailer!.
  }
  forward. (* p -> b = t; *)
  entailer!.
Qed.

(** [int_pair_swap2] is another implementation of [int_pair_swap]; it uses
    [int_swap]. In this proof, we need to mention the address of a struct
    field --- it is called [field_address]. *)
Lemma body_int_pair_swap2: semax_body Vprog Gprog
                            f_int_pair_swap2 int_pair_swap2_spec.
Proof.
  start_function.
  unfold_data_at (data_at Tsh tpair _ _).
  (** Here, [field_address tpair [StructField _a] p] means, [p] is a pointer
      of type [tpair], [_a] is a field of [_a], and this [field_address] is
      the address of [_a] field. *)
  forward_call (x,
                y,
                field_address tpair [StructField _a] p,
                field_address tpair [StructField _b] p).
    (* swap ( & (p -> a), & (p -> b) ); *)
  {
    entailer!.
    (** [offset n p] means [ ( void * ) p + n ] intuitively.
        [field_address_solver] is a tactic to solve equations like [offset_val
        _ p = field_address _ _ p]. *)
    split; f_equal; field_address_solver.
  }
  unfold_data_at (data_at _ tpair _ _).
  entailer!.
Qed.

End Verif_swap.

Module Verif_test_null_first_try.

Import EV.test_null.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** Here is a simple function to test whether a pointer is null or not:

      int test_null (int * p) {
        if (p)
          return 1;
        else
          return 0;
      }
*)

(** Specification: *)
Definition test_null_spec :=
 DECLARE _test_null
  WITH p: val
  PRE  [ _p OF (tptr tint) ]
     PROP  ()
     LOCAL (temp _p p)
     SEP   ()
  POST [ (tint) ]
    EX b: bool,
     PROP  (b = true <-> p = nullval)
     LOCAL (temp ret_temp (Vint (Int.repr (if b then 0 else 1))))
     SEP   ().

Definition Gprog : funspecs :=
         ltac:(with_library prog [ test_null_spec ]).

Lemma body_test_null: semax_body Vprog Gprog
                                    f_test_null test_null_spec.

Proof.
  start_function.
  forward_if.
  (** Here, you see this side-condition:
        [emp |-- denote_tc_test_eq p (Vint Int.zero)]
      It asks whether it is legal to test whether [p] is [zero]. In fact, it is
      UB if [p] is a dangling pointer. However, we don't know whether [p] is
      dangling or not. *)
Abort.

End Verif_test_null_first_try.

Module Verif_test_null_second_try.

Import EV.test_null.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** Now, let's try again. This time, we only prove [test_null]'s correctness on
    cases that we own the R/W permission of [p]. *)

Definition test_null_spec :=
 DECLARE _test_null
  WITH p: val, x: val
  PRE  [ _p OF (tptr tint) ]
     PROP  ()
     LOCAL (temp _p p)
     SEP   (data_at Tsh tint x p)
  POST [ (tint) ]
     PROP  ()
     LOCAL (temp ret_temp (Vint (Int.repr 1)))
     SEP   (data_at Tsh tint x p).

Definition Gprog : funspecs :=
         ltac:(with_library prog [ test_null_spec ]).

Lemma body_test_null: semax_body Vprog Gprog
                                    f_test_null test_null_spec.

Proof.
  start_function.
  forward_if.
  (** This time, we know [p] cannot be a dangling pointer. *)
  {
    forward. (* return 1 *)
  }
  {
    forward. (* return 0 *)
    (** Why forward directly solve the goal? Because the precondition is already
        a contradiction. It is impossible that [data_at _ _ _ nullval]. *)
  }
Qed.

End Verif_test_null_second_try.

Module Verif_test_null.

Import EV.test_null.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* What if [p] might be [NULL]? We use the following predicate for demonstration. *)

Definition FooPred (p: val): mpred :=
  !! (p = nullval) && emp || EX x: val, data_at Tsh tint x p.

Definition test_null_spec :=
 DECLARE _test_null
  WITH p: val, x: val
  PRE  [ _p OF (tptr tint) ]
     PROP  ()
     LOCAL (temp _p p)
     SEP   (FooPred p)
  POST [ (tint) ]
    EX b: bool,
     PROP  (b = true <-> p = nullval)
     LOCAL (temp ret_temp (Vint (Int.repr (if b then 0 else 1))))
     SEP   (FooPred p).

(** The following lemma is for VST proof automation. [valid_pointer p] means [p]
    is not a dangling pointer. *)

Lemma FooPred_valid: forall p,
  FooPred p |-- valid_pointer p.
Proof.
  intros.
  unfold FooPred.
  apply orp_left.
  + entailer!.
  + Intros x.
    entailer!.
Qed.

(** The following line add [FooPred_valid] to VST's automation system. *)

Hint Resolve FooPred_valid : valid_pointer.

Definition Gprog : funspecs :=
         ltac:(with_library prog [ test_null_spec ]).

Lemma body_test_null: semax_body Vprog Gprog
                                    f_test_null test_null_spec.

Proof.
  start_function.
  forward_if.
  {
    forward. (* return 1 *)
    Exists false; simpl.
    entailer!.
    assert (p <> nullval) by (intro; subst; auto).
    split; intros; congruence.
  }
  {
    forward. (* return 0 *)
    Exists true; simpl.
    entailer!.
    split; auto.
  }
Qed.

End Verif_test_null.

Module Verif_reverse.

(** The last C program that we verify in this tutorial is the following one.

      struct list {unsigned head; struct list *tail;};

      struct list *reverse (struct list *p) {
        struct list *w, *t, *v;
        w = NULL;
        v = p;
        while (v) {
          t = v->tail;
          v->tail = w;
          w = v;
          v = t;
        }
        return w;
      }
*)

Import EV.reverse.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

(** Inductive definition of linked lists *)
Fixpoint listrep (sigma: list Z) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
      data_at Tsh t_struct_list (Vint (Int.repr h), y) x  *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Arguments listrep sigma x : simpl never.

(** Specification: *)
Definition reverse_spec :=
 DECLARE _reverse
  WITH sigma : list Z, p: val
  PRE  [ _p OF (tptr t_struct_list) ]
     PROP ()
     LOCAL (temp _p p)
     SEP (listrep sigma p)
  POST [ (tptr t_struct_list) ]
    EX q:val,
     PROP ()
     LOCAL (temp ret_temp q)
     SEP (listrep (rev sigma) q).

Definition Gprog : funspecs :=
         ltac:(with_library prog [ reverse_spec ]).

(** Whenever you define a new spatial operator, such as [listrep], it is
    useful to populate two hint databases. The [saturate_local] hint is a
    lemma that extracts pure propositional facts from a spatial fact. The
    [valid_pointer] hint is a lemma that extracts a valid-pointer fact from
    a spatial lemma. A pointer is valid if "we" own at least an empty share
    of that piece of memory. C standard says comparison with a dangling
    pointer is undefined behavior. The [valid_pointer] database is used for
    excluding such possibilities. *)

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros; normalize.
apply prop_right; split; simpl; auto. intuition.
entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
  destruct sigma; unfold listrep; fold listrep.
  + entailer!.
  + intros y.
    entailer!.
    entailer!.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma body_reverse: semax_body Vprog Gprog
                                    f_reverse reverse_spec.
Proof.
  start_function.
  forward.  (* w = NULL; *)
  forward.  (* v = p; *)
  forward_while
   (EX s1: list Z, EX s2 : list Z,
    EX w: val, EX v: val,
     PROP (sigma = rev s1 ++ s2)
     LOCAL (temp _w w; temp _v v)
     SEP (listrep s1 w; listrep s2 v)).
  { (* Prove that precondition implies loop invariant *)
    Exists (@nil Z) sigma nullval p.
    entailer!.
    unfold listrep.
    entailer!.
  }
  { (* Prove that loop invariant implies typechecking of loop condition *)
    entailer!.
  }
  {
    assert_PROP (s2 <> nil).
    (** [assert_PROP] tactic adds a proposition to Coq's assumption list.
        This proposition should be derivable from the precondition. *)
    {
      entailer!.
      pose proof proj2 H1 eq_refl.
      subst.
      apply HRE.
    }
    destruct s2 as [ | s2a s2b]; [congruence | clear H0].
    (** We cannot do "forward" directly here because it only recognizes
       [data_at] and [field_at]. *)
    Fail forward.
    (** We can unfold the definition of [listrep] first. *)
    unfold listrep at 2; fold listrep.
    Intros y.
    forward. (* t = v->tail *)
    forward. (* v->tail = w; *)
    forward. (* w = v; *)
    forward. (* v = t; *)
    entailer!.
    Exists (s2a::s1,s2b,v,y).
    entailer!.
    + simpl. rewrite app_ass. auto.
    + unfold listrep at 3; fold listrep.
      Exists w. entailer!.
  }
  forward.  (* return w; *)
  Exists w; entailer!.
  rewrite (proj1 H1) by auto.
  unfold listrep at 2; fold listrep.
  entailer!.
  rewrite <- app_nil_end, rev_involutive.
  auto.
Qed.

End Verif_reverse.

(** Here is a cheat sheet of VST's tactic library (some other tactics are not
    listed):

      - hint:
            finding out what to do when you do not know what to do

      - forward:
            forward symbolic execution for assignments, break, continue, and
            return

      - forward_if:
            for if commands

      - forward_whie:
            for while commands

      - forward_for_simple_bound:
            for "for" commands

      - forward_call
            forward symbolic execution of function calls

      - Intros
            extracting existential variables and propositions in preconditions
            and left-hand-side assertions

      - Exists
            instantiating existential variables right-hand-side assertions

      - entailer!
            simplifying or solving assertion derivations

      - unfold_data_at
            unfolding data_at

      - unfold_field_at
            unfolding field_at

      - gather_SEP
            gather multiple [SEP] clauses

      - replace_SEP
            replacing a [SEP] clause with an equivalent one
*)
(* Mon May 13 04:52:44 UTC 2019 *)


Require Export SystemFR.TypeErasure.
Require Export SystemFR.TypeErasureLemmas.
Require Export SystemFR.Trees.
Require Export SystemFR.Tactics.
Require Export SystemFR.NoTypeFVar.
Require Export SystemFR.Syntax.

Lemma no_type_fvar_erased:
  forall T vars,
    no_type_fvar T vars ->
    no_type_fvar (erase_type T) vars.
Proof.
  unfold no_type_fvar; steps; eauto with fv.
Qed.


Require Import List.
Require Import Arith.
Require Import FunctionalExtensionality.

(** * Compiling C to CU *)

Require Import C.
Require Import CU.

Fixpoint compute_cleanup_n (n : nat) (e : C.expr) {struct e} : CU.expr :=
match e with
| C.App x xs => CU.App x xs (n)
| C.Constr C xs => CU.Constr C xs (n)
| C.Letrec lfs f => CU.Letrec
    (map (fun lf => match lf with
       Lf pi xs bind e => Lf pi xs bind (compute_cleanup_n bind e)
    end) lfs)
    (compute_cleanup_n (length lfs + n) f)
| C.Case f als => CU.Case (compute_cleanup_n 0 f)
    (map (fun alt => match alt with
       Alt bind e => Alt bind (compute_cleanup_n (bind + n) e)
    end) als)
end.

Definition compile : C.expr -> CU.expr := compute_cleanup_n 0.

(* Completeness *)

Hint Constructors C.Sem CU.Sem.

Definition clo_cleanup (clo : C.closure) :=
match clo with
| (Node (Lf pi xs bind e), vs) =>
    (Lf pi xs bind (compute_cleanup_n bind e) : node, vs)
| (Bloack_hole, addrs) => (Black_hole, addrs)
end.

Definition promote_heap (g : C.heap) : CU.heap :=
(heap_map clo_cleanup g).

Definition promote_value (v : C.value) : CU.value :=
match v with
| C.Val_con Gamma C ps => CU.Val_con (promote_heap Gamma) C ps
| C.Val_pap Gamma p ps => CU.Val_pap (promote_heap Gamma) p ps
end.

Create HintDb c_cu.

Theorem promote_on_heap :
forall Gamma p pi clovars bind e some_clo
  (ONHEAP : Gamma p = Some (Lf pi clovars bind e : node, some_clo)),
  promote_heap Gamma p =
    Some (Lf pi clovars bind (compute_cleanup_n bind e) : node, some_clo).
Proof with isa.
intros.
unfold promote_heap; unfold heap_map.
rewrite ONHEAP...
Qed.

Lemma look_up_app :
forall sigma clo x p tau
  (LOOKUP : look_up sigma clo x = Some p),
  look_up (sigma ++ tau) clo x = Some p.
Proof with isa.
intros.
unfold look_up in *.
destruct x...
revert n LOOKUP.
induction sigma; isa; destruct n; try discriminate...
Qed.

Lemma map_env_app :
forall xs addrs sigma tau clo
  (MAPENV : map_env sigma clo xs = Some addrs),
  map_env (sigma ++ tau) clo xs = Some addrs.
Proof with isa.
induction xs...
rename a into x.
remember (map_env sigma clo xs) as ME.
destruct ME as [addrs0 | ?]; try discriminate.
remember (look_up sigma clo x) as LU.
destruct LU as [addr0 | ?]; try discriminate.
rewrite <- MAPENV.
symmetry in HeqME; apply IHxs with (tau := tau) in HeqME; rewrite HeqME.
symmetry in HeqLU; apply look_up_app with (tau := tau) in HeqLU;
  rewrite HeqLU...
Qed.

Lemma make_closure_app :
forall sigma tau current_clo lf closure
  (CLOS : make_closure (Expr := C.expr) sigma current_clo lf =
    Some closure),
  make_closure (sigma++tau) current_clo lf = Some closure.
Proof with isa.
intros.
unfold make_closure in *.
destruct lf.
remember (map_env sigma current_clo v) as ME.
destruct ME as [addrs | ?]; try discriminate.
symmetry in HeqME; apply map_env_app with (tau := tau) in HeqME.
rewrite HeqME...
Qed.

Lemma make_closures_app :
forall sigma tau current_clo lfs closures
  (CLOS : make_closures (Expr := C.expr) sigma current_clo lfs =
    Some closures),
  make_closures (sigma++tau) current_clo lfs = Some closures.
Proof with isa.
induction lfs...
rename a into lf.
remember (make_closures sigma current_clo lfs) as MCS.
destruct MCS as [clos | ?]; try discriminate.
remember (make_closure sigma current_clo lf) as MC.
destruct MC as [clo | ?]; try discriminate.
rewrite <- CLOS.
rewrite IHlfs with (closures := clos)...
symmetry in HeqMC; apply make_closure_app with (tau := tau) in HeqMC;
  rewrite HeqMC...
Qed.

Lemma firstn_skipn :
forall A tau bind0 args
  (LENGTH : bind0 <= length (A := A) args),
  skipn bind0 (firstn bind0 args ++ tau) = tau.
Proof with isa; auto with arith.
induction bind0...
destruct args...
inversion LENGTH...
Qed.

Lemma skipn_add :
forall A n (sigma : list A) tau addrs,
skipn n (sigma ++ tau) =
  skipn (length addrs + n) ((addrs ++ sigma) ++ tau).
Proof with isa.
induction addrs...
Qed.

Lemma promote_set_cons :
forall Delta p C addrs,
promote_heap (set Delta p (C.make_cons C addrs)) =
  set (promote_heap Delta) p (CU.make_cons C addrs).
Proof with isa.
intros.
apply functional_extensionality...
unfold promote_heap; unfold heap_map; unfold set.
destruct (eq_nat_dec x p)...
Qed.

Lemma promote_set_pap :
forall Delta p q addrs,
set (promote_heap Delta) p (CU.make_pap q addrs) =
  promote_heap (set Delta p (C.make_pap q addrs)).
Proof with isa.
intros.
apply functional_extensionality...
unfold promote_heap; unfold heap_map; unfold set.
destruct (eq_nat_dec x p)...
Qed.

(* Hail Coq for the following proof, which had been admitted for
such a long time that I forgot the definitions or any intuitive
understanding of the lemma. It has been proven by a random
series of unfolding and destruction late at a very dark night. *)

Lemma promote_alloc :
forall addrs Gamma closures
  (LENGTH : length addrs = length closures),
  alloc (promote_heap Gamma) addrs (map clo_cleanup closures) =
    promote_heap (alloc Gamma addrs closures).
Proof with isa.
unfold promote_heap.
induction addrs...
destruct closures...
unfold alloc in *; unfold heap_map in *...
apply functional_extensionality...
unfold set in *...
destruct eq_nat_dec...
rewrite IHaddrs in *...
Qed.

Lemma make_closures_map_cu :
forall sigma current_clo lfs closures
(CLOS : make_closures sigma current_clo lfs = Some closures),
make_closures sigma current_clo
  (map
     (fun lf : gen_lambda_form =>
      match lf with
      | Lf pi xs bind0 e0 => Lf pi xs bind0 (compute_cleanup_n bind0 e0)
      end) lfs) = Some (map clo_cleanup closures).
Proof with isa.
induction lfs; [ isa; inversion CLOS | ]...
rename a into lf.
destruct lf as [pi0 vars0 bind0 e0].
remember (make_closures sigma current_clo lfs) as MCS.
destruct MCS as [clos | ?]; try discriminate...
remember (map_env sigma current_clo vars0) as ME.
destruct ME as [addrs | ?]; try discriminate...
rewrite IHlfs with (closures := clos)...
inversion CLOS; subst.
f_equal.
Qed.

Lemma nth_map_cu :
forall C als bind0 e0 n
  (SELECT : nth C als = Some (Alt bind0 e0)),
  nth C (map
     (fun alt : gen_alt =>
      match alt with
      | Alt bind1 e1 => Alt bind1 (compute_cleanup_n (bind1 + n) e1)
      end) als) = Some (Alt bind0 (compute_cleanup_n (bind0 + n) e0)).
Proof with isa.
induction C...
destruct als.
discriminate.
destruct g; inversion SELECT; subst...
destruct als; try discriminate...
Qed.

Lemma clog_promote :
forall Gamma p,
  clog (promote_heap Gamma) p = promote_heap (clog Gamma p).
Proof with isa; eauto.
intros.
apply functional_extensionality...
unfold clog.
unfold promote_heap...
unfold heap_map.
destruct (eq_nat_dec x p)...
subst...
destruct (eq_nat_dec p p); intuition.
destruct (Gamma p)...
destruct c...
destruct n...
destruct g...
Qed.

Hint Resolve promote_on_heap map_env_app look_up_app : c_cu.

Lemma invariant :
forall Config Value
  (EVAL : C.Sem Config Value),
  match Config with
  | C.Config Gamma e sigma args clo => forall (n : nat) (tau : env),
      CU.Sem (CU.Config (promote_heap Gamma) (compute_cleanup_n n e)
             (sigma++tau) args clo)
             (promote_value Value, skipn n (sigma++tau))
  | C.Enter Gamma p ps => forall (tau : env),
      CU.Sem (CU.Enter (promote_heap Gamma) p ps tau)
             (promote_value Value, tau)
  end.
Proof with isa; auto with c_cu.
intros.
induction EVAL...
(* Case Accum *)
eauto with c_cu.
(* Case App1 *)
apply CU.App1 with (clovars := clovars) (bind := bind)
  (some_clo := some_clo) (e := (compute_cleanup_n bind e))...
apply promote_on_heap...
(* Case App2 *)
apply CU.App2 with (clovars := clovars) (bind := bind)
  (clo := clo) (e := (compute_cleanup_n bind e))...
apply promote_on_heap...
remember (IHEVAL bind tau) as IHEVAL0; clear HeqIHEVAL0...
rewrite firstn_skipn in IHEVAL0...
(* Case App3 *)
rewrite promote_set_cons.
eapply CU.App3 with (clovars := clovars);
[ apply promote_on_heap; eauto
| rewrite clog_promote; apply IHEVAL ].
(* Case App4 *)
eapply CU.App4 with (clovars := clovars);
[ apply promote_on_heap; eauto
| rewrite clog_promote; apply IHEVAL1
| rewrite promote_set_pap; apply IHEVAL2 ].
(* Case Let *)
apply CU.Let with (addrs := addrs) (closures := map clo_cleanup closures).
rewrite LENGTH; rewrite map_length...
intros p IN;
  apply FRESH in IN;
  unfold promote_heap; unfold heap_map;
  rewrite IN...
apply make_closures_app with (tau := tau) in CLOS;
  apply make_closures_map_cu;
  rewrite <- app_ass...
assert (X := make_closures_length _ _ _ _ _ CLOS).
  assert (X0 := trans_eq LENGTH X).
  rewrite promote_alloc...
  rewrite <- app_ass.
  rewrite <- LENGTH.
  rewrite skipn_add with (addrs := addrs)...
(* Case Case_of *)
apply CU.Case_of with (bind := bind) (Delta := promote_heap Delta)
  (C := C) (addrs := addrs) (theta := sigma++tau)
  (e0 := compute_cleanup_n (bind + n) e0);
[ apply nth_map_cu
| apply IHEVAL1 with (n := 0)
| rewrite skipn_add with (addrs := addrs);
  rewrite <- app_ass; rewrite LENGTH;
  apply IHEVAL2 with (n := length addrs + n)]...
Qed.


Set Warnings "-notation-overridden".

Require Import Category.Theory.
Require Import Category.Structure.Monoidal.
Require Import Category.Lib.
Require Import Category.Structure.Monoidal.Internal.Product.
Require Import Category.Instance.Cat.
Require Import Category.Instance.Cat.Cartesian.
Require Import Category.Instance.One.

Require Import Enriched.Category.
Require Import Enriched.Functor.
Require Import Enriched.Natural.Transformation.
Require Import Enriched.TwoCategory.
Require Import Enriched.Fun.
Require Import Enriched.Forget.Lib.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section VCat.

Context {V0: Category} {V : Monoidal}.

Existing Instance enat_equiv_equivalence.

Let Cat_Monoidal := InternalProduct_Monoidal (H:= Cat_Cartesian).
Existing Instance Cat_Monoidal.

Program Definition eid_VCat (x : EnrichedCategory) : I ~{ Cat.Cat }~> Fun x x := {|
  fobj := fun _ => (EId : obj[Fun x x]);
  fmap := fun _ _ _ => enat_id;
|}.
Next Obligation.
  rewrite vert_comp_id_right.
  reflexivity.
Qed.

Program Definition ecompose_VCat (x y z : EnrichedCategory) : (Fun y z : obj[Cat.Cat]) ⨂ Fun x y ~{ Cat }~> Fun x z := {|
  fobj := fun FG => let (F, G) := FG in F ○ G;
  fmap := fun _ _ fg => let (f, g) := fg in _;
|}.
Next Obligation.
  apply (HorizontalComposite f g).
Defined.
Next Obligation.
  proper.
  simpl.
  unfold Lib.ecompose0.
  simpl in X, H.
  rewrite (H A).
  rewrite (X (e0 A)).
  reflexivity.
Qed.
Next Obligation.
  Existing Instance vert_comp_respects.
  unfold HorizontalComposite.
  rewrite outside_id, inside_id.
  intro.
  simpl.
  apply ecomp0_id_left.
Qed.
Next Obligation.
  apply interchange_law.
Qed.

Program Definition iso_functor_comp_id_left {C D : EnrichedCategory} {F : C ⟶ D} : (Id[D] ○ F : obj[Fun C D]) ≅ F := {|
  to := {| etransform := fun _ => eid; |};
  from := {| etransform := fun _ => eid; |};
|}.
Next Obligation.
  rewrite post_id, pre_id.
  normal.
  reflexivity.
Qed.
Next Obligation.
  rewrite post_id, pre_id.
  normal.
  reflexivity.
Qed.
Next Obligation.
  intro.
  simpl.
  apply ecomp0_id_left.
Qed.
Next Obligation.
  intro.
  simpl.
  apply ecomp0_id_left.
Qed.

Program Definition iso_functor_comp_id_right {C D : EnrichedCategory} {F : C ⟶ D} : (F ○ Id[C] : obj[Fun C D]) ≅ F := {|
  to := {| etransform := fun _ => eid; |};
  from := {| etransform := fun _ => eid; |};
|}.
Next Obligation.
  normal.
  rewrite post_id, pre_id.
  reflexivity.
Qed.
Next Obligation.
  normal.
  rewrite post_id, pre_id.
  reflexivity.
Qed.
Next Obligation.
  intro.
  simpl.
  apply ecomp0_id_left.
Qed.
Next Obligation.
  intro.
  simpl.
  apply ecomp0_id_left.
Qed.

Program Definition iso_functor_comp_assoc {A B C D : EnrichedCategory} {F : C ⟶ D} {G : B ⟶ C} {H : A ⟶ B} : ((F ○ G) ○ H : obj[Fun A D]) ≅ F ○ (G ○ H) := {|
  to := {| etransform := fun _ => eid; |};
  from := {| etransform := fun _ => eid; |};
|}.
Next Obligation.
  rewrite post_id, pre_id.
  normal.
  reflexivity.
Qed.
Next Obligation.
  rewrite post_id, pre_id.
  normal.
  reflexivity.
Qed.
Next Obligation.
  intro.
  simpl.
  apply ecomp0_id_left.
Qed.
Next Obligation.
  intro.
  simpl.
  apply ecomp0_id_left.
Qed.

Program Definition VCat : TwoCategory := {|
  eobj := EnrichedCategory (V := V);
  ehom := fun C D => Fun C D;
  eid := eid_VCat;
  ecompose := ecompose_VCat;
|}.
Next Obligation.
  exists (fun x0 : () ∧ (x ⟶ y) => @iso_functor_comp_id_left _ _ (snd x0) : (Id[y] ○ snd x0 : obj[Fun x y])≅ snd x0).
  intros.
  destruct x0 as [x0 F], y0 as [y0 G].
  simpl in f.
  destruct f as [f' f].
  intro.
  simpl.
  Existing Instance ecompose0_respects.
  do 2 rewrite ecomp0_id_left.
  rewrite ecomp0_id_right.
  normal.
  reflexivity.
Qed.
Next Obligation.
  exists (fun x0 : (x ⟶ y) ∧ () => @iso_functor_comp_id_right _ _ (fst x0) : (fst x0 ○ Id[x] : obj[Fun x y])≅ fst x0).
  intros.
  destruct x0 as [x0 F], y0 as [y0 G].
  simpl in f.
  destruct f as [f' f].
  intro.
  simpl.
  rewrite efmap_id.
  rewrite ecomp0_id_left, ecomp0_id_right.
  reflexivity.
Qed.
Next Obligation.
  unshelve eexists (fun FGH => _).
  + destruct FGH as [[F G] H].
    simpl.
    apply iso_functor_comp_assoc.
  + intros.
    destruct x0 as [[F0 F1] F2], y0 as [[G0 G1] G2].
    simpl in f.
    destruct f as [[f0 f1] f2].
    intro.
    simpl.
    rewrite ecomp0_id_left.
    rewrite ecomp0_id_right.
    rewrite ecomp0_assoc.
    f_equiv.
    transitivity (efmap0 (F:=F0) _ _ (ecompose0 (f1 (G2 A)) ((efmap (EnrichedFunctor:=F1)) ∘ f2 A)%morphism)).
    rewrite (efmap_comp0 _ _ _ (f1 (G2 A)) (efmap ∘ f2 A)%morphism).
    unfold efmap0.
    normal.
    reflexivity.
    unfold efmap0.
    reflexivity.
Qed.

End VCat.

(*
Section VCat0.

Context {V0: Category} {V : Monoidal}.

Program Definition VCat0 : Category := {|
  obj := EnrichedCategory (V := V);
  hom := fun C D => C ⟶ D;
  id := fun _ => EId;
  Category.compose := fun _ _ _ => ECompose;
|}.
Next Obligation.

End VCat0.
*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	              Pullbacks in SET                  		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Pullbacks.
Require Export Setoid_prop.
Require Export SET.
Require Export SetoidPROD.

Set Implicit Arguments.
Unset Strict Implicit.

Section s_pulb_def.

Variables (A B C : Setoid) (f : Map A B) (g : Map C B).

Definition S_pulb_pred (axc : SPROD A C) :=
  f (Sprod_l axc) =_S g (Sprod_r axc).

Lemma S_pulb_reg : Reg_law S_pulb_pred.
Proof.
unfold Reg_law, S_pulb_pred in |- *; intros a1xc1 a2xc2 H1 H2.
elim H1; intros H3 H4.
apply Trans with (f (Sprod_l a1xc1)).
apply Pres1; apply Sym; assumption.
apply Trans with (g (Sprod_r a1xc1)).
assumption.
apply Pres1; assumption.
Qed.

Canonical Structure S_pulb_constr := Build_Setoid_pred S_pulb_reg.

Definition S_pulb_prod := SubSetoid S_pulb_constr.

Definition S_pulb_p := RestrictedMap (Proj1_SPROD A C) S_pulb_constr.

Definition S_pulb_q := RestrictedMap (Proj2_SPROD A C) S_pulb_constr.

Lemma S_pulb_law1 : Pullback_law1 f g S_pulb_p S_pulb_q.
Proof.
unfold Pullback_law1, Pullback_eq1 in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; intro x; elim x; unfold Comp_fun in |- *;
 simpl in |- *.
trivial.
Qed.

 Section s_pulb_diese_def.

 Variables (D : Setoid) (t1 : Map D A) (t2 : Map D C).
 Hypothesis H : Pullback_eq1 f g t1 t2.

 Lemma Check_S_pulb_constr :
  forall d : D, S_pulb_constr (Build_Sprod (t1 d) (t2 d)).
 Proof.
 intro d; exact (H d).
 Qed.

 Canonical Structure S_pulb_fun (d : D) :=
   Build_SubType (Check_S_pulb_constr d).

 Lemma S_pulb_map_law : Map_law S_pulb_fun.
 Proof.
 unfold Map_law in |- *; simpl in |- *; unfold Equal_Sprod in |- *;
  simpl in |- *.
 intros x y H1; split; apply Pres1; trivial.
 Qed.

 Canonical Structure S_pulb_diese := Build_Map S_pulb_map_law.

 End s_pulb_diese_def.

Lemma S_pulb_law2 : Pullback_law2 S_pulb_p S_pulb_diese.
Proof.
unfold Pullback_law2, Pullback_eq2 in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; intros; simpl in |- *.
apply Refl.
Qed.

Lemma S_pulb_law3 : Pullback_law3 S_pulb_q S_pulb_diese.
Proof.
unfold Pullback_law3, Pullback_eq2 in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; intros; simpl in |- *.
apply Refl.
Qed.

Lemma S_pulb_law4 : Pullback_law4 S_pulb_p S_pulb_q S_pulb_diese.
Proof.
unfold Pullback_law4, Pullback_eq2 in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; intros D t1 t2 H h H1 H2 x.
unfold Equal_Sprod in |- *; simpl in |- *; split.
apply Sym; apply H1.
apply Sym; apply H2.
Qed.

Canonical Structure S_pulb :=
  Build_Pullback S_pulb_law1 S_pulb_law2 S_pulb_law3 S_pulb_law4.

End s_pulb_def.


(**
This example is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2014-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals.
From Flocq Require Import Core.
From Gappa Require Import Gappa_tactic.
From Interval Require Import Tactic.

Open Scope R_scope.

Lemma rel_helper :
  forall xa xe b : R,
  xe <> 0 ->
  (Rabs ((xa - xe) / xe) <= b <-> Rabs (xa - xe) <= b * Rabs xe).
Proof.
intros xa xe b Zx.
unfold Rdiv.
rewrite Rabs_mult, Rabs_Rinv by exact Zx.
split ; intros H.
- apply Rmult_le_reg_r with (/ Rabs xe).
  apply Rinv_0_lt_compat.
  now apply Rabs_pos_lt.
  rewrite Rmult_assoc, Rinv_r, Rmult_1_r.
  exact H.
  now apply Rabs_no_R0.
- apply Rmult_le_reg_r with (Rabs xe).
  now apply Rabs_pos_lt.
  rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
  exact H.
  now apply Rabs_no_R0.
Qed.

Lemma Rdiv_compat_r :
  forall a b c : R, a <> 0 -> c <> 0 ->
  (a*b) / (a*c) = b/c.
Proof.
intros a b c Ha Hc.
field.
apply conj.
apply Hc.
apply Ha.
Qed.

Notation pow2 := (bpow radix2).
Notation rnd := (round radix2 (FLT_exp (-1074) 53) ZnearestE).

Definition add x y := rnd (x + y).
Definition sub x y := rnd (x - y).
Definition mul x y := rnd (x * y).
Definition div x y := rnd (x / y).
Definition nearbyint x := round radix2 (FIX_exp 0) ZnearestE x.

Definition Log2h := 3048493539143 * pow2 (-42).
Definition Log2l := 544487923021427 * pow2 (-93).
Definition InvLog2 := 3248660424278399 * pow2 (-51).

Definition p0 := 1 * pow2 (-2).
Definition p1 := 4002712888408905 * pow2 (-59).
Definition p2 := 1218985200072455 * pow2 (-66).
Definition q0 := 1 * pow2 (-1).
Definition q1 := 8006155947364787 * pow2 (-57).
Definition q2 := 4573527866750985 * pow2 (-63).

Definition cw_exp (x : R) :=
  let k := nearbyint (mul x InvLog2) in
  let t := sub (sub x (mul k Log2h)) (mul k Log2l) in
  let t2 := mul t t in
  let p := add p0 (mul t2 (add p1 (mul t2 p2))) in
  let q := add q0 (mul t2 (add q1 (mul t2 q2))) in
  pow2 (Zfloor k + 1) * (add (div (mul t p) (sub q (mul t p))) (1/2)).

Lemma method_error :
  forall t : R,
  let t2 := t * t in
  let p := p0 + t2 * (p1 + t2 * p2) in
  let q := q0 + t2 * (q1 + t2 * q2) in
  let f := 2 * ((t * p) / (q - t * p) + 1/2) in
  Rabs t <= 355 / 1024 ->
  Rabs ((f - exp t) / exp t) <= 23 * pow2 (-62).
Proof.
intros t t2 p q f Ht.
unfold f, q, p, t2, p0, p1, p2, q0, q1, q2 ;
interval with (i_bisect t, i_taylor t, i_degree 9, i_prec 70).
Qed.

Lemma argument_reduction :
  forall x : R,
  generic_format radix2 (FLT_exp (-1074) 53) x ->
  -746 <= x <= 710 ->
  let k := nearbyint (mul x InvLog2) in
  let tf := sub (sub x (mul k Log2h)) (mul k Log2l) in
  let te := x - k * ln 2 in
  Rabs tf <= 355 / 1024 /\
  Rabs (tf - te) <= 65537 * pow2 (-71).
Proof with auto with typeclass_instances.
intros x Fx Bx k tf te.
assert (Rabs x <= 5/16 \/ 5/16 <= Rabs x <= 746) as [Bx'|Bx'] by gappa.
- assert (k = 0).
    clear -Bx'.
    refine (let H := _ in Rle_antisym _ _ (proj2 H) (proj1 H)).
    unfold k, mul, nearbyint, InvLog2, Log2h ; gappa.
  unfold tf, te, mul, sub.
  rewrite H.
  rewrite 2!Rmult_0_l.
  rewrite round_0...
  rewrite Rmult_0_l.
  rewrite 2!Rminus_0_r.
  rewrite 2!round_generic with (2 := Fx)...
  gappa.
- assert (Hl: - 1 * pow2 (-102) <= Log2l - (ln 2 - Log2h) <= 0).
    unfold Log2l, Log2h ;
    interval with (i_prec 110).
  assert (Ax: x = x * InvLog2 * (1 / InvLog2)).
    field.
    unfold InvLog2 ; interval.
  unfold te.
  replace (x - k * ln 2) with (x - k * Log2h - k * (ln 2 - Log2h)) by ring.
  revert Hl Ax.
  unfold tf, te, k, sub, mul, nearbyint, InvLog2, Log2h, Log2l ; gappa.
Qed.

Theorem exp_correct :
  forall x : R,
  generic_format radix2 (FLT_exp (-1074) 53) x ->
  -746 <= x <= 710 ->
  Rabs ((cw_exp x - exp x) / exp x) <= 1 * pow2 (-51).
Proof.
intros x Fx Bx.
generalize (argument_reduction x Fx Bx).
unfold cw_exp.
set (k := nearbyint (mul x InvLog2)).
set (t := sub (sub x (mul k Log2h)) (mul k Log2l)).
set (t2 := mul t t).
intros [Bt Et].
clearbody t.
generalize (method_error t Bt).
intros Ef.
rewrite bpow_plus, Rmult_assoc.
assert (exp x = pow2 (Zfloor k) * exp (x - k * ln 2)) as ->.
  assert (exists k', k = IZR k') as [k' ->] by (eexists ; apply Rmult_1_r).
  rewrite Zfloor_IZR, bpow_exp, <- exp_plus.
  apply f_equal.
  simpl ; ring.
rewrite <- Rmult_minus_distr_l.
rewrite Rdiv_compat_r.
2: apply Rgt_not_eq, bpow_gt_0.
2: apply Rgt_not_eq, exp_pos.
clearbody k.
revert Et.
generalize (x - k * ln 2).
clear x Fx Bx.
intros x Ex.
assert (Rabs ((exp t - exp x) / exp x) <= 33 * pow2 (-60)).
  unfold Rdiv.
  rewrite Rmult_minus_distr_r.
  rewrite Rinv_r by apply Rgt_not_eq, exp_pos.
  rewrite <- exp_Ropp, <- exp_plus.
  revert Ex.
  unfold Rminus ; generalize (t + - x) ; clear.
  intros r Hr ; interval with (i_prec 60).
apply rel_helper. apply Rgt_not_eq, exp_pos.
apply rel_helper in H. 2: apply Rgt_not_eq, exp_pos.
apply rel_helper in Ef. 2: apply Rgt_not_eq, exp_pos.
unfold t2, add, mul, sub, div, p0, p1, p2, q0, q1, q2 in * ; gappa.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus lv1 (plus lv0 lv2))).
Admitted.
QuickChick conj18eqsynthconj5.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj24synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus (mult lv0 lv1) lv2)) (plus (mult lv0 lv3) lv3)).
Admitted.
QuickChick conj24synthconj5.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ A C /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O A Cprime /\ col_ A B C))))))))))))))) -> col_ O A Aprime)).
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 A B C P Q I : Universe, ((wd_ P Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ A I /\ (wd_ I B /\ (wd_ A B /\ (wd_ P I /\ (wd_ Q I /\ (col_ A I B /\ (col_ P Q I /\ col_ A B Q))))))))))))))))) -> col_ B P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Monic.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

Reserved Notation "C ₊" (at level 1).

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
 Definition Mono (C: Category): Monic :=
  {|
  C := {|
    Obj := C ;
    Mor A B := {f: C A B | ∀ (Z:C) (x y: C Z A), (f ∘ x == f ∘ y) → x == y } ;
    Mor_Setoid _ _ := {| equiv x y := (x :>) == (y :>) |} ;
    id := @id _ ;
    compose := @compose _ ;
  |} ;
|}.

Next Obligation.
Proof.
  exists.
  - intro.
    reflexivity.
  - intros ? ? ?.
    symmetry.
    auto.
  - intros ? ? ? p q.
    rewrite p, q.
    reflexivity.
Qed.

Next Obligation.
Proof.
  repeat rewrite compose_id_left in H.
  assumption.
Qed.

Next Obligation.
Proof.
  repeat rewrite <- compose_assoc in H.
  apply (H0 _ _ _ (H1 _ _ _ H)).
Qed.

Next Obligation.
Proof.
  intros ? ? p ? ? q.
  cbn.
  rewrite p, q.
  reflexivity.
Qed.

Module MonoNotations.
  Notation "C ₊" := (Mono C) : category_scope.
End MonoNotations.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.