(** * Equiv: Program Equivalence *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Logic.FunctionalExtensionality.
From PLF Require Export Imp.

(** *** Before You Get Started:

    - Create a fresh directory for this volume. (Do not try to mix the
      files from this volume with files from _Logical Foundations_ in
      the same directory: the result will not make you happy.)  You
      can either start with an empty directory and populate it with
      the files listed below, or else download the whole PLF zip file
      and unzip it.

    - The new directory should contain at least the following files:
         - [Imp.v] (make sure it is the one from the PLF distribution,
           not the one from LF: they are slightly different);
         - [Maps.v] (ditto)
         - [Equiv.v] (this file)
         - [_CoqProject], containing the following line:

           -Q . PLF

    - If you see errors like this...

             Compiled library PLF.Maps (in file
             /Users/.../plf/Maps.vo) makes inconsistent assumptions
             over library Coq.Init.Logic

      ... it may mean something went wrong with the above steps.
      Doing "[make clean]" (or manually removing everything except
      [.v] and [_CoqProject] files) may help.

    - If you are using VSCode with the VSCoq extension, you'll then
      want to open a new window in VSCode, click [Open Folder > plf],
      and run [make].  If you get an error like "Cannot find a
      physical path..." error, it may be because you didn't open plf
      directly (you instead opened a folder containing both lf and
      plf, for example). *)

(** *** Advice for Working on Exercises:

    - Most of the Coq proofs we ask you to do in this chapter are
      similar to proofs that we've provided.  Before starting to work
      on exercises, take the time to work through our proofs (both
      informally and in Coq) and make sure you understand them in
      detail.  This will save you a lot of time.

    - The Coq proofs we're doing now are sufficiently complicated that
      it is more or less impossible to complete them by random
      experimentation or following your nose.  You need to start with
      an idea about why the property is true and how the proof is
      going to go.  The best way to do this is to write out at least a
      sketch of an informal proof on paper -- one that intuitively
      convinces you of the truth of the theorem -- before starting to
      work on the formal one.  Alternately, grab a friend and try to
      convince them that the theorem is true; then try to formalize
      your explanation.

    - Use automation to save work!  The proofs in this chapter can get
      pretty long if you try to write out all the cases explicitly. *)

(* ################################################################# *)
(** * Behavioral Equivalence *)

(** In an earlier chapter, we investigated the correctness of a very
    simple program transformation: the [optimize_0plus] function.  The
    programming language we were considering was the first version of
    the language of arithmetic expressions -- with no variables -- so
    in that setting it was very easy to define what it means for a
    program transformation to be correct: it should always yield a
    program that evaluates to the same number as the original.

    To talk about the correctness of program transformations for the
    full Imp language -- in particular, assignment -- we need to
    consider the role of mutable state and develop a more
    sophisticated notion of correctness, which we'll call _behavioral
    equivalence_.. *)

(* ================================================================= *)
(** ** Definitions *)

(** For [aexp]s and [bexp]s with variables, the definition we want is
    clear: Two [aexp]s or [bexp]s are "behaviorally equivalent" if
    they evaluate to the same result in every state. *)

Definition aequiv (a1 a2 : aexp) : Prop :=
  forall (st : state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall (st : state),
    beval st b1 = beval st b2.

(** Here are some simple examples of equivalences of arithmetic
    and boolean expressions. *)

Theorem aequiv_example:
  aequiv
    <{ X - X }>
    <{ 0 }>.
Proof.
  intros st. simpl. lia.
Qed.

Theorem bequiv_example:
  bequiv
    <{ X - X = 0 }>
    <{ true }>.
Proof.
  intros st. unfold beval.
  rewrite aequiv_example. reflexivity.
Qed.

(** For commands, the situation is a little more subtle.  We
    can't simply say "two commands are behaviorally equivalent if they
    evaluate to the same ending state whenever they are started in the
    same initial state," because some commands, when run in some
    starting states, don't terminate in any final state at all!

    What we need instead is this: two commands are behaviorally
    equivalent if, for any given starting state, they either (1) both
    diverge or (2) both terminate in the same final state.  A compact
    way to express this is "if the first one terminates in a
    particular state then so does the second, and vice versa." *)

Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (st =[ c1 ]=> st') <-> (st =[ c2 ]=> st').

Definition refines (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (st =[ c1 ]=> st') -> (st =[ c2 ]=> st').

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

(** For examples of command equivalence, let's start by looking at
    some trivial program equivalences involving [skip]: *)

Theorem skip_left : forall c,
  cequiv
    <{ skip; c }>
    c.
Proof.
  (* WORKED IN CLASS *)
  intros c st st'.
  split; intros H.
  - (* -> *)
    inversion H. subst.
    inversion H2. subst.
    assumption.
  - (* <- *)
    apply E_Seq with st.
    apply E_Skip.
    assumption.
Qed.

(** **** Exercise: 2 stars, standard (skip_right)

    Prove that adding a [skip] after a command results in an
    equivalent program *)

Theorem skip_right : forall c,
  cequiv
    <{ c ; skip }>
    c.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Similarly, here is a simple equivalence that optimizes [if]
    commands: *)

Theorem if_true_simple : forall c1 c2,
  cequiv
    <{ if true then c1 else c2 end }>
    c1.
Proof.
  intros c1 c2.
  split; intros H.
  - (* -> *)
    inversion H; subst. assumption. discriminate.
  - (* <- *)
    apply E_IfTrue. reflexivity. assumption.  Qed.

(** Of course, no (human) programmer would write a conditional whose
    condition is literally [true].  But they might write one whose
    condition is _equivalent_ to true:

    _Theorem_: If [b] is equivalent to [true], then [if b then c1
    else c2 end] is equivalent to [c1].
   _Proof_:

     - ([->]) We must show, for all [st] and [st'], that if [st =[
       if b then c1 else c2 end ]=> st'] then [st =[ c1 ]=> st'].

       Proceed by cases on the rules that could possibly have been
       used to show [st =[ if b then c1 else c2 end ]=> st'], namely
       [E_IfTrue] and [E_IfFalse].

       - Suppose the final rule in the derivation of [st =[ if b
         then c1 else c2 end ]=> st'] was [E_IfTrue].  We then have,
         by the premises of [E_IfTrue], that [st =[ c1 ]=> st'].
         This is exactly what we set out to prove.

       - On the other hand, suppose the final rule in the derivation
         of [st =[ if b then c1 else c2 end ]=> st'] was [E_IfFalse].
         We then know that [beval st b = false] and [st =[ c2 ]=> st'].

         Recall that [b] is equivalent to [true], i.e., forall [st],
         [beval st b = beval st <{true}> ].  In particular, this means
         that [beval st b = true], since [beval st <{true}> = true].  But
         this is a contradiction, since [E_IfFalse] requires that
         [beval st b = false].  Thus, the final rule could not have
         been [E_IfFalse].

     - ([<-]) We must show, for all [st] and [st'], that if
       [st =[ c1 ]=> st'] then
       [st =[ if b then c1 else c2 end ]=> st'].

       Since [b] is equivalent to [true], we know that [beval st b] =
       [beval st <{true}> ] = [true].  Together with the assumption that
       [st =[ c1 ]=> st'], we can apply [E_IfTrue] to derive
       [st =[ if b then c1 else c2 end ]=> st'].  []

   Here is the formal version of this proof: *)

Theorem if_true: forall b c1 c2,
  bequiv b <{true}>  ->
  cequiv
    <{ if b then c1 else c2 end }>
    c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - (* -> *)
    inversion H. subst.
    + (* b evaluates to true *)
      assumption.
    + (* b evaluates to false (contradiction) *)
      unfold bequiv in Hb. simpl in Hb.
      rewrite Hb in H5.
      discriminate.
  - (* <- *)
    apply E_IfTrue; try assumption.
    unfold bequiv in Hb. simpl in Hb.
    apply Hb. Qed.

(** **** Exercise: 2 stars, standard, especially useful (if_false) *)
Theorem if_false : forall b c1 c2,
  bequiv b <{false}> ->
  cequiv
    <{ if b then c1 else c2 end }>
    c2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (swap_if_branches)

    Show that we can swap the branches of an [if] if we also negate its
    condition. *)

Theorem swap_if_branches : forall b c1 c2,
  cequiv
    <{ if b then c1 else c2 end }>
    <{ if ~ b then c2 else c1 end }>.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For [while] loops, we can give a similar pair of theorems.  A loop
    whose guard is equivalent to [false] is equivalent to [skip],
    while a loop whose guard is equivalent to [true] is equivalent to
    [while true do skip end] (or any other non-terminating program). *)

(** The first of these facts is easy. *)

Theorem while_false : forall b c,
  bequiv b <{false}> ->
  cequiv
    <{ while b do c end }>
    <{ skip }>.
Proof.
  intros b c Hb. split; intros H.
  - (* -> *)
    inversion H. subst.
    + (* E_WhileFalse *)
      apply E_Skip.
    + (* E_WhileTrue *)
      rewrite Hb in H2. discriminate.
  - (* <- *)
    inversion H. subst.
    apply E_WhileFalse.
    apply Hb.  Qed.

(** **** Exercise: 2 stars, advanced, optional (while_false_informal)

    Write an informal proof of [while_false].

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

(** To prove the second fact, we need an auxiliary lemma stating that
    [while] loops whose guards are equivalent to [true] never
    terminate. *)

(** _Lemma_: If [b] is equivalent to [true], then it cannot be
    the case that [st =[ while b do c end ]=> st'].

    _Proof_: Suppose that [st =[ while b do c end ]=> st'].  We show,
    by induction on a derivation of [st =[ while b do c end ]=> st'],
    that this assumption leads to a contradiction. The only two cases
    to consider are [E_WhileFalse] and [E_WhileTrue], the others
    are contradictory.

    - Suppose [st =[ while b do c end ]=> st'] is proved using rule
      [E_WhileFalse].  Then by assumption [beval st b = false].  But
      this contradicts the assumption that [b] is equivalent to
      [true].

    - Suppose [st =[ while b do c end ]=> st'] is proved using rule
      [E_WhileTrue].  We must have that:

      1. [beval st b = true],
      2. there is some [st0] such that [st =[ c ]=> st0] and
         [st0 =[ while b do c end ]=> st'],
      3. and we are given the induction hypothesis that
         [st0 =[ while b do c end ]=> st'] leads to a contradiction,

      We obtain a contradiction by 2 and 3. [] *)

Lemma while_true_nonterm : forall b c st st',
  bequiv b <{true}> ->
  ~( st =[ while b do c end ]=> st' ).
Proof.
  (* WORKED IN CLASS *)
  intros b c st st' Hb.
  intros H.
  remember <{ while b do c end }> as cw eqn:Heqcw.
  induction H;
  (* Most rules don't apply; we rule them out by inversion: *)
  inversion Heqcw; subst; clear Heqcw.
  (* The two interesting cases are the ones for while loops: *)
  - (* E_WhileFalse *) (* contradictory -- b is always true! *)
    unfold bequiv in Hb.
    (* [rewrite] is able to instantiate the quantifier in [st] *)
    rewrite Hb in H. discriminate.
  - (* E_WhileTrue *) (* immediate from the IH *)
    apply IHceval2. reflexivity.  Qed.

(** **** Exercise: 2 stars, standard, optional (while_true_nonterm_informal)

    Explain what the lemma [while_true_nonterm] means in English.

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

(** **** Exercise: 2 stars, standard, especially useful (while_true)

    Prove the following theorem. _Hint_: You'll want to use
    [while_true_nonterm] here. *)

Theorem while_true : forall b c,
  bequiv b <{true}>  ->
  cequiv
    <{ while b do c end }>
    <{ while true do skip end }>.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** A more interesting fact about [while] commands is that any number
    of copies of the body can be "unrolled" without changing meaning.

    Loop unrolling is an important transformation in any real
    compiler, so its correctness is of more than academic interest! *)

Theorem loop_unrolling : forall b c,
  cequiv
    <{ while b do c end }>
    <{ if b then c ; while b do c end else skip end }>.
Proof.
  (* WORKED IN CLASS *)
  intros b c st st'.
  split; intros Hce.
  - (* -> *)
    inversion Hce; subst.
    + (* loop doesn't run *)
      apply E_IfFalse. assumption. apply E_Skip.
    + (* loop runs *)
      apply E_IfTrue. assumption.
      apply E_Seq with (st' := st'0). assumption. assumption.
  - (* <- *)
    inversion Hce; subst.
    + (* loop runs *)
      inversion H5; subst.
      apply E_WhileTrue with (st' := st'0).
      assumption. assumption. assumption.
    + (* loop doesn't run *)
      inversion H5; subst. apply E_WhileFalse. assumption.  Qed.

(** **** Exercise: 2 stars, standard, optional (seq_assoc) *)
Theorem seq_assoc : forall c1 c2 c3,
  cequiv <{(c1;c2);c3}> <{c1;(c2;c3)}>.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Proving program properties involving assignments is one place
    where the fact that program states are treated extensionally
    (e.g., [x !-> m x ; m] and [m] are equal maps) comes in handy. *)

Theorem identity_assignment : forall x,
  cequiv
    <{ x := x }>
    <{ skip }>.
Proof.
  intros.
  split; intro H; inversion H; subst; clear H.
  - (* -> *)
    rewrite t_update_same.
    apply E_Skip.
  - (* <- *)
    assert (Hx : st' =[ x := x ]=> (x !-> st' x ; st')).
    { apply E_Asgn. reflexivity. }
    rewrite t_update_same in Hx.
    apply Hx.
Qed.

(** **** Exercise: 2 stars, standard, especially useful (assign_aequiv) *)
Theorem assign_aequiv : forall (X : string) (a : aexp),
  aequiv <{ X }> a ->
  cequiv <{ skip }> <{ X := a }>.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (equiv_classes) *)

(** Given the following programs, group together those that are
    equivalent in Imp. Your answer should be given as a list of lists,
    where each sub-list represents a group of equivalent programs. For
    example, if you think programs (a) through (h) are all equivalent
    to each other, but not to (i), your answer should look like this:

       [ [prog_a;prog_b;prog_c;prog_d;prog_e;prog_f;prog_g;prog_h] ;
         [prog_i] ]

    Write down your answer below in the definition of
    [equiv_classes]. *)

Definition prog_a : com :=
  <{ while ~(X <= 0) do
       X := X + 1
     end }>.

Definition prog_b : com :=
  <{ if (X = 0) then
       X := X + 1;
       Y := 1
     else
       Y := 0
     end;
     X := X - Y;
     Y := 0 }>.

Definition prog_c : com :=
  <{ skip }> .

Definition prog_d : com :=
  <{ while X <> 0 do
       X := (X * Y) + 1
     end }>.

Definition prog_e : com :=
  <{ Y := 0 }>.

Definition prog_f : com :=
  <{ Y := X + 1;
     while X <> Y do
       Y := X + 1
     end }>.

Definition prog_g : com :=
  <{ while true do
       skip
     end }>.

Definition prog_h : com :=
  <{ while X <> X do
       X := X + 1
     end }>.

Definition prog_i : com :=
  <{ while X <> Y do
       X := Y + 1
     end }>.

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

(* Do not modify the following line: *)
Definition manual_grade_for_equiv_classes : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * Properties of Behavioral Equivalence *)

(** We next consider some fundamental properties of program
    equivalence. *)

(* ================================================================= *)
(** ** Behavioral Equivalence Is an Equivalence *)

(** First, let's verify that the equivalences on [aexps], [bexps], and
    [com]s really are _equivalences_ -- i.e., that they are reflexive,
    symmetric, and transitive.  The proofs are all easy. *)

Lemma refl_aequiv : forall (a : aexp),
  aequiv a a.
Proof.
  intros a st. reflexivity.  Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
  aequiv a1 a2 -> aequiv a2 a1.
Proof.
  intros a1 a2 H. intros st. symmetry. apply H.  Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
  aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof.
  unfold aequiv. intros a1 a2 a3 H12 H23 st.
  rewrite (H12 st). rewrite (H23 st). reflexivity.  Qed.

Lemma refl_bequiv : forall (b : bexp),
  bequiv b b.
Proof.
  unfold bequiv. intros b st. reflexivity.  Qed.

Lemma sym_bequiv : forall (b1 b2 : bexp),
  bequiv b1 b2 -> bequiv b2 b1.
Proof.
  unfold bequiv. intros b1 b2 H. intros st. symmetry. apply H.  Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
  bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof.
  unfold bequiv. intros b1 b2 b3 H12 H23 st.
  rewrite (H12 st). rewrite (H23 st). reflexivity.  Qed.

Lemma refl_cequiv : forall (c : com),
  cequiv c c.
Proof.
  unfold cequiv. intros c st st'. reflexivity.  Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 -> cequiv c2 c1.
Proof.
  unfold cequiv. intros c1 c2 H st st'.
  rewrite H. reflexivity.
Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
  cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
  unfold cequiv. intros c1 c2 c3 H12 H23 st st'.
  rewrite H12. apply H23.
Qed.

(* ================================================================= *)
(** ** Behavioral Equivalence Is a Congruence *)

(** Less obviously, behavioral equivalence is also a _congruence_.
    That is, the equivalence of two subprograms implies the
    equivalence of the larger programs in which they are embedded:

                 aequiv a a'
         -------------------------
         cequiv (x := a) (x := a')

              cequiv c1 c1'
              cequiv c2 c2'
         --------------------------
         cequiv (c1;c2) (c1';c2')

    ... and so on for the other forms of commands. *)

(** (Note that we are using the inference rule notation here not
    as part of an inductive definition, but simply to write down some
    valid implications in a readable format. We prove these
    implications below.) *)

(** We will see a concrete example of why these congruence
    properties are important in the following section (in the proof of
    [fold_constants_com_sound]), but the main idea is that they allow
    us to replace a small part of a large program with an equivalent
    small part and know that the whole large programs are equivalent
    _without_ doing an explicit proof about the parts that didn't
    change -- i.e., the "proof burden" of a small change to a large
    program is proportional to the size of the change, not the
    program! *)

Theorem CAsgn_congruence : forall x a a',
  aequiv a a' ->
  cequiv <{x := a}> <{x := a'}>.
Proof.
  intros x a a' Heqv st st'.
  split; intros Hceval.
  - (* -> *)
    inversion Hceval. subst. apply E_Asgn.
    rewrite Heqv. reflexivity.
  - (* <- *)
    inversion Hceval. subst. apply E_Asgn.
    rewrite Heqv. reflexivity.  Qed.

(** The congruence property for loops is a little more interesting,
    since it requires induction.

    _Theorem_: Equivalence is a congruence for [while] -- that is, if
    [b] is equivalent to [b'] and [c] is equivalent to [c'], then
    [while b do c end] is equivalent to [while b' do c' end].

    _Proof_: Suppose [b] is equivalent to [b'] and [c] is
    equivalent to [c'].  We must show, for every [st] and [st'], that
    [st =[ while b do c end ]=> st'] iff [st =[ while b' do c'
    end ]=> st'].  We consider the two directions separately.

      - ([->]) We show that [st =[ while b do c end ]=> st'] implies
        [st =[ while b' do c' end ]=> st'], by induction on a
        derivation of [st =[ while b do c end ]=> st'].  The only
        nontrivial cases are when the final rule in the derivation is
        [E_WhileFalse] or [E_WhileTrue].

          - [E_WhileFalse]: In this case, the form of the rule gives us
            [beval st b = false] and [st = st'].  But then, since
            [b] and [b'] are equivalent, we have [beval st b' =
            false], and [E_WhileFalse] applies, giving us
            [st =[ while b' do c' end ]=> st'], as required.

          - [E_WhileTrue]: The form of the rule now gives us [beval st
            b = true], with [st =[ c ]=> st'0] and [st'0 =[ while
            b do c end ]=> st'] for some state [st'0], with the
            induction hypothesis [st'0 =[ while b' do c' end ]=>
            st'].

            Since [c] and [c'] are equivalent, we know that [st =[
            c' ]=> st'0].  And since [b] and [b'] are equivalent,
            we have [beval st b' = true].  Now [E_WhileTrue] applies,
            giving us [st =[ while b' do c' end ]=> st'], as
            required.

      - ([<-]) Similar. [] *)

Theorem CWhile_congruence : forall b b' c c',
  bequiv b b' -> cequiv c c' ->
  cequiv <{ while b do c end }> <{ while b' do c' end }>.
Proof.
  (* WORKED IN CLASS *)

  (* We will prove one direction in an "assert"
     in order to reuse it for the converse. *)
  assert (A: forall (b b' : bexp) (c c' : com) (st st' : state),
             bequiv b b' -> cequiv c c' ->
             st =[ while b do c end ]=> st' ->
             st =[ while b' do c' end ]=> st').
  { unfold bequiv,cequiv.
    intros b b' c c' st st' Hbe Hc1e Hce.
    remember <{ while b do c end }> as cwhile
      eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    + (* E_WhileFalse *)
      apply E_WhileFalse. rewrite <- Hbe. apply H.
    + (* E_WhileTrue *)
      apply E_WhileTrue with (st' := st').
      * (* show loop runs *) rewrite <- Hbe. apply H.
      * (* body execution *)
        apply (Hc1e st st').  apply Hce1.
      * (* subsequent loop execution *)
        apply IHHce2. reflexivity. }

  intros. split.
  - apply A; assumption.
  - apply A.
    + apply sym_bequiv. assumption.
    + apply sym_cequiv. assumption.
Qed.

(** **** Exercise: 3 stars, standard, optional (CSeq_congruence) *)
Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv <{ c1;c2 }> <{ c1';c2' }>.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (CIf_congruence) *)
Theorem CIf_congruence : forall b b' c1 c1' c2 c2',
  bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv <{ if b then c1 else c2 end }>
         <{ if b' then c1' else c2' end }>.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For example, here are two equivalent programs and a proof of their
    equivalence... *)

Example congruence_example:
  cequiv
    (* Program 1: *)
    <{ X := 0;
       if (X = 0) then Y := 0
       else Y := 42 end }>
    (* Program 2: *)
    <{ X := 0;
       if (X = 0) then Y := X - X   (* <--- Changed here *)
       else Y := 42 end }>.
Proof.
  apply CSeq_congruence.
  - apply refl_cequiv.
  - apply CIf_congruence.
    + apply refl_bequiv.
    + apply CAsgn_congruence. unfold aequiv. simpl.
      symmetry. apply minus_diag.
    + apply refl_cequiv.
Qed.

(** **** Exercise: 3 stars, advanced (not_congr)

    We've shown that the [cequiv] relation is both an equivalence and
    a congruence on commands.  Can you think of a relation on commands
    that is an equivalence but _not_ a congruence?  Write down the
    relation (formally), together with an informal sketch of a proof
    that it is an equivalence but not a congruence. *)

(* FILL IN HERE *)
(* Do not modify the following line: *)
Definition manual_grade_for_not_congr : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * Program Transformations *)

(** A _program transformation_ is a function that takes a program as
    input and produces a modified program as output.  Compiler
    optimizations such as constant folding are a canonical example,
    but there are many others. *)

(** A program transformation is said to be _sound_ if it preserves the
    behavior of the original program. *)

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall (a : aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall (b : bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

(* ================================================================= *)
(** ** The Constant-Folding Transformation *)

(** An expression is _constant_ if it contains no variable references.

    Constant folding is an optimization that finds constant
    expressions and replaces them by their values. *)

Fixpoint fold_constants_aexp (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId x        => AId x
  | <{ a1 + a2 }>  =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 + n2)
    | (a1', a2') => <{ a1' + a2' }>
    end
  | <{ a1 - a2 }> =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => <{ a1' - a2' }>
    end
  | <{ a1 * a2 }>  =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => <{ a1' * a2' }>
    end
  end.

Example fold_aexp_ex1 :
    fold_constants_aexp <{ (1 + 2) * X }>
  = <{ 3 * X }>.
Proof. reflexivity. Qed.

(** Note that this version of constant folding doesn't do other
    "obvious" things like eliminating trivial additions (e.g.,
    rewriting [0 + X] to just [X]).: we are focusing attention on a
    single optimization for the sake of simplicity.

    It is not hard to incorporate other ways of simplifying
    expressions -- the definitions and proofs just get longer.  We'll
    consider optimizations in the exercises. *)

Example fold_aexp_ex2 :
  fold_constants_aexp <{ X - ((0 * 6) + Y) }> = <{ X - (0 + Y) }>.
Proof. reflexivity. Qed.

(** Not only can we lift [fold_constants_aexp] to [bexp]s (in the
    [BEq], [BNeq], and [BLe] cases); we can also look for constant
    _boolean_ expressions and evaluate them in-place as well. *)

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | <{true}>        => <{true}>
  | <{false}>       => <{false}>
  | <{ a1 = a2 }>  =>
      match (fold_constants_aexp a1,
             fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if n1 =? n2 then <{true}> else <{false}>
      | (a1', a2') =>
          <{ a1' = a2' }>
      end
  | <{ a1 <> a2 }>  =>
      match (fold_constants_aexp a1,
             fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if negb (n1 =? n2) then <{true}> else <{false}>
      | (a1', a2') =>
          <{ a1' <> a2' }>
      end
  | <{ a1 <= a2 }>  =>
      match (fold_constants_aexp a1,
             fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if n1 <=? n2 then <{true}> else <{false}>
      | (a1', a2') =>
          <{ a1' <= a2' }>
      end
  | <{ a1 > a2 }>  =>
      match (fold_constants_aexp a1,
             fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if n1 <=? n2 then <{false}> else <{true}>
      | (a1', a2') =>
          <{ a1' > a2' }>
      end
  | <{ ~ b1 }>  =>
      match (fold_constants_bexp b1) with
      | <{true}> => <{false}>
      | <{false}> => <{true}>
      | b1' => <{ ~ b1' }>
      end
  | <{ b1 && b2 }>  =>
      match (fold_constants_bexp b1,
             fold_constants_bexp b2) with
      | (<{true}>, <{true}>) => <{true}>
      | (<{true}>, <{false}>) => <{false}>
      | (<{false}>, <{true}>) => <{false}>
      | (<{false}>, <{false}>) => <{false}>
      | (b1', b2') => <{ b1' && b2' }>
      end
  end.

Example fold_bexp_ex1 :
  fold_constants_bexp <{ true && ~(false && true) }>
  = <{ true }>.
Proof. reflexivity. Qed.

Example fold_bexp_ex2 :
  fold_constants_bexp <{ (X = Y) && (0 = (2 - (1 + 1))) }>
  = <{ (X = Y) && true }>.
Proof. reflexivity. Qed.

(** To fold constants in a command, we apply the appropriate folding
    functions on all embedded expressions. *)

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | <{ skip }> =>
      <{ skip }>
  | <{ x := a }> =>
      <{ x := (fold_constants_aexp a) }>
  | <{ c1 ; c2 }>  =>
      <{ fold_constants_com c1 ; fold_constants_com c2 }>
  | <{ if b then c1 else c2 end }> =>
      match fold_constants_bexp b with
      | <{true}>  => fold_constants_com c1
      | <{false}> => fold_constants_com c2
      | b' => <{ if b' then fold_constants_com c1
                       else fold_constants_com c2 end}>
      end
  | <{ while b do c1 end }> =>
      match fold_constants_bexp b with
      | <{true}> => <{ while true do skip end }>
      | <{false}> => <{ skip }>
      | b' => <{ while b' do (fold_constants_com c1) end }>
      end
  end.

Example fold_com_ex1 :
  fold_constants_com
    (* Original program: *)
    <{ X := 4 + 5;
       Y := X - 3;
       if ((X - Y) = (2 + 4)) then skip
       else Y := 0 end;
       if (0 <= (4 - (2 + 1))) then Y := 0
       else skip end;
       while (Y = 0) do
         X := X + 1
       end }>
  = (* After constant folding: *)
    <{ X := 9;
       Y := X - 3;
       if ((X - Y) = 6) then skip
       else Y := 0 end;
       Y := 0;
       while (Y = 0) do
         X := X + 1
       end }>.
Proof. reflexivity. Qed.

(* ================================================================= *)
(** ** Soundness of Constant Folding *)

(** Now we need to show that what we've done is correct. *)

(** Here's the proof for arithmetic expressions: *)

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound. intros a. unfold aequiv. intros st.
  induction a; simpl;
    (* ANum and AId follow immediately *)
    try reflexivity;
    (* APlus, AMinus, and AMult follow from the IH
       and the observation that
              aeval st (<{ a1 + a2 }>)
            = ANum ((aeval st a1) + (aeval st a2))
            = aeval st (ANum ((aeval st a1) + (aeval st a2)))
       (and similarly for AMinus/minus and AMult/mult) *)
    try (destruct (fold_constants_aexp a1);
         destruct (fold_constants_aexp a2);
         rewrite IHa1; rewrite IHa2; reflexivity). Qed.

(** **** Exercise: 3 stars, standard, optional (fold_bexp_Eq_informal)

    Here is an informal proof of the [BEq] case of the soundness
    argument for boolean expression constant folding.  Read it
    carefully and compare it to the formal proof that follows.  Then
    fill in the [BLe] case of the formal proof (without looking at the
    [BEq] case, if possible).

   _Theorem_: The constant folding function for booleans,
   [fold_constants_bexp], is sound.

   _Proof_: We must show that [b] is equivalent to [fold_constants_bexp b],
   for all boolean expressions [b].  Proceed by induction on [b].  We
   show just the case where [b] has the form [a1 = a2].

   In this case, we must show

       beval st <{ a1 = a2 }>
     = beval st (fold_constants_bexp <{ a1 = a2 }>).

   There are two cases to consider:

     - First, suppose [fold_constants_aexp a1 = ANum n1] and
       [fold_constants_aexp a2 = ANum n2] for some [n1] and [n2].

       In this case, we have

           fold_constants_bexp <{ a1 = a2 }>
         = if n1 =? n2 then <{true}> else <{false}>

       and

           beval st <{a1 = a2}>
         = (aeval st a1) =? (aeval st a2).

       By the soundness of constant folding for arithmetic
       expressions (Lemma [fold_constants_aexp_sound]), we know

           aeval st a1
         = aeval st (fold_constants_aexp a1)
         = aeval st (ANum n1)
         = n1

       and

           aeval st a2
         = aeval st (fold_constants_aexp a2)
         = aeval st (ANum n2)
         = n2,

       so

           beval st <{a1 = a2}>
         = (aeval a1) =? (aeval a2)
         = n1 =? n2.

       Also, it is easy to see (by considering the cases [n1 = n2] and
       [n1 <> n2] separately) that

           beval st (if n1 =? n2 then <{true}> else <{false}>)
         = if n1 =? n2 then beval st <{true}> else beval st <{false}>
         = if n1 =? n2 then true else false
         = n1 =? n2.

       So

           beval st (<{ a1 = a2 }>)
         = n1 =? n2.
         = beval st (if n1 =? n2 then <{true}> else <{false}>),

       as required.

     - Otherwise, one of [fold_constants_aexp a1] and
       [fold_constants_aexp a2] is not a constant.  In this case, we
       must show

           beval st <{a1 = a2}>
         = beval st (<{ (fold_constants_aexp a1) =
                         (fold_constants_aexp a2) }>),

       which, by the definition of [beval], is the same as showing

           (aeval st a1) =? (aeval st a2)
         = (aeval st (fold_constants_aexp a1)) =?
                   (aeval st (fold_constants_aexp a2)).

       But the soundness of constant folding for arithmetic
       expressions ([fold_constants_aexp_sound]) gives us

         aeval st a1 = aeval st (fold_constants_aexp a1)
         aeval st a2 = aeval st (fold_constants_aexp a2),

       completing the case.  [] *)

Theorem fold_constants_bexp_sound:
  btrans_sound fold_constants_bexp.
Proof.
  unfold btrans_sound. intros b. unfold bequiv. intros st.
  induction b;
    (* true and false are immediate *)
    try reflexivity.
  - (* BEq *)
    simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
       (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
       (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.
    (* The only interesting case is when both a1 and a2
       become constants after folding *)
      simpl. destruct (n =? n0); reflexivity.
  - (* BNeq *)
    simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
       (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
       (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.
    (* The only interesting case is when both a1 and a2
       become constants after folding *)
      simpl. destruct (n =? n0); reflexivity.
  - (* BLe *)
    (* FILL IN HERE *) admit.
  - (* BGt *)
    (* FILL IN HERE *) admit.
  - (* BNot *)
    simpl. remember (fold_constants_bexp b) as b' eqn:Heqb'.
    rewrite IHb.
    destruct b'; reflexivity.
  - (* BAnd *)
    simpl.
    remember (fold_constants_bexp b1) as b1' eqn:Heqb1'.
    remember (fold_constants_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1. rewrite IHb2.
    destruct b1'; destruct b2'; reflexivity.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (fold_constants_com_sound)

    Complete the [while] case of the following proof. *)

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. intros c.
  induction c; simpl.
  - (* skip *) apply refl_cequiv.
  - (* := *) apply CAsgn_congruence.
              apply fold_constants_aexp_sound.
  - (* ; *) apply CSeq_congruence; assumption.
  - (* if *)
    assert (bequiv b (fold_constants_bexp b)). {
      apply fold_constants_bexp_sound. }
    destruct (fold_constants_bexp b) eqn:Heqb;
      try (apply CIf_congruence; assumption).
      (* (If the optimization doesn't eliminate the if, then the
          result is easy to prove from the IH and
          [fold_constants_bexp_sound].) *)
    + (* b always true *)
      apply trans_cequiv with c1; try assumption.
      apply if_true; assumption.
    + (* b always false *)
      apply trans_cequiv with c2; try assumption.
      apply if_false; assumption.
  - (* while *)
    (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Soundness of (0 + n) Elimination, Redux *)

(** **** Exercise: 4 stars, standard, optional (optimize_0plus_var)

    Recall the definition [optimize_0plus] from the [Imp] chapter
    of _Logical Foundations_:

    Fixpoint optimize_0plus (a:aexp) : aexp :=
      match a with
      | ANum n =>
          ANum n
      | <{ 0 + a2 }> =>
          optimize_0plus a2
      | <{ a1 + a2 }> =>
          <{ (optimize_0plus a1) + (optimize_0plus a2) }>
      | <{ a1 - a2 }> =>
          <{ (optimize_0plus a1) - (optimize_0plus a2) }>
      | <{ a1 * a2 }> =>
          <{ (optimize_0plus a1) * (optimize_0plus a2) }>
      end.

   Note that this function is defined over the old version of [aexp]s,
   without states.

   Write a new version of this function that deals with variables (by
   leaving them alone), plus analogous ones for [bexp]s and commands:

     optimize_0plus_aexp
     optimize_0plus_bexp
     optimize_0plus_com
*)

Fixpoint optimize_0plus_aexp (a : aexp) : aexp
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Fixpoint optimize_0plus_bexp (b : bexp) : bexp
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Fixpoint optimize_0plus_com (c : com) : com
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_optimize_0plus:
    optimize_0plus_com
       <{ while X <> 0 do X := 0 + X - 1 end }>
  =    <{ while X <> 0 do X := X - 1 end }>.
Proof.
  (* FILL IN HERE *) Admitted.

(** Prove that these three functions are sound, as we did for
    [fold_constants_*].  Make sure you use the congruence lemmas in the
    proof of [optimize_0plus_com] -- otherwise it will be _long_! *)

Theorem optimize_0plus_aexp_sound:
  atrans_sound optimize_0plus_aexp.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem optimize_0plus_bexp_sound :
  btrans_sound optimize_0plus_bexp.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem optimize_0plus_com_sound :
  ctrans_sound optimize_0plus_com.
Proof.
  (* FILL IN HERE *) Admitted.

(** Finally, let's define a compound optimizer on commands that first
    folds constants (using [fold_constants_com]) and then eliminates
    [0 + n] terms (using [optimize_0plus_com]). *)

Definition optimizer (c : com) := optimize_0plus_com (fold_constants_com c).

(** Prove that this optimizer is sound. *)

Theorem optimizer_sound :
  ctrans_sound optimizer.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Proving Inequivalence *)

(** Next, let's look at some programs that are _not_ equivalent. *)

(** Suppose that [c1] is a command of the form

       X := a1; Y := a2

    and [c2] is the command

       X := a1; Y := a2'

    where [a2'] is formed by substituting [a1] for all occurrences
    of [X] in [a2].

    For example, [c1] and [c2] might be:

       c1  =  (X := 42 + 53;
               Y := Y + X)
       c2  =  (X := 42 + 53;
               Y := Y + (42 + 53))

    Clearly, this _particular_ [c1] and [c2] are equivalent.  Is this
    true in general? *)

(** We will see in a moment that it is not, but it is worthwhile
    to pause, now, and see if you can find a counter-example on your
    own. *)

(** More formally, here is the function that substitutes an arithmetic
    expression [u] for each occurrence of a given variable [x] in
    another expression [a]: *)

Fixpoint subst_aexp (x : string) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n       =>
      ANum n
  | AId x'       =>
      if String.eqb x x' then u else AId x'
  | <{ a1 + a2 }>  =>
      <{ (subst_aexp x u a1) + (subst_aexp x u a2) }>
  | <{ a1 - a2 }> =>
      <{ (subst_aexp x u a1) - (subst_aexp x u a2) }>
  | <{ a1 * a2 }>  =>
      <{ (subst_aexp x u a1) * (subst_aexp x u a2) }>
  end.

Example subst_aexp_ex :
  subst_aexp X <{42 + 53}> <{Y + X}>
  = <{ Y + (42 + 53)}>.
Proof. simpl. reflexivity. Qed.

(** And here is the property we are interested in, expressing the
    claim that commands [c1] and [c2] as described above are
    always equivalent.  *)

Definition subst_equiv_property : Prop := forall x1 x2 a1 a2,
  cequiv <{ x1 := a1; x2 := a2 }>
         <{ x1 := a1; x2 := subst_aexp x1 a1 a2 }>.

(** Sadly, the property does _not_ always hold.

    Here is a counterexample:

       X := X + 1; Y := X

    If we perform the substitution, we get

       X := X + 1; Y := X + 1

    which clearly isn't equivalent. *)

Theorem subst_inequiv :
  ~ subst_equiv_property.
Proof.
  unfold subst_equiv_property.
  intros Contra.

  (* Here is the counterexample: assuming that [subst_equiv_property]
     holds allows us to prove that these two programs are
     equivalent... *)
  remember <{ X := X + 1;
              Y := X }>
      as c1.
  remember <{ X := X + 1;
              Y := X + 1 }>
      as c2.
  assert (cequiv c1 c2) by (subst; apply Contra).
  clear Contra.

  (* ... allows us to show that the command [c2] can terminate
     in two different final states:
        st1 = (Y !-> 1 ; X !-> 1)
        st2 = (Y !-> 2 ; X !-> 1). *)
  remember (Y !-> 1 ; X !-> 1) as st1.
  remember (Y !-> 2 ; X !-> 1) as st2.
  assert (H1 : empty_st =[ c1 ]=> st1);
  assert (H2 : empty_st =[ c2 ]=> st2);
  try (subst;
       apply E_Seq with (st' := (X !-> 1));
       apply E_Asgn; reflexivity).
  clear Heqc1 Heqc2.

  apply H in H1.
  clear H.

  (* Finally, we use the fact that evaluation is deterministic
     to obtain a contradiction. *)
  assert (Hcontra : st1 = st2)
    by (apply (ceval_deterministic c2 empty_st); assumption).
  clear H1 H2.

  assert (Hcontra' : st1 Y = st2 Y)
    by (rewrite Hcontra; reflexivity).
  subst. discriminate. Qed.

(** **** Exercise: 4 stars, standard, optional (better_subst_equiv)

    The equivalence we had in mind above was not complete nonsense --
    in fact, it was actually almost right.  To make it correct, we
    just need to exclude the case where the variable [X] occurs in the
    right-hand side of the first assignment statement. *)

Inductive var_not_used_in_aexp (x : string) : aexp -> Prop :=
  | VNUNum : forall n, var_not_used_in_aexp x (ANum n)
  | VNUId : forall y, x <> y -> var_not_used_in_aexp x (AId y)
  | VNUPlus : forall a1 a2,
      var_not_used_in_aexp x a1 ->
      var_not_used_in_aexp x a2 ->
      var_not_used_in_aexp x (<{ a1 + a2 }>)
  | VNUMinus : forall a1 a2,
      var_not_used_in_aexp x a1 ->
      var_not_used_in_aexp x a2 ->
      var_not_used_in_aexp x (<{ a1 - a2 }>)
  | VNUMult : forall a1 a2,
      var_not_used_in_aexp x a1 ->
      var_not_used_in_aexp x a2 ->
      var_not_used_in_aexp x (<{ a1 * a2 }>).

Lemma aeval_weakening : forall x st a ni,
  var_not_used_in_aexp x a ->
  aeval (x !-> ni ; st) a = aeval st a.
Proof.
  (* FILL IN HERE *) Admitted.

(** Using [var_not_used_in_aexp], formalize and prove a correct version
    of [subst_equiv_property]. *)

(* FILL IN HERE

    [] *)

(** **** Exercise: 3 stars, standard (inequiv_exercise)

    Prove that an infinite loop is not equivalent to [skip] *)

Theorem inequiv_exercise:
  ~ cequiv <{ while true do skip end }> <{ skip }>.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Extended Exercise: Nondeterministic Imp *)

(** As we have seen (in theorem [ceval_deterministic] in the [Imp]
    chapter), Imp's evaluation relation is deterministic.  However,
    _non_-determinism is an important part of the definition of many
    real programming languages. For example, in many imperative
    languages (such as C and its relatives), the order in which
    function arguments are evaluated is unspecified.  The program
    fragment

      x = 0;
      f(++x, x)

    might call [f] with arguments [(1, 0)] or [(1, 1)], depending how
    the compiler chooses to order things.  This can be a little
    confusing for programmers, but it gives the compiler writer useful
    freedom.

    In this exercise, we will extend Imp with a simple
    nondeterministic command and study how this change affects
    program equivalence.  The new command has the syntax [HAVOC X],
    where [X] is an identifier. The effect of executing [HAVOC X] is
    to assign an _arbitrary_ number to the variable [X],
    nondeterministically. For example, after executing the program:

      HAVOC Y;
      Z := Y * 2

    the value of [Y] can be any number, while the value of [Z] is
    twice that of [Y] (so [Z] is always even). Note that we are not
    saying anything about the _probabilities_ of the outcomes -- just
    that there are (infinitely) many different outcomes that can
    possibly happen after executing this nondeterministic code.

    In a sense, a variable on which we do [HAVOC] roughly corresponds
    to an uninitialized variable in a low-level language like C.  After
    the [HAVOC], the variable holds a fixed but arbitrary number.  Most
    sources of nondeterminism in language definitions are there
    precisely because programmers don't care which choice is made (and
    so it is good to leave it open to the compiler to choose whichever
    will run faster).

    We call this new language _Himp_ (``Imp extended with [HAVOC]''). *)

Module Himp.

(** To formalize Himp, we first add a clause to the definition of
    commands. *)

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CHavoc : string -> com.                (* <--- NEW *)

Notation "'havoc' l" := (CHavoc l)
                          (in custom com at level 60, l constr at level 0).
Notation "'skip'"  :=
         CSkip (in custom com at level 0).
Notation "x := y"  :=
         (CAsgn x y)
            (in custom com at level 0, x constr at level 0,
             y at level 85, no associativity).
Notation "x ; y" :=
         (CSeq x y)
           (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z)
           (in custom com at level 89, x at level 99,
            y at level 99, z at level 99).
Notation "'while' x 'do' y 'end'" :=
         (CWhile x y)
            (in custom com at level 89, x at level 99, y at level 99).

(** **** Exercise: 2 stars, standard (himp_ceval)

    Now, we must extend the operational semantics. We have provided
   a template for the [ceval] relation below, specifying the big-step
   semantics. What rule(s) must be added to the definition of [ceval]
   to formalize the behavior of the [HAVOC] command? *)

Reserved Notation "st '=[' c ']=>' st'"
         (at level 40, c custom com at level 99, st constr,
          st' constr at next level).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ skip ]=> st
  | E_Asgn  : forall st a n x,
      aeval st a = n ->
      st =[ x := a ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=> st'' ->
      st  =[ c1 ; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ while b do c end ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st  =[ c ]=> st' ->
      st' =[ while b do c end ]=> st'' ->
      st  =[ while b do c end ]=> st''
(* FILL IN HERE *)

  where "st =[ c ]=> st'" := (ceval c st st').

(** As a sanity check, the following claims should be provable for
    your definition: *)

Example havoc_example1 : empty_st =[ havoc X ]=> (X !-> 0).
Proof.
(* FILL IN HERE *) Admitted.

Example havoc_example2 :
  empty_st =[ skip; havoc Z ]=> (Z !-> 42).
Proof.
(* FILL IN HERE *) Admitted.

(* Do not modify the following line: *)
Definition manual_grade_for_Check_rule_for_HAVOC : option (nat*string) := None.
(** [] *)

(** Finally, we repeat the definition of command equivalence from above: *)

Definition cequiv (c1 c2 : com) : Prop := forall st st' : state,
  st =[ c1 ]=> st' <-> st =[ c2 ]=> st'.

(** Let's apply this definition to prove some nondeterministic
    programs equivalent / inequivalent. *)

(** **** Exercise: 3 stars, standard (havoc_swap)

    Are the following two programs equivalent? *)

Definition pXY :=
  <{ havoc X ; havoc Y }>.

Definition pYX :=
  <{ havoc Y; havoc X }>.

(** If you think they are equivalent, prove it. If you think they are
    not, prove that. *)

Theorem pXY_cequiv_pYX :
  cequiv pXY pYX \/ ~cequiv pXY pYX.
Proof.
  (* Hint: You may want to use [t_update_permute] at some point,
     in which case you'll probably be left with [X <> Y] as a
     hypothesis. You can use [discriminate] to discharge this. *)
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, standard, optional (havoc_copy)

    Are the following two programs equivalent? *)

Definition ptwice :=
  <{ havoc X; havoc Y }>.

Definition pcopy :=
  <{ havoc X; Y := X }>.

(** If you think they are equivalent, then prove it. If you think they
    are not, then prove that.  (Hint: You may find the [assert] tactic
    useful.) *)

Theorem ptwice_cequiv_pcopy :
  cequiv ptwice pcopy \/ ~cequiv ptwice pcopy.
Proof. (* FILL IN HERE *) Admitted.
(** [] *)

(** The definition of program equivalence we are using here has some
    subtle consequences on programs that may loop forever.  What
    [cequiv] says is that the set of possible _terminating_ outcomes
    of two equivalent programs is the same. However, in a language
    with nondeterminism, like Himp, some programs always terminate,
    some programs always diverge, and some programs can
    nondeterministically terminate in some runs and diverge in
    others. The final part of the following exercise illustrates this
    phenomenon.
*)

(** **** Exercise: 4 stars, advanced (p1_p2_term)

    Consider the following commands: *)

Definition p1 : com :=
  <{ while ~ (X = 0) do
       havoc Y;
       X := X + 1
     end }>.

Definition p2 : com :=
  <{ while ~ (X = 0) do
       skip
     end }>.

(** Intuitively, [p1] and [p2] have the same termination behavior:
    either they loop forever, or they terminate in the same state they
    started in.  We can capture the termination behavior of [p1] and
    [p2] individually with these lemmas: *)

Lemma p1_may_diverge : forall st st', st X <> 0 ->
  ~ st =[ p1 ]=> st'.
Proof. (* FILL IN HERE *) Admitted.

Lemma p2_may_diverge : forall st st', st X <> 0 ->
  ~ st =[ p2 ]=> st'.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced (p1_p2_equiv)

    Use these two lemmas to prove that [p1] and [p2] are actually
    equivalent. *)

Theorem p1_p2_equiv : cequiv p1 p2.
Proof. (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced (p3_p4_inequiv)

    Prove that the following programs are _not_ equivalent.  (Hint:
    What should the value of [Z] be when [p3] terminates?  What about
    [p4]?) *)

Definition p3 : com :=
  <{ Z := 1;
     while X <> 0 do
       havoc X;
       havoc Z
     end }>.

Definition p4 : com :=
  <{ X := 0;
     Z := 1 }>.

Theorem p3_p4_inequiv : ~ cequiv p3 p4.
Proof. (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 5 stars, advanced, optional (p5_p6_equiv)

    Prove that the following commands are equivalent.  (Hint: As
    mentioned above, our definition of [cequiv] for Himp only takes
    into account the sets of possible terminating configurations: two
    programs are equivalent if and only if the set of possible terminating
    states is the same for both programs when given a same starting state
    [st].  If [p5] terminates, what should the final state be? Conversely,
    is it always possible to make [p5] terminate?) *)

Definition p5 : com :=
  <{ while X <> 1 do
       havoc X
     end }>.

Definition p6 : com :=
  <{ X := 1 }>.

Theorem p5_p6_equiv : cequiv p5 p6.
Proof. (* FILL IN HERE *) Admitted.
(** [] *)

End Himp.

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

(** **** Exercise: 3 stars, standard, optional (swap_noninterfering_assignments)

    (Hint: You'll need [functional_extensionality] for this one.) *)

Theorem swap_noninterfering_assignments: forall l1 l2 a1 a2,
  l1 <> l2 ->
  var_not_used_in_aexp l1 a2 ->
  var_not_used_in_aexp l2 a1 ->
  cequiv
    <{ l1 := a1; l2 := a2 }>
    <{ l2 := a2; l1 := a1 }>.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, standard, optional (for_while_equiv)

    This exercise extends the optional [add_for_loop] exercise from
    the [Imp] chapter, where you were asked to extend the language
    of commands with C-style [for] loops.  Prove that the command:

      for (c1; b; c2) {
          c3
      }

    is equivalent to:

       c1;
       while b do
         c3;
         c2
       end
*)
(* FILL IN HERE

    [] *)

(** **** Exercise: 4 stars, advanced, optional (capprox)

    In this exercise we define an asymmetric variant of program
    equivalence we call _program approximation_. We say that a
    program [c1] _approximates_ a program [c2] when, for each of
    the initial states for which [c1] terminates, [c2] also terminates
    and produces the same final state. Formally, program approximation
    is defined as follows: *)

Definition capprox (c1 c2 : com) : Prop := forall (st st' : state),
  st =[ c1 ]=> st' -> st =[ c2 ]=> st'.

(** For example, the program

  c1 = while X <> 1 do
         X := X - 1
       end

    approximates [c2 = X := 1], but [c2] does not approximate [c1]
    since [c1] does not terminate when [X = 0] but [c2] does.  If two
    programs approximate each other in both directions, then they are
    equivalent. *)

(** Find two programs [c3] and [c4] such that neither approximates
    the other. *)

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

Theorem c3_c4_different : ~ capprox c3 c4 /\ ~ capprox c4 c3.
Proof. (* FILL IN HERE *) Admitted.

(** Find a program [cmin] that approximates every other program. *)

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

Theorem cmin_minimal : forall c, capprox cmin c.
Proof. (* FILL IN HERE *) Admitted.

(** Finally, find a non-trivial property which is preserved by
    program approximation (when going from left to right). *)

Definition zprop (c : com) : Prop
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem zprop_preserving : forall c c',
  zprop c -> capprox c c' -> zprop c'.
Proof. (* FILL IN HERE *) Admitted.
(** [] *)

(* 2022-08-08 17:31 *)


Polymorphic Fixpoint g@{i} (t : Type@{i}) (n : nat) : Type@{i} :=
  t.

Module A.
Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} :=
  match n with
  | 0 => t
  | S n => bar t n
  end

with bar (t : Type@{i}) (n : nat) : Type@{i} :=
    match n with
    | 0 => t
    | S n => foo t n
    end.
End A.

Module B.
Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} :=
  match n with
  | 0 => t
  | S n => bar t n
  end

with bar@{i} (t : Type@{i}) (n : nat) : Type@{i} :=
    match n with
    | 0 => t
    | S n => foo t n
    end.
End B.

Module C.
Fail Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} :=
  match n with
  | 0 => t
  | S n => bar t n
  end

with bar@{j} (t : Type@{j}) (n : nat) : Type@{j} :=
    match n with
    | 0 => t
    | S n => foo t n
    end.
End C.

Module D.
Polymorphic Fixpoint foo@{i j} (t : Type@{i}) (n : nat) : Type@{i} :=
  match n with
  | 0 => t
  | S n => bar t n
  end

with bar@{i j} (t : Type@{j}) (n : nat) : Type@{j} :=
    match n with
    | 0 => t
    | S n => foo t n
    end.
End D.

Module E.
Fail Polymorphic Fixpoint foo@{i j} (t : Type@{i}) (n : nat) : Type@{i} :=
  match n with
  | 0 => t
  | S n => bar t n
  end

with bar@{j i} (t : Type@{j}) (n : nat) : Type@{j} :=
    match n with
    | 0 => t
    | S n => foo t n
    end.
End E.

(*
Polymorphic Fixpoint g@{i} (t : Type@{i}) (n : nat) : Type@{i} :=
  t.

Print g.

Polymorphic Fixpoint a@{i} (t : Type@{i}) (n : nat) : Type@{i} :=
  t
with b@{i} (t : Type@{i}) (n : nat) : Type@{i} :=
  t.

Print a.
Print b.
*)

Polymorphic CoInductive foo@{i} (T : Type@{i}) : Type@{i} :=
| A : foo T -> foo T.

Polymorphic CoFixpoint cg@{i} (t : Type@{i}) : foo@{i} t :=
  @A@{i} t (cg t).

Print cg.

Polymorphic CoFixpoint ca@{i} (t : Type@{i}) : foo@{i} t :=
  @A@{i} t (cb t)
with cb@{i} (t : Type@{i}) : foo@{i} t :=
  @A@{i} t (ca t).

Print ca.
Print cb.


(** * [Proper] morphisms for ℤ constants *)
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationPairs.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.LandLorBounds.
Require Import Crypto.Util.ZUtil.Tactics.PeelLe.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Local Open Scope Z_scope.

Module Z.
  (** We prove a bunch of [Proper] lemmas, but do not make them
      instances; making them instances would slow typeclass search
      unacceptably.  In files where we use these, we add them with
      [Local Existing Instances]. *)
  Lemma succ_le_Proper : Proper (Z.le ==> Z.le) Z.succ.
  Proof. repeat (lia || intro). Qed.
  Hint Resolve succ_le_Proper : zarith.
  Lemma add_le_Proper : Proper (Z.le ==> Z.le ==> Z.le) Z.add.
  Proof. repeat (lia || intro). Qed.
  Hint Resolve add_le_Proper : zarith.
  Lemma add_le_Proper' x : Proper (Z.le ==> Z.le) (Z.add x).
  Proof. repeat (lia || intro). Qed.
  Hint Resolve add_le_Proper' : zarith.
  Lemma sub_le_ge_Proper : Proper (Z.le ==> Z.ge ==> Z.le) Z.sub.
  Proof. repeat (lia || intro). Qed.
  Hint Resolve sub_le_ge_Proper : zarith.
  Lemma sub_le_flip_le_Proper : Proper (Z.le ==> Basics.flip Z.le ==> Z.le) Z.sub.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve sub_le_flip_le_Proper : zarith.
  Lemma sub_le_eq_Proper : Proper (Z.le ==> Logic.eq ==> Z.le) Z.sub.
  Proof. repeat (lia || intro). Qed.
  Hint Resolve sub_le_eq_Proper : zarith.
  Lemma mul_Zpos_le_Proper p : Proper (Z.le ==> Z.le) (Z.mul (Z.pos p)).
  Proof. repeat (nia || intro). Qed.
  Hint Resolve mul_Zpos_le_Proper : zarith.
  Lemma log2_up_le_Proper : Proper (Z.le ==> Z.le) Z.log2_up.
  Proof. intros ???; apply Z.log2_up_le_mono; assumption. Qed.
  Hint Resolve log2_up_le_Proper : zarith.
  Lemma log2_le_Proper : Proper (Z.le ==> Z.le) Z.log2.
  Proof. intros ???; apply Z.log2_le_mono; assumption. Qed.
  Hint Resolve log2_le_Proper : zarith.
  Lemma pow_Zpos_le_Proper x : Proper (Z.le ==> Z.le) (Z.pow (Z.pos x)).
  Proof. intros ???; apply Z.pow_le_mono_r; try reflexivity; try assumption. Qed.
  Hint Resolve pow_Zpos_le_Proper : zarith.
  Lemma lt_le_flip_Proper_flip_impl
    : Proper (Z.le ==> Basics.flip Z.le ==> Basics.flip Basics.impl) Z.lt.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve lt_le_flip_Proper_flip_impl : zarith.
  Lemma le_Proper_ge_le_flip_impl : Proper (Z.le ==> Z.ge ==> Basics.flip Basics.impl) Z.le.
  Proof. intros ???????; lia. Qed.
  Hint Resolve le_Proper_ge_le_flip_impl : zarith.
  Lemma add_le_Proper_flip : Proper (Basics.flip Z.le ==> Basics.flip Z.le ==> Basics.flip Z.le) Z.add.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve add_le_Proper_flip : zarith.
  Lemma sub_le_ge_Proper_flip : Proper (Basics.flip Z.le ==> Basics.flip Z.ge ==> Basics.flip Z.le) Z.sub.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve sub_le_ge_Proper_flip : zarith.
  Lemma sub_flip_le_le_Proper_flip : Proper (Basics.flip Z.le ==> Z.le ==> Basics.flip Z.le) Z.sub.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve sub_flip_le_le_Proper_flip : zarith.
  Lemma sub_le_eq_Proper_flip : Proper (Basics.flip Z.le ==> Logic.eq ==> Basics.flip Z.le) Z.sub.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve sub_le_eq_Proper_flip : zarith.
  Lemma log2_up_le_Proper_flip : Proper (Basics.flip Z.le ==> Basics.flip Z.le) Z.log2_up.
  Proof. intros ???; apply Z.log2_up_le_mono; assumption. Qed.
  Hint Resolve log2_up_le_Proper_flip : zarith.
  Lemma log2_le_Proper_flip : Proper (Basics.flip Z.le ==> Basics.flip Z.le) Z.log2.
  Proof. intros ???; apply Z.log2_le_mono; assumption. Qed.
  Hint Resolve log2_le_Proper_flip : zarith.
  Lemma pow_Zpos_le_Proper_flip x : Proper (Basics.flip Z.le ==> Basics.flip Z.le) (Z.pow (Z.pos x)).
  Proof. intros ???; apply Z.pow_le_mono_r; try reflexivity; try assumption. Qed.
  Hint Resolve pow_Zpos_le_Proper_flip : zarith.
  Lemma add_with_carry_le_Proper : Proper (Z.le ==> Z.le ==> Z.le ==> Z.le) Z.add_with_carry.
  Proof. unfold Z.add_with_carry; repeat (lia || intro). Qed.
  Hint Resolve add_with_carry_le_Proper : zarith.
  Lemma sub_with_borrow_le_Proper : Proper (Basics.flip Z.le ==> Z.le ==> Basics.flip Z.le ==> Z.le) Z.sub_with_borrow.
  Proof. unfold Z.sub_with_borrow, Z.add_with_carry, Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve sub_with_borrow_le_Proper : zarith.
  Lemma opp_flip_le_le_Proper : Proper (Basics.flip Z.le ==> Z.le) Z.opp.
  Proof. cbv [Basics.flip]; repeat (lia || intro). Qed.
  Hint Resolve opp_flip_le_le_Proper : zarith.
  Lemma opp_le_flip_le_Proper : Proper (Z.le ==> Basics.flip Z.le) Z.opp.
  Proof. cbv [Basics.flip]; repeat (lia || intro). Qed.
  Hint Resolve opp_le_flip_le_Proper : zarith.
  Lemma opp_le_ge_Proper : Proper (Z.le ==> Z.ge) Z.opp.
  Proof. cbv [Basics.flip]; repeat (lia || intro). Qed.
  Hint Resolve opp_le_ge_Proper : zarith.
  Lemma opp_ge_le_Proper : Proper (Z.ge ==> Z.le) Z.opp.
  Proof. cbv [Basics.flip]; repeat (lia || intro). Qed.
  Hint Resolve opp_ge_le_Proper : zarith.
  Lemma add_le_Proper'' x : Proper (Z.le ==> Z.le) (fun y => Z.add y x).
  Proof. repeat (lia || intro). Qed.
  Hint Resolve add_le_Proper'' : zarith.
  Lemma sub_le_ge_Proper_r p : Proper (Z.le ==> Z.ge) (Z.sub p).
  Proof. repeat (lia || intro). Qed.
  Hint Resolve sub_le_ge_Proper_r : zarith.
  Lemma sub_le_le_Proper_l p : Proper (Z.le ==> Z.le) (fun x => Z.sub x p).
  Proof. repeat (lia || intro). Qed.
  Hint Resolve sub_le_le_Proper_l : zarith.
  Lemma sub_le_flip_le_Proper_r p : Proper (Z.le ==> Basics.flip Z.le) (Z.sub p).
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve sub_le_flip_le_Proper_r : zarith.
  Lemma sub_flip_le_le_Proper_r p : Proper (Basics.flip Z.le ==> Z.le) (Z.sub p).
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve sub_flip_le_le_Proper_r : zarith.
  Lemma sub_ge_le_Proper_r p : Proper (Z.ge ==> Z.le) (Z.sub p).
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
  Hint Resolve sub_ge_le_Proper_r : zarith.
  Lemma mul_Z0_le_Proper : Proper (Z.le ==> Z.le) (Z.mul Z0).
  Proof. repeat (nia || intro). Qed.
  Hint Resolve mul_Z0_le_Proper : zarith.
  Lemma mul_Zneg_le_flip_le_Proper p : Proper (Z.le ==> Basics.flip Z.le) (Z.mul (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zneg_le_flip_le_Proper : zarith.
  Lemma mul_Zneg_le_ge_Proper p : Proper (Z.le ==> Z.ge) (Z.mul (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zneg_le_ge_Proper : zarith.
  Lemma mul_Zneg_flip_le_le_Proper p : Proper (Basics.flip Z.le ==> Z.le) (Z.mul (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zneg_flip_le_le_Proper : zarith.
  Lemma mul_Zneg_ge_le_Proper p : Proper (Z.ge ==> Z.le) (Z.mul (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zneg_ge_le_Proper : zarith.
  Lemma mul_Zpos_le_Proper' p : Proper (Z.le ==> Z.le) (fun y => Z.mul y (Zpos p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zpos_le_Proper' : zarith.
  Lemma mul_Z0_le_Proper' : Proper (Z.le ==> Z.le) (fun y => Z.mul y Z0).
  Proof. repeat (nia || intro). Qed.
  Hint Resolve mul_Z0_le_Proper' : zarith.
  Lemma mul_Zneg_le_flip_le_Proper' p : Proper (Z.le ==> Basics.flip Z.le) (fun y => Z.mul y (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zneg_le_flip_le_Proper' : zarith.
  Lemma mul_Zneg_le_ge_Proper' p : Proper (Z.le ==> Z.ge) (fun y => Z.mul y (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zneg_le_ge_Proper' : zarith.
  Lemma mul_Zneg_flip_le_le_Proper' p : Proper (Basics.flip Z.le ==> Z.le) (fun y => Z.mul y (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zneg_flip_le_le_Proper' : zarith.
  Lemma mul_Zneg_ge_le_Proper' p : Proper (Z.ge ==> Z.le) (fun y => Z.mul y (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
  Hint Resolve mul_Zneg_ge_le_Proper' : zarith.
  Lemma div_Zpos_le_Proper_r p : Proper (Z.le ==> Z.le) (fun x => Z.div x (Zpos p)).
  Proof. repeat (nia || Z.div_mod_to_quot_rem || intro). Qed.
  Hint Resolve div_Zpos_le_Proper_r : zarith.
  Lemma div_Z0_le_Proper_r : Proper (Z.le ==> Z.le) (fun x => Z.div x Z0).
  Proof. repeat (nia || Z.div_mod_to_quot_rem || intro). Qed.
  Hint Resolve div_Z0_le_Proper_r : zarith.
  Lemma div_Zneg_le_flip_le_Proper_r p : Proper (Z.le ==> Basics.flip Z.le) (fun x => Z.div x (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || Z.div_mod_to_quot_rem || intro). Qed.
  Hint Resolve div_Zneg_le_flip_le_Proper_r : zarith.
  Lemma div_Zneg_flip_le_le_Proper_r p : Proper (Basics.flip Z.le ==> Z.le) (fun x => Z.div x (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || Z.div_mod_to_quot_rem || intro). Qed.
  Hint Resolve div_Zneg_flip_le_le_Proper_r : zarith.
  Lemma div_Z0_le_Proper_l : Proper (Z.le ==> Z.le) (Z.div Z0).
  Proof. do 3 intro; destruct_head' Z; cbv; congruence. Qed.
  Hint Resolve div_Z0_le_Proper_l : zarith.
  Local Ltac div_Proper_t :=
    let H := fresh in
    cbv [Basics.flip]; intros ?? H; apply Pos2Z.pos_le_pos in H;
    apply Z.div_cross_le_abs; cbn [Z.sgn Z.abs]; try nia.
  Lemma div_Zpos_Zpos_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.div (Zpos p) (Zpos x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Zpos_Zpos_le_Proper_l : zarith.
  Lemma div_Zpos_Zneg_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.div (Zpos p) (Zneg x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Zpos_Zneg_le_Proper_l : zarith.
  Lemma div_Zneg_Zpos_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.div (Zneg p) (Zpos x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Zneg_Zpos_le_Proper_l : zarith.
  Lemma div_Zneg_Zneg_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.div (Zneg p) (Zneg x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Zneg_Zneg_le_Proper_l : zarith.
  Lemma div_Z0_Zpos_le_Proper_l : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.div Z0 (Zpos x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Z0_Zpos_le_Proper_l : zarith.
  Lemma div_Z0_Zneg_le_Proper_l : Proper (Pos.le ==> Z.le) (fun x => Z.div Z0 (Zneg x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Z0_Zneg_le_Proper_l : zarith.
  Lemma div_Zpos_Zpos_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.div (Zpos p) (Zpos x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Zpos_Zpos_le_Proper_r : zarith.
  Lemma div_Zpos_Zneg_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.div (Zpos p) (Zneg x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Zpos_Zneg_le_Proper_r : zarith.
  Lemma div_Zneg_Zpos_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.div (Zneg p) (Zpos x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Zneg_Zpos_le_Proper_r : zarith.
  Lemma div_Zneg_Zneg_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.div (Zneg p) (Zneg x)).
  Proof. div_Proper_t. Qed.
  Hint Resolve div_Zneg_Zneg_le_Proper_r : zarith.
  Lemma div_Zpos_Z0_le_Proper_r : Proper (Pos.le ==> Z.le) (fun p => Z.div (Zpos p) Z0).
  Proof. do 3 intro; cbv; congruence. Qed.
  Hint Resolve div_Zpos_Z0_le_Proper_r : zarith.
  Lemma div_Zneg_Z0_le_Proper_r : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.div (Zneg p) Z0).
  Proof. do 3 intro; cbv; congruence. Qed.
  Hint Resolve div_Zneg_Z0_le_Proper_r : zarith.
  Local Ltac shift_t :=
    repeat first [ progress intros
                 | progress cbv [Proper respectful Basics.flip] in *
                 | progress rewrite ?Z.shiftr_div_pow2, ?Z.shiftr_mul_pow2, ?Z.shiftl_div_pow2, ?Z.shiftl_mul_pow2, ?Z.div_1_r, ?Zdiv_0_l by lia
                 | progress (cbn [Z.pow Z.opp]; change Z.pow_pos with (fun x p => Z.pow x (Zpos p)); cbn beta)
                 | progress Z.peel_le
                 | nia
                 | match goal with
                   | [ |- context[(2^Zpos ?p)%Z] ] => unique assert (0 < 2^Zpos p)%Z by (apply Z.pow_pos_nonneg; lia)
                   | [ |- (?x / ?a <= ?x * ?b)%Z ] => transitivity x
                   | [ |- (?x * ?a <= ?x / ?b)%Z ] => transitivity x
                   | [ H : (0 > Z.neg _)%Z |- _ ] => clear H
                   | [ H : (Zneg ?a <= Zneg ?b)%Z |- _ ] => assert ((Zpos b <= Zpos a)%Z) by lia; clear H
                   | [ H : (?a <= ?b)%Z |- context[(2^?a)%Z] ]
                     => unique assert (2^a <= 2^b)%Z by (apply Z.pow_le_mono_r; lia); clear H
                   | [ |- context[(2^Zpos ?a)%Z] ] => generalize dependent (2^Zpos a)%Z; clear a
                   end
                 | progress destruct_head' Z
                 | Z.div_mod_to_quot_rem; nia
                 | apply Z.div_cross_le_abs; cbn [Z.sgn Z.abs]; nia ].
  Lemma shiftr_le_Proper_l : forall y : Z, Proper (Z.le ==> Z.le) (fun x : Z => Z.shiftr x y).
  Proof. shift_t. Qed.
  Hint Resolve shiftr_le_Proper_l : zarith.
  Lemma shiftl_le_Proper_l : forall y : Z, Proper (Z.le ==> Z.le) (fun x : Z => Z.shiftl x y).
  Proof. shift_t. Qed.
  Hint Resolve shiftl_le_Proper_l : zarith.
  Lemma shiftr_le_Proper_r x
        (R := fun b : bool => if b then Basics.flip Z.le else Z.le)
    : Proper (R (0 <=? x)%Z ==> Z.le) (Z.shiftr x).
  Proof. subst R; cbv beta; break_match; Z.ltb_to_lt; shift_t. Qed.
  Hint Resolve shiftr_le_Proper_r : zarith.
  Lemma shiftl_le_Proper_r x
        (R := fun b : bool => if b then Z.le else Basics.flip Z.le)
    : Proper (R (0 <=? x)%Z ==> Z.le) (Z.shiftl x).
  Proof. subst R; cbv beta; break_match; Z.ltb_to_lt; shift_t. Qed.
  Hint Resolve shiftl_le_Proper_r : zarith.
  Local Ltac shift_Proper_t' :=
    let H := fresh in
    cbv [Basics.flip]; intros ?? H; apply Pos2Z.pos_le_pos in H;
    try ((apply shiftr_le_Proper_r + apply shiftr_le_Proper_l + apply shiftl_le_Proper_r + apply shiftl_le_Proper_l);
         cbv [Z.leb Z.compare Basics.flip];
         lia).
  Lemma shiftr_Zpos_Zpos_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftr (Zpos p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zpos_Zpos_le_Proper_l : zarith.
  Lemma shiftr_Zpos_Zneg_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.shiftr (Zpos p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zpos_Zneg_le_Proper_l : zarith.
  Lemma shiftr_Zneg_Zpos_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.shiftr (Zneg p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zneg_Zpos_le_Proper_l : zarith.
  Lemma shiftr_Zneg_Zneg_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftr (Zneg p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zneg_Zneg_le_Proper_l : zarith.
  Lemma shiftr_Z0_Zpos_le_Proper_l : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftr Z0 (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Z0_Zpos_le_Proper_l : zarith.
  Lemma shiftr_Z0_Zneg_le_Proper_l : Proper (Pos.le ==> Z.le) (fun x => Z.shiftr Z0 (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Z0_Zneg_le_Proper_l : zarith.
  Lemma shiftr_Zpos_Zpos_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.shiftr (Zpos p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zpos_Zpos_le_Proper_r : zarith.
  Lemma shiftr_Zpos_Zneg_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.shiftr (Zpos p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zpos_Zneg_le_Proper_r : zarith.
  Lemma shiftr_Zneg_Zpos_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftr (Zneg p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zneg_Zpos_le_Proper_r : zarith.
  Lemma shiftr_Zneg_Zneg_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftr (Zneg p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zneg_Zneg_le_Proper_r : zarith.
  Lemma shiftr_Zpos_Z0_le_Proper_r : Proper (Pos.le ==> Z.le) (fun p => Z.shiftr (Zpos p) Z0).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zpos_Z0_le_Proper_r : zarith.
  Lemma shiftr_Zneg_Z0_le_Proper_r : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftr (Zneg p) Z0).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftr_Zneg_Z0_le_Proper_r : zarith.
  Lemma shiftl_Zpos_Zpos_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.shiftl (Zpos p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zpos_Zpos_le_Proper_l : zarith.
  Lemma shiftl_Zpos_Zneg_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftl (Zpos p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zpos_Zneg_le_Proper_l : zarith.
  Lemma shiftl_Zneg_Zpos_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftl (Zneg p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zneg_Zpos_le_Proper_l : zarith.
  Lemma shiftl_Zneg_Zneg_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.shiftl (Zneg p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zneg_Zneg_le_Proper_l : zarith.
  Lemma shiftl_Z0_Zpos_le_Proper_l : Proper (Pos.le ==> Z.le) (fun x => Z.shiftl Z0 (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Z0_Zpos_le_Proper_l : zarith.
  Lemma shiftl_Z0_Zneg_le_Proper_l : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftl Z0 (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Z0_Zneg_le_Proper_l : zarith.
  Lemma shiftl_Zpos_Zpos_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.shiftl (Zpos p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zpos_Zpos_le_Proper_r : zarith.
  Lemma shiftl_Zpos_Zneg_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.shiftl (Zpos p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zpos_Zneg_le_Proper_r : zarith.
  Lemma shiftl_Zneg_Zpos_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftl (Zneg p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zneg_Zpos_le_Proper_r : zarith.
  Lemma shiftl_Zneg_Zneg_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftl (Zneg p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zneg_Zneg_le_Proper_r : zarith.
  Lemma shiftl_Zpos_Z0_le_Proper_r : Proper (Pos.le ==> Z.le) (fun p => Z.shiftl (Zpos p) Z0).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zpos_Z0_le_Proper_r : zarith.
  Lemma shiftl_Zneg_Z0_le_Proper_r : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftl (Zneg p) Z0).
  Proof. shift_Proper_t'. Qed.
  Hint Resolve shiftl_Zneg_Z0_le_Proper_r : zarith.

  Hint Resolve Z.land_round_Proper_pos_r : zarith.
  Hint Resolve Z.land_round_Proper_pos_l : zarith.
  Hint Resolve Z.lor_round_Proper_pos_r : zarith.
  Hint Resolve Z.lor_round_Proper_pos_l : zarith.
  Hint Resolve Z.land_round_Proper_neg_r : zarith.
  Hint Resolve Z.land_round_Proper_neg_l : zarith.
  Hint Resolve Z.lor_round_Proper_neg_r : zarith.
  Hint Resolve Z.lor_round_Proper_neg_l : zarith.
End Z.


From Paco Require Export paconotation.
From Paco Require Import pacotac_internal paconotation_internal.
Set Implicit Arguments.
Set Primitive Projections.

(** ** Predicates of Arity 1
*)

Section Arg1_def.

Variable T0 : Type.
Variable gf : rel1 T0 -> rel1 T0.
Arguments gf : clear implicits.

Variant _paco (paco: rel1 T0 -> rel1 T0) ( r: rel1 T0) x0 : Prop :=
| paco_pfold pco
    (LE : pco <1= (paco r \1/ r))
    (SIM: gf pco x0)
.

CoInductive paco r x0 : Prop := paco_go { paco_observe: _paco paco r x0 }.

Definition upaco( r: rel1 T0) := paco r \1/ r.

End Arg1_def.

Arguments paco [ T0 ] gf r x0.
Arguments upaco [ T0 ] gf r x0.
#[export] Hint Unfold upaco : core.

(* Less than or equal - internal use only *)
Notation "p <_paco_1= q" :=
  (forall _paco_x0 (PR: p _paco_x0 : Prop), q _paco_x0 : Prop)
  (at level 50, no associativity).

(* coinduction automation - internal use only *)
Ltac paco_cofix_auto :=
  let CIH := fresh "CIH" in cofix CIH; repeat intro;
  match goal with [H: _ |- _] => apply paco_observe in H; destruct H as [] end; do 2 econstructor;
  try (match goal with [H: _|-_] => apply H end); intros;
  lazymatch goal with [PR: _ |- _] => match goal with [H: _ |- _] => apply H in PR end end;
  repeat match goal with [ H : _ \/ _ |- _] => destruct H end; first [eauto; fail|eauto 10].

Definition monotone T0 (gf: rel1 T0 -> rel1 T0) :=
  forall x0 r r' (IN: gf r x0) (LE: r <1= r'), gf r' x0.

Definition _monotone T0 (gf: rel1 T0 -> rel1 T0) :=
  forall r r'(LE: r <1= r'), gf r <1== gf r'.

Lemma monotone_eq T0 (gf: rel1 T0 -> rel1 T0) :
  monotone gf <-> _monotone gf.
Proof. unfold monotone, _monotone, le1. split; eauto. Qed.

Lemma paco_mon_gen T0 gf gf' r r' x
    (PR: @paco T0 gf r x)
    (LEgf: gf <2= gf')
    (LEr: r <1= r'):
  paco gf' r' x.
Proof.
  revert x PR. cofix CIH.
  intros. apply paco_observe in PR. destruct PR as [].
  do 2 econstructor.
  - intros. specialize (LE x0 PR). destruct LE.
    + left. apply CIH, H.
    + right. apply LEr, H.
  - apply LEgf, SIM.
Qed.

Section Arg1.

Variable T0 : Type.
Variable gf : rel1 T0 -> rel1 T0.
Arguments gf : clear implicits.

Theorem paco_acc: forall
  l r (OBG: forall rr (INC: r <1= rr) (CIH: l <1= rr), l <1= paco gf rr),
  l <1= paco gf r.
Proof.
  intros; assert (SIM: paco gf (r \1/ l) x0) by eauto.
  clear PR; repeat (try left; do 2 paco_revert; paco_cofix_auto).
Qed.

Theorem paco_mon: monotone (paco gf).
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco_mult_strong: forall r,
  paco gf (upaco gf r) <1= paco gf r.
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Corollary paco_mult: forall r,
  paco gf (paco gf r) <1= paco gf r.
Proof. intros; eapply paco_mult_strong, paco_mon; eauto. Qed.

Theorem paco_fold: forall r,
  gf (upaco gf r) <1= paco gf r.
Proof. intros; do 2 econstructor; [ |eauto]; eauto. Qed.

Theorem paco_unfold: forall (MON: monotone gf) r,
  paco gf r <1= gf (upaco gf r).
Proof. unfold monotone; intros; apply paco_observe in PR; destruct PR as []; eauto. Qed.

Theorem _paco_acc: forall
  l r (OBG: forall rr (INC: r <1== rr) (CIH: l <1== rr), l <1== paco gf rr),
  l <1== paco gf r.
Proof. unfold le1. eapply paco_acc. Qed.

Theorem _paco_mon: _monotone (paco gf).
Proof. apply monotone_eq. eapply paco_mon. Qed.

Theorem _paco_mult_strong: forall r,
  paco gf (upaco gf r) <1== paco gf r.
Proof. unfold le1. eapply paco_mult_strong. Qed.

Theorem _paco_fold: forall r,
  gf (upaco gf r) <1== paco gf r.
Proof. unfold le1. eapply paco_fold. Qed.

Theorem _paco_unfold: forall (MON: _monotone gf) r,
  paco gf r <1== gf (upaco gf r).
Proof.
  unfold le1. intro.
  eapply paco_unfold; apply monotone_eq; eauto.
Qed.

End Arg1.

#[export] Hint Unfold monotone : core.
#[export] Hint Resolve paco_fold : core.

Arguments paco_mon_gen        [ T0 ] gf gf' r r' x PR LEgf LEr.
Arguments paco_acc            [ T0 ] gf l r OBG x0 PR.
Arguments paco_mon            [ T0 ] gf x0 r r' IN LE.
Arguments paco_mult_strong    [ T0 ] gf r x0 PR.
Arguments paco_mult           [ T0 ] gf r x0 PR.
Arguments paco_fold           [ T0 ] gf r x0 PR.
Arguments paco_unfold         [ T0 ] gf MON r x0 PR.


(*
Copyright © 2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Export CoRN.raster.Raster.
Require Import CoRN.reals.fast.Interval.
Require Export CoRN.metric2.FinEnum.
Require Export CoRN.metric2.ProductMetric.
Require Import CoRN.logic.Classic.

Set Implicit Arguments.
(**
** Rasters on Planes
By attaching coordinates to the top-left and bottom-right corners of
a raster, it can be interpreted as a finite set in [Q]^2. *)
Definition Q2 := (ProductMS Q_as_MetricSpace Q_as_MetricSpace).

(** For [Q2], classical membership in a finite enumeration is the
same as a constructive membership. *)
Lemma InStrengthen : forall x (l:FinEnum Q2),
    InFinEnumC x l -> exists y : Q2, In y l /\ msp_eq x y.
Proof.
 induction l.
 intro abs. exfalso; exact (FinSubset_ball_nil abs).
 intros H.
 assert (L:msp_eq x a \/ ~msp_eq x a).
  destruct (Qeq_dec (fst x) (fst a)).
   destruct (Qeq_dec (snd x) (snd a)).
    left.
    split; apply Qball_0; auto.
   right; intros [_ B].
   apply Qball_0 in B. contradiction.
  right; intros [B _].
   apply Qball_0 in B. contradiction.
 destruct L.
  exists a.
  split; auto with *.
 destruct (IHl) as [y [Hy0 Hy1]].
 apply FinSubset_ball_orC in H.
  destruct H as [G | H | H] using orC_ind.
  intro abs. contradict G; intro G. contradiction.
   elim H0; auto.
   exact H.
 exists y.
 split; auto with *.
Qed.

Definition InterpRow (up : list Q) (v:list bool) : list Q :=
 map (@fst _ _ ) (filter (@snd _ _) (combine up v)).

(* TODO define on sparse rasters directly. *)
Definition CentersOfPixels (n m:positive) (pixels : raster n m) (tl br:Q2)
  : FinEnum Q2 :=
 let (l,t) := tl in
 let (r,b) := br in
 let up := (UniformPartition l r n) in
 flat_map (fun (p:Q*list bool) => let (y,r):=p in map (fun x => (x,y)) (InterpRow up r))
          (combine (UniformPartition t b m) (let (d):=pixels in d)).

(** Notation for the interpretation of a raster. *)
Notation "a ⇱ b ⇲ c" := (CentersOfPixels b a c) (at level 1,
 format "a ⇱ '[v' '/' b ']' '[v' '/' ⇲ c ']'") : raster.

(*
Local Open Scope raster.
Local Open Scope raster_parsing.

Example ex5 :=
(0, 1)⇱
         ⎥█░█⎢
         ⎥░█░⎢
         ⎥░░█⎢
             ⇲(1, 0).

Eval compute in (ex5).
*)

Lemma In_map_snd_const
  : forall A (v : list A) f (a b : Q),
    In a (map f v)
    -> In (a,b) (map (fun x => (f x, b)) v).
Proof.
  induction v.
  - intros. contradiction H.
  - intros. simpl. destruct H.
    subst a0. left. reflexivity.
    right. apply IHv, H.
Qed.

Lemma In_filtered_list
  : forall (l : list Q) (q : Q) (filterList : list bool) (j : nat),
    (length filterList <= length l)%nat
    -> Is_true (nth j filterList false)
    -> In (nth j l q)
         (map fst (filter snd (combine l filterList))).
Proof.
  induction l.
  - intros. destruct filterList. 2: exfalso; inversion H.
    exfalso. simpl in H0. destruct j; contradiction.
  - intros. destruct filterList.
    destruct j; contradiction.
    simpl in H. apply le_S_n in H.
    simpl. destruct j.
    + simpl in H0. destruct b. 2: contradiction.
      left. reflexivity.
    + destruct b.
      right. exact (IHl q _ _ H H0).
      exact (IHl q _ _ H H0).
Qed.

Lemma In_filter_list
  : forall (filterList : list bool) (j : nat),
    Is_true (nth j filterList false)
    -> (j < length filterList)%nat.
Proof.
  induction filterList.
  - intros. destruct j; contradiction.
  - intros. destruct j. simpl. apply le_n_S, le_0_n.
    simpl. apply le_n_S. apply IHfilterList, H.
Qed.

Lemma Vector_bool_in
  : forall (v : list bool) j,
    Is_true (nth j v false) -> (j < length v)%nat.
Proof.
  induction v.
  - intros j H. destruct j; contradiction H.
  - intros j H. simpl in H.
    destruct j. apply le_n_S, le_0_n.
    simpl. apply le_n_S, IHv, H.
Qed.

Lemma RasterIndex_in
  : forall m n i j (r : raster n m),
    raster_well_formed r ->
    Is_true (RasterIndex r i j) -> (i < Pos.to_nat m /\ j < Pos.to_nat n)%nat.
Proof.
  intros. destruct r as [l].
  destruct H. rewrite <- H.
  simpl in H0.
  clear H m.
  simpl in H0.
  revert H0. revert i j. induction l as [|a l].
  - intros. exfalso. simpl in H0.
    destruct i; destruct j; contradiction.
  - intros.
    inversion H1. subst l0. subst x. clear H1.
    specialize (IHl H4).
    destruct i.
    + split. apply le_n_S, le_0_n.
      apply Vector_bool_in in H0.
      rewrite <- H3. exact H0.
    + specialize (IHl i j H0).
      split. apply le_n_S, IHl. apply IHl.
Qed.

(** Correctness properties of our interpretation. *)
Section InterpRasterCorrect.

Let f := fun l r (n:positive) (i:Z) => l + (r - l) * (2 * i + 1 # 1) / (2 * Zpos n # 1).

Lemma InterpRaster_correct1
  : forall n m (t l b r:Q) (bitmap: raster n m) i j,
    raster_well_formed bitmap
    -> Is_true (RasterIndex bitmap i j)
    -> In (f l r n (Z.of_nat j), f t b m (Z.of_nat i))
         (CentersOfPixels bitmap (l,t) (r,b)).
Proof.
  intros n m t l b r bitmap.
  unfold CentersOfPixels, InterpRow, UniformPartition.
  fold (f l r n).
  fold (f t b m).
  generalize (f l r n) (f t b m).
  clear t l b r f.
  unfold RasterIndex.
  intros.
  pose proof (RasterIndex_in i j _ H H0) as [iin jin].
  destruct bitmap as [bitmap], H.
  apply in_flat_map.
  exists (nth i (map q0 (iterateN_succ 0 m)) (q0 0%Z), nth i bitmap nil).
  split.
  - rewrite <- (combine_nth (map q0 (iterateN_succ 0 m)) bitmap i (q0 0%Z) nil).
    apply nth_In.
    rewrite combine_length, map_length, iterateN_succ_length.
    apply Nat.min_case. exact iin.
    rewrite H. exact iin.
    rewrite map_length, iterateN_succ_length, H.
    reflexivity.
  - rewrite map_map.
    replace (q0 (Z.of_nat i))
      with (nth i (map q0 (iterateN_succ 0 m)) (q0 0%Z)).
    apply In_map_snd_const.
    replace (q (Z.of_nat j))
      with (nth j (map q (iterateN_succ 0 n)) (q 0%Z)).
    apply In_filtered_list.
    2: exact H0.
    rewrite map_length, iterateN_succ_length.
    rewrite Forall_forall in H1.
    rewrite (H1 (nth i bitmap nil)).
    apply le_refl.
    apply nth_In. rewrite H. exact iin.
    rewrite map_nth. apply f_equal.
    apply iterateN_succ_nth, jin.
    rewrite map_nth. apply f_equal.
    apply iterateN_succ_nth, iin.
Qed.

Lemma InterpRaster_correct2 : forall n m (t l b r:Q) x y (bitmap: raster n m),
raster_well_formed bitmap ->
In (x,y) (CentersOfPixels bitmap (l,t) (r,b)) ->
exists p, Is_true (RasterIndex bitmap (fst p) (snd p)) /\ x=f l r n (Z.of_nat (snd p))
     /\ y=f t b m (Z.of_nat (fst p)).
Proof.
 intros n m t l b r x y bitmap.
 unfold CentersOfPixels, InterpRow, UniformPartition.
 fold (f l r n).
 fold (f t b m).
 generalize (f l r n) (f t b m).
 clear t l b r f.
 intros q q0 wf H. apply in_flat_map in H.
 destruct H as [[s v] [H H0]].
 destruct bitmap as [bitmap]. simpl.
 destruct wf.
 apply In_nth with (d:=(q0 0%Z, nth 0 bitmap nil)) in H.
 destruct H as [i [ilt H]].
 rewrite combine_length, map_length, iterateN_succ_length in ilt.
 assert (i < Pos.to_nat m)%nat.
 { apply (lt_le_trans _ _ _ ilt), Nat.le_min_l. }
 clear ilt.
 rewrite combine_nth in H.
 2: rewrite map_length, iterateN_succ_length, H1; reflexivity.
 inversion H. clear H. subst s. subst v. simpl in H0.
 rewrite map_map in H0.
 apply in_map_iff in H0.
 destruct H0 as [[s b] [H H0]].
 unfold fst in H.
 inversion H. clear H.
 subst s. clear H6 y.
 apply filter_In in H0.
 destruct H0. unfold snd in H0. subst b.
 apply In_nth with (d:= (q 0%Z,true)) in H.
 destruct H as [j [jlt H]].
 rewrite Forall_forall in H2.
 rewrite combine_nth in H.
 inversion H. clear H H4 x.
 rewrite combine_length, map_length, iterateN_succ_length in jlt.
 assert (j < Pos.to_nat n)%nat.
 { apply (lt_le_trans _ _ _ jlt). apply Nat.le_min_l. }
 clear jlt.
 exists (i,j). split.
 - simpl.
   rewrite (nth_indep _ false true).
   rewrite (nth_indep _ nil (nth 0 bitmap nil)).
   unfold Is_true. rewrite H5. trivial.
   rewrite H1. exact H3.
   rewrite H2. exact H.
   apply nth_In. rewrite H1. exact H3.
 - simpl. split.
   rewrite map_nth.
   apply f_equal.
   apply iterateN_succ_nth.
   exact H.
   rewrite map_nth.
   apply f_equal.
   apply iterateN_succ_nth, H3.
 - rewrite map_length, iterateN_succ_length.
   rewrite H2. reflexivity.
   apply nth_In. rewrite H1. exact H3.
Qed.

End InterpRasterCorrect.
(* begin hide *)
Add Parametric Morphism n m (bm:raster n m) (bmWf : raster_well_formed bm)
  : (@CentersOfPixels n m bm)
    with signature (@msp_eq _) ==> (@msp_eq _) ==> (@msp_eq _) as InterpRaster_wd.
Proof.
 cut (forall (x1 x2 : Q2), msp_eq x1 x2 -> forall x3 x4 : Q2,
   msp_eq x3 x4 -> forall y,
     InFinEnumC y (CentersOfPixels bm x1 x3) ->
       InFinEnumC y (CentersOfPixels bm x2 x4)).
 { intro L. split. discriminate. split.
   intros q H1 abs.
   contradiction (abs q). split. exact (L x y H x0 y0 H0 q H1).
   reflexivity.
   intros q H1 abs.
   contradiction (abs q). split.
   symmetry in H, H0.
   exact (L y x H y0 x0 H0 q H1).
   reflexivity. }
 intros [x1l x1r] x2 Hx [y1l y1r] y2 Hy z Hz.
 destruct (@InStrengthen _ _ Hz) as [[ax ay] [Ha0 Ha1]].
 destruct (InterpRaster_correct2 _ _ _ _ _ _ _ bmWf Ha0)
   as [[bx by'] [Hb0 [Hb1 Hb2]]].
 rewrite Hb1 in Ha1.
 rewrite Hb2 in Ha1.
 unfold snd, fst in Ha1.
 destruct x2 as [x2l x2r].
 destruct y2 as [y2l y2r].
 assert (L0:msp_eq z ((x2l + (y2l - x2l) * (2 * Z.of_nat by' + 1 # 1) / (2 * Zpos n # 1)),
   (x2r + (y2r - x2r) * (2 * Z.of_nat bx + 1 # 1) / (2 * Zpos m # 1)))).
  transitivity ((x1l + (y1l - x1l) * (2 * Z.of_nat by' + 1 # 1) / (2 * Zpos n # 1)),
    (x1r + (y1r - x1r) * (2 * Z.of_nat bx + 1 # 1) / (2 * Zpos m # 1))).
   auto.
  clear - Hx Hy.
  destruct Hx as [Hx1 Hx2].
  destruct Hy as [Hy1 Hy2].
  split; unfold fst,snd in *.
  apply Qball_0 in Hx1.
  apply Qball_0 in Hy1.
   rewrite -> Hx1, Hy1.
   reflexivity.
  apply Qball_0 in Hx2.
  apply Qball_0 in Hy2.
  rewrite -> Hx2, Hy2.
  reflexivity.
  unfold InFinEnumC.
  rewrite -> (@FinSubset_ball_wd _ z _ 0 0
                                (CentersOfPixels bm (x2l, x2r) (y2l, y2r))
                                (reflexivity _) L0).
 apply InFinEnumC_weaken.
 auto using InterpRaster_correct1.
Qed.
(* end hide *)


(** * Definition of the part of boolean-returning CFG parser-recognizer that instantiates things to lists *)
Require Import Coq.Lists.List Coq.Strings.String Coq.Arith.Wf_nat.
Require Import ParsingParses.Parsers.ContextFreeGrammar.
Require Import ParsingParses.Parsers.BaseTypes ParsingParses.Parsers.BooleanBaseTypes.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section recursive_descent_parser_list.
  Context {CharType} {String : string_like CharType} {G : grammar CharType}.
  Definition rdp_list_nonterminals_listT : Type := list string.
  Definition rdp_list_is_valid_nonterminal : rdp_list_nonterminals_listT -> string -> bool
    := fun ls nt => if in_dec string_dec nt ls then true else false.
  Definition rdp_list_remove_nonterminal : rdp_list_nonterminals_listT -> string -> rdp_list_nonterminals_listT
    := fun ls nt =>
         filter (fun x => if string_dec nt x then false else true) ls.

  Definition rdp_list_nonterminals_listT_R : rdp_list_nonterminals_listT -> rdp_list_nonterminals_listT -> Prop
    := ltof _ (@List.length _).
  Lemma filter_list_dec {T} f (ls : list T) : List.length (filter f ls) <= List.length ls.
  Proof.
    induction ls; trivial; simpl in *.
    repeat match goal with
             | [ |- context[if ?a then _ else _] ] => destruct a; simpl in *
             | [ |- S _ <= S _ ] => solve [ apply Le.le_n_S; auto ]
             | [ |- _ <= S _ ] => solve [ apply le_S; auto ]
           end.
  Qed.
  Lemma rdp_list_remove_nonterminal_dec : forall ls prods,
                                            @rdp_list_is_valid_nonterminal ls prods = true
                                            -> @rdp_list_nonterminals_listT_R (@rdp_list_remove_nonterminal ls prods) ls.
  Proof.
    intros.
    unfold rdp_list_is_valid_nonterminal, rdp_list_nonterminals_listT_R, rdp_list_remove_nonterminal, ltof in *.
    edestruct in_dec; [ | discriminate ].
    match goal with
      | [ H : In ?prods ?ls |- context[filter ?f ?ls] ]
        => assert (~In prods (filter f ls))
    end.
    { intro H'.
      apply filter_In in H'.
      destruct H' as [? H'].
      edestruct string_dec; congruence. }
    { match goal with
        | [ |- context[filter ?f ?ls] ] => generalize dependent f; intros
      end.
      induction ls; simpl in *; try congruence.
      repeat match goal with
               | [ |- context[if ?x then _ else _] ] => destruct x; simpl in *
               | [ H : _ \/ _ |- _ ] => destruct H
               | _ => progress subst
               | [ H : ~(_ \/ _) |- _ ] => apply Decidable.not_or in H
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : ?x <> ?x |- _ ] => exfalso; apply (H eq_refl)
               | _ => apply Lt.lt_n_S
               | _ => apply Le.le_n_S
               | _ => apply filter_list_dec
               | [ H : _ -> _ -> ?G |- ?G ] => apply H; auto
             end. }
  Qed.
  Lemma rdp_list_ntl_wf : well_founded rdp_list_nonterminals_listT_R.
  Proof.
    unfold rdp_list_nonterminals_listT_R.
    intro.
    apply well_founded_ltof.
  Defined.

  Lemma rdp_list_remove_nonterminal_1
  : forall ls ps ps',
      rdp_list_is_valid_nonterminal (rdp_list_remove_nonterminal ls ps) ps' = true
      -> rdp_list_is_valid_nonterminal ls ps' = true.
  Proof.
    unfold rdp_list_is_valid_nonterminal, rdp_list_remove_nonterminal.
    repeat match goal with
             | _ => exfalso; congruence
             | _ => reflexivity
             | [ |- appcontext[if ?E then _ else _] ] => destruct E
             | _ => intro
             | [ H : In _ (filter _ _) |- _ ] => apply filter_In in H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
           end.
  Qed.

  Lemma rdp_list_remove_nonterminal_2
  : forall ls ps ps',
      rdp_list_is_valid_nonterminal (rdp_list_remove_nonterminal ls ps) ps' = false
      <-> rdp_list_is_valid_nonterminal ls ps' = false \/ ps = ps'.
  Proof.
    unfold rdp_list_is_valid_nonterminal, rdp_list_remove_nonterminal.
    repeat match goal with
             | _ => exfalso; congruence
             | _ => reflexivity
             | _ => progress subst
             | _ => intro
             | [ H : context[In _ (filter _ _)] |- _ ] => rewrite filter_In in H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
             | [ |- true = false \/ _ ] => right
             | [ |- ?x = ?x \/ _ ] => left; reflexivity
             | [ H : ~(_ /\ ?x = ?x) |- _ ] => specialize (fun y => H (conj y eq_refl))
             | [ H : _ \/ _ |- _ ] => destruct H
             | [ |- _ <-> _ ] => split
             | [ H : appcontext[if ?E then _ else _] |- _ ] => destruct E
             | [ |- appcontext[if ?E then _ else _] ] => destruct E
           end.
  Qed.

  Global Instance rdp_list_predata : parser_computational_predataT
    := { nonterminals_listT := rdp_list_nonterminals_listT;
         initial_nonterminals_data := Valid_nonterminals G;
         is_valid_nonterminal := rdp_list_is_valid_nonterminal;
         remove_nonterminal := rdp_list_remove_nonterminal;
         nonterminals_listT_R := rdp_list_nonterminals_listT_R;
         remove_nonterminal_dec := rdp_list_remove_nonterminal_dec;
         ntl_wf := rdp_list_ntl_wf }.

  Global Instance rdp_list_data' : @parser_computational_types_dataT _ String
    := { predata := rdp_list_predata;
         split_stateT := fun _ _ _ _ => True }.

  Global Instance rdp_list_rdata' : @parser_removal_dataT' rdp_list_predata
    := { remove_nonterminal_1 := rdp_list_remove_nonterminal_1;
         remove_nonterminal_2 := rdp_list_remove_nonterminal_2 }.
End recursive_descent_parser_list.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import machine_int.
Require Import mips_cmd.

Local Open Scope mips_cmd_scope.
Import expr_m.

Definition multi_sub_u_u (k a b c t j u bor atmp btmp : reg) :=
  addiu j r0 zero16 ;
  addiu t c zero16 ;
  addiu bor r0 zero16 ;
  While (bne j k) {{
    lwxs atmp j b ;
    addu btmp atmp bor ;
    sltu u btmp atmp ;
    lwxs atmp j a ;
    (If_beq u, r0 Then
      addiu u r0 one16 ;
      multu atmp u ;
      msubu btmp u ;
      sltu bor atmp btmp ;
      mflhxu atmp
    Else
      nop) ;
    sw atmp zero16 t ;
    addiu t t four16 ;
    addiu j j one16 }}.