Require Import pv_in.
Require Import PeanoNat Compare_dec Lia.

Definition occ_in_modal (phi : Modal) (i : nat) : Prop :=
i <> 0 /\ le i (length (pv_in phi)).

Lemma occ_in_modal_le : forall (phi : Modal) (i : nat),
  occ_in_modal phi i ->
    le i (length (pv_in phi)).
Proof. intros phi i [Hneq Hle]. assumption. Qed.

Lemma occ_in_modal_0 : forall (phi : Modal) (i : nat),
  occ_in_modal phi i -> i <> 0.
Proof.  intros phi i [Hneq Hleb]. assumption. Qed.

Lemma occ_in_modal_f : forall phi i,
    ~ occ_in_modal phi i -> (i = 0 \/ i > length (pv_in phi)).
Proof.
  intros phi i H.
  unfold gt.
  destruct (Nat.eq_dec i 0) as [H2 | H2]. auto.
  destruct (lt_dec (length (pv_in phi)) i) as [?|H3]. auto.
  apply Nat.nlt_ge in H3. firstorder.
Qed.

Lemma occ_in_modal_leb3 : forall (phi : Modal) (n : nat),
  n <> 0 -> le n (length (pv_in phi)) -> occ_in_modal phi n.
Proof. intros; constructor; assumption. Qed.

Lemma occ_in_modal_leb2 : forall (phi : Modal) (n : nat),
  occ_in_modal phi n -> (n <> 0 /\ le n (length (pv_in phi))).
Proof. intros phi n [Hneq Hleb]. auto. Qed.

Lemma occ_in_modal_mconj_l : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal phi1 i ->
    occ_in_modal (mconj phi1 phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2]. constructor. assumption.
  simpl. rewrite app_length. lia.
Qed.

Lemma occ_in_modal_mdisj_l : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal phi1 i ->
    occ_in_modal (mdisj phi1 phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2]. constructor. assumption.
  simpl. rewrite app_length. lia.
Qed.

Lemma occ_in_modal_mimpl_l : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal phi1 i ->
    occ_in_modal (mimpl phi1 phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2]. constructor. assumption.
  simpl. rewrite app_length. lia.
Qed.

Lemma occ_in_modal_mconj_r : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal phi2 i ->
    occ_in_modal (mconj phi1 phi2) (length (pv_in phi1) + i).
Proof.
  intros phi1 phi2 i [Hneq Hleb]. constructor.
  intros H. destruct i; firstorder.
  simpl. rewrite app_length. lia.
Qed.

Lemma occ_in_modal_mdisj_r : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal phi2 i ->
    occ_in_modal (mdisj phi1 phi2) (length (pv_in phi1) + i).
Proof.
  intros phi1 phi2 i [Hneq Hleb]. constructor.
  intros H. destruct i; firstorder.
  simpl. rewrite app_length. lia.
Qed.

Lemma occ_in_modal_mimpl_r : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal phi2 i ->
    occ_in_modal (mimpl phi1 phi2) (length (pv_in phi1) + i).
Proof.
  intros phi1 phi2 i [Hneq Hleb]. constructor.
  intros H. destruct i; firstorder.
  simpl. rewrite app_length. lia.
Qed.

Lemma occ_in_modal_mconj : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal (mconj phi1 phi2) i ->
    ~ occ_in_modal phi1 i ->
      occ_in_modal phi2 (i - length (pv_in phi1)).
Proof.
  intros phi1 phi2 i [Heq1 Hleb1] H. constructor.
  apply occ_in_modal_f in H. destruct H as [H | H].
  contradiction. lia. simpl in Hleb1.
  rewrite app_length in Hleb1. lia.
Qed.

Lemma occ_in_modal_mdisj : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal (mdisj phi1 phi2) i ->
    ~ occ_in_modal phi1 i ->
      occ_in_modal phi2 (i - length (pv_in phi1)).
Proof.
  intros phi1 phi2 i [Heq1 Hleb1] H. constructor.
  apply occ_in_modal_f in H. destruct H as [H | H].
  contradiction. lia. simpl in Hleb1.
  rewrite app_length in Hleb1. lia.
Qed.

Lemma occ_in_modal_mimpl : forall (phi1 phi2 : Modal) (i : nat),
  occ_in_modal (mimpl phi1 phi2) i ->
    ~occ_in_modal phi1 i ->
      occ_in_modal phi2 (i - length (pv_in phi1)).
Proof.
  intros phi1 phi2 i [Heq1 Hleb1] H. constructor.
  apply occ_in_modal_f in H. destruct H as [H | H].
  contradiction. lia. simpl in Hleb1.
  rewrite app_length in Hleb1. lia.
Qed.

Lemma occ_in_modal_mneg : forall (phi : Modal) (i : nat),
  occ_in_modal (mneg phi) i <->
    occ_in_modal phi i.
Proof.
  intros phi i. split; intros [Heq Hleb]; constructor; auto.
Qed.

Lemma occ_in_modal_box : forall (phi : Modal) (i : nat),
  occ_in_modal (box phi) i <->
    occ_in_modal phi i.
Proof.
  intros phi i. split; intros [Heq Hleb]; constructor; auto.
Qed.

Lemma occ_in_modal_dia : forall (phi : Modal) (i : nat),
  occ_in_modal (dia phi) i <->
    occ_in_modal phi i.
Proof.
  intros phi i. split; intros [Heq Hleb]; constructor; auto.
Qed.

Lemma occ_in_modal_atom : forall (p : propvar) (i : nat),
  occ_in_modal (atom p) i -> i = 1.
Proof.
  intros p i [Heq Hleb]. simpl in *. firstorder.
Qed.

Lemma occ_in_modal_leb_minus : forall phi n m,
    occ_in_modal phi (n - m) -> n <=? m = false.
Proof.
  intros phi n m [H1 H2].
  apply Compare_dec.leb_iff_conv. firstorder.
Qed.

Lemma occ_in_modal_atom2 : forall p,
    occ_in_modal #p 1.
Proof.  intros p. constructor; auto. Qed.

Lemma if_then_else_f_t_t_f: forall (a : bool),
    (if a then false else true) = true -> a = false.
Proof. intros a. destruct a; auto. Qed.

Lemma occ_in_modal_mconj_r2 : forall phi1 phi2 i,
    occ_in_modal phi2 (i - length (pv_in phi1)) ->
    occ_in_modal (phi1 m∧ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. destruct i; auto.
  simpl. rewrite app_length.
  rewrite  Nat.add_comm.
  apply Nat.le_sub_le_add_r. assumption.
Qed.

Lemma occ_in_modal_mdisj_r2 : forall phi1 phi2 i,
    occ_in_modal phi2 (i - length (pv_in phi1)) ->
    occ_in_modal (phi1 m∨ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. destruct i; auto.
  simpl. rewrite app_length.
  rewrite  Nat.add_comm.
  apply Nat.le_sub_le_add_r. assumption.
Qed.

Lemma occ_in_modal_mimpl_r2 : forall phi1 phi2 i,
    occ_in_modal phi2 (i - length (pv_in phi1)) ->
    occ_in_modal (phi1 m→ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. destruct i; auto.
  simpl. rewrite app_length.
  rewrite  Nat.add_comm.
  apply Nat.le_sub_le_add_r. assumption.
Qed.

Lemma occ_in_modal_dec : forall phi i,
    {occ_in_modal phi i} + {~ occ_in_modal phi i}.
Proof.
  induction phi; intros i;
    try   (destruct (IHphi i) as [IH | IH]; firstorder).

  destruct i. right. intros H. inversion H; contradiction.
  destruct i. left. constructor; auto.
  right. intros H. inversion H as [? H1].
  simpl in *. inversion H1 as [ | H3 H2]. inversion H2.

  destruct (IHphi1 i) as [IH1 | IH1].
  left. apply occ_in_modal_mconj_l. auto.
  destruct (IHphi2 (i - length (pv_in phi1))) as [IH2 | IH2].
  assert ( i = ( (length (pv_in phi1)) + (i - length (pv_in phi1)))) as Hass.
    firstorder.
  left. rewrite Hass. apply occ_in_modal_mconj_r. auto.
  right. intros H. apply occ_in_modal_mconj in H; auto.

  destruct (IHphi1 i) as [IH1 | IH1].
  left. apply occ_in_modal_mdisj_l. auto.
  destruct (IHphi2 (i - length (pv_in phi1))) as [IH2 | IH2].
  assert ( i = ( (length (pv_in phi1)) + (i - length (pv_in phi1)))) as Hass.
    firstorder.
  left. rewrite Hass. apply occ_in_modal_mdisj_r. auto.
  right. intros H. apply occ_in_modal_mdisj in H; auto.

  destruct (IHphi1 i) as [IH1 | IH1].
  left. apply occ_in_modal_mimpl_l. auto.
  destruct (IHphi2 (i - length (pv_in phi1))) as [IH2 | IH2].
  assert ( i = ( (length (pv_in phi1)) + (i - length (pv_in phi1)))) as Hass.
    firstorder.
  left. rewrite Hass. apply occ_in_modal_mimpl_r. auto.
  right. intros H. apply occ_in_modal_mimpl in H; auto.
Qed.


Require Import PocklingtonRefl.

Open Local Scope positive_scope.

Lemma prime174550993 : prime 174550993.
Proof.
 apply (Pocklington_refl
         (Pock_certif 174550993 5 ((11, 1)::(3, 1)::(2,4)::nil) 34)
        ((Proof_certif 11 prime11) ::
         (Proof_certif 3 prime3) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime4567890123456789012345689: prime  4567890123456789012345689.
apply (Pocklington_refl

(SPock_certif
4567890123456789012345689
2
((570986265432098626543211, 1)::nil))
(
(Ell_certif
570986265432098626543211
4566
((125051744509636077691,1)::nil)
570986265432098626449131
9834496
0
3136)
::
(Ell_certif
125051744509636077691
138775
((901111472016823,1)::nil)
0
192
4
16)
::
(SPock_certif
901111472016823
2
((174550993, 1)::nil))
:: (Proof_certif 174550993 prime174550993) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


Require Import Tutorial.

Section data.
  Variable data : Set.
  (* Here we parameterize over an arbitrary type of data stored within stacks. *)
  Variable dummy : data.
  (* Sometimes it's useful to have a default value of the data type. *)

  (** Type signature of an implementation of functional queues *)
  Definition sig : ADTSig :=
    ADTsignature {
      Constructor "empty" : rep,
      Method "enqueue" : rep * data -> rep,
      Method "dequeue" : rep -> rep * (option data)
    }.
  (* Notice that "effectful" methods just return new private-state values,
   * in addition to being passed original state values as parameters. *)

  (** The specification of functional correctness *)
  Definition spec : ADT sig :=
    Def ADT
    {
      rep := list data, (* This first part is the abstract representation type. *)
      Def Constructor "empty" : rep :=
        ret nil,,
      Def Method1 "enqueue" (self : rep) (d : data) : rep :=
        ret (self ++ d :: nil),
      Def Method0 "dequeue"(self : rep) : rep * (option data) :=
        match self with
        | nil => ret (self, None)
        | d :: self' => ret (self', Some d)
        end
    }.

  (* We define an abstraction relation, connecting abstract and concrete states.
   * Classic trick: simulate a queue with two stacks,
   * one of which needs to be reversed to reproduce the abstract queue. *)
  Definition absRel (abs : list data) (conc : list data * list data) :=
    abs = fst conc ++ rev (snd conc).

  (* The appropriate initial states are related. *)
  Lemma absRel_initial : absRel nil (nil, nil).
  Proof.
    reflexivity.
  Qed.

  (* The simple implementation of "push" preserves the relation. *)
  Lemma absRel_push : forall d abs conc, absRel abs conc
    -> absRel (abs ++ d :: nil) (fst conc, d :: snd conc).
  Proof.
    unfold absRel; simpl; intros; subst.
    rewrite app_assoc; reflexivity.
  Qed.

  (* When the concrete state is empty, so must be the abstract state. *)
  Lemma absRel_must_be_nil : forall abs conc,
    absRel abs conc
    -> fst conc = nil
    -> snd conc = nil
    -> abs = nil.
  Proof.
    unfold absRel; destruct conc; simpl; intros; subst; reflexivity.
  Qed.

  (* The abstract queue may be expanded into its first element and tail,
   * if it's related to a concrete state with nonempty first list.
   * In general, such a property depends on a list being nonempty. *)
  Lemma eta_abs_fst : forall abs conc,
    absRel abs conc
    -> fst conc <> nil
    -> abs = hd dummy abs :: tl abs.
  Proof.
    unfold absRel; destruct abs; simpl; intuition.
    destruct (fst conc); simpl in *; intuition congruence.
  Qed.

  (* The abstract queue may be expanded into its first element and tail,
   * if it's related to a concrete state with nonempty second list. *)
  Lemma eta_abs_snd : forall abs conc,
    absRel abs conc
    -> snd conc <> nil
    -> abs = hd dummy abs :: tl abs.
  Proof.
    unfold absRel; destruct abs; simpl; intros.
    destruct (snd conc); simpl in *; intuition.
    apply (f_equal (@length _)) in H.
    repeat rewrite app_length in H; simpl in H.
    arithmetic.
    auto.
  Qed.

  (* The case for preserving the relation on "pop",
   * when we need to reverse the second list. *)
  Lemma absRel_reversed_rep : forall abs conc r,
    absRel abs conc
    -> fst conc = nil
    -> snd conc <> nil
    -> r = rev (snd conc)
    -> absRel (tl abs) (tl r, nil).
  Proof.
    unfold absRel; intuition simpl in *; subst.
    autorewrite with core; auto.
  Qed.

  (* The case for returning the right data value on "pop",
   * when we need to reverse the second list. *)
  Lemma absRel_reversed_data : forall abs conc r,
    absRel abs conc
    -> fst conc = nil
    -> snd conc <> nil
    -> r = rev (snd conc)
    -> hd dummy abs = hd dummy r.
  Proof.
    unfold absRel; intuition simpl in *; subst; auto.
  Qed.

  (* The case for preserving the relation on "pop",
   * in the fast path where the first list is not empty. *)
  Lemma absRel_fast_rep : forall abs conc,
    absRel abs conc
    -> fst conc <> nil
    -> absRel (tl abs) (tl (fst conc), snd conc).
  Proof.
    unfold absRel; intuition simpl in *; subst.
    destruct (fst conc); simpl in *; tauto.
  Qed.

  (* The case for returning the right data value on "pop",
   * in the fast path where the first list is not empty. *)
  Lemma absRel_fast_data : forall abs conc,
    absRel abs conc
    -> fst conc <> nil
    -> hd dummy abs = hd dummy (fst conc).
  Proof.
    unfold absRel; intuition simpl in *; subst; auto.
    destruct (fst conc); simpl in *; tauto.
  Qed.

  (* Now we start deriving an implementation, in a correct-by-construction way. *)
  Theorem implementation : FullySharpened spec.
  Proof.
    start sharpening ADT.
    hone representation using absRel.

    monad_simpl.
    pick_by absRel_initial.
    done.

    monad_simpl.
    pick_by absRel_push.
    done.

    refine_testnil (fst r_n).

    refine_testnil (snd r_n).

    assert (r_o = nil) by (eapply absRel_must_be_nil; eauto).
    subst.
    monad_simpl.
    pick_by absRel_initial.
    monad_simpl.
    done.

    refine_let (rev (snd r_n)).

    erewrite eta_abs_snd with (abs := r_o) by eauto.
    monad_simpl.
    pick_by absRel_reversed_rep.
    monad_simpl.
    erewrite absRel_reversed_data by eauto.
    done.

    done.

    erewrite eta_abs_fst with (abs := r_o) by eauto.
    monad_simpl.
    pick_by absRel_fast_rep.
    monad_simpl.
    erewrite absRel_fast_data with (abs := r_o) by eauto.
    done.

    rewrite refine_let_ret.
    rewrite refine_testnil_ret.
    rewrite refine_testnil_ret.
    done.

    finalize.
  Defined.

  (* We can now extract a standlone Gallina term for this ADT. *)
  Definition impl := Eval simpl in projT1 implementation.
  Print impl.

  (* We can go further, building tactics to automate most of our strategy. *)

  Hint Resolve absRel_initial absRel_push absRel_must_be_nil absRel_reversed_rep absRel_fast_rep.

  Ltac queue' :=
    repeat match goal with
           | _ => progress monad_simpl
           | _ => pick
           | [ H : absRel ?abs _ |- _ ] =>
             match abs with
             | nil => fail 1
             | _ => assert (abs = nil) by eauto; subst
             end
           | [ _ : absRel ?abs_ ?conc |- context[match ?abs_ with nil => _ | _ :: _ => _ end] ] =>
             (erewrite eta_abs_fst with (abs := abs_) by eauto)
             || (erewrite eta_abs_snd with (abs := abs_) by eauto)
           | [ |- context[hd dummy _] ] =>
             (erewrite absRel_reversed_data by eauto)
             || (erewrite absRel_fast_data by eauto)
           end.

  Ltac queue := queue'; done.

  Theorem even_more_automated_implementation : FullySharpened spec.
  Proof.
    start sharpening ADT.
    hone representation using absRel; try queue.

    refine_testnil (fst r_n); [
      refine_testnil (snd r_n); [ queue |
        refine_let (rev (snd r_n)); queue | queue ] | queue | ].

    cleanup; done.

    finalize.
  Defined.

  (* OK, we just spent all that effort on automating the derivation.
   * Ideally the same automation will keep working with different implementations.
   * Let's try another (dumb, slow) one. *)
  Definition dumbAbsRel (abs conc : list data) := conc = rev abs.

  Fixpoint getLast (ls : list data) : (list data * data) :=
    match ls with
    | nil => (nil, dummy)
    | d :: nil => (nil, d)
    | d :: ls' =>
      let p := getLast ls' in
      (d :: fst p, snd p)
    end.

  Lemma dumbAbsRel_initial : dumbAbsRel nil nil.
  Proof.
    reflexivity.
  Qed.

  Lemma dumbAbsRel_push : forall abs conc d,
    dumbAbsRel abs conc
    -> dumbAbsRel (abs ++ d :: nil) (d :: conc).
  Proof.
    unfold dumbAbsRel; simpl; intros.
    rewrite rev_unit.
    congruence.
  Qed.

  Lemma dumbAbsRel_must_be_nil : forall abs conc,
    dumbAbsRel abs conc
    -> conc = nil
    -> abs = nil.
  Proof.
    unfold dumbAbsRel; simpl; intros.
    subst.
    destruct abs; simpl in *; intuition.
    exfalso; eauto.
  Qed.

  Lemma dumbAbsRel_eta : forall abs conc,
    dumbAbsRel abs conc
    -> conc <> nil
    -> abs = hd dummy abs :: tl abs.
  Proof.
    unfold dumbAbsRel; simpl; intros.
    subst.
    destruct abs; intuition.
  Qed.

  Lemma getLast_append_list : forall ls d,
    fst (getLast (ls ++ d :: nil)) = ls.
  Proof.
    induction ls; simpl; intuition.
    destruct (ls ++ d :: nil) eqn:Heq.
    exfalso; eauto.
    rewrite <- Heq.
    rewrite IHls.
    auto.
  Qed.

  Lemma dumbAbsRel_pop_rep : forall abs conc r,
    dumbAbsRel abs conc
    -> conc <> nil
    -> r = getLast conc
    -> dumbAbsRel (tl abs) (fst r).
  Proof.
    unfold dumbAbsRel; intros; subst.
    destruct abs; simpl in *; intuition.
    apply getLast_append_list.
  Qed.

  Lemma getLast_append_data : forall ls d,
    snd (getLast (ls ++ d :: nil)) = d.
  Proof.
    induction ls; auto.

    intros.
    simpl app.
    unfold getLast.
    fold getLast.
    destruct (ls ++ d :: nil) eqn:Heq.
    exfalso; eauto.
    rewrite <- Heq.
    rewrite IHls.
    auto.
  Qed.

  Lemma dumbAbsRel_pop_data : forall abs conc r,
    dumbAbsRel abs conc
    -> conc <> nil
    -> r = getLast conc
    -> hd dummy abs = snd r.
  Proof.
    unfold dumbAbsRel; intros; subst.
    destruct abs; simpl in *; intuition.
    rewrite getLast_append_data; auto.
  Qed.

  Hint Resolve dumbAbsRel_initial dumbAbsRel_push dumbAbsRel_must_be_nil dumbAbsRel_pop_rep.

  (* Here's our first derivation, showing a bit more manual perspective. *)
  Theorem dumb_implementation : FullySharpened spec.
  Proof.
    start sharpening ADT.
    hone representation using dumbAbsRel; try queue.

    refine_testnil r_n.

    assert (r_o = nil) by eauto.
    subst.
    queue.

    refine_let (getLast r_n).
    erewrite dumbAbsRel_eta with (abs := r_o) by eauto.
    erewrite dumbAbsRel_pop_data by eauto.
    queue.

    cleanup.
    done.

    finalize.
  Defined.

  (* We use a double colon to override the prior definition. *)
  Ltac queue' ::=
    repeat match goal with
           | _ => progress monad_simpl
           | _ => pick
           | [ H : dumbAbsRel ?abs _ |- _ ] =>
             match abs with
             | nil => fail 1
             | _ => assert (abs = nil) by eauto; subst
             end
           | [ _ : dumbAbsRel ?abs_ ?conc |- context[match ?abs_ with nil => _ | _ :: _ => _ end] ] =>
             erewrite dumbAbsRel_eta with (abs := abs_) by eauto
           | [ |- context[hd dummy _] ] =>
             erewrite dumbAbsRel_pop_data by eauto
           end.

  (* Now let's automate it more. *)
  Theorem more_automated_dumb_implementation : FullySharpened spec.
  Proof.
    start sharpening ADT.
    hone representation using dumbAbsRel; try queue.

    refine_testnil r_n; [ queue |
      refine_let (getLast r_n); queue | ].

    queue'.
    cleanup.
    done.

    finalize.
  Defined.
End data.


Require Export Imp_J.

(* 定義 *)

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.

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

(* 練習問題: pairs_equiv
   一旦飛ばす *)

(* 例 *)

Theorem aequiv_example :
  aequiv (AMinus (AId X) (AId X)) (ANum O).
Proof.
  intros st.
  simpl.
  apply minus_diag.
Qed.

Theorem bequiv_example :
  bequiv (BEq (AMinus (AId X) (AId X)) (ANum O)) BTrue.
Proof.
  intros st.
  unfold beval.
  rewrite aequiv_example.
  reflexivity.
Qed.

Theorem skip_left : forall c,
  cequiv (SKIP; c) c.
Proof.
  intros c st st'.
  split; intros H.
  Case "->".
    inversion H. subst.
    inversion H2. subst.
    assumption.
  Case "<-".
    apply E_Seq with st.
    apply E_Skip.
    assumption.
Qed.

Theorem skip_right : forall c,
  cequiv (c; SKIP) c.
Proof.
  Admitted.

Theorem IFB_true_simple : forall c1 c2,
  cequiv
    (IFB BTrue THEN c1 ELSE c2 FI)
    c1.
Proof.
  intros c1 c2.
  split; intros H.
  Case "->".
    inversion H; subst. assumption. inversion H5.
  Case "<-".
    apply E_IfTrue. reflexivity. assumption. Qed.

Theorem IFB_true : forall b c1 c2,
  bequiv b BTrue ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  Case "->".
    inversion H; subst.
    SCase "b evaluates to true".
      assumption.
    SCase "b evaluates to false (contradiction)".
      rewrite Hb in H5.
      inversion H5.
  Case "<-".
    apply E_IfTrue; try assumption.
    rewrite Hb. reflexivity. Qed.

(* 練習問題 IFB_false *)
Theorem IFB_false : forall b c1 c2,
  bequiv b BFalse ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c2.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  Case "->".
    inversion H.
    rewrite Hb in H5.
    inversion H5.
    apply H6.
  Case "<-".
    apply E_IfFalse.
    apply Hb.
    apply H. Qed.

(* 練習問題 swap_if_branches *)
Theorem swap_if_branches : forall b e1 e2,
  cequiv
    (IFB b THEN e1 ELSE e2 FI)
    (IFB BNot b THEN e2 ELSE e1 FI).
Proof.
  Admitted.

Theorem WHILE_false : forall b c,
  bequiv b BFalse ->
  cequiv
    (WHILE b DO c END)
    SKIP.
Proof.
  intros b c Hb.
  split; intros H.
  Case "->".
    inversion H; subst.
    SCase "E_WhileEnd".
      apply E_Skip.
    SCase "E_WhileLoop".
      rewrite Hb in H2.
      inversion H2.
  Case "<-".
    inversion H; subst.
    apply E_WhileEnd.
    rewrite Hb.
    reflexivity. Qed.

Lemma WHILE_true_nonterm : forall b c st st',
  bequiv b BTrue ->
  ~( (WHILE b DO c END) / st || st').
Proof.
  intros b c st st' Hb.
  intros H.
  remember (WHILE b DO c END) as cw.
  ceval_cases (induction H) Case;
  inversion Heqcw; subst; clear Heqcw.
  Case "E_WhileEnd". rewrite Hb in H. inversion H.
  Case "E_WhileLoop". apply IHceval2. reflexivity. Qed.

(* 練習問題 WHILE_true *)
Theorem WHILE_true : forall b c,
  bequiv b BTrue ->
  cequiv
    (WHILE b DO c END)
    (WHILE BTrue DO SKIP END).
Proof.
  intros b c Hb.
  split; intros H.
  Case "->".
Admitted.

Theorem loop_unrolling : forall b c,
  cequiv
    (WHILE b DO c END)
    (IFB b THEN (c; WHILE b DO c END) ELSE SKIP FI).
Proof.
  intros b c st st'.
  split; intros Hce.
  Case "->".
    inversion Hce; subst.
    SCase "loop doesn't run".
      apply E_IfFalse.
      assumption.
      apply E_Skip.
    SCase "loop runs".
      apply E_IfTrue.
      assumption.
      apply E_Seq with (st' := st'0).
      assumption.
      assumption.
  Case "<-".
    inversion Hce; subst.
    SCase "loop runs".
      inversion H5; subst.
      apply E_WhileLoop with (st' := st'0).
      assumption. assumption. assumption.
    SCase "loop doesn't run".
      inversion H5; subst. apply E_WhileEnd. assumption. Qed.

(* 練習問題 seq_assoc *)

Theorem seq_assoc : forall c1 c2 c3,
  cequiv ((c1;c2);c3) (c1;(c2;c3)).
Proof.
  Admitted.


From HoTT Require Import Basics Types Spaces.Nat Classes.implementations.peano_naturals.

(** * Monoids *)

(** This defines the type of monoids as a record, which is equvialent to a nested sigma-type but has the convenience of 'named projections' (explained below). *)

Record Monoid := {
    monoid_type : Type;
    monoid_ishset : IsHSet monoid_type;
    monoid_unit : monoid_type;
    monoid_op : monoid_type -> monoid_type -> monoid_type;
    monoid_op_assoc : forall x y z,
      monoid_op x (monoid_op y z) = monoid_op (monoid_op x y) z;
    monoid_left_identity : forall x, monoid_op monoid_unit x = x;
    monoid_right_identity : forall x, monoid_op x monoid_unit = x;
  }.

(** [monoid_type], [monoid_op], etc... are "named projections" or "accessors". Given [M : Monoid], the underlying type is [monoid_type M]. Simlarly, [monoid_op M] is the binary operation. *)
Check monoid_type.

(** If we have [M : Monoid], then to pick an element of [M] we have to write [x : monoid_type M]. This line lets us simply write [x : M] by making [monoid_type] a coercion. *)
Coercion monoid_type : Monoid >-> Sortclass.

(** We make the monoid an implicit argument to some of the accessors, as Coq can usually figure it out. *)
Arguments monoid_unit {_}.
Arguments monoid_op {_} _ _.
Arguments monoid_left_identity {_} _.
Arguments monoid_right_identity {_} _.

(** This adds the fact that monoids are sets to Coq's "typeclass database," which lets us apply results about sets to monoids without having to repeatedly prove to Coq that monoids are sets. *)
Local Existing Instance monoid_ishset.

(** Standard notation. *)
Local Notation "1" := monoid_unit : monoid_scope.
Local Notation "x * y" := (monoid_op x y) : monoid_scope.

Delimit Scope monoid_scope with monoid.

Open Scope monoid_scope.

Record MonoidHom (M N : Monoid) := {
    monoidhom_fun : M -> N;
    monoidhom_unit : monoidhom_fun 1 = 1;
    monoidhom_op : forall x y : M,
      monoidhom_fun (x * y) = monoidhom_fun x * monoidhom_fun y;
  }.

Coercion monoidhom_fun : MonoidHom >-> Funclass.

(** ** Basics *)

Lemma unique_left_unit (M : Monoid) (u : M)
  : (forall x : M, u * x = x) -> (u = 1).
Proof.
  intro is_left_unit_u.
  pose (u1 := is_left_unit_u 1).
  refine (_ @ u1). (* the symbol [@] is for path concatenation *)
  exact (monoid_right_identity u)^. (* the hat [^] inverts a path *)
Defined.

Lemma unique_right_unit (M : Monoid) (u : M)
  : (forall x : M, x * u = x) -> (u = 1).
Proof.
  intro is_right_unit_u.
  (* This can be inlined, but you need to clarify which "1" you mean.  I think the [@] notation makes Coq think we are in path_scope. *)
  exact ((monoid_left_identity u)^ @ is_right_unit_u 1%monoid).
Defined.

(** Next, state and prove the following:  for [x] in a monoid, if [y] is a left-inverse to [x] and [z] is a right-inverse to [x], then [y = z]. *)
(** It follows that two two-sided inverses are equal.  Do you think it is true that two left-inverses are necessarily equal? *)

Lemma inverses_coincide (M : Monoid) (x y z : M) : (y * x = 1) * (x * z = 1) -> (y = z).
Proof.
  intros [p q].
  (* Most of the time (but not always), it's best not to "pose" things into the context. *)
  (* Instead, we can build up a composite of paths, one step at a time, like this: *)
  refine ((monoid_right_identity y)^ @ _).
  (* [refine] lets me partially solve a goal, with underscores creating new goals (unless Coq can guess how to fill them in). *)
  refine ((ap _ q)^ @ _).  (* Coq guesses the function. *)
  refine (monoid_op_assoc _ _ _ _ @ _).
  refine (ap (fun m => m*z) p @ _).  (* Here Coq needs help. *)
  apply monoid_left_identity.
  (* Advantages of the iterative approach:
     - Coq can guess arguments, since the terms are being defined with a specific goal in mind.
       This saves you work.
     - Coq tells you what the next goal is, so you don't have to do scratch work figuring out
       the final answer all at once.
     - The reader can follow along and see how the proof progresses. *)
Defined.

(** ** The two monoid structures on [Bool] *)

(** Look at the definition of [Bool] in Types/Bool. There are two monoid structures on [Bool], one using [andb] and one using [orb]. *)

Definition monoid_bool_orb : Monoid.
Proof.
  (* Coq automatically gives us a function [Build_Monoid] which lets us construct monoids. *)
  (* [srapply] is a custom tactic in the HoTT library which figures out how many arguments need to be supplied to a function and leaves those as goals for you to figure out. *)
  srapply (Build_Monoid Bool).
  - exact false.
  - exact orb.
  - induction x; induction y; reflexivity.
  - simpl. reflexivity.
  - induction x; reflexivity.
    (* [simpl]'s that don't change anything should be removed. *)
Defined.

Definition monoid_bool_andb : Monoid.
Proof.
  srapply (Build_Monoid Bool).
  - exact true.
  - exact andb.
  - induction x; induction y; reflexivity.
  - simpl. reflexivity.
  - induction x; reflexivity.
Defined.

(** The negation function [negb] defines a homomorphism between these monoid structures. *)

Definition monoid_negb : MonoidHom monoid_bool_andb monoid_bool_orb.
  srapply Build_MonoidHom.
  - exact negb.
  - simpl. reflexivity.
  - simpl. induction x; reflexivity.
Defined.

(** ** The monoid structure on [nat] *)

(** Next show that set of natural numbers is a monoid. The natural numbers are defined in Basics/Overture (search for "Natural numbers"), and there are useful functions in Spaces/Nat. You can also use Coq's search functionality to find things, by giving the signature of the term that you want: *)
Search (nat -> nat -> nat).

Definition monoid_nat : Monoid.
Proof.
srapply (Build_Monoid nat).
- exact O.
- exact add.
- apply add_assoc. (* Your proofs were great! It can be hard to find existing things in the library. *)
- reflexivity.
- apply add_0_r.
Defined.

(* Need to prove that everything in the image of the proposed homomorphism below commutes, so I define it as a
   function of its underlying types first and check the identifications in the next Lemma. *)

(* Essentially exponentiation on x by natural numbers *)
(* { } indicates implicit arguments. *)
Definition monoid_exp {M : Monoid} (x : M) : monoid_nat -> M.
Proof.
  - intro n. induction n.
    + exact 1.
    + exact (IHn * x).
Defined.

(* Is there a way to coerce Coq into understanding a different encoding for a function? Writing
   ptd_mon_function M x for each application is a bit cumbersome and obfuscates the code, but I wanted a
   descriptive name. *)
(* I chose a shorter descriptive name, and made the [M] argument implicit. You could also make a notation, if you want, e.g. [x ** n]. *)
Lemma xy_paths_commute (M : Monoid) (x : M) : forall n, (monoid_exp x n) * x = x * (monoid_exp x n).
Proof.
  intro y. induction y.
  + cbn.
    exact (monoid_left_identity _ @ (monoid_right_identity _)^).
  + simpl. (* [cbn] and [simpl] use different heuristics, and sometimes [simpl] is better. *)
    refine (ap (fun m => m*x) IHy @ _).
    symmetry.  (* reverse LHS and RHS *)
    apply monoid_op_assoc. (* Coq can guess the arguments. *)
Defined.

(** Next state and prove that if [M] is any monoid with a chosen element [x], there is a monoid homomorphism from [nat] to [M] sending [1] to [x]. *)

(* Jarl and I did a similar path concatenation on the board; is there a more concise way of making this proof go through? *)

Lemma monoid_hom_exp {M : Monoid} (x : M) : MonoidHom monoid_nat M.
Proof.
srapply Build_MonoidHom.
- exact (monoid_exp x).
- cbn. reflexivity.
- intros m n. induction m.
  + simpl. symmetry. apply monoid_left_identity.
  + simpl.
    (* I won't clean this up, since I give a better approach below. *)
    pose (ap_IH := ap (fun y => y*x) IHm).
    pose (assoc := monoid_op_assoc M (monoid_exp x m) (monoid_exp x n) x).
    pose (IH_assoc := ap_IH @ assoc^).
    pose (ap_comm_paths := ap (monoid_op (monoid_exp x m)) (xy_paths_commute M x n)).
    pose (IH_assoc_comm := IH_assoc @ ap_comm_paths).
    pose (assoc' := monoid_op_assoc M (monoid_exp x m) x (monoid_exp x n)).
    exact (IH_assoc_comm @ assoc').
Defined.

(* Essentially exponentiation on x by natural numbers *)
(* Since the successor of [n] is [1 + n], let's define [monoid_exp' (S n)] to be [x * monoid_exp n]. *)
Definition monoid_exp' {M : Monoid} (x : M) : monoid_nat -> M.
Proof.
  - intro n. induction n.
    + exact 1.
    + exact (x * IHn).
Defined.

(* Now we don't need the lemma about commutation, and the proof below is much shorter.
   This is a good lesson:  choose your definitions carefully, and if they seem to lead
   to complication, look at how you might be able to change them to make later things easier. *)

(** Next state and prove that if [M] is any monoid with a chosen element [x], there is a monoid homomorphism from [nat] to [M] sending [1] to [x]. *)
Lemma monoid_hom_exp' {M : Monoid} (x : M) : MonoidHom monoid_nat M.
Proof.
  srapply Build_MonoidHom.
  - exact (monoid_exp' x).
  - cbn. reflexivity.
  - intros m n. induction m.
    + simpl. symmetry. apply monoid_left_identity.
    + simpl.
      refine (ap _ IHm @ _). (* Coq can guess the function. *)
      apply monoid_op_assoc.
Defined.


Require Import IExpr.
Require Import ZArith.

Inductive irectangle : Set :=
| IRectangle : iexpr -> iexpr -> iexpr -> iexpr -> irectangle.

Fixpoint foldIRectangleConstants (r : irectangle) : irectangle :=
  match r with
    | IRectangle rs re cs ce =>
      IRectangle (tryFoldConstantsRec rs)
                 (tryFoldConstantsRec re)
                 (tryFoldConstantsRec cs)
                 (tryFoldConstantsRec ce)
  end.

Fixpoint isConstIRectangle (r : irectangle) : Prop :=
  match foldIRectangleConstants r with
    | IRectangle (IConst _) (IConst _) (IConst _) (IConst _) => True
    | _ => False
  end.

Open Scope Z_scope.

Check (exists i : Z, i + 2 = 3).

Check ex.

Check ex_intro.

Check (exists k : Z, k + 2 = 4).

Fixpoint mkExists (b : iexpr) (P : Prop) : Prop :=
  exists b : iexpr, P.


Require Export Metalib.Metatheory.
Require Export Stlc.Classes.
Require Import Stlc.DefinitionsSyntax.
Require Import Stlc.ClassInstances.

(* Tactics for simplifying syntax definitions *)

Lemma fv_exp_var_b : forall n (m: fin n), fv (var_b m) = {}.
Proof. reflexivity. Qed.
Lemma fv_exp_var_f : forall n (x:atom), fv (var_f (n:=n) x) = {{x}}.
Proof. reflexivity. Qed.
Lemma fv_exp_abs : forall n (e: exp (S n)), fv (abs e) = fv e.
Proof. reflexivity. Qed.
Lemma fv_exp_app : forall n (e1 : exp n) (e2: exp n), fv (app e1 e2) = fv e1 `union` fv e2.
Proof. reflexivity. Qed.

#[export] Hint Rewrite fv_exp_var_b fv_exp_var_f fv_exp_abs fv_exp_app : fv.

(* Re-define behavior of size in terms of size_exp *)
Lemma size_exp_var_b : forall n (m: fin n), size (var_b m) = 1.
Proof. reflexivity. Qed.
Lemma size_exp_var_f : forall n (x:atom), size (var_f (n:=n) x) = 1.
Proof. reflexivity. Qed.
Lemma size_exp_abs : forall n (e: exp (S n)), size (abs e) = 1 + (size e).
Proof. reflexivity. Qed.
Lemma size_exp_app : forall n (e1 : exp n) (e2: exp n), size (app e1 e2) = 1 + size e1 + size e2.
Proof. reflexivity. Qed.

#[export] Hint Rewrite size_exp_var_b size_exp_var_f size_exp_abs size_exp_app : size.

Lemma weaken_exp_var_b : forall n (m: fin n),   weaken  (var_b m) = var_b (increase_fin m).
Proof. reflexivity. Qed.
Lemma weaken_exp_var_f : forall n (x:atom), weaken (var_f (n:=n) x) = var_f x.
Proof. reflexivity. Qed.
Lemma weaken_exp_abs : forall n (e: exp (S n)), weaken (abs e) = abs (weaken e).
Proof. reflexivity. Qed.
Lemma weaken_exp_app : forall n (e1 : exp n) (e2: exp n), weaken (app e1 e2) = app (weaken e1) (weaken e2).
Proof. reflexivity. Qed.

#[export] Hint Rewrite weaken_exp_var_b weaken_exp_var_f weaken_exp_abs weaken_exp_app : weaken.

Lemma close_exp_var_b : forall n x (m: fin n),   close x (var_b m) = var_b (increase_fin m).
Proof. reflexivity. Qed.
Lemma close_exp_var_f : forall n (x1 x2:atom), close x1 (var_f (n:=n) x2) = if (x1 == x2) then (var_b (gof n)) else (var_f x2).
Proof. reflexivity. Qed.
Lemma close_exp_abs : forall n (e: exp (S n)) x1, close x1 (abs e) = abs (close x1 e).
Proof. reflexivity. Qed.
Lemma close_exp_app : forall n (e1 : exp n) (e2: exp n) x1, close x1 (app e1 e2) = app (close x1 e1) (close x1 e2).
Proof. reflexivity. Qed.

#[export] Hint Rewrite close_exp_var_b close_exp_var_f close_exp_abs close_exp_app : close.

Lemma open_exp_var_b : forall n (u:exp n) (m: fin (S n)),
    open u (var_b m) =
      match decrease_fin n m with
      | Some f => var_b f
      | None => u
      end.
Proof. reflexivity. Qed.
Lemma open_exp_var_f : forall n (u:exp n) (x:atom), open u (var_f (n:= S n) x) = var_f x.
Proof. reflexivity. Qed.

Lemma open_exp_abs : forall n (u:exp n) (e: exp (S (S n))),
    open u (abs e) = abs (open (weaken u) e).
Proof. reflexivity. Qed.
Lemma open_exp_app : forall n (u:exp n) (e1 : exp (S n)) (e2: exp (S n)),
    open u (app e1 e2) = app (open u e1) (open u e2).
Proof. reflexivity. Qed.

#[export] Hint Rewrite open_exp_var_b open_exp_var_f open_exp_abs open_exp_app : open.

Lemma subst_exp_var_b : forall n (u:exp n) (y:atom) (m: fin n),
    subst u y (var_b m) = var_b m.
Proof. reflexivity. Qed.
Lemma subst_exp_var_f : forall n (u:exp n) (y:atom) (x:atom),
    subst u y (var_f (n:=n) x) = if x == y then u else var_f x.
Proof. reflexivity. Qed.
Lemma subst_exp_abs : forall n (u:exp n) (y:atom) (e: exp (S n)),
    subst u y (abs e) = abs (subst (weaken u) y e).
Proof. reflexivity. Qed.
Lemma subst_exp_app : forall n (u:exp n) (y:atom) (e1 : exp n) (e2: exp n),
    subst u y (app e1 e2) = app (subst u y e1) (subst u y e2).
Proof. reflexivity. Qed.

#[export] Hint Rewrite subst_exp_var_b subst_exp_var_f subst_exp_abs subst_exp_app : subst.


Set Implicit Arguments.

Require Import Crypto.
Require Import RndNat.

Definition Bernoulli(r : Rat) : Comp bool :=
  match r with
    | RatIntro n d =>
      v <-$ RndNat d; ret (if (lt_dec v n) then true else false)
  end.

Theorem Bernoulli_correct :
  forall (r : Rat),
    r <= 1 ->
    Pr[Bernoulli r] == r.

  unfold Bernoulli.
  intuition.
  destruct r.

  rewrite RndNat_seq.

  rewrite (sumList_filter_partition (fun z => if (lt_dec z n) then true else false)).
  eapply eqRat_trans.
  eapply ratMult_eqRat_compat.
  eapply eqRat_refl.
  eapply ratAdd_eqRat_compat.

  eapply sumList_all.
  intros.
  destruct ( lt_dec a n).
  simpl.
  destruct ( EqDec_dec bool_EqDec true true).
  eapply eqRat_refl.
  intuition.
  apply filter_In in H0.
  intuition.
  exfalso.
  destruct (lt_dec a n); intuition.

  eapply sumList_0.
  intros.
  apply filter_In in H0.
  intuition.
  destruct (lt_dec a n); simpl in *.
  discriminate.
  destruct (EqDec_dec bool_EqDec false true); intuition.

  rewrite allNatsLt_filter_lt.
  rewrite <- ratAdd_0_r.
  rewrite ratMult_1_r.
  rewrite allNatsLt_length.
  rewrite <- ratMult_num_den.
  eapply eqRat_terms.
  omega.
  unfold posnatMult, posnatToNat, natToPosnat.
  destruct p.
  omega.

  eapply rat_le_1_if; trivial.

Qed.

Theorem Bernoulli_wf :
  forall r,
    well_formed_comp (Bernoulli r).

  intuition.
  unfold Bernoulli.
  destruct r.
  wftac.

Qed.

Theorem Bernoulli_correct_complement :
  forall (r : Rat),
    r <= 1 ->
    evalDist (Bernoulli r) false ==
    ratSubtract 1 r.

  intuition.
  eapply eqRat_trans.
  eapply evalDist_complement.
  eapply Bernoulli_wf.
  eapply ratSubtract_eqRat_compat; intuition.
  eapply Bernoulli_correct.
  trivial.
Qed.


From Coq Require Import Arith Lia List.
Import ListNotations.
From Equations Require Import Equations.
Ltac refl := reflexivity.
Definition dec (P: Prop) : Type := P + ~P.
Definition eqdec X : Type := forall x x': X, dec (x = x').
Notation sig := sigT.
Notation Sig := existT.
Notation pi1 := projT1.
Notation pi2 := projT2.
Notation "'Sigma' x .. y , p" :=
  (sig (fun x => .. (sig (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'Sigma'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Inductive num : nat -> Type :=
| Zero: forall n, num (S n)
| Next: forall {n}, num n -> num (S n).

Section Vector.
  Variable X : Type.

  Inductive vector : nat -> Type :=
  | Nil : vector O
  | Cons : forall {n}, X -> vector n -> vector (S n).

  Definition vector_elim (p: forall n, vector n -> Type)
    : p 0 Nil ->
      (forall n x v, p n v -> p (S n) (Cons x v)) ->
      forall n v, p n v
    := fun e1 e2 => fix f n v := match v with
                              | Nil => e1
                              | @Cons n' x v' => e2 n' x v' (f n' v')
                              end.

  Definition vec_inv :
    forall {n} (v: vector n),
      match n return vector n -> Type with
      | 0 => fun v => v = Nil
      | S n' => fun v => Sigma x v', v = Cons x v'
      end v.
  Proof.
    intros n v.
    destruct v as [|n x v].
    - refl.
    - exists x, v. refl.
  Defined.

  Goal forall v: vector 0,
      v = Nil.
  Proof.
    intros v. apply (vec_inv v).
  Qed.

  Goal forall n (v: vector (S n)),
      Sigma x v', v = Cons x v'.
  Proof.
    intros n v. apply (vec_inv v).
  Qed.

  (** Head, tail, last, sub *)

  Definition hd {n} (v: vector (S n)) : X :=
    pi1 (vec_inv v).

  Definition tl {n} (v: vector (S n)) : vector n :=
    pi1 (pi2 (vec_inv v)).

  Fact eta_law n (v:vector (S n)) :
    v = Cons (hd v) (tl v).
  Proof.
    destruct (vec_inv v) as (x&v'&->).
    refl.
  Qed.

  Fixpoint last {n} : vector (S n) -> X :=
    match n with
    | 0 => hd
    | S n' => fun v => @last n' (@tl (S n') v)
    end.

  Fixpoint trunc {n} : vector (S n) -> vector n :=
    match n with
    | 0 => fun _ => Nil
    | S n' => fun v => Cons (hd v) (trunc (tl v))
    end.

  Fixpoint sub {n} (a: num n) : vector n -> X :=
    match a with
    | Zero n' => @hd n'
    | @Next n' a' => fun v => @sub n' a' (@tl n' v)
    end.

  (** Constructor injectivity *)

  Fact Cons_inj1 n x x' (v v': vector n) :
    Cons x v = Cons x' v' -> x = x'.
  Proof.
    intros H % (f_equal hd). exact H.
  Qed.

  Fact Cons_inj2 n x x' (v v': vector n) :
    Cons x v = Cons x' v' -> v = v'.
  Proof.
    intros H % (f_equal tl).
    exact H.
  Qed.

  (** Equality Decider *)

  Definition vector_eq n :
    eqdec X -> forall v1 v2: vector n, dec (v1 = v2).
  Proof.
    intros H.
    induction v1 as [|n x1 v1 IH];
      intros v2;
      generalize (vec_inv v2).
    - intros ->. left. refl.
    - intros (x2&v2'&->).
      specialize (H x1 x2) as [<-|H].
      + destruct (IH v2') as [<-|H1].
        * left. refl.
        * right. contradict H1. exact (f_equal tl H1).
      + right. contradict H. exact (f_equal hd H).
  Defined.

  (** Generalized head and tail *)

  Definition Hd  {n} (v: vector n)
    : match n return Type with 0 => True | S n' => X end
    := match v with Nil => I | Cons x _ => x end.

  Definition Tl  {n} (v: vector n)
    : match n return Type with 0 => True | S n' => vector n' end
    := match v with Nil => I | Cons _ v' => v' end.

  Fact Cons_inj n x x' (v v': vector n) :
    Cons x v = Cons x' v' -> x = x' /\ v = v'.
  Proof.
    intros H. split.
    - exact (f_equal Hd H).
    - exact (f_equal Tl H).
  Qed.

  (** Snoc, reverse *)

  Fixpoint snoc {n} (v: vector n) (x: X) : vector (S n) :=
    match v with
    | Nil => Cons x Nil
    | Cons x' v' => Cons x' (snoc v' x)
    end.

  Fixpoint rev {n} (v: vector n) : vector n :=
    match v with
    | Nil => Nil
    | Cons x v' => snoc (rev v') x
    end.

  Goal forall x n (v: vector n),
      last (snoc v x) = x.
  Proof.
    induction v as [|n y v IH]; cbn.
    - refl.
    - exact IH.
  Qed.

  Goal forall n (v: vector (S n)),
      v = snoc (trunc v) (last v).
  Proof.
    induction n as [|n IH];
      intros v;
      destruct (vec_inv v) as (x&v'&->);
      cbn; f_equal.
    - destruct (vec_inv v'); refl.
    - apply IH.
  Qed.

  Fact rev_snoc x n (v: vector n) :
    rev (snoc v x) = Cons x (rev v).
  Proof.
    induction v as [|n y v IH]; cbn.
    - refl.
    - rewrite IH. refl.
  Qed.

  Goal forall n (v: vector n),
      rev (rev v) = v.
  Proof.
    induction v as [|n x v IH]; cbn.
    - refl.
    - rewrite rev_snoc, IH. refl.
  Qed.

  (** Converting between vectors and lists *)

  Fixpoint vec_list {n} (v: vector n) : list X :=
    match v with
    | Nil => nil
    | Cons x v' => cons x (vec_list v')
    end.

  Fact vec_list_length n :
    forall v: vector n, length (vec_list v) = n.
  Proof.
    induction v as [|n x v IH]; cbn.
    - refl.
    - f_equal.  exact IH.
  Qed.

  Fact vec_list_injective n (v1 v2: vector n) :
    vec_list v1 = vec_list v2 -> v1 = v2.
  Proof.
    revert n v1 v2.
    induction v1 as [|n x1 v1 IH];
      intros v2;
      generalize (vec_inv v2).
    - intros ->. easy.
    - intros (x2&v2'&->); cbn.
      intros [= <- H].
      f_equal. apply IH, H.
  Qed.

  Definition guarded_list_vec :
    forall A, Sigma v: vector (length A), vec_list v = A.
  Proof.
    induction A as [|x A IH]; cbn.
    - exists Nil. refl.
    - specialize IH as [v IH].
      exists (Cons x v). cbn. f_equal. exact IH.
  Defined.

  Definition list_vec (A: list X) : vector (length A) :=
    pi1 (guarded_list_vec A).

  Fact vec_list_eq :
    forall A, vec_list (list_vec A) = A.
  Proof.
    intros A.
    apply (pi2 (guarded_list_vec A)).
  Qed.

  Fail Check forall n (v: vector n),
      list_vec (vec_list v) = v.

  Fact vec_cast {n} {v: vector n} :
    vector (length (vec_list v)) -> vector n.
  Proof.
    rewrite vec_list_length. easy.
  Qed.

  Check forall n (v: vector n),
      vec_cast (list_vec (vec_list v)) = v.

  (** Smart matches *)

  Definition hd' {n} (v: vector (S n)) : X :=
    match v with Cons x _ => x end.

  Definition tl' {n} (v: vector (S n)) : vector n :=
    match v with Cons _ v' => v' end.

  Fact eta_law' n (v: vector (S n)) :
    v = Cons (hd' v) (tl' v).
  Proof.
    refine (match v with Cons x v' => eq_refl end).
  Qed.

  Definition hd'' {n} (v: vector (S n)) : X :=
    match v
          in vector n return match n with 0 => True | S _ => X end
    with
    | Nil => I
    | Cons x _ => x
    end.

  Goal forall v: vector 0,
      v = Nil.
  Proof.
    refine (fun v => match v with Nil => eq_refl end).
  Qed.

  Goal forall n (v: vector (S n)),
      Sigma x v', v = Cons x v'.
  Proof.
    refine (fun n v => match v with Cons x v' => _ end).
    exists x, v'. refl.
  Qed.

  (** Experiments *)

  Fixpoint revapp {m} (v: vector m) :
    forall {n} (w: vector n), vector (tail_plus m n) :=
    match v with
    | Nil => fun n w => w
    | Cons x v => fun n w => revapp v (Cons x w)
    end.

  Fail Goal forall n (v: vector n),
      rev v = revapp v Nil.

  Fixpoint app {m n} (v: vector m) (w: vector n) : vector (m + n) :=
    match v with
    | Nil => w
    | Cons x v' => Cons x (app v' w)
    end.

  Fixpoint cast {m n} (v: vector (m + S n)) : vector (S (m + n)).
  Proof.
    rewrite plus_n_Sm. exact v.
  Defined.

  Fact snoc_app m n (v: vector m) (w: vector n) x :
    snoc (app v w) x = cast (app v (snoc w x)).
  Proof.
    induction v as [|n' x' v' IH] in n,w |-*.
    - cbn.
  Abort.

End Vector.

Arguments Nil {X}.
Arguments Cons {X n}.
Arguments hd {X n}.
Arguments hd'' {X n}.
Arguments tl {X n}.
Arguments last {X n}.
Arguments rev {X n}.
Arguments sub {X n}.
Arguments vec_list {X n}.
Arguments list_vec {X}.
Arguments vec_list {X n}.

Compute rev (Cons 5 (Cons 2 Nil)).
Compute hd (tl (Cons 5 (Cons 2 Nil))).
Compute hd'' (tl (Cons 5 (Cons 2 Nil))).
Compute last (Cons 5 (Cons 2 Nil)).

Compute sub (Zero 1) (Cons 5 (Cons 2 Nil)).
Compute sub (Next (Zero 0)) (Cons 5 (Cons 2 Nil)).
Compute vec_list (Cons 5 (Cons 2 Nil)).

Compute list_vec [5;3;7].
Compute vec_list (list_vec [5;3;7]).

Goal vec_list (list_vec [5;3;7]) = [5;3;7].
Proof.
  refl.
Qed.

(** Exercises *)

Fixpoint map {X Y} (f: X -> Y) {n} (v: vector X n) : vector Y n :=
  match v with
  | Nil => Nil
  | Cons x v' => Cons (f x) (map f v')
  end.

Fixpoint tab n : vector (num n) n :=
  match n with
  | 0 => Nil
  | S n' => Cons (Zero n') (map Next (tab n'))
  end.

Compute tab 7.
Compute rev (tab 7).
Compute sub (Zero 6) (rev (tab 7)).


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.
Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
   f_equal. }
   { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
   induction l1.
   { induction l2.
   { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
   { simpl. rewrite append_nil. reflexivity. }
   }
   { intro.  simpl. lfind.  reflexivity.  }
Admitted.

Theorem rev_involutive : forall (x : lst), eq (rev (rev x)) x.
Proof.
   induction x.
   { simpl. rewrite rev_append. simpl. f_equal.
   assumption. }
   { simpl. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
   rewrite append_nil.
   reflexivity. }
Qed.

Theorem rev_qreva_nil : forall (x : lst), eq (rev x) (qreva x Nil).
Proof.
   intros.
   rewrite qreva_append.
   rewrite append_nil.
   reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (qreva x Nil)) x.
Proof.
   intro.
   rewrite <- rev_qreva_nil.
   apply rev_involutive.
Qed.


Require Import List.

Require Import Logic.List.In.
Require Import Logic.List.Include.

Declare Scope Equiv_scope.

Definition Equiv (v:Type) (xs ys:list v) : Prop :=
    (xs <= ys) /\ (ys <= xs).

Arguments Equiv {v}.

Notation "xs == ys" := (Equiv xs ys)
    (at level 70, no associativity) : Equiv_scope.

Open Scope Equiv_scope.

Lemma equivRefl : forall (v:Type) (xs:list v), xs == xs.
Proof.
    intros v xs. split; apply incl_refl.
Qed.

Lemma equivSym : forall (v:Type) (xs ys:list v),
    xs == ys -> ys == xs.
Proof.
    intros v xs ys [H1 H2]. split; assumption.
Qed.

Lemma equivTrans : forall (v:Type) (xs ys zs:list v),
    xs == ys -> ys == zs -> xs == zs.
Proof.
    intros v xs ys zs [H1 H2] [H3 H4]. split;
    apply incl_tran with ys; assumption.
Qed.

Lemma equivNil : forall (v:Type) (xs:list v),
    xs == nil <-> xs = nil.
Proof.
    intros v xs. split.
    - intros [H1 H2]. apply incl_nil. assumption.
    - intros H. rewrite H. apply equivRefl.
Qed.

Lemma equivConsCompat : forall (v:Type) (x:v) (xs ys:list v),
    xs == ys -> cons x xs == cons x ys.
Proof.
    intros v x xs ys [H1 H2]. split; intros z [H3|H3].
    - subst. left. reflexivity.
    - right. apply H1. assumption.
    - subst. left. reflexivity.
    - right. apply H2. assumption.
Qed.

Lemma inConsEquiv : forall (v:Type) (x:v) (xs:list v),
    x :: xs -> cons x xs == xs.
Proof.
    intros a x xs H. split; intros z.
    - intros [H1|H1].
        + subst. assumption.
        + assumption.
    - intros H1. right. assumption.
Qed.

Lemma equivCompatLR : forall (v:Type) (xs' ys' xs ys:list v),
    xs == xs' -> ys == ys' -> xs' == ys' -> xs == ys.
Proof.
    intros v xs' ys' xs ys H1 H2 H3. apply equivTrans with xs'.
    - assumption.
    - apply equivTrans with ys'.
        + assumption.
        + apply equivSym. assumption.
Qed.


Require Export P06.

Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  intros A B f l y. split.
  - (* -> *) intros H. induction l as [| x' l' IHl'].
    + (* l = [] *)
      simpl in H. contradiction.
    + (* l = x' :: l' *)
      simpl in H. destruct H as [H1 | H2].
      { exists x'. split.
        - assumption.
        - simpl. left. reflexivity. }
      { apply IHl' in H2. destruct H2 as [x2 H2]. exists x2. destruct H2. split.
        - assumption.
        - simpl. right. assumption. }
  - (* <- *) intros H. induction l as [| x' l' IHl'].
    + (* l = [] *)
      simpl in H. destruct H. destruct H. contradiction.
    + (* l = x' :: l' *)
      simpl. simpl in H. destruct H as [x'' H]. destruct H. destruct H0.
      { left. rewrite H0. assumption. }
      { right. apply IHl'. exists x''. split.
        - assumption.
        - assumption. }
Qed.


(*
 * Conversion of DataProp terms to negation normal form (NNF).
 *)

Require Import Classical.

Require Import SNF.Inhabited.
Require Import SNF.Context.
Require Import SNF.DataProp.

Inductive NNFProp : TypeContext -> Type :=
  | NNFOpaque  : forall {env}, (Valuation env -> Prop) -> NNFProp env
  | NNFAnd     : forall {env}, NNFProp env -> NNFProp env -> NNFProp env
  | NNFOr      : forall {env}, NNFProp env -> NNFProp env -> NNFProp env
  | NNFExists  : forall {env} (T : Type) `{IsInhabited T}, NNFProp (TypeCons T env) -> NNFProp env
  | NNFForall  : forall {env} (T : Type) `{IsInhabited T}, NNFProp (TypeCons T env) -> NNFProp env
  .

Fixpoint denote_nnf {env : TypeContext} (P : NNFProp env) : Valuation env -> Prop :=
  match P with
  | NNFOpaque A => A
  | NNFAnd A B => fun v => denote_nnf A v /\ denote_nnf B v
  | NNFOr A B => fun v => denote_nnf A v \/ denote_nnf B v
  | NNFExists T body => fun v => exists (x:T), denote_nnf body (ValuationCons x v)
  | NNFForall T body => fun v => forall (x:T), denote_nnf body (ValuationCons x v)
  end.

(* so that our tactics can avoid expanding `negb` everywhere *)
Definition nnf_negb (b : bool) :=
  match b with
  | true => false
  | false => true
  end.

Fixpoint nnf' {env} (P : DataProp env) (negate : bool) : NNFProp env :=
  match P with
  | Opaque A => NNFOpaque (if negate then (fun v => ~(A v)) else A)
  | Literal b => if negate then NNFOpaque (fun _ => if b then False else True) else NNFOpaque (fun _ => if b then True else False)
  | And A B => if negate then NNFOr (nnf' A true) (nnf' B true) else NNFAnd (nnf' A false) (nnf' B false)
  | Or A B => if negate then NNFAnd (nnf' A true) (nnf' B true) else NNFOr (nnf' A false) (nnf' B false)
  | Implies A B => if negate then NNFAnd (nnf' A false) (nnf' B true) else NNFOr (nnf' A true) (nnf' B false)
  | Not A => nnf' A (nnf_negb negate)
  | Exists T body => if negate then NNFForall T (nnf' body true) else NNFExists T (nnf' body false)
  | Forall T body => if negate then NNFExists T (nnf' body true) else NNFForall T (nnf' body false)
  end.

Lemma nnf'_correct:
  forall env (P : DataProp env) negate v,
    denote_nnf (nnf' P negate) v <->
      if negate
      then denote (Not P) v
      else denote P v.
Proof.
  induction P; destruct negate; cbn in *; intros;
    repeat setoid_rewrite IHP;
    repeat setoid_rewrite IHP1;
    repeat setoid_rewrite IHP2;
    try easy.
    - destruct b; easy.
    - intuition; apply not_and_or; intuition.
    - split.
      + apply and_not_or.
      + apply not_or_and.
    - split.
      + intuition.
      + apply imply_to_and.
    - split.
      + intuition.
      + apply imply_to_or.
    - split.
      + intuition.
      + apply NNPP.
    - split.
      + apply all_not_not_ex.
      + apply not_ex_all_not.
    - split.
      + apply ex_not_not_all.
      + apply not_all_ex_not.
Qed.

Definition nnf {env} (P : DataProp env) : NNFProp env :=
  nnf' P false.

Lemma nnf_correct:
  forall env (P : DataProp env) v,
    denote_nnf (nnf P) v <-> denote P v.
Proof.
  intros.
  apply nnf'_correct.
Qed.


From Coq Require Import ZArith Psatz Bool String List Wellfounded Program.Equality.
From Coq Require Import FunctionalExtensionality.
From CDF Require Import IMP Sequences.

Local Open Scope string_scope.
Local Open Scope Z_scope.

(** * 4.  Program logics: Hoare logic *)

(** ** 4.1.  Prelude: direct verification of a program *)

(** We can verify the correctness of a program using nothing but an
    operational semantics for the language in which it is written.
    For example, here is an IMP program that exchanges the values of
    two variables. *)

Definition swap_xy :=
    ASSIGN "t" (VAR "x");; ASSIGN "x" (VAR "y");; ASSIGN "y" (VAR "t").

(** We can characterize the expected behavior of the program as
    follows: started in a store [s], the program always terminates, in
    a store [s'] where ["x"] has value [s "y"] and ["y"] has value [s "x"]. *)

Lemma swap_xy_correct:
  forall s, exists s',
  star red (swap_xy, s) (SKIP, s') /\ s' "x" = s "y" /\ s' "y" = s "x".
Proof.
  intros. econstructor; split.
- eapply star_step. apply red_seq_step. apply red_assign.
  eapply star_step. apply red_seq_done.
  eapply star_step. apply red_seq_step. apply red_assign.
  eapply star_step. apply red_seq_done.
  eapply star_step. apply red_assign.
  apply star_refl.
- unfold update; cbn. auto.
Qed.

(** The proof script is long but not difficult.  First, we perform a
    "symbolic execution" of the program by chaining reduction steps.
    This determines the final store [s'], which is easily shown
    to satisfy the expected property. *)

(** Here is a more complicated example, involving a loop.
    The program adds ["x"] to ["y"] by incrementing ["y"] and
    decrementing ["x"] until ["x"] drops to zero. *)

Definition slow_add :=
  WHILE (LESSEQUAL (CONST 1) (VAR "x"))
        (ASSIGN "x" (MINUS (VAR "x") (CONST 1)) ;;
         ASSIGN "y" (PLUS  (VAR "y") (CONST 1))).

(** The statement of correctness for this program remains simple. *)

Lemma slow_add_correct:
  forall s,
  s "x" >= 0 ->
  exists s', star red (slow_add, s) (SKIP, s') /\ s' "y" = s "y" + s "x".
Proof.
  assert (REC: forall v, 0 <= v ->
               forall s, s "x" = v ->
               exists s', star red (slow_add, s) (SKIP, s') /\ s' "y" = s "y" + s "x").
  { intros v0 v0POS. pattern v0. apply natlike_ind; auto.
  - intros. exists s; split.
    + apply star_one. apply red_while_done. cbn. rewrite H. apply Z.leb_nle. lia.
    + lia.
  - intros v VPOS REC s EQ.
    set (s1 := update "x" v s).
    set (s2 := update "y" (s "y" + 1) s1).
    destruct (REC s2) as (s' & REDS & EQ'). auto.
    exists s'; split.
    + eapply star_step. apply red_while_loop. cbn. rewrite EQ. apply Z.leb_le. lia.
      eapply star_step. apply red_seq_step. apply red_seq_step. apply red_assign.
      eapply star_step. apply red_seq_step. apply red_seq_done.
      eapply star_step. apply red_seq_step. apply red_assign.
      eapply star_step. apply red_seq_done.
      cbn. replace (s "x" - 1) with v by lia. apply REDS.
    + rewrite EQ'. cbn. lia.
  }
  intros. eapply REC; eauto. lia.
Qed.

(** The proof, however, is rather difficult.  We need to perform
    an explicit induction on the value [v] of variable ["x"].
    To use the induction hypothesis, we must manually determine
    some of the intermediate stores: purely symbolic execution
    no longer suffices.  It is inconceivable to verify much more
    complex programs with these techniques! *)

(** Program logics provide higher-level reasoning principles to formally
    verify programs.  In particular, they provide ways to reason about
    loops without setting up a full proof by induction. *)

(** The most familiar program logic is Hoare logic.  In this module,
    we build a Hoare logic to reason about programs written in IMP. *)

(** ** 4.2.  Assertions on the values of variables *)

(** Hoare logic manipulates formulas / claims / assertions that "talk about"
    the values of the program variables.  A typical assertion is
    [0 <= x /\ x <= y], meaning "at this program point, the value of
    variable [x] is positive and less than or equal to the value of
    variable [y]". *)

(** In our Coq development, we represent assertions by Coq logical formulas
    (type [Prop]) parameterized by the current store, which provides
    the values of the variables.

    For example, the assertion [0 <= x /\ x <= y] above is represented
    by the Coq predicate [fun s => 0 <= s "x" /\ s "x" <= s "y"]. *)

Definition assertion : Type := store -> Prop.

(** Here are some useful assertions.
    Conjunction and disjunction of two assertions. *)

Definition aand (P Q: assertion) : assertion :=
  fun s => P s /\ Q s.

Definition aor (P Q: assertion) : assertion :=
  fun s => P s \/ Q s.

(** The assertion "arithmetic expression [a] evaluates to value [v]". *)

Definition aequal (a: aexp) (v: Z) : assertion :=
  fun s => aeval a s = v.

(** The assertions "Boolean expression [b] evaluates to true / to false". *)

Definition atrue (b: bexp) : assertion :=
  fun s => beval b s = true.

Definition afalse (b: bexp) : assertion :=
  fun s => beval b s = false.

(** The assertion written "[ P[x <- a] ]" in the literature.
    Substituting [a] for [x] in [P] amounts to evaluating [P] in
    stores where the variable [x] is equal to the value of expression [a]. *)

Definition aupdate (x: ident) (a: aexp) (P: assertion) : assertion :=
  fun s => P (update x (aeval a s) s).

(** Pointwise implication.  Unlike conjunction and disjunction, this is
    not a predicate over the store, just a Coq proposition. *)

Definition aimp (P Q: assertion) : Prop :=
  forall s, P s -> Q s.

(** A few notations to improve legibility. *)

Notation "P -->> Q" := (aimp P Q) (at level 95, no associativity).
Notation "P //\\ Q" := (aand P Q) (at level 80, right associativity).
Notation "P \\// Q" := (aor P Q) (at level 75, right associativity).

(** ** 4.3.  The rules of weak Hoare logic *)

(** Here are the base rules for Hoare logic.
    They define a relation [Hoare P c Q], where
-   [P] is the precondition, assumed to hold "before" executing [c];
-   [c] is the program or program fragment we reason about;
-   [Q] is the postcondition, guaranteed to hold "after" executing [c].

  This is a "weak" logic, meaning that it does not guarantee termination
  of the command [c].  What is guaranteed is that if [c] terminates,
  then its final store satisfies postcondition [Q]. *)

Inductive Hoare: assertion -> com -> assertion -> Prop :=
  | Hoare_skip: forall P,
      Hoare P SKIP P
  | Hoare_assign: forall P x a,
      Hoare (aupdate x a P) (ASSIGN x a) P
  | Hoare_seq: forall P Q R c1 c2,
      Hoare P c1 Q ->
      Hoare Q c2 R ->
      Hoare P (c1;;c2) R
  | Hoare_ifthenelse: forall P Q b c1 c2,
      Hoare (atrue b //\\ P) c1 Q ->
      Hoare (afalse b //\\ P) c2 Q ->
      Hoare P (IFTHENELSE b c1 c2) Q
  | Hoare_while: forall P b c,
      Hoare (atrue b //\\ P) c P ->
      Hoare P (WHILE b c) (afalse b //\\ P)
  | Hoare_consequence: forall P Q P' Q' c,
      Hoare P c Q ->
      P' -->> P ->
      Q -->> Q' ->
      Hoare P' c Q'.

(** Some derived rules. *)

Lemma Hoare_consequence_pre: forall P P' Q c,
      Hoare P c Q ->
      P' -->> P ->
      Hoare P' c Q.
Proof.
  intros. apply Hoare_consequence with (P := P) (Q := Q); unfold aimp; auto.
Qed.

Lemma Hoare_consequence_post: forall P Q Q' c,
      Hoare P c Q ->
      Q -->> Q' ->
      Hoare P c Q'.
Proof.
  intros. apply Hoare_consequence with (P := P) (Q := Q); unfold aimp; auto.
Qed.

Lemma Hoare_ifthen: forall b c P Q,
    Hoare (atrue b //\\ P) c Q ->
    afalse b //\\ P -->> Q ->
    Hoare P (IFTHENELSE b c SKIP) Q.
Proof.
  intros. apply Hoare_ifthenelse; auto.
  apply Hoare_consequence_pre with Q; auto using Hoare_skip.
Qed.

(** An example of a derivation in Hoare logic. *)

Example Hoare_swap_xy: forall m n,
  Hoare (aequal (VAR "x") m //\\ aequal (VAR "y") n)
        swap_xy
        (aequal (VAR "x") n //\\ aequal (VAR "y") m).
Proof.
  intros.
  eapply Hoare_consequence_pre.
- unfold swap_xy. eapply Hoare_seq. apply Hoare_assign.
  eapply Hoare_seq. apply Hoare_assign. apply Hoare_assign.
- unfold aequal, aupdate, aand, aimp; cbn. tauto.
Qed.

(** *** Exercise (2 stars) *)
(** Here is another way to exchange the values of two variables,
    without using a third, temporary variable. *)

Definition swap_xy_2 :=
  ASSIGN "x" (PLUS (VAR "x") (VAR "y")) ;;
  ASSIGN "y" (MINUS (VAR "x") (VAR "y")) ;;
  ASSIGN "x" (MINUS (VAR "x") (VAR "y")).

(** Prove that this program satisfies the same property as [swap_xy].
    Hint: rework the proof script for [Hoare_swap_xy], only minimal
    changes need to be made. *)

Example Hoare_swap_xy_2: forall m n,
  Hoare (aequal (VAR "x") m //\\ aequal (VAR "y") n)
        swap_xy_2
        (aequal (VAR "x") n //\\ aequal (VAR "y") m).
Proof.
  (* FILL IN HERE *)
Admitted.

(** ** 4.4.  Soundness of Hoare logic *)

(** We give a semantic interpretation to the statements [Hoare P c Q]
    of Hoare logic.  The interpretation is the relation [triple P c Q]
    defined below in terms of IMP's natural semantics
    (the relation [cexec s c s']). *)

Definition triple (P: assertion) (c: com) (Q: assertion) : Prop :=
  forall s s', cexec s c s' -> P s -> Q s'.

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

(** The semantic interpretation validates every rule of Hoare logic. *)

Lemma triple_skip: forall P,
     {{P}} SKIP {{P}}.
Proof.
  unfold triple; intros. inversion H; subst. auto.
Qed.

Lemma triple_assign: forall P x a,
      {{aupdate x a P}} ASSIGN x a {{P}}.
Proof.
  unfold triple, aupdate; intros. inversion H; subst. auto.
Qed.

Lemma triple_seq: forall P Q R c1 c2,
      {{P}} c1 {{Q}} ->
      {{Q}} c2 {{R}} ->
      {{P}} c1;;c2 {{R}}.
Proof.
  unfold triple; intros. inversion H1; subst. eauto.
Qed.

Lemma triple_ifthenelse: forall P Q b c1 c2,
      {{atrue b //\\ P}} c1 {{Q}} ->
      {{afalse b //\\ P}} c2 {{Q}} ->
      {{P}} IFTHENELSE b c1 c2 {{Q}}.
Proof.
  unfold triple, aand, atrue, afalse; intros. inversion H1; subst.
  destruct (beval b s) eqn:B; eauto.
Qed.

Lemma triple_while: forall P b c,
      {{atrue b //\\ P}} c {{P}} ->
      {{P}} WHILE b c {{afalse b //\\ P}}.
Proof.
  unfold triple; intros P b c T s s' E. dependent induction E; intros.
- split; auto.
- eapply IHE2; eauto. apply T with s; auto. split; auto.
Qed.

Lemma triple_consequence: forall P Q P' Q' c,
      {{P}} c {{Q}} ->
      P' -->> P ->
      Q -->> Q' ->
      {{P'}} c {{Q'}}.
Proof.
  unfold triple, aimp; intros. eauto.
Qed.

(** It follows that Hoare logic is sound: every triple derivable by the
    rules of the logic is semantically valid. *)

Theorem Hoare_sound:
  forall P c Q, Hoare P c Q -> {{P}} c {{Q}}.
Proof.
  induction 1; eauto using triple_skip, triple_assign, triple_seq,
  triple_ifthenelse, triple_while, triple_consequence.
Qed.

(** ** 4.5.  Completeness of Hoare logic *)

(** The converse of theorem [Hoare_sound] is true: a "Hoare triple"
    that holds semantically ([{{P}} c {{Q}}]) can always be derived
    using the rules of the logic ([Hoare P c Q]).  The proof relies
    on the notion of "weakest precondition" (WP). *)

(** The weakest precondition for a command [c] with postcondition [Q]. *)

Definition wp (c: com) (Q: assertion) : assertion :=
  fun s => forall s', cexec s c s' -> Q s'.

(** The WP is a precondition. *)

Lemma wp_precondition: forall c Q, {{wp c Q}} c {{Q}}.
Proof.
  unfold triple, wp; intros. auto.
Qed.

(** The WP is the weakest of all preconditions:
    any other precondition implies the WP. *)

Lemma wp_weakest: forall P c Q, {{P}} c {{Q}} -> P -->> wp c Q.
Proof.
  unfold triple, wp, aimp; intros. eauto.
Qed.

(** The rules of Hoare logic are powerful enough to derive the fact
    that [wp c Q] is a valid precondition for [c] and [Q]. *)

Lemma Hoare_wp: forall c Q, Hoare (wp c Q) c Q.
Proof.
  induction c; intros Q.
- (* SKIP *)
  eapply Hoare_consequence_pre. apply Hoare_skip.
  unfold aimp, wp; intros. apply H. apply cexec_skip.
- (* ASSIGN *)
  eapply Hoare_consequence_pre. apply Hoare_assign.
  unfold aimp, aupdate, wp; intros. apply H. apply cexec_assign.
- (* SEQ *)
  eapply Hoare_consequence_pre.
  eapply Hoare_seq with (wp c2 Q); eauto.
  unfold aimp, wp; intros. apply H. apply cexec_seq with s'; auto.
- (* IFTHENELSE *)
  apply Hoare_ifthenelse.
  + eapply Hoare_consequence_pre. apply IHc1.
    unfold atrue, aand, aimp, wp; intros. destruct H.
    apply H1. apply cexec_ifthenelse. rewrite H; auto.
  + eapply Hoare_consequence_pre. apply IHc2.
    unfold afalse, aand, aimp, wp; intros. destruct H.
    apply H1. apply cexec_ifthenelse. rewrite H; auto.
- (* WHILE *)
  eapply Hoare_consequence_post.
  + apply Hoare_while.
    eapply Hoare_consequence_pre. apply IHc.
    unfold atrue, aand, aimp, wp; intros. destruct H.
    apply H2. apply cexec_while_loop with s'; auto.
  + unfold afalse, aand, aimp, wp; intros. destruct H.
    apply H0. apply cexec_while_done; auto.
Qed.

(** It follows that any semantically valid triple [{{P}} c {{Q}}]
    can be derived by Hoare's rules. *)

Theorem Hoare_complete: forall P c Q, {{P}} c {{Q}} -> Hoare P c Q.
Proof.
  intros. apply Hoare_consequence_pre with (wp c Q).
- apply Hoare_wp.
- apply wp_weakest; auto.
Qed.

(** ** 4.6.  Other useful rules *)

(** Using the semantic definition of Hoare triples, it is easy to add
    new reasoning rules: these are just lemmas about the operational
    semantics that we prove once and for all.  For example: *)

Lemma triple_conj:
  forall c P1 Q1 P2 Q2,
  {{P1}} c {{Q1}} -> {{P2}} c {{Q2}} -> {{P1 //\\ P2}} c {{Q1 //\\ Q2}}.
Proof.
  intros; red; intros. destruct H2 as [PRE1 PRE2]. split; eauto.
Qed.

Lemma triple_disj:
  forall c P1 Q1 P2 Q2,
  {{P1}} c {{Q1}} -> {{P2}} c {{Q2}} -> {{P1 \\// P2}} c {{Q1 \\// Q2}}.
Proof.
  intros; red; intros. destruct H2 as [PRE1|PRE2]; [left|right]; eauto.
Qed.

(** We can also give an alternate rule to reason about assignments.
    The alternate rule is a "forward" rule (the postcondition is
    determined by the precondition), unlike Hoare's rule which is "backward". *)

Definition aexists {A: Type} (P: A -> assertion) : assertion :=
  fun (s: store) => exists (a: A), P a s.

Lemma triple_assign_fwd: forall x a P,
  {{ P }}
  ASSIGN x a
  {{ aexists (fun m => aexists (fun n =>
     aequal (VAR x) n //\\ aupdate x (CONST m) (P //\\ aequal a n))) }}.
Proof.
  intros. unfold triple, aequal, aupdate; intros.
  inversion H; subst.
  exists (s x); exists (aeval a s); cbn.
  split. apply update_same.
  replace (update x (s x) (update x (aeval a s) s)) with s.
  split; auto.
  apply functional_extensionality; intros y.
  unfold update. destruct (string_dec x y); congruence.
Qed.

(** Finally, we build a frame rule that makes it possible to reuse
    an existing verification of [{{P} c {{Q}}]
    and add extra facts [R] to the precondition and the postcondition,
    obtaining a verification of [{{P //\\ R}} c {{Q //\\ R}}]. *)

(** For example: if we showed the correctness of [swap_xy] like this
<<
    {{ aequal (VAR "x") m //\\ aequal (VAR "y") n }}
    swap_xy
    {{ aequal (VAR "x") n //\\ aequal (VAR "y") m }}
>>
    we should be able, without having to re-do the verification de [swap_xy],
    to prove a more informative triple such as
<<
    {{ aequal (VAR "x") m //\\ aequal (VAR "y") n //\\ aequal (VAR "z") p }}
    swap_xy
    {{ aequal (VAR "x") n //\\ aequal (VAR "y") m //\\ aequal (VAR "z") p }}
>>
    to be read as: "furthermore, the value of variable [z] is unchanged". *)

(** This reasoning is valid provided the extra facts [R] mention exclusively
    variables that are not modified during the execution of [c].
    We approximate this requirement by saying that variables that occur
    as left-hand sides of an assignment in [c] can be modified,
    and other variables definitely cannot. *)

Fixpoint modified_by (c: com) (x: ident) : Prop :=
  match c with
  | SKIP => False
  | ASSIGN y a => x = y
  | SEQ c1 c2 => modified_by c1 x \/ modified_by c2 x
  | IFTHENELSE b c1 c2 => modified_by c1 x \/ modified_by c2 x
  | WHILE b c1 => modified_by c1 x
  end.

Lemma cexec_modified:
  forall x s1 c s2,
  cexec s1 c s2 -> ~modified_by c x -> s2 x = s1 x.
Proof.
  induction 1; cbn; intros MB.
- auto.
- unfold update. destruct (string_dec x0 x); congruence.
- rewrite IHcexec2, IHcexec1 by tauto. auto.
- apply IHcexec. destruct (beval b s); tauto.
- auto.
- rewrite IHcexec2, IHcexec1 by tauto. auto.
Qed.

(** Syntactically, an assertion [P] is independent from a set [vars] of
    variables if none of the variables in [vars] is mentioned in [P].
    With out encoding of assertions as predicates [store -> Prop],
    we cannot state the independence condition like this, since
    the predicates are opaque functions.
    Instead, we will say that the assertion has the same truth value
    in any two stores [s1] and [s2] that differ only on the values of
    the variables in set [vars]. *)

Definition independent_of (P: assertion) (vars: ident -> Prop) : Prop :=
  forall s1 s2,
  (forall x, ~ vars x -> s1 x = s2 x) ->
  (P s1 <-> P s2).

(** In the end, we obtain the following frame rule. *)

Lemma triple_frame:
  forall c P Q R,
  {{P}} c {{Q}} ->
  independent_of R (modified_by c) ->
  {{P //\\ R}} c {{Q //\\ R}}.
Proof.
  intros; red; intros. destruct H2 as [PRE1 PRE2]. split.
- eapply H; eauto.
- apply (H0 s' s).
  + intros. apply cexec_modified with c; auto.
  + auto.
Qed.

(** ** 4.7.  Strong Hoare triples *)

(** The Hoare logic presented above is "weak" because it does not
    guarantee program termination, and therefore can show partial
    correctness results only. *)

(** Following similar approaches, we now construct a "strong" Hoare logic
    that guarantees termination and therefore proves total correctness
    results. *)

(** As we did for the weak logic, we could give the rules of the strong
    logic as an inductive predicate, then interpret them semantically.
    To simplify the presentation, we omit the inductive predicate
    and define the "strong" logic directly from the operational semantics,
    via the relation [ [[P]] c [[Q]] ] below. *)

Definition Triple (P: assertion) (c: com) (Q: assertion) :=
  forall s, P s -> exists s', cexec s c s' /\ Q s'.

Notation "[[ P ]] c [[ Q ]]" := (Triple P c Q) (at level 90, c at next level).

(** Note the difference with the weak logic:
-   For the weak triple [ {{P}} c {{Q}} ], we conclude
    "if [c] terminates, then the final store [s'] satisfies [Q]".
-   For the strong triple [ [[P]] c [[Q]] ], we conclude
    "[c] terminates and the final store [s'] satisfies [Q]".
*)

(** The base rules for the strong logic are the same as for the weak logic,
    except for loops. *)

Lemma Triple_skip: forall P,
      [[P]] SKIP [[P]].
Proof.
  intros P s PRE. exists s; split; auto. apply cexec_skip.
Qed.

Lemma Triple_assign: forall P x a,
      [[aupdate x a P]] ASSIGN x a [[P]].
Proof.
  intros P x a s PRE. exists (update x (aeval a s) s); split.
- apply cexec_assign.
- exact PRE.
Qed.

Lemma Triple_seq: forall P Q R c1 c2,
      [[P]] c1 [[Q]] -> [[Q]] c2 [[R]] ->
      [[P]] c1;;c2 [[R]].
Proof.
  intros; intros s PRE.
  destruct (H s PRE) as (s1 & EXEC1 & MID).
  destruct (H0 s1 MID) as (s2 & EXEC2 & POST).
  exists s2; split.
- apply cexec_seq with s1; auto.
- exact POST.
Qed.

Lemma Triple_ifthenelse: forall P Q b c1 c2,
      [[atrue b //\\ P]] c1 [[Q]] ->
      [[afalse b //\\ P]] c2 [[Q]] ->
      [[P]] IFTHENELSE b c1 c2 [[Q]].
Proof.
  intros; intros s PRE. destruct (beval b s) eqn:B.
- destruct (H s) as (s' & EXEC & POST). split; auto.
  exists s'; split; auto. constructor; rewrite B; auto.
- destruct (H0 s) as (s' & EXEC & POST). split; auto.
  exists s'; split; auto. constructor; rewrite B; auto.
Qed.

Lemma Triple_consequence: forall P Q P' Q' c,
      [[P]] c [[Q]] -> P' -->> P -> Q -->> Q' ->
      [[P']] c [[Q']].
Proof.
  intros; intros s PRE.
  destruct (H s) as (s' & EXEC & POST). apply H0; auto.
  exists s'; auto.
Qed.

(** For [WHILE b c] loops, the strong triple must guarantee that the loop
    terminates for all initial stores satisfying the precondition.
    A simple way to guarantee termination is to exhibit a "variant":
    an integer-valued expression that decreases at every loop iteration
    while remaining nonnegative. *)

Definition alessthan (a: aexp) (v: Z) : assertion :=
  fun (s: store) => 0 <= aeval a s < v.

Lemma Triple_while: forall P variant b c,
  (forall v,
     [[ P //\\ atrue b //\\ aequal variant v ]]
     c
     [[ P //\\ alessthan variant v ]])
  ->
     [[P]] WHILE b c [[P //\\ afalse b]].
Proof.
  intros P variant b c T.
  assert (REC: forall v s, P s -> aeval variant s = v ->
               exists s', cexec s (WHILE b c) s' /\ (P s' /\ beval b s' = false)).
  { induction v using (well_founded_induction (Z.lt_wf 0)).
    intros. destruct (beval b s) eqn:B.
  - destruct (T v s) as (s1 & EXEC1 & (PS1 & LT1)). unfold aand, aequal, atrue; auto.
    destruct (H _ LT1 s1 PS1) as (s2 & EXEC2 & PS2). auto.
    exists s2; split; auto. apply cexec_while_loop with s1; auto.
  - exists s; split; auto. apply cexec_while_done; auto.
  }
  intros s PRE. apply REC with (v := aeval variant s); auto.
Qed.

(** *** Exercise (3 stars) *)

(** The "variant" trick and the order on nonnegative integers are sometimes
    insufficient to show termination of a [WHILE] loop.
    Here is a more powerful rule that uses two variant expressions
    and a lexicographic ordering between pairs of nonnegative integers.
    Show that this rule is sound. *)

Lemma Triple_while_lexico: forall P variant1 variant2 b c,
  (forall v1 v2,
    [[ P //\\ atrue b //\\ aequal variant1 v1 //\\ aequal variant2 v2 ]]
    c
    [[ P //\\ (alessthan variant1 v1 \\// (aequal variant1 v1 //\\ alessthan variant2 v2)) ]])
  ->
    [[P]] WHILE b c [[P //\\ afalse b]].
Proof.
  intros P variant1 variant2 b c T.
  assert (REC: forall v1 v2 s, P s -> aeval variant1 s = v1 -> aeval variant2 s = v2 ->
               exists s', cexec s (WHILE b c) s' /\ (P s' /\ beval b s' = false)).
  (* FILL IN HERE *)
Admitted.

(** ** 4.8.  Verification condition generation *)

(** With the exception of the rule for [WHILE] loops, the rules of
    Hoare logic can be read as an algorithm that, given a command [c]
    and a postcondition [Q], computes the weakest precondition [P].
    For example, if [c] comprises two assignments in sequence
<<
    c = ASSIGN x1 a1 ;; ASSIGN x2 a2
>>
    the precondition [P] is determined as
<<
    P = aupdate x1 a1 (aupdate x2 a2 Q)
>>
    Such a computation is much simpler than general proof search,
    which can apply the weakening rule [triple_consequence] at any point. *)

(** Of course, the problem is with [WHILE] loops: the loop invariant
    cannot be determined automatically by a computation. *)

(** In the following, we develop a hybrid approach where loops are
    manually annotated with their loop invariants, but all other preconditions
    are automatically computed from the postconditions. *)

Module VCGEN.

(** This is the language of commands where [WHILE] loops are annotated by
    an invariant [Inv]. *)

Inductive com: Type :=
  | SKIP
  | ASSIGN (x: ident) (a: aexp)
  | SEQ (c1: com) (c2: com)
  | IFTHENELSE (b: bexp) (c1: com) (c2: com)
  | WHILE (Inv: assertion) (b: bexp) (c1: com).  (**r new! *)

(** The function [pre c Q] computes a precondition for command [c]
    and postcondition [Q], by "backward execution" of command [c] and
    application of the rules of Hoare logic.  The only exception is
    [WHILE] loops, where we take as precondition the loop invariant
    provided. *)

Fixpoint pre (c: com) (Q: assertion) : assertion :=
  match c with
  | SKIP => Q
  | ASSIGN x a => aupdate x a Q
  | SEQ c1 c2 => pre c1 (pre c2 Q)
  | IFTHENELSE b c1 c2 => atrue b //\\ pre c1 Q \\// afalse b //\\ pre c2 Q
  | WHILE Inv b c => Inv
  end.

(** The Hoare triple [ {{ pre c Q }} c {{ Q }} ] is not always valid:
    we must also ensure that the invariants provided for the loops are
    actually invariant.  For a loop [WHILE Inv b c] having postcondition [Q],
    it must be the case that
-   [afalse b //\\ Inv -->> Q] :
    when the loop stops, the invariant implies the postcondition;
-   [atrue b //\\ Inv -->> pre c Inv] :
    when the loop iterates, the invariant implies the precondition of
    the loop body.

    The following function [vcg] (Verification Condition Generator)
    collects all these "verification conditions" for all the loops [WHILE]
    contained in command [c]. *)

Fixpoint vcg (c: com) (Q: assertion) : Prop :=
  match c with
  | SKIP => True
  | ASSIGN x a => True
  | SEQ c1 c2 => vcg c1 (pre c2 Q) /\ vcg c2 Q
  | IFTHENELSE b c1 c2 => vcg c1 Q /\ vcg c2 Q
  | WHILE Inv b c =>
       vcg c Inv
    /\ (afalse b //\\ Inv -->> Q)
    /\ (atrue b //\\ Inv -->> pre c Inv)
  end.

(** The triple [ {{P}} c {{Q}} ] is valid as soon as
-   [P] implies the precondition [pre c Q]
-   the conditions [vcg c Q] are true.
*)

Definition vcgen (P: assertion) (c: com) (Q: assertion) : Prop :=
  (P -->> pre c Q) /\ vcg c Q.

(** To prove this verification algorithm correct, we define
    the plain IMP command [erase c] obtained from the annotated command [c]
    by erasing the loop invariants from the [WHILE] nodes. *)

Fixpoint erase (c: com) : IMP.com :=
  match c with
  | SKIP => IMP.SKIP
  | ASSIGN x a => IMP.ASSIGN x a
  | SEQ c1 c2 => IMP.SEQ (erase c1) (erase c2)
  | IFTHENELSE b c1 c2 => IMP.IFTHENELSE b (erase c1) (erase c2)
  | WHILE Inv b c => IMP.WHILE b (erase c)
  end.

(** We can then show that [pre c Q] is a valid precondition for [c] and [Q],
    provided that the conditions [vcg c Q] are true. *)

Lemma vcg_sound:
  forall c Q, vcg c Q -> {{pre c Q}} erase c {{Q}}.
Proof.
  induction c; cbn; intros.
- apply triple_skip.
- apply triple_assign.
- destruct H as (V1 & V2).
  apply triple_seq with (pre c2 Q); auto.
- destruct H as (V1 & V2).
  apply triple_ifthenelse.
  + eapply triple_consequence. eapply IHc1; eauto.
    unfold aimp, aand, aor, atrue, afalse. intuition congruence.
    unfold aimp; auto.
  + eapply triple_consequence. eapply IHc2; eauto.
    unfold aimp, aand, aor, atrue, afalse. intuition congruence.
    unfold aimp; auto.
- destruct H as (V1 & V2 & V3).
  eapply triple_consequence.
  + apply triple_while. eapply triple_consequence. apply IHc; eauto.
    eauto. red; auto.
  + red; auto.
  + auto.
Qed.

(** The correctness of algorithm [vcgen] follows. *)

Theorem vcgen_correct:
  forall P c Q, vcgen P c Q -> {{P}} erase c {{Q}}.
Proof.
  unfold vcgen; intros. destruct H as (V1 & V2).
  eapply triple_consequence. eapply vcg_sound; eauto. auto. red; auto.
Qed.

(** *** Application: Euclidean division *)

Infix ";;" := SEQ (at level 80, right associativity).

(** Here are the precondition, the loop invariant, and the postcondition
    for the program that does Euclidean division by iterated subtraction. *)

Definition Pre (s: store) :=
  s "a" >= 0 /\ s "b" > 0.

Definition Inv (s: store) :=
  s "r" >= 0 /\ s "b" > 0 /\ s "a" = s "b" * s "q" + s "r".

Definition Post (s: store) :=
  s "q" = s "a" / s "b" /\ s "r" = s "a" mod s "b".

(** Here is the IMP program with the loop annotated by [Inv]. *)

Definition Euclidean_division :=
  ASSIGN "r" (VAR "a") ;;
  ASSIGN "q" (CONST 0) ;;
  WHILE Inv (LESSEQUAL (VAR "b") (VAR "r"))
    (ASSIGN "r" (MINUS (VAR "r") (VAR "b")) ;;
     ASSIGN "q" (PLUS (VAR "q") (CONST 1))).

(** And here is its correctness proof.  It does not use explicitly any
    rules of Hoare logic.  Instead, we apply the [vcgen_correct]
    theorem, then ask Coq to compute and simplify the verification
    condition.  In the end, all what remains is a formula in standard
    logic (not Hoare logic) that is easily proved using standard Coq
    tactics. *)

Theorem Euclidean_division_correct:
  {{Pre}} erase Euclidean_division {{Post}}.
Proof.
  apply vcgen_correct. red; cbn.
  unfold aimp, aupdate, aand, afalse, atrue, Pre, Post, Inv; cbn.
  intuition auto.
  (* The precondition implies the loop invariant. *)
  - lia.
  (* The invariant and the loop exit imply the postcondition. *)
  - apply Z.leb_gt in H0. apply Zdiv_unique with (s "r"). lia. auto.
  - apply Z.leb_gt in H0. apply Zmod_unique with (s "q"). lia. auto.
  (* The loop invariant is preserved at each iteration. *)
  - apply Z.leb_le in H0. lia.
  - lia.
Qed.

(** *** Exercise (1 star) *)
(** Redo the verification after removing the hypothesis [s "b" > 0] from
    the precondition and the invariant.  How is it possible that
    the verification "goes through" even when the divisor [b] is zero? *)

(** *** Exercise (3 stars) *)
(** Specify and verify the following program.  It leaves in [r] the
    integer square root of [a].
<<
    r := 0; s := 1;
    while s <= a do (r := r + 1; s := s + r + r + 1)
>>
*)

End VCGEN.


Set Warnings "-notation-overridden,-parsing".
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype ssralg finalg.
Require Import ZArith.
From Tweetnacl.High Require Import Zmodp Zmodp_Ring GRing_tools.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope Z.
Import Zmodp.
Open Scope ring_scope.
Import GRing.Theory.

Module Zmodp2.

Inductive type := Zmodp2 (x: Zmodp.type) (y:Zmodp.type).

Definition pi (x : Zmodp.type * Zmodp.type) : type := Zmodp2 x.1 x.2.
Coercion repr (x : type) : Zmodp.type*Zmodp.type := let: Zmodp2 u v := x in (u, v).

Definition zero : type := pi (0%:R, 0%:R).
Definition one : type := pi (1, 0%:R).
Definition opp (x : type) : type := pi (- x.1 , - x.2).
Definition add (x y : type) : type := pi (x.1 + y.1, x.2 + y.2).
Definition sub (x y : type) : type := pi (x.1 - y.1, x.2 - y.2).
Definition mul (x y : type) : type := pi ((x.1 * y.1) + (2%:R * (x.2 * y.2)), (x.1 * y.2) + (x.2 * y.1)).

Lemma pi_of_reprK : cancel repr pi.
Proof. by case. Qed.

Definition eqb (x y : type) := match x, y with
  | Zmodp2 x1 x2, Zmodp2 y1 y2 => Zmodp.eqb x1 y1 && Zmodp.eqb x2 y2
end.

Lemma eqb_spec (x y: type) : reflect (x = y) (eqb x y).
Proof.
apply Bool.iff_reflect.
split.
+ move => ->.
  rewrite /eqb.
  case y => y1 y2.
  by apply/andP ; split ; apply /Refl.eqb_spec.
+ rewrite /eqb.
  case x => x1 x2.
  case y => y1 y2.
  by move/andP => [] /Refl.eqb_spec -> /Refl.eqb_spec ->.
Qed.

Lemma Zmodp2_inv : forall a b c d, Zmodp2 a c = Zmodp2 b d -> a = b /\ c = d.
Proof. by move => a b c d H; inversion H. Qed.

Ltac Zmodp2_unfold := rewrite /mul /sub /add /opp /zero /one.

End Zmodp2.

Import Zmodp2.

Definition Zmodp2_eqMixin := CanEqMixin pi_of_reprK.
Canonical Structure Zmodp2_eqType := Eval hnf in EqType type Zmodp2_eqMixin.
Definition Zmodp2_choiceMixin := CanChoiceMixin pi_of_reprK.
Canonical Structure Zmodp2_choiceType := Eval hnf in ChoiceType type Zmodp2_choiceMixin.
Definition Zmodp2_countMixin := CanCountMixin pi_of_reprK.
Canonical Structure Zmodp2_countType := Eval hnf in CountType type Zmodp2_countMixin.
Definition Zmodp2_finMixin := CanFinMixin pi_of_reprK.
Canonical Structure Zmodp2_finType := Eval hnf in FinType type Zmodp2_finMixin.

Lemma modZp_1 (x : type) : (Zmodp.repr x.1) mod p = (Zmodp.repr x.1).
Proof. by elim x.1 => xi i; apply: Zmod_small ; apply/betweenbP; move: i; case xi. Qed.

Lemma modZp_2 (x : type) : (Zmodp.repr x.2) mod p = (Zmodp.repr x.2).
Proof. by elim x.2 => xi i; apply: Zmod_small ; apply/betweenbP; move: i; case xi. Qed.

Lemma reprK (x : type) : pi x = x.
Proof. by case x. Qed.
Lemma piK (x : Zmodp.type*Zmodp.type) : repr (pi x) = x.
Proof. by case x. Qed.

Lemma Zmodp2_const x1 x2 y1 y2: x1 = y1 -> x2 = y2 -> Zmodp2 x1 x2 = Zmodp2 y1 y2.
Proof. move=> -> -> //. Qed.

Local Ltac solve_this :=
  repeat match goal with
    | _ => progress Zmodp2_unfold; ring_unfold
    | [ |- context[Zmodp2 ?A ?B]] => have ->: Zmodp2 A B = Zmodp2.pi (A,B) => //
    | _ => solve[f_equal ; f_equal ; ring]
    | _ => solve[f_equal ; f_equal ; Zmodp_ringify ; ring_simplify_this]
  end.

Module Zmodp2_zmod.

Lemma add_comm : commutative add.
Proof.
move=> [x1 x2] [y1 y2].
solve_this.
Qed.

Lemma add_left_id : left_id zero add.
Proof. move => [x1 x2].
solve_this.
Qed.

Lemma add_left_inv : left_inverse zero opp add.
Proof. move => [x1 x2].
solve_this.
rewrite Zmodp_zmod.add_left_inv.
rewrite Zmodp_zmod.add_left_inv.
reflexivity.
Qed.

Lemma add_assoc : associative add.
Proof. move=> [x1 x2] [y1 y2] [z1 z2].
solve_this.
Qed.

Lemma add_sub : forall (x y:type), sub x y = add x (opp y).
Proof.
move=> x y.
solve_this.
Qed.

Module Exports.
Definition Zmodp_zmodMixin :=
  ZmodMixin add_assoc add_comm add_left_id add_left_inv.
Canonical Structure Zmodp_zmodType :=
  Eval hnf in ZmodType type Zmodp_zmodMixin.
End Exports.

End Zmodp2_zmod.
Import Zmodp2_zmod.Exports.

Lemma Zmodp2_addE x y : (pi x + pi y)%R = pi (x.1 + y.1, x.2 + y.2).
Proof. reflexivity. Qed.

Lemma Zmodp2_oppE x : (-pi x)%R = pi (-x).
Proof. reflexivity. Qed.

Fact Hp_gt1 : p > 1.
Proof. by unlock p; rewrite Z.gt_lt_iff; apply/Z.ltb_spec0. Qed.

Module Zmodp2_ring.

Lemma mul_comm : commutative mul.
Proof. move=> [x1 x2] [y1 y2].
solve_this.
Qed.

Lemma mul_assoc : associative mul.
Proof.
move=> [x1 x2] [y1 y2] [z1 z2].
solve_this.

Qed.

Lemma mul_left_id : left_id one mul.
Proof.
move=> [x1 x2].
solve_this.
Qed.

Lemma mul_left_distr : left_distributive mul add.
Proof.
move=> [x1 x2] [y1 y2] [z1 z2].
solve_this.
Qed.

Lemma one_neq_zero : one != zero.
Proof.
rewrite /one /zero; f_equal.
apply/eqP => H ; inversion H; move: H1.
by rewrite Zmod_0_l Zmod_1_l; last exact: Z.gt_lt Hp_gt1.
Qed.

Lemma two_neq_zero : (one + one) != zero.
Proof.
rewrite /one /zero; f_equal.
zmodp_compute.
apply/eqP => H ; inversion H; clear H; move: H1.
rewrite /p -lock.
by compute.
Qed.

Lemma three_neq_zero : (one + one + one) != zero.
Proof.
rewrite /one /zero; f_equal.
zmodp_compute.
apply/eqP => H ; inversion H; clear H; move: H1.
rewrite /p -lock.
by compute.
Qed.

Module Exports.
Definition Zmodp2_ringMixin := Eval hnf in ComRingMixin mul_assoc mul_comm mul_left_id mul_left_distr one_neq_zero.
Canonical Structure Zmodp2_ringType := Eval hnf in RingType type Zmodp2_ringMixin.
Canonical Structure Zmodp2_comRingType := Eval hnf in ComRingType type mul_comm.
End Exports.

End Zmodp2_ring.
Import Zmodp2_ring.Exports.

Lemma Zmodp2_mulE x y : (pi x * pi y)%R = pi (x.1 * y.1 + (Zmodp.pi 2) * (x.2 * y.2), x.1 * y.2 + x.2 * y.1).
Proof.
apply/eqP; rewrite pi_2 eqE; apply/eqP=> //=.
Qed.

Inductive Zinv_spec (x : type) : Type :=
| Zinv_spec_zero : x = zero -> Zinv_spec x
| Zinv_spec_unit : x <> zero -> forall y, (y * x)%R = one -> Zinv_spec x.

Lemma Zinv x : Zinv_spec x.
Proof.
case_eq (eqb x zero) ; move/eqb_spec.
+ move => -> ; exact: Zinv_spec_zero.
+ destruct x as [x y] => Hxy.
apply (@Zinv_spec_unit (Zmodp2 x y) Hxy (Zmodp2 (x/(x^+2-2%:R*y^+2)) (-y/(x^+2-2%:R*y^+2)))).
rewrite /GRing.mul /= /mul /=.
Zmodp_ringify.
have ->: x / (x ^+ 2 - 2%:R * y ^+ 2) * x + 2%:R * (- y / (x ^+ 2 - 2%:R * y ^+ 2) * y) = (x ^+2 - 2%:R * y^+2) / (x ^+ 2 - 2%:R * y ^+ 2).
remember (x ^+ 2 - 2%:R * y ^+ 2) as M.
by rewrite (mulrC x) (mulrC (-y)) ?mulrA (mulrC (2%:R)) -?mulrA -mulrDr mulrC mulNr mulrN HeqM ?expr2.
have ->: x / (x ^+ 2 - 2%:R * y ^+ 2) * y + - y / (x ^+ 2 - 2%:R * y ^+ 2) * x = 0.
remember (x ^+ 2 - 2%:R * y ^+ 2) as M.
by rewrite (mulrC x) (mulrC (-y)) -?mulrA (mulrC x) mulNr mulrN addrN.
rewrite mulfV //.
apply x2_eq_2_y2.
apply/orP.
move/eqP: Hxy.
apply/contraR.
case_eq (x != 0) ; move/eqP;
case_eq (y != 0) ; move/eqP => //= => -> -> _.
apply/eqP => //=.
Qed.

Definition Zmodp2_inv (x : type) : type :=
  match Zinv x with
  | Zinv_spec_zero _ => zero
  | @Zinv_spec_unit _ _ y _ => pi y
  end.

Module Zmodp2_field.

Lemma mulVx : GRing.Field.axiom Zmodp2_inv.
Proof.
move=> x Hx_neq0.
rewrite /Zmodp2_inv.
case: (Zinv x).
+ by move/eqP: Hx_neq0.
+ move=> Hxx_neq0 y.
done.
Qed.

Lemma inv0 : Zmodp2_inv 0%R = 0%R.
Proof.
rewrite /Zmodp2_inv; case: (Zinv 0); done.
Qed.

Module Exports.
Definition Zmodp2_unitRingMixin := Eval hnf in FieldUnitMixin mulVx inv0.
Canonical Structure Zmodp2_unitRingType :=
  Eval hnf in UnitRingType type Zmodp2_unitRingMixin.
Canonical Structure Zmodp2_comUnitRingType :=
  Eval hnf in [comUnitRingType of type].

Lemma Zmodp2_fieldMixin : GRing.Field.mixin_of Zmodp2_unitRingType.
Proof. by move=> x Hx_neq0; rewrite qualifE /=. Qed.

Definition Zmodp2_idomainMixin := FieldIdomainMixin Zmodp2_fieldMixin.
Canonical Structure Zmodp2_idomainType :=
  Eval hnf in IdomainType type Zmodp2_idomainMixin.
Canonical Structure Zmodp2_fieldType :=
  Eval hnf in FieldType type Zmodp2_fieldMixin.
End Exports.

End Zmodp2_field.
Import Zmodp2_field.Exports.

(* Useful tactic to compute boolean equalities. *)
Ltac zmodp2_compute := rewrite ?(Zmodp2_addE, Zmodp2_mulE) eqE /=; unlock p=> /=.

(* Now create the finalg variants too. *)
Canonical Structure Zmodp2_finZmodType := Eval hnf in [finZmodType of type].
Canonical Structure Zmodp2_finRingType := Eval hnf in [finRingType of type].
Canonical Structure Zmodp2_finComRingType := Eval hnf in [finComRingType of type].
Canonical Structure Zmodp2_finUnitRingType := Eval hnf in [finUnitRingType of type].
Canonical Structure Zmodp2_finComUnitRingType := Eval hnf in [finComUnitRingType of type].
Canonical Structure Zmodp2_finIdomainType := Eval hnf in [finIdomainType of type].
Canonical Structure Zmodp2_finFieldType := Eval hnf in [finFieldType of type].

Export Zmodp2_zmod.Exports Zmodp2_ring.Exports.
Export Zmodp2_field.Exports.

Import GRing.Theory.

Lemma Zmodp2_ring : ring_theory zero one add mul sub opp eq.
Proof.
apply mk_rt.
apply Zmodp2_zmod.add_left_id.
apply Zmodp2_zmod.add_comm.
apply Zmodp2_zmod.add_assoc.
apply Zmodp2_ring.mul_left_id.
apply Zmodp2_ring.mul_comm.
apply Zmodp2_ring.mul_assoc.
apply Zmodp2_ring.mul_left_distr.
apply Zmodp2_zmod.add_sub.
move => x. rewrite Zmodp2_zmod.add_comm Zmodp2_zmod.add_left_inv //.
Defined.

Lemma Zmodp2_ring2 : @ring_theory (GRing.Ring.sort Zmodp2_ringType) Zmodp2.zero Zmodp2.one Zmodp2.add Zmodp2.mul Zmodp2.sub Zmodp2.opp eq.
Proof.
apply mk_rt.
apply Zmodp2_zmod.add_left_id.
apply Zmodp2_zmod.add_comm.
apply Zmodp2_zmod.add_assoc.
apply Zmodp2_ring.mul_left_id.
apply Zmodp2_ring.mul_comm.
apply Zmodp2_ring.mul_assoc.
apply Zmodp2_ring.mul_left_distr.
apply Zmodp2_zmod.add_sub.
move => x. rewrite Zmodp2_zmod.add_comm Zmodp2_zmod.add_left_inv //.
Defined.

Add Ring Zmodp2_ring : Zmodp2_ring.
Add Ring Zmodp2_ring2 : Zmodp2_ring2.

Open Scope ring_scope.

Ltac Zmodp2_ringify := repeat match goal with
  | [ |- context[Zmodp2.mul ?a ?b]] => have ->: (Zmodp2.mul a b) = a * b => //
  | [ |- context[Zmodp2.add ?a (Zmodp2.opp ?b)]] => have ->: (Zmodp2.add a (Zmodp2.opp b)) = a - b => //
  | [ |- context[Zmodp2.opp ?a]] => have ->: Zmodp2.opp a = -a => //
  | [ |- context[Zmodp2.add ?a ?b]] => have ->: (Zmodp2.add a b) = a + b => //
  | [ |- context[Zmodp2.one] ] => have ->: Zmodp2.one = 1 => //
  | [ |- context[Zmodp2.zero] ] => have ->: Zmodp2.zero = 0 => //
  end.

Close Scope ring_scope.