(** This file contains some lemmas you will have to prove, i.e. replacing
   the "Admitted" joker with a sequence of tactic calls, terminated with a
   "Qed" command.

   Each lemma should be proved several times :
   first using only elementary tactics :
   intro[s], apply, assumption
   split, left, right, destruct.
   exists, rewrite
   assert (only if you don't find another solution)

   Then, use tactic composition, auto, tauto, firstorder.

Notice that, if you want to keep all solutions, you may use various
identifiers like in the given example : imp_dist, imp_dist' share
the same statement, with different interactive proofs.

*)

Section Minimal_propositional_logic.
 Variables P Q R S : Prop.

 Lemma id_P : P -> P.
 Proof.
 Admitted.

 Lemma id_PP : (P -> P) -> P -> P.
 Proof.
 Admitted.

 Lemma imp_dist : (P -> Q -> R) -> (P -> Q) -> P -> R.
 Proof.
 Admitted.

 Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
 Proof.
 Admitted.

 Lemma imp_perm : (P -> Q -> R) -> Q -> P -> R.
 Proof.
 Admitted.

 Lemma ignore_Q : (P -> R) -> P -> Q -> R.
 Proof.
 Admitted.

 Lemma delta_imp : (P -> P -> Q) -> P -> Q.
 Proof.
 Admitted.

 Lemma delta_impR : (P -> Q) -> P -> P -> Q.
 Proof.
 Admitted.

 Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
 Proof.
 Admitted.

 Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
 Proof.
 Admitted.

End Minimal_propositional_logic.

(** Same exercise as the previous one, with full intuitionistic propositional
   logic

   You may use the tactics intro[s], apply, assumption, destruct,
                           left, right, split and try to use tactic composition *)

Section propositional_logic.

 Variables P Q R S T : Prop.

 Lemma and_assoc : P /\ (Q /\ R) -> (P /\ Q) /\ R.
 Proof.
 Admitted.

 Lemma and_imp_dist : (P -> Q) /\ (R -> S) -> P /\ R -> Q /\ S.
 Proof.
 Admitted.

 Lemma not_contrad :  ~(P /\ ~P).
 Proof.
 Admitted.

 Lemma or_and_not : (P \/ Q) /\ ~P -> Q.
 Proof.
 Admitted.

 Lemma not_not_exm : ~ ~ (P \/ ~ P).
 Proof.
 Admitted.

 Lemma de_morgan_1 : ~(P \/ Q) -> ~P /\ ~Q.
 Proof.
 Admitted.

 Lemma de_morgan_2 : ~P /\ ~Q -> ~(P \/ Q).
 Proof.
 Admitted.

 Lemma de_morgan_3 : ~P \/ ~Q -> ~(P /\ Q).
 Proof.
 Admitted.

 Lemma or_to_imp : P \/ Q -> ~ P -> Q.
 Admitted.

 Lemma imp_to_not_not_or : (P -> Q) -> ~~(~P \/ Q).
 Admitted.

 Lemma contraposition : (P -> Q) -> (~Q -> ~P).
 Admitted.

 Lemma contraposition' : (~P -> ~Q) <-> (~~Q -> ~~P).
 Admitted.

 Lemma contraposition'' : (~P -> ~Q) <-> ~~(Q -> P).
 Admitted.

 Section S0.
  Hypothesis H0 : P -> R.
  Hypothesis H1 : ~P -> R.

  Lemma weak_exm : ~~R.
  Admitted.

End S0.

Check weak_exm.

 (* Now, you may invent and solve your own exercises !
    Note that you can trust the tactic tauto: if it fails, then your formula
    is probably not (intuitionnistically) provable *)
(*
Lemma contraposition''' : (~P -> ~Q) <-> (Q -> P).
Proof.
 tauto.
Toplevel input, characters 8-13:
Error: tauto failed.
*)
End propositional_logic.

(* Now observe that the section mechanism discharges also the local
variables P, Q, R, etc. *)

Check and_imp_dist.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From PLF Require Export Imp.
From PLF Require Import Hoare.

(*    {{ True }}
      if X ≤ Y then
          {{ True /\ X ≤ Y           }} ->>
          {{ Y = X + Y - X           }}
        Z := Y - X
          {{ Y = X + Z               }}
      else
          {{ True /\ ~(X ≤ Y)        }} ->>
          {{ X + Z = X + Z           }}
        Y := X + Z
          {{ Y = X + Z               }}
      end
        {{ Y = X + Z }}
*)

(*
        (1)      {{ True }}
               while ~(X = 0) do
        (2)        {{ True ∧ X ≠ 0 }} ->>
        (3)        {{ True }}
                 X := X - 1
        (4)        {{ True }}
               end
        (5)      {{ True ∧ ~(X ≠ 0) }} ->>
        (6)      {{ X = 0 }}
*)
Definition reduce_to_zero' : com :=
  <{ while ~(X = 0) do X := X - 1 end }>.
Theorem reduce_to_zero_correct' :
  {{True}} reduce_to_zero' {{X = 0}}.
Proof.
  unfold reduce_to_zero'.
  (* First we need to transform the postcondition so
     that hoare_while will apply. *)
  eapply hoare_consequence_post.
  - apply hoare_while.
    + (* Loop body preserves invariant *)
      (* Need to massage precondition before hoare_asgn applies *)
      eapply hoare_consequence_pre.
      * apply hoare_asgn.
      * (* Proving trivial implication (2) ->> (3) *)
        unfold assn_sub, "->>". simpl. intros. exact I.
  - (* Invariant and negated guard imply postcondition *)
    intros st [Inv GuardFalse].
    unfold bassn in GuardFalse. simpl in GuardFalse.
    rewrite not_true_iff_false in GuardFalse.
    rewrite negb_false_iff in GuardFalse.
    apply eqb_eq in GuardFalse.
    apply GuardFalse.
Qed.

Ltac verify_assn :=
  repeat split;
  simpl; unfold assert_implies;
  unfold ap in *; unfold ap2 in *;
  unfold bassn in *; unfold beval in *; unfold aeval in *;
  unfold assn_sub; intros;
  repeat (simpl in *;
          rewrite t_update_eq ||
          (try rewrite t_update_neq; [| (intro X; inversion X; fail)] ) );
  simpl in *;
  repeat match goal with [H : _ /\ _ |- _] => destruct H end;
  repeat rewrite not_true_iff_false in *;
  repeat rewrite not_false_iff_true in *;
  repeat rewrite negb_true_iff in *;
  repeat rewrite negb_false_iff in *;
  repeat rewrite eqb_eq in *;
  repeat rewrite eqb_neq in *;
  repeat rewrite leb_iff in *;
  repeat rewrite leb_iff_conv in *;
  try subst;
  simpl in *;
  repeat
    match goal with
      [st : state |- _] =>
        match goal with
        | [H : st _ = _ |- _] => rewrite -> H in *; clear H
        | [H : _ = st _ |- _] => rewrite <- H in *; clear H
        end
    end;
  try eauto; try lia.

Theorem reduce_to_zero_correct''' :
  {{True}} reduce_to_zero' {{X = 0}}.
Proof.
  unfold reduce_to_zero'.
  eapply hoare_consequence_post.
  - apply hoare_while.
    + eapply hoare_consequence_pre.
      * apply hoare_asgn.
      * verify_assn.
  - verify_assn.
Qed.

(*
       X := m;
       Y := 0;
       while n ≤ X do
         X := X - n;
         Y := Y + 1
       end;

    Y = m / n
    X = m % n

    n × Y + X = m ∧ X < n.

      (1)    {{ True }} ->>
      (2)    {{ n × 0 + m = m }}
           X := m;
      (3)    {{ n × 0 + X = m }}
           Y := 0;
      (4)    {{ n × Y + X = m }}
           while n ≤ X do
      (5)      {{ n × Y + X = m ∧ n ≤ X }} ->>
      (6)      {{ n × (Y + 1) + (X - n) = m }}
             X := X - n;
      (7)      {{ n × (Y + 1) + X = m }}
             Y := Y + 1
      (8)      {{ n × Y + X = m }}
           end
      (9)    {{ n × Y + X = m ∧ ¬(n ≤ X) }} ->>
     (10)    {{ n × Y + X = m ∧ X < n }}
*)

(*
      {{ X = m }}
      {{ X = m /\ 0 = 0}}
      Y := 0;
      {{ X = m /\ Y = 0}}
      {{ X + Y = m /\ ~(X = 0) }}
      while ~(X = 0) do
        {{ X - 1 + Y + 1 = m /\ ~(X = 0) }}
        X := X - 1;
        {{ X + Y + 1 = m /\ ~(X = 0) }}
        Y := Y + 1
        {{ X + Y = m /\ ~(X = 0) }}
      end
      {{ X + Y = m /\ X = 0 }}
      {{ Y = m }}
*)
Definition  slow_assignment_prog : com :=
  <{
      Y := 0;
      while ~(X = 0) do
        X := X - 1;
        Y := Y + 1
      end
  }>.

Definition body_slow_assignment_prog: com :=
  <{
    X := X - 1;
    Y := Y + 1
  }>.
Lemma tst: forall (m: nat), {{ X + Y = m /\ ~(X = 0)}} body_slow_assignment_prog {{ X + Y = m }}.
Proof. intro m. unfold body_slow_assignment_prog.
  eapply hoare_seq.
  - (* Y *)
    apply hoare_asgn.
  - (* X *)
    eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + (* func *)
      verify_assn.
Qed.

Fixpoint parity x :=
  match x with
  | 0 => 0
  | 1 => 1
  | S (S x') => parity x'
  end.

Lemma parity_ge_2 : forall x, 2 <= x -> parity (x - 2) = parity x.
Proof.
  induction x; intros; simpl.
  - reflexivity.
  - destruct x.
    + lia.
    + inversion H; subst; simpl.
      * reflexivity.
      * rewrite sub_0_r. reflexivity.
Qed.

Lemma parity_lt_2 : forall x, ~(2 <= x) -> parity x = x.
Proof.
  induction x; intros; simpl.
  - reflexivity.
  - destruct x.
    + reflexivity.
    + lia.
Qed.

Theorem parity_correct : forall (m:nat),
  {{ X = m }}
  while 2 <= X do
    X := X - 2
  end
  {{ X = parity m }}.
Proof.
  intro m.
  apply hoare_consequence_pre with (P' := assert (ap parity X = parity m)).
  --  eapply hoare_consequence_post.
      - eapply hoare_while.
        + (* While body *)
          eapply hoare_consequence_pre.
          * apply hoare_asgn.
          * verify_assn.
            rewrite <- H.
            apply (parity_ge_2 (st X)).
            destruct (st X). discriminate H0.
            destruct n. discriminate H0.
            lia.
      - verify_assn.
        rewrite <- H. symmetry.
        apply parity_lt_2.
        destruct (st X). lia.
        destruct n. lia.
        lia.
  -- verify_assn.
Qed.

(*
    {{ X = m }} ->>
    {{ X! * 1 = m!                                     }}
      Y := 1;
    {{ X! * Y = m!                                     }}
      while ~(X = 0)
      do   {{ X! * Y = m!  /\  ~(X = 0)                }} ->>
           {{ X! * Y = m!                              }}
         Y := Y × X;
           {{ X! * (Y * X) = m!                        }}
         X := X - 1
           {{ (X - 1)! * (Y * X) = m!                  }}
      end
    {{ X! * Y = m!  /\  X = 0                          }} ->>
    {{ Y = m! }}
*)

(*
  {{ True }} ->>
  {{ min a b  + 0 = min a b                      }}
  X := a;
  {{ min X b  + 0 = min a b                      }}
  Y := b;
  {{ min X Y  + 0 = min a b                      }}
  Z := 0;
  {{ min X Y  + Z = min a b                      }}
  while ~(X = 0) && ~(Y = 0) do
    {{ (min X Y  + Z = min a b) /\ ~(X = 0) /\ ~(Y = 0)    }} ->>
    {{ (min (X - 1) (Y - 1)  + (Z + 1) = min a b)          }}
    X := X - 1;
    {{ (min X (Y - 1)  + (Z + 1) = min a b)                }}
    Y := Y - 1;
    {{ (min X Y  + (Z + 1) = min a b)                      }}
    Z := Z + 1
    {{ (min X Y  + Z = min a b)                        }}
  end
  {{ (min X Y  + Z = min a b) /\ (X = 0) /\ (Y = 0)    }} ->>
  {{ Z = min a b }}
*)

Definition is_wp P c Q :=
  {{P}} c {{Q}} /\ forall P', {{P'}} c {{Q}} -> (P' ->> P).

Theorem is_wp_example :
  is_wp (Y <= 4) <{X := Y + 1}> (X <= 5).
Proof.
  split.
  - eapply hoare_consequence_pre.
    * apply hoare_asgn.
    * verify_assn.
  - intros P' H.
    unfold hoare_triple in H.
    unfold "->>".
    intros st Hp'.
    assert (G: (X !-> st Y + 1; st) X <= 5). {
      simpl in H.
      apply (H st (X !-> st Y + 1; st)).
      + constructor. simpl. reflexivity.
      + assumption.
    }
    unfold t_update in G. simpl in G.
    Search (?c <-> S ?x <= S ?y).
    Search (?x + ?y = ?y + ?x).
    rewrite add_comm in G.
    rewrite <- succ_le_mono in G.
    simpl.
    apply G.
Qed.

Theorem hoare_asgn_weakest : forall Q X a,
  is_wp (Q [X |-> a]) <{ X := a }> Q.
Proof.
  split.
  - apply hoare_asgn.
  - intros P' Hc st Hpst.
    unfold assn_sub.
    apply (Hc st).
    + constructor. reflexivity.
    + assumption.
Qed.

Module Himp2.
Import Himp.
Lemma hoare_havoc_weakest : forall (P Q : Assertion) (X : string),
  {{ P }} havoc X {{ Q }}  ->  P ->> havoc_pre X Q.
Proof.
  intros P Q X H st Hpst n.
  apply (H st).
  - constructor.
  - assumption.
Qed.
End Himp2.

Inductive dcom : Type :=
| DCSkip (Q : Assertion) (* skip {{ Q }} *)
| DCSeq (d1 d2 : dcom)  (* d1 ; d2 *)
| DCAsgn (X : string) (a : aexp) (Q : Assertion)  (* X := a {{ Q }} *)
| DCIf (b : bexp) (P1 : Assertion) (d1 : dcom)
       (P2 : Assertion) (d2 : dcom) (Q : Assertion)
  (* if b then {{ P1 }} d1 else {{ P2 }} d2 end {{ Q }} *)
| DCWhile (b : bexp) (P : Assertion) (d : dcom) (Q : Assertion)  (* while b do {{ P }} d end {{ Q }} *)
| DCPre (P : Assertion) (d : dcom)  (* ->> {{ P }} d *)
| DCPost (d : dcom) (Q : Assertion)  (* d ->> {{ Q }} *)
.

Inductive decorated : Type :=
  | Decorated : Assertion -> dcom -> decorated.

Declare Scope dcom_scope.
Notation "'skip' {{ P }}" := (DCSkip P)
      (in custom com at level 0, P constr) : dcom_scope.
Notation "l ':=' a {{ P }}" := (DCAsgn l a P)
      (in custom com at level 0, l constr at level 0, a custom com at level 85, P constr, no associativity) : dcom_scope.
Notation "'while' b 'do' {{ P }} d 'end' {{ Q }}" := (DCWhile b P d Q)
      (in custom com at level 89, b custom com at level 99, P constr, Q constr) : dcom_scope.
Notation "'if' b 'then' {{ P }} d 'else' {{ P' }} d' 'end' {{ Q }}" := (DCIf b P d P' d' Q)
      (in custom com at level 89, b custom com at level 99, P constr, P' constr, Q constr) : dcom_scope.
Notation "'->>' {{ P }} d" := (DCPre P d)
      (in custom com at level 12, right associativity, P constr) : dcom_scope.
Notation "d '->>' {{ P }}" := (DCPost d P)
      (in custom com at level 10, right associativity, P constr) : dcom_scope.
Notation " d ; d' " := (DCSeq d d')
      (in custom com at level 90, right associativity) : dcom_scope.
Notation "{{ P }} d" := (Decorated P d)
      (in custom com at level 91, P constr) : dcom_scope.
Open Scope dcom_scope.

Example dec0 :=  <{ skip {{ True }} }>.
Example dec1 :=  <{ while true do {{ True }} skip {{ True }} end  {{ True }} }>.

Example dec_while : decorated :=
  <{
    {{ True }}
    while ~(X = 0)
    do
      {{ True /\ ~(X = 0) }}
      X := X - 1
      {{ True }}
    end
    {{ True /\ X = 0}} ->>
    {{ X = 0 }}
  }>.

Fixpoint extract (d : dcom) : com :=
  match d with
  | DCSkip _            => CSkip
  | DCSeq d1 d2         => CSeq (extract d1) (extract d2)
  | DCAsgn X a _        => CAsgn X a
  | DCIf b _ d1 _ d2 _  => CIf b (extract d1) (extract d2)
  | DCWhile b _ d _     => CWhile b (extract d)
  | DCPre _ d           => extract d
  | DCPost d _          => extract d
  end.

Definition extract_dec (dec : decorated) : com :=
  match dec with
  | Decorated P d => extract d
  end.

Example extract_while_ex :
  extract_dec dec_while = <{while ~(X = 0) do X := X - 1 end}>.
Proof.
  unfold dec_while.
  reflexivity.
Qed.

Fixpoint post (d : dcom) : Assertion :=
  match d with
  | DCSkip P          => P
  | DCSeq _ d2        => post d2
  | DCAsgn _ _ Q      => Q
  | DCIf _ _ _ _ _ Q  => Q
  | DCWhile _ _ _ Q   => Q
  | DCPre _ d         => post d
  | DCPost _ Q        => Q
  end.

Definition pre_dec (dec : decorated) : Assertion :=
  match dec with
  | Decorated P d => P
  end.

Definition post_dec (dec : decorated) : Assertion :=
  match dec with
  | Decorated P d => post d
  end.

Example pre_dec_while : pre_dec dec_while = True.
Proof. reflexivity. Qed.

Example post_dec_while : post_dec dec_while = (X = 0)%assertion.
Proof. reflexivity. Qed.

Definition dec_correct (dec : decorated) :=  {{pre_dec dec}} extract_dec dec {{post_dec dec}}.

Example dec_while_triple_correct :
  dec_correct dec_while
 = {{ True }}
   while ~(X = 0) do X := X - 1 end
   {{ X = 0 }}.
Proof. reflexivity. Qed.

Fixpoint verification_conditions (P : Assertion) (d : dcom) : Prop :=
  match d with
  | DCSkip Q    => (P ->> Q)
  | DCSeq d1 d2 =>
         verification_conditions P d1
      /\ verification_conditions (post d1) d2
  | DCAsgn X a Q =>
      (P ->> Q [X |-> a])
  | DCIf b P1 d1 P2 d2 Q =>
         ((P /\  b) ->> P1)%assertion
      /\ ((P /\ ~b) ->> P2)%assertion
      /\ (post d1 ->> Q)
      /\ (post d2 ->> Q)
      /\ verification_conditions P1 d1
      /\ verification_conditions P2 d2
  | DCWhile b Pbody d Ppost =>
      (* post d is the loop invariant and the initial precondition *)
         (P ->> post d)
      /\ ((post d /\  b) ->> Pbody)%assertion
      /\ ((post d /\ ~b) ->> Ppost)%assertion
      /\ verification_conditions Pbody d
  | DCPre P' d =>
         (P ->> P')
      /\ verification_conditions P' d
  | DCPost d Q =>
         verification_conditions P d
      /\ (post d ->> Q)
  end.

Theorem verification_correct : forall d P,
  verification_conditions P d -> {{P}} extract d {{post d}}.
Proof.
  induction d; intros; simpl in *.
  - (* Skip *)
    eapply hoare_consequence_pre.
      + apply hoare_skip.
      + assumption.
  - (* Seq *)
    destruct H as [H1 H2].
    eapply hoare_seq.
      + apply IHd2. apply H2.
      + apply IHd1. apply H1.
  - (* Asgn *)
    eapply hoare_consequence_pre.
      + apply hoare_asgn.
      + assumption.
  - (* If *)
    destruct H as [HPre1 [HPre2 [Hd1 [Hd2 [HThen HElse] ] ] ] ].
    apply IHd1 in HThen. clear IHd1.
    apply IHd2 in HElse. clear IHd2.
    apply hoare_if.
      + eapply hoare_consequence; eauto.
      + eapply hoare_consequence; eauto.
  - (* While *)
    destruct H as [Hpre [Hbody1 [Hpost1 Hd] ] ].
    eapply hoare_consequence; eauto.
    apply hoare_while.
    eapply hoare_consequence_pre; eauto.
  - (* Pre *)
    destruct H as [HP Hd].
    eapply hoare_consequence_pre; eauto.
  - (* Post *)
    destruct H as [Hd HQ].
    eapply hoare_consequence_post; eauto.
Qed.

Definition verification_conditions_dec (dec : decorated) : Prop :=
  match dec with
  | Decorated P d => verification_conditions P d
  end.

Corollary verification_correct_dec : forall dec,
  verification_conditions_dec dec -> dec_correct dec.
Proof.
  intros [P d]. apply verification_correct.
Qed.

Eval simpl in verification_conditions_dec dec_while.

Example vc_dec_while : verification_conditions_dec dec_while.
Proof. verify_assn. Qed.

Ltac verify :=
  intros;
  apply verification_correct;
  verify_assn.

Theorem Dec_while_correct :  dec_correct dec_while.
Proof. verify. Qed.

Example subtract_slowly_dec (m : nat) (p : nat) : decorated :=
  <{
      {{ X = m /\ Z = p }} ->>
      {{ Z - X = p - m }}
    while ~(X = 0)
    do {{ Z - X = p - m /\ X <> 0 }} ->>
         {{ (Z - 1) - (X - 1) = p - m }}
       Z := Z - 1
         {{ Z - (X - 1) = p - m }} ;
       X := X - 1
         {{ Z - X = p - m }}
    end
      {{ Z - X = p - m /\ X = 0 }} ->>
      {{ Z = p - m }}
  }>.
Theorem subtract_slowly_dec_correct : forall m p,
  dec_correct (subtract_slowly_dec m p).
Proof. verify. (* this grinds for a bit! *) Qed.

(* Definition swap : com := *)
(*   <{ X := X + Y; *)
(*      Y := X - Y; *)
(*      X := X - Y }>. *)
Definition swap_dec (m n:nat) : decorated :=
  <{
       {{ X = m /\ Y = n}} ->>
       {{ (X + Y) - ((X + Y) - Y) = n /\ (X + Y) - Y = m }}
      X := X + Y
       {{ X - (X - Y) = n /\ X - Y = m }};
      Y := X - Y
       {{ X - Y = n /\ Y = m }};
      X := X - Y
       {{ X = n /\ Y = m}}
  }>.
Theorem swap_correct : forall m n,  dec_correct (swap_dec m n).
Proof. verify. Qed.

Definition div_mod_dec (a b : nat) : decorated :=
  <{
      {{ True }} ->>
      {{ b * 0 + a = a }}
      X := a
      {{ b * 0 + X = a }};
      Y := 0
      {{ b * Y + X = a }};
      while b <= X do
        {{ b * Y + X = a /\ b <= X }} ->>
        {{ b * (Y + 1) + (X - b) = a }}
        X := X - b
        {{ b * (Y + 1) + X = a }};
        Y := Y + 1
        {{ b * Y + X = a }}
      end
      {{ b * Y + X = a /\ ~(b <= X) }} ->>
      {{ b * Y + X = a /\ (X < b) }}
  }>.
Theorem div_mod_dec_correct : forall a b,  dec_correct (div_mod_dec a b).
Proof.
  verify.
Qed.

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n : nat, ev n -> ev (S (S n)).

Definition find_parity_dec' (m:nat) : decorated :=
  <{
        {{ X = m }} ->>
        {{ ap ev X <-> ev m }}
       while 2 <= X do
          {{ (ap ev X <-> ev m) /\ 2 <= X }} ->>
          {{ ap ev (X - 2) <-> ev m }}
          X := X - 2
          {{ ap ev X <-> ev m }}
       end
       {{ (ap ev X <-> ev m) /\ ~(2 <= X) }} ->>
       {{ X=0 <-> ev m }}
  }>.

Lemma l4 : forall m,
  2 <= m -> (ev (m - 2) <-> ev m).
Proof.
  induction m; intros. split; intro; constructor.
  destruct m. inversion H. inversion H1. simpl in *.
  rewrite <- minus_n_O in *. split; intro.
    constructor. assumption.
    inversion H0. assumption.
Qed.

Theorem find_parity_correct' : forall m,  dec_correct (find_parity_dec' m).
Proof.
  verify;
    (* simplification too aggressive ... reverting a bit *)
    fold (2 <=? (st X)) in *;
    try rewrite leb_iff in *;
    try rewrite leb_iff_conv in *; intuition; eauto; try lia.
  - (* invariant preserved (part 1) *)
    rewrite l4 in H0; eauto.
  - (* invariant preserved (part 2) *)
    rewrite l4; eauto.
  - (* invariant strong enough to imply conclusion
       (-> direction) *)
    apply H0. constructor.
  - (* invariant strong enough to imply conclusion
       (<- direction) *)
      destruct (st X) as [| [| n] ]. (* by H1 X can only be 0 or 1 *)
      + (* st X = 0 *)
        reflexivity.
      + (* st X = 1 *)
        inversion H.
      + (* st X = 2 *)
        lia.
Qed.

Example slow_assignment_dec (m : nat) : decorated :=
  <{  {{ X = m }} ->>
      {{ X + 0 = m }}
      Y := 0
      {{ X + Y = m }};
      while ~(X = 0) do
        {{ X + Y = m /\ ~(X = 0) }} ->>
        {{ (X - 1) + (Y + 1) = m }}
        X := X - 1
        {{ X + (Y + 1) = m }};
        Y := Y + 1
        {{ X + Y = m }}
      end
      {{ X + Y = m /\ (X = 0) }} ->>
      {{ Y = m }}
  }>.

Theorem slow_assignment_dec_correct : forall m,  dec_correct (slow_assignment_dec m).
Proof. verify. Qed.

Definition foo1: nat -> nat -> nat := fun a b => a + b.
Definition foo2: nat -> nat -> Prop := fun a b => a = b.

Definition foo3: foo2 1 1. (* Theorem / Lemma is just functions *)
Proof. reflexivity. Qed.

Fixpoint fib n :=
  match n with
  | 0    => 1
  | S n' => match n' with
            | 0     => 1
            | S n'' => fib n' + fib n''
            end
  end.

Lemma fib_eqn : forall n,
  n > 0 -> fib n + fib (pred n) = fib (1 + n).
Proof.
  intros n Hgt0.
  destruct n as [| n'].
  - inversion Hgt0.
  - simpl. reflexivity.
Qed.

Definition T : string := "T".

Open Scope com_scope.
Definition fib_prog (n: nat) : com :=
  <{
    X := 1;
    Y := 1;
    Z := 1;
    while ~(X = 1 + n) do
      T := Z;
      Z := Z + Y;
      Y := T;
      X := 1 + X
    end
  }>.

Open Scope dcom_scope.
Definition dfib (n: nat) : decorated :=
  <{
    {{ True }} ->>
    {{ 1 = 1 /\ 1 = 1 /\ 1 = 1 }}
    X := 1
    {{ X = 1 /\ 1 = 1 /\ 1 = 1 }};
    Y := 1
    {{ X = 1 /\ Y = 1 /\ 1 = 1 }};
    Z := 1
    {{ X = 1 /\ Y = 1 /\ Z = 1 }} ->>
    {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) }};
    while ~(X = 1 + n) do
      {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) /\ ~(X = 1 + n) }}
      T := Z
      {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) /\ T = (ap fib X) /\ ~(X = 1 + n) }};
      Z := Z + Y
      {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib (1 + X)) /\ T = (ap fib X) /\ ~(X = 1 + n) }};
      Y := T
      {{ X > 0 /\ Y = (ap fib X) /\ Z = (ap fib (1 + X)) /\ T = (ap fib X) /\ ~(X = 1 + n)  }} ->>
      {{ X > 0 /\ Y = (ap fib ((X + 1) - 1)) /\ Z = (ap fib (1 + X)) }};
      X := 1 + X
      {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) }}
    end
    {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) /\ (X = 1 + n) }} ->>
    {{ Y = fib n }}
  }>.

Lemma sn_1: forall n, S n - 1 = n.
Proof. intros n. simpl. lia. Qed.

Lemma n_1_1: forall n, n + 1 - 1 = n.
Proof. intros n. lia. Qed.

Lemma n_0: forall n, n - 0 = n.
Proof. intros n. lia. Qed.

Theorem dfib_correct : forall n,  dec_correct (dfib n).
Proof. verify.
  - destruct (st X). inversion H.
    rewrite -> sn_1. reflexivity.
  - rewrite -> n_1_1. reflexivity.
  - rewrite -> n_1_1.
    rewrite -> n_0. reflexivity.
  - rewrite -> sn_1. reflexivity.
Qed.

(*
  Exercise: 5 stars, advanced, optional (improve_dcom)
  The formal decorated programs defined in this section are intended to
  look as similar as possible to the informal ones defined earlier in the
  chapter. If we drop this requirement, we can eliminate almost all annotations,
   just requiring final postconditions and loop invariants to be provided explicitly.
  Do this -- i.e., define a new version of dcom with as few annotations as possible
  and adapt the rest of the formal development leading up to the verification_correct theorem.
*)

Module LastEx.
End LastEx.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**

----------------------------------------------------------
#
#
** Lesson 7: summary

- generic notations and theories
- interfaces
- parametrizing theories
- the BigOp library (the theories of fold)

Let's start with a lie and then make it true:

#
#
Coq is an object oriented
programming language.
#
#

#
#

----------------------------------------------------------
#
#
** Generic notations and theories

Polymorphism != overloading.

Example: the [==] computable equality

#
#
*)

(**
#
#

Polymorphism

#
#

*)

Check (_ = _).

Check true = false.

Check (eq true false).

Check @eq.

Check (@eq _ true false).

Check (@eq bool true false).

(**
#
#

Overloading : looking inside types

#
#

*)

Check (_ == _).

Check true == false.

Check (@eq_op _ true false).

Check (@eq_op bool_eqType true false).

Check 3 == 4.

Check [::] == [:: 2; 3; 4].

Section T.

Variable T : eqType.
Variable x : T.

Eval lazy in x == x.

End T.

(**
#
#

Object oriented flavor

#
#

*)

Eval lazy in true == false.

Eval lazy in 3 == 4.

Eval lazy in [::] == [:: 2; 3; 4].

Check (3, true) == (4, false).

Eval lazy in (3, true) == (4, false).

(**
#
#

Overloading may fail, polymorphism never

#
#

*)

Fail Check (fun x => x) == (fun y => y).

Check (fun x => x) = (fun y => y).

(**
#
#

Type inference

#
#

*)

Check [eqType of bool].

Fail Check [eqType of bool -> bool].

Check [eqType of {ffun bool -> bool}].

Check [eqType of nat].

Fail Check [eqType of nat -> nat].

Check [eqType of {ffun 'I_256 -> nat}].

Check [eqType of seq nat].

Fail Check [eqType of seq (nat -> nat)].

Check [eqType of seq {ffun 'I_256 -> nat}].

(**
#
#

We call [eqType] an interface. With some "approximation"
[eqType] is defined as follows:

<<

Module Equality.

Structure type : Type := Pack {
  sort : Type;
  op : sort -> sort -> bool;
  axiom : ∀x y, reflect (x = y) (op x y)
}.

End Equality
>>

#
(notes)
#
This slide corresponds to
section 5.4 of
#the Mathematical Components book#
#

#
#

#
#
#

----------------------------------------------------------
#
#
** Interfaces

Mathematical Components defines a hierarchy
of interfaces. They group notations and
theorems.

# #

Let's use the theory of [eqType]

#
#
*)

About eqxx.

About eq_refl.

Lemma test_eq (*(T : eqType) (x : T)*) :
  (3 == 3) && (true == true) (*&& (x == x)*).
Proof.
rewrite eqxx.
rewrite eqxx.
(* rewrite eqxx. *)
by [].
Qed.

(**
#
#

Interfaces do apply to registered, concrete examples
such as [bool] or [nat]. They can also apply to variables,
as long as their type is "rich" ([eqType] is richer than [Type]).

#
(notes)
#
This slide corresponds to
section 5.5 and 7 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Theories over an interface

Interfaces can be used to parametrize an
entire theory

#
#
*)
Module Seq. Section Theory.

Variable T : eqType.

Implicit Type s : seq T.

Fixpoint mem_seq s x :=
  if s is y :: s1
  then (y == x) || mem_seq s1 x
  else false.

(* the infix \in and \notin are generic, not
   just for sequences. *)

Fixpoint uniq s :=
  if s is x :: s1
  then (x \notin s1) && uniq s1
  else true.

Fixpoint undup s :=
  if s is x :: s1 then
    if x \in s1 then undup s1 else x :: undup s1
  else [::].

End Theory. End Seq.

About undup_uniq.

Eval lazy in (undup [::1;3;1;4]).

Lemma test : uniq (undup [::1;3;1;4]).
Proof.
by rewrite undup_uniq.
Qed.

(**
#
#

Others interfaces

**)

Section Interfaces.

Variable chT : choiceType.

Check (@sigW chT).

Check [eqType of chT].

Variable coT : countType.

Check [countType of nat].
Check [choiceType of coT].
Check [choiceType of nat * nat].
Check [choiceType of seq coT].

Variable fT : finType.

Check [finType of bool].
Check [finType of 'I_10].
Check [finType of {ffun 'I_10 -> fT}].
Check [finType of bool * bool].

End Interfaces.

(**
#
#

#
(notes)
#
This slide corresponds to
section 5.6 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Generic theories: the BigOp library

The BigOp library is the canonical example
of a generic theory. It it about the
[fold] iterator we studied in lesson 1,
and the many uses it can have.

#
#
*)

Lemma sum_odd_3 :
  \sum_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite unlock /=.
by [].
Qed.

About big_mkcond.
About big_nat_recr.

Lemma sum_odd_3_bis :
  \sum_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite big_mkcond big_nat_recr //= -big_mkcond /=.
Abort.

Lemma prod_odd_3_bis : (* try [maxn/0] and also [maxn/1] *)
  \big[muln/1]_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite big_mkcond big_nat_recr //= -big_mkcond /=.
Abort.

(**
#
#

Most of the lemmas require the operation to be a monoid,
some others to be a commutative monoid.

#
#
*)

About bigD1.

(**
#
#

Searching for bigop

#
#
*)

Lemma sum_odd_even_all n :
  \sum_(0 <= i < n) i =
  \sum_(0 <= i < n | odd i) i + \sum_(0 <= i < n | ~~ odd i) i.
Proof.
Search _ (~~ _) in bigop.
by rewrite (bigID odd).
Qed.

(**
#
#

Primer for bigop

#
#
*)

Section Primer.

Variable n: nat.
Variable f : 'I_n -> nat.
Variable g : nat -> nat.

Check \big[addn/0]_(i <- [::1; 4; 5] | odd i) g i.

Check \big[addn/0]_(i : 'I_n | odd i) f i.

Definition oddIn := [pred i | odd (i : 'I_n)].

Check \big[addn/0]_(i in oddIn) f i.

Goal \sum_(i in oddIn) i = \sum_(i < n | odd i) i.
Proof.
by [].
Qed.

Check \big[addn/0]_(0 <= i < n | odd i) g i.

Goal \sum_(0 <= i < n | odd i) g i = \sum_(i < n | odd i) g i.
Proof.
Check big_mkord.
rewrite big_mkord.
by [].
Qed.

Goal \sum_(0 <= i < n |odd i) i.*2 = \sum_(0 <= i < n|odd i) (i + i).
Proof.
Fail rewrite addnn.
About eq_bigr.
apply: eq_bigr.
move=> i Hi.
by rewrite addnn.
Qed.

Goal \sum_(0 <= i < n |odd i) i.*2 = \sum_(0 <= i < n | odd i) (i + i).
Proof.
About eq_bigr.
rewrite (eq_bigr (fun i => i + i)) //.
move=> i Hi.
by rewrite addnn.
Qed.

Goal (\sum_(i < n|odd i) i).*2 = \sum_(i < n |odd i) i.*2.
Proof.
About  big_morph.
Fail rewrite big_morph.
rewrite (big_morph _ (_ : {morph double : x y / x + y}) (_ : 0.*2 = 0)).
- by [].
- move=> x y; exact: doubleD.
by [].
Qed.

End Primer.

(**
#
#

#
(notes)
#
This slide corresponds to
section 5.7 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Sum up

- Coq is an object oriented language ;-)

- in the Mathematical Components library [xxType] is an
  interface (eg [eqType] for types with an equality test).
  Notations and theorems are linked to interfaces.
  Interfaces are organized in hierarchies (we just saw a picture,
  how it works can be found in the book).

#
#

*)


(**************************************************************)
(* Negation.v                                                 *)
(*                                                            *)
(* Author: Aaron Bohannon                                     *)
(**************************************************************)

(** This file provides some lemmas and tactics for manipulating
    uses of [not] in propositions.  A few assorted items are
    included that would make more sense in [Decidable.v] in the
    standard library. *)

Require Export Decidable.
Require Import Setoid.

(** * Some Lemmas and Tactics About Decidable Propositions *)

Lemma dec_iff : forall P Q : Prop,
  decidable P ->
  decidable Q ->
  decidable (P <-> Q).
Proof.
  unfold decidable in *. tauto.
Qed.

(** With this hint database, we can leverage [auto] to check
    decidability of propositions. *)
Hint Resolve
  dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff
: decidable_prop.

(** [solve_decidable using lib] will solve goals about the
    decidability of a proposition, assisted by an auxiliary
    database of lemmas.  The database is intended to contain
    lemmas stating the decidability of additional propositions,
    (e.g., the decidability of equality on a particular
    inductive type). *)
Tactic Notation "solve_decidable" "using" ident(db) :=
  match goal with
  | |- decidable ?P =>
    solve [ auto 100 with decidable_prop db ]
  end.

Tactic Notation "solve_decidable" :=
  solve_decidable using core.

(** * Propositional Equivalences Involving Negation
    These are all written with the unfolded form of negation,
    since, in a situation (such as a tactic) where they will be
    used repeatedly, we don't want to have to interleave their
    uses with uses of [fold] or [unfold] to get their full
    benefit.  (For a specific example, consider what would
    happen if the first lemma [not_true_iff] were written as [~
    True <-> False].  How would it be used to replace [True ->
    (~ True)] with [False]?)
*)

(** ** Eliminating Negations
    We begin with lemmas that, when read from left to right, can
    be understood as ways to eliminate uses of [not]. *)

Lemma not_true_iff :
  (True -> False) <-> False.
Proof.
  tauto.
Qed.

Lemma not_false_iff :
  (False -> False) <-> True.
Proof.
  tauto.
Qed.

Lemma not_not_iff : forall P : Prop,
  decidable P ->
  (((P -> False) -> False) <-> P).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma contrapositive : forall P Q : Prop,
  decidable P ->
  (((P -> False) -> (Q -> False)) <-> (Q -> P)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma and_not_l_iff_1 : forall P Q : Prop,
  decidable P ->
  ((P -> False) \/ Q <-> (P -> Q)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma and_not_l_iff_2 : forall P Q : Prop,
  decidable Q ->
  ((P -> False) \/ Q <-> (P -> Q)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma and_not_r_iff_1 : forall P Q : Prop,
  decidable P ->
  (P \/ (Q -> False) <-> (Q -> P)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma and_not_r_iff_2 : forall P Q : Prop,
  decidable Q ->
  (P \/ (Q -> False) <-> (Q -> P)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma imp_not_l : forall P Q : Prop,
  decidable P ->
  ((~ P -> Q) <-> (P \/ Q)).
Proof.
  unfold decidable in *. tauto.
Qed.

(** ** Pushing Negations Around
    We have four lemmas that, when read from left to right,
    describe how to push negations toward the leaves of a
    proposition and, when read from right to left, describe
    how to pull negations toward the top of a propsition. *)

Lemma not_or_iff : forall P Q : Prop,
  (P \/ Q -> False) <-> (P -> False) /\ (Q -> False).
Proof.
  tauto.
Qed.

Lemma not_and_iff : forall P Q : Prop,
  (P /\ Q -> False) <-> (P -> Q -> False).
Proof.
  tauto.
Qed.

Lemma not_imp_iff : forall P Q : Prop,
  decidable P ->
  (((P -> Q) -> False) <-> P /\ (Q -> False)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma not_imp_rev_iff : forall P Q : Prop,
  decidable P ->
  (((P -> Q) -> False) <-> (Q -> False) /\ P).
Proof.
  unfold decidable in *. tauto.
Qed.

(** * Tactics for Negations *)

(** ** Folding Negations
    This section provides tactics for folding uses of [not]
    wherever possible.  Multiple versions are provided that
    correspond to many of the forms used by the built-in
    conversion tactics. *)

Tactic Notation "fold" "any" "not" :=
  repeat (
    match goal with
    | |- context [?P -> False] =>
      fold (~ P)
    end).

Tactic Notation "fold" "any" "not" "in" ident(H) "|-" :=
  repeat (
    match goal with
    | J: context [?P -> False] |- _ =>
      fold (~ P) in H
    end).

Tactic Notation "fold" "any" "not" "in" ident(H) :=
  fold any not in H |-.

Tactic Notation "fold" "any" "not" "in" "*" "|-" :=
  repeat (
    match goal with
    | H: context [?P -> False] |- _ =>
      fold (~ P) in H
    end).

Tactic Notation "fold" "any" "not" "in" "*" :=
  fold any not in * |-; fold any not.

Tactic Notation "fold" "any" "not" "in" "*" "|-" "*" :=
  fold any not in *.

(** ** Folding [Iff]
    This section provides tactics for folding uses of [iff]
    wherever possible.  Multiple versions are provided that
    correspond to many of the forms used by the built-in
    conversion tactics.  These tactic may be better located
    somewhere else in the standard library: although it is
    used in this file, it has nothing to do with negation. *)

Tactic Notation "fold" "any" "iff" :=
  repeat (
    match goal with
    | |- context [(?P -> ?Q) /\ (?Q -> ?P)] =>
      fold (P <-> Q)
    end).

Tactic Notation "fold" "any" "iff" "in" ident(H) "|-" :=
  repeat (
    match goal with
    | J: context [(?P -> ?Q) /\ (?Q -> ?P)] |- _ =>
      fold (P <-> Q) in H
    end).

Tactic Notation "fold" "any" "iff" "in" ident(H) :=
  fold any iff in H |-.

Tactic Notation "fold" "any" "iff" "in" "*" "|-" :=
  repeat (
    match goal with
    | H: context [(?P -> ?Q) /\ (?Q -> ?P)] |- _ =>
      fold (P <-> Q) in H
    end).

Tactic Notation "fold" "any" "iff" "in" "*" :=
  fold any iff in * |-; fold any iff.

Tactic Notation "fold" "any" "iff" "in" "*" "|-" "*" :=
  fold any iff in *.

(** [push not using db] will push all negations to the leaves of
    propositions in the goal, using the lemmas in [db] to assist
    in checking the decidability of the propositions involved.
    If [using db] is omitted, then [core] will be used.
    Additional versions are provided to manipulate the
    hypotheses, following the conventions used by the built-in
    tactics.  (Is there a way to do this without using so much
    cut-and-paste?) *)

Tactic Notation "push" "not" "using" ident(db) :=
  unfold not, iff;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | |- context [True -> False] =>
      rewrite not_true_iff
    (** simplification by not_false_iff *)
    | |- context [False -> False] =>
      rewrite not_false_iff
    (** simplification by not_not_iff *)
    | |- context [(?P -> False) -> False] =>
      rewrite (not_not_iff P);
        [ solve_decidable using db | ]
    (** simplification by contrapositive *)
    | |- context [(?P -> False) -> (?Q -> False)] =>
      rewrite (contrapositive P Q);
        [ solve_decidable using db | ]
    (** simplification by and_not_l_iff_1/_2 *)
    | |- context [(?P -> False) \/ ?Q] =>
      (rewrite (and_not_l_iff_1 P Q);
        [ solve_decidable using db | ]) ||
      (rewrite (and_not_l_iff_2 P Q);
        [ solve_decidable using db | ])
    (** simplification by and_not_r_iff_1/_2 *)
    | |- context [?P \/ (?Q -> False)] =>
      (rewrite (and_not_r_iff_1 P Q);
        [ solve_decidable using db | ]) ||
      (rewrite (and_not_r_iff_2 P Q);
        [ solve_decidable using db | ])
    (** simplification by imp_not_l *)
    | |- context [(?P -> False) -> ?Q] =>
      rewrite (imp_not_l P Q);
        [ solve_decidable using db | ]
    (** rewriting by not_or_iff *)
    | |- context [?P \/ ?Q -> False] =>
      rewrite (not_or_iff P Q)
    (** rewriting by not_and_iff *)
    | |- context [?P /\ ?Q -> False] =>
      rewrite (not_and_iff P Q)
    (** rewriting by not_imp_iff *)
    | |- context [(?P -> ?Q) -> False] =>
      rewrite (not_imp_iff P Q);
        [ solve_decidable using db | ]
    end);
  fold any not; fold any iff.

Tactic Notation "push" "not" :=
  push not using core.

Tactic Notation "push" "not" "in" ident(H) "|-"
  "using" ident(db) :=
  unfold not, iff in * |-;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | J: context [True -> False] |- _ =>
      rewrite not_true_iff in H
    (** simplification by not_false_iff *)
    | J: context [False -> False] |- _ =>
      rewrite not_false_iff in H
    (** simplification by not_not_iff *)
    | J: context [(?P -> False) -> False] |- _ =>
      rewrite (not_not_iff P) in H;
        [ | solve_decidable using db ]
    (** simplification by contrapositive *)
    | J: context [(?P -> False) -> (?Q -> False)] |- _ =>
      rewrite (contrapositive P Q) in H;
        [ | solve_decidable using db ]
    (** simplification by and_not_l_iff_1/_2 *)
    | J: context [(?P -> False) \/ ?Q] |- _ =>
      (rewrite (and_not_l_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_l_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by and_not_r_iff_1/_2 *)
    | J: context [?P \/ (?Q -> False)] |- _ =>
      (rewrite (and_not_r_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_r_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by imp_not_l *)
    | J: context [(?P -> False) -> ?Q] |- _ =>
      rewrite (imp_not_l P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_or_iff *)
    | J: context [?P \/ ?Q -> False] |- _ =>
      rewrite (not_or_iff P Q) in H
    (** rewriting by not_and_iff *)
    | J: context [?P /\ ?Q -> False] |- _ =>
      rewrite (not_and_iff P Q) in H
    (** rewriting by not_imp_iff *)
    | J: context [(?P -> ?Q) -> False] |- _ =>
      rewrite (not_imp_iff P Q) in H;
        [ | solve_decidable using db ]
    end);
  fold any not in * |-; fold any iff in * |-.

Tactic Notation "push" "not" "in" ident(H) "|-"  :=
  push not in H |- using core.

Tactic Notation "push" "not" "in" ident(H) "using" ident(db) :=
  push not in H |- using db.
Tactic Notation "push" "not" "in" ident(H) :=
  push not in H |- using core.

Tactic Notation "push" "not" "in" "*" "|-" "using" ident(db) :=
  unfold not, iff in * |-;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | H: context [True -> False] |- _ =>
      rewrite not_true_iff in H
    (** simplification by not_false_iff *)
    | H: context [False -> False] |- _ =>
      rewrite not_false_iff in H
    (** simplification by not_not_iff *)
    | H: context [(?P -> False) -> False] |- _ =>
      rewrite (not_not_iff P) in H;
        [ | solve_decidable using db ]
    (** simplification by contrapositive *)
    | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
      rewrite (contrapositive P Q) in H;
        [ | solve_decidable using db ]
    (** simplification by and_not_l_iff_1/_2 *)
    | H: context [(?P -> False) \/ ?Q] |- _ =>
      (rewrite (and_not_l_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_l_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by and_not_r_iff_1/_2 *)
    | H: context [?P \/ (?Q -> False)] |- _ =>
      (rewrite (and_not_r_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_r_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by imp_not_l *)
    | H: context [(?P -> False) -> ?Q] |- _ =>
      rewrite (imp_not_l P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_or_iff *)
    | H: context [?P \/ ?Q -> False] |- _ =>
      rewrite (not_or_iff P Q) in H
    (** rewriting by not_and_iff *)
    | H: context [?P /\ ?Q -> False] |- _ =>
      rewrite (not_and_iff P Q) in H
    (** rewriting by not_imp_iff *)
    | H: context [(?P -> ?Q) -> False] |- _ =>
      rewrite (not_imp_iff P Q) in H;
        [ | solve_decidable using db ]
    end);
  fold any not in * |-; fold any iff in * |-.

Tactic Notation "push" "not" "in" "*" "|-"  :=
  push not in * |- using core.

Tactic Notation "push" "not" "in" "*" "using" ident(db) :=
  push not using db; push not in * |- using db.
Tactic Notation "push" "not" "in" "*" :=
  push not in * using core.

Tactic Notation "push" "not" "in" "*" "|-" "*"
  "using" ident(db) :=
  push not in * using db.
Tactic Notation "push" "not" "in" "*" "|-" "*" :=
  push not in * using core.

Lemma test_push : forall P Q R : Prop,
  decidable P ->
  decidable Q ->
  (~ True) ->
  (~ False) ->
  (~ ~ P) ->
  (~ (P /\ Q) -> ~ R) ->
  ((P /\ Q) \/ ~ R) ->
  (~ (P /\ Q) \/ R) ->
  (R \/ ~ (P /\ Q)) ->
  (~ R \/ (P /\ Q)) ->
  (~ P -> R) ->
  (~ ((R -> P) \/ (R -> Q))) ->
  (~ (P /\ R)) ->
  (~ (P -> R)) ->
  True.
Proof.
  intros. push not in *. tauto.
Qed.

(** [pull not using db] will pull as many negations as possible
    toward the top of the propositional formula in the goal,
    using the lemmas in [db] to assist in checking the
    decidability of the propositions involved.  If [using db] is
    omitted, then [core] will be used.  Additional versions are
    provided to manipulate the hypotheses, following the
    conventions used by the built-in tactics.  (Is there a way
    to do this without using so much cut-and-paste?) *)

Tactic Notation "pull" "not" "using" ident(db) :=
  unfold not, iff;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | |- context [True -> False] =>
      rewrite not_true_iff
    (** simplification by not_false_iff *)
    | |- context [False -> False] =>
      rewrite not_false_iff
    (** simplification by not_not_iff *)
    | |- context [(?P -> False) -> False] =>
      rewrite (not_not_iff P);
        [ solve_decidable using db | ]
    (** simplification by contrapositive *)
    | |- context [(?P -> False) -> (?Q -> False)] =>
      rewrite (contrapositive P Q);
        [ solve_decidable using db | ]
    (** simplification by and_not_l_iff_1/_2 *)
    | |- context [(?P -> False) \/ ?Q] =>
      (rewrite (and_not_l_iff_1 P Q);
        [ solve_decidable using db | ]) ||
      (rewrite (and_not_l_iff_2 P Q);
        [ solve_decidable using db | ])
    (** simplification by and_not_r_iff_1/_2 *)
    | |- context [?P \/ (?Q -> False)] =>
      (rewrite (and_not_r_iff_1 P Q);
        [ solve_decidable using db | ]) ||
      (rewrite (and_not_r_iff_2 P Q);
        [ solve_decidable using db | ])
    (** simplification by imp_not_l *)
    | |- context [(?P -> False) -> ?Q] =>
      rewrite (imp_not_l P Q);
        [ solve_decidable using db | ]
    (** rewriting by not_or_iff *)
    | |- context [(?P -> False) /\ (?Q -> False)] =>
      rewrite <- (not_or_iff P Q)
    (** rewriting by not_and_iff *)
    | |- context [?P -> ?Q -> False] =>
      rewrite <- (not_and_iff P Q)
    (** rewriting by not_imp_iff *)
    | |- context [?P /\ (?Q -> False)] =>
      rewrite <- (not_imp_iff P Q);
        [ solve_decidable using db | ]
    (** rewriting by not_imp_rev_iff *)
    | |- context [(?Q -> False) /\ ?P] =>
      rewrite <- (not_imp_rev_iff P Q);
        [ solve_decidable using db | ]
    end);
  fold any not; fold any iff.

Tactic Notation "pull" "not" :=
  pull not using core.

Tactic Notation "pull" "not" "in" ident(H) "|-"
  "using" ident(db) :=
  unfold not, iff in * |-;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | J: context [True -> False] |- _ =>
      rewrite not_true_iff in H
    (** simplification by not_false_iff *)
    | J: context [False -> False] |- _ =>
      rewrite not_false_iff in H
    (** simplification by not_not_iff *)
    | J: context [(?P -> False) -> False] |- _ =>
      rewrite (not_not_iff P) in H;
        [ | solve_decidable using db ]
    (** simplification by contrapositive *)
    | J: context [(?P -> False) -> (?Q -> False)] |- _ =>
      rewrite (contrapositive P Q) in H;
        [ | solve_decidable using db ]
    (** simplification by and_not_l_iff_1/_2 *)
    | J: context [(?P -> False) \/ ?Q] |- _ =>
      (rewrite (and_not_l_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_l_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by and_not_r_iff_1/_2 *)
    | J: context [?P \/ (?Q -> False)] |- _ =>
      (rewrite (and_not_r_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_r_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by imp_not_l *)
    | J: context [(?P -> False) -> ?Q] |- _ =>
      rewrite (imp_not_l P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_or_iff *)
    | J: context [(?P -> False) /\ (?Q -> False)] |- _ =>
      rewrite <- (not_or_iff P Q) in H
    (** rewriting by not_and_iff *)
    | J: context [?P -> ?Q -> False] |- _ =>
      rewrite <- (not_and_iff P Q) in H
    (** rewriting by not_imp_iff *)
    | J: context [?P /\ (?Q -> False)] |- _ =>
      rewrite <- (not_imp_iff P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_imp_rev_iff *)
    | J: context [(?Q -> False) /\ ?P] |- _ =>
      rewrite <- (not_imp_rev_iff P Q) in H;
        [ | solve_decidable using db ]
    end);
  fold any not in * |-; fold any iff in * |-.

Tactic Notation "pull" "not" "in" ident(H) "|-"  :=
  pull not in H |- using core.

Tactic Notation "pull" "not" "in" ident(H) "using" ident(db) :=
  pull not in H |- using db.
Tactic Notation "pull" "not" "in" ident(H) :=
  pull not in H |- using core.

Tactic Notation "pull" "not" "in" "*" "|-" "using" ident(db) :=
  unfold not, iff in * |-;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | H: context [True -> False] |- _ =>
      rewrite not_true_iff in H
    (** simplification by not_false_iff *)
    | H: context [False -> False] |- _ =>
      rewrite not_false_iff in H
    (** simplification by not_not_iff *)
    | H: context [(?P -> False) -> False] |- _ =>
      rewrite (not_not_iff P) in H;
        [ | solve_decidable using db ]
    (** simplification by contrapositive *)
    | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
      rewrite (contrapositive P Q) in H;
        [ | solve_decidable using db ]
    (** simplification by and_not_l_iff_1/_2 *)
    | H: context [(?P -> False) \/ ?Q] |- _ =>
      (rewrite (and_not_l_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_l_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by and_not_r_iff_1/_2 *)
    | H: context [?P \/ (?Q -> False)] |- _ =>
      (rewrite (and_not_r_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_r_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by imp_not_l *)
    | H: context [(?P -> False) -> ?Q] |- _ =>
      rewrite (imp_not_l P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_or_iff *)
    | H: context [(?P -> False) /\ (?Q -> False)] |- _ =>
      rewrite <- (not_or_iff P Q) in H
    (** rewriting by not_and_iff *)
    | H: context [?P -> ?Q -> False] |- _ =>
      rewrite <- (not_and_iff P Q) in H
    (** rewriting by not_imp_iff *)
    | H: context [?P /\ (?Q -> False)] |- _ =>
      rewrite <- (not_imp_iff P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_imp_rev_iff *)
    | H: context [(?Q -> False) /\ ?P] |- _ =>
      rewrite <- (not_imp_rev_iff P Q) in H;
        [ | solve_decidable using db ]
    end);
  fold any not in * |-; fold any iff in * |-.

Tactic Notation "pull" "not" "in" "*" "|-"  :=
  pull not in * |- using core.

Tactic Notation "pull" "not" "in" "*" "using" ident(db) :=
  pull not using db; pull not in * |- using db.
Tactic Notation "pull" "not" "in" "*" :=
  pull not in * using core.

Tactic Notation "pull" "not" "in" "*" "|-" "*"
  "using" ident(db) :=
  pull not in * using db.
Tactic Notation "pull" "not" "in" "*" "|-" "*" :=
  pull not in * using core.

Lemma test_pull : forall P Q R : Prop,
  decidable P ->
  decidable Q ->
  (~ True) ->
  (~ False) ->
  (~ ~ P) ->
  (~ (P /\ Q) -> ~ R) ->
  ((P /\ Q) \/ ~ R) ->
  (~ (P /\ Q) \/ R) ->
  (R \/ ~ (P /\ Q)) ->
  (~ R \/ (P /\ Q)) ->
  (~ P -> R) ->
  (~ (R -> P) /\ ~ (R -> Q)) ->
  (~ P \/ ~ R) ->
  (P /\ ~ R) ->
  (~ R /\ P) ->
  True.
Proof.
  intros. pull not in *. tauto.
Qed.


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

Inductive natural : Type :=   Zero : natural | Succ : natural -> natural .

Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> 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 plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint fac (fac_arg0 : natural) : natural
           := match fac_arg0 with
              | Zero => Succ Zero
              | Succ n => mult (fac n) n
              end.

Fixpoint qfac (qfac_arg0 : natural) (qfac_arg1 : natural) : natural
           := match qfac_arg0, qfac_arg1 with
              | Zero, n => n
              | Succ n, m => qfac n (mult m n)
              end.
Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   -
   rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma mult_zero : forall (x : natural), mult x Zero = Zero.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma mult_succ : forall (x y : natural), plus (mult x y) x = mult x (Succ y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite plus_succ. rewrite plus_assoc. rewrite (plus_commut y x).
      rewrite <- plus_assoc. rewrite IHx. rewrite plus_succ. reflexivity.
Qed.

Lemma mult_commut : forall (x y : natural), mult x y = mult y x.
Proof.
   intros.
   induction x.
   -
     rewrite mult_zero. reflexivity.
   - simpl. rewrite IHx. rewrite mult_succ. reflexivity.
Qed.

Lemma distrib : forall (x y z : natural), mult (plus x y) z = plus (mult x z) (mult y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut (mult y z) z).
     rewrite <- plus_assoc. reflexivity.
Qed.

Lemma mult_assoc : forall (x y z : natural), mult (mult x y) z = mult x (mult y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite distrib. rewrite IHx. reflexivity.
Qed.

Lemma qfac_mult : forall (x y : natural), qfac x y = mult (qfac x (Succ Zero)) y.
Proof.
   intro.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite (IHx x). lfind. Admitted.


Definition BoolE : forall (p:bool -> Prop), p true -> p false -> forall (x:bool), p x :=
    fun (p:bool -> Prop) =>
        fun (tt:p true) =>
            fun (ff: p false) =>
                fun (x:bool) =>
                    match x with
                    | true  => tt
                    | false => ff
                    end.

Definition BoolC1 : bool := true.
Definition BoolC2 : bool := false.

Definition L1 : forall (x:bool), negb (negb x) = x.
Proof.
    intros x.
    apply (BoolE (fun z => negb (negb z) = z)).
    - exact (eq_refl true).
    - exact (eq_refl false).
Qed.

Definition L2 : forall (x:bool), negb (negb x) = x :=
    fun (x:bool) => BoolE
        (fun (z:bool) => negb (negb z) = z)
        (eq_refl true)
        (eq_refl false)
        x.

Definition BoolRec : forall (p:bool -> Type), p true -> p false -> forall (x:bool), p x :=
    fun (p:bool -> Type) =>
        fun (tt:p true) =>
            fun (ff: p false) =>
                fun (x:bool) =>
                    match x with
                    | true  => tt
                    | false => ff
                    end.

Definition not : bool -> bool := BoolRec (fun (x:bool) => bool) false true.

Definition L3 : not = fun(x:bool) => match x with true => false | false => true end :=
    eq_refl not.

Definition BoolE' : forall (p:bool -> Prop), p true -> p false -> forall (x:bool), p x :=
    fun (p:bool -> Prop) => BoolRec p.

Variable BoolE1 : forall (p:bool -> Prop), p true -> p false -> forall (x:bool), p x.

Definition L4 : forall (x:bool), x = true \/ x = false :=
    fun (x:bool) =>
        match x with
        | true  => or_introl (eq_refl true)
        | false => or_intror (eq_refl false)
        end.

Definition L5 : forall (x:bool), x = true \/ x = false := BoolE1
    (fun (x:bool) => x = true \/ x = false)
    (or_introl (eq_refl true))
    (or_intror (eq_refl false)).

Definition L6 : forall (p:bool -> Prop), (forall (x y:bool), y = x -> p x) -> forall (x:bool), p x :=
    fun (p:bool -> Prop) =>
        fun (q:forall (x y:bool), y = x -> p x) =>
            fun (x:bool) => q x x (eq_refl x).

Fail Definition L7 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) =>
        fun (x:bool) =>
            fun (tt:x = true -> p true) =>
                fun (ff:x = false -> p false) =>
                    match x with
                    | true  => tt (eq_refl true)
                    | false => ff (eq_refl false)
                    end.

Definition bool_dec : forall (x:bool), x = true \/ x = false :=
    fun (x:bool) =>
        match x with
        | true  => or_introl (eq_refl true)
        | false => or_intror (eq_refl false)
        end.

Fail Definition L8 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) =>
        fun (x:bool) =>
            fun (tt:x = true -> p true) =>
                fun (ff:x = false -> p false) =>
                    match bool_dec x with
                    | or_introl p  => tt p
                    | or_intror p  => ff p
                    end.

Definition bool_dec' : forall (x:bool), {x = true} + {x = false} :=
    fun (x:bool) =>
        match x with
        | true  => left  (eq_refl true)
        | false => right (eq_refl false)
        end.

Fail Definition L9 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) =>
        fun (x:bool) =>
            fun (tt:x = true -> p true) =>
                fun (ff:x = false -> p false) =>
                    match bool_dec' x with
                    | left p   => tt p
                    | right p  => ff p
                    end.

Definition L10 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x.
Proof.
    intros p x H1 H2. destruct x.
    - apply H1. reflexivity.
    - apply H2. reflexivity.
Qed.

Definition L11 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) (x:bool) (H1:x = true -> p true) (H2:x = false -> p false) =>
        match x as b return x = b -> p b with
        | true  => H1
        | false => H2
        end (eq_refl x).

Print L10.

Definition L12 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) (x:bool) (H1:x = true -> p true) (H2:x = false -> p false) =>
        match x as b return  ((b = true -> p true) -> (b = false -> p false) -> p b) with
        | true  => fun (H3:true  = true -> p true) (_ :true  = false -> p false) => H3 (eq_refl true)
        | false => fun (_ :false = true -> p true) (H4:false = false -> p false) => H4 (eq_refl false)
        end H1 H2.

Definition and1 : bool -> bool -> bool := BoolRec
    (fun _ => bool -> bool)
    (fun y => y)
    (fun _ => false).

Definition and : bool -> bool -> bool :=
    fun (x:bool) =>
        fun(y:bool) => (BoolRec
            (fun _ => bool)
            y
            false) x.

(* and is computationally equal to ....                                        *)
Definition L13 : and = fun (x y:bool) => match x with true => y | false => false end.
Proof.
    unfold and. unfold BoolRec. reflexivity.
Qed.

Definition or : bool -> bool -> bool :=
    fun (x:bool) =>
        fun (y:bool) => (BoolRec
            (fun _ => bool)
            true
            y) x.

(* or is computationally equal to ....                                        *)
Definition L14 : or = fun (x y:bool) => match x with true => true | false => y end.
Proof.
    unfold or. unfold BoolRec. reflexivity.
Qed.

Definition L15 : forall (x y:bool), and x y = true <-> x = true /\ y = true.
Proof.
    intros x y. split; intros H.
    - unfold and in H. unfold BoolRec in H. destruct x.
        + split.
            { reflexivity. }
            { assumption. }
        + inversion H.
    - destruct H as [H1 H2]. rewrite H1. rewrite H2. reflexivity.
Qed.

Print L15.

Definition subst2 (a:Type) (p:a -> Prop) (x y:a) (e:x = y) (px: p x) : p y.
Proof.
   rewrite <- e. assumption.
Qed.

Definition subst1 (a:Type) (p:a -> Prop) (x y:a) (e:x = y) (px: p x) : p y.
Proof.
refine (
    match e with
    | eq_refl _ => px
    end
).
Defined.

Definition subst : forall (a:Type) (p:a -> Prop) (x y:a), x = y -> p x -> p y :=
    fun (a:Type) (p:a -> Prop) (x y:a) (e:x = y) (px:p x) =>
        match e with
        | eq_refl _ => px
        end.

Definition boolFalse : false = true -> False :=
    fun (e:false = true) =>
        subst bool (fun (b:bool) => if b then False else True) false true e I.

Definition contradiction : forall (p:Prop), False -> p :=
    fun (p:Prop) (H:False) => match H with end.

Definition subst2d : forall (a:Type) (p:a -> a -> Prop) (x x' y y':a),
    x = x' -> y = y' -> p x y -> p x' y' :=
    fun (a:Type) (p:a -> a -> Prop) (x x' y y':a) =>
        fun (ex:x = x') (ey:y = y') (pxy:p x y) =>
            match ex with
            | eq_refl _ =>
                match ey with
                | eq_refl _ => pxy
                end
            end.

Definition L16 : forall (x y:bool), and x y = true <-> x = true /\ y = true.
Proof.
    refine (fun (x y:bool) => conj
        (fun (H:and x y = true)       =>
            match x as b return (if b then y else false) = true -> b = true /\ y = true with
            | true  => fun (H1:y = true) => conj (eq_refl true) H1
            | false => fun (H1:false = true) => conj H1 (contradiction _ (boolFalse H1))
            end H)
        (fun (H:x = true /\ y = true) =>
            match H with
            | conj H1 H2 =>
                subst2d bool (fun x y => and x y = true)
                    true x true y (eq_sym H1) (eq_sym H2) (eq_refl true)
            end)
).
Qed.


(**************************************************************************)
(**  Mechanised Framework for Local Interactions & Distributed Algorithms

     T. Balabonski, P. Courtieu, L. Rieg, X. Urbain

     PACTOLE project

     This file is distributed under the terms of the CeCILL-C licence     *)
(**************************************************************************)

(**************************************************************************)
(* Author : Mathis Bouverot-Dupuis (June 2022).

 * This file implements an algorithm to ALIGN all robots on an arbitrary
 * axis, in the plane (R²). The algorithm assumes there are no byzantine robots,
 * and works in a FLEXIBLE and SEMI-SYNCHRONOUS setting.

 * The algorithm is as follows : all robots go towards the 'weber point' of
 * the configuration. The weber point, also called geometric median, is unique
 * if the robots are not aligned, and has the property that moving any robot
 * towards the weber point in a straight line doesn't change the weber point.
 * It thus remains at the same place throughout the whole execution.  *)
(**************************************************************************)

Require Import Bool.
Require Import Arith.Div2.
Require Import Lia Field.
Require Import Rbase Rbasic_fun R_sqrt Rtrigo_def.
Require Import List.
Require Import SetoidList.
Require Import Relations.
Require Import RelationPairs.
Require Import Morphisms.
Require Import Psatz.
Require Import Inverse_Image.
Require Import FunInd.
Require Import FMapFacts.

(* Helping typeclass resolution avoid infinite loops. *)
Typeclasses eauto := (bfs).

(* Pactole basic definitions *)
Require Export Pactole.Setting.
(* Specific to R^2 topology *)
Require Import Pactole.Spaces.R2.
(* Specific to gathering *)
Require Pactole.CaseStudies.Gathering.WithMultiplicity.
Require Import Pactole.CaseStudies.Gathering.Definitions.
(* Specific to multiplicity *)
Require Import Pactole.Observations.MultisetObservation.
(* Specific to flexibility *)
Require Import Pactole.Models.Flexible.
(* Specific to settings with no Byzantine robots *)
Require Import Pactole.Models.NoByzantine.
(* Utility lemmas. *)
Require Import Pactole.CaseStudies.Gathering.InR2.Weber.Utils.
(* Specific to definition and properties of the weber point. *)
Require Import Pactole.CaseStudies.Gathering.InR2.Weber.Weber_point.

(* User defined *)
Import Permutation.
Import Datatypes.

Set Implicit Arguments.
Close Scope R_scope.
Close Scope VectorSpace_scope.

Section Alignment.
Local Existing Instances dist_sum_compat.

(* We assume the existence of a function that calculates a weber point of a collection
 * (even when the weber point is not unique).
 * This is a very strong assumption : such a function may not exist in closed form,
 * and the Weber point can only be approximated. *)
Axiom weber_calc : list R2 -> R2.
Axiom weber_calc_correct : forall ps, Weber ps (weber_calc ps).
(* We also suppose this function doesn't depend on the order of the points.
* This is probably not necessary (we can show that it holds when the points aren't colinear)
* but simplifies the proof a bit. *)
Axiom weber_calc_compat : Proper (PermutationA equiv ==> equiv) weber_calc.
Local Existing Instance weber_calc_compat.

(* The number of robots *)
Variables n : nat.
Hypothesis lt_0n : 0 < n.

(* There are no byzantine robots. *)
Local Instance N : Names := Robots n 0.
Local Instance NoByz : NoByzantine.
Proof using . now split. Qed.

Lemma list_in_length_n0 {A : Type} x (l : list A) : List.In x l -> length l <> 0.
Proof using . intros Hin. induction l as [|y l IH] ; cbn ; auto. Qed.

Lemma byz_impl_false : B -> False.
Proof using .
intros b. assert (Hbyz := In_Bnames b).
apply list_in_length_n0 in Hbyz.
rewrite Bnames_length in Hbyz.
cbn in Hbyz. intuition.
Qed.

(* Use this tactic to solve any goal
 * provided there is a byzantine robot as a hypothesis. *)
Ltac byz_exfalso :=
  match goal with
  | b : ?B |- _ => exfalso ; apply (byz_impl_false b)
  end.

(* Since all robots are good robots, we can define a function
 * from identifiers to good identifiers. *)
Definition unpack_good (id : ident) : G :=
  match id with
  | Good g => g
  | Byz _ => ltac:(byz_exfalso)
  end.

Lemma good_unpack_good id : Good (unpack_good id) == id.
Proof using . unfold unpack_good. destruct_match ; [auto | byz_exfalso]. Qed.

Lemma unpack_good_good g : unpack_good (Good g) = g.
Proof using . reflexivity. Qed.

(* The robots are in the plane (R^2). *)
Local Instance Loc : Location := make_Location R2.
Local Instance LocVS : RealVectorSpace location := R2_VS.
Local Instance LocES : EuclideanSpace location := R2_ES.

(* Refolding typeclass instances *)
Ltac foldR2 :=
  change R2 with location in *;
  change R2_Setoid with location_Setoid in *;
  change state_Setoid with location_Setoid in *;
  change R2_EqDec with location_EqDec in *;
  change state_EqDec with location_EqDec in *;
  change R2_VS with LocVS in *;
  change R2_ES with LocES in *.

(* Robots don't have a state (and thus no memory) apart from their location. *)
Local Instance St : State location := OnlyLocation (fun f => True).
(* Robots choose their destination and also the path they take to this destination. *)
Local Instance RobotC : robot_choice (path location) := {| robot_choice_Setoid := @path_Setoid _ location_Setoid |}.

(* Robots view the other robots' positions up to a similarity. *)
Local Instance FrameC : frame_choice (similarity location) := FrameChoiceSimilarity.
Local Instance UpdateC : update_choice ratio := OnlyFlexible.
Local Instance InactiveC : inactive_choice unit := NoChoiceIna.

(* In a flexible setting, the minimum distance that robots are allowed to move is delta. *)
Variables delta : R.
Hypothesis delta_g0 : (0 < delta)%R.

(* We are in a flexible and semi-synchronous setting (for now). *)
Local Instance UpdateF : update_function (path location) (similarity location) ratio :=
  FlexibleUpdate delta.
(* We are in a semi-synchronous setting : inactive robots don't move. *)
Local Instance InactiveF : inactive_function _.
  refine {| inactive := fun config id _ => config id |}.
Proof using . repeat intro. now subst. Defined.

(* The support of a multiset, but elements are repeated
 * a number of times equal to their multiplicity.
 * This is needed to convert an observation from multiset to list format,
 * so that we can use functions [colinear_dec] and [weber_calc]. *)
Definition multi_support {A} `{EqDec A} (s : multiset A) :=
  List.flat_map (fun '(x, mx) => alls x mx) (elements s).

Local Instance multi_support_compat {A} `{EqDec A} : Proper (equiv ==> PermutationA equiv) (@multi_support A _ _).
Proof using .
intros s s' Hss'. unfold multi_support. f_equiv.
+ intros [x mx] [y my] Hxy. inv Hxy. simpl in H0, H1. now rewrite H0, H1.
+ now apply elements_compat.
Qed.

(* The main algorithm : just move towards the weber point
 * (in a straight line) until all robots are aligned. *)
Definition gatherW_pgm obs : path location :=
  if aligned_dec (multi_support obs)
  (* Don't move (the robot's local frame is always centered on itself, i.e. its position is at the origin). *)
  then local_straight_path origin
  (* Go towards the weber point. *)
  else local_straight_path (weber_calc (multi_support obs)).

Local Instance gatherW_pgm_compat : Proper (equiv ==> equiv) gatherW_pgm.
Proof using .
intros s1 s2 Hs. unfold gatherW_pgm.
repeat destruct_match.
+ reflexivity.
+ rewrite Hs in a. now intuition.
+ rewrite Hs in n0. now intuition.
+ f_equiv. apply weber_unique with (multi_support s1) ; auto.
  - rewrite Hs. now apply weber_calc_correct.
  - now apply weber_calc_correct.
Qed.

Definition gatherW : robogram := {| pgm := gatherW_pgm |}.

Lemma multi_support_add {A : Type} `{EqDec A} s x k : ~ In x s -> k > 0 ->
  PermutationA equiv (multi_support (add x k s)) (alls x k ++ multi_support s).
Proof using .
intros Hin Hk. unfold multi_support.
transitivity (flat_map (fun '(x0, mx) => alls x0 mx) ((x, k) :: elements s)).
+ f_equiv.
  - intros [a ka] [b kb] [H0 H1]. cbn in H0, H1. now rewrite H0, H1.
  - apply elements_add_out ; auto.
+ now cbn -[elements].
Qed.

Lemma multi_support_countA {A : Type} `{eq_dec : EqDec A} s x :
  countA_occ equiv eq_dec x (multi_support s) == s[x].
Proof using .
pattern s. apply MMultisetFacts.ind.
+ intros m m' Hm. f_equiv.
  - apply countA_occ_compat ; autoclass. now rewrite Hm.
  - now rewrite Hm.
+ intros m x' n' Hin Hn IH. rewrite add_spec, multi_support_add, countA_occ_app by auto.
  destruct_match.
  - now rewrite <-e, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
  - now rewrite countA_occ_alls_out, IH, Nat.add_0_l ; auto.
+ now reflexivity.
Qed.

(* This is the main result about multi_support. *)
Lemma multi_support_config config id :
  PermutationA equiv
    (multi_support (obs_from_config config (config id)))
    (config_list config).
Proof using .
cbv -[multi_support config_list equiv make_multiset List.map]. rewrite List.map_id.
apply PermutationA_countA_occ. intros x. rewrite multi_support_countA. now apply make_multiset_spec.
Qed.

Corollary multi_support_map f config id :
  Proper (equiv ==> equiv) (projT1 f) ->
  PermutationA equiv
    (multi_support (obs_from_config (map_config (lift f) config) (lift f (config id))))
    (List.map (projT1 f) (config_list config)).
Proof using .
intros H. destruct f as [f Pf]. cbn -[equiv config_list multi_support].
change (f (config id)) with (map_config f config id).
now rewrite multi_support_config, config_list_map.
Qed.

Lemma lift_update_swap da config1 config2 g target :
  @equiv location _
    (lift (existT precondition (frame_choice_bijection (change_frame da config1 g ⁻¹))
                               (precondition_satisfied_inv da config1 g))
          (update config2
           g (change_frame da config1 g) target (choose_update da config2 g target)))
    (update (map_config (lift (existT precondition (frame_choice_bijection (change_frame da config1 g ⁻¹))
                                      (precondition_satisfied_inv da config1 g)))
                        config2)
            g Similarity.id
            (lift_path (frame_choice_bijection (change_frame da config1 g ⁻¹)) target)
            (choose_update da config2 g target)).
Proof using .
cbn -[inverse dist equiv]. unfold id.
rewrite Similarity.dist_prop, Rmult_1_l.
destruct_match_eq Hle; destruct_match_eq Hle' ; try reflexivity ; [|];
rewrite Rle_bool_true_iff, Rle_bool_false_iff in *;
exfalso; revert_one not; intro Hgoal; apply Hgoal.
- assert (Hzoom := Similarity.zoom_pos (change_frame da config1 g)).
  eapply Rmult_le_reg_l; eauto; []. simpl.
  rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l; trivial; [].
  foldR2. lra.
- assert (Hzoom := Similarity.zoom_pos (change_frame da config1 g ⁻¹)).
  eapply Rmult_le_reg_l; eauto; []. simpl.
  rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l; trivial; [].
  foldR2. generalize (Similarity.zoom_pos (change_frame da config1 g)). lra.
Qed.

(* Simplify the [round] function and express it in the global frame of reference. *)
(* All the proofs below use this simplified version. *)
Lemma round_simplify da config : similarity_da_prop da ->
  exists r : G -> ratio,
  round gatherW da config ==
  fun id => if activate da id then
              if aligned_dec (config_list config) then config id
              else
                let trajectory := straight_path (config id) (weber_calc (config_list config)) in
                update config (unpack_good id) Similarity.id trajectory (r (unpack_good id))
            else config id.
Proof using .
intros Hsim. eexists ?[r]. intros id. unfold round.
destruct_match ; [|reflexivity].
destruct_match ; [|byz_exfalso].
cbn -[inverse equiv lift precondition frame_choice_bijection config_list origin update].
rewrite (lift_update_swap da config _ g).
pose (f := existT precondition
  (change_frame da config g)
  (precondition_satisfied da config g)).
pose (f_inv := existT (fun _ : location -> location => True)
  ((change_frame da config g) ⁻¹)
  (precondition_satisfied_inv da config g)).
pose (obs := obs_from_config (map_config (lift f) config) (lift f (config (Good g)))).
change_LHS (update
  (map_config (lift f_inv) (map_config (lift f) config)) g Similarity.id
  (lift_path
    (frame_choice_bijection (change_frame da config g ⁻¹))
    (gatherW_pgm obs))
  (choose_update da
    (map_config (lift f) config) g (gatherW_pgm obs))).
assert (Proper (equiv ==> equiv) (projT1 f)) as f_compat.
{ unfold f ; cbn -[equiv]. intros x y Hxy ; now rewrite Hxy. }
assert (Halign_loc_glob : aligned (config_list config) <-> aligned (multi_support obs)).
{ unfold obs. rewrite multi_support_map by auto. unfold f. cbn -[config_list]. apply aligned_similarity. }
destruct_match.
(* The robots are aligned. *)
+ unfold gatherW_pgm. destruct_match ; [|intuition].
  cbn -[equiv lift dist mul inverse]. unfold id.
  repeat rewrite mul_origin. destruct_match ; apply Hsim.
(* The robots aren't aligned. *)
+ unfold gatherW_pgm. destruct_match ; [intuition|].
  pose (sim := change_frame da config g). foldR2. fold sim.
  assert (Hweb : weber_calc (multi_support obs) == sim (weber_calc (config_list config))).
  {
    unfold obs. rewrite multi_support_map by auto. unfold f. cbn -[equiv config_list].
    foldR2. fold sim.
    apply weber_unique with (List.map sim (config_list config)).
    - now rewrite <-aligned_similarity.
    - apply weber_similarity, weber_calc_correct.
    - apply weber_calc_correct.
  }
  change location_Setoid with state_Setoid. apply update_compat ; auto.
  - intros r. cbn -[equiv]. rewrite Bijection.retraction_section. reflexivity.
  - intros r. rewrite Hweb.
    pose (w := weber_calc (config_list config)). fold w.
    pose (c := config (Good g)). fold c.
    cbn -[equiv w c opp RealVectorSpace.add mul inverse].
    rewrite sim_mul.
    assert (Hcenter : (sim ⁻¹) 0%VS == c).
    { foldR2. change_LHS (center sim). apply Hsim. }
    assert (Hsim_cancel : forall x, (inverse sim) (sim x) == x).
    { cbn -[equiv]. now setoid_rewrite Bijection.retraction_section. }
    rewrite Hcenter, Hsim_cancel. simplifyR2.
    rewrite 2 RealVectorSpace.add_assoc. f_equiv. now rewrite RealVectorSpace.add_comm.
  - rewrite Hweb.
    instantiate (r := fun g => choose_update da (map_config ?[sim] config) g
      (local_straight_path (?[sim'] (weber_calc (config_list config))))).
    cbn -[equiv config_list]. reflexivity.
Qed.

(* This is the goal (for all demons and configs). *)
Definition eventually_aligned config (d : demon) (r : robogram) :=
  Stream.eventually
    (Stream.forever (Stream.instant (fun c => aligned (config_list c))))
    (execute r d config).

(* If the robots are aligned, they stay aligned. *)
Lemma round_preserves_aligned da config : similarity_da_prop da ->
  aligned (config_list config) -> aligned (config_list (round gatherW da config)).
Proof using .
intros Hsim Halign. assert (round gatherW da config == config) as H.
{ intros id. destruct (round_simplify config Hsim) as [r Hround].
  rewrite Hround. repeat destruct_match ; auto. }
now rewrite H.
Qed.

Lemma aligned_over config (d : demon) :
  Stream.forever (Stream.instant similarity_da_prop) d ->
  aligned (config_list config) ->
  Stream.forever (Stream.instant (fun c => aligned (config_list c))) (execute gatherW d config).
Proof using .
revert config d.
cofix Hind. intros config d Hsim Halign. constructor.
+ cbn -[config_list]. apply Halign.
+ cbn -[config_list]. simple apply Hind ; [apply Hsim |].
  apply round_preserves_aligned ; [apply Hsim | apply Halign].
Qed.

(* This would have been much more pleasant to do with mathcomp's tuples. *)
Lemma config_list_In_combine x x' c c' :
  List.In (x, x') (combine (config_list c) (config_list c')) <->
  exists id, x == c id /\ x' == c' id.
Proof using lt_0n.
assert (g0 : G).
{ change G with (fin n). apply (exist _ 0). lia. }
split.
+ intros Hin. apply (@In_nth (location * location) _ _ (c (Good g0), c' (Good g0))) in Hin.
  destruct Hin as [i [Hi Hi']].
  rewrite combine_nth in Hi' by now repeat rewrite config_list_length. inv Hi'.
  assert (i < n) as Hin.
  {
    eapply Nat.lt_le_trans ; [exact Hi|]. rewrite combine_length.
    repeat rewrite config_list_length. rewrite Nat.min_id. cbn. lia.
  }
  pose (g := exist (fun x => x < n) i Hin).
  change (fin n) with G in *. exists (Good g) ;
  split ; rewrite config_list_spec, map_nth ; f_equiv ; unfold names ;
    rewrite app_nth1, map_nth by (now rewrite map_length, Gnames_length) ;
    f_equiv ; cbn ; change G with (fin n) ; apply nth_enum.
+ intros [[g|b] [Hx Hx']].
  - assert ((x, x') = nth (proj1_sig g) (combine (config_list c) (config_list c')) (c (Good g0), c' (Good g0))) as H.
    {
      rewrite combine_nth by now repeat rewrite config_list_length.
      destruct g as [g Hg].
      repeat rewrite config_list_spec, map_nth. rewrite Hx, Hx'. unfold names.
      repeat rewrite app_nth1, map_nth by now rewrite map_length, Gnames_length.
      repeat f_equal ; cbn ; change G with (fin n) ; erewrite nth_enum ; reflexivity.
    }
    rewrite H. apply nth_In. rewrite combine_length. repeat rewrite config_list_length.
    rewrite Nat.min_id. cbn. destruct g. cbn. lia.
  - exfalso. assert (Hbyz := In_Bnames b). apply list_in_length_n0 in Hbyz. rewrite Bnames_length in Hbyz. auto.
Qed.

(* This measure counts how many robots aren't on the weber point. *)
Definition measure_count config : R :=
  let ps := config_list config in
  (*INR (n - countA_occ equiv R2_EqDec (weber_calc ps) ps).*)
  list_sum (List.map (fun x => if x =?= weber_calc ps then 0%R else 1%R) ps).

(* This measure counts the total distance from the robots to the weber point. *)
Definition measure_dist config : R :=
  let ps := config_list config in
  dist_sum ps (weber_calc ps).

(* This measure is positive, and decreases whenever a robot moves. *)
Definition measure config := (measure_count config + measure_dist config)%R.

Local Instance measure_compat : Proper (equiv ==> equiv) measure.
Proof using .
intros c c' Hc. unfold measure, measure_count, measure_dist.
assert (Rplus_compat : Proper (equiv ==> equiv ==> equiv) Rplus).
{ intros x x' Hx y y' Hy. now rewrite Hx, Hy. }
apply Rplus_compat.
+ apply list_sum_compat, eqlistA_PermutationA. f_equiv ; [| now rewrite Hc].
  intros ? ? H. repeat destruct_match ; rewrite H, Hc in * ; intuition.
+ now rewrite Hc.
Qed.

Lemma measure_nonneg config : (0 <= measure config)%R.
Proof using .
unfold measure. apply Rplus_le_le_0_compat.
+ unfold measure_count. apply list_sum_ge_0. rewrite Forall_map, Forall_forall.
  intros x _. destruct_match ; lra.
+ unfold measure_dist. apply list_sum_ge_0. rewrite Forall_map, Forall_forall.
  intros x _. apply dist_nonneg.
Qed.

(* All the magic is here : when the robots move
 * they go towards the weber point so it is preserved.
 * This still holds in an asynchronous setting.
 * The point calculated by weber_calc thus stays the same during an execution,
 * until the robots are colinear. *)
Lemma round_preserves_weber config da w :
  similarity_da_prop da -> Weber (config_list config) w ->
    Weber (config_list (round gatherW da config)) w.
Proof using lt_0n.
intros Hsim Hweb. apply weber_contract with (config_list config) ; auto.
unfold contract. rewrite Forall2_Forall, Forall_forall by now repeat rewrite config_list_length.
intros [x x']. rewrite config_list_In_combine.
intros [id [Hx Hx']]. destruct (round_simplify config Hsim) as [r Hround].
revert Hx'. rewrite Hround.
repeat destruct_match ; intros Hx' ; rewrite Hx, Hx' ; try apply segment_end.
assert (w == weber_calc (config_list config)) as Hw.
{ apply weber_unique with (config_list config) ; auto. apply weber_calc_correct. }
cbn zeta. rewrite <-Hw. cbn -[dist straight_path]. unfold Datatypes.id.
pose (c := config id). fold c.
destruct_match ; rewrite segment_sym ; apply segment_straight_path.
Qed.

(* If the robots don't end up colinear, then the point calculated by weber_calc doesn't change. *)
Corollary round_preserves_weber_calc config da :
  similarity_da_prop da -> ~aligned (config_list (round gatherW da config)) ->
  weber_calc (config_list (round gatherW da config)) == weber_calc (config_list config).
Proof using lt_0n.
intros Hsim HNalign.
apply weber_unique with (config_list (round gatherW da config)) ; auto.
+ apply round_preserves_weber ; [auto | apply weber_calc_correct].
+ apply weber_calc_correct.
Qed.

Lemma Forall2_le_count_weber config da :
  similarity_da_prop da -> ~aligned (config_list (round gatherW da config)) ->
  Forall2 Rle
    (List.map
      (fun x : R2 => if x =?= weber_calc (config_list (round gatherW da config)) then 0%R else 1%R)
      (config_list (round gatherW da config)))
    (List.map
      (fun x : R2 => if x =?= weber_calc (config_list config) then 0%R else 1%R)
      (config_list config)).
Proof using lt_0n.
intros Hsim RNcol.
assert (Hweb := round_preserves_weber_calc config Hsim RNcol).
rewrite Forall2_Forall, combine_map, Forall_map, Forall_forall by now repeat rewrite map_length, config_list_length.
intros [x' x] Hin. apply config_list_In_combine in Hin. destruct Hin as [id [Hx Hx']].
repeat destruct_match ; try lra. rewrite Hx, Hx', Hweb in *.
assert (H : round gatherW da config id == weber_calc (config_list config)).
{
  destruct (round_simplify config Hsim) as [r Hround].
  rewrite Hround. repeat destruct_match ; auto.
  cbn zeta. rewrite <-e. cbn -[equiv dist mul opp RealVectorSpace.add].
  simplifyR2. now destruct_match.
}
rewrite <-H in e. intuition.
Qed.

Lemma Forall2_le_dist_weber config da :
  similarity_da_prop da -> ~aligned (config_list (round gatherW da config)) ->
  Forall2 Rle
    (List.map
      (dist (weber_calc (config_list (round gatherW da config))))
      (config_list (round gatherW da config)))
    (List.map
      (dist (weber_calc (config_list config)))
      (config_list config)).
Proof using lt_0n.
intros Hsim RNcol.
assert (Hweb := round_preserves_weber_calc config Hsim RNcol).
rewrite Forall2_Forall, combine_map, Forall_map, Forall_forall by now repeat rewrite map_length, config_list_length.
intros [x' x] Hin. apply config_list_In_combine in Hin. destruct Hin as [id [Hx' Hx]].
rewrite Hx, Hx', Hweb. destruct (round_simplify config Hsim) as [r Hround].
rewrite Hround. repeat destruct_match ; try lra.
cbn zeta. pose (w := weber_calc (config_list config)). fold w. rewrite <-Hx.
pose (ri := r (unpack_good id)). fold ri.
cbn -[dist RealVectorSpace.add mul opp w ri]. destruct_match.
+ repeat rewrite norm_dist. rewrite R2_opp_dist, RealVectorSpace.add_assoc.
  rewrite <-(mul_1 (w - x)) at 1. rewrite <-minus_morph, add_morph, norm_mul.
  rewrite <-Rmult_1_l. apply Rmult_le_compat_r ; try apply norm_nonneg.
  unfold Rabs. destruct_match ; generalize (ratio_bounds ri) ; lra.
+ rewrite mul_1, (RealVectorSpace.add_comm w), RealVectorSpace.add_assoc.
  simplifyR2. rewrite dist_same. apply dist_nonneg.
Qed.

(* If a robot moves, either the measure strictly decreases or the robots become colinear. *)
Lemma round_decreases_measure config da :
  similarity_da_prop da ->
  moving gatherW da config <> nil ->
    aligned (config_list (round gatherW da config)) \/
    (measure (round gatherW da config) <= measure config - Rmin delta 1)%R.
Proof using lt_0n.
intros Hsim Hmove.
destruct (aligned_dec (config_list (round gatherW da config))) as [Rcol | RNcol] ; [now left|right].
assert (Hweb := round_preserves_weber_calc config Hsim RNcol).
destruct (not_nil_In Hmove) as [i Hi]. apply moving_spec in Hi.
destruct (round gatherW da config i =?= weber_calc (config_list config)) as [Hreached | HNreached].
(* The robot that moved reached its destination. *)
+ transitivity (measure config - 1)%R ; [|generalize (Rmin_r delta 1%R) ; lra].
  unfold measure, Rminus. rewrite Rplus_assoc, (Rplus_comm _ (-1)%R), <-Rplus_assoc.
  apply Rplus_le_compat.
  - unfold measure_count. apply list_sum_le_eps ; [now apply Forall2_le_count_weber|].
    rewrite combine_map, Exists_map. apply Exists_exists.
    exists (round gatherW da config i, config i).
    split ; [apply config_list_In_combine ; exists i ; intuition |].
    repeat destruct_match ; solve [lra | rewrite Hreached in * ; intuition].
  - unfold measure_dist. apply list_sum_le. now apply Forall2_le_dist_weber.
(* The robots that moved didn't reach its destination. *)
+ transitivity (measure config - delta)%R ; [|generalize (Rmin_l delta 1%R) ; lra].
  unfold measure, Rminus. rewrite Rplus_assoc.
  apply Rplus_le_compat.
  - unfold measure_count. apply list_sum_le. now apply Forall2_le_count_weber.
  - unfold measure_dist. apply list_sum_le_eps ; [now apply Forall2_le_dist_weber|].
    rewrite combine_map, Exists_map. apply Exists_exists.
    exists (round gatherW da config i, config i).
    split ; [apply config_list_In_combine ; exists i ; intuition |].
    rewrite Hweb. destruct (round_simplify config Hsim) as [r Hround].
    rewrite Hround. destruct_match_eq Hact ; [destruct_match_eq Halign|].
    * exfalso. now apply RNcol, round_preserves_aligned.
    * cbn zeta.
      pose (w := weber_calc (config_list config)). foldR2. fold w.
      pose (x := config i). fold x.
      pose (ri := r (unpack_good i)). fold ri.
      cbn -[dist RealVectorSpace.add mul opp w ri]. rewrite Rmult_1_l, mul_1.
      destruct_match_eq Hdelta ; unfold id in * ; rewrite good_unpack_good in * ; fold x in Hdelta.
      --rewrite Rle_bool_true_iff in Hdelta. repeat rewrite norm_dist in *.
        rewrite R2_opp_dist, RealVectorSpace.add_assoc in Hdelta |- *.
        rewrite add_opp, add_origin_l, norm_opp, norm_mul, Rabs_pos_eq in Hdelta by (generalize (ratio_bounds ri) ; lra).
        rewrite <-(mul_1 (w - x)) at 1. rewrite <-minus_morph, add_morph, norm_mul.
        rewrite Rabs_pos_eq ; [|generalize (ratio_bounds ri) ; lra].
        rewrite Rmult_plus_distr_r, Rmult_1_l.
        simpl location in Hdelta |- *.
        apply Rplus_le_compat ; try lra.
        rewrite <-Ropp_mult_distr_l. now apply Ropp_le_contravar.
      --exfalso. apply HNreached. rewrite Hround. destruct_match ; [|intuition].
        cbn -[config_list dist mul opp RealVectorSpace.add].
        rewrite Rmult_1_l, good_unpack_good ; unfold id ; fold x ; fold ri ; foldR2 ; fold w.
        destruct_match ; intuition.
        rewrite mul_1, (RealVectorSpace.add_comm w), RealVectorSpace.add_assoc.
        now simplifyR2.
    * exfalso. apply Hi. rewrite Hround. destruct_match ; intuition.
Qed.

Lemma gathered_aligned ps x :
  (Forall (fun y => y == x) ps) -> aligned ps.
Proof using .
rewrite Forall_forall. intros Hgathered.
unfold aligned. rewrite ForallTriplets_forall.
intros a b c Ha Hb Hc.
apply Hgathered in Ha, Hb, Hc. rewrite Ha, Hb, Hc, add_opp.
apply colinear_origin_r.
Qed.

(* If the robots aren't aligned yet then there exists at least one robot which,
 * if activated, will move.
 * Any robot that isn't on the weber point will do the trick. *)
Lemma one_must_move config : ~aligned (config_list config) ->
  exists i, forall da, similarity_da_prop da -> activate da i = true ->
                       round gatherW da config i =/= config i.
Proof using delta_g0.
intros Nalign.
pose (w := weber_calc (config_list config)).
cut (exists i, config i =/= w).
{
  intros [i Hi]. exists i. intros da Hsim Hact.
  destruct (round_simplify config Hsim) as [r Hround]. rewrite Hround.
  repeat destruct_match ; try intuition. clear Hact.
  cbn -[opp mul RealVectorSpace.add dist config_list equiv complement].
  rewrite Rmult_1_l, mul_1, good_unpack_good ; unfold id ; fold w.
  destruct_match_eq Hdelta.
  + intros H.
    rewrite <-(add_origin_r (config i)) in H at 3 ; apply add_reg_l in H.
    rewrite mul_eq0_iff in H. destruct H as [H1|H2].
    - rewrite H1, mul_0, add_origin_r, dist_same, Rle_bool_true_iff in Hdelta. lra.
    - rewrite R2sub_origin in H2. intuition.
  + rewrite (RealVectorSpace.add_comm w), RealVectorSpace.add_assoc.
    simplifyR2. intuition.
}
assert (List.Exists (fun x => x =/= weber_calc (config_list config)) (config_list config)) as HE.
{
  apply neg_Forall_Exists_neg ; [intros ; apply equiv_dec|].
  revert Nalign. apply contra. apply gathered_aligned.
}
rewrite Exists_exists in HE. destruct HE as [x [Hin Hx]].
apply (@In_InA R2 equiv _) in Hin.
foldR2. change location_Setoid with state_Setoid in *. rewrite config_list_InA in Hin.
destruct Hin as [r Hr]. exists r. now rewrite <-Hr.
Qed.

(* Fairness entails progress. *)
Lemma fair_first_move (d : demon) config :
  Fair d -> Stream.forever (Stream.instant similarity_da_prop) d ->
  ~(aligned (config_list config)) -> FirstMove gatherW d config.
Proof using delta_g0.
intros Hfair Hsim Nalign.
destruct (one_must_move config Nalign) as [id Hmove].
destruct Hfair as [locallyfair Hfair].
specialize (locallyfair id).
revert config Nalign Hmove.
induction locallyfair as [d Hnow | d] ; intros config Nalign Hmove.
* apply MoveNow. apply Hmove in Hnow.
  + rewrite <-(moving_spec gatherW (Stream.hd d) config id) in Hnow.
    intros Habs. now rewrite Habs in Hnow.
  + apply Hsim.
* destruct (moving gatherW (Stream.hd d) config) as [| id' mov] eqn:Hmoving.
  + apply MoveLater ; trivial.
    apply IHlocallyfair.
    - apply Hfair.
    - apply Hsim.
    - apply no_moving_same_config in Hmoving. now rewrite Hmoving.
    - intros da Hda Hactive. apply no_moving_same_config in Hmoving.
      rewrite (Hmoving id).
      apply (round_compat (reflexivity gatherW) (reflexivity da)) in Hmoving.
      rewrite (Hmoving id).
      now apply Hmove.
  + apply MoveNow. rewrite Hmoving. discriminate.
Qed.

(* This is the well founded relation we will perform induction on. *)
Definition lt_config eps c c' :=
  (0 <= measure c <= measure c' - eps)%R.

Local Instance lt_config_compat : Proper (equiv ==> equiv ==> equiv ==> iff) lt_config.
Proof using . intros e e' He c1 c1' Hc1 c2 c2' Hc2. unfold lt_config. now rewrite He, Hc1, Hc2. Qed.

(* We proove this using the well-foundedness of lt on nat. *)
Lemma lt_config_wf eps : (eps > 0)%R -> well_founded (lt_config eps).
Proof using .
intros Heps. unfold well_founded. intros c.
pose (f := fun x : R => Z.to_nat (up (x / eps))).
remember (f (measure c)) as k. generalize dependent c.
pattern k. apply (well_founded_ind lt_wf). clear k.
intros k IH c Hk. apply Acc_intro. intros c' Hc'. apply IH with (f (measure c')) ; auto.
rewrite Hk ; unfold f ; unfold lt_config in Hc'.
rewrite <-Z2Nat.inj_lt.
+ apply Zup_lt. unfold Rdiv. rewrite <-(Rinv_r eps) by lra.
  rewrite <-Rmult_minus_distr_r. apply Rmult_le_compat_r ; intuition.
+ apply up_le_0_compat, Rdiv_le_0_compat ; intuition.
+ apply up_le_0_compat, Rdiv_le_0_compat ; intuition.
  transitivity eps ; intuition.
  apply (Rplus_le_reg_r (- eps)). rewrite Rplus_opp_r. etransitivity ; eauto.
Qed.

(* The proof is essentially a well-founded induction on [measure config].
 * Fairness ensures that the measure must decrease at some point. *)
Theorem weber_correct config : forall d,
  Fair d ->
  Stream.forever (Stream.instant similarity_da_prop) d ->
  eventually_aligned config d gatherW.
Proof using delta_g0 lt_0n.
assert (Hdelta1 : (Rmin delta 1 > 0)%R).
{ unfold Rmin. destruct_match ; lra. }
induction config as [config IH] using (well_founded_ind (lt_config_wf Hdelta1)).
intros d Hfair Hsim.
destruct (aligned_dec (config_list config)) as [align | Nalign] ;
  [now apply Stream.Now, aligned_over|].
induction (fair_first_move config Hfair Hsim Nalign) as [d config Hmove | d config Hmove FM IH_FM] ;
  destruct Hsim as [Hsim_hd Hsim_tl] ; cbn in Hsim_hd ; apply Stream.Later.
+ destruct (round_decreases_measure config Hsim_hd Hmove) as [Ralign | Rmeasure].
  - now apply Stream.Now, aligned_over.
  - apply IH.
    * unfold lt_config. split ; [apply measure_nonneg | apply Rmeasure].
    * apply Hfair.
    * apply Hsim_tl.
+ apply no_moving_same_config in Hmove. cbn -[config_list].
  apply IH_FM.
  - intros c' Hc' d' Hfair' Hsim'. rewrite Hmove in Hc'. apply IH ; auto.
  - apply Hfair.
  - apply Hsim_tl.
  - now rewrite Hmove.
Qed.

End Alignment.