(*************************************************************************)
(** The simply-typed lambda calculus in Coq. *)
(*************************************************************************)

(** An interactive tutorial on developing programming language
    metatheory.  This file uses the simply-typed lambda calculus
    (STLC) to demonstrate the locally nameless representation of
    lambda terms and cofinite quantification in judgments.

    This tutorial concentrates on "how" to formalize STLC; for more
    details about "why" we use this style of development see:
    "Engineering Formal Metatheory", Aydemir, Charguéraud, Pierce,
    Pollack, Weirich. POPL 2008.

    Tutorial authors: Brian Aydemir and Stephanie Weirich, with help
    from Aaron Bohannon, Nate Foster, Benjamin Pierce, Jeffrey
    Vaughan, Dimitrios Vytiniotis, and Steve Zdancewic.  Adapted from
    code by Arthur Charguéraud.
*)

(*************************************************************************)
(** * Contents
    - Syntax of STLC
    - Substitution
    - Free variables
    - Open
    - Local closure
    - Properties about basic operations
    - Cofinite quantification
    - Tactic support
    - Typing environments
    - Typing relation
    - Weakening
    - Substitution
    - Values and evaluation
    - Preservation
    - Progress
    - Additional properties

  Solutions to exercises are in [STLC_Solutions.v].
*)
(*************************************************************************)

(* First, we import a number of definition from the Metatheory
   library (see Metatheory.v). The following command makes those
   definitions available in the rest of this file. This command
   will only succeed if you have already run "make" in the tutorial
   directory to compile the Metatheory library.
*)
Require Import Metatheory.

(*************************************************************************)
(** * Syntax of STLC *)
(*************************************************************************)

(** We use a locally nameless representation for the simply-typed
    lambda calculus, where bound variables are represented as natural
    numbers (de Bruijn indices) and free variables are represented as
    [atom]s.  The type [atom], defined in the [Atom] library,
    represents names: equality is decidable on atoms (eq_atom_dec),
    and it is possible to generate an atom fresh for any given
    finite set of atoms (atom_fresh_for_set).
*)

Inductive typ : Set :=
  | typ_base  : typ
  | typ_arrow : typ -> typ -> typ.

Inductive exp : Set :=
  | bvar : nat  -> exp    (* bound variables *)
  | fvar : atom -> exp   (* free  variables *)
  | abs  : exp  -> exp
  | app  : exp  -> exp -> exp.

Coercion bvar : nat >-> exp.
Coercion fvar : atom >-> exp.

(** We declare the constructors for indices and variables to be
    coercions. That way, if Coq sees a [nat] where it expects an
    [exp], it will implicitly insert an application of [bvar]; and
    similarly for [atom]s.
*)

(** For example, we can encode the expression (\x. Y x) as below. *)
(** Because "Y" is free variable in this term, we need to assume an
    atom for this name.
*)

Parameter Y : atom.
Definition demo_rep1 := abs (app Y 0).

(** Note that because of the coercions we may write
    [abs (app Y 0)] instead of [abs (app (fvar Y) (bvar 0))].
*)

(** Another example: the encoding of (\x. \y. (y x)) *)
Definition demo_rep2 := abs (abs (app 0 1)).

(** *** Exercise [two] *)

(** Convert the following lambda calculus term to locally nameless
representation.
*)

(** "two"    \s. \z. s(s z) **)

Definition two := abs (abs (app 1 (app 1 0))).

(** There are two important advantages of the locally nameless
    representation:
     - Alpha-equivalent terms have a unique representation,
       we're always working up to alpha-equivalence.
     - Operations such as free variable substitution and free
       variable calculation have simple recursive definitions
      (and therefore are simple to reason about).

    Weighed against these advantages are two drawbacks:
     - The [exp] datatype admits terms, such as [abs 3], where
       indices are unbound.
       A term is called "locally closed" when it contains
       no unbound indices.
     - We must define *both* bound variable & free variable
       substitution and reason about how these operations
       interact with eachother.

*)

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

(** Substitution replaces a free variable with a term.  The definition
    below is simple for two reasons:
      - Because bound variables are represented using indices, there
        is no need to worry about variable capture.
      - We assume that the term being substituted in is locally
        closed.  Thus, there is no need to shift indices when
        passing under a binder.
*)

Fixpoint subst (z : atom) (u : exp) (e : exp) {struct e} : exp :=
  match e with
    | bvar i => bvar i
    | fvar x => if x == z then u else (fvar x)
    | abs e1 => abs (subst z u e1)
    | app e1 e2 => app (subst z u e1) (subst z u e2)
  end.
(** The Fixpoint keyword defines a Coq function. As all functions in
    Coq must be total, the annotation [{struct e}] indicates the termination
    metric---all recursive calls in this definition are made to
    arguments that are structurally smaller than [e].
*)

(* Note also that subst uses the notation [x == z] for
   decidable atom equality. (This notation is defined in
   [Metatheory].)
*)

(** We define a notation for free variable substitution that mimics
    standard mathematical notation. *)

Notation "[ z ~> u ] e" := (subst z u e) (at level 68).

(** To demonstrate how free variable substitution works, we
    need to reason about decidable equality.
*)
Parameter Z : atom.
Check (Y == Z).

(** The decidable atom equality function returns a sum. If the
    two atoms are equal, the left branch of the sum is returned,
    carrying a proof of the proposition that the atoms are equal.
    If they are not equal, the right branch includes a proof of
    the disequality.
*)

(** The demo below uses three new tactics:
    - The tactic [simpl] reduces a Coq expression to its normal
      form.
    - The tactic [Case] marks cases in the proof script.
      It takes any string as its argument, and puts that string in
      the hypothesis list until the case is finished.
    - The tactic [destruct (Y==Y)] considers the two possible
      results of the equality test.
*)

Lemma demo_subst1:  [Y ~> Z] (abs (app 0 Y)) = (abs (app 0 Z)).
Proof.
  simpl.
  destruct (Y==Y).
    Case "left".
      auto.
    Case "right".
      destruct n. auto.
Qed.

(*************************************************************************)
(** * Free variables *)
(*************************************************************************)

(** The function [fv], defined below, calculates the set of free
    variables in an expression.  Because we are using locally nameless
    representation, where bound variables are represented as indices,
    any name we see is a free variable of a term.  In particular, this
    makes the [abs] case simple.
*)

Fixpoint fv (e : exp) {struct e} : atoms :=
  match e with
    | bvar i => {}
    | fvar x => singleton x
    | abs e1 => fv e1
    | app e1 e2 => (fv e1) `union` (fv e2)
  end.

(** The type [atoms] represents a finite set of elements of type [atom],
    and the notations for the empty set and infix union are defined in
    the Metatheory library.
*)

(** *** EXERCISE [subst_fresh] *)

(** To show the ease of reasoning with these definitions, we will
    prove a standard result from lambda calculus: if a variable does
    not appear free in a term, then substituting for it has no
    effect.
*)

Lemma subst_fresh : forall (x : atom) e u,
  x `notin` fv e -> [x ~> u] e = e.
Proof.
  intros x e u H.
  induction e.
  Case "bvar".
   auto.
  Case "fvar".
   simpl.
   destruct (a == x).
    SCase "a=x".
      subst. simpl fv in H. fsetdec.
    SCase "a<>x".
      auto.
  Case "abs".
    simpl.
    f_equal.
    auto.
  Case "app".
    simpl in *.
    f_equal.
    auto.
    auto.
Qed.

(*************************************************************************)
(** * Opening *)
(*************************************************************************)

(** Opening replaces an index with a term. It corresponds to informal
    substitution for a bound variable, such as in the rule for beta
    reduction. Note that only "dangling" indices (those that do not
    refer to any abstraction) can be opened. Opening has no effect for
    terms that are locally closed.

    Natural numbers are just an inductive datatype with two
    constructors: O and S, defined in Coq.Init.Datatypes.
    The notation [k === i] is the decidable equality function for
    natural numbers (cf. Coq.Peano_dec.eq_nat_dec).
    This notation is defined in the [Metatheory] library.

    We make several simplifying assumptions in defining [open_rec].

    First, we assume that the argument [u] is locally closed.  This
    assumption simplifies the implementation since we do not need to
    shift indices in [u] when passing under a binder.  Second, we
    assume that this function is initially called with index zero and
    that zero is the only unbound index in the term.  This eliminates
    the need to possibly subtract one in the case of indices.

    There is no need to worry about variable capture because bound
    variables are indices.
*)

Fixpoint open_rec (k : nat) (u : exp) (e : exp) {struct e} : exp :=
  match e with
    | bvar i => if k === i then u else (bvar i)
    | fvar x => fvar x
    | abs e1 => abs (open_rec (S k) u e1)
    | app e1 e2 => app (open_rec k u e1) (open_rec k u e2)
  end.

(** We also define a notation for [open_rec].
*)

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).

(** Many common applications of opening replace index zero with an
    expression or variable.  The following definition provides a
    convenient shorthand for such uses.  Note that the order of
    arguments is switched relative to the definition above.  For
    example, [(open e x)] can be read as "substitute the variable [x]
    for index [0] in [e]" and "open [e] with the variable [x]."
    Recall that the coercions above let us write [x] in place of
    [(fvar x)].
*)

Definition open e u := open_rec 0 u e.

(** This next demo shows the operation of 'open'.  For example, the
   locally nameless representation of the term (\y. (\x. (y x)) y)
   is [abs (app (abs (app 1 0)) 0)]. To look at the body
   without the outer abstraction, we need to replace the indices that
   refer to that abstraction with a name.
   Therefore, we show that we can open the body of the abs above
   with Y to produce [app (abs (app Y 0)) Y)].
*)

Lemma demo_open :
  open (app (abs (app 1  0))  0) Y =
       (app (abs (app Y 0)) Y).

Proof.
unfold open.
unfold open_rec.
simpl.
auto.
Qed.

(*************************************************************************)
(*                                                                       *)
(*  Stretch break (5 mins)                                               *)
(*                                                                       *)
(*************************************************************************)

(*************************************************************************)
(** * Local closure *)
(*************************************************************************)

(** Recall that [exp] admits terms that contain unbound indices.
    We say that a term is locally closed,
    when no indices appearing in it are unbound.  The proposition
    [lc e] holds when an expression [e] is locally closed.

    The inductive definition below formalizes local closure such that
    the resulting induction principle serves as the structural
    induction principle over (locally closed) expressions.  In
    particular, unlike induction for type exp, there is no cases
    for bound variables.  Thus, the induction principle corresponds more
    closely to informal practice than the one arising from the
    definition of pre-terms.
*)

Inductive lc : exp -> Prop :=
  | lc_var : forall x,
      lc (fvar x)
  | lc_abs : forall L e,
      (forall x:atom, x `notin` L -> lc (open e x)) ->
      lc (abs e)
  | lc_app : forall e1 e2,
      lc e1 ->
      lc e2 ->
      lc (app e1 e2).

Hint Constructors lc : core.

(*************************************************************************)
(** Properties about basic operations *)
(*************************************************************************)

(** The first property we would like to show is the analogue to subst_fresh:
    that index substitution has no effect for closed terms.

    Here is an initial attempt at the proof.
*)

Lemma open_rec_lc_0 : forall k u e,
  lc e ->
  e = {k ~> u} e.
Proof.
  intros k u e LC.
  induction LC.
  Case "lc_fvar".
    simpl. auto.
  Case "lc_abs".
    simpl.
    f_equal.
Admitted.

(** At this point there are two problems. Our goal is about substitution
    for index [S k] in term [e], while our induction hypothesis IHLC only
    tells use about index [k] in term [open e x].

    To solve the first problem, we generalize our IH over all k.
    That way, when k is incremented in the abs case, it will still apply.
    Below, we use the tactic [generalize dependent] to generalize over
    [k] before using induction.
*)

Lemma open_rec_lc_1 : forall k u e,
  lc e ->
  e = {k ~> u} e.
Proof.
  intros k u e LC.
  generalize dependent k.
  induction LC.
  Case "lc_fvar".
    simpl. auto.
  Case "lc_abs".
    simpl.
    intro k.
    f_equal.
Admitted.

(** At this point we are still stuck because the IH concerns
   [open e x] instead of [e]. The result that
   we need is that if an index substitution has no effect for
   an opened term, then it has no effect for the raw term (as long
   as we are *not* substituting for 0, hence S k below).
<<
   open e x = {S k ~> u}(open e x)  -> e = {S k ~> u} e
>>
   In other words, expanding the definition of open:
<<
   {0 ~> x}e = {S k ~> u}({0 ~> x} e)  -> e = {S k ~> u} e
>>
   Of course, to prove this result, we must generalize
   0 and S k to be any pair of inequal numbers to get a strong
   enough induction hypothesis for the abs case.
 *)

Lemma open_rec_lc_core : forall e j v i u,
  i <> j ->
  {j ~> v} e = {i ~> u} ({j ~> v} e) ->
  e = {i ~> u} e.
Proof with eauto*.
  induction e; intros j v i u Neq H; simpl in *;
      try solve [inversion H; f_equal; eauto].
  Case "bvar".
    destruct (j === n)...
    destruct (i === n)...
Qed.

(** With the help of this lemma, we can complete the proof. *)

Lemma open_rec_lc : forall k u e,
  lc e ->
  e = {k ~> u} e.
Proof.
  intros k u e LC.
  generalize dependent k.
  induction LC.
  Case "lc_fvar".
    simpl. auto.
  Case "lc_abs".
    simpl.
    intro k.
    f_equal.
    unfold open in *.
    pick fresh x for L.
    apply open_rec_lc_core with (i := S k) (j := 0) (u := u) (v := x). auto. auto.
  Case "lc_app".
    intro k. simpl. f_equal. auto. auto.
Qed.

(** *** Take-home Exercise [subst_open_rec] *)

(** The next lemma demonstrates that free variable substitution
   distributes over index substitution.

   The proof of this lemma is by straightforward induction over
   e1. When e1 is a free variable, we need to appeal to
   [open_rec_lc], proved above.
*)

Lemma subst_open_rec : forall e1 e2 u x k,
  lc u ->
  [x ~> u] ({k ~> e2} e1) = {k ~> [x ~> u] e2} ([x ~> u] e1).
Proof.
  induction e1; intros e2 u x k H; simpl in *; f_equal; auto.
  Case "bvar".
    destruct (k === n); auto.
  Case "fvar".
    destruct (a == x); subst; auto.
    apply open_rec_lc; auto.
Qed.

(** *** Exercise [subst_open_var] *)

(** The lemma above is most often used with k = 0 and
    e2 as some fresh variable. Therefore, it simplifies matters
    to define the following useful corollary.
*)

Lemma subst_open_var : forall (x y : atom) u e,
  y <> x ->
  lc u ->
  open ([x ~> u] e) y = [x ~> u] (open e y).
Proof.
  intros x y u e Neq H.
  unfold open.
  rewrite subst_open_rec with (e2 := y).
  simpl.
  destruct (y == x).
    Case "y=x".
    destruct Neq. auto.
    Case "y<>x".
    auto.
  auto.
Qed.

(*************************************************************************)
(** Cofinite quantification *)
(*************************************************************************)

(* In the next example, we will reexamine the definition of
   [lc] in the abs case.

   The lemma [subst_lc] says that local closure is preserved by
   substitution. Let's start working through this proof.
*)

Lemma subst_lc_1 : forall (x : atom) u e,
  lc e ->
  lc u ->
  lc ([x ~> u] e).
Proof.
  intros x u e He Hu.
  induction He.
  Case "lc_fvar".
   simpl.
   destruct (x0 == x).
     auto.
     auto.
  Case "lc_abs".
   simpl.
Admitted.

(** Here we are stuck. We don't know that x0 is not the same as x.

    The solution is to change the *definition* of local closure so that
    we get a different induction principle. Currently, in the lc_abs
    case, we show that an abstraction is locally closed by showing
    that the body is locally closed, after it has been opened with
    one particular variable.

<<
  | lc_abs : forall (x:atom) e,
      lc (open e x) ->
      lc (abs e)
>>

   Therefore, our induction hypothesis in this case only applies to that
   variable. From the hypothesis list in the abs case:

    x0 : atom
    IHHe : lc ([x ~> u]open e x0)

   The problem is that we don't have any assumptions about x0. It
   could very well be equal to x.

   A stronger induction principle provides an IH that applies to many
   variables. In that case, we could pick one that is "fresh enough".
   To do so, we need to edit the above definition of lc and
   replace the type of lc_abs with this one:

<<
  | lc_abs : forall L e,
      (forall x:atom, x `notin` L -> lc (open e x)) ->
      lc (abs e)
>>

  This rule says that to show that an abstraction is locally closed,
  we need to show that the body is closed, after it has been opened
  by any atom x, *except* those in some set L. With this rule, the
  IH in this proof is now:

  H0 : forall x0 : atom, x0 `notin` L -> lc ([x ~> u]open e x0)

  We call this "cofinite quantification" because the IH applies to
  an infinite number of atoms x0, except those in some finite set L.

  Changing the rule in this way does not change what terms are locally
  closed.  (For more details about cofinite-quantification see:
  "Engineering Formal Metatheory", Aydemir, Chargu\u00e9raud, Pierce,
  Pollack, Weirich. POPL 2008.)

  So to complete this proof, make the change to lc_abs above.  Note,
  that you will need to go back to the proof of [open_rec_lc] and
  patch it as well.  To fix that proof, add the line
  [pick fresh x for L.]  immediately before [apply open_rec_lc_core].
  This tactic, defined in [Metatheory], introduces a new atom [x] that
  is known not to be in the set [L].

 You will also have to comment out [subst_lc_1].

  Once these changes have been made, we can complete the proof
  of subst_lc.

*)

Lemma subst_lc : forall (x : atom) u e,
  lc e ->
  lc u ->
  lc ([x ~> u] e).
Proof.
  intros x u e He Hu.
  induction He.
  Case "lc_var".
   simpl.
   destruct (x0 == x).
     auto.
     auto.
  Case "lc_abs".
   simpl.
    apply lc_abs with (L := L `union` singleton x).
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
  Case "lc_app".
     simpl. auto.
Qed.

(*************************************************************************)
(** * Tactic support *)
(*************************************************************************)

(** When picking a fresh atom or applying a rule that uses cofinite
    quantification, choosing a set of atoms to be fresh for can be
    tedious.  In practice, it is simpler to use a tactic to choose the
    set to be as large as possible.

    The first tactic we define, [gather_atoms], is used to collect
    together all the atoms in the context.  It relies on an auxiliary
    tactic from [Atom.v], [gather_atoms_with], which collects together
    the atoms appearing in objects of a certain type.  The argument to
    [gather_atoms_with] is a function that should return the set of
    atoms appearing in its argument. *)

Ltac gather_atoms :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (atom * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv x) in
  constr:(A `union` B `union` C `union` D).

(** We can use [gather_atoms] to define a variant of the [(pick fresh
    x for L)] tactic, which we call [(pick fresh x)].  The tactic
    chooses an atom fresh for "everything" in the context. *)

Tactic Notation "pick" "fresh" ident(x) :=
  let L := gather_atoms in
  (pick fresh x for L).

(** We can also use [gather_atoms] to define a tactic for applying a
    rule that is defined using cofinite quantification.  The tactic
    [(pick fresh x and apply H)] applies a rule [H], just as the
    [apply] tactic would.  However, the tactic also picks a
    sufficiently fresh name [x] to use.

    Note: We define this tactic in terms of another tactic, [(pick
    fresh x excluding L and apply H)], which is defined and documented
    in [Metatheory.v]. *)

Tactic Notation
      "pick" "fresh" ident(atom_name) "and" "apply" constr(lemma) :=
  let L := gather_atoms in
  pick fresh atom_name excluding L and apply lemma.

(** *** Example

    Below, we reprove [subst_lc] using [(pick fresh and apply)].
    Step through the proof below to see how [(pick fresh and apply)]
    works. *)

Lemma subst_lc_alternate_proof : forall (x : atom) u e,
  lc e ->
  lc u ->
  lc ([x ~> u] e).
Proof.
  intros x u e He Hu.
  induction He.
  Case "fvar".
   simpl.
   destruct (x0 == x).
     auto.
     auto.
  Case "abs".
    simpl.
    pick fresh y and apply lc_abs.
    (* Here, take note of the hypothesis [Fr]. *)
    rewrite subst_open_var. auto. auto. auto.
  Case "app".
     simpl. auto.
Qed.

(*************************************************************************)
(*                                                                       *)
(*  Coffee break (30 mins)                                               *)
(*                                                                       *)
(*************************************************************************)

(*************************************************************************)
(** * Typing environments *)
(*************************************************************************)

(** We represent environments as association lists (lists of pairs of
    keys and values) whose keys are [atom]s.  New bindings are added
    to the head of the list.

    Lists are defined in Coq's standard library. *)

Print list.

(** Here, environments bind [atom]s to [typ]s.  We define an
    abbreviation [env] for the type of these environments.  Coq will
    print [list (atom * typ)] as [env], and we can use [env] as a
    shorthand for writing [list (atom * typ)]. *)

Notation env := (list (atom * typ)).

(** The [Environment] library, which is included by the [Metatheory]
    library, provides functions, predicates, tactics, and lemmas that
    simplify working with environments.  Note that everything in the
    library is polymorphic over the type of objects bound in the
    environment.  Look in [Environment.v] for additional details about
    the functions and predicates that we mention below.

    The function [dom] computes the domain of an environment,
    returning a finite set of [atom]s. *)

Check dom.

(** The unary predicate [ok] holds when each atom is bound at most
    once in an environment. *)

Print ok.

(** The ternary predicate [binds] holds when a given binding is
    present in an environment.  More specifically, [binds x a E] holds
    when the binding for [x] closest to the head of [E] binds [x] to
    [a]. *)

Check binds.

(*************************************************************************)
(** * Typing relation *)
(*************************************************************************)

(** The definition of the typing relation is straightforward.  In
    order to ensure that the relation holds for only well-formed
    environments, we check in the [typing_var] case that the
    environment is [ok].  The structure of typing derivations
    implicitly ensures that the relation holds only for locally closed
    expressions.  Finally, note the use of cofinite quantification in
    the [typing_abs] case. *)

Inductive typing : env -> exp -> typ -> Prop :=
  | typing_var : forall E (x : atom) T,
      ok E ->
      binds x T E ->
      typing E (fvar x) T
  | typing_abs : forall L E e T1 T2,
      (forall x : atom, x `notin` L ->
        typing ((x, T1) :: E) (open e x) T2) ->
      typing E (abs e) (typ_arrow T1 T2)
  | typing_app : forall E e1 e2 T1 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (app e1 e2) T2.

(** We add the constructors of the typing relation as hints to be used
    by the [auto] and [eauto] tactics. *)

Hint Constructors typing.

(*************************************************************************)
(** * Weakening *)
(*************************************************************************)

(** Weakening states that if an expression is typeable in some
    environment, then it is typeable in any well-formed extension of
    that environment.  This property is needed to prove the
    substitution lemma.

    As stated below, this lemma is not directly proveable.  The
    natural way to try proving this lemma proceeds by induction on the
    typing derivation for [e]. *)

Lemma typing_weakening_0 : forall E F e T,
  typing E e T ->
  ok (F ++ E) ->
  typing (F ++ E) e T.
Proof.
  intros E F e T H J.
  induction H; eauto.
  Case "typing_abs".
    pick fresh x and apply typing_abs.
    (* ... stuck here ... *)
Admitted.

(** We are stuck in the [typing_abs] case because the induction
    hypothesis [H0] applies only when we weaken the environment at its
    head.  In this case, however, we need to weaken the environment in
    the middle; compare the conclusion at the point where we're stuck
    to the hypothesis [H], which comes from the given typing derivation.

    We can obtain a more useful induction hypothesis by changing the
    statement to insert new bindings into the middle of the
    environment, instead of at the head.  However, the proof still
    gets stuck, as can be seen by examining each of the cases in
    the proof below.

    Note: To view subgoal n in a proof, use the command "[Show n]".
    To work on subgoal n instead of the first one, use the command
    "[Focus n]". *)

Lemma typing_weakening_strengthened_0 : forall E F G e T,
  typing (G ++ E) e T ->
  ok (G ++ F ++ E) ->
  typing (G ++ F ++ E) e T.
Proof.
  intros E F G e T H J.
  induction H.
  (* ... the E0 looks strange in the [typing_var] case ... *)
  (* ... the [typing_abs] case still does not have a strong enough IH ... *)
Admitted.

(** The hypotheses in the [typing_var] case include an environment
    [E0] that that has no relation to what we need to prove.  The
    missing fact we need is that [E0 = (G ++ E)].

    The problem here arises from the fact that Coq's [induction]
    tactic let's us only prove something about all typing derivations.
    While it's clear to us that weakening applies to all typing
    derivations, it's not clear to Coq, because the environment is
    written using concatenation.  The [induction] tactic expects that
    all arguments to a judgement are variables.  So we see [E0] in the
    proof instead of [(G ++ E)].

    The solution is to restate the lemma.  For example, we can prove

<<
  forall E F E' e T, typing E' e T ->
  forall G, E' = G ++ E -> ok (G ++ F ++ E) -> typing (G ++ F ++ E) e T.
>>

    The equality gets around the problem with Coq's [induction]
    tactic.  The placement of the [(forall G)] quantifier gives us a
    sufficiently strong induction hypothesis in the [typing_abs] case.

    However, we prefer not to state the lemma in the way shown above,
    since it is not as readable as the original statement.  Instead,
    we use a tactic to introduce the equality within the proof itself.
    The tactic [(remember t as t')] replaces an object [t] with the
    identifier [t'] everywhere in the goal and introduces an equality
    [t' = t] into the context.  It is often combined with [generalize
    dependent], as illustrated below. *)

(** *** Exercise

    See how we use [remember as] in the proof below for weakening.
    Then, complete the proof. *)

Lemma typing_weakening_strengthened :  forall E F G e T,
  typing (G ++ E) e T ->
  ok (G ++ F ++ E) ->
  typing (G ++ F ++ E) e T.
Proof.
  intros E F G e T H.
  remember (G ++ E) as E'.
  generalize dependent G.
  induction H; intros G Eq Ok; subst.
  Case "typing_var".
    apply typing_var.
      apply Ok.
      apply binds_weaken. apply H0. apply Ok.
  Case "typing_abs".
    pick fresh x and apply typing_abs.
    rewrite <- cons_concat_assoc.
    apply H0.
      auto.
      rewrite cons_concat_assoc. reflexivity.
      rewrite cons_concat_assoc. apply ok_cons.
        apply Ok.
        auto.
  Case "typing_app".
    eapply typing_app.
      eapply IHtyping1. reflexivity. apply Ok.
      eapply IHtyping2. reflexivity. apply Ok.
Qed.

(** *** Example

    We can now prove our original statement of weakening.  The only
    interesting step is the use of the lemma [nil_concat], which is
    defined in [Environment.v]. *)

Lemma typing_weakening : forall E F e T,
    typing E e T ->
    ok (F ++ E) ->
    typing (F ++ E) e T.
Proof.
  intros E F e T H J.
  rewrite <- (nil_concat _ (F ++ E)).
  apply typing_weakening_strengthened; auto.
Qed.

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

(** Having proved weakening, we can now prove the usual substitution
    lemma, which we state both in the form we need and in the
    strengthened form needed to make the proof go through.

<<
  typing_subst : forall E e u S T z,
    typing ((z, S) :: E) e T ->
    typing E u S ->
    typing E ([z ~> u] e) T

  typing_subst_strengthened : forall E F e u S T z,
    typing (F ++ (z, S) :: E) e T ->
    typing E u S ->
    typing (F ++ E) ([z ~> u] e) T
>>

    The proof of the strengthened statement proceeds by induction on
    the given typing derivation for [e].  The most involved case is
    the one for variables; the others follow from the induction
    hypotheses. *)

(** *** Exercise

    Below, we state what needs to be proved in the [typing_var] case
    of the substitution lemma.  Fill in the proof.

    Proof sketch: The proof proceeds by a case analysis on [(x == z)],
    i.e., whether the two variables are the same or not.

      - If [(x = z)], then we need to show [(typing (F ++ E) u T)].
        This follows from the given typing derivation for [u] by
        weakening and the fact that [T] must equal [S].

      - If [(x <> z)], then we need to show [(typing (F ++ E) x T)].
        This follows by the typing rule for variables. *)

Lemma typing_subst_var_case : forall E F u S T z x,
  binds x T (F ++ (z, S) :: E) ->
  ok (F ++ (z, S) :: E) ->
  typing E u S ->
  typing (F ++ E) ([z ~> u] x) T.
Proof.
  intros E F u S T z x H J K.
  simpl.
  destruct (x == z).
  Case "x = z".
    subst.
    assert (T = S).
      eapply binds_mid_eq_cons. apply H. apply J.
    subst.
    apply typing_weakening.
      apply K.
      eapply ok_remove_mid_cons. apply J.
  Case "x <> z".
    apply typing_var.
      eapply ok_remove_mid_cons. apply J.
      eapply binds_remove_mid_cons. apply H. apply n.
Qed.

(** *** Note

    The other two cases of the proof of the substitution lemma are
    relatively straightforward.  However, the case for [typing_abs]
    needs the fact that the typing relation holds only for
    locally-closed expressions. *)

Lemma typing_regular_lc : forall E e T,
  typing E e T -> lc e.
Proof.
  intros E e T H. induction H; eauto.
Qed.

(** *** Exercise

    Complete the proof of the substitution lemma. The proof proceeds
    by induction on the typing derivation for [e].  The initial steps
    should use [remember as] and [generalize dependent] in a manner
    similar to the proof of weakening. *)

Lemma typing_subst_strengthened : forall E F e u S T z,
  typing (F ++ (z, S) :: E) e T ->
  typing E u S ->
  typing (F ++ E) ([z ~> u] e) T.
Proof.
  intros E F e u S T z He Hu.
  remember (F ++ (z, S) :: E) as E'.
  generalize dependent F.
  induction He.
  Case "typing_var".
    intros F Eq.
    subst.
    eapply typing_subst_var_case. apply H0. apply H. apply Hu.
  Case "typing_abs".
    intros F Eq.
    subst.
    simpl.
    pick fresh y and apply typing_abs.
    rewrite subst_open_var.
    rewrite <- cons_concat_assoc.
    apply H0.
      auto.
      rewrite cons_concat_assoc. auto.
    (* The following subgoals are from [rewrite subst_open_var]. *)
    auto.
    eapply typing_regular_lc. apply Hu.
  Case "typing_app".
    intros F Eq. subst. simpl. eapply typing_app.
      apply IHHe1. reflexivity.
      apply IHHe2. reflexivity.
Qed.

(** *** Exercise

    Complete the proof of the substitution lemma stated in the form we
    need it.  The proof is similar to that of [typing_weakening].  In
    particular, recall the lemma [nil_concat]. *)

Lemma typing_subst : forall E e u S T z,
  typing ((z, S) :: E) e T ->
  typing E u S ->
  typing E ([z ~> u] e) T.
Proof.
  intros E e u S T z H J.
  rewrite <- (nil_concat _ E).
  eapply typing_subst_strengthened.
    rewrite nil_concat. apply H.
    apply J.
Qed.

(*************************************************************************)
(** * Values and Evaluation *)
(*************************************************************************)

(** In order to state the preservation lemma, we first need to define
    values and the small-step evaluation relation.  These inductive
    relations are straightforward to define.

    Note the hypotheses which ensure that the relations hold only for
    locally closed terms.  Below, we prove that this is actually the
    case, since it is not completely obvious from the definitions
    alone. *)

Inductive value : exp -> Prop :=
  | value_abs : forall e,
      lc (abs e) ->
      value (abs e).

Inductive eval : exp -> exp -> Prop :=
  | eval_beta : forall e1 e2,
      lc (abs e1) ->
      value e2 ->
      eval (app (abs e1) e2) (open e1 e2)
  | eval_app_1 : forall e1 e1' e2,
      lc e2 ->
      eval e1 e1' ->
      eval (app e1 e2) (app e1' e2)
  | eval_app_2 : forall e1 e2 e2',
      value e1 ->
      eval e2 e2' ->
      eval (app e1 e2) (app e1 e2').

(** We add the constructors for these two relations as hints to be used
    by Coq's [auto] and [eauto] tactics. *)

Hint Constructors value eval.

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

(** *** Note

    In order to prove preservation, we need one more lemma, which
    states that when we open a term, we can instead open the term with
    a fresh variable and then substitute for that variable.

    Technically, the [(lc u)] hypothesis is not needed to prove the
    conclusion.  However, it makes the proof simpler. *)

Lemma subst_intro : forall (x : atom) u e,
  x `notin` (fv e) ->
  lc u ->
  open e u = [x ~> u](open e x).
Proof.
  intros x u e H J.
  unfold open.
  rewrite subst_open_rec; auto.
  simpl.
  destruct (x == x).
  Case "x = x".
    rewrite subst_fresh; auto.
  Case "x <> x".
    destruct n; auto.
Qed.

(** *** Exercise

    Complete the proof of preservation.  In this proof, we proceed by
    induction on the given typing derivation.  The induction
    hypothesis has already been appropriately generalized by the given
    proof fragment.

    Proof sketch: By induction on the typing derivation for [e].

      - [typing_var] case: Variables don't step.

      - [typing_abs] case: Abstractions don't step.

      - [typing_app] case: By case analysis on how [e] steps. The
        [eval_beta] case is interesting, since it follows by the
        substitution lemma.  The others follow directly from the
        induction hypotheses. *)

Lemma preservation : forall E e e' T,
  typing E e T ->
  eval e e' ->
  typing E e' T.
Proof.
  intros E e e' T H.
  generalize dependent e'.
  induction H; intros e' J.
  Case "typing_var".
    inversion J.
  Case "typing_abs".
    inversion J.
  Case "typing_app".
    inversion J; subst; eauto.
    SCase "eval_beta".
      inversion H; subst.
      pick fresh y.
      rewrite (subst_intro y); auto.
      eapply typing_subst; auto.
      eapply typing_regular_lc; eauto.
Qed.

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

(** *** Exercise

    Complete the proof of the progress lemma.  The induction
    hypothesis has already been appropriately generalized by the given
    proof fragment.

    Proof sketch: By induction on the typing derivation for [e].

      - [typing_var] case: Can't happen; the empty environment doesn't
        bind anything.

      - [typing_abs] case: Abstractions are values.

      - [typing_app] case: Applications reduce.  The result follows
        from an exhaustive case analysis on whether the two components
        of the application step or are values and the fact that a
        value must be an abstraction. *)

Lemma progress : forall e T,
  typing nil e T ->
  value e \/ exists e', eval e e'.
Proof.
  intros e T H.

  (* It will be useful to have a "non-destructed" form of the given
     typing derivation, since [induction] takes apart the derivation
     it is called on. *)
  assert (typing nil e T); auto.

  (* [remember nil as E] fails here because [nil] takes an implicit
     argument that Coq is unable to infer.  By prefixing [nil] with
     [@], we can supply the argument to nil explicitly. *)
  remember (@nil (atom * typ)) as E.

  induction H; subst.

  Case "typing_var".
    inversion H1.
  Case "typing_abs".
    left.
    apply value_abs.
    eapply typing_regular_lc; eauto.
  Case "typing_app".
    right.
    destruct IHtyping1 as [V1 | [e1' Eval1]]; auto.
      destruct IHtyping2 as [V2 | [e2' Eval2]]; auto.
        inversion V1; subst. exists (open e e2); auto.
        exists (app e1 e2'); auto.
      exists (app e1' e2).
        apply eval_app_1.
          eapply typing_regular_lc; eauto.
          assumption.
Qed.

(*************************************************************************)
(** * Additional properties *)
(*************************************************************************)

(** While none of the lemmas below are needed to prove preservation or
    progress, they verify that our relations do indeed hold only for
    locally closed expressions.  This serves as a check that we have
    correctly defined the relations. *)

(** *** Example

    The lemma directly below, [open_abs], is needed to show that the
    evaluation relation holds only for locally closed terms.  The
    proof is straightforward, but we can use it to illustrate another
    feature of Coq's tactic language.

    If we start a proof with "[Proof with tac]" instead of simply
    "[Proof]", every time we end a step with "[...]", Coq will
    automatically apply [tac] to all the subgoals generated by that
    step.  This makes proof scripts somewhat more concise without
    hiding the details of the proof script in some far away
    location. *)

Lemma open_abs : forall e u,
  lc (abs e) ->
  lc u ->
  lc (open e u).
Proof with auto using subst_lc.
  intros e u H J.
  inversion H; subst.
  pick fresh y.
  rewrite (subst_intro y)...
  (* The previous line is equivalent to:
     [rewrite (subst_intro y); auto using subst_lc] *)
Qed.

(** *** Note

    The three lemmas below are straightforward to prove.  They do not
    illustrate any new concepts or tactics. *)

Lemma value_regular : forall e,
  value e -> lc e.
Proof.
  intros e H. induction H; auto.
Qed.

Lemma eval_regular : forall e1 e2,
  eval e1 e2 -> lc e1 /\ lc e2.
Proof.
  intros e1 e2 H. induction H; intuition; auto using value_regular, open_abs.
Qed.

Lemma typing_regular_ok : forall E e T,
  typing E e T -> ok E.
Proof with auto.
  induction 1...
  Case "typing_abs".
    pick fresh x.
    assert (ok ((x, T1) :: E))...
    inversion H1...
Qed.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U") ***
*** End: ***
 *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Require Import BinInt DoubleBase.

Open Scope Z_scope.

(** * NSig *)

(** Interface of a rich structure about natural numbers.
    Specifications are written via translation to Z.
*)

Module Type NType.

 Parameter t : univ_of_cycles.

 Parameter to_Z : t -> Z.
 Local Notation "[ x ]" := (to_Z x).
 Parameter spec_pos: forall x, 0 <= [x].

 Parameter of_N : N -> t.
 Parameter spec_of_N: forall x, to_Z (of_N x) = Z.of_N x.
 Definition to_N n := Z.to_N (to_Z n).

 Definition eq n m := [n] = [m].
 Definition lt n m := [n] < [m].
 Definition le n m := [n] <= [m].

 Parameter compare : t -> t -> comparison.
 Parameter eqb : t -> t -> bool.
 Parameter ltb : t -> t -> bool.
 Parameter leb : t -> t -> bool.
 Parameter max : t -> t -> t.
 Parameter min : t -> t -> t.
 Parameter zero : t.
 Parameter one : t.
 Parameter two : t.
 Parameter succ : t -> t.
 Parameter pred : t -> t.
 Parameter add  : t -> t -> t.
 Parameter sub : t -> t -> t.
 Parameter mul : t -> t -> t.
 Parameter square : t -> t.
 Parameter pow_pos : t -> positive -> t.
 Parameter pow_N : t -> N -> t.
 Parameter pow : t -> t -> t.
 Parameter sqrt : t -> t.
 Parameter log2 : t -> t.
 Parameter div_eucl : t -> t -> t * t.
 Parameter div : t -> t -> t.
 Parameter modulo : t -> t -> t.
 Parameter gcd : t -> t -> t.
 Parameter even : t -> bool.
 Parameter odd : t -> bool.
 Parameter testbit : t -> t -> bool.
 Parameter shiftr : t -> t -> t.
 Parameter shiftl : t -> t -> t.
 Parameter land : t -> t -> t.
 Parameter lor : t -> t -> t.
 Parameter ldiff : t -> t -> t.
 Parameter lxor : t -> t -> t.
 Parameter div2 : t -> t.

 Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]).
 Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]).
 Parameter spec_ltb : forall x y, ltb x y = ([x] <? [y]).
 Parameter spec_leb : forall x y, leb x y = ([x] <=? [y]).
 Parameter spec_max : forall x y, [max x y] = Z.max [x] [y].
 Parameter spec_min : forall x y, [min x y] = Z.min [x] [y].
 Parameter spec_0: [zero] = 0.
 Parameter spec_1: [one] = 1.
 Parameter spec_2: [two] = 2.
 Parameter spec_succ: forall n, [succ n] = [n] + 1.
 Parameter spec_add: forall x y, [add x y] = [x] + [y].
 Parameter spec_pred: forall x, [pred x] = Z.max 0 ([x] - 1).
 Parameter spec_sub: forall x y, [sub x y] = Z.max 0 ([x] - [y]).
 Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
 Parameter spec_square: forall x, [square x] = [x] * [x].
 Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n.
 Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n.
 Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n].
 Parameter spec_sqrt: forall x, [sqrt x] = Z.sqrt [x].
 Parameter spec_log2: forall x, [log2 x] = Z.log2 [x].
 Parameter spec_div_eucl: forall x y,
  let (q,r) := div_eucl x y in ([q], [r]) = Z.div_eucl [x] [y].
 Parameter spec_div: forall x y, [div x y] = [x] / [y].
 Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y].
 Parameter spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b].
 Parameter spec_even: forall x, even x = Z.even [x].
 Parameter spec_odd: forall x, odd x = Z.odd [x].
 Parameter spec_testbit: forall x p, testbit x p = Z.testbit [x] [p].
 Parameter spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p].
 Parameter spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p].
 Parameter spec_land: forall x y, [land x y] = Z.land [x] [y].
 Parameter spec_lor: forall x y, [lor x y] = Z.lor [x] [y].
 Parameter spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y].
 Parameter spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y].
 Parameter spec_div2: forall x, [div2 x] = Z.div2 [x].

End NType.

Module Type NType_Notation (Import N:NType).
 Notation "[ x ]" := (to_Z x).
 Infix "==" := eq (at level 70).
 Notation "0" := zero.
 Notation "1" := one.
 Notation "2" := two.
 Infix "+" := add.
 Infix "-" := sub.
 Infix "*" := mul.
 Infix "^" := pow.
 Infix "<=" := le.
 Infix "<" := lt.
End NType_Notation.

Module Type NType' := NType <+ NType_Notation.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e171m19_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e191m19_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e150m3_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import riscv.Utility.
Require Import riscv.util.Monads.
Require Import riscv.Memory.
Require Import riscv.util.Tactics.
Require riscv.ListMemoryZAddr.

Local Open Scope Z_scope.

Definition align(alignment: Z)(n: Z): Z := alignment * (n / alignment).

Lemma align_lt: forall a n,
    0 < a ->
    align a n <= n.
Proof.
  intros. unfold align.
  apply Z.mul_div_le.
  assumption.
Qed.

Lemma align8_lt: forall n, align 8 n <= n.
Proof.
  intros. apply align_lt. omega.
Qed.

Lemma align_eq: forall a n,
    0 < a  ->
    n mod a = 0 ->
    align a n = n.
Proof.
  intros. unfold align. symmetry. apply Z.div_exact; omega.
Qed.

Lemma align8_eq: forall n,
    n mod 8 = 0 ->
    align 8 n = n.
Proof.
  intros. apply align_eq; omega.
Qed.

Definition mem := ListMemoryZAddr.mem.

Section Memory.

  Context {mword: Set}.
  Context {MW: MachineWidth mword}.

  Definition mem_size(m: mem): Z :=
    align 8 (Z.min (2 ^ XLEN) (ListMemoryZAddr.mem_size m)).

  Definition read_byte(m: mem)(a: mword): word 8 :=
    ListMemoryZAddr.read_byte m (regToZ_unsigned a).

  Definition read_half(m: mem)(a: mword): word 16 :=
    ListMemoryZAddr.read_half m (regToZ_unsigned a).

  Definition read_word(m: mem)(a: mword): word 32 :=
    ListMemoryZAddr.read_word m (regToZ_unsigned a).

  Definition read_double(m: mem)(a: mword): word 64 :=
    ListMemoryZAddr.read_double m (regToZ_unsigned a).

  Definition write_byte(m: mem)(a: mword)(v: word 8): mem :=
    ListMemoryZAddr.write_byte m (regToZ_unsigned a) v.

  Definition write_half(m: mem)(a: mword)(v: word 16): mem :=
    ListMemoryZAddr.write_half m (regToZ_unsigned a) v.

  Definition write_word(m: mem)(a: mword)(v: word 32): mem :=
    ListMemoryZAddr.write_word m (regToZ_unsigned a) v.

  Definition write_double(m: mem)(a: mword)(v: word 64): mem :=
    ListMemoryZAddr.write_double m (regToZ_unsigned a) v.

  Definition const_mem(default: word 8)(size: Z): mem :=
    ListMemoryZAddr.const_mem default size.

  Definition zero_mem: Z -> mem := const_mem (ZToWord 8 0).

  (* Since mem_size is a bit fancy, we better prove that it's possible to create memory of any
     desired size (as long as it's a multiple of 8 and not bigger than the biggest address) *)
  Lemma const_mem_mem_size: forall size default,
      size mod 8 = 0 ->
      0 <= size <= 2 ^ XLEN ->
      mem_size (const_mem default size) = size.
  Proof.
    intros. unfold mem_size, const_mem. rewrite ListMemoryZAddr.const_mem_mem_size by omega.
    replace (Z.min (2 ^ XLEN) size) with size by momega.
    apply align8_eq. assumption.
  Qed.

End Memory.

Ltac pose_bounds :=
  repeat match goal with
         | _: context [align 8 ?x] |- _=> unique pose proof (align8_lt x)
         | |- context [align 8 ?x]     => unique pose proof (align8_lt x)
         | w: _ |- _ => unique pose proof (regToZ_unsigned_bounds w)
         end.

Local Ltac wrap L :=
  intros;
  repeat match goal with
         | H: valid_addr _ _ _ |- _ => destruct H
         end;
  unfold mem_size, ListMemoryZAddr.mem_size in *;
  first [do 2 f_equal; apply L | apply L];
  unfold ListMemoryZAddr.mem_size;
  pose_bounds;
  try apply ne_regToZ_unsigned;
  (congruence || momega || idtac).

Instance mem_is_Memory(mword: Set){MW: MachineWidth mword}: Memory mem mword :=
{|
  memSize     := mem_size;
  loadByte    := read_byte;
  loadHalf    := read_half;
  loadWord    := read_word;
  loadDouble  := read_double;
  storeByte   := write_byte;
  storeHalf   := write_half;
  storeWord   := write_word;
  storeDouble := write_double;
|}.
- intros. unfold mem_size. pose_bounds. momega.
- intros. unfold mem_size, align. rewrite Z.mul_comm. apply Z.mod_mul. congruence.
- wrap ListMemoryZAddr.write_read_byte_eq.
- wrap ListMemoryZAddr.write_read_byte_ne.
- wrap ListMemoryZAddr.write_byte_preserves_mem_size.
- wrap ListMemoryZAddr.write_read_half_eq.
- wrap ListMemoryZAddr.write_read_half_ne.
- wrap ListMemoryZAddr.write_half_preserves_mem_size.
- wrap ListMemoryZAddr.write_read_word_eq.
- wrap ListMemoryZAddr.write_read_word_ne.
- wrap ListMemoryZAddr.write_word_preserves_mem_size.
- wrap ListMemoryZAddr.write_read_double_eq.
- wrap ListMemoryZAddr.write_read_double_ne.
- wrap ListMemoryZAddr.write_double_preserves_mem_size.
- intros. unfold valid_addr, mem_size, read_byte in *. pose_bounds.
  rewrite regToZ_unsigned_add_r by momega. reflexivity.
- intros. unfold valid_addr, mem_size, read_half in *. pose_bounds.
  rewrite regToZ_unsigned_add_r by momega. reflexivity.
- intros. unfold valid_addr, mem_size, read_word in *. pose_bounds.
  rewrite regToZ_unsigned_add_r by momega. reflexivity.
Defined.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e137m13_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import HoTT hit.unique_choice FunextAxiom.
Require Export structures basics.
Require Import quotient.
Require Import syntax.

Open Scope path_scope.

Import BinOpTree.
Import Distributive.
Import Ring_pr.
Import OrderedMagma_pr.
Import Field_pr.

Module Fraction.
Import minus1Trunc.

Section VarSec.

Context {G : Type}.
Variable L : Prering G.
Context {Hg : IsRing L}.

Hypothesis Hdec : DecidablePaths G.
Let Hset : IsHSet G := hset_decidable Hdec.
Existing Instance Hset.
Context {Hint : IsStrictIntegral L}.
Hypothesis Hneq : ZeroV != OneV.

(*
a fraction is a/b with a,b in G

fraction equivalence:
if b,d#0 and ad=bc then a/b == c/d
forall a d, a/0 = 0/d and 0/a = d/0
*)

Let pairT := G*G.

Definition fractionT := sigT (fun p : pairT => neq ZeroV (snd p)).

Instance fractionT_set : IsHSet fractionT.
Proof.
apply @trunc_sigma. apply trunc_prod.
apply _.
Defined.

Definition fracV : fractionT -> pairT := fun x => x.1.
Coercion fracV : fractionT >-> pairT.

Definition fracEquiv : Rel fractionT :=
 fun x y => (fst x.1) ° (snd y.1) = (fst y.1) ° (snd x.1).

Lemma fractionT_eq : forall x y : fractionT, x.1 = y.1 -> x=y.
Proof.
intros ? ? p. apply path_sigma with p.
apply neq_is_prop.
Defined.

Instance fracEquiv_is_prop : forall x y, IsHProp (fracEquiv x y).
Proof.
intros. apply _.
Defined.

Lemma fracEquiv_dec : forall x y, fracEquiv x y + ~ fracEquiv x y.
Proof.
intros.
unfold fracEquiv. apply Hdec.
Defined.

Instance fracEquiv_refl : Reflexive fracEquiv.
Proof.
intro;reflexivity.
Defined.

Instance fracEquiv_symm : Symmetric fracEquiv.
Proof.
intros x y;apply inverse.
Defined.

Instance fracEquiv_trans : Transitive fracEquiv.
Proof.
intros [x Hx] [y Hy] [z Hz] H H0.

assert (Hcan : Rcancel (°) (snd y)).
apply intdom_partial_cancels_right. intro;apply Hy;auto;apply inverse;assumption.
apply Hcan. clear Hcan. simpl.
set (xa := fst x);set (xb := snd x);set (ya := fst y);set (yb:= snd y).
set (za := fst z);set (zb:=snd z).
path_via ((xa°yb)°zb). ssrapply (@ast_use _ (°) _); reflexivity.
path_via ((ya°xb)°zb). apply (ap (fun g => g ° _)). assumption.
path_via ((za ° yb)°xb). path_via ((ya°zb)°xb).
ssrapply (@ast_use _ (°) _); reflexivity.
apply (ap (fun g => g ° _)). assumption.
ssrapply (@ast_use _ (°) _); reflexivity.
Defined.

Definition fracQuot : Type := quotient fracEquiv.

Instance frac_set : IsHSet fracQuot := quotient_is_set.

Definition fracIn : fractionT -> fracQuot := class_of _.

Definition frac_rect := @quotient_rect _ fracEquiv.

Definition fracMult0 (x y : G*G) : G*G := (fst x ° fst y, snd x ° snd y).

Lemma fracMult_NZ : forall x y : fractionT, neq ZeroV (snd (fracMult0 x.1 y.1)).
Proof.
intros [x Hx] [y Hy] H.
simpl in H. apply Hint in H. revert H.
apply minus1Trunc_rect_nondep;[|intros []].
intros [H|H];auto.
Defined.

Instance fracMultU : Mult fractionT
 := fun x y => (fracMult0 x.1 y.1; fracMult_NZ x y).

Instance fracMultU_comm : Commutative fracMultU.
Proof.
red;unfold gop;simpl.
intros. apply fractionT_eq.
simpl. apply path_prod;apply (commutative (°) _).
Defined.

Instance fracMultU_assoc : Associative fracMultU.
Proof.
red;unfold gop;simpl.
intros x y z. apply fractionT_eq.
apply path_prod;apply (associative (°) _).
Defined.

Instance fracMultU_sg : IsSemigroup fracMultU.
Proof.
split;apply _.
Defined.

Definition fracLR_U : OpRel _ := BuildLR_Class _ fracMultU fracEquiv.

Instance fracMultU_passes : IsCompat fracLR_U.
Proof.
apply invariant_compat.
apply _.
assert (H:IsLInvariant fracLR_U);[|split;try assumption].
red. red. unfold rrel;unfold gop;simpl.
unfold fracEquiv,fracMultU.
intros [z Hz] [x Hx] [y Hy]. simpl.

intros H.
set (xa := fst x);set (xb := snd x);set (ya := fst y);set (yb:= snd y).
set (za := fst z);set (zb:=snd z).
path_via ((za°zb) ° (xa ° yb)).
ssrapply (@ast2_full_semiring G L Hg);reflexivity.
path_via ((za°zb) ° (ya ° xb)). apply ap;assumption.
ssrapply (@ast2_full_semiring _ _ Hg);reflexivity.

red;red;intros. change gop with mult.
pattern (x ° z);apply transport with (z ° x). apply (commutative _).
pattern (y ° z);apply transport with (z ° y). apply (commutative _).
apply H;assumption.
Defined.

Instance fracMult : Mult fracQuot.
Proof.
hnf. apply (quotient_rec2 (fun x y => class_of _ (fracMultU x y))).
intros. apply related_classes_eq.
apply fracMultU_passes;assumption.
Defined.

Instance fracMult_comm : Commutative fracMult.
Proof.
red. apply (quotient_ind (fun x => forall y, _)). apply _.
intros x. apply quotient_ind. apply _.
intros y.
unfold gop;simpl. apply ap. apply fracMultU_comm.
Defined.

Instance fracMult_assoc : Associative fracMult.
Proof.
red. apply (quotient_ind (fun x => forall y z, _) _).
intros x. apply (quotient_ind (fun y => forall z, _) _).
intros y. apply quotient_ind. apply _.
intros z.
unfold gop;simpl. apply ap. apply fracMultU_assoc.
Defined.

Instance fracMult_sg : IsSemigroup fracMult := BuildIsSemigroup _ _ _.

Definition fracOne : fracQuot := fracIn ((OneV, OneV);Hneq).

Instance fracOne_left : Left_id (°) fracOne.
Proof.
red. apply quotient_ind.
apply _.
intros [[xa xb] Hx].
unfold gop.
apply (ap fracIn).
apply fractionT_eq. apply path_prod;simpl;apply One.
Defined.

Instance fracOne_id : IsId (°) fracOne.
Proof.
apply left_id_id. apply _.
Defined.

Canonical Structure fracOne_idT : Identity (°)
 := BuildIdentity _ fracOne _.

Instance fracMult_ismonoid : IsMonoid (°) := BuildIsMonoid _ _
 fracOne_idT.

Definition fracAdd0 : Plus (G*G) := fun x y =>
(fst x ° snd y + fst y ° snd x, snd x ° snd y).

Definition fracAdd_NZ : forall x y : fractionT,
neq ZeroV (snd (fracAdd0 x.1 y.1)) := fracMult_NZ.

Instance fracAddU : Plus fractionT := fun x y =>
(fracAdd0 x.1 y.1 ; fracAdd_NZ x y).

Instance fracAddU_comm : Commutative fracAddU.
Proof.
red. intros [x Hx] [y Hy].
unfold gop;simpl in *. apply fractionT_eq.
apply path_prod;simpl.
apply (commutative). apply Hg.
apply (commutative). apply Hg.
Defined.

Definition fracAddEquivU := BuildLR_Class _ fracAddU fracEquiv.

Instance fracAddU_passes : IsCompat fracAddEquivU.
Proof.
apply invariant_compat.
apply _.
assert (H:IsLInvariant fracAddEquivU);[|split;try assumption].
red;red. unfold rrel;unfold gop;simpl.
unfold fracEquiv;unfold fracAddU. simpl.
intros [[za zb] Hz] [[xa xb] Hx] [[ya yb] Hy] H;simpl in *.
ssrapply (@ast2_full_semiring G L _). simpl. unfold gop.
apply ap.
path_via ((zb°zb)°(xa°yb)).
ssrapply (@ast_use G (°) _);reflexivity.
path_via ((zb°zb)°(ya°xb)). apply ap;assumption.
ssrapply (@ast_use G (°) _);reflexivity.

red;red;intros. change gop with plus.
pattern (x + z);apply transport with (z + x). apply fracAddU_comm.
pattern (y + z);apply transport with (z + y). apply fracAddU_comm.
apply H;assumption.
Defined.

Instance fracAdd : Plus fracQuot.
Proof.
hnf. apply quotient_rec2 with (fun x y => class_of _ (fracAddU x y)).
intros. apply related_classes_eq. apply fracAddU_passes;assumption.
Defined.

Definition fracZero : fracQuot := fracIn ((ZeroV, OneV);Hneq).

Instance fracZero_left : Left_id (+) fracZero.
Proof.
red. apply quotient_ind. apply _.
intros [[xa xb] Hx]. unfold gop;simpl. apply (ap fracIn).
apply fractionT_eq. simpl.
apply path_prod';simpl.
path_via (ZeroV + (xa ° OneV)).
apply ap10. apply ap.
apply rmult_0_l.
path_via (xa ° OneV). apply Zero.
apply One. apply One.
Defined.

Instance fracZero_right : Right_id (+) fracZero.
Proof.
red. apply quotient_ind. apply _.
intros [[xa xb] Hx]. unfold gop;simpl. apply (ap fracIn).
apply fractionT_eq. simpl.
apply path_prod';simpl.
path_via ((xa ° OneV) + ZeroV).
apply ap.
apply rmult_0_l.
path_via (xa ° OneV). apply Zero.
apply One. apply One.
Defined.

Instance fracZero_id : IsId (+) fracZero := BuildIsId _ _ _ _.

Canonical Structure fracZero_idT : Identity (+)
 := BuildIdentity _ fracZero _.

Instance fracPrering : Prering fracQuot := BuildLL_Class _ fracAdd fracMult.

Instance fracAdd_assoc : Associative (+).
Proof.
red.
apply (quotient_ind (fun x => forall y z, _) _).
intros x. apply (quotient_ind (fun y => forall z, _) _).
intros y. apply quotient_ind. apply _.
intros z.

apply related_classes_eq.
destruct x as [[xa xb] Hx];destruct y as [[ya yb] Hy];destruct z as [[za zb] Hz].
simpl in Hx,Hy,Hz.
red; simpl.
ssrapply (@ast2_full_semiring G L _);reflexivity.
Defined.

Instance fracAdd_comm : Commutative (+).
Proof.
red. apply (quotient_ind (fun x => forall y, _) _).
intros x. apply quotient_ind. apply _.
intros y.

apply (ap (class_of _)). apply fracAddU_comm.
Defined.

Instance fracAdd_sg : IsSemigroup (+) := BuildIsSemigroup _ _ _.

Instance fracAdd_ismonoid : IsMonoid (+) := BuildIsMonoid _ _
 fracZero_idT.

(* what for?
Lemma frac_neq0 : ~ @gidV (fracMult_monoid) = @gidV (fracAdd_monoid).
Proof.
intro H.
unfold gidV in H;simpl in H.
apply classes_eq_related in H.
red in H. simpl in H.
apply Hneq. path_via (@OneV G ° OneV).
apply inverse. apply One.
path_via (@ZeroV G ° OneV).
apply rmult_0_l.
Defined.
*)

Definition fracOppU : fractionT -> fractionT := fun x =>
((roppV (fst x.1), snd x.1) ; x.2).

Definition fracOpp : fracQuot -> fracQuot.
Proof.
apply quotient_rec with (fun x => class_of _ (fracOppU x)).
intros x y H.
red in H.
apply related_classes_eq. red. simpl.
path_via (roppV ((fst x.1) ° (snd y.1))). symmetry. apply ropp_rmult_left.
path_via (roppV (fst y.1 ° snd x.1)). apply ap;assumption.
apply ropp_rmult_left.
Defined.

Instance fracOpp_correct : forall x, IsInverse (+) x (fracOpp x).
Proof.
apply quotient_ind. apply _.
intros [[xa xb] Hx]. simpl in Hx.
apply linverse_inverse. red. unfold gop;simpl.
apply transport with fracZero. symmetry.
apply related_classes_eq.
red. simpl.
path_via ZeroV.
path_via (ZeroV ° OneV).
apply (@ap _ _ (fun g => g ° OneV)).
path_via ((xa + roppV xa) ° xb).
symmetry;apply semiring_distributes;apply _.
path_via (ZeroV ° xb). apply (ap (fun g => g ° _)).
eapply (id_unique (+)). apply ropp. apply Zero.
apply rmult_0_l. apply rmult_0_l.
apply inverse;apply rmult_0_l.
apply _.
Defined.

Canonical Structure fracOppT : forall x : fracQuot, Inverse (+) x
 := fun x => BuildInverse _ _ (fracOpp x) _.

Instance fracAdd_isgroup : IsGroup (+) := easyIsGroup _ fracOppT.

Instance frac_distrib : Distributes fracPrering.
Proof.
assert (H:Ldistributes fracPrering);[|split;try assumption].
red. apply (quotient_ind (fun a => forall b c, _) _).
intros x. apply (quotient_ind (fun b => forall c, _) _).
intros y. apply quotient_ind. apply _.
intros z.

destruct x as [[xa xb] Hx];
destruct y as [[ya yb] Hy];
destruct z as [[za zb] Hz].
simpl in Hx,Hy,Hz.
apply related_classes_eq. red;simpl.
ssrapply (@ast2_full_semiring G L _); reflexivity.

red;intros. path_via (a ° (b+c)). apply fracMult_comm.
eapply concat. apply H.
apply ap11;[apply ap|];apply fracMult_comm.
Defined.

Instance frac_isring : IsRing fracPrering := easyIsRing _ _ _ _.

Lemma frac_dec : DecidablePaths fracQuot.
Proof.
red.
assert (Hprop : forall x y : fracQuot, IsHProp ((x=y) \/ (x != y))).
intros;apply hprop_allpath. intros [x0|x0] [y0|y0].
apply ap. apply quotient_is_set.
destruct y0;auto. destruct x0;auto.
apply ap;apply neq_is_prop.

apply (quotient_ind (fun x => forall y, _) _).
intros x. apply quotient_ind. apply _.
intros y. clear Hprop.

destruct x as [[xa xb] Hx];destruct y as [[ya yb] Hy].
simpl in Hx,Hy.
destruct (Hdec (xa°yb) (ya°xb)) as [?|n].
left. apply related_classes_eq. red;simpl. assumption.
right. intro H.
apply classes_eq_related in H.
apply n;apply H.
Defined.

Definition fracInvU : fractionT -> fracQuot.
Proof.
intros x.
destruct (Hdec ZeroV (fst x.1)).
- exact fracZero.
- apply fracIn. exists (snd x.1,fst x.1). assumption.
Defined.

Definition fracInv : fracQuot -> fracQuot.
Proof.
apply quotient_rec with fracInvU.
intros [[xa xb] Hx] [[ya yb] Hy] Heq.
simpl in *. red in Heq. simpl in Heq. unfold fracInvU. simpl.
destruct (Hdec ZeroV xa);destruct (Hdec ZeroV ya).
- reflexivity.
- apply Empty_rect.
  assert (ZeroV = ya ° xb). path_via (xa ° yb). destruct p.
  apply inverse;apply rmult_0_l.
  apply Hint in X. revert X.
  apply minus1Trunc_rect_nondep;[|intros[]].
  intros [H | H]; auto.
- apply Empty_rect.
  assert (ZeroV = xa ° yb). path_via (ya ° xb). destruct p.
  apply inverse;apply rmult_0_l.
  apply Hint in X. revert X.
  apply minus1Trunc_rect_nondep;[|intros[]].
  intros [H | H]; auto.
- apply related_classes_eq.
  red. simpl. path_via (ya°xb). apply (commutative (°) _).
  path_via (xa ° yb).
  apply (commutative (°) _).
Defined.

Lemma frac_neq : neq fracZero fracOne.
Proof.
intros H.
apply classes_eq_related in H.
red in H;simpl in H. apply Hneq.
eapply concat;[|eapply concat;[apply H|]].
apply inverse. apply One.
apply One.
Defined.

Lemma fracInv_inv : forall x : fracQuot, neq ZeroV x
 -> IsInverse (°) x (fracInv x).
Proof.
apply (quotient_ind (fun x => _ -> _) _).

intros [[xa xb] Hx] H.
simpl in *. unfold fracInvU. simpl.
destruct (Hdec ZeroV xa).
- destruct H.
  apply related_classes_eq. red. simpl.
  eapply concat. apply rmult_0_l.
  destruct p;apply inverse;apply rmult_0_l.
- apply linverse_inverse.
  red. apply transport with OneV.
  symmetry. apply related_classes_eq.
  red;simpl.
  path_via (xa°xb). apply One.
  path_via (xb ° xa). apply (commutative (°) _).
  apply inverse;apply One.
  apply _.
Defined.

Global Instance frac_isdecfield : IsDecField fracPrering.
Proof.
apply BuildIsDecField with frac_isring fracInv.
apply frac_neq.
simpl. unfold fracInvU. simpl.
destruct (Hdec ZeroV ZeroV) as [_|[]]; reflexivity.
apply fracInv_inv.
Defined.

End VarSec.

End Fraction.


Require Import
  HoTT.Basics
  HoTT.Types
  HoTT.HSet
  HoTT.Spaces.Nat
  HoTT.Spaces.Finite.Fin.

Local Open Scope nat_scope.

Definition FinNat (n : nat) : Type0 := {x : nat | x < n}.

Definition zero_finnat (n : nat) : FinNat n.+1
  := (0; leq_1_Sn).

Lemma path_zero_finnat (n : nat) (h : 0 < n.+1) : zero_finnat n = (0; h).
Proof.
  by apply path_sigma_hprop.
Defined.

Definition succ_finnat {n : nat} (u : FinNat n) : FinNat n.+1
  := (u.1.+1; leq_S_n' u.1.+1 n u.2).

Lemma path_succ_finnat {n : nat} (u : FinNat n) (h : u.1.+1 < n.+1)
  : succ_finnat u = (u.1.+1; h).
Proof.
  by apply path_sigma_hprop.
Defined.

Definition last_finnat (n : nat) : FinNat n.+1
  := exist (fun x => x < n.+1) n (leq_refl n.+1).

Lemma path_last_finnat (n : nat) (h : n < n.+1)
  : last_finnat n = (n; h).
Proof.
  by apply path_sigma_hprop.
Defined.

Definition incl_finnat {n : nat} (u : FinNat n) : FinNat n.+1
  := (u.1; leq_trans u.2 (leq_S n n (leq_n n))).

Lemma path_incl_finnat (n : nat) (u : FinNat n) (h : u.1 < n.+1)
  : incl_finnat u = (u.1; h).
Proof.
  by apply path_sigma_hprop.
Defined.

Definition finnat_ind (P : forall n : nat, FinNat n -> Type)
  (z : forall n : nat, P n.+1 (zero_finnat n))
  (s : forall (n : nat) (u : FinNat n), P n u -> P n.+1 (succ_finnat u))
  {n : nat} (u : FinNat n)
  : P n u.
Proof.
  induction n as [| n IHn].
  - elim (not_lt_n_0 u.1 u.2).
  - destruct u as [x h].
    destruct x as [| x].
    + exact (transport (P n.+1) (path_zero_finnat _ h) (z _)).
    + refine (transport (P n.+1) (path_succ_finnat (x; leq_S_n _ _ h) _) _).
      apply s. apply IHn.
Defined.

Lemma compute_finnat_ind_zero (P : forall n : nat, FinNat n -> Type)
  (z : forall n : nat, P n.+1 (zero_finnat n))
  (s : forall (n : nat) (u : FinNat n), P n u -> P n.+1 (succ_finnat u))
  (n : nat)
  : finnat_ind P z s (zero_finnat n) = z n.
Proof.
  cbn. by induction (hset_path2 1 (path_zero_finnat n leq_1_Sn)).
Defined.

Lemma compute_finnat_ind_succ (P : forall n : nat, FinNat n -> Type)
  (z : forall n : nat, P n.+1 (zero_finnat n))
  (s : forall (n : nat) (u : FinNat n),
       P n u -> P n.+1 (succ_finnat u))
  {n : nat} (u : FinNat n)
  : finnat_ind P z s (succ_finnat u) = s n u (finnat_ind P z s u).
Proof.
  refine
    (_ @ transport
          (fun p => transport _ p (s n u _) = s n u (finnat_ind P z s u))
          (hset_path2 1 (path_succ_finnat u (leq_S_n' _ _ u.2))) 1).
  destruct u as [u1 u2].
  assert (u2 = leq_S_n u1.+1 n (leq_S_n' u1.+1 n u2)) as p.
  - apply path_ishprop.
  - simpl. by induction p.
Defined.

Monomorphic Definition is_bounded_fin_to_nat {n} (k : Fin n)
  : fin_to_nat k < n.
Proof.
  induction n as [| n IHn].
  - elim k.
  - destruct k as [k | []].
    + apply (@leq_trans _ n _).
      * apply IHn.
      * by apply leq_S.
    + apply leq_refl.
Defined.

Monomorphic Definition fin_to_finnat {n} (k : Fin n) : FinNat n
  := (fin_to_nat k; is_bounded_fin_to_nat k).

Monomorphic Fixpoint finnat_to_fin {n : nat} : FinNat n -> Fin n
  := match n with
     | 0 => fun u => Empty_rec (not_lt_n_0 _ u.2)
     | n.+1 => fun u =>
        match u with
        | (0; _) => fin_zero
        | (x.+1; h) => fsucc (finnat_to_fin (x; leq_S_n _ _ h))
        end
     end.

Lemma path_fin_to_finnat_fsucc {n : nat} (k : Fin n)
  : fin_to_finnat (fsucc k) = succ_finnat (fin_to_finnat k).
Proof.
  apply path_sigma_hprop.
  apply path_nat_fsucc.
Defined.

Lemma path_fin_to_finnat_fin_zero (n : nat)
  : fin_to_finnat (@fin_zero n) = zero_finnat n.
Proof.
  apply path_sigma_hprop.
  apply path_nat_fin_zero.
Defined.

Lemma path_fin_to_finnat_fin_incl {n : nat} (k : Fin n)
  : fin_to_finnat (fin_incl k) = incl_finnat (fin_to_finnat k).
Proof.
  reflexivity.
Defined.

Lemma path_fin_to_finnat_fin_last (n : nat)
  : fin_to_finnat (@fin_last n) = last_finnat n.
Proof.
  reflexivity.
Defined.

Lemma path_finnat_to_fin_succ {n : nat} (u : FinNat n)
  : finnat_to_fin (succ_finnat u) = fsucc (finnat_to_fin u).
Proof.
  cbn. do 2 f_ap. by apply path_sigma_hprop.
Defined.

Lemma path_finnat_to_fin_zero (n : nat)
  : finnat_to_fin (zero_finnat n) = fin_zero.
Proof.
  reflexivity.
Defined.

Lemma path_finnat_to_fin_incl {n : nat} (u : FinNat n)
  : finnat_to_fin (incl_finnat u) = fin_incl (finnat_to_fin u).
Proof.
  induction n as [| n IHn].
  - elim (not_lt_n_0 _ u.2).
  - destruct u as [x h].
    destruct x as [| x]; [reflexivity|].
    refine ((ap _ (ap _ (path_succ_finnat (x; leq_S_n _ _ h) h)))^ @ _).
    refine (_ @ ap fsucc (IHn (x; leq_S_n _ _ h))).
    by induction (path_finnat_to_fin_succ (incl_finnat (x; leq_S_n _ _ h))).
Defined.

Lemma path_finnat_to_fin_last (n : nat)
  : finnat_to_fin (last_finnat n) = fin_last.
Proof.
  induction n as [| n IHn].
  - reflexivity.
  - exact (ap fsucc IHn).
Defined.

Lemma path_finnat_to_fin_to_finnat {n : nat} (u : FinNat n)
  : fin_to_finnat (finnat_to_fin u) = u.
Proof.
  induction n as [| n IHn].
  - elim (not_lt_n_0 _ u.2).
  - destruct u as [x h].
    apply path_sigma_hprop.
    destruct x as [| x].
    + exact (ap pr1 (path_fin_to_finnat_fin_zero n)).
    + refine ((path_fin_to_finnat_fsucc _)..1 @ _).
      exact (ap S (IHn (x; leq_S_n _ _ h))..1).
Defined.

Lemma path_fin_to_finnat_to_fin {n : nat} (k : Fin n)
  : finnat_to_fin (fin_to_finnat k) = k.
Proof.
  induction n as [| n IHn].
  - elim k.
  - destruct k as [k | []].
    + specialize (IHn k).
      refine (path_finnat_to_fin_incl (fin_to_finnat k) @ _).
      exact (ap fin_incl IHn).
    + apply path_finnat_to_fin_last.
Defined.

Definition equiv_fin_finnat (n : nat) : Fin n <~> FinNat n
  := equiv_adjointify fin_to_finnat finnat_to_fin
      path_finnat_to_fin_to_finnat
      path_fin_to_finnat_to_fin.


Set Implicit Arguments.

Require Import MakeWrapper ExampleADT ExampleRepInv.

Module Import Wrp := Make(ExampleADT)(ExampleRepInv).
Export Wrp.

Require Import Notations4.
Module Import Notations4Make := Make ExampleADT.

Open Scope nat.

Require Import Arith.

Definition fact_w (w : W) := natToW (fact (wordToNat w)).

Import ProgramLogicMake.

Definition body := (
    "ret" <- 1;;
    [BEFORE(V, h)
     AFTER(V', h')
       fact_w (V "n") = V' "ret" ^* fact_w (V' "n")
       /\ h' = h]
    While (0 < "n") {
      "ret" <- "ret" * "n";;
      "n" <- "n" - 1
    }
  )%stmtex.

Definition f := (
  cfunction "fact"("n")
    body
  end
)%Citofuncs.

Definition m := cmodule "fact" {{
  f
}}.

Lemma good : IsGoodModule m.
  good_module.
Qed.

Definition gm := to_good_module good.

Definition fspec :=
  cimport "fact"!"fact"
  cmodules [[ gm ]]
  definition f.

Notation extra_stack := 40.

Definition topS := SPEC reserving (4 + extra_stack)
  PREonly[_] mallocHeap 0.

Notation input := 5.

Definition top := bimport [[ ("fact"!"fact", fspec), "sys"!"printInt" @ [printIntS],
                             "sys"!"abort" @ [abortS] ]]
  bmodule "top" {{
    bfunction "top"("R") [topS]
      "R" <-- Call "fact"!"fact"(extra_stack, input)
      [PREonly[_, R] [| R = fact input |] ];;

      Call "sys"!"printInt"("R")
      [PREonly[_] Emp ];;

      Call "sys"!"abort"()
      [PREonly[_] [| False |] ]
    end
  }}.

Definition empty_precond : assert := fun _ v0 v => v0 = v.

Require Import WordFacts2 WordFacts5.

Lemma fact_step : forall n,
  ($0 < n)%word
  -> fact_w n = n ^* fact_w (n ^- $1).
  intros.
  unfold fact_w.
  rewrite wordToNat_positive by assumption.
  unfold fact at 1; fold fact.
  rewrite <- wordToNat_positive by assumption.
  unfold natToW; rewrite natToWord_mult.
  rewrite natToWord_wordToNat.
  reflexivity.
Qed.

Hint Rewrite fact_step using solve [ eauto 2 ] : sepFormula.

Definition dummy_gf : GoodFunction.
  refine (to_good_function f _).
  good_module.
Defined.

Definition spec_op := hd dummy_gf (Functions gm).

Definition specs := add ("fact", "fact") (Internal spec_op) (empty _).

Definition modules := gm :: nil.
Definition imports := empty ForeignFuncSpec.

Import LinkSpecMake.
Require Import LinkSpecFacts.
Module Import LinkSpecFactsMake := Make ExampleADT.
Import Notations4Make.
Import LinkSpecMake.

Lemma specs_good : specs_equal specs modules imports.
  split; intros.

  unfold label_mapsto, specs in *.
  eapply find_mapsto_iff in H.
  eapply add_mapsto_iff in H.
  openhyp.
  subst; simpl in *.
  left; descend; eauto.
  unfold spec_op, gm; simpl; eauto.

  eapply empty_mapsto_iff in H0; intuition.

  unfold label_mapsto, specs in *.
  eapply find_mapsto_iff.
  eapply add_mapsto_iff.
  openhyp.
  subst; simpl in *.
  openhyp.
  2 : intuition.
  subst.
  left.
  unfold spec_op, gm, to_good_module in *; simpl in *.
  openhyp.
  2 : intuition.
  subst; simpl in *.
  eauto.

  subst; simpl in *.
  right; descend; eauto.
  Require Import GeneralTactics2.
  nintro.
  subst; simpl in *.
  compute in H0.
  intuition.
  rewrite empty_o in H0; intuition.
Qed.

Lemma vcs_good : and_all (vc body empty_precond) specs.
  unfold empty_precond; cito_vcs body; words.
Qed.

Local Hint Immediate vcs_good.

Theorem final : forall n x r,
  ($0 >= n)%word
  -> x = r ^* fact_w n
  -> r = x.
  intros; subst.
  assert (n = $0) by (apply wordToNat_inj; nomega).
  subst.
  change (fact_w $0) with (natToW 1).
  words.
Qed.

Local Hint Resolve final.

Import LinkSpecMake.

Hint Resolve specs_good.

Lemma body_runsto : forall stn fs v v', env_good_to_use modules imports stn fs -> RunsTo (from_bedrock_label_map (Labels stn), fs stn) (Body f) v v' -> sel (fst v') (RetVar f) = fact_w (sel (fst v) "n") /\ snd v' = snd v.
  cito_runsto f empty_precond vcs_good; eauto.
  eapply specs_equal_agree; eauto.
Qed.

Lemma body_safe : forall stn fs v, env_good_to_use modules imports stn fs -> Safe (from_bedrock_label_map (Labels stn), fs stn) (Body f) v.
  cito_safe f empty_precond vcs_good.
  eapply specs_equal_agree; eauto.
Qed.

Require Import Inv.
Module Import InvMake := Make ExampleADT.
Module Import InvMake2 := Make ExampleRepInv.
Import Made.

Theorem top_ok : moduleOk top.
  vcgen.

  sep_auto.
  sep_auto.
  sep_auto.
  sep_auto.

  post.
  call_cito 40 ("n" :: nil).
  hiding ltac:(evaluate auto_ext).
  unfold name_marker.
  hiding ltac:(step auto_ext).
  unfold spec_without_funcs_ok.
  post.
  descend.
  eapply CompileExprs.change_hyp.
  Focus 2.
  apply (@is_state_in''' (upd (upd x2 "extra_stack" 40) "n" input)).
  autorewrite with sepFormula.
  clear H7.
  hiding ltac:(step auto_ext).
  apply body_safe; eauto.
  hiding ltac:(step auto_ext).
  repeat ((apply existsL; intro) || (apply injL; intro) || apply andL); reduce.
  apply swap; apply injL; intro.
  openhyp.
  Import LinkSpecMake2.CompileFuncSpecMake.InvMake.SemanticsMake.
  match goal with
    | [ x : State |- _ ] => destruct x; simpl in *
  end.
  Require Import GeneralTactics3.
  eapply_in_any body_runsto; simpl in *; intuition subst.
  eapply replace_imp.
  change 40 with (wordToNat (sel (upd (upd x2 "extra_stack" 40) "n" 5) "extra_stack")).
  apply is_state_out''''.
  NoDup.
  NoDup.
  NoDup.
  clear H7.
  hiding ltac:(step auto_ext).
  hiding ltac:(step auto_ext).
  Require Import BedrockTactics.
  sel_upd_simpl.
  rewrite H9.
  rewrite H11.
  reflexivity.

  sep_auto.
  sep_auto.
  sep_auto.
  sep_auto.
  sep_auto.
  sep_auto.
  sep_auto.
Qed.

Definition all := link top (link_with_adts modules imports).

Theorem all_ok : moduleOk all.
  link0 top_ok.
Qed.


(* TP3 Langages formels *)

(******************************************************************************)
(********** programmation fonctionnelle et automates en Coq (partie 2) ********)
(******************************************************************************)

(*
  L'objectif de LIFLF_TP3 est de définir des automates et de les faire s'exécuter
  dans la partie *programme* de Coq. Pour cela, on va utiliser ce qu'on a défini
  lors du TP2, pour définir les automates :
   1) Le codage du quintuplet usuel <K, Sigma, delta : K*Sigma -> K, s, F> en Coq,
   2) La représentation finie de la fonction delta : K*Sigma -> K.

  Pour aller plus loin, on introduit le polymorphisme en fin de sujet.
*)

(* On commence par rappeler ce qu'on avait défini dans le TP2 *)

(* Notre alphabet d'exemple *)
Inductive Alphabet : Type :=
| a : Alphabet
| b : Alphabet.

(* La fonction "comp_alphabet" de comparaison de deux Alphabet *)
Definition comp_alphabet (x y : Alphabet) : bool :=
  match x with
  | a => match y with
         | a => true
         | b => false
         end
  | b => match y with
         | a => false
         | b => true
         end
end.

Require Export List.
Import ListNotations.

(* La fonction "appartient" qui teste si un entier appartient à une liste d'entiers *)
Fixpoint appartient (x : nat) (l : list nat) : bool :=
  match l with
  | [] => false
  | h::rl => (Nat.eqb x h) || (appartient x rl)
  end.

(* La fonction "trouve" qui prend en paramètres une listes de paires (clef,valeur)
   et une clef k, et renvoie la première valeur associée à k quand elle existe et None sinon
*)
Fixpoint trouve (assoc : list (Alphabet * nat)) (key : Alphabet) : option nat :=
  match assoc with
    | [] => None
    | h::rassoc => if (comp_alphabet key (fst h)) then (Some (snd h))
                   else trouve rassoc key
  end.

(******************************************************************************)
(* Partie 1 : la représentation des Automates en Coq  *)
(******************************************************************************)

(* Formellement, un Automate est un quintuplet <K, Sigma, delta : K*Sigma -> K, s, F > avec
   - K l'ensemble des états,
   - Sigma l'alphabet,
   - delta la fonction de transition
   - s l'état initial,
   - F l'ensemble des état finaux.

   Ici, on va représenter les ensembles par des listes et la fonction de transition par une fonction (!).
   On va s'appuyer sur le type "Alphabet" défini dans le TP2.
   De même, on va prendre les entiers "nat" pour identifier les états.

   L'automate "M" défini par "automate K Sigma delta s F", correspond au
   quintuplet "M = <K, Sigma, delta, s, F>" du cours.

   On justifie la représentation et le choix des types :
    - (K : list nat) : *liste* de TOUS les états. Une liste c'est différent d'un ensemble, plus facilement programmable
    - (Sigma : Alphabet) : liste des symboles utilisés
    - (s : nat) : état initial
    - (F : list nat) une liste de nat des états finals. Là encore ensemble != liste.

   La principale différence est sur le choix de la fonction de transition delta
    - (delta : nat -> Alphabet -> option nat)

   C'est *presque* le type usuel K * Sigma -> K à la curryfication près ET avec une "option" sur le résultat.
   "option" permet d'exprimer que la fonction de transition delta est *partielle* (et non totale) :
   on va en fait manipuler en Coq des automates aux transitions *partielles*.
*)

(* EXERCICE *)
(* Définir le type "Automate" représentant ce quintuplet.
   Ce type aura un seul constructeur que l'on nommera "automate". *)
Inductive automate :=
|Automate : list nat -> list Alphabet -> (nat->Alphabet->option nat) -> nat -> list nat -> automate.

(* EXERCICE *)
(* Définir les 5 fonctions suivantes *)

(* "etats" : prend en paramètre un automate et renvoie la liste des états *)
Definition etats (Auto : automate) : list nat :=
match Auto with
|Automate K Sigma delta s F => K
end.

(* "symboles" : prend en paramètre un automate et renvoie la liste des symboles de l'alphabet *)
Definition symboles (Auto : automate) : list Alphabet :=
match Auto with
|Automate K Sigma delta s F => Sigma
end.

(* "initial" : prend en paramètre un automate et renvoie l'état initial *)
Definition initial (Auto : automate) : nat :=
match Auto with
|Automate K Sigma delta s F => s
end.

(* "acceptant" : prend en paramètre un automate et un état q et renvoie true ssi q est un état final *)
Definition acceptant (Auto : automate)(q : nat) : bool :=
match Auto with
|Automate K Sigma delta s F => appartient q F
end.

(* "transition" : prend en paramètre un automate, un état q et un symbole c, et renvoie l'état (optionnellement)
   accessible depuis q en lisant c *)
Definition transition (Auto : automate) (q : nat) (c : Alphabet) : option nat :=
match Auto with
|Automate K Sigma delta s F => delta q c
end.

(* EXERCICE *)
(* Exemple : définir l'automate "M_nb_b_impair" à deux états qui accepte les mots contenant un nombre impair de 'b',
             et donner des tests unitaires. La fonction delta est donnée ci-dessous. *)

Definition delta_nb_b_impair (q : nat) (c : Alphabet) : option nat :=
match (q,c) with
 | (1,a) => Some 1
 | (1,b) => Some 2
 | (2,a) => Some 2
 | (2,b) => Some 1
 | (_,_) => None
end.

Definition M_nb_b_impair : automate :=
Automate (1::2::[]) (a::b::[]) delta_nb_b_impair 1 (2::[]).

Example M_nb_b_impair_etats : etats M_nb_b_impair = [1;2].
Proof.
cbv. reflexivity.
Qed.
Example M_nb_b_impair_symboles : symboles M_nb_b_impair = [a;b].
Proof.
cbv. reflexivity.
Qed.
Example M_nb_b_impair_initial : initial M_nb_b_impair = 1.
Proof.
cbv. reflexivity.
Qed.
Example M_nb_b_impair_acceptant_1 : acceptant M_nb_b_impair 1 = false.
Proof.
cbv. reflexivity.
Qed.
Example M_nb_b_impair_acceptant_2 : acceptant M_nb_b_impair 2 = true.
Proof.
cbv. reflexivity.
Qed.
Example M_nb_b_impair_transition_1 : transition M_nb_b_impair 1 a = Some 1.
Proof.
cbv. reflexivity.
Qed.
Example M_nb_b_impair_transition_2 : transition M_nb_b_impair 2 b = Some 1.
Proof.
cbv. reflexivity.
Qed.

(* EXERCICE *)
(* Définir "execute" qui prend en paramètre un automate, un état q et un mot w (une "list Alphabet"),
   et qui va calculer l'état d'arrivée, en partant de l'état q et en lisant le mot w *)
Fixpoint execute (Auto : automate)(q : nat)(w : list Alphabet) : option nat :=
match Auto with
|Automate K Sigma delta s F =>  match w with
                                |[] => Some q
                                |c::l => match delta q c with
                                         |None => None
                                         |Some n => execute Auto n l
                                         end
                                end
end.

Example M_nb_b_impair_execute_1 : execute M_nb_b_impair 1 [] = Some 1.
cbv. reflexivity. Qed.
Example M_nb_b_impair_execute_2 : execute M_nb_b_impair 1 [a;a;b;a;b;b] = Some 2.
cbv. reflexivity. Qed.

(* EXERCICE *)
(* Définir "reconnait" qui prend en paramètre un automate et un mot w,
   et qui renvoie vrai si w est accepté par l'automate, faux sinon *)
Definition reconnait (Auto : automate) (w : list Alphabet) : bool :=
match Auto with
|Automate K Sigma delta s F => match execute Auto s w with
                               |None => false
                               |Some n => acceptant Auto n
                               end
end.

Example M_nb_b_impair_reconnait_1 : reconnait M_nb_b_impair [] = false.
cbv. reflexivity. Qed.
Example M_nb_b_impair_reconnait_2 : reconnait M_nb_b_impair [a;a;b;a;b;b] = true.
cbv. reflexivity. Qed.

(* EXERCICE *)
(* Exemple : définir l'automate "M_commence_et_finit_par_a" à trois états
             qui accepte les mots commençant et finissant par 'a',
             et donner des tests unitaires *)
Definition delta_commence_et_finit_par_a (q : nat)(c : Alphabet) : option nat :=
match (q, c) with
|(1, a) => Some 2
|(1, b) => None
|(2, a) => Some 2
|(2, b) => Some 3
|(3, a) => Some 2
|(3, b) => Some 3
|(_, _) => None
end.

Definition M_commence_et_finit_par_a : automate :=
Automate (1::2::3::[]) (a::b::[]) delta_commence_et_finit_par_a 1 (2::[]).

Example M_commence_et_finit_par_a_reconnait_1 : reconnait M_commence_et_finit_par_a [] = false.
cbv. reflexivity. Qed.

Example M_commence_et_finit_par_a_reconnait_2 : reconnait M_commence_et_finit_par_a [a] = true.
cbv. reflexivity. Qed.

Example M_commence_et_finit_par_a_reconnait_3 : reconnait M_commence_et_finit_par_a [a;b;a;a;b] = false.
cbv. reflexivity. Qed.

Example M_commence_et_finit_par_a_reconnait_4 : reconnait M_commence_et_finit_par_a [a;b;a;a;b;a] = true.
cbv. reflexivity. Qed.

(******************************************************************************)
(* Partie 2 : la représentation des fonctions de transition en Coq ou
              recherche dans les listes de paires  *)
(******************************************************************************)
Require Import Nat.
Print nat.

(* La fonction qui teste l'égalité de deux entiers. *)
Check Nat.eqb : nat -> nat -> bool.
Print Nat.eqb.
(* On souhaite donner une description de la fonction de transition par SON GRAPHE
   plutôt que donner son code.
   Rappel, le graphe d'une fonction f : A -> B est la relation définie par { (x,f(x)) | x dans A}.

   Par exemple la liste [((1,a),1) ; ((1,b),2) ; ((2,a),2) ; ((2,b),1)] indique que
     - ((1,a),1) : état courant 1, symbole courant a --> nouvel état 1
     - ((1,b),2) : état courant 1, symbole courant b --> nouvel état 2
     - ((2,a),2) : état courant 2, symbole courant a --> nouvel état 2
     - ((2,b),1) : état courant 2, symbole courant b --> nouvel état 1
*)

Print delta_nb_b_impair.
(*
Definition delta_nb_b_impair (c : Alphabet) (q : nat) : option nat :=
match (c,q) with
 | (a,1) => Some 1
 | (b,1) => Some 2
 | (a,2) => Some 2
 | (b,2) => Some 1
 | (_,_) => None
end.
*)

(* Comme le domaine de la fonction de transition est fini, on peut faire l'inverse,
   c'est-à-dire construire une fonction à partir d'un graphe FINI.

   On va représenter le graphe de f par *un dictionnaire*, une liste de paires (clé, valeur).

   La principale fonctionnalité que l'on attend d'un dictionnaire est de pouvoir retrouver
   la valeur associée à une clé. En le faisant, on reconstruit (à un "option" près) f
*)

(* EXERCICE *)
(* Définir la fonction "trouve_paire" avec pour type "list ((nat * Alphabet) * nat) -> (nat * Alphabet) -> option nat"
   qui prend en paramètres une liste et une clé et retourne la première valeur correspondant à la clé si elle existe,
   None sinon.
   La liste est une liste de "((nat * Alphabet) * Alphabet)" et donc la clé est un "(nat * Alphabet)".
*)
Fixpoint trouve_paire (l : list ((nat * Alphabet) * nat)) (p : (nat * Alphabet)) : option nat :=
match l with
|[] => None
|h::l2 => match p with
                       |(n,c) => if (Nat.eqb (fst (fst h)) n)
                        then if (comp_alphabet(snd (fst h)) c)
                             then Some (snd h)
                             else trouve_paire l2 p
                        else trouve_paire l2 p
                        end
end.

(* EXERCICE *)
(* En utilisant trouve_paire, définir une fonction "graphe_vers_fonction" qui transforme
   une liste "list ((nat * Alphabet) * nat)" en une fonction "nat -> Alphabet -> option nat"
*)
CoInductive graphe_vers_fonction (l : list ((nat * Alphabet) * nat)) : nat -> Alphabet -> option nat :=
  forall (n : nat)(c : Alphabet),
          appartient l (n, c) -> trouve_paire l (n, c)
  end
end.

(* EXERCICE *)
(* Exemple : définir l'automate "M_nb_b_impair'"à deux états qui accepte les mots contenant un nombre impair de 'b',
             et donner des tests unitaires. Le graphe de transition est donnée ci-dessous. *)
Definition graphe_nb_b_impair := [((1,a), 1) ; ((1,b),2) ; ((2,a),2) ; ((2,b),1)].

(*
Example M_nb_b_impair_reconnait_1' : reconnait M_nb_b_impair' [] = false.
cbv. reflexivity. Qed.
Example M_nb_b_impair_reconnait_2' : reconnait M_nb_b_impair' [a;a;b;a;b;b] = true.
cbv. reflexivity. Qed.
*)

(* EXERCICE *)
(* Exemple : définir l'automate à trois états qui accepte les mots commençant et finissant par 'a',
             et donner des tests unitaires. Définir pour cela le graphe puis l'automate qui l'utilise. *)

(* Rappel : dans "M_nb_b_impair'" et "M_nb_b_impair" on ne s'intéresse qu'aux états,
            PAS à TOUS les entiers, donc on met une garde sur "q". *)

(* EXERCICE *)
(* Montrer que delta_nb_b_impair et delta_nb_b_impair_graphe sont équivalents sur les états valides *)
(* Cette preuve utilise la logique du premier ordre, nous reviendrons dessus plus tard. *)

(* FIN DU TP3 *)

(* ------------------------------------------------------------ *)

(******************************************************************************)
(* Pour aller plus loin : le polymorphisme  *)
(******************************************************************************)

(* Quand on lit et a fortiori quand on écrit la fonction "appartient" on remarque
   son caractère générique sur les listes. *)

Print appartient.

(* Elle est écrite pour le type "list nat" mais si on remplace "Nat.eqb"
   par une fonction "comp_A : A -> A -> bool", "appartient" fonctionnerait
   pour un type donné "A". *)

(* EXERCICE *)
(* Définir la fonction "appartient_poly" qui prend en paramètres
    - Un type A,
    - Une fonction comp_A de décision de l'égalité sur A,
    - Un élement x de type A,
    - Une liste l d'éléments de A,
   et renvoie true si et seulement si l'élément x est dans la liste l *)

(* Tests unitaires avec reflexivity *)
(*
Example appartient_poly_ex1 : appartient_poly nat (Nat.eqb) 0 [1;3;0;5] = true.
Proof.
simpl. reflexivity.
Qed.
Example appartient_poly_ex2 : appartient_poly nat (Nat.eqb) 4 [1;3;0;5] = false.
Proof.
simpl. reflexivity.
Qed.
*)

(* EXERCICE *)
(* Montrer que "appartient" est juste l'instance particulière de "appartient_poly nat (Nat.eqb) nat (Nat.eqb)" *)

(* Pour bien représenter *l'appartenance* à la liste, il faut quand même s'assurer
   que "comp_A" respecte la spécification 'décider de l'égalité dans "A"'.
   Les exemples suivants montrent des choix arbitraires de "comp_A". *)

(*
Example appartient_poly_ex3 : appartient_poly nat (fun x y => false) 0 [1;3;0;5] = false.
Proof.
simpl. reflexivity.
Qed.

Example appartient_poly_ex4 : appartient_poly nat (fun x y => true) 4 [1;3;0;5] = true.
Proof.
simpl. reflexivity.
Qed.
*)

(* Si on veut prouver le lemme équivalent pour "appartient_poly", on a besoin
   d'une propriété de type "forall x y:A, comp_A x y = true <-> x = y"
   similaire à "PeanoNat.Nat.eqb_eq", "comp_alphabet_eq", "comp_option_nat_correct", etc. *)

(* EXERCICE *)
(* Montrer que si x = y alors x appartient à une liste constituée que de [y] *)

(* On peut même aller plus loin et montrer que "(comp x y = true <-> x = y)" est
  non seulement SUFFISANTE mais aussi NECESSAIRE si on veut "appartient_poly A comp x [y] = true <-> x = y" *)

(* EXERCICE *)
(* Montrer que si x appartient à une liste constituée que de [y] alors x = y *)

(* Il en est de même pour "trouve" et "trouve_paire" *)

Print trouve.
Print trouve_paire.

(* EXERCICE *)
(* Définir la fonction "trouve_poly", version polymorphe de "trouve" et "trouve_paire" *)

(* EXERCICE *)
(* Montrer que "trouve" et "trouve_paire" sont bien des instances de "trouve_poly" *)

(* ------------------------------------------------------------ *)