(** * Hoare: Hoare Logic, Part I *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Imp.
Require Import Maps.

(** In the past couple of chapters, we've begun applying the
    mathematical tools developed in the first part of the course to
    studying the theory of a small programming language, Imp.

    - We defined a type of _abstract syntax trees_ for Imp, together
      with an _evaluation relation_ (a partial function on states)
      that specifies the _operational semantics_ of programs.

      The language we defined, though small, captures some of the key
      features of full-blown languages like C, C++, and Java,
      including the fundamental notion of mutable state and some
      common control structures.

    - We proved a number of _metatheoretic properties_ -- "meta" in
      the sense that they are properties of the language as a whole,
      rather than of particular programs in the language.  These
      included:

        - determinism of evaluation

        - equivalence of some different ways of writing down the
          definitions (e.g., functional and relational definitions of
          arithmetic expression evaluation)

        - guaranteed termination of certain classes of programs

        - correctness (in the sense of preserving meaning) of a number
          of useful program transformations

        - behavioral equivalence of programs (in the [Equiv] chapter).

    If we stopped here, we would already have something useful: a set
    of tools for defining and discussing programming languages and
    language features that are mathematically precise, flexible, and
    easy to work with, applied to a set of key properties.  All of
    these properties are things that language designers, compiler
    writers, and users might care about knowing.  Indeed, many of them
    are so fundamental to our understanding of the programming
    languages we deal with that we might not consciously recognize
    them as "theorems."  But properties that seem intuitively obvious
    can sometimes be quite subtle (sometimes also subtly wrong!).

    We'll return to the theme of metatheoretic properties of whole
    languages later in the book when we discuss _types_ and _type
    soundness_.  In this chapter, though, we turn to a different set
    of issues.

    Our goal is to carry out some simple examples of _program
    verification_ -- i.e., to use the precise definition of Imp to
    prove formally that particular programs satisfy particular
    specifications of their behavior.  We'll develop a reasoning
    system called _Floyd-Hoare Logic_ -- often shortened to just
    _Hoare Logic_ -- in which each of the syntactic constructs of Imp
    is equipped with a generic "proof rule" that can be used to reason
    compositionally about the correctness of programs involving this
    construct.

    Hoare Logic originated in the 1960s, and it continues to be the
    subject of intensive research right up to the present day.  It
    lies at the core of a multitude of tools that are being used in
    academia and industry to specify and verify real software
    systems.

    Hoare Logic combines two beautiful ideas: a natural way of
    writing down _specifications_ of programs, and a _compositional
    proof technique_ for proving that programs are correct with
    respect to such specifications -- where by "compositional" we mean
    that the structure of proofs directly mirrors the structure of the
    programs that they are about. *)

(** This chapter:
       - A systematic method for reasoning about the correctness of
         particular programs in Imp

    Goals:
      - a natural notation for _program specifications_ and
      - a _compositional_ proof technique for program correctness

    Plan:
      - assertions (Hoare Triples)
      - proof rules
      - decorated programs
      - loop invariants
      - examples *)

(* ################################################################# *)
(** * Assertions *)

(** To talk about specifications of programs, the first thing we
    need is a way of making _assertions_ about properties that hold at
    particular points during a program's execution -- i.e., claims
    about the current state of the memory when execution reaches that
    point.  Formally, an assertion is just a family of propositions
    indexed by a [state]. *)

Definition Assertion := state -> Prop.

(** **** Exercise: 1 star, optional (assertions)  *)
(** Paraphrase the following assertions in English (or your favorite
    natural language). *)

Module ExAssertions.
Definition as1 : Assertion := fun st => st X = 3.
Definition as2 : Assertion := fun st => st X <= st Y.
Definition as3 : Assertion :=
  fun st => st X = 3 \/ st X <= st Y.
Definition as4 : Assertion :=
  fun st => st Z * st Z <= st X /\
            ~ (((S (st Z)) * (S (st Z))) <= st X).
Definition as5 : Assertion := fun st => True.
Definition as6 : Assertion := fun st => False.
(* FILL IN HERE *)
End ExAssertions.
(** [] *)

(** This way of writing assertions can be a little bit heavy,
    for two reasons: (1) every single assertion that we ever write is
    going to begin with [fun st => ]; and (2) this state [st] is the
    only one that we ever use to look up variables in assertions (we
    will never need to talk about two different memory states at the
    same time).  For discussing examples informally, we'll adopt some
    simplifying conventions: we'll drop the initial [fun st =>], and
    we'll write just [X] to mean [st X].  Thus, instead of writing *)
(**

      fun st => (st Z) * (st Z) <= m /\
                ~ ((S (st Z)) * (S (st Z)) <= m)

    we'll write just

      Z * Z <= m /\ ~((S Z) * (S Z) <= m).
*)

(** This example also illustrates a convention that we'll use
    throughout the Hoare Logic chapters: in informal assertions,
    capital letters like {X], [Y], and [Z] are Imp variables, while
    lowercase letters like [x], [y], [m], and [n] are ordinary Coq
    variables (of type [nat]).  This is why, when translating from
    informal to formal, we replace [X] with [st X] but leave [m]
    alone. *)

(** Given two assertions [P] and [Q], we say that [P] _implies_ [Q],
    written [P ->> Q] (in ASCII, [P -][>][> Q]), if, whenever [P]
    holds in some state [st], [Q] also holds. *)

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

(** (The [hoare_spec_scope] annotation here tells Coq that this
    notation is not global but is intended to be used in particular
    contexts.  The [Open Scope] tells Coq that this file is one such
    context.) *)

(** We'll also want the "iff" variant of implication between
    assertions: *)

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* ################################################################# *)
(** * Hoare Triples *)

(** Next, we need a way of making formal claims about the
    behavior of commands. *)

(** In general, the behavior of a command is to transform one state to
    another, so it is natural to express claims about commands in
    terms of assertions that are true before and after the command
    executes:

      - "If command [c] is started in a state satisfying assertion
        [P], and if [c] eventually terminates in some final state,
        then this final state will satisfy the assertion [Q]."

    Such a claim is called a _Hoare Triple_.  The property [P] is
    called the _precondition_ of [c], while [Q] is the
    _postcondition_.  Formally: *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
     c / st \\ st'  ->
     P st  ->
     Q st'.

(** Since we'll be working a lot with Hoare triples, it's useful to
    have a compact notation:

       {{P}} c {{Q}}.
*)
(** (The traditional notation is [{P} c {Q}], but single braces
    are already used for other things in Coq.)  *)

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(** **** Exercise: 1 star, optional (triples)  *)
(** Paraphrase the following Hoare triples in English.

   1) {{True}} c {{X = 5}}

   2) {{X = m}} c {{X = m + 5)}}

   3) {{X <= Y}} c {{Y <= X}}

   4) {{True}} c {{False}}

   5) {{X = m}}
      c
      {{Y = real_fact m}}

   6) {{True}}
      c
      {{(Z * Z) <= m /\ ~ (((S Z) * (S Z)) <= m)}}
*)

(** [] *)

(** **** Exercise: 1 star, optional (valid_triples)  *)
(** Which of the following Hoare triples are _valid_ -- i.e., the
    claimed relation between [P], [c], and [Q] is true?

   1) {{True}} X ::= 5 {{X = 5}}

   2) {{X = 2}} X ::= X + 1 {{X = 3}}

   3) {{True}} X ::= 5; Y ::= 0 {{X = 5}}

   4) {{X = 2 /\ X = 3}} X ::= 5 {{X = 0}}

   5) {{True}} SKIP {{False}}

   6) {{False}} SKIP {{True}}

   7) {{True}} WHILE True DO SKIP END {{False}}

   8) {{X = 0}}
      WHILE X == 0 DO X ::= X + 1 END
      {{X = 1}}

   9) {{X = 1}}
      WHILE X <> 0 DO X ::= X + 1 END
      {{X = 100}}
*)
(** [] *)

(** (Note that we're using informal mathematical notations for
   expressions inside of commands, for readability, rather than their
   formal [aexp] and [bexp] encodings.  We'll continue doing so
   throughout the chapter.)

   To get us warmed up for what's coming, here are two simple
   facts about Hoare triples. *)

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  apply H.  Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~(P st)) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  unfold not in H. apply H in HP.
  inversion HP.  Qed.

(* ################################################################# *)
(** * Proof Rules *)

(** The goal of Hoare logic is to provide a _compositional_
    method for proving the validity of specific Hoare triples.  That
    is, we want the structure of a program's correctness proof to
    mirror the structure of the program itself.  To this end, in the
    sections below, we'll introduce a rule for reasoning about each of
    the different syntactic forms of commands in Imp -- one for
    assignment, one for sequencing, one for conditionals, etc. -- plus
    a couple of "structural" rules for gluing things together.  We
    will then be able to prove programs correct using these proof
    rules, without ever unfolding the definition of [hoare_triple]. *)

(* ================================================================= *)
(** ** Assignment *)

(** The rule for assignment is the most fundamental of the Hoare logic
    proof rules.  Here's how it works.

    Consider this valid Hoare triple:

       {{ Y = 1 }}  X ::= Y  {{ X = 1 }}

    In English: if we start out in a state where the value of [Y]
    is [1] and we assign [Y] to [X], then we'll finish in a
    state where [X] is [1].
    That is, the property of being equal to [1] gets transferred
    from [Y] to [X].

    Similarly, in

       {{ Y + Z = 1 }}  X ::= Y + Z  {{ X = 1 }}

    the same property (being equal to one) gets transferred to
    [X] from the expression [Y + Z] on the right-hand side of
    the assignment. *)

(** More generally, if [a] is _any_ arithmetic expression, then

       {{ a = 1 }}  X ::= a {{ X = 1 }}

    is a valid Hoare triple. *)

(** This can be made even more general. To conclude that an
    arbitrary property [Q] holds after [X ::= a], we need to assume
    that [Q] holds before [X ::= a], but _with all occurrences of_ [X]
    replaced by [a] in [Q]. This leads to the Hoare rule for
    assignment

      {{ Q [X |-> a] }} X ::= a {{ Q }}

    where "[Q [X |-> a]]" is pronounced "[Q] where [a] is substituted
    for [X]". *)

(** For example, these are valid applications of the assignment
    rule:

      {{ (X <= 5) [X |-> X + 1]
         i.e., X + 1 <= 5 }}
      X ::= X + 1
      {{ X <= 5 }}

      {{ (X = 3) [X |-> 3]
         i.e., 3 = 3}}
      X ::= 3
      {{ X = 3 }}

      {{ (0 <= X /\ X <= 5) [X |-> 3]
         i.e., (0 <= 3 /\ 3 <= 5)}}
      X ::= 3
      {{ 0 <= X /\ X <= 5 }}
*)

(** To formalize the rule, we must first formalize the idea of
    "substituting an expression for an Imp variable in an assertion."
    That is, given a proposition [P], a variable [X], and an
    arithmetic expression [a], we want to derive another proposition
    [P'] that is just the same as [P] except that, wherever [P]
    mentions [X], [P'] should instead mention [a].

    Since [P] is an arbitrary Coq proposition, we can't directly
    "edit" its text.  Instead, we can achieve the same effect by
    evaluating [P] in an updated state: *)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

(** That is, [P [X |-> a]] stands for an assertion -- let's call it [P'] --
    that is just like [P] except that, wherever [P] looks up the
    variable [X] in the current state, [P'] instead uses the value
    of the expression [a]. *)

(** To see how this works, let's calculate what happens with a couple
    of examples.  First, suppose [P'] is [(X <= 5) [X |-> 3]] -- that
    is, more formally, [P'] is the Coq expression

    fun st =>
      (fun st' => st' X <= 5)
      (t_update st X (aeval st (ANum 3))),

    which simplifies to

    fun st =>
      (fun st' => st' X <= 5)
      (t_update st X 3)

    and further simplifies to

    fun st =>
      ((t_update st X 3) X) <= 5)

    and finally to

    fun st =>
      (3 <= 5).

    That is, [P'] is the assertion that [3] is less than or equal to
    [5] (as expected). *)

(** For a more interesting example, suppose [P'] is [(X <= 5) [X |->
    X+1]].  Formally, [P'] is the Coq expression

    fun st =>
      (fun st' => st' X <= 5)
      (t_update st X (aeval st (APlus (AId X) (ANum 1)))),

    which simplifies to

    fun st =>
      (((t_update st X (aeval st (APlus (AId X) (ANum 1))))) X) <= 5

    and further simplifies to

    fun st =>
      (aeval st (APlus (AId X) (ANum 1))) <= 5.

    That is, [P'] is the assertion that [X+1] is at most [5].
*)

(** Now, using the concept of substitution, we can give the precise
    proof rule for assignment:

      ------------------------------ (hoare_asgn)
      {{Q [X |-> a]}} X ::= a {{Q}}
*)

(** We can prove formally that this rule is indeed valid. *)

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(** Here's a first formal proof using this rule. *)

Example assn_sub_example :
  {{(fun st => st X = 3) [X |-> ANum 3]}}
  (X ::= (ANum 3))
  {{fun st => st X = 3}}.
Proof.
  (* WORKED IN CLASS *)
  apply hoare_asgn.  Qed.

(** **** Exercise: 2 starsM (hoare_asgn_examples)  *)
(** Translate these informal Hoare triples...

    1) {{ (X <= 5) [X |-> X + 1] }}
       X ::= X + 1
       {{ X <= 5 }}

    2) {{ (0 <= X /\ X <= 5) [X |-> 3] }}
       X ::= 3
       {{ 0 <= X /\ X <= 5 }}

   ...into formal statements (use the names [assn_sub_ex1]
   and [assn_sub_ex2]) and use [hoare_asgn] to prove them. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 2 stars, recommendedM (hoare_asgn_wrong)  *)
(** The assignment rule looks backward to almost everyone the first
    time they see it.  If it still seems puzzling, it may help
    to think a little about alternative "forward" rules.  Here is a
    seemingly natural one:

      ------------------------------ (hoare_asgn_wrong)
      {{ True }} X ::= a {{ X = a }}

    Give a counterexample showing that this rule is incorrect and
    argue informally that it is really a counterexample.  (Hint:
    The rule universally quantifies over the arithmetic expression
    [a], and your counterexample needs to exhibit an [a] for which
    the rule doesn't work.) *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars, advanced (hoare_asgn_fwd)  *)
(** However, by using a _parameter_ [m] (a Coq number) to remember the
    original value of [X] we can define a Hoare rule for assignment
    that does, intuitively, "work forwards" rather than backwards.

       ------------------------------------------ (hoare_asgn_fwd)
       {{fun st => P st /\ st X = m}}
         X ::= a
       {{fun st => P st' /\ st X = aeval st' a }}
       (where st' = t_update st X m)

    Note that we use the original value of [X] to reconstruct the
    state [st'] before the assignment took place. Prove that this rule
    is correct.  (Also note that this rule is more complicated than
    [hoare_asgn].)
*)

Theorem hoare_asgn_fwd :
  (forall {X Y: Type} {f g : X -> Y},
     (forall (x: X), f x = g x) ->  f = g) ->
  forall m a P,
  {{fun st => P st /\ st X = m}}
    X ::= a
  {{fun st => P (t_update st X m)
            /\ st X = aeval (t_update st X m) a }}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced (hoare_asgn_fwd_exists)  *)
(** Another way to define a forward rule for assignment is to
    existentially quantify over the previous value of the assigned
    variable.

      ------------------------------------ (hoare_asgn_fwd_exists)
      {{fun st => P st}}
        X ::= a
      {{fun st => exists m, P (t_update st X m) /\
                     st X = aeval (t_update st X m) a }}
*)

Theorem hoare_asgn_fwd_exists :
  (forall {X Y: Type} {f g : X -> Y},
     (forall (x: X), f x = g x) ->  f = g) ->
  forall a P,
  {{fun st => P st}}
    X ::= a
  {{fun st => exists m, P (t_update st X m) /\
                st X = aeval (t_update st X m) a }}.
Proof.
  intros functional_extensionality a P.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Consequence *)

(** Sometimes the preconditions and postconditions we get from the
    Hoare rules won't quite be the ones we want in the particular
    situation at hand -- they may be logically equivalent but have a
    different syntactic form that fails to unify with the goal we are
    trying to prove, or they actually may be logically weaker (for
    preconditions) or stronger (for postconditions) than what we need.

    For instance, while

      {{(X = 3) [X |-> 3]}} X ::= 3 {{X = 3}},

    follows directly from the assignment rule,

      {{True}} X ::= 3 {{X = 3}}

    does not.  This triple is valid, but it is not an instance of
    [hoare_asgn] because [True] and [(X = 3) [X |-> 3]] are not
    syntactically equal assertions.  However, they are logically
    _equivalent_, so if one triple is valid, then the other must
    certainly be as well.  We can capture this observation with the
    following rule:

                {{P'}} c {{Q}}
                  P <<->> P'
         -----------------------------   (hoare_consequence_pre_equiv)
                {{P}} c {{Q}}
*)

(** Taking this line of thought a bit further, we can see that
    strengthening the precondition or weakening the postcondition of a
    valid triple always produces another valid triple. This
    observation is captured by two _Rules of Consequence_.

                {{P'}} c {{Q}}
                   P ->> P'
         -----------------------------   (hoare_consequence_pre)
                {{P}} c {{Q}}

                {{P}} c {{Q'}}
                  Q' ->> Q
         -----------------------------    (hoare_consequence_post)
                {{P}} c {{Q}}
*)

(** Here are the formal versions: *)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

(** For example, we can use the first consequence rule like this:

                {{ True }} ->>
                {{ 1 = 1 }}
    X ::= 1
                {{ X = 1 }}

    Or, formally... *)

Example hoare_asgn_example1 :
  {{fun st => True}} (X ::= (ANum 1)) {{fun st => st X = 1}}.
Proof.
  (* WORKED IN CLASS *)
  apply hoare_consequence_pre
    with (P' := (fun st => st X = 1) [X |-> ANum 1]).
  apply hoare_asgn.
  intros st H. unfold assn_sub, t_update. simpl. reflexivity.
Qed.

(** Finally, for convenience in proofs, we can state a combined
    rule of consequence that allows us to vary both the precondition
    and the postcondition at the same time.

                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* ================================================================= *)
(** ** Digression: The [eapply] Tactic *)

(** This is a good moment to take another look at the [eapply] tactic,
    which we introduced briefly in the [Auto] chapter.

    We had to write "[with (P' := ...)]" explicitly in the proof of
    [hoare_asgn_example1] and [hoare_consequence] above, to make sure
    that all of the metavariables in the premises to the
    [hoare_consequence_pre] rule would be set to specific
    values.  (Since [P'] doesn't appear in the conclusion of
    [hoare_consequence_pre], the process of unifying the conclusion
    with the current goal doesn't constrain [P'] to a specific
    assertion.)

    This is annoying, both because the assertion is a bit long and
    also because, in [hoare_asgn_example1], the very next thing we are
    going to do -- applying the [hoare_asgn] rule -- will tell us
    exactly what it should be!  We can use [eapply] instead of [apply]
    to tell Coq, essentially, "Be patient: The missing part is going
    to be filled in later in the proof." *)

Example hoare_asgn_example1' :
  {{fun st => True}}
  (X ::= (ANum 1))
  {{fun st => st X = 1}}.
Proof.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  intros st H.  reflexivity.  Qed.

(** In general, [eapply H] tactic works just like [apply H] except
    that, instead of failing if unifying the goal with the conclusion
    of [H] does not determine how to instantiate all of the variables
    appearing in the premises of [H], [eapply H] will replace these
    variables with _existential variables_ (written [?nnn]), which
    function as placeholders for expressions that will be
    determined (by further unification) later in the proof. *)

(** In order for [Qed] to succeed, all existential variables need to
    be determined by the end of the proof. Otherwise Coq
    will (rightly) refuse to accept the proof. Remember that the Coq
    tactics build proof objects, and proof objects containing
    existential variables are not complete. *)

Lemma silly1 : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (forall x y : nat, P x y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. apply HP.

(** Coq gives a warning after [apply HP].  (The warnings look
    different between Coq 8.4 and Coq 8.5.  In 8.4, the warning says
    "No more subgoals but non-instantiated existential variables."  In
    8.5, it says "All the remaining goals are on the shelf," meaning
    that we've finished all our top-level proof obligations but along
    the way we've put some aside to be done later, and we have not
    finished those.)  Trying to close the proof with [Qed] gives an
    error. *)

Abort.

(** An additional constraint is that existential variables cannot be
    instantiated with terms containing ordinary variables that did not
    exist at the time the existential variable was created.  (The
    reason for this technical restriction is that allowing such
    instantiation would lead to inconsistency of Coq's logic.) *)

Lemma silly2 :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. destruct HP as [y HP'].

(** Doing [apply HP'] above fails with the following error:

     Error: Impossible to unify "?175" with "y".

    In this case there is an easy fix: doing [destruct HP] _before_
    doing [eapply HQ]. *)

Abort.

Lemma silly2_fixed :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP'].
  eapply HQ. apply HP'.
Qed.

(** The [apply HP'] in the last step unifies the existential variable
    in the goal with the variable [y].

    Note that the [assumption] tactic doesn't work in this case, since
    it cannot handle existential variables.  However, Coq also
    provides an [eassumption] tactic that solves the goal if one of
    the premises matches the goal up to instantiations of existential
    variables. We can use it instead of [apply HP'] if we like. *)

Lemma silly2_eassumption : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP']. eapply HQ. eassumption.
Qed.

(** **** Exercise: 2 starsM (hoare_asgn_examples_2)  *)
(** Translate these informal Hoare triples...

       {{ X + 1 <= 5 }}  X ::= X + 1  {{ X <= 5 }}
       {{ 0 <= 3 /\ 3 <= 5 }}  X ::= 3  {{ 0 <= X /\ X <= 5 }}

   ...into formal statements (name them [assn_sub_ex1'] and
   [assn_sub_ex2']) and use [hoare_asgn] and [hoare_consequence_pre]
   to prove them. *)

(* FILL IN HERE *)
(** [] *)

(* ================================================================= *)
(** ** Skip *)

(** Since [SKIP] doesn't change the state, it preserves any
    property [P]:

      --------------------  (hoare_skip)
      {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* ================================================================= *)
(** ** Sequencing *)

(** More interestingly, if the command [c1] takes any state where
    [P] holds to a state where [Q] holds, and if [c2] takes any
    state where [Q] holds to one where [R] holds, then doing [c1]
    followed by [c2] will take any state where [P] holds to one
    where [R] holds:

        {{ P }} c1 {{ Q }}
        {{ Q }} c2 {{ R }}
       ---------------------  (hoare_seq)
       {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(** Note that, in the formal rule [hoare_seq], the premises are
    given in backwards order ([c2] before [c1]).  This matches the
    natural flow of information in many of the situations where we'll
    use the rule, since the natural way to construct a Hoare-logic
    proof is to begin at the end of the program (with the final
    postcondition) and push postconditions backwards through commands
    until we reach the beginning. *)

(** Informally, a nice way of displaying a proof using the sequencing
    rule is as a "decorated program" where the intermediate assertion
    [Q] is written between [c1] and [c2]:

      {{ a = n }}
    X ::= a;;
      {{ X = n }}    <---- decoration for Q
    SKIP
      {{ X = n }}
*)

(** Here's an example of a program involving both assignment and
    sequencing. *)

Example hoare_asgn_example3 : forall a n,
  {{fun st => aeval st a = n}}
  (X ::= a;; SKIP)
  {{fun st => st X = n}}.
Proof.
  intros a n. eapply hoare_seq.
  - (* right part of seq *)
    apply hoare_skip.
  - (* left part of seq *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    intros st H. subst. reflexivity.
Qed.

(** We typically use [hoare_seq] in conjunction with
    [hoare_consequence_pre] and the [eapply] tactic, as in this
    example. *)

(** **** Exercise: 2 stars, recommended (hoare_asgn_example4)  *)
(** Translate this "decorated program" into a formal proof:

                   {{ True }} ->>
                   {{ 1 = 1 }}
    X ::= 1;;
                   {{ X = 1 }} ->>
                   {{ X = 1 /\ 2 = 2 }}
    Y ::= 2
                   {{ X = 1 /\ Y = 2 }}

   (Note the use of "[->>]" decorations, each marking a use of
   [hoare_consequence_pre].) *)

Example hoare_asgn_example4 :
  {{fun st => True}} (X ::= (ANum 1);; Y ::= (ANum 2))
  {{fun st => st X = 1 /\ st Y = 2}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (swap_exercise)  *)
(** Write an Imp program [c] that swaps the values of [X] and [Y] and
    show that it satisfies the following specification:

      {{X <= Y}} c {{Y <= X}}

    Your proof should not need to use [unfold hoare_triple]. *)

Definition swap_program : com
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem swap_exercise :
  {{fun st => st X <= st Y}}
  swap_program
  {{fun st => st Y <= st X}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 starsM (hoarestate1)  *)
(** Explain why the following proposition can't be proven:

      forall (a : aexp) (n : nat),
         {{fun st => aeval st a = n}}
         (X ::= (ANum 3);; Y ::= a)
         {{fun st => st Y = n}}.
*)

(* FILL IN HERE *)
(** [] *)

(* ================================================================= *)
(** ** Conditionals *)

(** What sort of rule do we want for reasoning about conditional
    commands?

    Certainly, if the same assertion [Q] holds after executing
    either of the branches, then it holds after the whole conditional.
    So we might be tempted to write:

              {{P}} c1 {{Q}}
              {{P}} c2 {{Q}}
      --------------------------------
      {{P}} IFB b THEN c1 ELSE c2 {{Q}}
*)

(** However, this is rather weak. For example, using this rule,
   we cannot show

     {{ True }}
     IFB X == 0
     THEN Y ::= 2
     ELSE Y ::= X + 1
     FI
     {{ X <= Y }}

   since the rule tells us nothing about the state in which the
   assignments take place in the "then" and "else" branches. *)

(** Fortunately, we can say something more precise.  In the
    "then" branch, we know that the boolean expression [b] evaluates to
    [true], and in the "else" branch, we know it evaluates to [false].
    Making this information available in the premises of the rule gives
    us more information to work with when reasoning about the behavior
    of [c1] and [c2] (i.e., the reasons why they establish the
    postcondition [Q]). *)
(**

              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

(** To interpret this rule formally, we need to do a little work.
    Strictly speaking, the assertion we've written, [P /\ b], is the
    conjunction of an assertion and a boolean expression -- i.e., it
    doesn't typecheck.  To fix this, we need a way of formally
    "lifting" any bexp [b] to an assertion.  We'll write [bassn b] for
    the assertion "the boolean expression [b] evaluates to [true] (in
    the given state)." *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

(** A couple of useful facts about [bassn]: *)

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(** Now we can formalize the Hoare proof rule for conditionals
    and prove it correct. *)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  - (* b is true *)
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  - (* b is false *)
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

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

(** Here is a formal proof that the program we used to motivate the
    rule satisfies the specification we gave. *)

Example if_example :
    {{fun st => True}}
  IFB (BEq (AId X) (ANum 0))
    THEN (Y ::= (ANum 2))
    ELSE (Y ::= APlus (AId X) (ANum 1))
  FI
    {{fun st => st X <= st Y}}.
Proof.
  (* WORKED IN CLASS *)
  apply hoare_if.
  - (* Then *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold bassn, assn_sub, t_update, assert_implies.
    simpl. intros st [_ H].
    apply beq_nat_true in H.
    rewrite H. omega.
  - (* Else *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold assn_sub, t_update, assert_implies.
    simpl; intros st _. omega.
Qed.

(** **** Exercise: 2 stars (if_minus_plus)  *)
(** Prove the following hoare triple using [hoare_if].  Do not
    use [unfold hoare_triple].  *)

Theorem if_minus_plus :
  {{fun st => True}}
  IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI
  {{fun st => st Y = st X + st Z}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Exercise: One-sided conditionals *)

(** **** Exercise: 4 starsM (if1_hoare)  *)
(** In this exercise we consider extending Imp with "one-sided
    conditionals" of the form [IF1 b THEN c FI]. Here [b] is a
    boolean expression, and [c] is a command. If [b] evaluates to
    [true], then command [c] is evaluated. If [b] evaluates to
    [false], then [IF1 b THEN c FI] does nothing.

    We recommend that you do this exercise before the ones that
    follow, as it should help solidify your understanding of the
    material. *)

(** The first step is to extend the syntax of commands and introduce
    the usual notations.  (We've done this for you.  We use a separate
    module to prevent polluting the global name space.) *)

Module If1.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CIf1 : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAss X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'IF1' b 'THEN' c 'FI'" :=
  (CIf1 b c) (at level 80, right associativity).

(** Next we need to extend the evaluation relation to accommodate
    [IF1] branches.  This is for you to do... What rule(s) need to be
    added to [ceval] to evaluate one-sided conditionals? *)

Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st \\ st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
            aeval st a1 = n -> (X ::= a1) / st \\ t_update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
            c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
               beval st b1 = true ->
               c1 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
                beval st b1 = false ->
                c2 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
                 beval st b1 = false -> (WHILE b1 DO c1 END) / st \\ st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
                  beval st b1 = true ->
                  c1 / st \\ st' ->
                  (WHILE b1 DO c1 END) / st' \\ st'' ->
                  (WHILE b1 DO c1 END) / st \\ st''
(* FILL IN HERE *)

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

(** Now we repeat (verbatim) the definition and notation of Hoare triples. *)

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st \\ st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

(** Finally, we (i.e., you) need to state and prove a theorem,
    [hoare_if1], that expresses an appropriate Hoare logic proof rule
    for one-sided conditionals. Try to come up with a rule that is
    both sound and as precise as possible. *)

(* FILL IN HERE *)

(** For full credit, prove formally [hoare_if1_good] that your rule is
    precise enough to show the following valid Hoare triple:

  {{ X + Y = Z }}
  IF1 Y <> 0 THEN
    X ::= X + Y
  FI
  {{ X = Z }}
*)

(** Hint: Your proof of this triple may need to use the other proof
    rules also. Because we're working in a separate module, you'll
    need to copy here the rules you find necessary. *)

Lemma hoare_if1_good :
  {{ fun st => st X + st Y = st Z }}
  IF1 BNot (BEq (AId Y) (ANum 0)) THEN
    X ::= APlus (AId X) (AId Y)
  FI
  {{ fun st => st X = st Z }}.
Proof. (* FILL IN HERE *) Admitted.

End If1.
(** [] *)

(* ================================================================= *)
(** ** Loops *)

(** Finally, we need a rule for reasoning about while loops. *)

(** Suppose we have a loop

      WHILE b DO c END

    and we want to find a pre-condition [P] and a post-condition
    [Q] such that

      {{P}} WHILE b DO c END {{Q}}

    is a valid triple. *)

(** First of all, let's think about the case where [b] is false at the
    beginning -- i.e., let's assume that the loop body never executes
    at all.  In this case, the loop behaves like [SKIP], so we might
    be tempted to write: *)

(**

      {{P}} WHILE b DO c END {{P}}.
*)

(** But, as we remarked above for the conditional, we know a
    little more at the end -- not just [P], but also the fact
    that [b] is false in the current state.  So we can enrich the
    postcondition a little: *)
(**

      {{P}} WHILE b DO c END {{P /\ ~b}}
*)

(** What about the case where the loop body _does_ get executed?
    In order to ensure that [P] holds when the loop finally
    exits, we certainly need to make sure that the command [c]
    guarantees that [P] holds whenever [c] is finished.
    Moreover, since [P] holds at the beginning of the first
    execution of [c], and since each execution of [c]
    re-establishes [P] when it finishes, we can always assume
    that [P] holds at the beginning of [c].  This leads us to the
    following rule: *)
(**

                   {{P}} c {{P}}
        -----------------------------------
        {{P}} WHILE b DO c END {{P /\ ~b}}
*)
(** This is almost the rule we want, but again it can be improved a
    little: at the beginning of the loop body, we know not only that
    [P] holds, but also that the guard [b] is true in the current
    state.  This gives us a little more information to use in
    reasoning about [c] (showing that it establishes the invariant by
    the time it finishes).  This gives us the final version of the
    rule:
*)
(**

               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}

    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  - (* E_WhileEnd *)
    split. assumption. apply bexp_eval_false. assumption.
  - (* E_WhileLoop *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

(** One subtlety in the terminology is that calling some assertion [P]
    a "loop invariant" doesn't just mean that it is preserved by the
    body of the loop in question (i.e., [{{P}} c {{P}}], where [c] is
    the loop body), but rather that [P] _together with the fact that
    the loop's guard is true_ is a sufficient precondition for [c] to
    ensure [P] as a postcondition.

    This is a slightly (but significantly) weaker requirement.  For
    example, if [P] is the assertion [X = 0], then [P] _is_ an
    invariant of the loop

    WHILE X = 2 DO X := 1 END

    although it is clearly _not_ preserved by the body of the
    loop. *)

Example while_example :
    {{fun st => st X <= 3}}
  WHILE (BLe (AId X) (ANum 2))
  DO X ::= APlus (AId X) (ANum 1) END
    {{fun st => st X = 3}}.
Proof.
  eapply hoare_consequence_post.
  apply hoare_while.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  unfold bassn, assn_sub, assert_implies, t_update. simpl.
    intros st [H1 H2]. apply leb_complete in H2. omega.
  unfold bassn, assert_implies. intros st [Hle Hb].
    simpl in Hb. destruct (leb (st X) 2) eqn : Heqle.
    exfalso. apply Hb; reflexivity.
    apply leb_iff_conv in Heqle. omega.
Qed.
(** We can use the WHILE rule to prove the following Hoare triple... *)

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  (* WORKED IN CLASS *)
  intros P Q.
  apply hoare_consequence_pre with (P' := fun st : state => True).
  eapply hoare_consequence_post.
  apply hoare_while.
  - (* Loop body preserves invariant *)
    apply hoare_post_true. intros st. apply I.
  - (* Loop invariant and negated guard imply postcondition *)
    simpl. intros st [Hinv Hguard].
    exfalso. apply Hguard. reflexivity.
  - (* Precondition implies invariant *)
    intros st H. constructor.  Qed.

(** Of course, this result is not surprising if we remember that
    the definition of [hoare_triple] asserts that the postcondition
    must hold _only_ when the command terminates.  If the command
    doesn't terminate, we can prove anything we like about the
    post-condition. *)

(** Hoare rules that only talk about terminating commands are
    often said to describe a logic of "partial" correctness.  It is
    also possible to give Hoare rules for "total" correctness, which
    build in the fact that the commands terminate. However, in this
    course we will only talk about partial correctness. *)

(* ----------------------------------------------------------------- *)
(** *** Exercise: [REPEAT] *)

(** **** Exercise: 4 stars, advancedM (hoare_repeat)  *)
(** In this exercise, we'll add a new command to our language of
    commands: [REPEAT] c [UNTIL] a [END]. You will write the
    evaluation rule for [repeat] and add a new Hoare rule to the
    language for programs involving it.  (You may recall that the
    evaluation rule is given in an example in the [Auto] chapter.
    Try to figure it out yourself here rather than peeking.) *)

Module RepeatExercise.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

(** Add new rules for [REPEAT] to [ceval] below.  You can use the rules
    for [WHILE] as a guide, but remember that the body of a [REPEAT]
    should always execute at least once, and that the loop ends when
    the guard becomes true.  Then update the [ceval_cases] tactic to
    handle these added cases.  *)

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ;; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileEnd : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
(* FILL IN HERE *)
.

(** A couple of definitions from above, copied here so they use the
    new [ceval]. *)

Notation "c1 '/' st '\\' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion)
                        : Prop :=
  forall st st', (c / st \\ st') -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level).

(** To make sure you've got the evaluation rules for [REPEAT] right,
    prove that [ex1_repeat] evaluates correctly. *)

Definition ex1_repeat :=
  REPEAT
    X ::= ANum 1;;
    Y ::= APlus (AId Y) (ANum 1)
  UNTIL (BEq (AId X) (ANum 1)) END.

Theorem ex1_repeat_works :
  ex1_repeat / empty_state \\
               t_update (t_update empty_state X 1) Y 1.
Proof.
  (* FILL IN HERE *) Admitted.

(** Now state and prove a theorem, [hoare_repeat], that expresses an
    appropriate proof rule for [repeat] commands.  Use [hoare_while]
    as a model, and try to make your rule as precise as possible. *)

(* FILL IN HERE *)

(** For full credit, make sure (informally) that your rule can be used
    to prove the following valid Hoare triple:

  {{ X > 0 }}
  REPEAT
    Y ::= X;;
    X ::= X - 1
  UNTIL X = 0 END
  {{ X = 0 /\ Y > 0 }}
*)

End RepeatExercise.
(** [] *)

(* ################################################################# *)
(** * Summary *)

(** So far, we've introduced Hoare Logic as a tool for reasoning about
    Imp programs.  In the reminder of this chapter we'll explore a
    systematic way to use Hoare Logic to prove properties about
    programs. The rules of Hoare Logic are:

             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}

             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}

               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}

              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}

               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}

                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}

    In the next chapter, we'll see how these rules are used to prove
    that programs satisfy specifications of their behavior. *)

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

(** **** Exercise: 3 stars (himp_hoare)  *)
(** In this exercise, we will derive proof rules for the [HAVOC]
    command, which we studied in the last chapter.

    First, we enclose this work in a separate module, and recall the
    syntax and big-step semantics of Himp commands. *)

Module Himp.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CHavoc : id -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'HAVOC' X" := (CHavoc X) (at level 60).

Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st \\ st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
            aeval st a1 = n -> (X ::= a1) / st \\ t_update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
            c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
               beval st b1 = true ->
               c1 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
                beval st b1 = false ->
                c2 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
                 beval st b1 = false -> (WHILE b1 DO c1 END) / st \\ st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
                  beval st b1 = true ->
                  c1 / st \\ st' ->
                  (WHILE b1 DO c1 END) / st' \\ st'' ->
                  (WHILE b1 DO c1 END) / st \\ st''
  | E_Havoc : forall (st : state) (X : id) (n : nat),
              (HAVOC X) / st \\ t_update st X n

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

(** The definition of Hoare triples is exactly as before. *)

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st', c / st \\ st' -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

(** Complete the Hoare rule for [HAVOC] commands below by defining
    [havoc_pre] and prove that the resulting rule is correct. *)

Definition havoc_pre (X : id) (Q : Assertion) : Assertion
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem hoare_havoc : forall (Q : Assertion) (X : id),
  {{ havoc_pre X Q }} HAVOC X {{ Q }}.
Proof.
  (* FILL IN HERE *) Admitted.

End Himp.
(** [] *)

(** $Date: 2017-02-02 10:32:28 -0500 (Thu, 02 Feb 2017) $ *)


Axiom SET : Type.
Axiom In : SET -> SET -> Prop.

Ltac put H name :=
generalize H; intro name.

(* Sub Typeing *)

Definition Cls (P : SET -> Prop) := sig P.
Notation "## P" := (Cls P) (at level 100).
Definition Cls_to_SET {A} (p : Cls A) : SET := (proj1_sig p).
Coercion Cls_to_SET : Cls >-> SET.
Definition partial_SET A := Cls (fun v => In v A).
Notation "# A" := (partial_SET A) (at level 100).
Definition partialSET_to_SET {A} (p : partial_SET A) : SET := (Cls_to_SET p).
Coercion partialSET_to_SET : partial_SET >-> SET.

Theorem ClsProp : forall {P} (a : (##P)), P a.
intros P a.
compute.
generalize (proj2_sig a); intro HH.
apply HH.
Qed.

Theorem SetProp : forall {A} (a : (#A)), In a A.
Proof.
intros A a.
apply (@ClsProp (fun v => In v A)).
Qed.
Hint Immediate @SetProp.

(*DownCast*)
Definition DCast_Cls {P : SET -> Prop} x (prf : P x) : (##P) := exist P _ prf.
Notation "{ x !! prf }" := (DCast_Cls x prf) (at level 1).
Definition DCast_SET {A} x (prf : In x A) : (#A) := exist (fun x => In x A) x prf.
Notation "{ x ! prf }" := (DCast_SET x prf) (at level 1).

Definition ZFCEq (a : SET) (b : SET) := a = b.
Notation "a == b" := (ZFCEq a b) (at level 70).

Theorem ReflexivityEq : forall a , a == a.
Proof.
intros.
reflexivity.
Qed.
Hint Immediate ReflexivityEq.
Theorem SymmetryEq : forall a b, a == b -> b == a.
Proof.
intros a b ab.
rewrite ab.
auto.
Qed.
Hint Immediate SymmetryEq.
Theorem TransitivityEq : forall {a c} b, a == b -> b == c -> a == c.
Proof.
intros a c b ab bc.
transitivity b.
auto.
auto.
Qed.
Hint Immediate @TransitivityEq.

Theorem DSETEq : forall {A} x (prf : In x A), {x ! prf} == x.
Proof.
intros x A prf.
apply ReflexivityEq.
Qed.

Theorem DSETEq' : forall {A} x (prf : In x A), x == {x ! prf}.
Proof.
intros A x prf.
apply ReflexivityEq.
Qed.

Theorem PropRewrite : forall (P : SET -> Prop),
forall x y, x == y -> P x -> P y.
Proof.
intros P x y Eqxy Px.
rewrite Eqxy in Px.
assumption.
Qed.
Theorem PropRewrite' : forall (P : SET -> Prop),
forall x y, x == y -> P y -> P x.
Proof.
intros P x y Eqxy.
apply PropRewrite.
apply SymmetryEq.
assumption.
Qed.

Definition RPred {A} (P : (#A) -> Prop) :=
forall (x : (#A)) (y : (#A)),
x == y -> (P x <-> P y).
Definition RPred' {A} (P : (#A) -> Prop) :=
forall (x : (#A)) (y : (#A)),
x == y -> (P x -> P y).
Definition RFunS {A} (F : (#A) -> SET) :=
forall (x y : (#A)),
x == y -> F x == F y.
Definition RFun {A B} (F : (#A) -> (#B)) :=
forall (x y : (#A)),
x == y -> F x == F y.

Definition EquivPred (P1 P2 : SET -> Prop) := forall a, (P1 a <-> P2 a).
Definition EquivPred' {A} (P1 P2 : (#A) -> Prop) := forall a, (P1 a <-> P2 a).

Theorem RPredSimplify : forall {A} (P : (#A) -> Prop),
RPred P <-> RPred' P.
Proof.
intros A P.
split.
 intro RP.
 intros x y Eqxy Px.
 apply (RP _ _ Eqxy).
 assumption.

 intro RP'.
 intros x y Eqxy.
 split.
  intro Px.
  apply (RP' _ _ Eqxy).
  assumption.

  intro Py.
  apply SymmetryEq in Eqxy.
  apply (RP' _ _ Eqxy).
  assumption.
Qed.

Theorem RFunRewrite' : forall {P : SET -> Prop} (F : (##P) -> SET) x,
(exists y, forall prf : P x, F {x !! prf} == y) ->
forall (a b : ##P), x == a -> x == b ->  F a == F b.
Proof.
intros P F x Cond a b Eqa Eqb.
destruct a as [a prfa].
destruct b as [b prfb].
destruct Cond as [y Cond].
assert(Eqxa : x = a).
 apply Eqa.
assert(Eqxb : x = b).
 apply Eqb.
apply (TransitivityEq y).
rewrite Eqxa in Cond.
apply Cond.
apply SymmetryEq.
rewrite Eqxb in Cond.
apply Cond.
Qed.

Theorem RFunRewrite : forall {A} (F : (#A) -> SET) x,
(exists y, forall prf : In x A, F {x ! prf} == y) ->
forall (a b : #A), x == a -> x == b ->  F a == F b.
Proof.
intros A F x Cond a b Eqa Eqb.
destruct a as [a prfa].
destruct b as [b prfb].
destruct Cond as [y Cond].
assert(Eqxa : x = a).
 apply Eqa.
assert(Eqxb : x = b).
 apply Eqb.
apply (TransitivityEq y).
rewrite Eqxa in Cond.
apply Cond.
apply SymmetryEq.
rewrite Eqxb in Cond.
apply Cond.
Qed.

Theorem FunRewrite : forall (F : SET -> SET), forall x y,
x == y -> F x == F y.
Proof.
intros F x y Eqxy.
rewrite Eqxy.
apply ReflexivityEq.
Qed.

Theorem FunRewrite2 : forall (F : SET -> SET -> SET), forall a b x y,
a == b -> x == y -> F a x == F b y.
Proof.
intros F a b x y Eqab Eqxy.
rewrite Eqab.
rewrite Eqxy.
apply ReflexivityEq.
Qed.

Theorem ArrowRewrite : forall (P : SET -> Prop), forall x y,
x == y -> (P x -> P y).
Proof.
intros P x y Eqxy Px.
rewrite Eqxy in Px.
apply Px.
Qed.

Theorem Arrow2Rewrite : forall (P : SET -> SET -> Prop), forall a b x y,
a == b -> x == y -> (P a x -> P b y).
Proof.
intros P a b x y Eqab Eqxy Pax.
rewrite <- Eqab.
rewrite <- Eqxy.
apply Pax.
Qed.

Definition ProofEquiv := forall (P : Prop) (prf1 : P) (prf2 : P), prf1
= prf2.

Theorem ProofEquiv_RPred : ProofEquiv -> (forall A (P : (#A) -> Prop), RPred P).
Proof.
intros pe A P.
intros x y Eqxy.
destruct x as [xs px].
destruct y as [ys py].
assert(EqP : (exist (fun v => In v A) xs px) = (exist (fun v => In v A) ys py)).
 assert(EqxyS : xs = ys).
  auto.
 generalize px.
 rewrite EqxyS.
 intro py'.
 assert(Eqp : py' = py).
  apply (pe (In ys A)).
 rewrite Eqp.
 reflexivity.
rewrite EqP.
tauto.
Qed.

Theorem ProofEquiv_RFun : ProofEquiv -> forall A B (F : (#A) -> (#B)), RFun F.
Proof.
intros pe A B F.
intros x y Eqxy.
destruct x as [x InxA].
destruct y as [y InyA].
unfold ZFCEq in Eqxy.
assert(Eqxy' : {x ! InxA} == {y ! InyA}).
now apply Eqxy.
clear Eqxy.
assert(Eqxy : x = y).
{
  unfold ZFCEq in Eqxy'.
  apply Eqxy'.
}
apply (TransitivityEq (F {x ! InxA})).
now auto.
apply (TransitivityEq (F {y ! InyA})).
{
  subst.
  assert(Eqp : InyA = InxA).
  now apply pe.
  rewrite Eqp.
  auto.
}
now auto.
Qed.

(* Unique *)
Definition Unique (P : SET -> Prop) :=
(exists x , P x) /\
(forall x y , P x -> P y -> x==y).
Axiom UniqueOut :
  forall (P : SET -> Prop) , Unique P -> SET.
Axiom HUniqueOut :
  forall (P : SET -> Prop) (prf : Unique P),
  P (UniqueOut P prf).

Definition Unique' {A} (P : (#A) -> Prop) :=
(exists a, P a) /\ (forall x y, P x /\ P y -> x == y).
Definition Unique'OutProof : forall {A} (P : (#A) -> Prop),
Unique' P -> Unique (fun x => exists prf : In x A, P ({x ! prf})).
Proof.
intros A P unqp.
destruct unqp as [Exs Unq].
split.
 destruct Exs as [a Exs].
 destruct a as [sa pa].
 exists sa.
 exists pa.
 apply Exs.

 intros x y Hx Hy.
 destruct Hx as [px Hx].
 destruct Hy as [py Hy].
 assert(Eqxy : {x ! px} == {y ! py}).
  apply Unq.
  split; assumption.
 apply Eqxy.
Qed.
Definition Unique'OutSet {A} (P : (#A) -> Prop) (unq : Unique' P) :=
UniqueOut (fun x => exists prf : In x A, P {x ! prf}) (Unique'OutProof _ unq).
Theorem Unique'OutSetIn : forall {A} (P : (#A) -> Prop) (unq : Unique' P),
In (Unique'OutSet P unq) A.
Proof.
intros A P unq.
unfold Unique'OutSet.
assert (UH : (fun x => exists prf : In x A, P {x ! prf}) (UniqueOut (fun x => exists prf : In x A, P {x ! prf}) (Unique'OutProof P unq))).
 apply (HUniqueOut (fun x => exists prf : In x A, P {x ! prf})).
simpl in UH.
destruct UH as [InA UH].
assumption.
Qed.
Definition Unique'Out {A} (P : (#A) -> Prop) (unq : Unique' P) :=
{(Unique'OutSet P unq) ! (Unique'OutSetIn P unq)}.
Theorem HUnique'Out : forall {A} (P : (#A) -> Prop) (unq : Unique' P),
RPred P -> P (Unique'Out P unq).
Proof.
intros A P unq rpp.
assert (UH : (fun x => exists prf : In x A, P {x ! prf}) (UniqueOut (fun x => exists prf : In x A, P {x ! prf}) (Unique'OutProof P unq))).
 apply (HUniqueOut (fun x => exists prf : In x A, P {x ! prf})).
simpl in UH.
destruct UH as [InUA PH].
assert(EqP : (Unique'Out P unq) == {(UniqueOut (fun x => exists prf : In x A, P {x ! prf}) (Unique'OutProof P unq)) ! InUA}).
 apply ReflexivityEq.
apply (rpp _ _ EqP).
assumption.
Qed.

Theorem UniqueOutEquiv : forall P (Unq : Unique P) x,
UniqueOut P Unq == x <-> P x.
Proof.
intros P Unq x.
split; intro HH.
 symmetry in HH.
 rewrite HH.
 apply (HUniqueOut P).

 destruct Unq as [Exs Unq].
 apply (Unq).
 apply (HUniqueOut P).
 auto.
Qed.

Theorem Unique'OutEquiv : forall {A} (P : (#A) -> Prop) (Unq : Unique' P) (x : (#A)),
RPred P -> (Unique'Out P Unq == x <-> P x).
Proof.
intros A P Unq x rpp.
split.
 intro UPEq.
 apply (rpp _ _ UPEq).
 apply (HUnique'Out _ _ rpp).

 intro Px.
 inversion Unq as [exs unq].
 apply unq.
 split.
 apply (HUnique'Out _ _ rpp).
 assumption.
Qed.

Theorem UniqueRewrite : forall P1 P2,
EquivPred P1 P2 ->
(Unique P1 <-> Unique P2).
Proof.
intros P1 P2 cond.
split.
 intro UP1.
 destruct UP1 as [Exs Unq].
 destruct Exs as [a Exs].
 split.
  exists a.
  apply cond.
  assumption.
 intros a1 a2 H1 H2.
 apply Unq.
  apply cond.
  assumption.
 apply cond.
 assumption.

 intro UP2.
 destruct UP2 as [Exs Unq].
 destruct Exs as [a Exs].
 split.
  exists a.
  apply cond.
  assumption.
 intros a1 a2 H1 H2.
 apply Unq.
  apply cond.
  assumption.
 apply cond.
 assumption.
Qed.

Theorem Unique'Rewrite : forall {A} (P1 : (#A) -> Prop) (P2 : (#A) -> Prop),
EquivPred' P1 P2 ->
(Unique' P1 <-> Unique' P2).
Proof.
intros A P1 P2 cond.
split.
 intro UP1.
 destruct UP1 as [Exs Unq].
 destruct Exs as [a Exs].
 split.
  exists a.
  apply cond.
  assumption.
 intros a1 a2 HD.
 destruct HD as [H1 H2].
 apply Unq.
 split.
  apply cond.
  assumption.
 apply cond.
 assumption.

 intro UP2.
 destruct UP2 as [Exs Unq].
 destruct Exs as [a Exs].
 split.
  exists a.
  apply cond.
  assumption.
 intros a1 a2 HD.
 destruct HD as [H1 H2].
 apply Unq.
 split.
  apply cond.
  assumption.
 apply cond.
 assumption.
Qed.

Definition Atmost (P : SET -> Prop) :=
(forall x y , P x -> P y -> x==y).

Definition Atmost' {A} (P : (#A) -> Prop) :=
(forall x y , P x -> P y -> x==y).

Theorem AtmostEqApply :
forall (P : SET -> Prop) (prf : Atmost P) x y ,
P x /\ P y -> x==y.
Proof.
intros P prf x y DP.
apply prf; tauto.
Qed.

Theorem Atmost'EqApply :
forall {A} (P : (#A) -> Prop) (prf : Atmost' P) x y,
P x /\ P y -> x == y.
Proof.
intros A P prf x y PD.
destruct PD as [Px Py].
apply prf.
auto.
auto.
Qed.

Theorem Unique_Atmost : forall P ,
Unique P -> Atmost P.
Proof.
intros P UnqP.
destruct UnqP as [Exs Unq].
intros x y Px Py.
apply Unq; auto.
Qed.

Theorem Unique'_Atmost' : forall {A} (P : (#A) -> Prop),
Unique' P -> Atmost' P.
Proof.
intros A P Unq.
destruct Unq as [Exs Unq].
intros x y Px Py.
apply (Unq _ _).
split; assumption.
Qed.

Theorem UniqueEqApply :
forall (P : SET -> Prop) (prf : Unique P) x y ,
P x /\ P y -> x==y.
Proof.
intros P prf.
apply Unique_Atmost in prf.
apply AtmostEqApply.
auto.
Qed.

Theorem Unique'EqApply :
forall {A} (P : (#A) -> Prop) (prf : Unique' P) x y,
P x /\ P y -> x == y.
intros A P prf.
apply Unique'_Atmost' in prf.
apply Atmost'EqApply.
auto.
Qed.

Theorem Atmost_Unique : forall P : SET -> Prop,
Atmost P -> (exists x , P x) -> Unique P.
Proof.
intros P AP EP.
split; auto.
Qed.

Definition AtmostOut
(P : SET -> Prop) (atm : Atmost P) (exs : exists x , P x) :=
UniqueOut P (Atmost_Unique _ atm exs).

Theorem HAtmostOut : forall
(P : SET -> Prop) (atm : Atmost P) (exs : exists x , P x),
P (AtmostOut P atm exs).
Proof.
intros P atm exs.
apply (HUniqueOut P).
Qed.

(*Theorems*)
Theorem DeMorganANO : forall P Q : Prop ,
(~P /\ ~Q) -> ~(P \/ Q).
Proof.
intros P Q HH NH.
destruct HH as [NP NQ].
destruct NH as [PP | QQ]; tauto.
Qed.

Theorem DeMorganONA : forall P Q : Prop ,
(~P \/ ~Q) -> ~(P /\ Q).
Proof.
intros P Q HH NH.
destruct NH as [PP QQ].
destruct HH as [NP | NQ]; tauto.
Qed.

Theorem DeMorganNOA : forall P Q : Prop ,
~(P \/ Q) -> (~P /\ ~Q).
Proof.
intros P Q HH.
split; intro TT; apply HH; tauto.
Qed.

Theorem DoubleDeny : forall P : Prop, P -> ~~P.
Proof.
auto.
Qed.

Theorem DeMorganFNE : forall P : SET -> Prop,
(forall x , ~P x) -> ~(exists x , P x).
Proof.
intros P NP NN.
destruct NN as [x NN].
apply (NP x).
auto.
Qed.

Theorem DeMorganENF : forall P : SET -> Prop,
(exists x , ~P x) -> ~(forall x , P x).
Proof.
intros P NP NN.
destruct NP as [x NP].
apply NP.
auto.
Qed.

Theorem DeMorganNEF : forall P : SET -> Prop,
~(exists x , P x) -> (forall x , ~P x).
Proof.
intros P NE x NN.
apply NE.
exists x.
auto.
Qed.

Theorem ChangeInForall : forall P Q : SET -> Prop,
(forall x , P x -> Q x) ->
(forall x , P x) -> (forall x , Q x).
Proof.
intros P Q HH F1 x.
apply HH.
auto.
Qed.

Theorem ChangeInExists : forall P Q : SET -> Prop,
(forall x , P x -> Q x) ->
(exists x , P x) -> (exists x , Q x).
Proof.
intros P Q HH F1.
destruct F1 as [x F1].
exists x.
apply HH.
auto.
Qed.

Theorem ReflexivityArrow : forall P Q : Prop,
P -> P.
Proof.
tauto.
Qed.

Theorem TransitivityArrow : forall P Q R : Prop,
(P -> Q) -> (Q -> R) -> (P -> R).
Proof.
tauto.
Qed.

Theorem ReflexivityEquiv : forall P : Prop,
P <-> P.
Proof.
tauto.
Qed.

Theorem SymmetryEquiv : forall P Q : Prop ,
(P <-> Q) -> (Q <-> P).
Proof.
intros P Q PQ.
tauto.
Qed.

Theorem TransitivityEquiv : forall {P R : Prop} (Q : Prop),
(P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
tauto.
Qed.

(*
Theorem DistributeEquivAndL : forall A B C : Prop,
(A /\ (B <-> C)) <-> ((A /\ B) <-> (A /\ C)).
Proof.
intros A B C.
split.
 intro HH.
 destruct HH as [a bc].
 split.
  intro ab.
  destruct ab as [a' b].
  split.
  assumption.
  apply bc.
  assumption.

  intro ac.
  destruct ac as [a' c].

 split.
 split.
  intro a.
  cut (B /\ C).
  tauto.
  apply HH.
  auto.

  intro b.
  apply HH.

  assum
(A /\ B <-> C /\ D) <-> ((A <-> C) /\ (B <-> D)).
Proof.
intros A B C D.
split.
 intro AndH.
 split.
 split.
  intro a.
  cut (C /\ D).
  tauto.
  apply AndH.

  cut D.
  apply AndH.

 destruct AndH as [H1 H2].

(P /\ Q <-> R) <-> (P ->
*)

Theorem SymmetryAnd : forall P Q : Prop,
P /\ Q -> Q /\ P.
Proof.
intros P Q PQ.
split; tauto.
Qed.

Theorem LeftAnd : forall {R} L,
L /\ R -> R.
Proof.
tauto.
Qed.

Theorem RightAnd : forall {L} R,
L /\ R -> L.
Proof.
tauto.
Qed.

Theorem DoubleAnd : forall P,
P /\ P <-> P.
Proof.
tauto.
Qed.

Theorem SymmetryOr : forall P Q : Prop,
P \/ Q -> Q \/ P.
Proof.
intros P Q PQ.
destruct PQ; auto.
Qed.

Theorem LeftOr : forall {R : Prop} (L : Prop),
R -> R \/ L.
Proof.
tauto.
Qed.

Theorem RightOr : forall {L : Prop} (R : Prop),
L -> R \/ L.
Proof.
tauto.
Qed.

(*Classical Theorems*)
Definition REM := forall P : Prop , P \/ ~P.
Definition DDE := forall P : Prop , ~~P -> P.

(*Definition ContraPosition := forall P Q : Prop, (P -> Q) -> (~Q -> ~P).*)

Theorem ContraPosition : forall P Q : Prop, (P -> Q) -> (~Q -> ~P).
Proof.
intros P Q HH NQH NP.
apply NQH.
apply HH.
auto.
Qed.

Theorem DDE_REM : DDE -> REM.
Proof.
intros dd P.
apply (dd (P \/ ~P)).
intro NN.
apply DeMorganNOA in NN.
tauto.
Qed.

Theorem REM_DDE : REM -> DDE.
Proof.
intros em P NNP.
generalize (em P); intro em'.
destruct em' as [PP | NP].
auto.
elimtype False.
apply NNP.
auto.
Qed.

Theorem DeMorganNAO : REM -> forall P Q : Prop ,
~(P /\ Q) -> (~P \/ ~Q).
Proof.
intros rem P Q HH.
destruct (rem P) as [PH | NPH].
 right.
 intro QH.
 apply HH.
 split; auto.

 left.
 auto.
Qed.

Theorem DeMorganNFE : REM -> forall P : SET -> Prop,
~(forall x , P x) -> (exists x , ~P x).
Proof.
intros dd P NP.
apply REM_DDE in dd.
apply dd.
intro NN.
apply NP.
generalize (DeMorganNEF _ NN); intro NN'.
intro x.
apply dd.
auto.
Qed.

Theorem ArrowDestruct1 : REM ->
forall P Q : Prop, (P -> Q) -> (~P \/ Q).
Proof.
intros rem P Q Arr.
destruct (rem Q) as [QH | NQH].
 auto.

 left.
 intro PH.
 apply NQH.
 auto.
Qed.

Theorem ArrowDestruct2 :
forall P Q, (~P \/ Q) -> (P -> Q).
Proof.
intros P Q destarr HP.
destruct destarr as [NPH | QH].
tauto.
auto.
Qed.

Theorem ArrowDestructRem :
(forall P Q : Prop, (P -> Q) -> (~P \/ Q)) -> REM.
Proof.
intros Arrd M.
assert(c : M -> M).
 auto.
destruct (Arrd _ _ c); auto.
Qed.

Theorem NArrowDest : REM -> forall P Q : Prop, ~(P -> Q) -> (P /\ ~Q).
Proof.
intros REM P Q NPQ.
apply (REM_DDE REM).
intro PNQ.
apply (DeMorganNAO REM) in PNQ.
apply NPQ.
intro PH.
destruct PNQ as [NPH | QH].
tauto.
apply (REM_DDE REM).
auto.
Qed.

(*
Theorem REMInForall : REM -> forall P : SET -> Prop ,
(forall x , ~~P x) -> (forall x , P x).
Proof.
intros dd P HH x.
apply dd.
auto.
Qed.

Theorem REMInExists : DDE -> forall P : SET -> Prop ,
(exists x , ~~P x) -> (exists x , P x).
Proof.
intros dd P HH.
destruct HH as [x HH].
exists x.
apply dd.
auto.
Qed.
*)


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Key constructor: Finite list.  *)

Set Implicit Arguments.

Require Import OrderedType.
Require Import hpattern vgtac.
Require Import VocabA DLat.

Definition size : nat := 6.

Extract Constant size => "try int_of_string (Sys.getenv ""NLISTSIZE"") with _ -> 6".

Module NListKey (A : KEY) <: KEY.

Module F := OrderedTypeFacts (A).

Inductive t' :=
| nil
| cons (hd : A.t) (tl : t').

Definition t := t'.

Fixpoint app l x :=
  match l with
    | nil => cons x nil
    | cons h t => cons h (app t x)
  end.

Inductive eq' : nat -> t -> t -> Prop :=
| eq_zero : forall x1 x2, eq' O x1 x2
| eq_nil : forall s, eq' s nil nil
| eq_cons : forall (hd1 hd2 : A.t) (Hhd: A.eq hd1 hd2)
                   s (tl1 tl2 : t) (Htl: eq' s tl1 tl2),
              eq' (S s) (cons hd1 tl1) (cons hd2 tl2).

Definition eq : t -> t -> Prop := eq' size.

Lemma app_mor' : forall n, Proper (eq' n ==> A.eq ==> eq' n) app.
Proof.
induction 1; intros y1 y2 Hy; s.
- by constructor.
- destruct s; [by constructor|constructor; [by auto|by constructor]].
- constructor; [by auto|by apply IHeq'].
Qed.

Lemma app_mor : Proper (eq ==> A.eq ==> eq) app.
Proof. by apply app_mor'. Qed.

Inductive lt' : nat -> t -> t -> Prop :=
| lt_nil : forall s (hd_x : A.t) (tl_x : t) (Hs : s <> O),
             lt' s nil (cons hd_x tl_x)
| lt_cons1 : forall (hd1 hd2 : A.t) (Hhd : A.eq hd1 hd2)
                    s (tl1 tl2 : t) (Htl : lt' s tl1 tl2),
               lt' (S s) (cons hd1 tl1) (cons hd2 tl2)
| lt_cons2 : forall s (hd1 hd2 : A.t) (Hhd : A.lt hd1 hd2)
                    (tl1 tl2 : t),
               lt' (S s) (cons hd1 tl1) (cons hd2 tl2).

Definition lt : t -> t -> Prop := lt' size.

Lemma eq'_refl : forall (x : t) s, eq' s x x.
Proof.
induction x; [by econs|].
destruct s; econs; [apply A.eq_refl|apply IHx].
Qed.

Lemma eq_refl : forall x : t, eq x x.
Proof. i; apply eq'_refl. Qed.

Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof.
unfold eq. induction 1; [by econs|by econs|].
econs; auto.
Qed.

Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof.
unfold eq. i; depgen z; induction H; [econs|inversion 1; by econs|].
inversion 1; subst; econs; [by eauto using A.eq_trans|].
by apply IHeq'.
Qed.

Definition zb_eq : zb_equiv eq :=
  {| zb_equiv_refl := eq_refl
   ; zb_equiv_sym := eq_sym
   ; zb_equiv_trans := eq_trans |}.

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.
unfold lt. i; depgen z; induction H; [inversion 1; by econs| |].
+ inversion 1; subst.
  - apply lt_cons1; [eauto using A.eq_trans|]; by apply IHlt'.
  - apply lt_cons2; by eauto using F.lt_eq.
+ inversion 1; subst.
  - apply lt_cons2; by eauto using F.eq_lt.
  - apply lt_cons2; by eauto using A.lt_trans.
Qed.

Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof.
unfold lt, eq. induction 1; inversion 1; [congruence|tauto|].
subst; eapply A.lt_not_eq; eauto.
Qed.

Fixpoint compare' s (x y : t) : Compare (lt' s) (eq' s) x y :=
  match s with
    | O => EQ (eq_zero x y)
    | S s' =>
      match x, y with
        | nil, nil => EQ (eq_nil (S s'))
        | nil, cons ty y' => LT (lt_nil ty y' (not_eq_sym (O_S s')))
        | cons tx x', nil => GT (lt_nil tx x' (not_eq_sym (O_S s')))
        | cons tx x', cons ty y' =>
          match A.compare tx ty with
            | LT l => LT (lt_cons2 s' l x' y')
            | EQ e =>
              match compare' s' x' y' with
                | LT l => LT (lt_cons1 e l)
                | EQ e0 => EQ (eq_cons e e0)
                | GT l => GT (lt_cons1 (A.eq_sym e) l)
              end
            | GT l => GT (lt_cons2 s' l y' x')
          end
      end
  end.

Definition compare (x y : t) : Compare lt eq x y := compare' size x y.

Fixpoint eq_dec' s (x y : t) : {eq' s x y} + {~ eq' s x y}.
refine
  match s with
    | O => left (eq_zero x y)
    | S s' => _
  end;
refine
  match x, y with
  | nil, nil => left _
  | cons hd1 tl1, cons hd2 tl2 =>
    match A.eq_dec hd1 hd2 with
    | left _ =>
      match eq_dec' s' tl1 tl2 with
      | left _ => left _
      | right _ => right _
      end
    | right _ => right _
    end
  | _, _ => right _
  end; try (by inversion 1).
- apply eq_nil.
- apply eq_cons; auto.
Qed.

Definition eq_dec (x y : t) : {eq x y} + {~ eq x y}.
refine
  ((if physical_eq x y as c return
       physical_eq x y = c -> {eq x y} + {~ eq x y} then fun Hc => left _
    else fun _ => eq_dec' size x y) Logic.eq_refl).
apply physical_eq_prop in Hc; subst; by apply eq_refl.
Qed.

Definition eqb x y := if eq_dec x y then true else false.

End NListKey.


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

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

Print Assumptions sub.


Require Export prosa.behavior.all.

(** * Definition of Work Conservation *)

(** In this module, we introduce a restrictive definition of work-conserving
    schedules. The definition is restrictive because it does not yet cover
    multiprocessor scheduling (there are plans to address this in future
    work). The definition does however cover effects such as jitter or
    self-suspensions that affect whether a job can be scheduled at a given
    point in time because it is based on the general notion of a job being
    [backlogged] (i.e., ready and not executing), which is parametric in any
    given job readiness model. *)

Section WorkConserving.
  (** Consider any type of jobs... *)
  Context {Job: JobType}.

  (** ... with arrival times and costs ... *)
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** ... and any kind of processor model. *)
  Context {PState: Type}.
  Context `{ProcessorState Job PState}.

  (** Further, allow for any notion of job readiness. *)
  Context `{JobReady Job PState}.

  (** Given an arrival sequence and a schedule ... *)
  Variable arr_seq : arrival_sequence Job.
  Variable sched: schedule PState.

  (** ... we say that a scheduler is _work-conserving_ iff whenever a job [j]
     is backlogged, the processor is always busy executing another job
     [j_other]. Note that this definition is intentionally silent on matters of
     priority. *)
  Definition work_conserving :=
    forall j t,
      arrives_in arr_seq j ->
      backlogged sched j t ->
      exists j_other, scheduled_at sched j_other t.

End WorkConserving.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Require Import Examples.AutoSep.

(** Read from pointers in variables *)

Definition indirS : spec := SPEC("x") reserving 1
  Al v,
  PRE[V] V "x" =*> v
  POST[R] [| R = v |] * V "x" =*> v.

Definition indir := bmodule "indir" {{
  bfunction "indir"("x", "y") [indirS]
    "y" <-* "x";;
    Return "y"
  end
}}.

Theorem indirOk : moduleOk indir.
  vcgen; abstract sep_auto.
Qed.

Definition doubleIndirS : spec := SPEC("x") reserving 1
  Al p, Al v,
  PRE[V] V "x" =*> p * p =*> v
  POST[R] [| R = v |] * V "x" =*> p * p =*> v.

Definition doubleIndir := bmodule "doubleIndir" {{
  bfunction "doubleIndir"("x", "y") [doubleIndirS]
    "y" <-* "x";;
    "y" <-* "y";;
    Return "y"
  end
}}.

Theorem doubleIndirOk : moduleOk doubleIndir.
(*TIME Clear Timing Profile. *)
  vcgen; abstract sep_auto.
(*TIME Print Timing Profile. *)
Qed.


Require Export RelDefinitions.
Require Export RelOperators.
Require Export Relators.
Require Import Delay.

(** ** The [monotonicity] tactic *)

(** The purpose of the [monotonicity] tactic is to automatically
  select and apply a theorem of the form [Monotonic ?m ?R] in order to
  make progress when the goal is an applied relation. Compared with
  setoid rewriting, [monotonicity] is less powerful, but more direct
  and simple. This means it is easier to debug, and it can seamlessly
  handle dependent types and heterogenous relations.

  The [monotonicity] tactic applies to a goal of the form
  [R (f x1 x2 ... xn) (g y1 y2 ... yn)]. The basic idea is to first
  locate a relational property declared by the user relating [f] and
  [g], namely an instance of [Related f g R'], then to locate and
  instance of [RElim] which will allow us to use [R' f g] to make
  progress on the current goal. Most of the time, [f] and [g] will be
  identical so that the corresponding relational property can be
  writted [Monotonic f R'].

  For instance, we can register the monotonicity of [plus] as an
  instance of [Monotonic plus (lt ++> lt ++> lt)]. Given an goal of
  the form [plus 5 6 < plus x 5], the monotonicity tactic will use
  that property and, using the [RElim] rule for [++>], construct an
  instance of
  [RElim (lt ++> lt ++> lt) plus plus (lt 5 7 -> lt x 5 -> lt (plus 5 6) (plus x 5))]
  to apply on the goal, leaving us with the subgoals [5 < 7] and
  [x < 5].

  While this basic principle is rather straightforward, there are some
  subtleties that we have to consider in order to build a reliable
  system: the relational property we need to use may be about a prefix
  [f x1 x2 ... xk] ([k] < [n]) of the application that still has some
  arguments applied; we want to be able to exploit [subrel]
  relationships to extend the applicability of the declared relational
  properties; we need to be need to be careful about how we treat
  existential variables. *)

(** *** Truncating applications *)

(** The first complication arises from the fact that [f] and [g] may
  themselves be partial applications, so the goal may in fact be of
  the form
  [R (f a1 a2 ... ak x1 x2 ... xn) (g b1 b2 ... bl y1 y2 ... yn)],
  with [k] ≠ [l], where the relational property to apply will be of
  the form [Related R' (f a1 a2 ... ak) (g b1 b2 ... bl)]. This is
  particularly relevant when [f] and [g] may have implicit typeclass
  arguments, or type arguments that cannot be covered by our dependent
  relators without causing universe inconsistency issues.

  Finding the head terms [f] and [g], then locating a property
  [Related R' f g] is rather straightforward, however in this case we
  must only drop the last [n] arguments from the applications before
  we look up the [Related] instance, with no way of guessing the
  correct value of [n]. We want to avoid having to peel off arguments
  one by one and performing a [Related] search at each step, so we ask
  the user to pitch in and declare instances of [Params f n] and
  [Params g n] to guide our search when partial applications with
  heads [f] and [g] are involved.

  Note that the term in the goal itself may only be partially
  applied. Suppose [f x1 x2 ... xn] is in expecting [p] more
  arguments, and that we find an instance of [Params f q]; then we
  should only drop [q - p] arguments to obtain the prefix
  [f x1 x2 ... x_(n+p-q)].

  The class [QueryParams m1 m2 n] asserts that the head terms of [m1]
  and [m2] have [Params] declarations that instruct us to remove [n]
  arguments from each of them before looking up a corresponding
  relational property. *)

Class QueryParams {A B} (m1: A) (m2: B) (n: nat).

(** If the head term on either side is an existential variable, we
  only check [Params] declarations for the other side. This auxiliary
  lemma is used to trigger this step; [p] should be the number of
  unapplied arguments in whichever term [m1] of [m2] we extracted the
  non-existential head term [h] from. *)

Lemma query_params_one {A B C} (h: A) p (m1: B) (m2: C) n:
  Params h (p + n) ->
  QueryParams m1 m2 n.
Proof.
  constructor.
Qed.

(** If neither head term is an existential variable, then the [Params]
  declarations for both should agree. *)

Lemma query_params_both {A B C D} (h1: A) (h2: B) p1 p2 (m1: C) (m2: D) n:
  Params h1 (p1 + n) ->
  Params h2 (p2 + n) ->
  QueryParams m1 m2 n.
Proof.
  constructor.
Qed.

(** Now we need to choose which one of these lemmas to apply in a
  given situation, and compute the appropriate values for [p].
  We compute [p] by essentially counting the products in the type of
  the related terms [m]. Note that we need to make sure we "open up"
  types such as [subrel] to expose the products, accomplished here by
  using [eval cbv]. *)

(** FIXME: [count_unapplied_params] fails if [m] has a dependent type,
  due to [t'] being a term under binders rather than a closed term.
  This means [monotonicity] can't handle goal where the related terms
  have dependent types if the corresponding relational property is
  about a partial application. *)

Ltac count_unapplied_params m :=
  let rec count t :=
    lazymatch t with
      | forall x, ?t' => let n := count t' in constr:(S n)
      | _ => constr:(O)
    end in
  let t := type of m in
  let t := eval cbv in t in
  count t.

Ltac query_params m1 m2 :=
  let rec head t := lazymatch t with ?t' _ => head t' | _ => t end in
  let h1 := head m1 in
  let p1 := count_unapplied_params m1 in
  let h2 := head m2 in
  let p2 := count_unapplied_params m2 in
  first
    [ not_evar h1; not_evar h2; eapply (query_params_both h1 h2 p1 p2)
    | not_evar h1; is_evar  h2; eapply (query_params_one h1 p1)
    | is_evar  h1; not_evar h2; eapply (query_params_one h2 p2) ].

Global Hint Extern 10 (QueryParams ?m1 ?m2 _) =>
  query_params m1 m2 : typeclass_instances.

(** Now that we can figure out how many parameters to drop, we use
  that information to construct the pair of prefixes we use to locate
  the relational property. We try the following (in this order):
    - the whole applications [f x1 ... xn] and [g y1 ... yn];
    - prefixes constructed as above from user-declared [Params] instances;
    - the smallest prefix we can obtain by dropping arguments from
      both applications simulataneously.

  Again, we need to take into account that either application could
  contain an eixstential variable. When we encounter an existential
  variable while chopping off arguments, we short-circuit the process
  and simply generate a new evar to serve as the shortened version. *)

Ltac pass_evar_to k :=
  let Av := fresh "A" in evar (Av : Type);
  let A := eval red in Av in clear Av;
  let av := fresh "a" in evar (av : A);
  let a := eval red in av in clear av;
  k a.

(** The class [RemoveParams] implements the concurrent removal of [n]
  parameters from applications [m1] and [m2]. *)

Class RemoveParams {A B C D} (n: nat) (m1: A) (m2: B) (f: C) (g: D).

Ltac remove_params_from n m k :=
  lazymatch n with
    | O => k m
    | S ?n' =>
      lazymatch m with
        | ?m' _ => remove_params_from n' m' k
        | _ => is_evar m; pass_evar_to k
      end
  end.

Ltac remove_params n m1 m2 f g :=
  remove_params_from n m1 ltac:(fun m1' => unify f m1';
    remove_params_from n m2 ltac:(fun m2' => unify g m2')).

Global Hint Extern 1 (RemoveParams ?n ?m1 ?m2 ?f ?g) =>
  remove_params n m1 m2 f g; constructor : typeclass_instances.

(** The class [RemoveAllParams] implements the concurrent removal of
  as many arguments as possible. *)

Class RemoveAllParams {A B C D} (m1: A) (m2: B) (f: C) (g: D).

Ltac remove_all_params_from m k :=
  lazymatch m with
    | ?m' _ => remove_all_params_from m' k
    | _ => not_evar m; k m
  end.

Ltac remove_all_params m1 m2 f g :=
  first
    [ is_evar m2;
      remove_all_params_from m1
        ltac:(fun m1' => unify f m1'; pass_evar_to ltac:(fun m2' => unify g m2'))
    | is_evar m1;
      remove_all_params_from m2
        ltac:(fun m2' => unify g m2'; pass_evar_to ltac:(fun m1' => unify f m1'))
    | lazymatch m1 with ?m1' _ =>
        lazymatch m2 with ?m2' _ =>
          remove_all_params m1' m2' f g
        end
      end
    | not_evar m1; unify f m1;
      not_evar m2; unify g m2 ].

Global Hint Extern 1 (RemoveAllParams ?m1 ?m2 ?f ?g) =>
  remove_all_params m1 m2 f g; constructor : typeclass_instances.

(** *** Selecting a relational property *)

(** With this machinery in place, we can implement the search for
  candidate relational properties to use in conjunction with a given
  goal [Q]. *)

Class CandidateProperty {A B} (R': rel A B) f g (Q: Prop) :=
  candidate_related: R' f g.

Instance as_is_candidate {A B} (R R': rel A B) m1 m2:
  Related m1 m2 R' ->
  CandidateProperty R' m1 m2 (R m1 m2) | 10.
Proof.
  firstorder.
Qed.

Instance remove_params_candidate {A B C D} R (m1: A) (m2: B) R' (f: C) (g: D) n:
  QueryParams m1 m2 n ->
  RemoveParams n m1 m2 f g ->
  Related f g R' ->
  CandidateProperty R' f g (R m1 m2) | 20.
Proof.
  firstorder.
Qed.

Instance remove_all_params_candidate {A B C D} R (m1:A) (m2:B) R' (f:C) (g:D):
  RemoveAllParams m1 m2 f g ->
  Related f g R' ->
  CandidateProperty R' f g (R m1 m2) | 30.
Proof.
  firstorder.
Qed.

(** We also attempt to use any matching hypothesis. This takes
  priority and bypasses any [Params] declaration. We assume that we
  will always want such hypotheses to be used, at least when the left-
  or right-hand side matches exactly. There is a possibility that this
  ends up being too broad for some applications, for which we'll want
  to restrict ourselves to [Related] instances explicitely defined by
  the user. If this turns out to be the case, we can introduce an
  intermediate class with more parameters to control the sources of
  the relational properties we use, and perhaps have some kind of
  normalization process akin to what is done in [Coq.Classes.Morphisms].

  We don't hesitate to instantiate evars in the goal or hypothesis; if
  the types or skeletons are compatible this is likely what we want.
  In one practical case where this is needed, my hypothesis is
  something like [R (f ?x1 ?y1 42) (f ?x2 ?y2 24)], and I want
  [?x1], [?x2], [?y1], [?y2] to be matched against the goal. In case
  the use of [unify] below is too broad, we could develop a strategy
  whereby at least one of the head terms [f], [g] should match exactly.

  We also consider the possibility that the relation's arguments may
  be flipped in the hypothesis. In that case we wrap the relation with
  [flip] to construct a corresponding [CandidateProperty]. This [flip]
  will most likely be handled at the [RElim] stage by [flip_relim].
  The hypothesis relation itself may be of the form [flip R]. In that
  case, the [CandidateProperty] will use [flip (flip R)] and
  [flip_relim] will simply be used twice. In more common and subtle
  variation, the hypothesis relation is not directly of this form, but
  should either be instantiated or refined (through [subrel]) into
  such a form. This is handled by [rimpl_flip_subrel].

  Such issues are especially common when solving a goal of the
  form [(R --> R') f g], or goals generated by the setoid rewriting
  system of the form [Proper (?R1 ==> ... ==> ?Rn ==> flip impl)],
  and where the [?Ri]s will generally need to be instantiated as
  [flip ?Ri']. We do not pursue a similar strategy when looking up
  candidates from the typeclass instance database, because we expect
  the user to normalize such properties before they declare them, for
  example declare an instance of [Related (R1 ++> R2 --> R3) g f]
  rather than an instance of [Related (R1 --> R2 ++> flip R3) f g].

  Note that it is important that we reduce the goal to [?R ?m ?n]
  before we use [eexact]: if the relation in the hypothesis is an
  existential variable, we don't want it unified against
  [CandidateProperty _ _ _ (_ ?m ?n)]. *)

Lemma flip_context_candidate {A B} (R: rel A B) x y : R y x -> flip R x y.
Proof.
  firstorder.
Qed.

Ltac context_candidate :=
  let rec is_prefix f m :=
    first
      [ unify f m
      | lazymatch m with ?n _ => is_prefix f n end ] in
  let rec is_prefixable f m :=
    first
      [ is_evar f
      | is_evar m
      | unify f m
      | lazymatch m with ?n _ => is_prefixable f n end ] in
  multimatch goal with
    | H: _ ?f ?g |- @CandidateProperty ?A ?B ?R ?x ?y (_ ?m ?n) =>
      red;
      once first
        [ is_prefix f m; is_prefixable g n
        | is_prefix g n; is_prefixable f m
        | is_prefix g m; is_prefixable f n; apply flip_context_candidate
        | is_prefix f n; is_prefixable g m; apply flip_context_candidate ];
      eexact H
  end.

Global Hint Extern 1 (CandidateProperty _ _ _ _) =>
  context_candidate : typeclass_instances.

(** *** Using [subrel] *)

(** It is not obvious at what point in the process [subrel] should be
  hooked in. One thing we crucially want to avoid is an open-ended
  [subrel] search enumerating all possibilities to be filtered later,
  with a high potential for exponential blow-up should the user be a
  little too liberal with the [subrel] instances they declare.

  Here I choose to have it kick in after a candidate property has been
  selected, and we know how to apply it to a goal. Then we use
  [subrel] to bridge any gap between that goal and the actual one,
  through the [RImpl] class below.

  This is a conservative solution which precludes many interesting
  usages of [subrel]. For instance, suppose we have a relational
  property alogn the lines of [Monotonic f ((R1 ++> R1) ∩ (R2 ++> R2))].
  We would want to be able to use it to show that [f] preserve [R1] or
  [R2] individually (because [subrel (R1 ++> R1) ((R1 ++> R1) ∩ (R2
  ++> R2))], but also together (because [subrel (R1 ∩ R2 ++> R1 ∩ R2)
  ((R1 ++> R1) ∩ (R2 ++> R2))]). This cannot be done using this
  approach, which does not act on the relational property itself but
  only the goal we're attempting to prove.

  Perhaps in the future we can extend this by acting at the level of
  [RElim]. In any case, we should provide explicit guidelines for when
  to declare [subrel] instances, and how. *)

Class RImpl (P Q: Prop): Prop :=
  rimpl: P -> Q.

(** While we give priority to [rimpl_refl] below, when it doesn't work
  we use [RAuto] to establish a [subrel] property. The [Monotonic]
  instances we declared alongside relators can be used conjunction
  with [Monotonicity] to break up [subrel] goals along the structure
  of the relations being considered. This may end up causing loops
  (especially in failure cases), so it may be necessary to add some
  flag in the context to prevent [rimpl_subrel] from being used when
  discharging the [subrel] goals themselves. *)

Global Instance rimpl_refl {A B} (R : rel A B) m n:
  RImpl (R m n) (R m n).
Proof.
  firstorder.
Qed.

Global Instance rimpl_subrel {A B} (R R': rel A B) m n:
  NonDelayed (RAuto (subrel R R')) ->
  RImpl (R m n) (R' m n).
Proof.
  firstorder.
Qed.

Global Instance rimpl_flip_subrel {A B} R R' (x: A) (y: B):
  NonDelayed (RAuto (subrel R (flip R'))) ->
  RImpl (R x y) (R' y x) | 2.
Proof.
  firstorder.
Qed.

(** *** Main tactic *)

(** With these components, defining the [monotonicity] tactic is
  straightforward: identify a candidate property, then figure out a
  way to apply it to the goal [Q] using the [RElim] class. We first
  define a [Monotonicity] typeclass that captures this behavior with
  full backtracking ability. *)

Class Monotonicity (P Q: Prop): Prop :=
  monotonicity: P -> Q.

Global Instance apply_candidate {A B} (R: rel A B) m n P Q Q':
  CandidateProperty R m n Q ->
  RElim R m n P Q' ->
  RImpl Q' Q ->
  Monotonicity P Q.
Proof.
  firstorder.
Qed.

(** The Ltac tactic simply applies [monotonicity]; typeclass
  resolution will do the rest. Note that using [apply] naively is too
  lenient because in a goal of type [A -> B], it will end up unifying
  [A] with [P] and [B] with [Q] instead of setting [Q := A -> B] and
  generating a new subgoal for [P] as expected. On the other hand,
  using [refine] directly is too restrictive because it will not unify
  the type of [monotonicity] against the goal if existential variables
  are present in one or the other. Hence we constrain apply just
  enough, so as to handle both of these cases. *)

Ltac monotonicity :=
  lazymatch goal with |- ?Q => apply (monotonicity (Q:=Q)) end;
  Delay.split_conjunction.

(** Another way to use [Monotonicity] is to hook it as an [RStep]
  instance. *)

Global Instance monotonicity_rstep {A B} (P: Prop) (R: rel A B) m n:
  PolarityResolved R ->
  Monotonicity P (R m n) ->
  RStep P (R m n) | 50.
Proof.
  firstorder.
Qed.

(** *** [subrel] constraint as a subgoal *)

(** When [monotonicity] fails it can be hard to figure out what is
  going wrong, especially if the problem occurs in the [subrel] goal
  of [rimpl_subrel]. The following tactic emits this constraint as a
  subgoal instead of solving it with [RAuto], so that the user can
  figure out what's broken and/or prove it manually in contexts where
  an automatic resolution is tricky.  *)

Class SubrelMonotonicity (P Q: Prop): Prop :=
  subrel_monotonicity: P -> Q.

Global Instance apply_candidate_subrel {A B C D} (R: rel A B) m n P Rc Rg x y:
  CandidateProperty R m n (Rg x y) ->
  RElim R m n P (Rc x y) ->
  SubrelMonotonicity (@subrel C D Rc Rg /\ P) (Rg x y).
Proof.
  firstorder.
Qed.

Ltac subrel_monotonicity :=
  lazymatch goal with |- ?Q => apply (subrel_monotonicity (Q:=Q)) end;
  Delay.split_conjunction.

(** ** Generic instances *)

(** When all else fail, we would like to fall back on a behavior
  similar to that of [f_equal]. To that end, we add a default
  [CandidateProperty] that identifies the longest common prefix of the
  applications in the goal and asserts that they are equal. *)

Class CommonPrefix {A B C} (m1: A) (m2: B) (f: C).

Ltac common_prefix m1 m2 f :=
  first
    [ not_evar m1; not_evar m2;
      unify m1 m2; unify f m1
    | lazymatch m1 with ?m1' _ =>
        lazymatch m2 with ?m2' _ =>
          common_prefix m1' m2' f
        end
      end
    | unify m1 m2; unify f m1 ].

Global Hint Extern 1 (CommonPrefix ?m1 ?m2 ?f) =>
  common_prefix m1 m2 f; constructor : typeclass_instances.

Global Instance eq_candidate {A B C} R (m1: A) (m2: B) (f: C):
  CommonPrefix m1 m2 f ->
  CandidateProperty eq f f (R m1 m2) | 100.
Proof.
  firstorder.
Qed.

(** Then, we can use the following [RElim] instance to obtain the
  behavior of the [f_equal] tactic.

  In practice, I find that [f_equal_relim] is too broadly applicable.
  In situations where a relational property is missing or inapplicable
  for some reason, we would like [repeat rstep] to leave us in a
  situation where we can examine what is going wrong, or do a manual
  proof when necessary. If we use [f_equal]-like behavior as a
  default, we will instead be left several step further, where it is
  no longer obvious which function is involved, and where the goal may
  not be provable anymore.

  With that said, if you would like to switch [f_equal] on, you can
  register [f_equal_elim] as an instance with the following hint:
<<
    Hint Extern 1 (RElim (@eq (_ -> _)) _ _ _ _) =>
      eapply f_equal_relim : typeclass_instances.
>> *)

Lemma f_equal_relim {A B} f g m n P Q:
  RElim eq (f m) (g n) P Q ->
  RElim (@eq (A -> B)) f g (m = n /\ P) Q.
Proof.
  intros Helim Hf [Hmn HP].
  apply Helim; eauto.
  congruence.
Qed.

(** Note that thanks to [eq_subrel], this will also apply to a goal
  that uses a [Reflexive] relation, not just a goal that uses [eq].
  In fact, this subsumes the [reflexivity] tactic as well, which
  corresponds to the special case where all arguments are equal;
  in that case [relim_base] can be used directly and [f_equal_elim] is
  not necessary. *)