(*************************************************************************)
(**                                                                      *)
(** * Typing: preservation and progress                                  *)
(**                                                                      *)
(*************************************************************************)

Require Import Coq.Strings.String.
From Coq Require Import ssreflect ssrfun ssrbool.
Require Import Utf8 Arith Compare_dec Lia.
Set Warnings "-notation-overridden".
Require Import Relation_Operators Program.
Close Scope program_scope.
From Equations Require Import Equations.

Require Import Metalib.Metatheory.
Require Import Stlc.Classes.
Require Import Stlc.ClassInstances.
Require Import Stlc.ClassRewrites.
Require Import Stlc.DefinitionsTyping.
Require Import Stlc.Fin.
Require Import Stlc.DefinitionsSyntax.

Opaque Syntax_exp.

Import SyntaxNotations.

(*************************************************************************)
(** * Typing contexts *)
(*************************************************************************)

(** We represent contexts as association lists (lists of pairs of
    keys and values) whose keys are [atom]s.   *)

(** For STLC, contexts bind [atom]s to [typ]s.  We define an
    abbreviation [ctx] for the type of these contexts.

    Lists are defined in Coq's standard library, with the constructors
    [nil] and [cons].  The list library includes the [::] notation
    for cons as well as standard list operations such as append, map,
    and fold. The infix operation "++" is list append.

    The Metatheory library extends this reasoning by instantiating the
    AssocList library to provide support for association lists whose
    keys are [atom]s.  Everything in this library is polymorphic over
    the type of objects bound in the context.  Look in AssocList
    for additional details about the functions and predicates that we
    mention below.  *)

(** Context equality *)

(** When reasoning about contexts, we often need to talk about
    bindings in the "middle" of a context. Therefore, it is common
    for lemmas and definitions to use list append in their statements.
    Unfortunately, list append is associative, so two Coq expressions may
    denote the same context even though they are not equal.

    The tactic [simpl_env] reassociates all concatenations of
    contexts to the right.  *)

Lemma append_assoc_demo : forall (E0 E1 E2 E3:ctx),
  E0 ++ (E1 ++ E2) ++ E3 = E0 ++ E1 ++ E2 ++ E3.
Proof.
  intros.
  auto. (* Does nothing. *)
  simpl_env.
  reflexivity.
Qed.

(** To make contexts easy to read, instead of building them from
    [nil] and [cons], we prefer to build them from the following
    components:
      - [nil]: The empty list.
      - [one]: Lists consisting of exactly one item.
      - [++]:  List append.
*)

(** The simpl_env tactic actually puts lists built from only nil, one
    and [++] into a "normal form". This process reassociates all appends
    to the right, removes extraneous nils and converts cons to singleton
    lists with an append.
*)

Lemma simpl_env_demo : forall (x y:atom) (T1 T2:typ) (E F:ctx),
   ([(x, T1)] ++ nil) ++ (y,T2) :: (nil ++ E) ++ F =
   [(x,T1)] ++ [(y, T2)] ++ E ++ F.
Proof.
   intros.
   (* simpl_env puts the left side into the normal form. *)
   simpl_env.
   reflexivity.
Qed.

(** Context operations. *)

(** The ternary predicate [binds] holds when a given binding is
    present somewhere in a context.
*)

Lemma binds_demo : forall (x:atom) (T:typ) (E F:ctx),
  binds x T (E ++ [(x, T)] ++ F).
Proof.
  auto.
Qed.

(** The function [dom] computes the domain of a context, returning a
    finite set of [atom]s. Note that we cannot use Coq's equality for
    finite sets, we must instead use a defined relation [=] for atom
    set equality.  *)

Lemma dom_demo : forall (x y : atom) (T : typ),
  dom [(x, T)] [=] singleton x.
Proof.
  auto.
Qed.

(** The unary predicate [uniq] holds when each atom is bound at most
    once in a context.
*)

Lemma uniq_demo : forall (x y : atom) (T : typ),
  x <> y -> uniq ([(x,T)] ++ [(y, T)]).
Proof.
  auto.
Qed.

(*************************************************************************)
(** * Typing relation and cofinite quantification *)
(*************************************************************************)

(** The typing relation in the STLC definition states the typing rule for
    abstractions in a particular way.

<<
typing_abs
     : forall (L : atoms) (G : ctx) (T1 : typ) (e : exp) (T2 : typ),
       (forall x : atom,
        x `notin` L -> typing ([(x, T1)] ++ G) (open e (var_f x)) T2) ->
       typing G (abs e) (typ_arrow T1 T2)
>>

   To show that abstractions are well-typed, we must show that the body
   of the abstraction is well-typed for any choice of variable, except
   those from some unspecified set `L`.

   This type of rule differs from the quantification in the
   [lc_abs] rule (which does not restrict the variables at all) or
   the [lc_abs_exists] version (which only applies for one particular
   variable. We call this version "co-finite" quantification.

   To see why this version is necessary, we will start with a more
   traditional version of the rules that only uses a single variable
   in the abs rule and then see what goes wrong.
   (We say that the [typing_e] judgement below uses "exists-fresh"
   quantification in the abs rule.)

*)

Inductive typing_e : ctx -> exp 0 -> typ -> Prop :=
  | typing_e_var : forall E (x : atom) T,
      uniq E ->
      binds x T E ->
      typing_e E (var_f x) T
  | typing_e_abs : forall x E e T1 T2,
      x `notin` dom E \u fv_exp e ->
      typing_e ([(x, T1)] ++ E) (e ^ var_f x) T2 ->
      typing_e E (abs e) (typ_arrow T1 T2)
  | typing_e_app : forall E e1 e2 T1 T2,
      typing_e E e1 (typ_arrow T1 T2) ->
      typing_e E e2 T1 ->
      typing_e E (app e1 e2) T2.
#[local] Hint Constructors typing_e : core.

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

(** Weakening states that if an expression is typeable in some
    context, then it is typeable in any well-formed extension of
    that context.  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 e T ->
  uniq (F ++ E) ->
  typing_e (F ++ E) e T.
Proof.
  intros E F e T H J.
  induction H; auto.
  - Case "typing_abs".
    apply (typing_e_abs x).
    (* ... stuck here ... *)
Abort.

(** We are stuck in the [typing_abs] case because the induction
    hypothesis [IHtyping_e] applies only when we weaken the context at its
    head.  In this case, however, we need to weaken the context 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
    context, 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 : ctx) e T,
  typing_e (G ++ E) e T ->
  uniq (G ++ F ++ E) ->
  typing_e (G ++ F ++ E) e T.
Proof.
  intros E F G e T H J.
  induction H.
  Case "typing_var".
    (* The G0 looks strange in the [typing_var] case. *)
2: {
  Case "typing_abs".
    (* The [typing_abs] case still does not have a strong enough IH. *)
  admit. }
Abort.

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

    The problem here arises from the fact that Coq's [induction]
    tactic lets 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 context 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 -> uniq (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.
*)

Lemma typing_weakening_strengthened_1 :  forall (E F G : ctx) e T,
  typing_e (G ++ E) e T ->
  uniq (G ++ F ++ E) ->
  typing_e (G ++ F ++ E) e T.
Proof.
  intros E F G e T H.
  remember (G ++ E) as E'.
  generalize dependent G.
  induction H; intros G0 Eq Uniq; subst.
  - Case "typing_var". auto.
  - Case "typing_abs".
    eapply (typing_e_abs x).
    (* STILL STUCK! *)
Abort.

(** At this point, we are very close. However, there is still one issue. We
    cannot show that [x] is fresh for the weakened context [F].

    This is the difficulty with the definition of [typing_e]. As in the local
    closure judgement, the induction hypotheses is not strong enough in the
    [abs] case.

    However, this time, we take a slightly different solution, with the
    cofinite quantification of the [typing_abs] rule.

<<
| typing_abs :
    forall (L : atoms) (G : ctx) (T1 : typ) (e : exp) (T2 : typ),
    (forall x, x `notin` L -> typing ([(x, T1)] ++ G) (e ^ x) T2) ->
    typing (abs e) (typ_arrow T1 T2) >>
>>

   The advantage of this definition is that it is easier to derive
   the "exists-fresh" version of the rule
   [typing_e_abs] as a lemma, than the version we used in [lc_exp].
   (See below, we prove this lemma after we show substitution.) At the same
   time, this version of the rule is sufficiently expressive to complete
   the proof of weakening.

*)

(** *** Exercise [typing_weakening_strengthened]

    Complete the proof below, using the [typing] relation from [Definitions.v].

    HINTS:

       - The [typing_var] case follows from [binds_weaken], the
         weakening lemma for the [binds] relation.

       - The [typing_abs] case follows from the induction
         hypothesis, but the [apply] tactic may be unable to unify
         things as you might expect.

           -- You'll need to specify the set to avoid with
              (L := dom (G0 ++ F ++ E) \u L)).

           -- In order to apply the induction hypothesis, use
              [rewrite_env] to reassociate the list operations.

           -- After applying the induction hypothesis, use
              [simpl_env] to use [uniq_push].

           -- Here, use [auto] to solve facts about finite sets of
              atoms, since it will simplify the [dom] function behind
              the scenes.  [fsetdec] does not work with the [dom]
              function.

       - The [typing_app] case follows directly from the induction
         hypotheses.
  *)

Lemma typing_weakening_strengthened :  forall (E F G : ctx) e T,
  typing (G ++ E) e T ->
  uniq (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 G0 Eq Uniq; subst.
  - eapply typing_var; eauto.
  - eapply typing_abs with (L := dom (G0 ++ F ++ E) \u L).
    intros x Fr.
    rewrite_env ((x ~ T1 ++ G0) ++ F ++ E).
    eapply H0; auto.
    solve_uniq.
  - eauto.
Qed.

(** *** Demo [typing_weakening]

    We can now prove our original statement of weakening.  The only
    interesting step is the use of the rewrite_env tactic.
*)

Lemma typing_weakening : forall (E F : ctx) e T,
    typing E e T ->
    uniq (F ++ E) ->
    typing (F ++ E) e T.
Proof.
  intros E F e T H J.
  rewrite_env (nil ++ 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_simple : 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 : 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 [typing_subst_var_case]

    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.

    HINTS: Lemmas [binds_mid_eq], [uniq_remove_mid],
    and [binds_remove_mid] are useful.

  *)

Lemma typing_subst_var_case : forall (E F : ctx) u S T (z x : atom),
  binds x T (F ++ [(z,S)] ++ E) ->
  uniq (F ++ [(z,S)] ++ E) ->
  typing E u S ->
  typing (F ++ E) ([z ~> u] (var_f x)) T.
Proof.
  intros E F u S T z x H J K.
  simp subst.
  destruct (x == z); simpl.
  + subst.
    assert (T = S).
    eapply binds_mid_eq; eauto.
    subst.
    eapply typing_weakening; eauto.
  + eapply typing_var; eauto.
Qed.

(** *** Exercise [typing_subst]

    Complete the proof of the substitution lemma. The proof proceeds
    by induction on the typing derivation for [e]. Use [dependent
    induction].

   HINTS:
      - Use the lemma proved above for the [typing_var] case.

      - The [typing_abs] case follows from the induction hypothesis.
          -- Use [simp subst] to simplify the substitution.

          -- apply the [typing_abs] constructor.

          -- In order to use the induction hypothesis, use [subst_open_var]
             to push the substitution under the opening operation.

          -- Recall the lemma [typing_to_lc_exp] and the [rewrite_env]
             and [simpl_env] tactics.

      - The [typing_app] case follows from the induction hypotheses.
        Use [simp subst] to simplify the substitution.
*)

Lemma typing_subst : forall (E F : ctx) e u S T (z : atom),
  typing (F ++ [(z,S)] ++ E) e T ->
  typing E u S ->
  typing (F ++ E) ([z ~> u] e) T.
Proof.
  intros.
  dependent induction H.
  - eapply typing_subst_var_case; eauto.
  - simp subst.
    pick fresh x and apply typing_abs.
    simp syntax. (* subst_open_var *)
    rewrite_env (((x ~ T1)++F)++E).
    eapply H0; eauto.
    auto.
  - simp subst.
    eauto.
Qed.

(** *** Exercise [typing_subst_simpl]

    Complete the proof of the substitution lemma stated in the form we
    need it.  The proof is similar to that of [typing_weakening].

    HINT: You'll need to use [rewrite_env] to prepend [nil],
    and [simpl_env] to simplify nil away.
*)

Lemma typing_subst_simple : forall (E : ctx) e u S T (z : atom),
  typing ([(z,S)] ++ E) e T ->
  typing E u S ->
  typing E ([z ~> u] e) T.
Proof.
  intros.
  eapply typing_subst with (F:= nil); eauto.
Qed.

(*************************************************************************)
(** * Type soundness *)
(*************************************************************************)

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

(** *** Recommended Exercise [preservation]

    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
        [step_beta] case is interesting, since it follows by the
        substitution lemma.  The others follow directly from the
        induction hypotheses.
*)

  (* HINTS:

       - Use [auto] and [eauto], especially with [;], to solve
         "uninteresting" subgoals.

       - Use [inversion] to perform case analyses and to rule out
         impossible cases.

       - In the [step_beta] subcase of the [typing_app] case:

          -- Use [inversion] on a typing judgement to obtain a
             hypothesis about when the body of the abstraction is
             well-typed.

          -- Use [subst_exp_intro] to rewrite the [open] operation
             into an [open] followed by a [subst].  You'll need to
             pick a fresh variable first using the
             [pick fresh x for S] tactic.

  *)

Lemma preservation : forall (E : ctx) e e' T,
  typing E e T ->
  step e e' ->
  typing E e' T.
Proof.
  intros E e e' T H.
  generalize e'.
  dependent induction H; intros e0' S; depelim S; subst.
  - depelim H. inversion H0. subst.
    pick fresh x for (L \u fv e0).
    rewrite (subst_intro _ _ x); auto.
    eapply typing_subst_simple; auto.
  - eauto.
Qed.

(* NOTE: instead of inversion for step derivation, need to use depelim. Otherwise get
 existT equalities that need to be resolved via inj_pair2. *)

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

(** *** Exercise [progress]

    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 context 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.
*)

  (* HINTS:

       - Use [auto] and [eauto], especially with [;], to solve
         "uninteresting" subgoals.

       - Use [inversion] to rule out impossible cases.

       - The lemma [typing_to_lc_exp] will be useful for reasoning
         about local closure.

       - In the [typing_app] case:

          -- Use [destruct] to perform a case analysis on the
             conclusions of the induction hypotheses.

          -- Use [inversion] on a [value] judgement to determine that
             the value must be an abstraction.
  *)

Lemma progress : forall e T,
  typing nil e T ->
  is_value e \/ exists e', step 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.
  + inversion H0. subst. inversion H5.
  + left. simpl. auto.
  + destruct IHtyping1; auto.
     ++ depelim e1; simpl in H2; try done; clear H2.
        depelim H. inversion H2. subst. clear H2.
        right.
        exists (open e2 e1).
        eauto.
     ++ destruct H2 as [e1' h].
        right.
        exists (app e1' e2).
         eauto.
Qed.

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

(** When picking a fresh var or applying a rule that uses cofinite
    quantification, choosing a set of vars 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 tactic [gather_atoms] is used to collect together all the
    atoms in the context.  It relies on an auxiliary tactic,
    [gather_atoms_with] (from MetatheoryAtom), which maps a function
    that returns a finite set of atoms over all hypotheses with the
    appropriate type.
*)

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 (var * typ) => dom x) in
  let D := gather_atoms_with (fun n : nat => fun x : exp n => fv x) in
  constr:(A `union` B `union` C `union` D).

(** A number of other, useful tactics are defined by the Metatheory
    library, and each depends on [gather_atoms].  By redefining
    [gather_atoms], denoted by the [::=] in its definition below, we
    automatically update these tactics so that they use the proper
    notion of "all atoms in the context."

    For example, the tactic [(pick fresh x)] chooses an atom fresh for
    "everything" in the context.  It is the same as [(pick fresh x for
    L)], except where [L] has been computed by [gather_atoms].

*)

(*************************************************************************)
(** * Renaming *)
(*************************************************************************)

(** Substitution and weakening together give us a property we call
   renaming: (see [typing_rename below] that we can change the name
   of the variable used to open an expression in a typing
   derivation. In practice, this means that if a variable is not
   "fresh enough" during a proof, we can use this lemma to rename it
   to one with additional freshness constraints.

   Renaming is used below to show the correspondence between the
   exists-fresh version of the rules with the cofinite version, and
   also to show that typechecking is decidable.
*)

(** However, before we prove renaming, we need an auxiliary lemma about
    typing judgments which says that terms are well-typed only in
    unique contexts.
*)

Lemma typing_uniq : forall E e T,
  typing E e T -> uniq E.
Proof.
  intros E e T H.
  induction H; auto.
  - Case "typing_abs".
    pick fresh x.
    assert (uniq ([(x, T1)] ++ G)); auto.
    solve_uniq.
Qed.

(** Demo: the proof of renaming.

   Note that this proof does not proceed by induction: even if we add
   new typing rules to the language, as long as the weakening and
   substution properties hold we can use this proof.
*)
Lemma typing_rename : forall (x y : atom) E e T1 T2,
  x `notin` fv e ->
  y `notin` dom E ->
  typing ([(x, T1)] ++ E) (e ^ var_f x) T2 ->
  typing ([(y, T1)] ++ E) (e ^ var_f y) T2.
Proof.
  intros x y E e T1 T2 Fr1 Fr2 H.
  destruct (x == y).
  - Case "x = y".
    subst; eauto.
  - Case "x <> y".
    assert (J : uniq ([(x, T1)] ++ E)).
      eapply typing_uniq; eauto.
    assert (J' : uniq E).
      inversion J; eauto.
    rewrite (subst_intro _ _ x); eauto.  (* why does x1=x not work here? *)
    rewrite_env (nil ++ [(y, T1)] ++ E).
    apply typing_subst with (S := T1).
    simpl_env.
    + SCase "(open x s) is well-typed".
      apply typing_weakening_strengthened. eauto. auto.
    + SCase "y is well-typed".
      eapply typing_var; eauto.
Qed.

(*************************************************************************)
(** ** Exists-Fresh Definition *)
(*************************************************************************)

(** The use of cofinite quantification may make some people worry that we
    are not formalizing the "right" language. Below, we show that
    the "exists-fresh" version of the rules is the same as the cofinite
    version. *)

Lemma typing_abs_exists : forall E e T1 T2 (x : atom),
      x `notin` dom E \u fv e ->
      typing ([(x,T1)] ++ E) (e ^ var_f x) T2 ->
      typing E (abs e) (typ_arrow T1 T2).
Proof.
  intros.
  apply typing_abs with (L := dom E \u fv_exp e).
  intros y Fr.
  apply typing_rename with (x:=x); auto.
Qed.

(** *** Exercise [exists_cofinite] *)

Lemma exists_cofinite : forall E e T,
    typing_e E e T -> typing E e T.
Proof.
  (* FILL IN HERE *) Admitted.

(** *** Exercise [cofinite_exists] *)

Lemma cofinite_exists : forall G e T,
    typing G e T -> typing_e G e T.
Proof. (* FILL IN HERE *) Admitted.

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

(** *** Challenge Exercise [fv_in_dom]

   We also want a property that states that the free variables of well-typed
   terms are contained within the domain of their typing contexts.

 *)
Lemma fv_in_dom : forall G e T,
    typing G e T -> fv e [<=] dom G.
Proof.
  intros G e T H.
  dependent induction H; simp fv.
  - eapply binds_In in H0. fsetdec.
  - pick fresh x.
    specialize (H0 x ltac:(eauto)).
    rewrite <- fv_open_lower in H0.
    simpl_env in H0.
    fsetdec.
  - fsetdec.
Qed.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Import Setoid.
From QuicksortComplexity Require Import util.
From QuicksortComplexity Require vec.
Require List.
Require Vector.

Section contents.

Variable T: Set.

Inductive L: Set := one: T -> L | cons: T -> L -> L.

Fixpoint to_plain (l: L): List.list T :=
match l with one x => List.cons x List.nil | cons x y => List.cons x (to_plain y) end.

Coercion to_plain: L >-> List.list.

Fixpoint from_plain (x: T) (l: List.list T): L:=
match l with
| List.nil => one x
| List.cons h t => cons x (from_plain h t)
end.

Lemma round_trip l x: (to_plain (from_plain x l)) = List.cons x l.
Proof with auto. hammer_hook "ne_list" "ne_list.round_trip".
revert l x.
induction l... simpl. rewrite IHl...
Qed.

Fixpoint app (a b: L) {struct a}: L :=
match a with
| one x => cons x b
| cons x y => cons x (app y b)
end.

Variable l: L.

Definition head := match l with one x => x | cons x _ => x end.
Definition tail := match l with one _ => List.nil | cons _ x => to_plain x end.

Lemma head_in_self: List.In head l.
Proof with auto. hammer_hook "ne_list" "ne_list.head_in_self". unfold head. destruct l; left... Qed.

Lemma In_sound x: List.In x l -> (head = x \/ List.In x tail).
Proof with auto. hammer_hook "ne_list" "ne_list.In_sound". unfold head. unfold tail. destruct l... Qed.

Lemma In_cons_head (x: T) y: List.In x (cons x y). left; reflexivity. Qed.
Lemma In_one (x: T): List.In x (one x). left; reflexivity. Qed.

Lemma coerced_cons_eq (h: T): List.cons h l = cons h l.
Proof. hammer_hook "ne_list" "ne_list.coerced_cons_eq". auto. Qed.

End contents.

Definition map (A B: Set) (f: A -> B): L A -> L B :=
fix r (l: L A): L B :=
match l with
| one x => one (f x)
| cons h t => cons (f h) (r t)
end.

Lemma plain_map (A B: Set) (f: A -> B) (l: L A): to_plain (map f l) = List.map f (to_plain l).
Proof with auto. hammer_hook "ne_list" "ne_list.plain_map".
induction l...
simpl.
rewrite IHl...
Qed.

Add Parametric Morphism (A B: Set): (@map A B)
with signature (@ext_eq A B) ==> (@ext_eq (L A) (L B))
as ne_list_map_ext_eq_morph.
Proof with try reflexivity.
unfold ext_eq.
intros.
induction x0; simpl; rewrite H...
rewrite IHx0...
Qed.

Lemma map_ext (T U: Set) (f g: T -> U): ext_eq f g -> forall l, map f l = map g l.
Proof. hammer_hook "ne_list" "ne_list.map_ext".
intros e.
fold (ext_eq (map f) (map g)).
rewrite e.
reflexivity.
Qed.

Lemma In_map_inv (T U: Set) (f: T -> U) (l: L T) (y: U): List.In y (map f l) -> exists x, f x = y /\ List.In x l.
Proof. hammer_hook "ne_list" "ne_list.In_map_inv". induction l; simpl; intros; destruct H; firstorder. Qed.

Lemma length_ne_0 (A: Set) (l: L A): List.length l <> 0.
Proof with auto with arith. hammer_hook "ne_list" "ne_list.length_ne_0". destruct l; simpl... Qed.

Lemma map_length (A B: Set) (f: A -> B) (l: L A): List.length (map f l) = List.length l.
Proof with auto. hammer_hook "ne_list" "ne_list.map_length". induction l... simpl. rewrite IHl... Qed.

Lemma map_map (A B C: Set) (g: A -> B) (f: B -> C) (l: L A):
map f (map g l) = map (f ∘ g) l.
Proof with auto. hammer_hook "ne_list" "ne_list.map_map". induction l... simpl. rewrite IHl... Qed.

Lemma In_round_tripped_head (T: Set) (x: T) l: List.In x (from_plain x l).
Proof with auto. hammer_hook "ne_list" "ne_list.In_round_tripped_head". intros. rewrite round_trip. left... Qed.

Hint Immediate In_one.
Hint Immediate In_cons_head.
Hint Immediate head_in_self.
Hint Immediate In_round_tripped_head.

Fixpoint from_vec (A: Set) n: Vector.t A (S n) -> L A :=
match n return Vector.t A (S n) -> L A with
| 0 => fun v => one (vec.head v)
| _ => fun v => cons (vec.head v) (from_vec (vec.tail v))
end.

Lemma from_vec_to_plain (A: Set) n (v: Vector.t A (S n)): to_plain (from_vec v) = vec.to_list v.
Proof with reflexivity. hammer_hook "ne_list" "ne_list.from_vec_to_plain".
induction n; intros.
rewrite (vec.eq_cons v).
simpl.
rewrite (vec.eq_nil (vec.tail v))...
rewrite (vec.eq_cons v).
simpl.
rewrite IHn...
Qed.


Require Import Gappa_common.
Require Import Gappa_pred_nzr.

Lemma Rabs_def2b :
  forall x a : R, (Rabs x <= a)%R -> (-a <= x <= a)%R.
Proof.
intros x a H.
split.
case (Rcase_abs x); intros.
rewrite Rabs_left with (1 := r) in H.
rewrite <- (Ropp_involutive x).
apply Ropp_le_contravar with (1 := H).
apply Rle_trans with 0%R.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
apply Rle_trans with (2 := H).
apply Rabs_pos.
apply Rge_le with (1 := r).
apply Rle_trans with (2 := H).
apply RRle_abs.
Qed.

Theorem neg_a :
  forall x : R, forall zi : FF,
  ABS x zi ->
  ABS (-x) zi.
Proof.
intros x zi Hx.
unfold ABS.
now rewrite Rabs_Ropp.
Qed.

Definition bnd_of_abs_helper (xi zi : FF) :=
 Fle2 (lower zi) (Fopp2 (upper xi)) &&
 Fle2 (upper xi) (upper zi).

Theorem bnd_of_abs :
 forall x : R, forall xi zi : FF,
 ABS x xi ->
 bnd_of_abs_helper xi zi = true ->
 BND x zi.
Proof.
intros x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite Fopp2_correct. fold float2R. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
assert (H : (-(upper xi) <= x <= (upper xi))%R).
apply (Rabs_def2b _ _ (proj2 (proj2 Hx))).
split.
apply Rle_trans with (1 := H1) (2 := proj1 H).
apply Rle_trans with (1 := proj2 H) (2 := H2).
Qed.

Theorem abs_of_uabs :
 forall x : R, forall zi : FF,
 BND (Rabs x) zi ->
 Fpos0 (lower zi) = true ->
 ABS x zi.
Proof.
intros x zi Hx Hb.
generalize (Fpos0_correct _ Hb). clear Hb. intro H1.
exact (conj H1 Hx).
Qed.

Theorem uabs_of_abs :
 forall x : R, forall zi : FF,
 ABS x zi ->
 BND (Rabs x) zi.
Proof.
intros x zi (_,Hx2).
exact Hx2.
Qed.

Definition abs_of_bnd_p_helper (xi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (lower xi) &&
 Fle2 (upper xi) (upper zi).

Theorem abs_of_bnd_p :
 forall x : R, forall xi zi : FF,
 BND x xi ->
 abs_of_bnd_p_helper xi zi = true ->
 ABS x zi.
Proof.
intros x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
split.
exact H1.
apply IRabs_p with (2 := H2) (3 := H3) (4 := Hx).
apply Rle_trans with (1 := H1) (2 := H2).
Qed.

Definition abs_of_bnd_o_helper (xi zi : FF) :=
 Fis0 (lower zi) &&
 Fle2 (upper xi) (upper zi) &&
 Fle2 (Fopp2 (lower xi)) (upper zi).

Theorem abs_of_bnd_o :
 forall x : R, forall xi zi : FF,
 BND x xi ->
 abs_of_bnd_o_helper xi zi = true ->
 ABS x zi.
Proof.
intros x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fis0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. clear H3. intro H3.
split.
rewrite H1.
apply Rle_refl.
apply IRabs_o with (2 := H3) (3 := H2) (4 := Hx).
rewrite H1.
apply Rle_refl.
Qed.

Definition abs_of_bnd_n_helper (xi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (Fopp2 (upper xi)) &&
 Fle2 (Fopp2 (lower xi)) (upper zi).

Theorem abs_of_bnd_n :
 forall x : R, forall xi zi : FF,
 BND x xi ->
 abs_of_bnd_n_helper xi zi = true ->
 ABS x zi.
Proof.
intros x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fopp2_correct. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. clear H3. intro H3.
split.
exact H1.
apply IRabs_n with (2 := H2) (3 := H3) (4 := Hx).
apply Ropp_le_cancel.
rewrite Ropp_0.
apply Rle_trans with (1 := H1) (2 := H2).
Qed.

Definition abs_subset_helper (xi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (lower xi) &&
 Fle2 (upper xi) (upper zi).

Theorem abs_subset :
 forall x : R, forall xi zi : FF,
 ABS x xi ->
 abs_subset_helper xi zi = true ->
 ABS x zi.
Proof.
intros x xi zi (Hx1,Hx2) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
split.
exact H1.
apply IRsubset with (1 := H2) (2 := H3) (3 := Hx2).
Qed.

Definition intersect_aa_helper (xf yf : float2) (zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) yf &&
 Fle2 xf (upper zi).

Theorem intersect_aa :
 forall z : R, forall xi yi zi : FF,
 ABS z xi -> ABS z yi ->
 intersect_aa_helper (upper xi) (lower yi) zi = true ->
 ABS z zi.
Proof.
intros z xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
split.
exact H1.
split.
apply Rle_trans with (1 := H2) (2 := proj1 (proj2 Hy)).
apply Rle_trans with (1 := proj2 (proj2 Hx)) (2 := H3).
Qed.

Theorem absurd_intersect_aa :
 forall z : R, forall xi yi : FF,
 ABS z xi -> ABS z yi ->
 Flt2 (upper xi) (lower yi) = true ->
 False.
Proof.
intros z xi yi Hx Hy Hb.
generalize (Flt2_correct _ _ Hb). clear Hb. intro H.
generalize (Rle_lt_trans _ _ _ (proj2 (proj2 Hx)) H). clear H. intro H.
generalize (Rlt_le_trans _ _ _ H (proj1 (proj2 Hy))). clear H. intro H.
elim (Rlt_irrefl _ H).
Qed.

Definition mul_aa_helper (xi yi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (Fmult2 (lower xi) (lower yi)) &&
 Fle2 (Fmult2 (upper xi) (upper yi)) (upper zi).

Theorem mul_aa :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 mul_aa_helper xi yi zi = true ->
 ABS (x * y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fmult2_correct. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3.
unfold ABS in *.
split.
exact H1.
rewrite Rabs_mult.
apply IRmult_pp with (lower xi) (upper xi) (lower yi) (upper yi)
 ; intuition.
Qed.

Definition div_aa_helper (xi yi zi : FF) :=
 Fpos (lower yi) &&
 Fpos0 (lower zi) &&
 Fle2 (Fmult2 (upper yi) (lower zi)) (lower xi) &&
 Fle2 (upper xi) (Fmult2 (lower yi) (upper zi)).

Theorem div_aa :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 div_aa_helper xi yi zi = true ->
 ABS (x / y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H2).
generalize (Fpos_correct _ Hb). intro H1.
generalize (Fpos0_correct _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4.
split.
exact H2.
replace (Rabs (x / y)) with (Rabs x / Rabs y)%R.
unfold ABS in *.
apply IRdiv_pp with (lower xi) (upper xi) (lower yi) (upper yi)
 ; intuition.
unfold Rdiv.
rewrite Rabs_mult.
rewrite Rabs_Rinv.
apply refl_equal.
apply nzr_of_abs with (1 := Hy) (2 := Hb).
Qed.

Definition add_aa_p_helper (xi yi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (Fminus2 (lower xi) (upper yi)) &&
 Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi).

Theorem add_aa_p :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_p_helper xi yi zi = true ->
 ABS (x + y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fminus2_correct. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fplus2_correct. clear H3. intro H3.
split.
exact H1.
split.
apply Rle_trans with (Rabs x - Rabs y)%R.
apply Rle_trans with (1 := H2).
unfold Rminus.
apply Rplus_le_compat with (1 := proj1 (proj2 Hx)).
apply Ropp_le_contravar with (1 := proj2 (proj2 Hy)).
replace (x + y)%R with (x - -y)%R. 2: ring.
rewrite<- (Rabs_Ropp y).
apply Rabs_triang_inv.
apply Rle_trans with (Rabs x + Rabs y)%R.
apply Rabs_triang.
apply Rle_trans with (2 := H3).
apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)).
Qed.

Definition add_aa_o_helper (xi yi zi : FF) :=
 Fis0 (lower zi) &&
 Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi).

Theorem add_aa_o :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_o_helper xi yi zi = true ->
 ABS (x + y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fis0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fplus2_correct. clear H2. intro H2.
split.
auto with real.
split.
rewrite H1.
apply Rabs_pos.
apply Rle_trans with (Rabs x + Rabs y)%R.
apply Rabs_triang.
apply Rle_trans with (2 := H2).
apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)).
Qed.

Definition add_aa_n_helper (xi yi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (Fminus2 (lower yi) (upper xi)) &&
 Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi).

Theorem add_aa_n :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_n_helper xi yi zi = true ->
 ABS (x + y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fminus2_correct. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fplus2_correct. clear H3. intro H3.
split.
exact H1.
split.
apply Rle_trans with (Rabs y - Rabs x)%R.
apply Rle_trans with (1 := H2).
unfold Rminus.
apply Rplus_le_compat with (1 := proj1 (proj2 Hy)).
apply Ropp_le_contravar with (1 := proj2 (proj2 Hx)).
replace (x + y)%R with (y - -x)%R. 2: ring.
rewrite<- (Rabs_Ropp x).
apply Rabs_triang_inv.
apply Rle_trans with (Rabs x + Rabs y)%R.
apply Rabs_triang.
apply Rle_trans with (2 := H3).
apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)).
Qed.

Theorem sub_aa_p :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_p_helper xi yi zi = true ->
 ABS (x - y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
unfold Rminus.
apply add_aa_p with xi yi.
exact Hx.
unfold ABS.
rewrite Rabs_Ropp.
exact Hy.
exact Hb.
Qed.

Theorem sub_aa_o :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_o_helper xi yi zi = true ->
 ABS (x - y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
unfold Rminus.
apply add_aa_o with xi yi.
exact Hx.
unfold ABS.
rewrite Rabs_Ropp.
exact Hy.
exact Hb.
Qed.

Theorem sub_aa_n :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_n_helper xi yi zi = true ->
 ABS (x - y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
unfold Rminus.
apply add_aa_n with xi yi.
exact Hx.
unfold ABS.
rewrite Rabs_Ropp.
exact Hy.
exact Hb.
Qed.

Definition bnd_of_bnd_abs_p_helper (xi yi zi : FF) :=
 Flt2 (Fopp2 (lower yi)) (lower xi) &&
 Fle2 (lower zi) (lower yi) &&
 Fle2 (upper xi) (upper zi).

Theorem bnd_of_bnd_abs_p :
 forall x : R, forall xi yi zi : FF,
 BND x xi -> ABS x yi ->
 bnd_of_bnd_abs_p_helper xi yi zi = true ->
 BND x zi.
Proof.
intros x xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Flt2_correct _ _ H1). rewrite Fopp2_correct. fold float2R. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
case (Rcase_abs x) ; intro H.
unfold ABS in Hy.
rewrite (Rabs_left _ H) in Hy.
elim (Rlt_not_le (lower xi) x). 2: exact (proj1 Hx).
apply Rle_lt_trans with (2 := H1).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
exact (proj1 (proj2 Hy)).
unfold ABS in Hy.
rewrite (Rabs_right _ H) in Hy.
split.
apply Rle_trans with (1 := H2) (2 := proj1 (proj2 Hy)).
apply Rle_trans with (1 := proj2 Hx) (2 := H3).
Qed.

Definition bnd_of_bnd_abs_n_helper (xi yi zi : FF) :=
 Flt2 (upper xi) (lower yi) &&
 Fle2 (lower zi) (lower xi) &&
 Fle2 (Fopp2 (lower yi)) (upper zi).

Theorem bnd_of_bnd_abs_n :
 forall x : R, forall xi yi zi : FF,
 BND x xi -> ABS x yi ->
 bnd_of_bnd_abs_n_helper xi yi zi = true ->
 BND x zi.
Proof.
intros x xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Flt2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. fold float2R. clear H3. intro H3.
case (Rcase_abs x) ; intro H.
unfold ABS in Hy.
rewrite (Rabs_left _ H) in Hy.
split.
apply Rle_trans with (1 := H2) (2 := proj1 Hx).
apply Rle_trans with (2 := H3).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
exact (proj1 (proj2 Hy)).
unfold ABS in Hy.
rewrite (Rabs_right _ H) in Hy.
elim (Rlt_not_le x (upper xi)). 2: exact (proj2 Hx).
apply Rlt_le_trans with (1 := H1) (2 := proj1 (proj2 Hy)).
Qed.


(* Exercise 3: Definiți o funcție care returnează ziua următoare. (0.25 puncte) *)

(* Define the 'Day' data type. *)

Inductive Day :=

  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday
  | Sunday.

(* Define the 'nextDay' function. *)

Definition nextDay (currentDay : Day) : Day :=

  match currentDay with

    | Monday => Tuesday
    | Tuesday => Wednesday
    | Wednesday => Thursday
    | Thursday => Friday
    | Friday => Saturday
    | Saturday => Sunday
    | Sunday => Monday

  end.

(* Test the 'nextDay' function. *)

Compute nextDay Monday.
Compute nextDay Tuesday.
Compute nextDay Wednesday.
Compute nextDay Thursday.
Compute nextDay Friday.
Compute nextDay Saturday.
Compute nextDay Sunday.


(* BOL Derivation Calculus *)

From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import bol.
Require Import fol.
Require Import boltofol.

(* for dependent induction *)
Require Import Coq.Program.Equality.

Reserved Notation "Gamma '|-' f" (at level 65).

Definition context (declType: Type) (formulaType: Type) := ((declType -> Prop) * (formulaType -> Prop))%type.
Definition emptyContext {D F} : context D F := (fun _ => False, fun _ => False).

Definition bolContext := context bolDecl bolFormula.

Definition ctxDeclCons {declType formulaType} ctx d: context declType formulaType := match ctx with
| (decls, formulae) => (fun e => (decls d) \/ d = e, formulae)
end.

Definition ctxFormulaCons {declType formulaType} ctx f: context declType formulaType  := match ctx with
| (decls, formulae) => (decls, fun g => (formulae g) \/ g = f)
end.

Notation "ctx ',,' f" := (ctxFormulaCons ctx f) (at level 64).
Notation "ctx '+++' f" := (ctxDeclCons ctx f) (at level 64).

Open Scope string_scope.

Inductive fresh: bolContext -> bolID -> Prop :=
  | freshEmpty: forall id, fresh emptyContext id
  | freshDecl: forall ctx id decl,
        fresh ctx id
     -> ~(bolIdEq id (bolDeclId decl))
     -> fresh (ctx +++ decl) id.

(* Definition generateFreshID (ctx: bolContext) -> bolID := ??? *)

Inductive bolDerivable : bolContext -> bolFormula -> Prop :=
  | ax: forall (ctx: bolContext) f,
      snd ctx f -> ctx |- f

  | eqIntro: forall ctx c d i j,
         fresh ctx i
      -> fresh ctx j
      -> ctx,, i IS-A c |- i IS-A d
      -> ctx,, j IS-A d |- j IS-A c
      -> ctx |- c == d

  | eqElim: forall (ctx: bolContext) (F: bolConcept -> bolFormula) c d,
      ctx |- (F c) -> ctx |- c == d -> ctx |- (F d)

  | subIntro: forall ctx c d e,
      ctx |- c <<= d -> ctx |- d <<= e -> ctx |- c <<= e
  | subElim: forall ctx ind c d,
      ctx |- c <<= d -> ctx |- ind IS-A c -> ctx |- ind IS-A d

  | conUnionIntroL: forall ctx ind c d,
      ctx |- ind IS-A c -> ctx |- ind IS-A (c U d)
  | conUnionIntroR: forall ctx ind c d,
      ctx |- ind IS-A d -> ctx |- ind IS-A (c U d)
  | conUnionElim: forall ctx ind c d f,
         ctx |- ind IS-A (c U d)
      -> ctx,, ind IS-A c |- f
      -> ctx,, ind IS-A d |- f
      -> ctx |- f

  | conIntersectIntro: forall ctx ind c d,
      ctx |- ind IS-A c -> ctx |- ind IS-A d -> ctx |- ind IS-A (c C d)
  | conIntersectElimL: forall ctx ind c d,
      ctx |- ind IS-A (c C d) -> ctx |- ind IS-A c
  | conIntersectElimR: forall ctx ind c d,
      ctx |- ind IS-A (c C d) -> ctx |- ind IS-A d

  | relUnionIntroL: forall ctx i j R1 R2,
      ctx |- i <.R1.> j -> ctx |- i <.R1 u R2.> j
  | relUnionIntroR: forall ctx i j R1 R2,
      ctx |- i <.R2.> j -> ctx |- i <.R1 u R2.> j
  | relUnionElim: forall ctx i j R1 R2 f,
         ctx |- i <.R1 u R2.> j
      -> ctx,, i <.R1.> j |- f
      -> ctx,, i <.R2.> j |- f
      -> ctx |- f

  | relInvIntro: forall ctx i j R,
      ctx |- i <.R.> j -> ctx |- j <.inv R.> i
  | relInvElim: forall ctx i j R,
      ctx |- i <.inv R.> j -> ctx |- j <.R.> i

  | relCompIntro: forall ctx i j k R1 R2,
      ctx |- i <.R1.> j -> ctx |- j <.R2.> k -> ctx |- i <.R1;R2.> k
  | relCompElim: forall ctx i j k R1 R2 f,
         ctx |- i <.R1;R2.> k
      -> fresh ctx j
      -> ctx +++ (IND j),, i <.R1.> j,, j <.R2.> k |- f
      -> ctx |- f

  | relDomIntro: forall ctx i j R,
      ctx |- i <.R.> j -> ctx |- i IS-A (dom R)
  | relDomElim: forall ctx i j R f,
        ctx |- i IS-A (dom R)
     -> fresh ctx j
     -> ctx +++ IND j,, (i <.R.> j) |- f
     -> ctx |- f

  | relCodIntro: forall ctx i j R,
      ctx |- i <.R.> j -> ctx |- j IS-A (cod R)
  | relCodElim: forall ctx i (j: bolID) R f,
         ctx |- j IS-A (dom R)
      -> fresh ctx j
      -> ctx +++ IND j,, (i <.R.> j) |- f
      -> ctx |- f

  | relForallIntro: forall ctx c R i j,
         fresh ctx j
      -> ctx +++ IND j,, i <.R.> j |- j IS-A c
      -> ctx |- j IS-A (c forall R)
  | relForallElim: forall ctx c R i j,
         ctx |- i IS-A (c forall R)
      -> ctx |- i <.R.> j
      -> ctx |- j IS-A c

  | relExistsIntro: forall ctx c R i j,
         ctx |- i <.R.> j
      -> ctx |- j IS-A c
      -> ctx |- i IS-A (c exists R)
  | relExistsElim: forall ctx c R i j f,
         ctx |- i IS-A (c exists R)
      -> fresh ctx j
      -> ctx +++ IND j,, i <.R.> j,, j IS-A c |- f
      -> ctx |- f

  where "Gamma '|-' f" := (bolDerivable Gamma f).

Require Import String.
Require Import Strings.String.
Open Scope string_scope.

Theorem thm: emptyContext,, "i" IS-A "C",, ("C" <<= "D") |- ("i" IS-A "D").
Proof.
  apply: subElim.
  - apply: ax. simpl.
    by apply: or_intror.
  - apply: ax. simpl.
    by apply: or_introl; apply: or_intror.
Qed.

Lemma doubleInvEquiv: forall ctx i R j, ctx |- i <.inv (inv R).> j <-> ctx |- i <.R.> j.
Proof.
  move => ctx i R j.
  split => [H|H].
  - by do 2! apply: relInvElim.
  - by do 2! apply: relInvIntro.
Qed.

Definition isContextSubset {declType formType: Type} (ctx ctx': context declType formType) := (forall d, ctx.1 d -> ctx'.1 d) /\ (forall f, ctx.2 f -> ctx'.2 f).

Lemma largerContext: forall ctx ctx' f, isContextSubset ctx ctx' -> ctx |- f -> ctx' |- f.
Proof.
  move => ctx ctx' f Hsubset der.
  elim: der f Hsubset ctx'.
  -
  induction der => //.
  - admit.
  -
  remember ctx in der.
  remember f in der.
  elim: der => //.
  -
  dependent induction der => //.
  - by apply: ax; apply: (snd Hsubset).
  - admit.
  - admit.
  - apply: subIntro.
    * by apply: IHder1.
    * by apply: IHder2.
  - apply: subElim.
    * by apply: IHder1.
    * by apply: IHder2.
  - (* ... *)
Admitted.

Create HintDb bolcalc.
Hint Immediate largerContext : bolcalc.

Lemma trivialContextSubset {declType formType: Type}: forall (ctx: context declType formType) f, isContextSubset ctx (ctx,, f).
Proof.
Admitted.

Hint Immediate trivialContextSubset : bolcalc.

Lemma trivialAx: forall ctx f, ctx,, f |- f.
Proof.
  move => ctx f.
  apply: ax.
  case: ctx; simpl.
  auto.
Qed.

Hint Immediate trivialAx : bolcalc.

Lemma subsetAsymmetry: forall ctx c d, ctx |- c <<= d -> ctx |- d <<= c -> ctx |- c == d.
Proof.
  move => ctx c d H J.
  apply: eqIntro.
  - admit.
  - admit.
  - apply: subElim.
    + apply: largerContext => //.
      * auto with bolcalc.
      * exact H.
    + apply: subElim.
      * apply: largerContext; auto with bolcalc; exact J.
      * apply: subElim.
        apply: largerContext; auto with bolcalc; exact H.
        auto with bolcalc.
  - apply: subElim.
    + apply: largerContext => //.
      * auto with bolcalc.
      * exact J.
    + apply: subElim.
      * apply: largerContext; auto with bolcalc; exact H.
      * apply: subElim.
        apply: largerContext; auto with bolcalc; exact J.
        auto with bolcalc.
Admitted.

Definition folContext := context folDecl folFormula.

Reserved Notation "Gamma '|--' f" (at level 65).

Inductive folFresh: folContext -> string -> Prop :=.

Fixpoint folSubstituteInTerm (v: folVariable) (e: folTerm) (t: folTerm): folTerm := match t with
| fromVar w => if (string_dec v w) then e else t
| x => x
end.

Fixpoint folSubstitute (v: folVariable) (e: folTerm) (f: folFormula): folFormula := match f with
| folForall      w f => folForall w    (normalizeFormula f)
| folExists      w f => folExists w    (normalizeFormula f)
| folBiimpl      f g => folBiimpl      (folSubstitute v e f) (folSubstitute v e g)
| folImpl        f g => folImpl        (folSubstitute v e f) (folSubstitute v e g)
| folDisjunction f g => folDisjunction (folSubstitute v e f) (folSubstitute v e g)
| folConjunction f g => folConjunction (folSubstitute v e f) (folSubstitute v e g)
| folEq s t          => folEq (folSubstituteInTerm v e s) (folSubstituteInTerm v e t)
| folApp f arg       => folApp (folSubstitute v e f) (folSubstituteInTerm v e arg)
| folLam _           => dummyFormula
| _                  => f
end.

Inductive folDerivable : folContext -> folFormula -> Prop :=
  | folAx: forall (ctx: folContext) f,
      snd ctx f -> ctx |-- f

  | folForallIntro: forall ctx (F: folFormula) v,

      folFresh ctx v -> ctx +++ (folIndSymbol v) |-- F -> ctx |-- folForall v F

  | folForallElim: forall ctx F v ind,

      ctx |-- folForall v F -> ctx |-- folSubstitute v ind F

  | implIntro: forall ctx f g,
      ctx,, f |-- g -> ctx |-- folImpl f g
  | implElim: forall ctx f g,
      ctx |-- folImpl f g -> ctx |-- f -> ctx |-- g

  where "Gamma '|--' f" := (folDerivable Gamma f).

(*
Inductive folDecl :=
    | functionSymbol: string -> nat -> folDecl (* nat is arity *)
    | predicateSymbol: string -> nat -> folDecl
    | bolIndSymbol: string -> folDecl.

Definition folSignature := list folDecl.

Definition folVariable := string.
Inductive folTerm : Set :=
  | fromVar: folVariable -> folTerm
  | folIndRef: string -> folTerm
  | folFunctionApp: string -> list folTerm -> folTerm.

Inductive folFormula : Set :=
    | folForall: folVariable -> folFormula -> folFormula
    | folExists: folVariable -> folFormula -> folFormula
    | folBiimpl: folFormula -> folFormula -> folFormula
    | folImpl: folFormula -> folFormula -> folFormula
    | folDisjunction: folFormula -> folFormula -> folFormula
    | folConjunction: folFormula -> folFormula -> folFormula
    | folEq: folTerm -> folTerm -> folFormula
    | folApp: folFormula -> folTerm -> folFormula
    | folLam: (folTerm -> folFormula) -> folFormula
    | folPredicateRef: string -> folFormula.*)

Require Import Coq.Lists.List.

Definition ctxFromSystem {declType folType: Type} (system: (list declType) * (list folType)): context declType folType := match system with
| (sig, thy) => (fun _ => False, fun _ => False)
end.

Notation "'^' sys" := (ctxFromSystem sys) (at level 50).
Notation "'[[' ontology ']]'" := (folSemantics ontology) (at level 45).

Definition contextSemantics {declType formType: Type} (declSemantics: bolDecl -> declType) (formSemantics: bolFormula -> formType) : bolContext -> context declType formType := fun ctx => (
  (* exists preimages under semantics *)
  fun d => exists d', fst ctx d' /\ declSemantics d' = d,
  fun f => exists f', snd ctx f' /\ formSemantics f' = f
).

Definition folContextSemantics := @contextSemantics folDecl folFormula FOLSemantics.declSemantics FOLSemantics.formulaSemantics.

Definition contextConcat {declType formType: Type} (ctx1 ctx2: context declType formType): context declType formType := (
  fun d => (fst ctx1 d) \/ (fst ctx2 d),
  fun f => (snd ctx1 f) \/ (snd ctx2 f)
).

Notation "ctx1 ':::' ctx2" := (contextConcat ctx1 ctx2) (at level 60).

Lemma emptyCtxAtBeginning: forall {declType folType: Type} system f, ~(snd (@ctxFromSystem declType folType system) f).
Proof.
  intros.
  rewrite /ctxFromSystem.
  case: system.
  intros.
  by simpl.
Qed.

From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma concatWithInitialContext: forall (ontology: bolOntology) ctx f, (^ ontology ::: ctx).2 f -> ctx.2 f.
Proof.
  move => ontology ctx f H.
  assert (~(^ontology).2 f). apply: emptyCtxAtBeginning.
  case: H => //.
Qed.

Lemma l: forall (ontology: bolOntology) ctx i (R: bolID) j, ctx |- i <.R.> j <-> ctx.2 (i <.R.> j) \/ ctx.2 (j <.inv R.> i).
Proof.
  move => ontology ctx i R j.
  split.
  - move => der.
    dependent induction der => //.
    * admit.
    * admit.
    * admit.
    * admit.
    * right.

Theorem correctnessHelper: forall (ontology: bolOntology) ctx f,
  ^ontology ::: ctx |- f -> ^[[ontology]] ::: folContextSemantics ctx |-- FOLSemantics.formulaSemantics f.
  move => ontology ctx f derivation.
  dependent induction derivation => //.
  - apply: folAx.
    simpl.
    apply: or_intror.
    exists f.
    split => //.
    by apply: concatWithInitialContext; exact H.
  - admit.
  - simpl.
    apply: folForallIntro.
    * admit.
    * apply: implIntro.
      apply: implElim.
      Locate "~=".
      Print JMeq.
      admit.
    admit.
  - simpl in IHderivation1.
    simpl in IHderivation2.
    assert (^ [[ontology]] ::: folContextSemantics ctx
|-- folSubstitute "x" (FOLSemantics.bolIndSemantics ind) (folImpl (folApp (FOLSemantics.bolConSemantics c) "x") (folApp (FOLSemantics.bolConSemantics d) "x"))). {
      by apply: folForallElim; apply: IHderivation1.
    }
    simpl.
    simpl in H.
    Admitted.

(* probably true *)
Theorem correctness: forall (ontology: bolOntology) f,
  ^ontology |- f -> ^[[ontology]] |-- FOLSemantics.formulaSemantics f.
  move => ontology f.
Admitted.

(* probably not true *)
Theorem completeness: forall (ontology: bolOntology) f,
  ^[[ontology]] |-- FOLSemantics.formulaSemantics f -> ^ontology |- f.
Admitted.


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

Require Export Rbase.
Require Export Rfunctions.
Require Export R_sqrt.
Require Export Fourier.

Lemma def_sqrt : forall x : R, x >= 0 -> sqrt x * sqrt x = x.
intros.
apply sqrt_sqrt; auto with real.
Qed.

Lemma sqrt_pos : forall x : R, x >= 0 -> sqrt x >= 0.
intros.
apply Rle_ge.
apply sqrt_positivity; auto with real.
Qed.

Lemma Rmult_pos : forall x y : R, x >= 0 -> y >= 0 -> x * y >= 0.
intros.
apply Rle_ge.
apply Rmult_le_pos; auto with real.
Qed.

Lemma Rinv_le_pos : forall x : R, x <> 0 -> x >= 0 -> / x >= 0.
intros.
inversion H0.
apply Rle_ge.
apply Rlt_le; auto with real.
absurd (x = 0); auto.
Qed.

Lemma non_sqrt_zero : forall r : R, r >= 0 -> r <> 0 -> sqrt r <> 0.
unfold not in |- *; intros.
apply H0.
rewrite <- (def_sqrt r); auto.
rewrite H1; ring.
Qed.

Lemma Rinv_sqrt_pos : forall r : R, r <> 0 -> r >= 0 -> / sqrt r >= 0.
intros r H H0; try assumption.
apply Rinv_le_pos; auto.
apply non_sqrt_zero; auto.
apply sqrt_pos; auto.
Qed.
Hint Resolve non_sqrt_zero Rinv_sqrt_pos Rinv_le_pos Rmult_pos sqrt_pos
  def_sqrt: real.

Lemma resolution : forall x y : R, x >= 0 -> y >= 0 -> x * x = y * y -> x = y.
intros.
rewrite <- (def_sqrt x); auto with real.
rewrite <- (def_sqrt y); auto with real.
rewrite <- sqrt_mult; auto with real.
rewrite <- sqrt_mult; auto with real.
Qed.

Lemma inversion_sqr :
 forall x y : R, x >= 0 -> y >= 0 -> x = y * y -> y = sqrt x.
intros; symmetry  in |- *.
apply sqrt_lem_1; auto with real.
Qed.

Lemma sqrt_Rinv : forall x : R, x >= 0 -> x <> 0 -> sqrt (/ x) = / sqrt x.
intros.
inversion H.
replace (/ x) with (1 / x); auto with real.
rewrite sqrt_div; auto with real.
rewrite sqrt_1.
replace (1 / sqrt x) with (1 * / sqrt x); auto with real.
replace (1 / x) with (1 * / x); auto with real.
absurd (x = 0); auto.
Qed.

Lemma resolution2 :
 forall x y x' y' : R, x <> 0 -> x = y -> x * x' = y * y' -> x' = y'.
intros.
cut (y <> 0); intros.
replace x' with (/ x * x * x').
replace (/ x * x * x') with (/ x * (x * x')).
rewrite H1; rewrite H0.
replace (/ y * (y * y')) with (/ y * y * y').
replace (/ y * y) with 1.
ring.
auto with real.
ring.
ring.
replace (/ x * x) with 1.
ring.
auto with real.
rewrite <- H0; auto.
Qed.

Lemma deux_demi : 2 * / 2 = 1.
cut (2 <> 0); intros.
auto with real.
try discrR.
Qed.
Hint Resolve deux_demi: real.

Lemma deux_demi_a : forall a : R, a = / 2 * a + / 2 * a.
intros.
replace (/ 2 * a + / 2 * a) with (2 * / 2 * a).
replace (2 * / 2) with 1; auto with real.
ring.
Qed.
Hint Resolve deux_demi_a: real.

Lemma integre_not : forall a b : R, a <> 0 -> b <> 0 -> a * b <> 0.
intros.
apply Rmult_integral_contrapositive; (split; auto; try discrR).
Qed.
Hint Resolve integre_not: real.

Axiom lR14 : 1 + - / 2 = / 2.
Hint Resolve lR14: real.

Lemma lR15 : forall k : R, k * k = (1 + - k) * (1 + - k) -> k = / 2.
intros.
cut (2 <> 0); intros.
cut (2 * k = 1); intros.
replace k with (/ 2 * (2 * k)).
rewrite H1.
ring.
replace (/ 2 * (2 * k)) with (/ 2 * 2 * k).
replace (/ 2 * 2) with 1.
ring.
auto with real.
ring.
cut ((1 + - k) * (1 + - k) = - (2 * k) + (k * k + 1)); intros.
rewrite <- H in H1.
cut (2 * k = k * k + 1 + - (k * k)); intros.
rewrite H2.
ring.
pattern (k * k) at 2 in |- *.
rewrite H1.
replace (- (- (2 * k) + (k * k + 1))) with (2 * k + - (k * k + 1)).
ring.
ring.
ring.
discrR.
Qed.
Hint Resolve lR15: real.

Lemma lR20 : forall a : R, ~ a >= 0 -> -1 * a >= 0.
intros.
replace (-1 * a) with (- a).
cut (0 <= - a); intros.
auto with real.
apply Ropp_0_ge_le_contravar.
cut (0 > a); intros.
fourier.
apply Rfourier_not_le_gt; intros.
apply H; auto with real.
ring.
Qed.
Hint Resolve lR20: real.

Lemma non_produit_un : forall k k' : R, k' * k <> 1 -> 1 + - (k' * k) <> 0.
intros; red in |- *; intros.
apply H.
replace 1 with (1 + - (k' * k) + k' * k); [ idtac | ring ].
rewrite H0; ring.
Qed.
Hint Resolve non_produit_un: real.

Lemma opp_inv_demi_nonzero : - / 2 <> 0.
cut (-2 <> 0); intros.
replace (- / 2) with (/ -2); auto with real.
rewrite Ropp_inv_permute; auto with real.
discrR.
Qed.
Hint Resolve opp_inv_demi_nonzero: real.

Lemma nonzero_un : 1 <> 0.
discrR.
Qed.

Lemma nonzero_oppun : -1 <> 0.
discrR.
Qed.

Lemma nonzero_deux : 2 <> 0.
discrR.
Qed.

Lemma nonzero_oppdeux : -2 <> 0.
discrR.
Qed.

Lemma nonzero_invdeux : / 2 <> 0.
cut (2 <> 0); intros; auto with real.
discrR.
Qed.

Lemma nonzero_trois : 3 <> 0.
discrR.
Qed.

Lemma nonzero_opptrois : -3 <> 0.
discrR.
Qed.

Lemma nonzero_invtrois : / 3 <> 0.
cut (3 <> 0); intros; auto with real.
discrR.
Qed.
Hint Resolve nonzero_invtrois nonzero_opptrois nonzero_trois nonzero_invdeux
  nonzero_oppdeux nonzero_deux nonzero_oppun nonzero_un: real.

Lemma double_zero : forall a : R, 2 * a = 0 -> a = 0.
intros.
replace a with (/ 2 * (2 * a)); auto with real.
field.
Qed.

Lemma zero_double : forall a : R, a = 0 -> 2 * a = 0.
intuition.
Qed.
Hint Resolve double_zero zero_double: real.

Lemma nonzero_oppinvtrois : - / 3 <> 0.
cut (-3 <> 0); intros; auto with real.
Qed.

Lemma nonzero_oppinvdeux : - / 2 <> 0.
cut (-2 <> 0); intros; auto with real.
Qed.
Hint Resolve nonzero_oppinvtrois nonzero_oppinvdeux: real.

Lemma Rgt_inv : forall k : R, k > 0 -> / k > 0.
intros.
cut (k <> 0); intros; [ idtac | auto with real ].
cut (k >= 0); intros.
cut (/ k >= 0); intros.
2: apply Rinv_le_pos; auto.
elim H2; intros; auto.
absurd (/ k = 0); auto with real.
red in |- *.
left; try assumption.
Qed.
Hint Resolve Rgt_inv: real.

Definition R2 := 2.

Definition R4 := 2 + 2.
Hint Unfold R2 R4: real geo.


(*|
################################################
Destructing equality of dependent records in Coq
################################################

:Link: https://stackoverflow.com/q/54569749
|*)

(*|
Question
********

Given a dependent record type:

.. code-block:: coq

    Record FinPath : Type := mkPath { fp_head : S i;
                                      fp_tail : FinPathTail fp_head
                                    }.

and two objects of type ``Path`` that are equal, I'd like to infer
that their heads and tails are equal. The problem is that I quickly
get something of this form:

.. code-block:: coq

    fpH : {| path_head := fp_head fp; path_tail := fpt_to_pt (fp_tail fp) |} =
          {| path_head := fp_head fp'; path_tail := fpt_to_pt (fp_tail fp') |}

Using the injection tactic, I can infer that ``fp_head fp = fp_head
fp'`` and also this term:

.. code-block:: coq

    existT (fun path_head : S i => PathTail path_head) (fp_head fp)
           (fpt_to_pt (fp_tail fp)) =
    existT (fun path_head : S i => PathTail path_head) (fp_head fp')
           (fpt_to_pt (fp_tail fp'))

Assuming decidability of ``S i``, I'd normally then want to use
``inj_pair2_eq_dec`` but that doesn't apply in this case because
``fp_head fp`` and ``fp_head fp'`` aren't syntactically the same. I
also can't rewrite them to be the same because rewriting with
``fp_head fp' = fp_head fp`` would leave the right hand side
ill-typed.

How can I proceed from here? Is there some cleverer version of
``inj_pair2_eq_dec`` that somehow uses the (non-syntactic) base
equality rather than requiring the bases of the sigma types to be
equal?

**Edit:** Thinking about this a little harder, I realise that it
doesn't make sense to ask that the tails are equal (since they are of
different types). But is it possible to prove some form of Leibniz
equality between them based on ``eq_rect``?
|*)

(*|
Answer
******

Issues like these are why many prefer avoiding dependent types in Coq.
I'll answer your question in the case of the Coq sigma type ``{x : T &
S x}``, which can be generalized to other dependent records.

We can express the equality that the dependent component of the pair
should satisfy via a cast function:
|*)

Definition cast {T} (S : T -> Type) {a b : T} (p : a = b) : S a -> S b :=
  match p with eq_refl => fun a => a end.

Definition eq_sig T (S : T -> Type) (a b : T) x y
           (p : existT S a x = existT S b y) :
  {q : a = b & cast S q x = y} :=
  match p in _ = z return {q : a = projT1 z & cast S q x = projT2 z} with
  | eq_refl => existT _ eq_refl eq_refl
  end.

(*|
The ``cast`` function allows us to use an equality ``p : a = b`` to
cast from ``S a`` to ``S b``. The ``eq_sig`` lemma, which I've defined
through a proof term, says that given an equality ``p`` between two
dependent pairs ``existT S a x`` and ``existT S b y``, I can produce
another dependent pair containing:

- An equality ``q : a = b``, and
- a proof that ``x`` and ``y`` are equal *after casting*.

With a similar definition, we can provide a proof principle for
"inducting" on a proof of equality between dependent pairs:
|*)

Definition eq_sig_elim T (S : T -> Type) (a b : T) x y
           (p : existT S a x = existT S b y) :
  forall (R : forall c, S c -> Prop), R a x -> R b y :=
  match p in _ = z
        return forall (R : forall c, S c -> Prop), R a x -> R _ (projT2 z)
  with
  | eq_refl => fun R H => H
  end.

(*|
The shape of the lemma is similar to that of ``eq_sig``, but this time
it says that in the presence of such an equality we can prove an
arbitrary *dependent* predicate ``R b y`` provided a proof of ``R a
x``.

Using such dependent principles can be awkward. The challenge is
finding such an ``R`` that allows you to express your goal: in the
result type above, the type of the second argument of ``R`` is
parametric with respect to the first argument. In many cases of
interest, the first component of the second term, ``y``, is not a
variable, but has a specific shape, which might prevent a direct
generalization.
|*)


Require Import ListAux.
Lemma customstk1bound_push0 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_0 = i_0))/\(list_member  il_1 u_0)) -> (list_member  il_0 u_0)).
Proof. solve_push. Qed.

Lemma customstk1bound_push1 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_0 = i_0))/\(list_member  il_1 u_0)) -> (not (list_head  il_1 u_0))).
Proof. solve_push. Qed.

Lemma customstk1bound_push2 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_0))) -> (not (u_0 = i_0))).
Proof. solve_push. Qed.

Lemma customstk1bound_push3 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_0))) -> (not (list_member  il_0 u_0))).
Proof. solve_push. Qed.

Lemma customstk1bound_push4 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_0 u_0))/\(not (list_member  il_1 u_0))) -> (not (list_head  il_1 u_0))).
Proof. solve_push. Qed.


(* Coq defintions for HCOL operator language *)

Require Import Helix.Util.VecUtil.
Require Import Helix.Util.VecSetoid.
Require Import Helix.Util.Misc.
Require Import Helix.Util.FinNat.
Require Import Helix.HCOL.CarrierType.
Require Import Helix.HCOL.HCOLImpl.

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.Plus.
Require Import Coq.Program.Program.
Require Import Coq.Classes.Morphisms.

Require Import Helix.Tactics.HelixTactics.
Require Import Coq.Logic.FunctionalExtensionality.

(* CoRN MathClasses *)
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.orders.minmax MathClasses.interfaces.orders.
Require Import MathClasses.implementations.peano_naturals.

Require Import MathClasses.theory.setoids.

Import VectorNotations.
Open Scope vector_scope.

Section WithCarrierA.

  Context `{CAPROPS: CarrierProperties}.

  (* === HCOL operators === *)

  Section HCOL_Language.

    Class HOperator {i o:nat} (op: avector i -> avector o) :=
      op_proper :> Proper ((=) ==> (=)) op.

    Global Instance HOperator_Setoid_Morphism
           {i o op}
           `{H: HOperator i o op}: Setoid_Morphism op.
    Proof.
      split; typeclasses eauto.
    Qed.

    Lemma HOperator_functional_extensionality
          {m n: nat}
          `{HOperator m n f}
          `{HOperator m n g}:
      (∀ v, f v = g v) -> f = g.
    Proof.
      apply ext_equiv_applied_iff.
    Qed.

    Definition HPrepend {i n} (a:avector n)
      : avector i -> avector (n+i)
      := Vapp a.

    Definition HInfinityNorm {i}
      : avector i -> avector 1
      := Vectorize ∘ InfinityNorm.

    Definition HReduction {i}
               (f: CarrierA -> CarrierA -> CarrierA)
               (idv: CarrierA)
      : avector i -> avector 1
      := Vectorize ∘ (Reduction f idv).

    Definition HAppend {i n} (a:avector n)
      : avector i -> avector (i+n)
      := fun x => Vapp x a.

    Definition HVMinus {o}
      : avector (o+o) -> avector o
      := VMinus  ∘ (vector2pair o).

    Definition HBinOp {o}
               (f: FinNat o -> CarrierA -> CarrierA -> CarrierA)
      : avector (o+o) -> avector o
      :=  BinOp f ∘ (vector2pair o).

    Definition HEvalPolynomial {n} (a: avector n): avector 1 -> avector 1
      := Lst ∘ EvalPolynomial a ∘ Scalarize.

    Definition HMonomialEnumerator n
      : avector 1 -> avector (S n)
      := MonomialEnumerator n ∘ Scalarize.

    Definition HChebyshevDistance h
      : avector (h+h) -> avector 1
      := Lst ∘ ChebyshevDistance ∘ (vector2pair h).

    Definition HScalarProd {h}
      : avector (h+h) -> avector 1
      := Lst ∘ ScalarProd ∘ (vector2pair h).

    Definition HInduction (n:nat)
               (f: CarrierA -> CarrierA -> CarrierA)
               (initial: CarrierA)
      : avector 1 -> avector n
      := Induction n f initial ∘ Scalarize.

    Definition HInductor
               (n:nat)
               (f:CarrierA -> CarrierA -> CarrierA)
               (initial: CarrierA)
      : avector 1 -> avector 1
      := Lst ∘ Inductor n f initial ∘ Scalarize.

    Definition HPointwise
               {n: nat}
               (f: FinNat n -> CarrierA -> CarrierA)
               (x: avector n): avector n
      := Vbuild (fun j jd => f (mkFinNat jd) (Vnth x jd)).

    (* Special case of pointwise *)
    Definition HAtomic
               (f: CarrierA -> CarrierA)
               (x: avector 1)
      := [f (Vhead x)].

    Section HCOL_operators.

      Global Instance HPointwise_HOperator
             {n: nat}
             {f: FinNat n -> CarrierA -> CarrierA}
             `{pF: !Proper ((=) ==> (=) ==> (=)) f}:
        HOperator (@HPointwise n f).
      Proof.
        intros x y E.
        apply Vforall2_intro_nth.
        intros j jc.
        unfold HPointwise.
        setoid_rewrite Vbuild_nth.
        apply pF.
        - reflexivity.
        - apply Vnth_proper, E.
      Qed.

      Global Instance HAtomic_HOperator
             (f: CarrierA -> CarrierA)
             `{pF: !Proper ((=) ==> (=)) f}:
        HOperator (HAtomic f).
      Proof.
        intros x y E.
        unfold HAtomic.
        vec_index_equiv i ip.
        simpl.
        dep_destruct i.
        rewrite E.
        reflexivity.
        reflexivity.
      Qed.

      Global Instance HScalarProd_HOperator {n}:
        HOperator (@HScalarProd n).
      Proof.
        intros x y E.
        unfold HScalarProd.
        unfold compose, Lst.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HBinOp_HOperator {o}
             (f: FinNat o -> CarrierA -> CarrierA -> CarrierA)
             `{pF: !Proper ((=) ==> (=) ==> (=) ==> (=)) f}:
        HOperator (@HBinOp o f).
      Proof.
        intros x y E.
        unfold HBinOp.
        unfold compose, Lst, vector2pair.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HReduction_HOperator {i}
             (f: CarrierA -> CarrierA -> CarrierA)
             `{pF: !Proper ((=) ==> (=) ==> (=)) f}
             (idv: CarrierA):
        HOperator (@HReduction i f idv).
      Proof.
        intros x y E.
        unfold HReduction .
        unfold compose, Lst.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HEvalPolynomial_HOperator {n} (a: avector n):
        HOperator (@HEvalPolynomial n a).
      Proof.
        intros x y E.
        unfold HEvalPolynomial.
        unfold compose, Lst.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HPrepend_HOperator {i n} (a:avector n):
        HOperator (@HPrepend i n a).
      Proof.
        intros x y E.
        unfold HPrepend.
        unfold compose, Lst.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HMonomialEnumerator_HOperator n:
        HOperator (@HMonomialEnumerator n).
      Proof.
        intros x y E.
        unfold HMonomialEnumerator.
        unfold compose, Lst.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HInfinityNorm_HOperator n:
        HOperator (@HInfinityNorm n).
      Proof.
        intros x y E.
        unfold HInfinityNorm.
        unfold compose, Lst.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HInduction_HOperator {n:nat}
             (f: CarrierA -> CarrierA -> CarrierA)
             `{pF: !Proper ((=) ==> (=) ==> (=)) f}
             (initial: CarrierA):
        HOperator (HInduction n f initial).
      Proof.
        intros x y E.
        unfold HInduction.
        unfold compose, Lst.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HInductor_HOperator
             (n:nat)
             (f:CarrierA -> CarrierA -> CarrierA)
             `{pF: !Proper ((=) ==> (=) ==> (=)) f}
             (initial: CarrierA):
        HOperator (HInductor n f initial).
      Proof.
        intros x y E.
        unfold HInductor.
        unfold compose, Lst.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HChebyshevDistance_HOperator h:
        HOperator (HChebyshevDistance h).
      Proof.
        intros x y E.
        unfold HChebyshevDistance.
        unfold compose, Lst, vector2pair.
        apply Vcons_single_elim.
        rewrite E.
        reflexivity.
      Qed.

      Global Instance HVMinus_HOperator h:
        HOperator (@HVMinus h).
      Proof.
        intros x y E.
        unfold HVMinus.
        unfold compose, Lst, vector2pair.
        rewrite E.
        reflexivity.
      Qed.

    End HCOL_operators.
  End HCOL_Language.

  (* We forced to use this instead of usual 'reflexivity' tactics, as currently there is no way in Coq to define 'Reflexive' class instance constraining 'ext_equiv' function arguments by HOperator class *)
  Ltac HOperator_reflexivity := eapply HOperator_functional_extensionality; reflexivity.

  Definition mult_by_nth
             {n:nat}
             (a: vector CarrierA n)
    : FinNat n -> CarrierA -> CarrierA :=
    fun jf x => mult x (Vnth a (proj2_sig jf)).

  Section IgnoreIndex_wrapper.

    (* Wrapper to swap index parameter for HPointwise kernel with given value. 1 stands for arity of 'f'.
  Also restricts domain of 1st natural number to 1 *)
    Definition Fin1SwapIndex {A:Type} {n:nat} (i:FinNat n) (f:FinNat n->A->A) : FinNat 1->A->A := const (f i).

    Global Instance Fin1SwapIndex_proper `{Equiv A} {n:nat}:
      Proper ((=) ==> ((=) ==> (=) ==> (=)) ==> (=) ==> (=) ==> (=)) (@Fin1SwapIndex A n).
    Proof.
      simpl_relation.
      apply H1; assumption.
    Qed.

    (* Wrapper to swap index parameter for HBinOp kernel with given value. 2 stands for arity of 'f'.
  Also restricts domain of 1st natural number to 1 *)
    Definition Fin1SwapIndex2 {A:Type} {n:nat} (i:FinNat n) (f:FinNat n->A->A->A) : FinNat 1->A->A->A := const (f i).

    Global Instance Fin1SwapIndex2_proper `{Equiv A} {n:nat}:
      Proper ((=) ==> ((=) ==> (=) ==> (=) ==> (=)) ==> (=) ==> (=) ==> (=) ==> (=)) (@Fin1SwapIndex2 A n).
    Proof.
      simpl_relation.
      apply H1; assumption.
    Qed.

    (* Wrapper to ignore index parameter for HBinOp kernel. 2 stands for arity of 'f' *)
    Definition IgnoreIndex2 {A B:Type} (f:A->A->A) := const (B:=B) f.

    Lemma IgnoreIndex2_ignores
          `{Equiv A}
          {B: Type}
          (f:A->A->A)
          `{f_mor: !Proper ((=) ==> (=) ==> (=)) f}
      : forall (i0 i1:B),
        (IgnoreIndex2 f) i0 = (IgnoreIndex2 f) i1.
    Proof.
      intros.
      unfold IgnoreIndex2.
      apply f_mor.
    Qed.

    Global Instance IgnoreIndex2_proper `{Ae:Equiv A} `{Ab:Equiv B}:
      (Proper (((=) ==> (=)) ==> (=) ==> (=) ==> (=) ==> (=)) (@IgnoreIndex2 A B)).
    Proof.
      simpl_relation.
      unfold IgnoreIndex2.
      apply H; assumption.
    Qed.

    (* Wrapper to ignore index parameter for HPointwise kernel. *)
    Definition IgnoreIndex {A:Type} {n:nat} (f:A->A) := const (B:=@sig nat (fun i : nat => @lt nat peano_naturals.nat_lt i n)) f.

    Global Instance IgnoredIndex_proper `{Ae:Equiv A} {n:nat}:
      (Proper
         (((=) ==> (=)) ==> (=) ==> (=) ==> (=)) (@IgnoreIndex A n)).
    Proof.
      simpl_relation.
      unfold IgnoreIndex.
      apply H.
      assumption.
    Qed.

  End IgnoreIndex_wrapper.

  Section HCOL_Operator_Lemmas.

    Lemma HPointwise_nth
          {n: nat}
          (f: FinNat n -> CarrierA -> CarrierA)
          {j:nat} {jc:j<n}
          (x: avector n):
      Vnth (HPointwise f x) jc ≡ f (j ↾ jc) (Vnth x jc).
    Proof.
      unfold HPointwise.
      rewrite Vbuild_nth.
      reflexivity.
    Qed.

    Lemma HBinOp_nth
          {o}
          {f: FinNat o -> CarrierA -> CarrierA -> CarrierA}
          {v: avector (o+o)}
          {j:nat}
          (jc: j<o)
          (jc1:j<o+o)
          (jc2: (j+o)<o+o)
      :
        Vnth (@HBinOp o f v) jc ≡ f (mkFinNat jc) (Vnth v jc1) (Vnth v jc2).
    Proof.
      unfold HBinOp, compose, vector2pair, HBinOp, HCOLImpl.BinOp.

      break_let.

      replace t with (fst (Vbreak v)) by crush.
      replace t0 with (snd (Vbreak v)) by crush.
      clear Heqp.

      rewrite Vnth_Vmap2SigIndexed.
      f_equiv.

      rewrite Vnth_fst_Vbreak with (jc3:=jc1); reflexivity.
      rewrite Vnth_snd_Vbreak with (jc3:=jc2); reflexivity.
    Qed.

    Lemma HReduction_nil
          (f: CarrierA -> CarrierA -> CarrierA)
          (idv: CarrierA):
      HReduction f idv [] ≡ [idv].
    Proof.
      reflexivity.
    Qed.

  End HCOL_Operator_Lemmas.

End WithCarrierA.

(* re-declare outside Section *)
Ltac HOperator_reflexivity := eapply HOperator_functional_extensionality; reflexivity.


Set Universe Polymorphism.

Inductive BushF (F : Type -> Type) (A : Type) : Type :=
| Leaf : BushF F A
| Node : A -> F (F A) -> BushF F A.

Arguments Leaf {F A}.
Arguments Node {F A} _ _.

Unset Positivity Checking.
CoInductive CoBush (A : Type) : Type :=
{
  Out : BushF CoBush A;
}.
Set Positivity Checking.

Arguments Out {A} _.

Unset Guard Checking.
CoFixpoint map {A B : Type} (f : A -> B) (b : CoBush A) : CoBush B :=
{|
  Out :=
    match Out b with
    | Leaf => Leaf
    | Node x b' => Node (f x) (map (map f) b')
    end;
|}.
Set Guard Checking.


From Coq Require Import ssreflect ssrfun ssrbool.

From stdpp Require Import base tactics sets.

From MatchingLogic.Utils
Require Import
    extralibrary
    stdpp_ext
.

From MatchingLogic
Require Import
    Signature
    Pattern
    ApplicationContext
    Substitution
.

Import MatchingLogic.Substitution.Notations.

Section with_signature.
  Open Scope ml_scope.
  Context {Σ : Signature}.

  Lemma free_evar_subst_subst_ctx_independent AC ϕ Xfr1 Xfr2:
  Xfr1 ∉ free_evars_ctx AC ->
  Xfr2 ∉ free_evars_ctx AC ->
  (subst_ctx AC (patt_free_evar Xfr1))^[[evar: Xfr1 ↦ ϕ]] =
  (subst_ctx AC (patt_free_evar Xfr2))^[[evar: Xfr2 ↦ ϕ]].
Proof.
  intros HXfr1 HXfr2.
  induction AC.
  - simpl.
    destruct (decide (Xfr1 = Xfr1)), (decide (Xfr2 = Xfr2)); simpl; try contradiction.
    reflexivity.
  - simpl in HXfr1. simpl in HXfr2.
    feed specialize IHAC.
    { set_solver. }
    { set_solver. }
    simpl. rewrite IHAC.
    rewrite [p^[[evar: Xfr1 ↦ ϕ]]]free_evar_subst_no_occurrence.
    { set_solver. }
    rewrite [p^[[evar: Xfr2 ↦ ϕ]]]free_evar_subst_no_occurrence.
    { set_solver. }
    reflexivity.
  - simpl in HXfr1. simpl in HXfr2.
    feed specialize IHAC.
    { set_solver. }
    { set_solver. }
    simpl. rewrite IHAC.
    rewrite [p^[[evar: Xfr1 ↦ ϕ]]]free_evar_subst_no_occurrence.
    { set_solver. }
    rewrite [p^[[evar: Xfr2 ↦ ϕ]]]free_evar_subst_no_occurrence.
    { set_solver. }
    reflexivity.
Qed.

End with_signature.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Syntax.
Require Import bedrock2.Semantics.
Require Import bedrock2.FE310CSemantics.
Require Import coqutil.Word.Naive.
Require Import coqutil.Map.SortedListWord.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ZRange.
Import API.Compilers.

Require Import Crypto.Util.Notations.
Import Types.Notations ListNotations.
Local Open Scope Z_scope.
Local Open Scope string_scope.

(* Declares default parameters for the bedrock2 backend specific to systems with
a 32-bit word size. *)

Section Defaults_32.
  Definition machine_wordsize := 32.

  Let wordsize_bytes := Eval vm_compute in (machine_wordsize / 8)%Z.

  Instance default_parameters : Types.parameters
    (word := Naive.word32)
    (mem:=SortedListWord.map _ _)
    (varname_gen := default_varname_gen)
    (error := expr.var Defaults.ERROR)
    := tt.
  Instance default_parameters_ok : Types.ok.
  Proof. constructor; try exact _; try apply prefix_name_gen_unique. Qed.
End Defaults_32.

Module Notations.
  Notation "'uint32,uint32'" := (ident.Literal
                                   (r[0 ~> 4294967295]%zrange,
                                    r[0 ~> 4294967295]%zrange)%core) : expr_scope.
  Notation "'uint32'" :=
    (ident.Literal (t:=Compilers.zrange) r[0 ~> 4294967295]%zrange) : expr_scope.
End Notations.


(**
* Partial combinatory algebra based on normal KS-terms
*)

Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Relations.Operators_Properties.
Require Import Coq.Relations.Relation_Operators.

Require Import fin.
Require Import ksrewriting.
Require Import pas.
Require Import pca.
Require Import rewriting.

Import KS_RW.
Import KS_RW.NOTATIONS.
Import KS_RW.THMS.
Import PAS.NOTATIONS.
Import PCA.NOTATIONS.

Local Open Scope PAS.
Local Open Scope KS_RW.

Module NORMAL_TERM_PCA.

  (**
  ** Definitions
  *)

  Definition normalTerm := {t : term | StrictlyNormal t}.

  Definition K : normalTerm := exist _ _ kStrictlyNormal.
  Definition S : normalTerm := exist _ _ sStrictlyNormal.

  Definition normalTermToTerm (T : normalTerm) : term := proj1_sig T.
  Local Coercion normalTermToTerm : normalTerm >-> term.

  Definition NormalTermEq (U V : normalTerm) := (U : term) = (V : term).

  Instance normalTermEqEquivalence : Equivalence NormalTermEq.
  Proof. unfold NormalTermEq. split; congruence. Qed.

  Instance normalTermSetoid : Setoid normalTerm := {equiv := NormalTermEq}.

  Definition Appl (U V W : normalTerm) : Prop := U⋅V >>* W.

  (**
  ** Theorems
  *)

  Module Type THMS_SIG.

    Declare Instance pas : PAS.Pas normalTermSetoid Appl.

    Declare Instance pca : PCA.Pca pas K S.

    Axiom nonTriviality : PCA.NonTrivial pca.

    Axiom normalTermDenotation : forall (T : normalTerm), §T ≃ &T.

    Axiom termDenotation :
      forall (U : term) (V : normalTerm), §U ≃ &V <-> U >>* V.

  End THMS_SIG.

  (**
  ** Proofs
  *)

  Module THMS : THMS_SIG.

    Instance pas : PAS.Pas normalTermSetoid Appl.
    Proof.
      split.
      - unfold Appl. congruence.
      - unfold Appl.
        intros [U HU] [V HV] [W HW] [W' HW'] H H'. simpl in *.
        unfold NormalTermEq. simpl.
        eapply strictNormalFormsUnique; unfold SNF; eauto.
    Qed.

    Fixpoint termToClosedPasTerm (T : term) : PAS.term 0 :=
    match T with
    | KS_RW.K   => &K
    | KS_RW.S   => &S
    | U⋅V       => termToClosedPasTerm U * termToClosedPasTerm V
    end.
    Local Notation "$ t" := (termToClosedPasTerm t) (at level 6).

    Lemma termDenotation' (U : term) (V : normalTerm) :
      $(U) ≃ &V <-> U >>* V.
    Proof.
      revert V. induction U as [ | | U IHU V IHV]; intro T.
      - simpl.
        assert (&K ≃ &T <-> K == T) as H. {
          split; intro H.
          - apply PAS.THMS.constInjective. exact H.
          - rewrite H. reflexivity.
        }
        rewrite H. clear H. simpl. unfold NormalTermEq. split; intro H.
        + rewrite <- H. simpl. apply rt_refl.
        + destruct T as [T HT]. simpl in *.
          apply strictlyNormalEagerReduction.
          * apply kStrictlyNormal.
          * exact H.
      - simpl.
        assert (&S ≃ &T <-> S == T) as H. {
          split; intro H.
          - apply PAS.THMS.constInjective. exact H.
          - rewrite H. reflexivity.
        }
        rewrite H. clear H. simpl. unfold NormalTermEq. split; intro H.
        + rewrite <- H. simpl. apply rt_refl.
        + destruct T as [T HT]. simpl in *.
          apply strictlyNormalEagerReduction.
          * apply sStrictlyNormal.
          * exact H.
      - split; intro H.
        + simpl in H. apply PAS.THMS.correctness1 in H.
          destruct H as [U' [V' [HU [HV H]]]].
          unfold Appl in H.
          specialize (IHU U'). destruct IHU as [IHU _]. specialize (IHU HU).
          specialize (IHV V'). destruct IHV as [IHV _]. specialize (IHV HV).
          clear HU HV. apply rt_trans with (y := U'⋅V').
          * destruct U' as [U' HU'], V' as [V' HV']. simpl in *.
            apply eagerReductionPar; assumption.
          * exact H.
        + simpl.
          assert (SNF (U⋅V) T) as H'. {
            split.
            - exact H.
            - destruct T as [T HT]. exact HT.
          }
          destruct
            (strictNormalFormApplL _ _ _ H') as [U' [HU HU']],
            (strictNormalFormApplR _ _ _ H') as [V' [HV HV']].
          clear H'.
          set (U'' := exist _ _ HU' : normalTerm).
          set (V'' := exist _ _ HV' : normalTerm).
          specialize (IHU U''). destruct IHU as [_ IHU]. rewrite (IHU HU).
          specialize (IHV V''). destruct IHV as [_ IHV]. rewrite (IHV HV).
          rewrite PAS.THMS.correctness1'. unfold Appl. simpl.
          clear IHU IHV U'' V''.
          pose proof (eagerReductionPar _ _ _ _ HU' HU HV) as H'.
          destruct
            (RW.THMS.functionalDoubleReduction
              EagerlyOneStepReduces eagerOneStepReductionFunctional _ _ _ H H')
          as [H'' | H''];
          [ | exact H''].
          destruct T as [T HT]. simpl in *.
          apply (strictlyNormalEagerReduction _ _ HT) in H''. subst.
          apply rt_refl.
    Qed.

    Lemma normalTermDenotation' (T : normalTerm) : $(T) ≃ &T.
    Proof. setoid_rewrite termDenotation'. apply rt_refl. Qed.

    Lemma eagerlyReduces_closedPasTermEq (U V : term) :
      U >>* V -> $(U) ≃ $(V).
    Proof.
      intro H. rewrite PAS.THMS.correctness2.
      setoid_rewrite termDenotation'.
      intros [T HT]. simpl. split; intro H'.
      - destruct (eagerReductionConfluent _ _ _ H H') as [T' [H'' HT']].
        apply (strictlyNormalEagerReduction _ _ HT) in HT'.
        subst. exact H''.
      - eapply rt_trans; eauto.
    Qed.

    Instance pca : PCA.Pca pas K S.
    Proof.
      split.
      - intros U V.
        setoid_rewrite <- normalTermDenotation'.
        cutrewrite ($(K)*$(U)*$(V) = $(K⋅U⋅V)); [ | reflexivity].
        apply eagerlyReduces_closedPasTermEq.
        destruct U as [U HU], V as [V HV]. simpl.
        apply rt_step. unfold EagerlyOneStepReduces. simpl. rewrite HU, HV.
        reflexivity.
      - intros U V.
        setoid_rewrite <- normalTermDenotation'.
        cutrewrite ($(S)*$(U)*$(V) = $(S⋅U⋅V)); [ | reflexivity].
        unfold PAS.Denotes. setoid_rewrite termDenotation'.
        destruct U as [U HU], V as [V HV]. simpl.
        set (SUV := exist _ _ (suvStrictlyNormal _ _ HU HV) : normalTerm).
        exists SUV. apply rt_refl.
      - intros U V W.
        setoid_rewrite <- normalTermDenotation'.
        cutrewrite ($(S)*$(U)*$(V)*$(W) = $(S⋅U⋅V⋅W)); [ | reflexivity].
        cutrewrite ($(U)*$(W)*($(V)*$(W)) = $(U⋅W⋅(V⋅W))); [ | reflexivity].
        apply eagerlyReduces_closedPasTermEq.
        destruct U as [U HU], V as [V HV], W as [W HW]. simpl.
        apply rt_step.
        unfold EagerlyOneStepReduces. simpl. rewrite HU, HV, HW.
        reflexivity.
    Qed.

    Theorem nonTriviality : PCA.NonTrivial pca.
    Proof. exists K, S. intros H. discriminate H. Qed.

    Lemma equalMaps (T : term) : §T = $(T).
    Proof.
      induction T as [ | | U IHU V IHV].
      - reflexivity.
      - reflexivity.
      - simpl. rewrite IHU, IHV. reflexivity.
    Qed.

    Theorem normalTermDenotation (T : normalTerm) : §T ≃ &T.
    Proof. rewrite equalMaps. apply normalTermDenotation'. Qed.

    Theorem termDenotation (U : term) (V : normalTerm) : §U ≃ &V <-> U >>* V.
    Proof. rewrite equalMaps. apply termDenotation'. Qed.

  End THMS.

End NORMAL_TERM_PCA.

(**
** Coercions
*)

Coercion NORMAL_TERM_PCA.normalTermToTerm :
  NORMAL_TERM_PCA.normalTerm >-> KS_RW.term.


Require Import VST.msl.Extensionality.
Require Import VST.msl.sepalg.
Require Import RamifyCoq.msl_ext.abs_addr.
Require Import RamifyCoq.msl_ext.ramify_tactics.

Set Implicit Arguments.

Lemma join_identity {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
  forall a b c, join a b c -> identity a -> identity b -> identity c.
Proof.
  intros.
  hnf; intros x y ?.
  try_join b x bx.
  apply H1 in H3.
  apply H0 in H4.
  subst; auto.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.